;;;  -*- mode: LISP; Package: CL-USER; Syntax: COMMON-LISP;  Base: 10 -*-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 
;;; Author      : Mike Byrne [with Dan Bothell]
;;; Copyright   : (c)1997-2002 CMU/Rice U./Mike Byrne, All Rights Reserved
;;; Availability: public domain
;;; Address     : Rice University
;;;             : Psychology Department
;;;             : Houston,TX 77251-1892
;;;             : byrne@acm.org
;;; 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 
;;; Filename    : master-process.lisp
;;; Version     : 2.1b7
;;; 
;;; Description : The "master process" for the PM extensions to ACT-R.  This
;;;             : is essentially the scheduler and message handler for the
;;;             : entire system.
;;; 
;;; Bugs        : No known open bugs.
;;;
;;; To do       : 
;;; 
;;; ----- History -----
;;; 01.07.28 mdb
;;;             : Started 2.1/ACT5 work.
;;;             : [x] Remove all the is-interrupt stuff.
;;;             : [x] Needs hooks:  One in NEW-MESSAGE, two in RUN-SCHED-QUEUE:
;;;             :     one before events, one after.
;;; 01.07.29 mdb
;;;             : [x] Needs Dan's scheduler.
;;;             : [x] Fix NEXT-STOP-TIME to not reference is-interrupt.
;;; 01.09.17 mdb
;;;             : [x] Fixed RUN-MASTER-PROCESS to hanlde the silent event case.
;;; 01.09.21 mdb [b2]
;;;             : * Added PRINT-OBJECT functions for queue entries.
;;;             : [x] Fixed RUN-MASTER-PROCESS to only run for the specified 
;;;             :   time.
;;;             : [x] Needs a new stepper, basic one implemented.
;;; 02.03.08 mdb [b5]
;;;             : Added SCHEDULE-POST-MODULE to support deferred happening
;;;             : of PM-PROC-DISPLAY.
;;; 2002.05.17 mdb [b6]
;;;             : A couple small changes to the stepper.
;;; 2002.05.23 mdb
;;;             : Backquoted various macros.
;;; 2002.06.05 mdb
;;;             : Incorporated Dan's addition of priorities, which is
;;;             : ;;; 02.05.30 Dan  :
;;;             : Added a priority to the queue-entry class and modified 
;;;             : the associated methods to handle it.  Events with equal times
;;;             : are placed before those with equal or lesser priority.  That
;;;             : preserves the old system that always put a new event before
;;;             : existing events with the same time.  The default priority
;;;             : is 0.
;;;             : I also forced the rounding of the event times in queue-insert
;;;             : because without it there was still possible problems with
;;;             : ordering.
;;; 2002.06.05 mdb
;;;             : Added STEP-HOOK slot to support the environment.
;;; 02.06.09 mdb [b7]
;;;             : Set TRACE-MODULES initform to T.
;;; 02.06.21 Dan
;;;             : Changed the #+:mcl to better work with openmcl.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

#+(and :mcl (not :openmcl)) (require 'quickdraw)

(defvar *mp* nil "Global for the Master Process")
(defvar *debug* nil "Print extra debugging messages?")


;;; QUEUE-ENTRY      [Class]
;;; Date        : 97.01.15
;;; Description : Base class for entries in queues, time tag and a target
;;;             : Module

(defclass queue-entry ()
  ((time :accessor time-tag :initarg :time-tag :initform nil)
   (destination :accessor destination :initarg :destination :initform nil)
   (priority :accessor priority :initarg :priority :initform 0)))


(defmethod print-object ((self queue-entry) stream)
  (print-unreadable-object (self stream :type t)
    (format stream "~5,3F ~A" (time-tag self) (destination self))))

;;; INPUT-QUEUE-ENTRY      [Class]
;;; Date        : 97.01.15
;;; Description : Additional slot for parameters--the meat of an input
;;;             : queue entry.

(defclass input-queue-entry (queue-entry)
  ((parameters :accessor params :initarg :params :initform nil)
   (act-cmd-p :accessor act-cmd-p :initarg :act-p :initform nil)))

(defmethod print-object ((self input-queue-entry) stream)
  (print-unreadable-object (self stream :type t)
    (format stream "~5,3F ~A ~A" (time-tag self) (destination self)
            (first (params self)))))

;;;; ---------------------------------------------------------------------- ;;;;
;;;;
;;;; The Master Process
;;;;
;;;; ---------------------------------------------------------------------- ;;;;

;;; MASTER-PROCESS      [Class]
;;; Description : The Master Process class itself, with slots for a clock,
;;;             : a schedule queue, and each of the individual Modules.

(defclass master-process ()
  ((schedule-queue :accessor sched-q  :initarg sched-q :initform nil)
   (clock :reader mp-time :writer clock :initarg :clock :initform 0.0)
   (is-slave :accessor slave-p :initarg :slave-p :initform nil)
   (trace-modules :accessor trace-modules :initarg :trace-mod :initform t)
   (randomize-time :accessor randomize-time :initarg :rand-time :initform nil)
   (param-lis :accessor param-lis :initarg :param-lst :initform nil)
   (auto-dequeue-p :accessor auto-dequeue-p :initarg :auto-dequeue-p
                   :initform nil)
   (saved-hook-fct :accessor saved-hook-fct :initarg :saved-hook-fct
                   :initform nil)
   (real-time-p :accessor real-time-p :initarg :real-time-p :initform nil)
   (output-queue :accessor output-q :initarg output-q :initform nil)  
   (sim-start-real :accessor sim-start-real :initarg :sim-start-real 
                   :initform 0)
   (start-time :accessor start-time :initform 0.0)
   (version-string :accessor version-string :initarg :version-string
                   :initform "2.1b7")
   (module-lst :accessor module-lst :initarg :module-lst :initform nil)
   (enqueue-hook :accessor enqueue-hook :initarg :enqueue-hook :initform nil)
   (pre-event-hook :accessor pre-event-hook :initarg :pre-event-hook 
                   :initform nil)
   (post-event-hook :accessor post-event-hook :initarg :post-event-hook 
                    :initform nil)
   (stepper-menu-p :accessor stepper-menu-p :initarg :stepper-menu-p 
                   :initform t)
   (step-hook :accessor step-hook :initarg :step-hook :initform nil)
   ))


(defmethod initialize-instance :after ((mstr-proc master-process) &key)
  (pm-install-module mstr-proc (make-instance 'device-interface))
  (pm-install-module mstr-proc (make-instance 'vision-module))
  (pm-install-module mstr-proc (make-instance 'motor-module))
  (pm-install-module mstr-proc (make-instance 'speech-module))
  (pm-install-module mstr-proc (make-instance 'audio-module))
  (pm-install-module mstr-proc (make-instance 'cognition-module))
  (setf (param-lis mstr-proc) (build-param-list))
  )

(defmethod vis-m ((mp master-process))
  (rest (assoc :VISION (module-lst mp))))

(defmethod motor-m ((mp master-process))
  (rest (assoc :MOTOR (module-lst mp))))

(defmethod audio-m ((mp master-process))
  (rest (assoc :AUDIO (module-lst mp))))

(defmethod speech-m ((mp master-process))
  (rest (assoc :SPEECH (module-lst mp))))

(defmethod cog-m ((mp master-process))
  (rest (assoc :COGNITION (module-lst mp))))

(defmethod dev-i ((mp master-process))
  (rest (assoc :DEVICE (module-lst mp))))

(defmethod device-interface ((mp master-process))
  (rest (assoc :DEVICE (module-lst mp))))

(defmacro vision-mod ()
  `(vis-m *mp*))

(defmacro motor-mod ()
  `(motor-m *mp*))

(defmacro speech-mod ()
  `(speech-m *mp*))

(defmacro audio-mod ()
  `(audio-m *mp*))

(defmacro cog-mod ()
  `(cog-m *mp*))

(defmacro dev-intf ()
  `(dev-i *mp*))


;;; RUN-MASTER-PROCESS      [Method]
;;; Date        : 97.01.27, rewritten for b4 on 98.07.15
;;; Description : Top-level runner for the Master Process, built because the
;;;             : full-slave version generates stack overflow [duh].
;;;             : 
;;;             : [1] Set up time bookkeeping.
;;;             : [2] Compute the run time.
;;;             : [3] Run the production system
;;;             : [4] Update everything
;;;             : [5] Determine next action based on state of the production
;;;             :     system. 

(defgeneric run-master-process (mstr-proc duration)
  (:documentation "Run a Master Process for <duration> seconds."))

(defmethod run-master-process ((mstr-proc master-process) duration)
  "Run a Master Process duration seconds."
  (setf (sim-start-real mstr-proc) (get-internal-real-time))
  (setf (start-time mstr-proc) (mp-time mstr-proc))
  (let ((current-time (mp-time mstr-proc))
        (finish-time (ms-round (+ duration (mp-time mstr-proc))))
        (cog-mod (cog-m mstr-proc))
        )
    (while (< (mp-time mstr-proc) finish-time)
      (let ((ps-status (ps-state cog-mod)))
        (cond     
         ;; pending execution--a production has matched and the RHS has been
         ;; scheduled, so there's guranteed to be a next event
         ((eq ps-status :PENDING-EXECUTION) 
          (setf current-time (min finish-time (next-stop-time mstr-proc)))
          (do-update mstr-proc current-time :real-wait t))
         
         ;; If there's no goal in focus, ACT won't ever do anything.  Bail.
         ((eq ps-status :NO-GOAL)
          (pm-output nil 
                     "* Production system halted because GOAL is cleared.")
          (maybe-dequeue-events mstr-proc finish-time)
          (return-from run-master-process
            (values (elapsed-time mstr-proc) current-time)))
         ;; If no production matched and there are pending events, then
         ;; just keep waiting until the next event.
         ((and (eq ps-status :FAILED-SELECTION)
               (sched-q mstr-proc))
          (setf (ps-state cog-mod) :IDLE)
          (setf current-time (min finish-time
                                  (stop-time mstr-proc finish-time)))
          (do-update mstr-proc current-time :real-wait t))
         ;; If no production matched and there are no pending events, either
         ;; nothing will ever happen and we're done, or there are silent 
         ;; events and we should keep trying.
         ((eq ps-status :FAILED-SELECTION)
          (if (no-silent-events mstr-proc)
            ;; no silent events: nothing will happen, bail out
            (progn 
              (setf (ps-state cog-mod) :IDLE)
              (pm-output nil 
                         "* Nothing to run:  No productions, no events.")
              (return-from run-master-process
                (values (elapsed-time mstr-proc) current-time))
              )
            ;; silent events--try another cognition cycle.
            (progn
              (queue-command :time (min-run-time mstr-proc) :where :COGNITION
                             :command 'select-production
                             :params (list 1))
              (do-update mstr-proc current-time :real-wait t))
            ))        
         ;; This state means a production cycle has completed, so it's time
         ;; to schedule another cycle.
         ((eq ps-status :IDLE) 
          ;(schedule-ps current-time finish-time)
          (queue-command :time 0 :where :COGNITION
                         :command 'select-production
                         :params (list 1))
          (do-update mstr-proc current-time :real-wait t))
         ;; fail!
         (t (error 
             "Unhandled state--email byrne@acm.org or db30@andrew.cmu.edu!")))
        ))
    (values (elapsed-time mstr-proc) current-time)))



;;; DO-UPDATE      [Method]
;;; Description : Whenever the time changes, the MP has several things that
;;;             : have to be updated.  The device needs to be updated, the
;;;             : schedule queue run, the various modules updated, and the
;;;             : global clock set.  Also, if running in "real time" mode,
;;;             : wait for RT to "catch up." Finally, update the global clock.


(defgeneric do-update (mstr-proc current-time &key real-wait)
  (:documentation "Update a Master Process to the current time (in seconds). If <real-wait> is T, spin to wait for 'real time' to catch up."))

(defmethod do-update ((mstr-proc master-process) current-time &key 
                        (real-wait nil))
  (update-device (device-interface mstr-proc) current-time)
  (run-sched-queue mstr-proc current-time)
  (update-modules mstr-proc)
  (set-clock mstr-proc current-time)
  (when (and real-wait (real-time-p mstr-proc))
    (maybe-wait (sim-start-real mstr-proc) (elapsed-time mstr-proc))))


;;; NEXT-STOP-TIME      [Method]
;;; Description : Since there isn't really anything to be interrupted, this
;;;             : just grabs the time off the first queue entry.

(defgeneric next-stop-time (mstr-proc)
  (:documentation "Returns the time of the next schedule queue entry that is an interruper."))

(defmethod next-stop-time ((mstr-proc master-process))
  (when (sched-q mstr-proc)
    (ms-round (time-tag (first (sched-q mstr-proc))))))

#|
    (dolist (entry (sched-q mstr-proc) nil)
      (when (interrupt-p entry mstr-proc)
        (return-from next-stop-time (ms-round (time-tag entry)))))))
|#



;;; MAYBE-DEQUEUE-EVENTS      [Method]
;;; Date        : 97.10.28
;;; Description : There's a little problem when the PS halts:  final
;;;             : events don't get dequeued.  This should solve that 
;;;             : problem, either with prompt or automagically.

(defgeneric maybe-dequeue-events (mstr-proc stop-time)
  (:documentation "When the goal stack is empty, either dequeue events or ask to dequeue events."))

(defmethod maybe-dequeue-events ((mstr-proc master-process) stop-time)
  (when (sched-q mstr-proc)
    (if (auto-dequeue-p mstr-proc)
      (run-sched-queue mstr-proc stop-time)
      (let (the-char)
        (old-pm-output "There are queued events.  Dequeue them?  [y/n]  ")
        (setf the-char (read-char))
        (when (or (eq the-char #\y) (eq the-char #\Y))
          (run-sched-queue mstr-proc stop-time))))))


(defgeneric elapsed-time (mstr-proc)
  (:documentation "Return the time (in seconds) since the MP was started."))3

(defmethod elapsed-time ((mstr-proc master-process))
  (ms-round (- (mp-time mstr-proc) (start-time mstr-proc))))


(defgeneric stop-time (mstr-proc finish-time)
  (:documentation "Return the next time the MP will stop, or <finish-time>, whichever is first."))

(defmethod stop-time ((mstr-proc master-process) finish-time)
  (aif (next-stop-time mstr-proc)
    it
    finish-time))


;;; RUN-PS      [Method]
;;; Date        : 98.06.30
;;; Description : Given the MP and a duration, run the underlying production
;;;             : system.  This method should return two values:  the actual
;;;             : time run, and the state of the production system, one of:
;;;             : :HALTED if the PS has stopped
;;;             : :WAITING if the PS is doing nothing
;;;             : :RUNNING if the PS is doing something

(defgeneric run-ps (mstr-proc duration)
  (:documentation "Run the Master Process for <duration> seconds."))

(defmethod run-ps ((mstr-proc master-process) duration)
  (declare (ignore duration))
  (error "No method defined for RUN-PS."))


;;; MIN-RUN-TIME      [Method]
;;; Date        : 98.06.30
;;; Description : Return the minimum cycle time for a production, in 
;;;             : seconds.

(defgeneric min-run-time (mstr-proc)
  (:documentation "PS-specific method which returns the minimum cycle time for a production, in seconds."))

(defmethod min-run-time ((mstr-proc master-process))
  (error "No method defined for MIN-RUN-TIME."))


;;; STEP-RPM-MTH      [Method]
;;; Date        : 97.04.16
;;; Description : New debugging tool, the stepper.  Crappy UI, I know, but
;;;             : it's a debugging tool, eh.  Anyway, dispatches commands
;;;             : based on user choice.
;;;             : [97.04.18] Added WHYNOT and SDM functionality.

(defgeneric step-rpm-mth (mstr-proc)
  (:documentation "Runs the MP in 'interactive' mode."))

(defmethod step-rpm-mth ((mstr-proc master-process))  
  (let ((old-trace (trace-modules mstr-proc))
        (*verbose* t)
        (done nil))
    (setf (trace-modules mstr-proc) t)
    (while (not done)
      (terpri)
      (pm-output nil "** Schedule queue contains:")
      (print-sched-queue mstr-proc)
      (terpri)
      (when (stepper-menu-p mstr-proc)
        (old-pm-output "** Commands are:" (mp-time mstr-proc))
        (old-pm-output "[A]bort (or [q]uit)")
        (old-pm-output "[C]ommand menu printing toggle")
        (old-pm-output "[D]equeue current events only")
        (old-pm-output "[I]con:  Print the visicon")
        (old-pm-output "[M]odule state")
        (old-pm-output "[P]rint a module's input queue")
        (old-pm-output "[R]un: dequeue current events and advance clock")
        (old-pm-output "[S]earch declarative memory")
        (old-pm-output "[W]hnot (also [Y])"))
      (old-pm-output "Command: ")
      (case (read-char)
        ((#\A #\a #\q #\Q) (setf done t))
        ((#\C #\c) (setf (stepper-menu-p mstr-proc) 
                         (not (stepper-menu-p mstr-proc))))
        ((#\D #\d) (let ((*debug* t)) 
                     (do-update mstr-proc (mp-time mstr-proc))))
        ((#\I #\i) (pm-print-icon))
        ((#\M #\m) (progn
                     (old-pm-output "Module keyword: ")
                     (pm-print-module-state (read))))
        ((#\P #\p) (progn
                      (old-pm-output "Module keyword: ")
                      (pm-print-input-q (read))))
        ((#\R #\r #\space) (single-step mstr-proc))
        ((#\w #\W #\y #\Y) (progn
                             (old-pm-output "Production name(s): ")
                             (whynot-fct (mklist (read)))))
        ((#\s #\S) (progn
                     (old-pm-output "Specification (must be a list): ")
                     (sdm-fct (read))))
        (otherwise (old-pm-output "Unknown command")))
      (when (and (eq (ps-state (cog-m mstr-proc)) :NO-GOAL)
                 (null (sched-q mstr-proc)))
        (pm-warning " No goal, the production system has halted!")
        (setf done t))
      )
    (setf (trace-modules mstr-proc) old-trace))
  (mp-time mstr-proc))


;;; SINGLE-STEP      [Method]
;;; Date        : 98.07.07
;;; Description : New single-step method to run the MP for one "step."
;;;             : A step is either until the next stopping event or the 
;;;             : minimum run time if there are no stopping events.
;;;             : The clock will then need an update, and print 
;;;             : notes about the state of the production system.

(defgeneric single-step (mstr-proc)
  (:documentation  "Run the MP for one 'step' of time.  For use by the stepper."))

(defmethod single-step ((mp master-process))
  (do-update mp (mp-time mp))
  (when (or (eq (ps-state (cog-m mp)) :IDLE)
            (eq (ps-state (cog-m mp)) :FAILED-SELECTION))
    (select-production (cog-m mp) 1)
    (when (eq (ps-state (cog-m mp)) :FAILED-SELECTION)
      (old-pm-output "Production system is spinning."))
    )
  (set-clock mp (aif (next-stop-time mp)
                  it
                  (+ (mp-time mp) (min-run-time mp)))))


;;; RUN-SCHED-QUEUE      [Method]
;;; Description : Factored out code for running the schedule queue.
;;;             : Changed with b6 to handle device architecture.

(defgeneric run-sched-queue (mstr-proc stop-time)
  (:documentation "Runs the schedule queue up to the supplied stop time."))

(defmethod run-sched-queue ((mstr-proc master-process) stop-time)
  (when *debug* (check-queue-integ (sched-q mstr-proc)))
  (while (and (sched-q mstr-proc)
              (>= (ms-round stop-time)
                  (ms-round (time-tag (first (sched-q mstr-proc))))))
    (let ((next-entry (pop (sched-q mstr-proc))))
      (set-clock mstr-proc (time-tag next-entry))
      (when (functionp (pre-event-hook mstr-proc))
        (funcall (pre-event-hook mstr-proc) next-entry))
      (case (destination next-entry)
        (:EXTERNAL 
         (apply (first (params next-entry)) (rest (params next-entry))))
        (:DEVICE
         (run-events (device-interface mstr-proc) (mp-time mstr-proc)))
        (otherwise
         (run-module (key->mgr mstr-proc (destination next-entry))
                     (mp-time mstr-proc))))
      (when (functionp (post-event-hook mstr-proc))
        (funcall (post-event-hook mstr-proc) next-entry)))))


;;; NEW-MESSAGE      [Method]
;;; Date        : 97.01.15
;;; Description : When a new message is sent, check to see if there is a
;;;             : matching schedule entry.  If not, create and insert one.
;;;             : Then pass the message along to the appropriate module.

(defgeneric new-message (mstr-proc entry)
  (:documentation "Sends a message (a queue entry) to the MP, which will then route it appropriately."))

(defmethod new-message ((mstr-proc master-process) (entry queue-entry))
  (setf (time-tag entry) (+ (mp-time mstr-proc) (time-tag entry)))
  (when (not (member entry (sched-q mstr-proc) :test #'sched=))
    (when (functionp (enqueue-hook mstr-proc))
      (funcall (enqueue-hook mstr-proc) entry))
    (setf (sched-q mstr-proc)
          (queue-insert (make-instance 'queue-entry :time-tag (time-tag entry)
                          :priority (priority entry)
                          :destination (destination entry))
                        (sched-q mstr-proc))))
  (new-message (key->mgr mstr-proc (destination entry)) entry))


;;; MESSAGE-MODULE      [Method]
;;; Date        : 97.01.15
;;; Description : Send a message (input queue entry) to the appropriate 
;;;             : module.

(defgeneric message-module (mstr-proc entry)
  (:documentation  "Passes a message from the MP to a specific module"))
 
(defmethod message-module ((mstr-proc master-process) (entry queue-entry))
  (new-message (key->mgr mstr-proc (destination entry)) entry))



;;; PRINT-SCHED-QUEUE      [Method]
;;; Date        : 97.01.21

(defgeneric print-sched-queue (mstr-proc)
  (:documentation "Prints out all the entries in the MP's schedule queue."))

(defmethod print-sched-queue ((mstr-proc master-process))
  (dolist (entry (sched-q mstr-proc))
    (print-entry entry)))


;;; RESET-MP      [Method]
;;; Description : Resets a Master Process clock and all the associated
;;;             : modules and the device.

(defgeneric reset-mp (mstr-proc)
  (:documentation "Reset a Master Process to the initial, empty state."))
 
(defmethod reset-mp ((mstr-proc master-process))
  (set-clock mstr-proc 0.0)
  (map-modules *mp* #'reset-module)
  (restore-parameters mstr-proc)
  (setf (sched-q mstr-proc) nil)
  (setf (output-q mstr-proc) nil))


(defgeneric update-modules (mstr-proc)
  (:documentation "Update each one of the modules."))

(defmethod update-modules ((mstr-proc master-process))
  (map-modules mstr-proc #'update-module))


;;; MAP-MODULES      [Method]
;;; Date        : 98.05.28
;;; Description : Utility method.

(defgeneric map-modules (mstr-proc func)
  (:documentation "Map a function on all the PM modules."))
 
(defmethod map-modules ((mp master-process) (func function))
  (mapcar func (mapcar #'rest (module-lst mp))))
                        


(defgeneric print-mod-state-mth (mstr-proc module-keyword)
  (:documentation  "Print the state of the specified module."))
 
(defmethod print-mod-state-mth ((mstr-proc master-process) mod)
  (print-module-state (key->mgr mstr-proc mod)))


(defgeneric no-silent-events (mstr-proc)
  (:documentation  "Returns T if there are any silent events in the MP."))
 
(defmethod no-silent-events ((mstr-proc master-process))
  (pm-output nil "Checking for silent events.")
  (not (remove nil (map-modules mstr-proc #'silent-events))))


;;;; ---------------------------------------------------------------------- ;;;;
;;;; Queue entries
;;;; ---------------------------------------------------------------------- ;;;;



;;; SCHED=      [Method]
;;; Date        : 97.01.15
;;; Description : Given two queue entries, determines if they are equal
;;;             : [at the time and Module levels only].

(defgeneric sched= (entry1 entry2)
  (:documentation "Are two queue entries equal in time and destination?"))

(defmethod sched= ((e1 queue-entry) (e2 queue-entry))
  (and (= (time-tag e1) (time-tag e2))
       (eql (destination e1) (destination e2))))
;(eql (is-interrupt e1) (is-interrupt e2))))


;;; QUEUE-INSERT      [Method]
;;; Date        : 97.01.15

(defgeneric queue-insert (entry queue)
  (:documentation  "Insert a queue entry into a queue."))
 
(defmethod queue-insert ((entry queue-entry) (queue list))
  (setf (time-tag entry) (ms-round (time-tag entry)))
  (if (null queue)
    (push entry queue)
    (progn
      (let ((pos 0))
        (while (and (nth pos queue) 
                    (or (> (time-tag entry) (time-tag (nth pos queue)))
                        (and 
                         (= (time-tag entry) (time-tag (nth pos queue)))
                         (<= (priority entry) (priority (nth pos queue))))) )
          (incf pos))
        (splice-into-list-des queue pos entry)))))


;;; PRINT-ENTRY      [Generic Function]
;;; Date        : 01.04.16
;;; Description : Differnt kinds of queue entries have slightly different
;;;             : print functions.

(defgeneric print-entry (entry)
  (:documentation   "Prints out a queue entry."))

(defmethod print-entry ((self queue-entry))
  (old-pm-output "Destination: ~S   Time: ~,3F" (destination self) 
             (time-tag self)))

(defmethod print-entry ((self input-queue-entry))
  (old-pm-output "Time: ~,3F Params: ~S" (time-tag self) (params self)))


;;; SCHEDULE-POST-MODULE      [Method]
;;; Date        : 02.03.08
;;; Description : Puts an entry in after a specified module next runs

(defgeneric schedule-post-module (mp module &key where command params)
  (:documentation   "Schedule an event to run after the next time the specified
module runs.  Does nothing if the specified module is not scheduled."))


(defmethod schedule-post-module ((mp master-process) module &key where 
                                command (params nil) (priority 0))
  (let ((event (first (member module (sched-q mp) :key 'destination))))
    (when event
      (if (eq where :EXTERNAL)
        (setf (sched-q mp)
              (queue-insert (make-instance 'input-queue-entry
                              :time-tag (time-tag event)
                              :priority priority
                              :destination :EXTERNAL
                              :params (cons command (mklist params)))
                            (sched-q mp)))
        (new-message mp
                     (make-instance 'input-queue-entry
                       :destination where
                       :act-p nil
                       :params (cons command (mklist params))
                       :time-tag (- (time-tag event) (mp-time mp))
                       :priority priority))))))

;;;; ---------------------------------------------------------------------- ;;;;
;;;;  Parameter setting stuff


;;; SET-PM-PARAMS-MTH      [Method]
;;; Date        : 97.03.07
;;; Description : Set the value of one or more PM parameters.  Parameters are
;;;             : stored in an assoc-list of the form (name param-obj).  Thus,
;;;             : if ASSOC finds it in the list, we can try to set it.

(defgeneric set-pm-params-mth (mstr-proc param-lst)
  (:documentation  "Sets the value of one or more global PM params."))

(defmethod set-pm-params-mth ((mstr-proc master-process) (params list))
  (let ((param-name nil)
        (value nil)
        (param-obj nil)
        (accum nil))
    (while params
      (setf param-name (pop params))
      (setf value (eval (pop params)))
      (setf param-obj (second (assoc param-name (param-lis mstr-proc))))
      (if (null param-obj)
        (pm-warning "~S is an unrecognized PM parameter." param-name)
        (when (set-param param-obj value)
          (push value accum))))
    (nreverse accum)))


;;; SHOW-PM-PARAMS-MTH      [Method]
;;; Date        : 97.03.07
;;; Description : Basically, the same idea as SET-PM-PARAMS-MTH, but prints
;;;             : instead of sets.

(defgeneric show-pm-params-mth (mstr-proc param-lst)
  (:documentation  "Set the value of one or more PM parameters."))

(defmethod show-pm-params-mth ((mstr-proc master-process) (params list))
  (if (null params)
    (dolist (the-param (param-lis mstr-proc))
      (print-param (second the-param)))
    (let ((param-name nil)
          (param-obj nil))
      (while params
        (setf param-name (pop params))
        (setf param-obj (second (assoc param-name (param-lis mstr-proc))))
        (if (null param-obj)
          (pm-warning "~S is an unrecognized PM parameter." param-name)
          (print-param param-obj))))))


(defgeneric key->mgr (mstr-proc module-keyword)
  (:documentation  "Return the module associated with a given keyword."))

(defmethod key->mgr ((mp master-process) (module-keyword symbol))
  (aif (assoc module-keyword (module-lst mp))
    (rest it)
    (error "No module named ~S" module-keyword)))


(defgeneric set-clock (mstr-proc time)
  (:documentation "Set the MP's clock to <time>."))

(defmethod set-clock ((mstr-proc master-process) time)
  (setf time (ms-round time))
  (clock time mstr-proc)
  (setf *time* time))


(defgeneric restore-parameters (mstr-proc)
  (:documentation  "Restore all the PM global parameters to their defaults."))

(defmethod restore-parameters ((mstr-proc master-process))
  (dolist (param (param-lis mstr-proc))
    (restore-default (second param))))



;;;; ---------------------------------------------------------------------- ;;;;
;;;; Misc utilities
;;;;

;;; SPLICE-INTO-LIST      [Function]
;;; Date        : 97.01.15
;;; Description : 

(defun splice-into-list (lis position item)
  (let ((temp (copy-list lis)))
    (splice-into-list-des temp position item)))
      
    
;;; SPLICE-INTO-LIST-DES      [Function]
;;; Date        : 97.01.15
;;; Description : 

(defun splice-into-list-des (lis position item)
  (if (= position 0)
    (push item lis)
    (if (listp item)
       (append (subseq lis 0 position) item (nthcdr position lis))   
      (append (subseq lis 0 position) (list item) (nthcdr position lis)))))


;;; CHECK-QUEUE-INTEG      [Function]
;;; Date        : 97.04.02
;;; Description : Ensures the integrity of a schedule queue.

(defun check-queue-integ (q-lis)
  "Checks the time integrity of a queue"
  (let ((last 0))
    (when
      (dolist (entry q-lis nil)
        (if (< (time-tag entry) last)
          (return entry)
          (setf last (time-tag entry))))
      (error "Queue integrity violation!"))))


;;;; ---------------------------------------------------------------------- ;;;;
;;;; ACT-R stuff
;;;;

;;; SEND-RPM-COMMAND      [Function]
;;; Date        : 97.01.24
;;; Description : Called by ACT-R to send commands to various processors.

(defun send-rpm-command (time where command &rest params)
  "Sends a command from the Cognition Layer to somewhere in the PM Layer"
  (declare (ignore time))
  (new-message *mp*
               (make-instance 'input-queue-entry
                 :time-tag 0
                 :destination where
                 :act-p t
                 :params (cons command params))))


;;; QUEUE-COMMAND      [Function]
;;; Date        : 98.01.21
;;; Description : More generalized version, used by RPM functions.  Takes
;;;             : all kinds of funky parameters to describe events.

(defun queue-command (&key time where command (params nil) 
                              (sent-by-act nil) (randomize nil))
  "Schedule a command in the MP's schedule queue."
  (new-message *mp*
               (make-instance 'input-queue-entry
                 :time-tag (if randomize (rand-time time) time)
                 :destination where
                 :act-p sent-by-act
                 :params (cons command (mklist params)))))



;;; RAND-TIME      [Function]
;;; Date        : 97.10.27, delta 00.01.21
;;; Description : Return a random number from a uniform distribution between
;;;             : 2/3 of the input and 4/3 of the input.  This is EPIC's
;;;             : randomization method.

(defun rand-time (time)
  "If time randomizing is on, do the EPIC time randomizing thing."
  (if (not (randomize-time *mp*))
    (ms-round time)
    (if (zerop time)
      0.0
      (let ((min (float (* time (/ 2 3))))
            (max (float (* time (/ 4 3)))))
        (ms-round (+ min (random (- max min))))))))



;;; MAYBE-WAIT      [Function]
;;; Date        : 97.11.17
;;; Description : Spin-wait until the amount of real time that has elapsed
;;;             : equals the amount of simulated time that has elapsed.

(defun maybe-wait (real-start sim-elapsed)
  (let ((my-start (get-internal-real-time)))
    (while (< (ms-round (/ (- (get-internal-real-time) real-start) 1000))
              sim-elapsed)
      ())
  (ms-round (- sim-elapsed (/ (- my-start real-start) 1000)))))