;;;  -*- mode: LISP; Package: CL-USER; Syntax: COMMON-LISP;  Base: 10 -*-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Author      : Mike Byrne & 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    : * load-rpm.lisp
;;; Version     : 2.1b4
;;;
;;; Description : File loader for ACT-R/PM system.
;;;
;;; 99.12.21 Dan Bothell
;;;          : Made the loader ACL friendly - it now assumes that the
;;;          :  files are located in the same dir as the load file
;;;	       : Added a feature check to quickdraw.
;;;          : The *file-list depends on which system is running (there should
;;;          :  probably be a neutral list also, but I didn't add it).
;;; 01.04.12 Dan Bothell
;;;          : Changed it to load the ACT-R 5.0 files.
;;;          : Rearranged the order slightly to put the
;;;          :   actr-interface after device-interface
;;;          :   so that process-display could be redefined.
;;;          : Added an ACL specific smart-load that checks
;;;          :   for zero length fasl's to allow updates
;;;          :   for the Windows environment to work safely.
;;; 01.05.31 Dan Bothell
;;;             : Added a default *file-list definition and made the allegro
;;;             : definition version specific (in an effort to make 
R/PM more general).
;;;             : Added a LispWorks smart-loader because it didn't like the
;;;             : pathname handling of the old one.
;;;             : Also removed act-sources from the lists because with 5.0 it's
;;;             : not an issue anymore.
;;; 01.06.15 Dan
;;;             : Added a loader for clisp (man is it super fast
;;;             : it's an order of magnitude faster than MCL or ACL).
;;; 01.09.17 mdb
;;;             : Made some file changes for 2.1b1
;;;
;;; 02.01.15 Dan
;;;             : Changed the file lists to include the right UWI
;;;             : files, changed the allegro feature tests so that
;;;             : it works better for ACL versions other than 5.0.1,
;;;             : and added a warning (at the end) for ACL users that
;;;             : tells them not to use the Modern mode (case sensitive)
;;;             : version of ACL.
;;; 02.02.11 Dan
;;;             : added a new file "uniform-interface-exp.lisp" for 
the UWI experiment interface
;;;             : basically an "easier" interface to the UWI for use 
by tutorial models
;;;             : mostly just hiding of the need to keep a pointer to 
the window
;;;             : around to do things.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


#+:mcl (require 'quickdraw)

(unless (boundp '*.lisp-pathname*)
   (defvar *.lisp-pathname* (make-pathname :type "lisp")))

(unless (boundp '*.fasl-pathname*)
   (defvar *.fasl-pathname* (make-pathname :type "fasl")))


;;; Define the files to be loaded.

;;; start with a generic list

(defparameter *file-list '("actr5" "actr5-pm-compiler-fix"
                              "rpm-utils" "dmi" "rpm-parameters"
                              "master-process" "pm-module"
                              "vision-categorization" "vision-module"
                              "motor-module"
                              "speech-module"
                              "audio-module"
                              "device-interface" "actr-interface"
                              "cognition-module" "virtual-view"
                            "generic-interface"

                            "uniform-interface-virtual"
                            "uniform-interface-exp"
                            "view-line-virtual"
                              "patch-support" "rpm-toplevel" "initialize-rpm"
                              ))


;;; then switch it to specifics if possible

#+:mcl
(defparameter *file-list '("actr5" "actr5-pm-compiler-fix"
                              "rpm-utils" "dmi" "rpm-parameters"
                              "master-process" "pm-module"
                              "vision-categorization" "vision-module"
                              "motor-module"
                              "speech-utils" "speech-module"
                              "audio-module"
                              "device-interface" "actr-interface"
                              "cognition-module" "virtual-view"
                              "mcl-interface"
                              "uniform-interface-virtual" "view-line-virtual"
                            "uniform-interface-mcl"
                            "uniform-interface-exp"
                            "view-line-mcl"
                              "patch-support" "rpm-toplevel" "initialize-rpm"
                              ))

#+(and :ALLEGRO-IDE :allegro-version>= (version>= 5))

(defparameter *file-list '("actr5" "actr5-pm-compiler-fix"
                              "rpm-utils" "dmi" "rpm-parameters"
                              "master-process" "pm-module"
                              "vision-categorization" "vision-module"
                              "motor-module"
                              "speech-module"
                              "audio-module"
                              "device-interface" "actr-interface"
                              "cognition-module" "virtual-view"
                              "acl-interface"
                            "uniform-interface-virtual"
                            "uniform-interface-acl"
                            "uniform-interface-exp"
                            "view-line-virtual"
                              "view-line-acl"
                              "patch-support" "rpm-toplevel" "initialize-rpm"
                              ))


;;; SMART-LOAD      [Function]
;;; Date        : 99.12.21
;;; Description : Loads binary version of a specified file.  Of 
course, the said
;;;             : binary version might not exist or be older than the source
;;;             : version, in which case the source file is compiled before
;;;             : loading.  Note that this will almost surely break 
under non-MCL
;;;             : Lisps.

(defun smart-load (this-files-dir file)
   "Loads binary <file> in directory <this-files-dir> or compiles and 
loads source version"
   (let* ((the-dir (directory-namestring this-files-dir))
          (srcpath (merge-pathnames
                      (make-pathname :directory the-dir :name file)
                      *.lisp-pathname*))
          (binpath (merge-pathnames
                      (make-pathname :directory the-dir :name file)
                      *.fasl-pathname*)))
     (unless (probe-file srcpath)
       (error "File ~S does not exist" srcpath))
     (when (or (not (probe-file binpath))
               (> (file-write-date srcpath) (file-write-date binpath)))
       (compile-file srcpath))
     (load binpath)))

#+:clisp
(defun smart-load (this-files-dir file)
   "Loads binary <file> in directory <this-files-dir> or compiles and 
loads source version"
   (let* ((srcpath (merge-pathnames
                      (make-pathname :name file :type "lisp")
                      this-files-dir))
          (binpath (merge-pathnames
                      (make-pathname :name file :type "fas")
                      this-files-dir)))
     (unless (probe-file srcpath)
       (error "File ~S does not exist" srcpath))
     (when (or (not (probe-file binpath))
               (> (file-write-date srcpath) (file-write-date binpath)))
       (compile-file srcpath))
     (load binpath)))


#+(and :linux :cmu)
(defun smart-load (this-files-dir file)
   "Loads binary <file> in directory <this-files-dir> or compiles and 
loads source version"
   (let* ((srcpath (merge-pathnames
                      (make-pathname :name file :type "lisp")
                      this-files-dir))
          (binpath (merge-pathnames
                      (make-pathname :name file :type "x86f")
                      this-files-dir)))
     (unless (probe-file srcpath)
       (error "File ~S does not exist" srcpath))
     (when (or (not (probe-file binpath))
               (> (file-write-date srcpath) (file-write-date binpath)))
       (compile-file srcpath))
     (load binpath)))

#+:lispworks
(defun smart-load (this-files-dir file)
   "Loads binary <file> in directory <this-files-dir> or compiles and 
loads source version"
   (let* ((srcpath (merge-pathnames
                      (make-pathname :name file :type "lisp")
                      this-files-dir))
          (binpath (merge-pathnames
                      (make-pathname :name file :type "fsl")
                      this-files-dir)))
     (unless (probe-file srcpath)
       (error "File ~S does not exist" srcpath))
     (when (or (not (probe-file binpath))
               (> (file-write-date srcpath) (file-write-date binpath)))
       (compile-file srcpath :output-file binpath))
     (load binpath)))


#+(and :ALLEGRO-IDE :allegro-version>= (version>= 5))
(defun smart-load (this-files-dir file)
   "Loads binary <file> in directory <this-files-dir> or compiles and 
loads source version
    with a test on the fasl length to make patches for windows environment safe"
   (let* ((the-dir (directory-namestring this-files-dir))
          (srcpath (merge-pathnames
                      (make-pathname :directory the-dir :name file)
                      *.lisp-pathname*))
          (binpath (merge-pathnames
                      (make-pathname :directory the-dir :name file)
                      *.fasl-pathname*)))
     (unless (probe-file srcpath)
       (error "File ~S does not exist" srcpath))
     (when (or (not (probe-file binpath))
               (zerop (file-size binpath))
               (> (file-write-date srcpath) (file-write-date binpath)))
       (compile-file srcpath))
     (load binpath)))


(defun load-actrpm (this-file)
     (dolist (the-file *file-list)
       (smart-load this-file the-file)))


;;; If the user isn't using ACL then load things as
;;; normal.

#-:allegro
(let ((*record-source-file* nil))
   (load-actrpm *load-pathname*))

;;; Otherwise first check to see if they are in the
;;; ACL Modern mode, and if so warn them that they
;;; should be using the ANSI version.

#+:allegro
(if (or (and (not (eq :case-sensitive-lower *current-case-mode*))
              (not (eq :case-sensitive-upper *current-case-mode*)))
         (yes-or-no-p "WARNING: you are using a case sensitive Lisp. 
ACT-R will not load and run correctly.  Continue anyway?"))
     (let ((*record-source-file* nil))
       (load-actrpm *load-pathname*))
   (format t "ACT-R 5 was NOT loaded."))



;;;  -*- mode: LISP; Package: CL-USER; Syntax: COMMON-LISP;  Base: 10 -*-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Author      : Dan Bothell (plus code from Tech support at Franz Inc.)
;;; Copyright   : (c)2000 CMU/Dan Bothell, All Rights Reserved
;;; Availability: public domain
;;; Address     : Carnegie Mellon University
;;;             : Psychology Department
;;;             : Pittsburgh,PA 15213-3890
;;;             : db30+@andrew.cmu.edu
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Filename    : acl-interface.lisp
;;; Version     : 2.0b3
;;;
;;; Description : ACL-specific functions for RPM.  This consists primarily
;;;             : of stuff for vision (parsing the screen), and output
;;;             : stuff for motor.
;;;
;;; Bugs        :
;;;
;;; --- History ---
;;; 00.01.25 Dan Bothell
;;;             : First version.
;;;             : function comments copied from mcl-interface.
;;; 00.06.08 mdb
;;;             : Moved POPULATE-LOC-TO-KEY-ARRAY method here.
;;; 00.09.05 Dan
;;;             : Fixed all of the text feature building to correctly
;;;             : use ascent and descent parameters for the font instead of
;;;             : only using the font-height.
;;;             : Made the changes to bring it up to speed with 2.0b3
;;;             : Specifically:
;;;             :    Added a focus ring.
;;;             :    Changed from xy lists to vectors.
;;;             :    Fixed the build-features-for for buttons.
;;;             :    Added the approach-width method for text features
;;;             :    so that if it's on a button it's computed correctly.
;;; 01.04.12 Dan
;;;             : Added a hack to get around the keypad not returning
;;;             :    numbers.
;;;             : Changed the focus ring so that it didn't 'eat' the
;;;             :    the keypresses.
;;; 02.01.15 Dan
;;;             : Added some feature checks to better handle ACL versions
;;;             : other than 5.0.1.  It's still not perfect however because
;;;             : in ACL 6 or newer the focus ring doesn't erase
;;;             : and I haven't figured out how to fix that yet.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defclass rpm-window (dialog)
   ())

(defvar *simulated-key* nil)

(defmethod window-select ((w window))
   (select-window w))

(defmethod device-move-cursor-to ((device window) (xyloc vector))
   (setf (cursor-position device) (make-position (px xyloc) (py xyloc))))

(defmethod device-speak-string ((device window) string)
   (declare (ignore string)))

(defmethod get-mouse-coordinates ((device window))
   (let ((cur-pos (cursor-position device)))
     (vector (position-x cur-pos) (position-y cur-pos))))


(defmethod device-handle-click ((device window))
   (rpm-window-click-event-handler device (list (position-x 
(cursor-position device))
                                                (position-y 
(cursor-position device))))
   (do-click nil :preview-seconds nil :down-seconds .0001))


(defmethod mouse-left-down ((device rpm-window) buttons cur-pos)
   (declare (ignore buttons))
   (unless *actr-enabled-p*
     (when (null cur-pos)
       (setf cur-pos (cursor-position device)))
     (rpm-window-click-event-handler device (list (position-x cur-pos)
                                          (position-y cur-pos)))))

(defmethod rpm-window-click-event-handler ((device window) position)
   (declare (ignore device position)))


(defmethod device-handle-keypress ((device window) key)
   (do-keypress device key :preview-seconds nil :down-seconds nil)
   (unless (subtypep (type-of device) 'rpm-window)
     (rpm-window-key-event-handler device key)))

(defmethod rpm-window-key-event-handler ((device window) key)
   (declare (ignore device position)))

(defmethod do-update :after ((mstr-proc master-process) current-time
                                &key (real-wait nil))
   (declare (ignore current-time real-wait))
   (process-pending-events))

(defmethod virtual-key-down :before ((device rpm-window) buts key)
    (declare (ignore-if-unused device buts key))
   (unless (equal key 16) ;;; if it's the shift key could be problems
     ;;; this is a big hack to get the num-pad 1-9 to return correctly
     ;;; I can't come up with a better way right now, so this is
     ;;; how it's got to be
     (rpm-window-key-event-handler device (case key
                                            (97 #\1)
                                            (98 #\2)
                                            (99 #\3)
                                            (100 #\4)
                                            (101 #\5)
                                            (102 #\6)
                                            (103 #\7)
                                            (104 #\8)
                                            (105 #\9)
                                            (t (code-char key)))))
   t)


(defun loc-avg (x y)
   (declare (fixnum x) (fixnum y))
   (floor (/ (+ x y) 2)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;; 
---------------------------------------------------------------------- 
;;;;;;;
;;;; ACL screen-to-icon interface
;;;; 
---------------------------------------------------------------------- 
;;;;;;;


;;; BUILD-FEATURES-FOR      [Method]
;;; Description : For an ACL window, just walk the sub-objects (which by
;;;             : default are subviews) and build features.

(defmethod build-features-for ((self window) (vis-mod vision-module))
   (let ((base-ls (flatten
                   (mapcar #'(lambda (obj) (build-features-for obj vis-mod))
                           (get-sub-objects self)))))
     (dolist (feat base-ls)
       (fill-default-dimensions feat))
     base-ls))


(defmethod get-sub-objects ((v window))
   "Grabbing the sub-objects of a window by default returns the dialog-items."
   (dialog-items v))


;;; BUILD-FEATURES-FOR      [Method]
;;; Date        : 97.01.27
;;; Description : The basic method for building features, returns an object
;;;             : of the ICON-FEATURE class with the location and ISA fields
;;;             : set.

(defmethod build-features-for ((self dialog-item)
                                   (vis-mgr vision-module))
   "Build an icon feature for the dialog item"

   (make-instance 'icon-feature
     :x (px (view-loc self))
     :y (py (view-loc self))
     :isa 'visual-object
     :value 'unknown
     :screen-obj self))


;;; BUILD-FEATURES-FOR      [Method]
;;; Date        : 97.01.28
;;; Description : Same as for EDIT-BOXes.

(defmethod build-features-for ((self editable-text)
                                   (vis-mod vision-module))
   "Builds an icon feature for an EDITABLE-TEXT-DIALOG-ITEM"
   (let* ((font-spec (nfontmetrics (window self) (make-fontmetrics)))
         (ascent (font-ascent font-spec))
         (descent (font-descent font-spec))
         (text (value self)))
     (cons
      (make-instance 'rect-feature
        :x (px (view-loc self))
        :y (py (view-loc self))
        :screen-obj self)
      (unless (equal text "")
         (build-string-feats vis-mod :text text
                             :start-x (1+ (box-left (box self)))
                             :y-pos (+ (box-top (box self))
                                       descent (round ascent 2))
                             :width-fct #'(lambda (str)
                                            (string-width str self))
                             :height ascent :obj self)))))



;;; BUILD-FEATURES-FOR      [Method]
;;; Date        : 99.04.02, delta 99.07.02
;;; Description : A button dialog item is a lot like a static text item,
;;;             : except there's an oval associated with it and the text
;;;             : is centered both horizontally and vertically.

(defmethod build-features-for ((self button)
                                   (vis-mod vision-module))
   "Builds an icon feature for a BUTTON DIALOG-ITEM"
   (let* ((btn-width (width self))
          (btn-height (height self))
          (text (title self)))

     (cons
      (make-instance 'oval-feature
        :x (px (view-loc self)) :y (py (view-loc self))
        :width btn-width :height btn-height
        :screen-obj self)
      (unless (equal text "")
        (let* ((font-spec (nfontmetrics (window self) (make-fontmetrics)))
               (ascent (font-ascent font-spec))
               (descent (font-descent font-spec))
               (textlines (string-to-lines text))
               (start-y (+ (box-top (box self))
                             (round (- btn-height (* (length textlines)
                                                    (+ ascent descent))) 2)))
               (accum nil)
               (width-fct #'(lambda (str) (string-width str self))))
          (dolist (item textlines (nreverse accum))
            (push
             (build-string-feats vis-mod :text text
                                   :start-x
                                   (+ (box-left (box self))
                                      (round
                                       (- btn-width (funcall width-fct text))
                                       2))
                              :y-pos (+ start-y (round (+ ascent descent) 2))
                                   :width-fct width-fct :height (min 
ascent btn-height)
                                   :obj self)
               accum)
            (incf start-y (+ ascent descent))))))))



;;; BUILD-FEATURES-FOR      [Method]
;;; Date        : 99.04.02
;;; Description : A static text dialog item is really just text, so just
;;;             : build the string features for it.

(defmethod build-features-for ((self static-text)
                                   (vis-mod vision-module))
   (let* ((font-spec (nfontmetrics (window self) (make-fontmetrics)))
         (ascent (font-ascent font-spec))
         (descent (font-descent font-spec))
         (text (value self)))
     (unless (equal text "")
         (build-string-feats vis-mod :text text
                             :start-x (1+ (box-left (box self)))
                             :y-pos (+ (box-top (box self))
                                       descent (round ascent 2))
                             :width-fct #'(lambda (str)
                                            (string-width str self))
                             :height ascent :obj self))))


(defun string-width (str item)
   (stream-string-width (window item) str))

(defmethod approach-width ((feat text-feature) (theta number))
   (let ((screen-obj (screen-obj feat)))
     (if (and screen-obj
                (eq 'button (class-name (class-of screen-obj))))
       (let ((new-feat (first (member screen-obj (visicon (vis-m *mp*))
                                      :key #'screen-obj))))
         (if new-feat
           (approach-width new-feat theta)
           (call-next-method)))
       (call-next-method))))

;;; CURSOR-TO-FEATURE      [Function]
;;; Date        : 97.06.16
;;; Description : Returns a feature representing the current state and shape
;;;             : of the cursor.

(defmethod cursor-to-feature ((the-window window))
   "Returns a feature corresponding to the current cursor."
   (let ((pos (cursor-position the-window))
         (shape (cursor the-window)))
     (when (cursor-in-window-p the-window)
       (make-instance 'cursor-feature
         :x (position-x pos) :y (position-y pos)
         :value (case (name shape)
                  (:line-cursor 'I-BEAM)
                  (:cross-cursor 'CROSSHAIR)
                  (:waiting-cursor 'WATCH)
                  (otherwise 'POINTER))))))


(defmethod cursor-in-window-p (tw)
   "Returns T if the cursor is over the input window, NIL otherwise."
   (or (equal (window-under-mouse) tw)
       (equal (parent (window-under-mouse)) tw)))



(defmethod view-loc ((self dialog-item))
   "Return the center point of a view in (X Y) format."
   (let ((b (box self))
         )
   (vector (+ (box-left b) (round (/ (- (box-right b) (box-left b)) 2)))
         (+ (box-top b) (round (/ (- (box-bottom b) (box-top b)) 2))))))



(defmethod view-loc ((self symbol))
   "Hacked VIEW-LOC method for the cursor--returns the cursor location 
as (X Y)."
   (if (eq self :cursor)
     (get-mouse-coordinates (device (device-interface *mp*)))
     (error "!! Can't find location of ~S" self)))



;;; FILL-DEFAULT-DIMENSIONS      [Method]
;;; Date        : 99.04.02
;;; Description : The base methods for most MCL views don't set the height or
;;;             : width attributes of the features they generate, nor their
;;;             : size.  Set that up if necessary.

(defmethod fill-default-dimensions ((feat icon-feature))
   "Fill in the width, height, and size of an icon feature."
   (aif (simple-size feat)
     (setf (size feat) it)
     (if (null (screen-obj feat))
       (setf (size feat) 1.0)              ; should be default size, eh
       (progn
         (unless (width feat) (setf (width feat) (width (screen-obj feat))))
         (unless (height feat) (setf (height feat) (height (screen-obj feat))))
         (setf (size feat) (simple-size feat))))))




(defmethod populate-loc-to-key-array ((ar array))
              "Sets all the keys in the array that need to be set"
              ;; function key row
              (setf (aref ar 0 0) #\ESC)
              (setf (aref ar 2 0) vk-f1)
              (setf (aref ar 3 0) vk-f2)
              (setf (aref ar 4 0) vk-f3)
              (setf (aref ar 5 0) vk-f4)
              (setf (aref ar 7 0) vk-f5)
              (setf (aref ar 8 0) vk-f6)
              (setf (aref ar 9 0) vk-f7)
              (setf (aref ar 10 0) vk-f8)
              (setf (aref ar 12 0) vk-f9)
              (setf (aref ar 13 0) vk-f10)
              (setf (aref ar 14 0) vk-f11)
              (setf (aref ar 15 0) vk-f12)
              (setf (aref ar 17 0) vk-f13)
              (setf (aref ar 18 0) vk-f14)
              (setf (aref ar 19 0) vk-f15)
              ;; numeric key row
              (setf (aref ar 0 2) vk-backquote)
              (setf (aref ar 1 2) #\1)
              (setf (aref ar 2 2) #\2)
              (setf (aref ar 3 2) #\3)
              (setf (aref ar 4 2) #\4)
              (setf (aref ar 5 2) #\5)
              (setf (aref ar 6 2) #\6)
              (setf (aref ar 7 2) #\7)
              (setf (aref ar 8 2) #\8)
              (setf (aref ar 9 2) #\9)
              (setf (aref ar 10 2) #\0)
              (setf (aref ar 11 2) #\-)
              (setf (aref ar 12 2) #\=)
              (setf (aref ar 13 2) vk-backspace)
              (setf (aref ar 15 2) vk-insert)
              (setf (aref ar 16 2) vk-home)
              (setf (aref ar 17 2) vk-pageup)
              (setf (aref ar 19 2) vk-numlock)
              (setf (aref ar 20 2) #\=)
              (setf (aref ar 21 2) #\/)
              (setf (aref ar 22 2) #\*)
              ;; qwerty row
              (setf (aref ar 0 3) #\Tab)
              (setf (aref ar 1 3) #\Q)
              (setf (aref ar 2 3) #\W)
              (setf (aref ar 3 3) #\E)
              (setf (aref ar 4 3) #\R)
              (setf (aref ar 5 3) #\T)
              (setf (aref ar 6 3) #\Y)
              (setf (aref ar 7 3) #\U)
              (setf (aref ar 8 3) #\I)
              (setf (aref ar 9 3) #\O)
              (setf (aref ar 10 3) #\P)
              (setf (aref ar 11 3) #\[)
              (setf (aref ar 12 3) #\])
              (setf (aref ar 13 3) #\\)
              (setf (aref ar 15 3) vk-delete)
              (setf (aref ar 16 3) vk-end)
              (setf (aref ar 17 3) vk-pagedown)
              (setf (aref ar 19 3) #\7)
              (setf (aref ar 20 3) #\8)
              (setf (aref ar 21 3) #\9)
              (setf (aref ar 22 3) #\-)
              ;; ASDF row
              (setf (aref ar 0 4) vk-capslock)
              (setf (aref ar 1 4) #\A)
              (setf (aref ar 2 4) #\S)
              (setf (aref ar 3 4) #\D)
              (setf (aref ar 4 4) #\F)
              (setf (aref ar 5 4) #\G)
              (setf (aref ar 6 4) #\H)
              (setf (aref ar 7 4) #\J)
              (setf (aref ar 8 4) #\K)
              (setf (aref ar 9 4) #\L)
              (setf (aref ar 10 4) #\;)
              (setf (aref ar 11 4) vk-quote)
              (setf (aref ar 12 4) #\return)
              (setf (aref ar 13 4) #\return)
              (setf (aref ar 19 4) #\4)
              (setf (aref ar 20 4) #\5)
              (setf (aref ar 21 4) #\6)
              (setf (aref ar 22 4) #\+)
              ;; Z row
              (setf (aref ar 0 5) vk-shift)
              (setf (aref ar 1 5) #\Z)
              (setf (aref ar 2 5) #\X)
              (setf (aref ar 3 5) #\C)
              (setf (aref ar 4 5) #\V)
              (setf (aref ar 5 5) #\B)
              (setf (aref ar 6 5) #\N)
              (setf (aref ar 7 5) #\M)
              (setf (aref ar 8 5) #\,)
              (setf (aref ar 9 5) #\.)
              (setf (aref ar 10 5) #\/)
              (setf (aref ar 11 5) vk-shift)
              (setf (aref ar 12 5) vk-shift)
              (setf (aref ar 16 5) vk-up)
              (setf (aref ar 19 5) #\1)
              (setf (aref ar 20 5) #\2)
              (setf (aref ar 21 5) #\3)
              (setf (aref ar 22 5) vk-enter)
              ;; space bar row
              (setf (aref ar 0 6) vk-control)
              (setf (aref ar 1 6) 'option)
              (setf (aref ar 2 6) vk-alt)
              (setf (aref ar 3 6) #\Space)
              (setf (aref ar 4 6) #\Space)
              (setf (aref ar 5 6) #\Space)
              (setf (aref ar 6 6) #\Space)
              (setf (aref ar 7 6) #\Space)
              (setf (aref ar 8 6) #\Space)
              (setf (aref ar 9 6) #\Space)
              (setf (aref ar 10 6) #\Space)
              (setf (aref ar 11 6) vk-alt)
              (setf (aref ar 12 6) 'option)
              (setf (aref ar 13 6) vk-control)
              (setf (aref ar 15 6) vk-left)
              (setf (aref ar 16 6) vk-down)
              (setf (aref ar 17 6) vk-right)
              (setf (aref ar 19 6) #\0)
              (setf (aref ar 20 6) #\0)
              (setf (aref ar 21 6) #\.)
              (setf (aref ar 22 6) vk-enter)
   ar)



;;; DEVICE-UPDATE-ATTENDED-LOC      [Method]
;;; Date        : 00.09.05
;;; Description : When the attended location is updated, update the focus
;;;             : ring.  Create a new one and add it to the window if the
;;;             : previous one was closed, exists in a different window, or
;;;             : if it hasn't been created yet.
;;;             : Differs from MCL's in that it doesn't exist outside of a
;;;             : device window.

(defmethod device-update-attended-loc ((wind window) xyloc)
   (unless (or (equal t *attn-tracker*)
               #+:allegro-V5.0.1 (equal (type-of *attn-tracker*) 'closed-stream)
               #+(version>= 6) (null (handle win))
               (equal wind (parent *attn-tracker*)))
     (close *attn-tracker*))
   (when (or (eql t *attn-tracker*)
             #+:allegro-V5.0.1 (equal (type-of *attn-tracker*) 'closed-stream)
             #+(version>= 6) (null (handle win))
             )
     (setf *attn-tracker* (make-window :focus-ring :device 'focal-view 
:parent wind
                                       :left (- (px xyloc) 11)
                                       :right (- (py xyloc) 11))))
   (update-me *attn-tracker* wind xyloc))


;;;; 
---------------------------------------------------------------------- 
;;;;
;;;; Focus ring stuff


(defclass focal-view (transparent-pane)
   ()
   (:default-initargs
    :foreground-color red
    :width 23
    :height 23))


;;; REDISPLAY-WINDOW    [Method]
;;; Date        : 00.09.05
;;; Description : Draws a red ring centered in the center of the transparent
;;;             : pane, which should be at the focus of attention.

(defmethod redisplay-window ((self focal-view) &optional box)
   (declare (ignore box))
   (setf (line-width self) 3)
   (draw-circle self (make-position 11 11) 10))



;;; UPDATE-ME      [Method]
;;; Date        : 00.09.05
;;; Description : Udating the focus ring means changing its location.
;;;             : It's hidden before moving to prevent disruption of
;;;             : other screen objects (problem with ACL transparent pane).

(defmethod update-me ((foc-ring focal-view) window xyloc)
   (setf (state foc-ring) :shrunk)
   (setf (left foc-ring) (- (px xyloc) 11))
   (setf (top foc-ring) (- (py xyloc) 11))
   (setf (state foc-ring) :normal))

(eval-when (load eval)
   (setf *attn-tracker* t))

;;; hack so that when the focus-ring is present it passes the key 
presses on to the
;;; window for handling - oh yeah it actually works

(defmethod virtual-key-down :before ((focus-ring focal-view) buttons key-code)
   (when (subtypep (type-of (parent focus-ring)) 'rpm-window)
     (virtual-key-down (parent focus-ring) buttons key-code)))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;;  The following code was given to me by a developer at Franz to simulate the
;;;  mouse clicking and the button pressing in a window so that all of the
;;;  correct ACL 'actions' occur (methods get called, window is 
selected, visual
;;;  action occurs, etc).


#|
Our developer most familiar with Common Graphics has found a way to
accomplish what you were trying to do. He has written some code
(attached below my signature) which when loaded into your lisp will
allow you to run some examples showing a number of ways to simulate keypresses

and button clicks.

Using the following definition of a window (which contains 2 widgets)


     (defun make-form1
     (&key (parent (development-main-window *system*))
      (exterior (make-box 256 167 944 534)) (name :form1)
      (title "Form1") form-p)
   (let ((parent
          (make-window name
            :parent parent
            :device 'dialog
            :exterior exterior
            :border :frame
            :close-button t
            :cursor-name :arrow-cursor
            :widgets
                (list
                   (setf w3 (make-instance 'button
                    :font
                    (make-font-ex nil "MS Sans Serif" 13 nil)
                              :left 176
                    :on-change 'foo
                    :name :button4
                    :top 24))
                  (setf w4 (make-instance 'editable-text
                    :font
                    (make-font-ex nil "MS Sans Serif" 13 nil)
                    :left 106
                    :name :editable-text-1
                    :template-string nil
                    :top 208
                    :up-down-control nil
                             :value "EDITABLE-TEXT")))
                    :form-state :normal
                  :maximize-button t
            :minimize-button t
            :name :form1
            :package-name :common-graphics-user
            :pop-up nil
            :resizable t
            :scrollbars nil
            :state :normal
            :status-bar nil
            :system-menu t
            :title title
            :title-bar t
            :toolbar nil
            :form-p form-p
            :path #p"C:\\Program Files\\acl50195pf\\form1.bil"
            :help-string nil
            :package-name :common-graphics-user)))
     parent))

(defun foo(widget new-value old-value)
   (princ "hello"))


You can try running the following examples using the widgets w3 and w4.
For example:

        (do-click w3)

will  call the button to be pressed and the on-change function foo to run.
Foo simply prints "hello" to the debug window.




Examples (where "it" is either a window or widget):

;; Mouse clicks

;; Left-click in the center of its scrollable page.
(do-click it)

;; Left-click near the upper-right corner of its scrollable page.
(do-click it :position (make-position (- (interior-width (window it))
                                          8)
                                       12))

;; Left-click it with no pause for people to watch the action.
(do-click it :preview-seconds nil :down-seconds nil)

;; Right-click in the center of its client area.
(do-click it :button :right)

;; Left-click wherever the mouse is now.
(do-click nil)

;; Left-click an arbitary position on the screen.
(do-click nil :position (make-position 100 200))


;; Left-click the screen over the center of it, but without first
;; exposing it.  So if another window covers it, then the click
;; will go to that window instead of it.  Pre-expose defaults to
;; t to ensure that the click goes to the specified window, but
;; it may be useful to pass it as nil as in this example if you
;; are testing that that the window is exposed when it should be.
(do-click it :pre-expose nil)

;; Keypresses

;; Type a "j" into it.
(do-keypress it #\j)

;; Type a semicolon into whatever window has the focus already.
(do-keypress nil vk-semicolon)

;; Give it the focus and press down the shift key
;; without releasing it.  WARNING:  Doing this without
;; a subsequent up-click of the same key leaves the OS thinking
;; that the shift key is still down, and a further keystroke
;; will believe it is shifted.  This can be fixed interactively
;; by simply pressing and releasing the left shift key.
(do-keypress it vk-shift :up nil)

;; Type control-J into it.
(do-keypress it #\j :control t)

;; Type a whole string of characters into it.
(do-keypresses it "How about that.")

;; Print an arbitrary object into it.
(do-keypresses it (list :one "Foo"))

|#

;; ------------------------------------------------------------
;; mouse events

(defconstant win::MOUSEEVENTF_MOVE        #x0001)
(defconstant win::MOUSEEVENTF_LEFTDOWN    #x0002)
(defconstant win::MOUSEEVENTF_LEFTUP      #x0004)
(defconstant win::MOUSEEVENTF_RIGHTDOWN   #x0008)
(defconstant win::MOUSEEVENTF_RIGHTUP     #x0010)
(defconstant win::MOUSEEVENTF_MIDDLEDOWN  #x0020)
(defconstant win::MOUSEEVENTF_MIDDLEUP    #x0040)
(defconstant win::MOUSEEVENTF_WHEEL       #x0800)
(defconstant win::MOUSEEVENTF_ABSOLUTE    #x8000)

(ff:def-foreign-call (win::mouse_event "mouse_event")
     ((win::dwFlags win::dword)
      (win::dx win::dword)
      (win::dy win::dword)
      (win::dwData win::dword)
      (win::dwExtraInfo win::dword))) ;; officially ulong_ptr

(defgeneric do-click (window-or-widget-or-nil
                       &key (position (and window-or-widget-or nil :center))
                       (button :left)(pre-expose t)
                       (preview-seconds 0.5)(down-seconds 0.5))
   (:documentation
    "Simulates clicking a mouse button at some position in a window."))

(defmethod do-click ((widget dialog-item)
                      &key (position (and widget :center))
                      (button :left)(pre-expose t)
                      (preview-seconds 0.5)(down-seconds 0.5))
   (let* ((window (window widget)))
     (when (windowp window)
       (do-click window :position position
         :button button :pre-expose pre-expose
         :preview-seconds preview-seconds
         :down-seconds down-seconds))))

(defmethod do-click ((window t)
                      &key (position (and window :center))
                      (button :left)(pre-expose t)
                      (preview-seconds 0.5)(down-seconds 0.5)
                      (down t)(up t))
   (unless window
     (setq window (screen *system*)))
   (let* ((win window)
          (down-event (and down
                           (case button
                             (:left win::MOUSEEVENTF_LEFTDOWN)
                             (:middle win::MOUSEEVENTF_MIDDLEDOWN)
                             (:right win::MOUSEEVENTF_RIGHTDOWN))))
          (up-event (and up
                         (case button
                           (:left win::MOUSEEVENTF_LEFTUP)
                           (:middle win::MOUSEEVENTF_MIDDLEUP)
                           (:right win::MOUSEEVENTF_RIGHTUP))))
          (stream-pos (case position
                        (:center (box-center (visible-box window)))
                        (t position)))
          #+not-used
          (screen-pos (and stream-pos
                           (window-to-screen-units window
                             (stream-to-window-units window
                               (copy-position stream-pos))))))
     (when window
       (when pre-expose
         (loop (unless (windowp win)(return))
               (unless (eq win (selected-window (parent win)))
                 (select-window win))
               (setq win (parent win))))

       ;; Move the mouse over the window.
       (when stream-pos
         (setf (cursor-position window) stream-pos))

       #+no ;; These units apparently would need to be normalized
       ;; where 0 to 65k covers the screen, so use (setf cursor-position)
       ;; instead in order to use pixel units.
       (when screen-pos
         (win::mouse_event (logior win::MOUSEEVENTF_MOVE
                                   win::MOUSEEVENTF_ABSOLUTE)
                           (position-x screen-pos)
                           (position-y screen-pos)
                           0 0)))

     ;; Wait a bit for the user to see the window before the click is done.
     (when preview-seconds (sleep preview-seconds))

     ;; Send the click down and up messages, pausing a bit in between
     ;; so that a human can see that the button was clicked.
     (when down
       (win::mouse_event down-event 0 0 0 0)

       #+no ;; The coordinates don't matter when doing the click,
       ;; though the MSDN doesn't make this clear.
       (win::mouse_event (logior down-event
                                 (if screen-pos
                                     win::MOUSEEVENTF_ABSOLUTE
                                   0))
                         (if screen-pos (position-x screen-pos) 0)
                         (if screen-pos (position-y screen-pos) 0)
                         0 0))
     #+old ;; This works, but mouse_event may be more robust.
     (win:SendMessage (handle window) win:WM_LBUTTONDOWN
       win:MK_LBUTTON (win:makelong (position-x window-pos)
                                    (position-y window-pos)))
     (when down-seconds (sleep down-seconds))
     (when up
       (win::mouse_event up-event 0 40000 0 0))
     ))

;; ------------------------------------------------------------
;; key presses

(defconstant win::KEYEVENTF_EXTENDEDKEY 1)
(defconstant win::KEYEVENTF_KEYUP       2)

(ff:def-foreign-call (win::keybd_event "keybd_event")
     ((win::bVk byte)
      (win::bScan byte)
      (win::dwFlags win::dword)
      (win::dwExtraInfo win::dword))
   :convention :stdcall
   :release-heap :when-ok
   :arg-checking nil
   :returning :void)

(defgeneric do-keypress (window-or-widget-or-nil
                          keynum-or-character
                          &key (preview-seconds 0.5)
                          shift control alt
                          (down-seconds 0.5)(down t)(up t))
   (:documentation
    #.(format nil "Simulates pressing and/or releasing a key ~
        on the keyboard while some window has the focus.")))

(defmethod do-keypress ((widget dialog-item)(keynum-or-char t)
                         &key (preview-seconds 0.5)(down-seconds 0.5)
                         shift control alt
                         (down t)(up t))
   (let* ((window (window widget)))
     (when (windowp window)
       (do-keypress window keynum-or-char
         :down-seconds down-seconds
         :preview-seconds preview-seconds
         :shift shift :control control :alt alt
         :down down :up up))))

(defmethod do-keypress ((window t)(keynum integer)
                         &key (preview-seconds 0.5)(down-seconds 0.5)
                         shift control alt
                         (down t)(up t))
   (declare (ignore shift control alt))

   ;; Expose the window and its parents all the way up
   (when window
     (let* ((win window))
       (loop (unless (windowp win)(return))
             (unless (eq win (selected-window (parent win)))
               (select-window win))
             (setq win (parent win))))

     ;; Make sure the window has the keyboard focus.
     (unless (eq window (get-focus (screen *system*)))
       (win:SetFocus (handle window))))

   ;; Wait a bit for the user to see the window before the click is done.
   (when preview-seconds (sleep preview-seconds))

   ;; Send the click down and up messages, pausing a bit in between
   ;; so that a human can see any effect of the key being down.
   (when down
     (win::keybd_event keynum 0 0 0)
     #+old ;; this doesn't seem to work
     (win:SendMessage (handle window) win:WM_KEYDOWN keynum
       1)) ;; "repeat" the keypress one time
   (when down-seconds (sleep down-seconds))
   (when up
     (win::keybd_event keynum 0 win::KEYEVENTF_KEYUP 0)
     #+old
     (win:SendMessage (handle window) win:WM_KEYUP keynum
       (logior (expt 2 31) ;; transition flag
               (expt 2 30) ;; flag that key was down
               1)) ;; "repeat" the keypress one time
     ))

(defmethod do-keypress ((window t)(char character)
                         &key (preview-seconds 0.5)(down-seconds 0.5)
                         shift control alt
                         (down t)(up t))
   (let* ((vk (win:VkKeyScan (char-int char)))
          (key-number (cg::lobyte vk))
          (shift-keys (cg::hibyte vk))
          (upper-case? (logbitp 0 shift-keys)))
     (when preview-seconds
       (sleep preview-seconds))
     (when alt
       (do-keypress window vk-alt :up nil
         :preview-seconds nil :down-seconds nil))
     (when control
       (do-keypress window vk-control :up nil
         :preview-seconds nil :down-seconds nil))
     (when (or shift upper-case?)
       (do-keypress window vk-shift :up nil
         :preview-seconds nil :down-seconds nil))
     (do-keypress window key-number
       :preview-seconds nil
       :down-seconds down-seconds
       :down down :up up)
     (when (or shift upper-case?)
       (do-keypress window vk-shift :down nil
         :preview-seconds nil :down-seconds nil))
     (when control
       (do-keypress window vk-control :down nil
         :preview-seconds nil :down-seconds nil))
     (when alt
       (do-keypress window vk-alt :down nil
         :preview-seconds nil :down-seconds nil))
     ))

(defmethod do-keypresses ((window t)(object string)
                           &key (preview-seconds 0.5)(down-seconds 0.5))
   (let* ((length (length object)))
     (dotimes (j length)
       (do-keypress
         window (aref object j)
         :preview-seconds (if (eq j 0) preview-seconds nil)
         :down-seconds (if (eq j (1- length)) down-seconds)))))

(defmethod do-keypresses ((window t)(object symbol)
                           &key (preview-seconds 0.5)(down-seconds 0.5))
   (do-keypresses window (symbol-name object)
     :preview-seconds preview-seconds
     :down-seconds down-seconds))

(defmethod do-keypresses ((window t)(object t)
                           &key (preview-seconds 0.5)(down-seconds 0.5))
   (do-keypresses window (princ-to-string object)
     :preview-seconds preview-seconds
     :down-seconds down-seconds))




;;; Any update in external sources will be propagated after the next
;;; production cycle.  Calling (update-activation-spread) will cause the
;;; spreading to occur immediately, with unspecified results if ACT-R is
;;; in the middle of the production-matching phase.

(defvar *external-sources* nil)

(let ((*warn-if-redefine* nil))
   (defun update-activation-spread (&key (focus *wmfocus*)
                                             (external *external-sources*))
     "Updates the activation sources to be the slot values of the focus wme.
      Also add the external sources if defined as list of (source . level)."
     (incf *spread-stamp* 1)
     (dolist (source *activation-sources*)
       (setf (wme-source source) nil))
     (setf *activation-sources* nil)
     (when focus
       (let ((level (first (wme-slot-wmes focus))))
         (when (> level 0.0)
           (setf level (/ *goal-activation* level))
           (dolist (source (rest (wme-slot-wmes focus)))
             (cond ((wme-source source)
                    (incf (wme-source source) level))
                   (t
                    (setf (wme-source source) level)
                    (push source *activation-sources*)))))))
     (when external
       (dolist (pair external)
         (let* ((object (car pair))
                (level (cdr pair))
                (sources (wme-slot-wmes object)))
           (when (> (first sources) 0.0)
             (setf level (/ level (first sources)))
             (dolist (source (rest sources))
               (cond ((wme-source source)
                      (incf (wme-source source) level))
                     (t
                      (setf (wme-source source) level)
                      (push source *activation-sources*)))))))))
   )


(defun external-sources-fct (&optional (sources-and-levels nil))
   "Sets each external source to its level.  If level is nil (or not
    a number), removes the source.  If the (first) source is nil,
    removes all sources. If no argument is given, then does nothing.
    Returns the list of external sources."
   (when sources-and-levels
     (if (null (first sources-and-levels))
       (setf *external-sources* nil)
       (loop
         (let* ((source (pop sources-and-levels))
                (level (pop sources-and-levels)))
           (setf source (get-safe-wme source))
           (when source
             (if (numberp level)
               (let ((pair (member source *external-sources*
                                   :test #'eq :key #'car)))
                 (if pair
                   (rplacd (first pair) level)
                   (push (cons source level) *external-sources*)))
               (setf *external-sources*
                     (delete source *external-sources*
                             :test #'eq :key #'car)))))
         (unless sources-and-levels (return)))))
   *external-sources*)


(defmacro external-sources (&rest sources-and-levels)
   "Sets each external source to its level.  If level is nil (or not
    a number), removes the source.  If the (first) source is nil,
    removes all sources. If no argument is given, then does nothing.
    Returns the list of external sources."
   `(external-sources-fct ',sources-and-levels))

#|
? (external-sources)
NIL
? (external-sources pega 0.35 pegb 0.5)
((PEGB . 0.5) (PEGA . 0.35))
? (external-sources pegc 0.65 pegb 0.55)
((PEGC . 0.65) (PEGB . 0.55) (PEGA . 0.35))
? (external-sources pega 0.5 pegb nil)
((PEGC . 0.65) (PEGA . 0.5))
? (external-sources nil)
NIL
|#



;;;  -*- mode: LISP; Package: CL-USER; Syntax: COMMON-LISP;  Base: 10 -*-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Author      : Mike Byrne
;;; Copyright   : (c)1998-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    : actr-interface.lisp
;;; Version     : 2.1b4
;;;
;;; Description : Formerly "act-interface.lisp"
;;;             : This file contains functions which are ACT-R specific,
;;;             : particularly in how DM is handled.
;;;
;;; Bugs        : [] No way to send SCALE info with default move-attention
;;;             :    command.
;;;
;;; Todo        :
;;;
;;; ----- History -----
;;; 01.07.27 mdb
;;;             : Started 5.0 conversion work.
;;;             : [x] MOVE-ATTENTION can fail to generate a chunk {this might
;;;             :    go into the actr-interface.lisp}
;;; 01.08.07 mdb
;;;             : Added a chunk type for START-TRACKING.  Added SIZE slot on
;;;             : VISUAL-LOCATION chunk type.
;;; 01.09.17 mdb
;;;             : * Fixed glitch in :after methods for new-*-sound.
;;;             : * Returned MIN-RUN-TIME.
;;; 02.01.21 mdb
;;;             : Changed the proc-state part of state-spec.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;; 
---------------------------------------------------------------------- 
;;;;
;;;; Functions that define the relevant chunk types and such for ACT-R.
;;;; 
---------------------------------------------------------------------- 
;;;;

(defun def-pm-chunk-types ()
   "Defines chunk types used by the PM layer"
   (unless (get-type 'visual-location)

     ;; define the dmetype for state chunks
     (chunk-type module-state module modality processor
                 preparation execution last-command)

     ;; visual interface chunks
     (chunk-type visual-object screen-pos value status color height width)
     (chunk-type abstract-object value line-pos bin-pos)
     (chunk-type (abstract-letter (:include abstract-object)))
     (chunk-type (abstract-number (:include abstract-object)))
     (chunk-type (text (:include visual-object)))
     (chunk-type (empty-space (:include visual-object)))

     #| This is really never used and requires lists, so this was 
removed for 2.1
     (chunk-type (sub-object (:include visual-object)) objects)
     (chunk-type (point (:include sub-object)))
     (chunk-type (pair (:include sub-object)))
     (chunk-type (triplet (:include sub-object)))
     |#

     (chunk-type (line (:include visual-object)) other-pos end1-x 
end1-y end2-x end2-y)
     (chunk-type (oval (:include visual-object)))
     (chunk-type (cursor (:include visual-object)))

     (chunk-type (phrase! (:include visual-object)) objects words)
     (chunk-type visual-location screen-x screen-y attended kind color value
                 size nearest)
     (chunk-type vision-command)
     (chunk-type motor-command)
     (chunk-type audio-command)
     (chunk-type pm-constant)
     (chunk-type color)

     ;; audio chunks
     (chunk-type audio-event attended onset offset pitch kind objects)
     (chunk-type sound kind content)

     ;;; Adds the chunk types to hold the various actions as subtypes 
of motor-command
     ;;; Note that move-mouse is currently a chunk of type motor-command but the
     ;;; documented motor commands (in 1.0 manual) such as press-key 
etc are just plain chunks.
     (chunk-type (click-mouse (:include motor-command)))
     (chunk-type (hand-to-mouse (:include motor-command)))
     (chunk-type (hand-to-home (:include motor-command)))
     (chunk-type (move-cursor (:include motor-command)) object loc device)
     (chunk-type (peck (:include motor-command)) hand finger r theta)
     (chunk-type (peck-recoil (:include motor-command)) hand finger r theta)
     (chunk-type (point-hand-at-key (:include motor-command)) hand to-key)
     (chunk-type (press-key (:include motor-command)) key)
     (chunk-type (punch (:include motor-command)) hand finger)
     ;;; Also for speech command(s)
     (chunk-type speech-command)
     (chunk-type (speak (:include speech-command)) string)
     ;;; Also for visual commands
     (chunk-type (start-tracking (:include vision-command)) object)
     ))


;;; add some state chunks to DM
(defun add-pm-state-chunks ()
   "Adds chunks for various RPM states."
   (unless (no-output (dm vision-state))
     (no-output
      (add-dm-fct
       '((free isa chunk)
         (busy isa chunk)
         (vision-state isa module-state module :VISION modality FREE 
processor FREE
                       preparation FREE execution FREE)
         (motor-state isa module-state module :MOTOR modality FREE 
processor FREE
                      preparation FREE execution FREE)
         (speech-state isa module-state module :SPEECH modality FREE 
processor FREE
                       preparation FREE execution FREE)
         (audio-state isa module-state module :AUDIO modality FREE 
processor FREE
                      preparation FREE execution FREE)

         (move-mouse isa motor-command)
         (click-mouse isa motor-command)
         (find-location isa vision-command)
         (move-attention isa vision-command)
         (punch isa motor-command)
         (press-key isa motor-command)
         (listen-for isa audio-command)
         (black isa color)
         (digit isa chunk)
         (speech isa chunk)
         (tone isa chunk)
         (oval isa chunk)
         (click-mouse isa chunk)
         (text isa chunk)
         (box isa chunk)
         (move-cursor isa chunk)
         (move-attention isa chunk)
         (punch isa chunk)
         (peck isa chunk)
         (peck-recoil isa chunk)
         (hand-ply isa chunk)
         (point-hand isa chunk)
         (press-key isa chunk)
         (point-hand-at-key isa chunk)
         (hand-to-mouse isa chunk)
         (hand-to-home isa chunk)
         (:motor isa chunk)
         (:vision isa chunk)
         (:audio isa chunk)
         (:speech isa chunk)
         (lowest isa pm-constant)
         (highest isa pm-constant)
         (greater-than-current isa pm-constant)
         (less-than-current isa pm-constant)
         (current isa pm-constant)
         )
       :reset-ia nil))))



(def-pm-chunk-types)
(add-pm-state-chunks)


;;;; 
---------------------------------------------------------------------- 
;;;;
;;;; ACT-R methods for the Declarative Memory Interface
;;;; 
---------------------------------------------------------------------- 
;;;;

(defmethod make-dme (id (dmtype symbol) (attrs list) &key (obj nil)
                           (where nil))
   (declare (ignore where))
   (no-output (add-dm-fct `((,id isa ,dmtype ,@attrs)) :reset-ia nil))
   (make-instance 'dmo :ps-ptr (get-safe-wme id) :dmtype dmtype
                  :id id :pm-obj obj))


(defmethod get-attribute ((self dmo) (attrname symbol))
   (no-output (chunk-slot-value-fct (ps-ptr self) attrname)))


(defmethod set-attributes ((self dmo) (attrs list))
   (no-output (mod-chunk-fct (ps-ptr self) attrs))
   self)


(defmethod psdme-to-dmo (psdme)
   (setf psdme (get-safe-wme psdme))
   (make-instance 'dmo :ps-ptr psdme :dmtype (wme-type psdme)
                  :id (wme-name psdme)))


(defmethod dmo-to-psdme ((self dmo))
   (no-output (get-safe-wme (id self))))

;  (ps-ptr self))


(defmethod matching-dmos ((dmtype symbol) (attrs list))
   (let ((psdmes
          (no-output (sdm-fct `(isa ,dmtype ,@attrs)))))
     (when psdmes
       (mapcar #'psdme-to-dmo psdmes))))

#|
;; mdb:  What's this doing here?
(defmethod xy-to-dmo :around ((loc list) (attended-p symbol))
   (let ((the-dmo (call-next-method)))
     (no-output
      (add-reference (wme-references (dmo-to-psdme the-dmo)))
      (update-activation-spread))
     the-dmo))
|#


;;;; 
---------------------------------------------------------------------- 
;;;;
;;;; Method overrides and specializers for ACT-R
;;;; 
---------------------------------------------------------------------- 
;;;;

;;; could this be an :after method?
(defmethod find-location :around ((vis-mod vision-module) &key (kind :IGNORE)
                                     (attended :IGNORE) (value :IGNORE)
                                     (color :IGNORE) (size :IGNORE)
                                     screen-x screen-y nearest)
   (declare (ignore kind attended value color size screen-x screen-y nearest))
   (aif (call-next-method)
     (setf *visual-location* it)
     (setf *visual-location* (get-wme 'FAILURE))))


(defmethod new-sound-event :around ((evt sound-event))
   (let ((evt (call-next-method)))
     (pm-timed-event (detect-at-time evt) #'stuff-sound-buffer)))


(defun stuff-sound-buffer  ()
   (unless *aural-location*
     (find-sound-fct :attended nil)))

;;; again, coul this be :after?
(defmethod find-sound :around ((aud-mod audio-module)
                                  &key (attended :IGNORE) (kind :IGNORE)
                                  onset pitch)
   (declare (ignore attended kind onset pitch))
   (aif (call-next-method)
     (setf *aural-location* it)
     (setf *aural-location* (get-wme 'FAILURE))))


(defmethod process-display :after ((devin device-interface)
                                       (vis-mod vision-module)
                                       &optional (clear nil))
   (declare (ignore devin clear))
   (stuff-visloc-buffer vis-mod))

(defmethod min-run-time ((mstr-proc master-process))
   *default-action-time*)

;;;; 
---------------------------------------------------------------------- 
;;;;
;;;; Functions to interface with ACT-R's modified production syntax
;;;; 
---------------------------------------------------------------------- 
;;;;

;;; vision

(defun current-visual-object ()
   "Return the chunk corresponding to the currently-attended object."
   (aif (currently-attended (vis-m *mp*))
     (dmo-to-psdme it)
     (get-wme 'failure)))                ; mdb 01.07.27


(defun find-location-fct (&key (kind :IGNORE) (attended :IGNORE)
                              (value :IGNORE) (color :IGNORE)
                              (size :IGNORE) (screen-x :IGNORE)
                              (screen-y :IGNORE) nearest)
   "Calls the Vision Module's FIND-LOCATION method"
   (setf kind (check-gwn kind))
   (setf attended (check-gwn attended))
   (setf value (check-gwn value))
   (setf color (check-gwn color))
   (setf size (check-gwn size))
   (setf screen-x (check-gwn screen-x))
   (setf screen-y (check-gwn screen-y))
   (setf nearest (check-gwn nearest))
   (find-location (vis-m *mp*) :kind kind  :attended attended  :value value
                  :color color  :size size  :screen-x screen-x
                  :screen-y screen-y :nearest nearest))


(defmethod stuff-visloc-buffer ((vis-mod vision-module))
   (unless *visual-location*
     (awhen (find-current-locs-with-spec vis-mod (default-spec vis-mod))
       (setf *visual-location*
             (construct-location vis-mod
                                 (random-item (objs-max-slotval it 'tstamp))
                                 (default-spec vis-mod))))))



;;; audition


(defun find-sound-fct (&rest params)
   "Call's the Audio Manager's FIND-SOUND method."
   (apply #'find-sound (audio-m *mp*) params))




(defun current-sound-fct ()
   "Return the chunk corresponding to the currently-attended object."
   (awhen (currently-attended (audio-m *mp*))
     (dmo-to-psdme it)))


;;; module state

(defun module-state-fct (&key module (modality :ignore)
                                  (preparation :ignore) (execution :ignore)
                                  (processor :ignore)
                                  (last-command :ignore))
   "Function to check the state of a PM module, for the ACT-R LHS test."
   (when (match-spec-p (make-instance 'pm-state-spec
                         :modality modality
                         :preparation preparation
                         :execution execution
                         :processor processor
                         :last-command last-command)
                       (key->mgr *mp* module))
     (dmo-to-psdme (state-dmo (key->mgr *mp* module)))))



(defclass pm-state-spec (pm-module spec)
   ()
   (:default-initargs
     :check-slots #(modality-state preparation-state execution-state
                                   processor-state last-command)
     :modality :IGNORE
     :preparation :IGNORE
     :execution :IGNORE
     :processor :IGNORE
     :last-command :IGNORE))


#|
(defmethod match-spec-p :around ((ts pm-state-spec)
                                    (mod pm-module))
   (when (call-next-method)
     (let ((condition (proc-stub ts))
           (value (proc-s mod)))
       (cond ((eq condition :IGNORE) T)
             ((functionp condition)
              (funcall condition value))
             (t (equal condition value))))))


(defmethod match-spec-p :around ((ts pm-state-spec)
                                    (mod pm-module))
   (call-next-method))
|#








;;; New code to patch up the compiler to act-r/pm
;;; ACT-R 5.0p1

(defvar *pm-calls*
   '((visual-location
      find-location-fct
      (attended :attended)
      (screen-x :screen-x)
      (screen-y :screen-y)
      (value :value)
      (kind :kind)
      (color :color)
      (size :size)
      (nearest :nearest)
      (time))
     (audio-event
      find-sound-fct
      (attended :attended)
      (onset :onset)
      (offset :offset)
      (pitch :pitch)
      (kind :type)
      (objects)
      (time))
     (module-state
      module-state-fct
      (module :module)
      (preparation :preparation)
      (processor :processor)
      (execution :execution)
      (modality :modality)
      (last-command :last-command))
     (visual-object current-visual-object)
     (sound current-sound-fct))
   "Mapping between chunk types and fcts and if applicable slot names
    and keyword arguments for calls to the perceptual/motor layer.")

(defun sub-eval-vars (expr bindings &optional (fct-call t))
   "Substitute stack reference for production variables in evaled expressions.
    Return a function to be funcalled rather than a form to be evaled, 
which for all
    but the simplest ones causes the compiler to be called every time, unless
    *compile-eval-calls* has been turned off."
   (let ((new-expr (list (copy-tree expr))))
     (dolist (binding bindings (if fct-call
                                 (if *compile-eval-calls*
                                   (compile nil `(lambda () ,(first new-expr)))
                                   (eval `(function (lambda () ,(first 
new-expr)))))
                                 (first new-expr)))
       (nsubst `(get-wme-name (svref *instantiation* ,(variable-index binding)))
               (variable-name binding) new-expr :test #'eq))))

(defun compile-lhs (production lhs initializations bindings index)
   "Compiles the left-hand side of production.
    Add the instantiation-adding call."
   (let ((code nil)
         (form nil))
     (dolist (clause lhs)
       (let ((key (pop clause))
             (type nil)
             (tests nil)
             (binds nil)
             (slot nil)
             (value nil)
             (negation nil))
         (setf form
               (cond
                ((retrievalp key)
                 (setf key (var>var key))
                 (with-binding binding direct key bindings index
                   (set-variable-type production type key (pop clause))
                   (when type
                     (cond ((and (member (wme-type-name type) 
'(visual-location audio-event) :test #'eq)
                                     (member '(time now) clause :test 
#'equal)) ;; compatibility with the old hack
                            (setf clause (delete '(time now) clause 
:test #'equal))
                            (setf (variable-type binding) type)
                            (let* ((fct-args (rest (assoc 
(wme-type-name type) *pm-calls* :test #'eq)))
                                   (pm-call (list (first fct-args)))
                                   (argument-alist (rest fct-args)))
                              (dolist (slot-value clause)
                                (let* ((negation (when (equal (first 
slot-value) '-)
                                                   (pop slot-value)))
                                       (slot (first slot-value))
                                       (value (second slot-value))
                                       (mapping (assoc slot argument-alist)))
                                  (cond (mapping
                                         (when (and (or (not (variablep value))
 
(get-variable-binding value bindings))
                                                    (second mapping))
                                           (setf value (sub-eval-vars 
value bindings nil))
                                           (nconc pm-call (list (second mapping)
                                                                (if negation
 
(list 'pm-not-equal value)
                                                                  value)))))
                                        (t
                                         (signal-warn "SLOT ~S OF 
CHUNK ~S TYPE ~S IN PRODUCTION ~S IS UNDEFINED."
                                                      slot key type 
production)))))
                              (compile-lhs-slots tests binds)
                              (list (if (and *enable-rational-analysis* code)
                                      ; the goal cannot be partial-matched
                                      'external-test-and-bind-pm
                                      'external-test-and-bind)
                                    (variable-index binding)
                                    pm-call
                                    type nil binds)))
                           ((or (member key '(=visual-state 
=aural-state =manual-state =vocal-state)) ;; reserved keywords for 
states
                                (eq (wme-type-name type) 'module-state))
                            (setf clause (delete '(time now) clause 
:test #'equal))
                            (setf (variable-type binding) type)
                            (let* ((fct-args (rest (assoc 
(wme-type-name type) *pm-calls* :test #'eq)))
                                   (pm-call (list (first fct-args)))
                                   (argument-alist (rest fct-args)))
                              (when (and (member key '(=visual-state 
=aural-state =manual-state =vocal-state))
                                         (not (assoc 'module clause)))
                                (nconc pm-call (list :module (case key
 
(=visual-state :vision)
 
(=aural-state :audio)
 
(=manual-state :motor)
 
(=vocal-state :speech)))))
                              (dolist (slot-value clause)
                                (let* ((negation (when (equal (first 
slot-value) '-)
                                                   (pop slot-value)))
                                       (slot (first slot-value))
                                       (value (second slot-value))
                                       (mapping (assoc slot argument-alist)))
                                  (cond (mapping
                                         (when (and (or (not (variablep value))
 
(get-variable-binding value bindings))
                                                    (second mapping))
                                           (setf value (sub-eval-vars 
value bindings nil))
                                           (nconc pm-call (list (second mapping)
                                                                (if negation
 
(list 'pm-not-equal value)
                                                                  value)))))
                                        (t
                                         (signal-warn "SLOT ~S OF 
CHUNK ~S TYPE ~S IN PRODUCTION ~S IS UNDEFINED."
                                                      slot key type 
production)))))

                              (compile-lhs-slots tests binds)
                              (list 'buffer-test-and-bind ;;  It is 
all a buffer match now
                                    (variable-index binding)
                                    pm-call
                                    type nil binds)))
                           ((or (member key '(=visual =aural)) ;; 
reserved keywords for visual and sound objects
                                (and (or (member 'visual-object 
(wme-type-supertypes type)
                                                 :test #'eq :key 
#'wme-type-name)
                                         (member 'sound 
(wme-type-supertypes type)
                                                 :test #'eq :key 
#'wme-type-name))
                                     (member '(time now) clause :test #'equal)))
                            (setf clause (delete '(time now) clause 
:test #'equal))
                            (setf (variable-type binding) type)
                            (compile-lhs-slots tests binds)
                            (list 'buffer-test-and-bind ;;  It is all 
a buffer match now
                                  (variable-index binding)
                                  (list (second (assoc (if (or (member 
'visual-object (wme-type-supertypes type)
 
:test #'eq :key #'wme-type-name)
                                                               (eq key 
'=visual))
                                                         'visual-object 'sound)
                                                       *pm-calls* :test #'eq)))
                                  type tests binds))
                           ((member key '(=manual =manual-location 
=vocal =vocal-location))
                            (signal-warn "RESERVED KEYWORD NOT YET 
IMPLEMENTED."))
                           (t  ;; includes =visual-location and 
=aural-location because they are now buffers
                            (setf (variable-type binding) type)
                            (compile-lhs-slots tests binds)
                            (list (if (assoc (variable-index binding) 
initializations :test #'=)
                                    ;; Fixed buffers have their 
special test to avoid activation
                                    'direct-test-and-bind-buffer
                                    (if *enable-rational-analysis*
                                      (if direct 'direct-test-and-bind-pm
                                          'indirect-test-and-bind-pm)
                                      (if direct 'direct-test-and-bind
                                          'indirect-test-and-bind)))
                                  (variable-index binding) type tests 
binds))))))
                ((eq '!eval! key)
                 (list 'eval-test (sub-eval-vars (first clause) bindings)))
                ((eq '!bind! key)
                 (with-binding binding bound (first clause) bindings index
                   (when bound
                     (signal-warn "VARIABLE ~S ALREADY BOUND IN PRODUCTION ~A."
                                  (first clause) production))
                   (list 'bind-lhs (variable-index binding)
                         (sub-eval-vars (second clause) bindings))))
                ((eq '!find-location! key)
                 (with-binding binding bound (first clause) bindings index
                   (when bound
                     (signal-warn "VARIABLE ~S ALREADY BOUND IN PRODUCTION ~A."
                                  (first clause) production))
                   (list 'bind-find-location (variable-index binding)
                         (sub-eval-vars (cons 'list (quote-arguments 
(rest clause)))
                                        bindings))))
                (t (signal-warn "UNKNOWN COMMAND ~S IN PRODUCTION ~A."
                                key production))))
         (setf code (nconc code form))))
     ;; FIX: split into goal and retrievals when ERA is enabled.
     (values (if *enable-rational-analysis*
               (let ((direct-length (first-retrieval-index code 
initializations)))
                 (cons (nconc (subseq code 0 direct-length) (list 
'add-instantiation-to-conflict-set))
                       (nconc (subseq code direct-length) (list 'not))))
               (nconc code (list 'add-instantiation-to-conflict-set)))
             bindings index)))

(defun buffer-test-and-bind (arguments)
   "Implements a direct match.  Tests for type and then slots, then bind
    variables.  Finally, call the function implementing the next clause.
    Arguments is a list of the wme's stack index, its type, a list of slots
    tests and bindings, and the next call if any.
    Returns t if a complete match is found, nil otherwise."
   (let* ((wme-index (pop arguments))
          ;; FIX: get the current visual or sound object by calling the PM layer
          ;; If the variable is already bound, test that it is identical
          (external-call (pop arguments))
          (wme (apply (first external-call) (rest external-call)))
          (binding (instantiation-variable *instantiation* wme-index))
          (wmetype (pop arguments))
          (slots-tested (pop arguments))
          (slots-bound (pop arguments)))
     (cond ((and binding (not (eq wme binding)))
            (signal-output *exact-matching-trace* "Current visual 
object ~S does not match existing binding ~S."
                           wme binding))
           (t
            (unless binding
              (setf (instantiation-variable *instantiation* wme-index) wme))
            (if (and (wmep wme) (subtype (wme-type wme) wmetype))
              (let ((slots (wme-slots wme)))
                ;; Set bindings before testing slots
                (and (set-bindings slots slots-bound)
;                   ;; FIX: The retrieval threshold does not apply to PM calls
;                    (let ((*retrieval-threshold* nil))
;                      (test-slots wme slots slots-tested wme-index))
                     (test-slots-buffer wme slots slots-tested)
                     (simulate-call arguments)))
              (signal-output *exact-matching-trace* "~S is not a CHUNK 
of type ~S."
                             wme wmetype))))))

;;; added back for compatibility with the old time now hack
(defun external-test-and-bind (arguments)
   "Implements a direct match.  Tests for type and then slots, then bind
    variables.  Finally, call the function implementing the next clause.
    Arguments is a list of the wme's stack index, its type, a list of slots
    tests and bindings, and the next call if any.
    Returns t if a complete match is found, nil otherwise."
   (let* ((wme-index (pop arguments))
          ;; FIX: get the current visual or sound object by calling the PM layer
          ;; If the variable is already bound, test that it is identical
          (external-call (pop arguments))
          (wme (apply (first external-call) (rest external-call)))
          (binding (instantiation-variable *instantiation* wme-index))
          (wmetype (pop arguments))
          (slots-tested (pop arguments))
          (slots-bound (pop arguments)))
     (cond ((and binding (not (eq wme binding)))
            (signal-output *exact-matching-trace* "Current visual 
object ~S does not match existing binding ~S."
                           wme binding))
           (t
            (unless binding
              (setf (instantiation-variable *instantiation* wme-index) wme))
            (if (and (wmep wme) (subtype (wme-type wme) wmetype))
              (let ((slots (wme-slots wme)))
                ;; Set bindings before testing slots
                (and (set-bindings slots slots-bound)
                    ;; FIX: The retrieval threshold does not apply to PM calls
                     (let ((*retrieval-threshold* nil))
                       (test-slots wme slots slots-tested)) ;; wme-index))
                     (simulate-call arguments)))
              (signal-output *exact-matching-trace* "~S is not a CHUNK 
of type ~S."
                             wme wmetype))))))

(defun external-test-and-bind-pm (arguments)
   "Implements a direct match.  Tests for type and then slots, then bind
    variables.  Finally, call the function implementing the next clause.
    Arguments is a list of the wme's stack index, its type, a list of slots
    tests and bindings, and the next call if any.
    This is the rational analysis version, which handles partial matching too."
   (let* ((wme-index (pop arguments))
          ;; FIX: get the current visual or sound object by calling the PM layer
          ;; If the variable is already bound, test that it is identical
          (external-call (pop arguments))
          (wme (apply (first external-call) (rest external-call)))
          (binding (instantiation-variable *instantiation* wme-index))
          (wmetype (pop arguments))
          (slots-tested (pop arguments))
          (slots-bound (pop arguments)))
     (cond ((and binding (not (eq wme binding)))
            (signal-output *exact-matching-trace* "Current visual 
object ~S does not match existing binding ~S."
                           wme binding))
           ((and (wmep wme) (subtype (wme-type wme) wmetype))
            (unless binding
              (setf (instantiation-variable *instantiation* wme-index) wme))
            (let* ((slots (wme-slots wme))
                   ;; Set bindings before testing slots
                   (activation (and (set-bindings slots slots-bound)
                                    ;; FIX: The retrieval threshold 
does not apply to PM calls
                                    (let ((*retrieval-threshold* 
most-negative-short-float))
                                      (if *partial-matching*
                                        (test-slots-pm wme slots slots-tested)
                                        (test-slots wme slots slots-tested))))))
              ;; FIX: Do not increment the latency
              ;; (add-latency wme (or activation *retrieval-threshold*))
              (when activation
                (simulate-call arguments))))
           (t
            ;; FIX: Do not increment the latency
            ;; (add-latency wme *retrieval-threshold*)
            (signal-output *exact-matching-trace* "~S is not a CHUNK 
of type ~S."
                           wme wmetype)))))

(defparameter *rhs-pm-calls*
   '((visual-object
      (:vision move-attention)
      (screen-pos :location)
      (scale :scale))
     (visual-location
      (:vision find-location)
      (attended :attended)
      (screen-x :screen-x)
      (screen-y :screen-y)
      (value :value)
      (kind :kind)
      (color :color)
      (size :size)
      (nearest :nearest)
      (time))
     (start-tracking                     ; 01.11.10 mdb
      (:vision start-tracking)           ; missing entry added [again]
      (object nil))
     (click-mouse
      (:motor click-mouse))
     (hand-to-mouse
      (:motor hand-to-mouse))
     (hand-to-home
      (:motor hand-to-home))
     (move-cursor
      (:motor move-cursor)
      (object :object)
      (loc :loc)
      (device :device))
     (peck
      (:motor peck)
      (hand :hand)
      (finger :finger)
      (r :r)
      (theta :theta))
     (peck-recoil
      (:motor peck)
      (hand :hand)
      (finger :finger)
      (r :r)
      (theta :theta))
     (point-hand-at-key
      (:motor point-hand-at-key)
      (hand :hand)
      (to-key :to-key))
     (press-key
      (:motor press-key)
      (key nil))
     (punch
      (:motor punch)
      (hand :hand)
      (finger :finger))
     (speak
      (:speech speak)
      (string :text))                    ; 01.11.10 mdb fixed entry
     (sound
      (:audio attend-sound)
      (event :event))
     (audio-event
      (:audio find-sound)
      (attended :attended)
      (type :type)
      (onset :onset)
      (pitch :pitch))
     ))

(defmethod not-equal ((criterion number))
   (lambda (val)
     (not (equal val criterion))))

(defmethod not-equal ((criterion list))
   (not-equal (check-fct criterion)))

(defun translate-comparison-tests (clause)
   (let ((new-clause nil))
     (dolist (pair clause)
       (if (test-modifier (first pair))
         (let ((modifier (first pair)))
           (cond ((or (eq modifier '>) (eq modifier '>=))
                  (push-last (list (second pair) (list 'greater-than 
(third pair))) new-clause))
                 ((or (eq modifier '<) (eq modifier '<=))
                  (push-last (list (second pair) (list 'less-than 
(third pair))) new-clause))
                 ((eq modifier '-)
                  (push-last (list (second pair) (list 'not-equal 
(third pair))) new-clause))
                 (t (signal-warn "ILLEGAL TEST ~S APPLIED TO ~S ~S IN 
PRODUCTION ACTION."
                                 modifier (second pair) (third pair)))))
         (push-last pair new-clause)))
     (do ((rest-clause new-clause (rest rest-clause)))
         ((null rest-clause))
       (let* ((first-pair (first rest-clause))
              (other-pair (assoc (first first-pair) (rest rest-clause) 
:test #'eq)))
         (when other-pair
           (let ((arguments nil))
             (when (listp (second first-pair))
               (setf arguments (append arguments (second first-pair))))
             (when (listp (second other-pair))
               (setf arguments (append arguments (second other-pair))))
             (when (and (member 'less-than arguments :test #'eq)
                        (member 'greater-than arguments :test #'eq))
               (rplacd first-pair (list (list 'within (min (second 
arguments) (fourth arguments))
                                              (max (second arguments) 
(fourth arguments)))))
               (setf rest-clause (delete other-pair rest-clause)))))))
     new-clause))

(defun compile-rhs (production rhs bindings index)
   "Compiles the right-hand side of production."
   (let ((code nil)
         (returns nil)
         (goal-stack (list (variable-name (first bindings)))))
     (dolist (clause rhs)
       (let ((key (pop clause))
             (type nil)
             (assigns nil)
             (slot nil)
             (value nil)
             (negation nil))
         (setf code (nconc code
          (cond ((retrievalp key)
                 (setf key (var>var key))
                 (when (actionp key) (setf key (var=var key))) ;; 
strip out the +
                 (cond ((clearp key)  ;; clearing buffers
                        (setf key (var=var key))  ;; strip out the -
                        (cond ((member key '(visual manual aural 
vocal))  ;; clearing modules
                               (let ((command-call (list (case key
                                                           (visual :vision)
                                                           (aural :audio)
                                                           (manual :motor)
                                                           (vocal 
:speech)) 'clear)))
                                 (list (list 'action-command
                                             (sub-eval-vars (cons 
'list (quote-arguments command-call))
                                                            bindings)))))
                              ((assoc key *buffer-keywords*)  ;; 
clearing ACT-R buffers
                               (list (list 'assign-buffer key nil)))
                              (t
                               (signal-warn "UNKNOWN BUFFER ~S CANNOT 
CLEAR." key))))
                       ((and (or (assoc key *buffer-keywords*)
                                 ;; directly manipulate PM buffers
                                 (member key '(visual manual vocal aural
                                               =visual =manual =vocal =aural)))
                             (null (rest clause))
                             (null (rest (first clause)))
                             (listp (first (first clause))))
                        ;; assignment to buffer of result of function call
                        (list (list 'assign-buffer key
                                    (sub-eval-vars (first (first 
clause)) bindings))))
                       ((and (not (variablep key)) (assoc key *buffer-keywords*)
                             (null (rest clause)) (null (rest (first clause))))
                        ;; direct assignment to buffers, including 
goal focus and direct retrieval
                        (let ((binding (get-variable-binding (first 
(first clause)) bindings)))
                          (cond ((eq key 'goal)  ;; focus on goal
                                 (setf goal-stack (butlast goal-stack))
                                 (push-last key goal-stack)
                                 (list (list 'focus-fct
                                             (variable-index binding)
                                             (subgoal-returns key returns))))
                                ((eq key 'retrieval)   ;; direct retrieval
                                 (list (list 'handle-failure
                                             (if *enable-rational-analysis*
                                               'direct-test-and-bind-pm
                                               'direct-test-and-bind)
                                             (variable-index binding)
                                             type nil nil
                                             'assign-retrieval
                                             (variable-index binding))))
                                (t  ;; other buffer assignment
                                 (list (list 'assign-buffer key 
(variable-index binding)))))))
                       (t
                        (with-binding binding modify key bindings index
                          (cond (modify
                                 (setf type (variable-type binding))
                                 (if (and type (not (integerp type)))
                                   (when (eq 'isa (caar clause))
                                     (set-variable-type production 
type key (pop clause))
                                     (unless (or (eq type 
(variable-type binding))
                                                 (assoc key *buffer-keywords*))
                                       (signal-warn "TYPE OF VARIABLE 
~S IS BEING REDEFINED IN PRODUCTION ~A."
                                                    key production)))
                                   (set-variable-type production type 
key (pop clause))))
                                (t
                                 (set-variable-type production type 
key (pop clause))))
                          (when type
                            (cond ((or (eq 'retrieval key)
                                       (member (list '!retrieve! key) 
rhs :test #'equal))
                                   (let ((tests nil)
                                         (binds nil))
                                     (compile-lhs-slots tests binds)
                                     (list (list 'handle-failure
                                                 (if *enable-rational-analysis*
                                                   (if modify
                                                     'direct-test-and-bind-pm
                                                     'indirect-test-and-bind-pm)
                                                   (if modify
                                                     'direct-test-and-bind
                                                     'indirect-test-and-bind))
                                                 nil
                                                 type tests binds
                                                 'assign-retrieval
                                                 nil))))
                                  ;;; Partial implementation of RHS buffers.
                                  ;;; Full implementation will require 
further standardization of RPM conventions
                                  ((member key '(visual manual 
visual-location vocal aural aural-location))
                                   (let* ((fct-args (rest (assoc 
(wme-type-name type) *rhs-pm-calls* :test #'eq)))
                                          (command-call (copy-seq 
(first fct-args)))
                                          (argument-alist (rest fct-args)))
                                     (dolist (slot-value 
(translate-comparison-tests clause))
                                       (let* ((slot (first slot-value))
                                              (value (second slot-value))
                                              (mapping (assoc slot 
argument-alist)))
                                         (if mapping
                                           (setf command-call
                                                 (nconc command-call 
(if (second mapping) (list (second mapping) value)
 
(list value))))
                                           (signal-warn "SLOT ~S OF 
CHUNK ~S TYPE ~S IN PRODUCTION ~S IS UNDEFINED."
                                                        slot key type 
production))))
                                     (list (list 'action-command
                                                 (sub-eval-vars (cons 
'list (quote-arguments command-call))
                                                                bindings)))))
                                  ((member key '(visual-state 
manual-location manual-state vocal-location vocal-state aural-state))
                                   (signal-warn "RESERVED KEYWORD ~A 
NOT YET IMPLEMENTED." key))
                                  (t
                                   (compile-rhs-slots assigns returns binding)
                                   (cons
                                    (if modify
                                      (list 'modify-old-wme 
(variable-index binding)
                                            type assigns)
                                      (list 'create-new-wme 
(variable-index binding)
                                            (if (variablep key) 
(var=var key) key) type assigns))
                                    (when (and (or (eq '=newgoal key) 
(eq 'newgoal key) (eq 'goal key))
                                               (not (member (list 
'!push! key) rhs :test #'equal))
                                               (not (member (list 
'!focus-on! key) rhs :test #'equal)))
                                      (setf goal-stack (butlast goal-stack))
                                      (push-last key goal-stack)
                                      (list (list 'focus-fct
                                                  (variable-index binding)
                                                  (subgoal-returns key 
returns))))))))))))
                ((eq '!retrieve! key) ;; do nothing since retrieval already done
                 nil)
                ((eq '!push! key)
                 (let* ((subgoal (first clause))
                        (binding (get-safe-variable-binding subgoal 
bindings production)))
                   (when binding
                     (push-last subgoal goal-stack)
                     (list (list 'push-fct
                                 (variable-index binding)
                                 (subgoal-returns subgoal returns))))))
                ((eq '!pop! key)
                 ;;; FIX: pop from the end of the stack
                 (setf goal-stack (butlast goal-stack))
                 (list (list 'pop-fct)))
                ((eq '!focus-on! key)
                 (let* ((subgoal (first clause))
                        (binding (get-safe-variable-binding subgoal 
bindings production)))
                   (when binding
                     ;;; FIX: do not assume that there is something on the stack
                     (setf goal-stack (butlast goal-stack))
                     (push-last subgoal goal-stack)
                     (list (list 'focus-fct
                                 (variable-index binding)
                                 (subgoal-returns subgoal returns))))))
                ((eq '!output! key)
                 (list (list 'output (compile-output clause bindings 
production))))
                ((eq '!eval! key)
                 (list (list 'eval-side (sub-eval-vars (first clause) 
bindings))))
                ((eq '!bind! key)
                 (with-binding binding bound (first clause) bindings index
                   (when bound
                     (signal-warn "VARIABLE ~S ALREADY BOUND IN PRODUCTION ~A."
                                  (first clause) production))
                   (list (list 'bind-rhs (variable-index binding)
                               (sub-eval-vars (second clause) bindings)))))
                ((eq '!move-attention! key)
                 (with-binding binding bound (first clause) bindings index
                   (when bound
                     (signal-warn "VARIABLE ~S ALREADY BOUND IN PRODUCTION ~A."
                                  (first clause) production))
                   (list (list 'bind-move-attention (variable-index binding)
                               (sub-eval-vars (cons 'list 
(quote-arguments (rest clause)))
                                              bindings)))))
                ((eq '!press-key! key)
                 (list (list 'visual-action 'press-key
                             (sub-eval-vars (cons 'list 
(quote-arguments clause))
                                            bindings))))
                ((eq '!move-mouse! key)
                 (list (list 'visual-action 'move-mouse
                             (sub-eval-vars (cons 'list 
(quote-arguments clause))
                                            bindings))))
                ((eq '!click-mouse! key)
                 (list (list 'visual-action 'click-mouse
                             (sub-eval-vars (cons 'list 
(quote-arguments clause))
                                            bindings))))
                ((eq '!send-command! key)
                 (list (list 'action-command
                             (sub-eval-vars (cons 'list 
(quote-arguments clause))
                                            bindings))))
                ((eq '!delete! key)
                 (let ((binding (get-safe-variable-binding (first 
clause) bindings production)))
                   (when binding
                     (list (list 'delete-wme-variable (variable-index 
binding))))))
                ((or (eq '!copy! key) (eq '!copywme! key))
                 (with-binding binding bound (first clause) bindings index
                   (when bound
                     (signal-warn "VARIABLE ~S ALREADY BOUND IN PRODUCTION ~A."
                                  (first clause) production))
                   (list (list 'copy-chunk-variable (variable-index binding)
                               (sub-eval-vars (cons 'list (rest clause))
                                              bindings)))))
                ((eq '!stop! key)
                 (list (list 'stop)))
                ((eq '!restart! key)
                 (list (list 'restart-top-goal)))
                (t (signal-warn "UNKNOWN COMMAND ~S IN PRODUCTION ~A." 
key production)))))))
     ; remove the unknown commands
     ; (setf code (delete nil code :test #'eq))
     ; translate wme variables into relative goal stack indices for 
value returns
     (dolist (return returns)
       (let ((from-position
              (position (variable-name (variable-index return))
                        goal-stack :test #'eq)))
         (if from-position
           (dolist (destination (variable-returns return))
             (let ((to-position (position (first destination) 
goal-stack :test #'eq)))
               (if (and (numberp to-position) (> from-position to-position))
                 (rplaca destination (- from-position to-position 1))
                 (signal-warn "VARIABLE ~A CANNOT BE RETURNED BECAUSE 
CHUNK ~A IS NOT ON THE STACK BELOW SUBGOAL ~A IN PRODUCTION ~A."
                        (variable-name return) (first destination)
                        (variable-name (variable-index return)) production))))
           (signal-warn "VARIABLE ~A CANNOT BE RETURNED BECAUSE CHUNK 
~A IS NOT ON THE STACK IN PRODUCTION ~A."
                        (variable-name return)
                        (variable-name (variable-index return)) production))))
     (values code bindings index)))



;;;
;;; ACT-R 5.0
;;;

;;;
;;; COPYRIGHT
;;;

(defun act-r-copyright ()
   (format t "~&ACT-R VERSION 5.0b0~%REPORT BUGS TO CL+@CMU.EDU~%~
              +------------------------------------------------------------+~%~
              |                           ACT-R 5.0                        |~%~
              |                           (c) 2000                         |~%~
              |            Christian Lebiere   John R. Anderson            |~%~
              |    Department of Psychology, Carnegie Mellon University    |~%~
              |         Supported by ONR Contract N00014-95-10223          |~%~
              +------------------------------------------------------------+~%")
   (values))

(act-r-copyright)

;;;
;;; VARIABLE, STRUCTURE AND ACCESS MACRO DEFINITIONS
;;;

;;; Global System Variables

(defvar *compile-eval-calls* nil
   "Do not compile !eval! and other Lisp calls at production definition.")

(defvar *model* nil
   "Holds the file name of the current model and its contents.
    Set by clear-all and used by reset and reload.")

(defvar *time* 0.0
   "The real-time counter.")

(defvar *start-time* 0.0
   "The real-time counter.")

(defvar *default-action-time* 0.05
   "The default time to execute a right-hand side is 50 milliseconds.")

(defvar *latency* 0.0
   "Latency of conflict resolution process.")

(defvar *cycle* 0
   "The production firing cycle counter.")

(defvar *spread-stamp* 0
   "The stamp for activation spreading.  Similar to *cycle*,
    but may clock faster due to interactive manipulation of sources,
    or slower when rational analysis is turned off.")

(defvar *wme-number* 0.0
   "Holds the count of the total number of wmes in declarative memory.")

(defvar *declarative-memory* nil
   "Holds a list of wme types indexed by name, with for each type its
    definition (with possible subtypes) and the list of wmes of that type.")

(defvar *hash-names* nil
   "Holds for each wme name a pointer to its structure.  Primarily used
    to load the data base and for interfacing, not at run-time when
    direct pointers are used instead of names to hash.")

(defvar *used-ACT-R-symbols* nil
   "Holds a list of all the temporary symbols interned
    by ACT-R so they can be freed on a reset.")

(defvar *procedural-memory* nil
   "Holds a list of productions indexed by names.")

(defvar *goal-activation* 1.0
   "Amount of activation source level to be evenly split among goal elements.")

(defvar *goal-sources* nil
   "Activation sources existing after the current goal is pushed.")

(defvar *wmfocus* nil
   "The top goal.")

(defvar *wmfocus-list* nil
   "The list of goals to focus on specified by the expanded form of wmfocus.")

(defvar *goal-stack* nil
   "Holds the stack of goal, with the top-most at the front of the list.")

(defvar *goal-depth* 1
   "The depth of the goal stack, times 3 plus 1, to be used for 
indenting traces.")

(defvar *g* 20.0
   "The value of G in PG-C.  Default is 20.0 for historical reasons.")

(defvar *exp-gain-noise* nil
   "Variance of the zero-mean gaussian noise added to instantiation values.")

(defvar *retrieval* nil
   "Holds the last chunk retrieved from declarative memory.")

(defvar *retrieval-scheduler* nil
   "Holds the result of the next retrieval and the time at which it 
will be available.")

(defvar *visual-location* nil
   "Holds the result of the last find-location.")

(defvar *aural-location* nil
   "Holds the result of the last find-sound")

(defvar *previous-instantiations* nil
   "The list of instantiations from the previous resetting.")

(defvar *previous-instantiation* nil
   "The previous instantiation and its time for use in production compilation.")

(defvar *instantiation* nil
   "The current instantiation as a global variable to limit parameter passing
    and allow references in eval statements.")

(defvar *extra-instantiation* nil
   "List of previously generated instantiations of a given production,
    or instantiation to store activations if partial matching is on.")

(defvar *conflict-set* nil
   "The conflict set holds the list of current instantiations.")

(defvar *sum-exp-act* 0.0
   "Holds the sum of the exponential of activations for scaling latencies.")

(defvar *latency-fn*  'old-latency
   "The function used in computing retrieval latency from chunk(s) activation.")

(defvar *latency-factor* 1.0
   "The latency scaling factor B in the latency equation ROM (3.3).")

(defvar *latency-exponent* 1.0
   "The activation scaling factor b in the latency equation ROM (3.3).")

(defvar *base-level-constant* 0.0
   "The base level constant, i.e. B in ROM Equation 4.3")

(defvar *activation-sources* nil
   "List of activation sources and their source level.")

(defvar *activation-noise* nil
   "Variance of the zero-mean gaussian noise added to activation.")

(defvar *permanent-activation-noise* nil
     "Variance of the zero-mean gaussian noise permanently added to 
activation.")

(defvar *mismatch-penalty* 1.0
   "Maximum mismatch penalty, in activation units, in partial matching.")

(defvar *retrieval-threshold* nil
   "Minimum amount of activation needed for retrieval.
    Nil by default (N/A) but switch to default of 0.0 for partial matching.")

(defvar *partial-matching* nil
   "Triggers partial matching.")

(defvar *max-sim* 1.0
   "Maximum similarity between two values, presumably in case of identity.")

(defvar *max-dif* -10.0
   "Maximum difference between two values, presumably for complete mismatches.")

(defvar *temperature* 1.0
   "When set (symbol :tmp) to a positive number, it is used instead of 
(sqrt 2 *)
    the activation noise as the scaling factor in the blending process.")

(defvar *blending* nil
   "Triggers blending (symbol :bln).  If set to 'rt, then blending
    occurs only after standard retrieval fails to reach threshold.")

(defvar *blending-trace* nil
   "Triggers the blending trace (symbol :blt).")

(defvar *blending-activation-fn* 'first-equation
   "Defines the activation of the blended value as a function of the activations
   of the individual chunks and the similarities between their values.")

(defvar *break-productions* nil
   "Holds the productions on which to break before firing.")

(defvar *failed-productions* nil
   "Holds the failed productions.")

(defvar *cost-penalty* 1.0
   "Cost Penalty for new productions.")

(defvar *initial-experience* 10.0
   "Initial Experience (total successes and failures) for new productions.")

(defvar *threshold-time* 2.0
   "Threshold of time between production firings to allow production 
rule learning.")

(defvar *enable-production-learning* nil
   "Triggers production rule learning.")

(defvar *reinforce-analogized-production* t
   "Whether or not to reinforce a production when it is re-analogized.")

(defvar *production-compilation-parameters* nil
   "Holds the argument list to the parameters command for compiled productions")

(defvar *enable-rational-analysis* nil
   "Triggers the activation and rational analysis computation.")

(defvar *enable-randomness* nil
   "When on, ranks instantiations randomly instead of according to
    some deterministic but arbitrary order.")

(defvar *utility-threshold* 0.0
   "Minimum utility (pg-c) needed for production selection.  0.0 by default,
    but can be set to any number or even NIL when no thresholding is desired.")

(defvar *optimized-learning* t
   "Mode of learning base levels and production strength which ensures
    constant space and time demands.  Generalized to take a fixed 
number of references.")

(defvar *base-level-learning* nil
   "The trigger for base level learning, d in ROM Equation 4.4.
    Should be less than 1.0 for the optimized learning formula to apply.")

(defvar *associative-learning* nil
   "The trigger for associative learning, a in ROM Equation 4.5.
    Can be any non-negative value.")

(defvar *strength-learning* nil
   "The trigger for learning production strength, d in ROM Equation 4.6.
    Should be less than 1.0 for the optimized learning formula to apply.")

(defvar *parameters-learning* nil
   "The trigger for learning production parameters in ROM Equations 4.7 and 4.8.
    True or false.")

(defvar *command-trace* t
   "Directs the output of the user-level commands.  Not included in sgp.")

(defvar *output-trace* t
   "Directs the printing of !output! command.")

(defvar *cycle-trace* t
   "Prints the name of production to fire at every cycle.")

(defvar *latency-trace* nil
   "Prints the latency of matching and action side of firing production.")

(defvar *partial-matching-trace* nil
   "Prints all information relevant to partial matching.")

(defvar *production-compilation-trace* t
   "Prints the trace of the production compilation process.")

(defvar *activation-trace* nil
   "Prints the activation computation for wmes and instantiations.")

(defvar *conflict-resolution-trace* nil
   "Prints the conflict resolution at work.")

(defvar *conflict-set-trace* nil
   "Prints the number of instantiations considered out of the conflict set
    total, and the expected gain of the winning instantiation.")

(defvar *goal-trace* nil
   "Prints goal pushing and popping.")

(defvar *dm-trace* nil
   "Prints addition or deletion of wmes during execution.")

(defvar *production-trace* nil
   "Prints a description of each production instantiation fired.")

(defvar *matches-trace* nil
   "Prints a description of all instantiations.")

(defvar *exact-matching-trace* nil
   "Prints a trace of every (non-partial) match.")

(defvar *verbose* t
   "When off, turns off all but essential printing.")

(defvar *abort-instantiation* t
   "Determines whether or not an instantiation can be aborted by a time limit
    or allowed to complete.")

(defvar *parameter-sets* nil
   "Holds the parameter sets in a-list format.")

(defvar *similarity-hook-fn* nil
   "If non-nil, call this function to get similarity values.  If it returns nil,
    then the usual process of looking up similarities in wmes and comparing
    non-wmes for equality is used.")

(defvar *linear-similarity-scale* 1.0
   "Scale for linear-similarity: similarity = difference / scale.")

(defvar *blending-hook-fn* 'blending-arithmetic-mean
   "Defines the direct averaging for number values.")

(defvar *conflict-set-hook-fn* nil
   "If non-nil, call this function before conflict resolution with the 
conflict set.
    If it returns an instantiation, then fires that one, otherwise run 
as usual.")

(defvar *firing-hook-fn* nil
   "if non-nil, called for side-effect with the instantiation before 
its firing.")

(defvar *cycle-hook-fn* nil
   "If non-nil, call this function after each cycle with the 
instantiation fired.")

(defvar *web-hook-fn* nil
   "If non-nil, call this function after each cycle with the 
instantiation fired.
    Same as *cycle-hook-fn*, but used specifically by ACT-R-on-the-web.")

(defvar *end-run-hook-fn* nil
   "If non-nil, call this function at the end of a run with the total 
run latency.")

(defvar *init-hook-fn* nil
   "if non-nil, call this function after clear-all with no arguments.")

(defvar *step-fn* 'step-fct
   "If non-nil, call this function at each step of pstep to get user 
instruction.")

(defvar *stop* nil
   "If non-nil, stops the run function before the next cycle.")

(defvar *save-state-changes* nil
   "If non-nil, the state changes are saved for later undoing.")

(defvar *pop-upon-failure* nil
   "If non-nil, then pop the focus when no suitable instantiation can be found.
    If nil, then stop the run as in previous versions without taking 
any action.")

(defconstant *buffer-keywords*
   '((=goal . *wmfocus*)
     (goal . *wmfocus*)
     (=retrieval . *retrieval*)
     (retrieval . *retrieval*)
     (=visual-location . *visual-location*)
     (visual-location . *visual-location*)
     (=aural-location . *aural-location*)
     (aural-location . *aural-location*))
   "Holds the alist of special buffers with their associated special variables.
    Works for both variable and constant names.")

(defconstant *command-mappings*
   '((ACTIVATION-SOURCES ACTIVATIONSOURCES) (ACTR-TIME ACTRTIME)
     (ADD-DM ADDWM) (ADD-IA ADDIA) (CHUNK-SLOT-VALUE WMESLOTVALUE)
     (CHUNK-TYPE WMETYPE) (CLEAR-ALL CLEARALL) (CLEAR-DM CLEARWM)
     (CLEAR-GOAL-STACK CLEARGOALSTACK)
     (CLEAR-PRODUCTIONS CLEARPRODUCTIONS) (CLOSE-OUTPUT CLOSEOUTPUT)
     (CLOSE-TRACE CLOSETRACE) (COPY-CHUNK COPYWME)
     (DELETE-CHUNK DELETEWM) (DM WM) (FOCUS-ON-GOAL FOCUS-ON-WME)
     (GET-BASE-LEVEL GETBASELEVEL) (GOAL-FOCUS WMFOCUS)
     (GOAL-STACK GOALSTACK) (HELP NIL) (IA IA)
     (IMPORT-MODEL IMPORT-MODEL) (LOAD-MODEL LOAD-MODEL)
     (MOD-CHUNK MODWME) (MOD-FOCUS MODFOCUS) (NAME NAME)
     (NO-OUTPUT NO-OUTPUT) (OUTPUT-STREAM OUTPUTSTREAM)
     (P P) (PARAMETERS PARAMETERS) (PBREAK PBREAK)
     (PDISABLE PDISABLE) (PENABLE PENABLE) (PMATCHES PMATCHES)
     (POP-GOAL POP-WME) (PP PP)
     (PRODUCTION-PARAMETER PRODUCTION-PARAMETER) (PSET PSET)
     (PSTEP PSTEP) (PUNBREAK PUNBREAK) (PUNDO PUNDO)
     (PUSH-GOAL PUSH-WME) (RELOAD RELOAD) (RESET RESET)
     (RESET-IA RESETIA) (RUN RUN) (RUN-MANY RUN-MANY) (SDM SWM)
     (SDP SWP) (SET-ALL-BASE-LEVELS SETALLBASELEVELS)
     (SET-COMPILATION-PARAMETERS SETANALOGIZEDPARAMETERS)
     (SET-BASE-LEVELS SETBASELEVELS) (SET-DM SETWM) (SET-G SETG)
     (SET-GENERAL-BASE-LEVELS SETGENERALBASELEVELS) (SET-IA SETIA)
     (SET-SIMILARITIES SETSIMILARITIES) (SGP SGP) (SIMILARITY SIMILARITY)
     (SPP SPP) (TRACE-STREAM TRACESTREAM) (UPDATE-ACTIVATION UPDATE-ACTIVATION)
     (WHYNOT WHYNOT) (WHYNOT-DEPENDENCY WHYNOT-ANALOGY)))


;;; Error, Abort, Warning and Output functions.  Plus Save State Changes.

(defmacro signal-error (message &rest arguments)
   "Signals an error and stops."
   `(error ,message ,@arguments))

(defmacro signal-warn (message &rest arguments)
   "Outputs a warning of message and arguments."
   `(format *error-output* ,(concatenate 'string "~&~VT" message)
            ,@(cons '*goal-depth* arguments)))

(defmacro signal-output (stream message &rest arguments)
   "Outputs message and arguments when verbose.  Prints by default in 
lowercase."
   `(when (and *verbose* ,stream)
      (let ((*print-case* :downcase))
        (format ,stream ,(concatenate 'string "~&~VT" message)
                ,@(cons '*goal-depth* arguments)))))

(defmacro save-state-change (&rest change)
   "Save the state change."
   `(when *save-state-changes*
      (push (list ,@change) *save-state-changes*)))

;;; WME Types as structures

(defun print-wme-type (wmetype stream depth)
   "Print a wme type as just its name, in uppercase."
   (declare (ignore depth))
   (format stream "~:@(~A~)" (wme-type-name wmetype)))

(defstruct (wme-type (:print-function print-wme-type))
   "Holds the wmetype name, lists of subtypes and supertypes including itself
    as the first of each, the size of the wme (number of slots),
    a list of slots containing name, index and default value,
    a list of productions in which this type is used as goal type,
    and the list of wmes of that type.  Also the documentation string."
   name subtypes supertypes size slots productions wmes documentation)


;;; Declarative Memory as an a-list of types

(defmacro get-type (type)
   "Returns the structure corresponding to type."
   `(cdr (assoc ,type *declarative-memory* :test #'eq)))

(defmacro get-safe-type (type &optional context)
   "Calls get-type, and prints an error if undefined."
   `(if (wme-type-p ,type) ,type
        (or (get-type ,type)
            (signal-warn "CHUNK TYPE ~S IS UNDEFINED IN ~A." ,type ,context))))

(defmacro for-all-wmes (wme &rest form)
   "Execute forms where wme cycles through all wmes in declarative memory."
   `(dolist (wme-type *declarative-memory*)
      (dolist (,wme (wme-type-wmes (cdr wme-type)))
        ,@form)))


;;; WMEs as structures

(defun print-wme (wme stream depth)
   "Print a wme as just its name, capitalized."
   (declare (ignore depth))
   (format stream "~:(~A~)" (wme-name wme)))

(defstruct (wme (:print-function print-wme))
   "WMEs are represented as structures, with the slots as a slot array."
   name type fan (slot-wmes (list 0.0)) ias similarities
   (creation-time *time*) (creation-cycle *cycle*) (time-stamp (- *time* 1.0))
   (activation *base-level-constant*) (base-level *base-level-constant*)
   (spread-stamp (- *spread-stamp* 1.0)) (source-spread 0.0)
   (references (cons 1.0 (when (and *base-level-learning* (not (eq 
*optimized-learning* t)))
                           (list *time*))))
   (contexts 0.0) (needed 0.0) slots source (permanent-noise 0.0) documentation)

(defmacro slots-slot (slots index)
   "Given the slots subarray, return the index value."
   `(svref ,slots ,index))

(defmacro wme-slot (wme index)
   "Given a wme and a slot index, return the slot value."
   `(slots-slot (wme-slots ,wme) ,index))

(defmacro wmep (wme)
   "Determines if argument is a wme."
   `(wme-p ,wme))

;;; Slot Descriptions as lists to gain on search time (assoc)

(defmacro make-slot (&key name index default)
   "A slot is a list of its name, index, and default value."
   `(list ,name ,index ,default))

(defmacro slot-name (slot)
   "Given a slot description, return its name."
   `(first ,slot))

(defmacro slot-index (slot)
   "Given a slot description, return its index."
   `(second ,slot))

(defmacro slot-default (slot)
   "Given a slot description, return its default."
   `(third ,slot))

(defmacro get-slot (name slots)
   "Get description of slot name from list of slots."
   `(assoc ,name ,slots :test #'eq))

(defmacro get-safe-slot (name type &optional context)
   "Get slot name from type, or print an error if non-existant.  Cache name."
   `(or (get-slot ,name (wme-type-slots ,type))
        (signal-output *command-trace*
                       "SLOT ~S OF TYPE ~S IS UNDEFINED IN ~A."
                       ,name ,type ,context)))

(defmacro get-slot-value (wme slot)
   "Given a wme and a slot name, return its value if the slot exists."
   `(let ((index (get-slot ,slot (wme-type-slots (wme-type ,wme)))))
      (when index (wme-slot ,wme (slot-index index)))))

(defmacro get-safe-slot-value (wme slot)
   "Given a wme and a slot name, return its value if the slot exists.
    Complain otherwise."
   `(let ((index (get-safe-slot ,slot (wme-type ,wme) ,wme)))
      (when index (wme-slot ,wme (slot-index index)))))


;;; Hash Table of wme names

(defmacro get-wme (name)
   "Given a wme name, returns the wme itself."
   `(gethash ,name *hash-names*))

(defun get-wme-name (wme)
   "Get the name of wme, or return directly if not a wme."
   (if (wmep wme) (wme-name wme) wme))

(defmacro get-safe-wme (name &optional (warn t))
   "Gets the wme corresponding to name.  Prints an error message if undefined."
   `(if (wmep ,name) ,name
        (or (get-wme ,name)
            ,(if warn
               `(signal-warn "CHUNK ~S IS UNDEFINED." ,name)
               `(signal-output *command-trace* "CHUNK ~S IS 
UNDEFINED." ,name)))))

(defun get-wme-or-constant (name)
   "Returns the wme corresponding to name, or the name if none.  Detects nil.
    Now automatically defines non-wme symbols as of the default type wme."
   (cond ((null name) nil)
          ((eq name t) t)  ;; t, like nil, is also given special status
          ((wmep name) name)
          ((get-wme name))
          ((symbolp name)
;          (signal-output *command-trace* "UNDEFINED CHUNK ~S IS 
BEING CREATED AS OF DEFAULT TYPE CHUNK."
;                       name)
           (create-wme name (cdar *declarative-memory*)))
          (t name)))

(defmacro remove-name (name)
   "Given a wme name, remove its entry from the hash table."
   `(remhash ,name *hash-names*))


;;; IA values as structures of 3 elements, indexed by wme in an a-list

(defun print-ia (ia stream depth)
   "Print an ia as just its sji."
   (declare (ignore depth))
   (format stream "~6,3F" (ia-sji ia)))

(defstruct (ia (:print-function print-ia))
   "An ia-link to wme i is indexed by the wme j and composed of its count
    (the number of times it appears in wme i), the current Sji value,
    the Rji* prior, and the F(Ni&Cj) statistics."
   (count 1)
   (sji 0.0)
   (rji* 1.0)
   (fnicj 0.0))

(defmacro default-rji* (wmej)
   "The default value of Rji* for that wme, i.e. m/n."
   `(/ *wme-number* (first (wme-fan ,wmej))))

(defmacro count-rji* (ia value)
   "Computes the value of Rji* of ia given the default value."
   `(if (<= (ia-count ,ia) 1)
      ,value
      (* ,value (ia-count ,ia))))

(defmacro rji-sji (rji)
   "Sji in terms of rji, i.e. log of rji."
   `(log ,rji))

(defmacro count-sji (ia value)
   "Computes Sji of ia from the default value."
   `(if (<= (ia-count ,ia) 1)
      ,value
      (+ ,value (log (coerce (ia-count ,ia) *read-default-float-format*)))))

(defmacro learn-rji (ia wmej wmei)
   "Computes rji for ia between wmej and wmei based on ROM Equation 4.5."
   `(/ (+ (* *associative-learning* (ia-rji* ,ia))
          (if (= (wme-needed ,wmei) 0.0)
            ; Eji defaults to 1 so Rji defaults to 0
            (wme-contexts ,wmej)
            (* (ia-fnicj ,ia)
               (/ (- *cycle* (wme-creation-cycle ,wmei))
                  (wme-needed ,wmei)))))
       (+ *associative-learning* (wme-contexts ,wmej))))

(defmacro compute-ia (wmej ia wmei)
   "Initializes the IA connection from wmej to wmei."
   `(let ((rji* (count-rji* ,ia (default-rji* ,wmej))))
      (setf (ia-rji* ,ia) rji*)
      (setf (ia-sji ,ia)
            (rji-sji (if *associative-learning* (learn-rji ,ia ,wmej 
,wmei) rji*)))))

(defmacro create-ia (wmej wmei &key (count 1) (sji 0.0) (rji* 1.0))
   "Creates an IA connection between wmej and wmei.
    Count indicates whether the wmes are connected or not (learned)."
   `(let ((ia (make-ia :count ,count :sji ,sji :rji* ,rji*)))
      (push (cons ,wmej ia) (wme-ias ,wmei))
      ia))

(defmacro ia-value (ia wmej wmei)
   "Compute new IA if necessary, and return the ia value."
   `(if (and *associative-learning* (< (wme-spread-stamp ,wmei) *spread-stamp*))
      (setf (ia-sji ,ia) (rji-sji (learn-rji ,ia ,wmej ,wmei)))
      (ia-sji ,ia)))

(defmacro delete-ia (wmej wmei)
   "Deletes the ia-link between two wmes."
   `(setf (wme-ias ,wmei)
          (delete ,wmej (wme-ias ,wmei) :test #'eq :key #'car :count 1)))

(defmacro get-ia (wmej wmei)
   "Retrieves the ia-link between two wmes."
   `(cdr (assoc ,wmej (wme-ias ,wmei) :test #'eq)))

(defmacro get-safe-ia (wmej wmei)
   "Gets the ia between wmej and wmei, or prints an error message if none."
   `(or (get-ia ,wmej ,wmei)
        (signal-warn "IA BETWEEN ~S AND ~S IS UNDEFINED." ,wmej ,wmei)))

(defmacro get-make-ia (wmej wmei)
   "Gets the ia between wmej and wmei, or adds it if none."
   `(or (get-ia ,wmej ,wmei)
        (create-ia ,wmej ,wmei :count 0)))

(defmacro remove-connection (wmej wmei &key (compute-ia t))
   "Remove the connection between two wmes."
   `(let ((ia (get-safe-ia ,wmej ,wmei)))
      (decf (first (wme-fan ,wmej)) 1.0)
      (delete ,wmei (wme-fan ,wmej) :test #'eq :count 1)
      (decf (first (wme-slot-wmes ,wmei)) 1.0)
      (delete ,wmej (wme-slot-wmes ,wmei) :test #'eq :count 1)
      (if (= (decf (ia-count ia) 1) 0)
        (delete-ia ,wmej ,wmei)
        ,@(when compute-ia
            `((compute-ia ,wmej ia ,wmei))))))

(defmacro add-connection (wmej wmei &key (compute-ia t))
   "Adds a connection between two wmes."
   `(let ((ia (get-ia ,wmej ,wmei)))
      (incf (first (wme-fan ,wmej)) 1.0)
      (push ,wmei (rest (wme-fan ,wmej)))
      (incf (first (wme-slot-wmes ,wmei)) 1.0)
      (push ,wmej (rest (wme-slot-wmes ,wmei)))
      (if ia
        (incf (ia-count ia) 1)
        (setf ia (create-ia ,wmej ,wmei)))
      ,@(when compute-ia
          `((compute-ia ,wmej ia ,wmei)))))

(defmacro set-slot-value (wme slot-index value &key (compute-ia t))
   "Sets wme slot index to value.  Maintains the proper connections.
    Tests for analogy special slots."
   `(let ((old-value (wme-slot ,wme ,slot-index))
          (new-value ,value))
      (save-state-change :set-slot-value ,wme ,slot-index old-value)
      (when (wmep old-value)
        (remove-connection old-value ,wme :compute-ia ,compute-ia))
      (when (wmep new-value)
        (add-connection new-value ,wme :compute-ia ,compute-ia))
      (setf (wme-slot ,wme ,slot-index) new-value)))


;;; Similarities as a-lists

(defmacro find-similarity (wmej wmei)
   "Returns the cons-cell holding the similarity between wmej and wmei, or nil."
   `(assoc ,wmei (wme-similarities ,wmej) :test #'eq))

(defmacro get-similarity (wmej wmei)
   "Retrieves the similarity between wmej and wmei, in that order, or 0.0."
   `(or (and *similarity-hook-fn* (funcall *similarity-hook-fn* ,wmej ,wmei))
        (if (and (wmep ,wmej) (wmep ,wmei))
          (or (cdr (find-similarity ,wmej ,wmei)) *max-dif*)
          (if (equal ,wmej ,wmei) *max-sim* *max-dif*))))

(defmacro set-similarity (wmej wmei similarity)
   "Sets the similarity between wmej and wmei to similarity."
   `(let ((existing (find-similarity ,wmej ,wmei)))
      (if existing
        (rplacd existing ,similarity)
        (push-last (cons ,wmei ,similarity) (wme-similarities ,wmej)))))

;;; Productions as structures

(defun print-production (production stream depth)
   "Print a production as just its name, capitalized."
   (declare (ignore depth))
   (format stream "~:(~A~)" (production-name production)))

(defstruct (production (:print-function print-production) (:predicate 
productionp))
   "Productions are represented as structures which hold the usual info,
    plus a list of instantiations for reuse."
   name goal-type text lhs rhs bindings retrievals initializations
   size instantiation extra-instantiation
   (creation-time *time*) (time-stamp (- *time* 1.0))
   (references (cons 1.0 (when (and *strength-learning* (not 
*optimized-learning*))
                           (list *time*))))
   (strength 0.0) success failure (chance 1.0) (effort *default-action-time*)
   (value 0.0) (p 1.0) (c *default-action-time*) pg-c
   (successes (cons 1.0 (when (numberp *parameters-learning*) (list *time*))))
   (failures (list 0.0))
   (efforts (cons *default-action-time* (when (numberp *parameters-learning*)
                                          (list *default-action-time*))))
   documentation)

;;; Productions stored in a-list of name-structure pair for easy search

(defmacro get-production (name &optional (productions '*procedural-memory*))
   "Returns the production of a given name, if any, or nil."
   `(cdr (assoc ,name ,productions :test #'eq)))

(defmacro get-safe-production (name &optional (productions 
'*procedural-memory*))
   "Returns the production of a given name, or prints a warning."
   `(if (productionp ,name) ,name
        (or (get-production ,name ,productions)
            (signal-warn "PRODUCTION ~S IS UNDEFINED." ,name))))


;;; Instantiations as arrays

(defconstant *instantiation-slots* 3
   "Specifies the number of common slots for each instantiation.
    Currently, the production, latency and gain.")

(defmacro instantiation-production (instantiation)
   "Given an instantiation, returns the production."
   `(svref ,instantiation 0))

(defmacro instantiation-latency (instantiation)
   "Given an instantiation, returns its latency."
   `(svref ,instantiation 1))

(defmacro instantiation-gain (instantiation)
   "Given an instantiation, returns its expected gain."
   `(svref ,instantiation 2))

(defmacro instantiation-variable (instantiation index)
   "Given an instantiation and a variable index, returns the binding value."
   `(svref ,instantiation ,index))

(defmacro make-instantiation (production)
   "Create a new instantiation with the given production size."
   `(let ((instantiation (make-array (production-size ,production)
                                     :initial-element nil)))
      (setf (instantiation-production instantiation) ,production)
      instantiation))

(defmacro get-next-instantiation (production)
   "Picks the next instantiation from *extra-instantiation*,
    or generate a new one and add it to the list for production."
   `(or (pop *extra-instantiation*)
        (first (push (make-instantiation ,production)
                     (production-extra-instantiation ,production)))))

(defmacro copy-instantiation (instantiation)
   "Makes a copy of an instantiation for keeping in *previous-instantiations*."
   `(copy-seq ,instantiation))


;;; Variable Bindings

(defmacro make-variable-binding (name index &key (type-or-slot nil))
   "Creates a binding for variable name of stack index.  Type-or-slot
    indicates the wme type for actual retrievals and slot number for others.
    List to make it searchable by assoc.
    NOTE: Return arguments depend on this format to work correctly!"
   `(list ,name ,index ,type-or-slot))

(defmacro variable-name (binding)
   "Returns the variable name from binding."
   `(first ,binding))

(defmacro variable-index (binding)
   "Returns the variable stack index from binding."
   `(second ,binding))

(defmacro variable-type (binding)
   "Returns the variable type from binding."
   `(third ,binding))

(defmacro variable-slot (binding)
   "Returns the index of the slot from which this variable is bound."
   `(third ,binding))

(defmacro variable-slot-and-returns (binding)
   "Returns the index of the slot from which this variable is bound,
    and the following return indices."
   `(cddr ,binding))

(defmacro variable-returns (binding)
   "Returns the return bindings which are pushed at the end of the list."
   `(cdddr ,binding))

(defmacro get-variable-binding (variable bindings)
   "Retrieves the binding of variable from the a-list of variable bindings."
   `(assoc ,variable ,bindings :test #'eq))

(defmacro get-safe-variable-binding (variable bindings &optional context)
   "Retrieves the binding of variable from the a-list of variable bindings.
    Prints a warning if no such variable binding exists."
   `(or (get-variable-binding ,variable ,bindings)
        (signal-warn "VARIABLE ~S IS UNBOUND IN ~A." ,variable ,context)))

(defmacro get-index-binding (index bindings)
   "Retrieves the variable binding index from the a-list of variable bindings."
   `(rassoc ,index ,bindings :test #'eq :key #'car))

(defmacro with-binding (binding existing variable bindings index &rest form)
   "Gets the binding of variable, or add a new one to bindings at index.
    Existing is set as to whether binding existed previously.
    Then form is evaluated with binding and existing bound."
   `(let ((,binding (get-variable-binding ,variable ,bindings))
          (,existing t))
      (unless ,binding
        (setf ,binding (make-variable-binding ,variable (incf ,index 1)))
        (push-last ,binding ,bindings)
        (setf ,existing nil))
      ,@form))


;;; Action Description

(defstruct action
   "Creates an action consisting of a slot name and index, a value to be bound
    or tested, a dispatch keyword {:stack, :literal, or :eval} and a 
negation flag."
    name slot value dispatch negation)


;;; Goal Stack Frames

(defun print-goal-frame (goal-frame stream depth)
   "Print a goal frame as just its focus."
   (declare (ignore depth))
   (format stream "~A" (goal-frame-focus goal-frame)))

(defstruct (goal-frame (:print-function print-goal-frame))
   "Creates a goal stack frame containg the focus,
    and a description of which return values to pass back and how.
    Also keep the sources as existing when the chunk was created."
   focus return-values sources)


;;; Functional parameters

(defun print-functional-parameter (parameter stream depth)
   (declare (ignore depth))
   (format stream "~S" (functional-parameter-expression parameter)))

(defstruct (functional-parameter (:print-function print-functional-parameter))
   "Stores a functional production parameter as the original expression
    and the compiled function."
   expression function)


;;; Syntax Macros

(defmacro first-char (string)
   "First character of the string."
   `(schar ,string 0))

(defmacro last-char (string)
   "Last character of the string."
   `(schar ,string (- (length ,string) 1)))

(defmacro var> (string)
   "Determines if there is a > character at the end of the string."
   `(and (eq #\> (last-char ,string)) (> (length ,string) 1)))

(defmacro !keyword! (string)
   "Determines if the first and last character of the string is a !."
   `(and (eq #\! (first-char ,string))
         (eq #\! (last-char ,string))))

(defmacro =var (string)
   "Determines if the first character of the string is a =."
   `(eq #\= (first-char ,string)))

(defmacro +var (string)
   "Determines if the first character of the string is a +."
   `(eq #\+ (first-char ,string)))

(defmacro -var (string)
   "Determines if the first character of the string is a -."
   `(eq #\- (first-char ,string)))

(defmacro delimiter (string)
   "Determines if string is either a var> or a !keyword!."
   `(or (var> ,string) (!keyword! ,string)))

(defmacro symbol-name-test (symbol test)
   "Gets the name of symbol and apply test to it."
   `(and (symbolp ,symbol)
         (let ((name (symbol-name ,symbol)))
           (,test name))))

(defmacro retrievalp (symbol)
   "Determines whether symbol is of the form var>."
   `(symbol-name-test ,symbol var>))

(defmacro commandp (symbol)
   "Determines whether symbol is of the form !keyword!."
   `(symbol-name-test ,symbol !keyword!))

(defmacro delimiterp (symbol)
   "Determines whether symbol is of the form var> or !keyword!."
   `(symbol-name-test ,symbol delimiter))

(defmacro separatorp (symbol)
   "Determines if symbol is the separator ==>."
   `(eq '==> ,symbol))

(defmacro variablep (symbol)
   "Determines whether symbol is of the form =var."
   `(symbol-name-test ,symbol =var))

(defmacro actionp (symbol)
   "Determines whether symbol is of the form +var."
   `(symbol-name-test ,symbol +var))

(defmacro clearp (symbol)
   "Determines whether symbol is of the form -var."
   `(symbol-name-test ,symbol -var))

(defmacro position-or-last (list test)
   "Determines the index of the first element in list to satisfy test, or last."
   `(let ((index 0))
      (dolist (symbol ,list index)
        (when (,test symbol) (return index))
        (incf index 1))))

(defmacro next-delimiter (list)
   "Determines the index of the position of the next delimiter,
    the current one not included."
   `(position-or-last (rest ,list) delimiterp))

(defmacro test-modifier (symbol)
   "Determines if symbol is a test modifier such as negation or comparison."
   `(member ,symbol '(- < > <= >=) :test #'eq))

(defmacro next-slot (list)
   "Returns 1 for positive tests, 2 for negative or comparison tests."
   `(if (test-modifier (first ,list)) 2 1))

(defmacro var-var> (var)
   "Adds a final > to var."
   `(intern (concatenate 'string (coerce-string ,var) ">")))

(defmacro var>var (var)
   "Strips the final > off the var."
   `(let* ((name (symbol-name ,var))
           (length (- (length name) 1))
           (new-string (make-string length)))
      (dotimes (i length (intern new-string))
        (setf (schar new-string i) (schar name i)))))

(defmacro var=var (var)
   "Strips the initial = off a var."
   `(let* ((name (symbol-name ,var))
           (length (- (length name) 1))
           (new-string (make-string length)))
      (dotimes (i length (intern new-string))
        (setf (schar new-string i) (schar name (+ i 1))))))

(defun coerce-string (expr)
   "Returns the string corresponding to expr.  Tries to avoid using format."
   (when (wmep expr) (setf expr (wme-name expr)))
   (cond ((stringp expr) expr)
         ((symbolp expr) (symbol-name expr))
         (t (format nil "~S" expr))))



;;;
;;; UTILITIES
;;;

(defmacro push-last (item place)
   `(setf ,place (nconc ,place (list ,item))))

(defun noise (s)
   "Approximates a sample from a normal distribution with mean zero and
    the given s-value (/ (sqrt (* 3.0 variance)) 3.1416)."
   ;; Need to test bound because of short-float lack of precision
   (let ((p (max 0.0001 (min (random 1.0) 0.9999))))
     (* s (log (/ (- 1.0 p) p)))))

(defmacro exp-log (base power)
   "Computes expt using exp and log to prevent getting out of short-float,
    if necessary."
   (if (typep (expt 1.0 1.0) *read-default-float-format*)
     `(expt ,base ,power)
     `(exp (* (log ,base) ,power))))

(defun quote-arguments (argument-list)
   "Return a new argument list with the non-constants quoted."
   (let ((new-list nil))
     (dolist (argument argument-list new-list)
       (push-last (if (or (constantp argument) (variablep argument)
                          (and (symbolp argument) (boundp argument)))
                    argument (list 'quote argument))
                  new-list))))

;;;
;;; MAIN FUNCTION DEFINITIONS
;;;

;;; Clearing, Resetting and Deleting

(defmacro safe-gentemp (prefix)
   "gentemp a new symbol and save it for later removal."
   `(car (push (gentemp ,prefix) *used-ACT-R-symbols*)))

(defun clear-used-symbols-fct ()
   "Uninterns all of the symbols that have been safe-gentemp'ed
    since the last reset."
   (dolist (x *used-ACT-R-symbols*)
     (unintern x))
   (setf *used-ACT-R-symbols* nil))

(defun init-types ()
   "Initializes the init types"
   (chunk-type-fct '(chunk))
   (chunk-type-fct '(error condition))
   (chunk-type-fct '(dependency goal modified stack constraints actions
                     generals specifics dont-cares differents))
   (let ((type-t (make-wme-type)))
     (setf (wme-type-name type-t) t)
     (setf (wme-type-documentation type-t) "The default type for 
productions without goals.")
     (setf (wme-type-size type-t) 0)
     (push-last (cons t type-t) *declarative-memory*))
   (add-dm-fct '((failure isa error condition failure))))

(defun clear-all-fct (&optional (save-model t))
   "Clears everything."
   (clear-used-symbols-fct)
   (setf *compile-eval-calls* nil)
   (when *load-pathname*
     (setf *model* (when save-model (list *load-pathname*)))
     (when (eq save-model t)
       (load-model-list *load-pathname*)))
   (setf *time* 0.0)
   (setf *start-time* 0.0)
   (setf *default-action-time* 0.05)
   (setf *latency* 0.0)
   (setf *cycle* 0)
   (setf *spread-stamp* 0)
   (setf *wme-number* 0.0)
   (setf *declarative-memory* nil)
   (setf *hash-names* (make-hash-table :test #'eq :size 1000))
   (init-types)
   (setf *procedural-memory* nil)
   (setf *goal-activation* 1.0)
   (setf *goal-sources* nil)
   (setf *wmfocus* nil)
   (setf *wmfocus-list* nil)
   (setf *goal-stack* nil)
   (setf *goal-depth* 1)
   (setf *g* 20.0)
   (setf *exp-gain-noise* nil)
   (setf *retrieval* nil)
   (setf *retrieval-scheduler* nil)
   (setf *visual-location* nil)
   (setf *aural-location* nil)
   (setf *previous-instantiations* nil)
   (setf *previous-instantiation* nil)
   (setf *instantiation* nil)
   (setf *extra-instantiation* nil)
   (setf *conflict-set* nil)
   (setf *sum-exp-act* 0.0)
   (setf *latency-fn*  'old-latency)
   (setf *latency-factor* 1.0)
   (setf *latency-exponent* 1.0)
   (setf *base-level-constant* 0.0)
   (setf *activation-sources* nil)
   (setf *activation-noise* nil)
   (setf *permanent-activation-noise* nil)
   (setf *mismatch-penalty* 1.0)
   (setf *retrieval-threshold* nil)
   (setf *partial-matching* nil)
   (setf *max-sim* 1.0)
   (setf *max-dif* -10.0)
   (setf *temperature* 1.0)
   (setf *blending* nil)
   (setf *break-productions* nil)
   (setf *failed-productions* nil)
   (setf *cost-penalty* 1.0)
   (setf *initial-experience* 10.0)
   (setf *threshold-time* 2.0)
   (setf *enable-production-learning* nil)
   (setf *reinforce-analogized-production* t)
   (setf *production-compilation-parameters* nil)
   (setf *enable-rational-analysis* nil)
   (setf *enable-randomness* nil)
   (setf *utility-threshold* 0.0)
   (setf *optimized-learning* t)
   (setf *base-level-learning* nil)
   (setf *associative-learning* nil)
   (setf *strength-learning* nil)
   (setf *parameters-learning* nil)
   (setf *command-trace* t)
   (setf *output-trace* t)
   (setf *cycle-trace* t)
   (setf *latency-trace* nil)
   (setf *partial-matching-trace* nil)
   (setf *blending-trace* nil)
   (setf *production-compilation-trace* t)
   (setf *activation-trace* nil)
   (setf *conflict-resolution-trace* nil)
   (setf *conflict-set-trace* nil)
   (setf *goal-trace* nil)
   (setf *dm-trace* nil)
   (setf *production-trace* nil)
   (setf *matches-trace* nil)
   (setf *exact-matching-trace* nil)
   (setf *verbose* t)
   (setf *abort-instantiation* t)
   (setf *parameter-sets* nil)
   (setf *similarity-hook-fn* nil)
   (setf *blending-hook-fn* 'blending-arithmetic-mean)
   (setf *conflict-set-hook-fn* nil)
   (setf *firing-hook-fn* nil)
   (setf *cycle-hook-fn* nil)
   (setf *web-hook-fn* nil)
   (setf *end-run-hook-fn* nil)
   (setf *step-fn* 'step-fct)
   (setf *stop* nil)
   (setf *save-state-changes* nil)
   (setf *pop-upon-failure* nil)
   (when *init-hook-fn* (funcall *init-hook-fn*)))

(defun clear-dm-fct ()
   "Clears all working memory elements."
   (dolist (wmetype *declarative-memory*)
     (setf (wme-type-wmes (cdr wmetype)) nil))
   (clrhash *hash-names*)
   (setf *wme-number* 0.0))

(defun clear-productions-fct ()
   "Clears all productions from memory."
   (dolist (wmetype *declarative-memory*)
     (setf (wme-type-productions (cdr wmetype)) nil))
   (setf *procedural-memory* nil)
   (setf *break-productions* nil)
   (setf *failed-productions* nil))

(defun actr-time-fct (&optional inc)
   "Returns the current act-r time, or adds inc to it if specified."
   (if inc
     (incf *time* inc)
     *time*))

(defparameter *merge* nil)

(defun delete-wme (wme &optional (identical nil))
   "Deletes a given wme node from the type memory and the hash table.
    Zeroes all its slots, and only proceed when it is not referenced. 
If identical
    is specified, any remaining reference to wme will be replaced with 
identical.
    Also replace occurrences of wme in buffers, retrieval scheduler and
    instantiation variables."
   (dolist (parent (rest (wme-fan wme)))
     (unless (eq parent wme)
       (if identical  ; replace references to wme in chunk slots with identical
         (dotimes (index (wme-type-size (wme-type parent)))
           (when (eq (wme-slot parent index) wme)
             (set-slot-value parent index identical)))
         (signal-output *command-trace* "CHUNK ~S IS STILL REFERENCED 
IN CHUNK ~S WHEN DELETED."
                        wme parent))))
   ;; Clear occurences of wme in buffers
   (dolist (buffer *buffer-keywords*)
     (setf buffer (cdr buffer))
     (when (eq (symbol-value buffer) wme)
       (setf (symbol-value buffer) identical)))
   ;; same for retrieval scheduler but make sure it works whether pair or wme
   (when *retrieval-scheduler*
     (if (consp *retrieval-scheduler*)
       (when (eq (cdr *retrieval-scheduler*) wme)
         (rplacd *retrieval-scheduler* identical))
       (when (eq *retrieval-scheduler* wme)
         (setf *retrieval-scheduler* wme))))
   ;; Clear occurences of wme in instantiation variables
   (let ((instantiation *instantiation*))
     (when instantiation
       (dotimes (variable (production-size (instantiation-production 
instantiation)))
         (when (eq (instantiation-variable instantiation variable) wme)
           (setf (instantiation-variable instantiation variable) identical)))))
   ;; When merging print a warning message
   (when identical
     (signal-output *cycle-trace* "Merging chunk ~S into chunk ~S" wme 
identical)
     ;; added for production compilation purposes
     (setf *merge* (list wme identical)))
   (let ((wmetype (wme-type wme)))
     (decf *wme-number* 1.0)
     (dolist (slot (wme-type-slots wmetype))
       (set-slot-value wme (slot-index slot) nil))
     (remove-name (wme-name wme))
     (setf (wme-type-wmes wmetype)
           (delete wme (wme-type-wmes wmetype) :test #'eq :count 1))
     (save-state-change :delete-wme wme)))

(defun delete-chunk-fct (wmes)
   "Deletes wmes."
   (let ((structures nil))
     (dolist (wme wmes structures)
       (setf wme (get-safe-wme wme))
       (when wme
         (push-last (wme-name wme) structures)
         (delete-wme wme)))))

(defun delete-production (production)
   "Removes a production from procedural memory and type memory."
   (let ((type (production-goal-type production)))
     (save-state-change :delete-production production)
     (setf (wme-type-productions type) (delete production 
(wme-type-productions type)
                                               :test #'eq :count 1))
     (setf *procedural-memory* (delete (production-name production) 
*procedural-memory*
                                       :test #'eq :key #'car :count 1))))

(defun remove-wmetype-definition (definition)
   "Removes the structure definitions pertaining to a wme type definition."
   (dolist (subtype (rest (wme-type-subtypes definition)))
     (setf (wme-type-supertypes subtype)
           (delete definition (wme-type-supertypes subtype) :test #'eq 
:count 1)))
   (dolist (supertype (wme-type-supertypes definition))
     (setf (wme-type-subtypes supertype)
           (delete definition (wme-type-subtypes supertype) :test #'eq 
:count 1)))
   (setf *declarative-memory*
           (delete definition *declarative-memory*
                   :test #'eq :key #'cdr :count 1)))


;;; WME Type Creating and Printing

(defun pprint-wmetype (wmetype)
   "Pretty prints a wmetype."
   (signal-output *command-trace* "~S" wmetype)
   (when (wme-type-documentation wmetype)
     (signal-output *command-trace* "~S" (wme-type-documentation wmetype)))
   (let ((super-type (second (wme-type-supertypes wmetype))))
     (when super-type
       (signal-output *command-trace* " <- ~S" super-type)))
   (dolist (slot (wme-type-slots wmetype))
     (signal-output *command-trace* "   ~S" (slot-name slot))
     (when (slot-default slot)
       (signal-output *command-trace* " <- ~S" (slot-default slot))))
   (wme-type-name wmetype))

(defun print-wmetypes (&optional (wmetypes nil))
   "Prints definitions for a list of types, possibly empty."
   (let ((*verbose* t)
         (*goal-depth* 1)
         (structures nil))
     (if wmetypes
       (dolist (wmetype wmetypes)
         (setf wmetype (get-safe-type wmetype "CHUNK-TYPE"))
         (when wmetype
           (push-last (pprint-wmetype wmetype) structures)))
       (dolist (wmetype *declarative-memory*)
         (setf wmetype (cdr wmetype))
         (push-last (pprint-wmetype wmetype) structures)))
     structures))

(defun chunk-type-fct (name-and-slots)
   "Defines a new wme type.  Checks that the syntax is correct.
    Clears the previous definition if wme type is already defined."
   (if name-and-slots
     (let* ((name-description (car name-and-slots))
            (name (if (consp name-description)
                    (car name-description) name-description))
            (super-type (if (consp name-description)
                          (cdr name-description) nil))
            (documentation (when (stringp (second name-and-slots))
                             (second name-and-slots)))
            (slots (if documentation (cddr name-and-slots) (cdr 
name-and-slots)))
            (definition nil)
            (slot-index 0))
       ; check type hierarchy
       (when super-type
         (unless (null (cdr super-type))
           (signal-warn "TOO MANY OPTIONS SPECIFIED FOR TYPE ~S: ~S. 
ALL BUT THE FIRST ARE IGNORED."
                        name super-type))
         (if (and (eq (caar super-type) :include) (null (cddar super-type)))
           (setf super-type (get-safe-type (cadar super-type) name))
           (signal-warn "UNKNOWN OPTION ~S SPECIFIED FOR TYPE ~S." 
(car super-type) name)))
       ; check for redefinition
       (setf definition (get-type name))
       (cond (definition
               (signal-warn "TYPE ~S IS BEING REDEFINED.  RESET 
STRONGLY SUGGESTED." name)
               (remove-wmetype-definition definition))
             (t
              (setf definition (make-wme-type))))
       (setf (wme-type-name definition) name)
       (setf (wme-type-documentation definition) documentation)
       (setf (wme-type-supertypes definition)
             (when super-type (copy-list (wme-type-supertypes super-type))))
       (setf (wme-type-size definition) (if super-type (wme-type-size 
super-type) 0))
       (setf (wme-type-slots definition)
             (when super-type (copy-list (wme-type-slots super-type))))
       (push-last (cons name definition) *declarative-memory*)
       (push definition (wme-type-subtypes definition))
       (dolist (super-type (wme-type-supertypes definition))
         (push-last definition (wme-type-subtypes super-type)))
       (push definition (wme-type-supertypes definition))
       (setf slot-index (wme-type-size definition))
       (dolist (slot slots)
         (cond ((or (atom slot) (and (listp slot) (= (length slot) 2)))
                (push-last (make-slot :name (if (atom slot) slot (first slot))
                                      :index slot-index
                                      :default (if (atom slot) nil
 
(get-wme-or-constant (second slot))))
                           (wme-type-slots definition))
                (incf slot-index 1))
               (t
                (signal-warn "UNKNOWN SLOT FORMAT ~S FOR TYPE ~S." slot name))))
       (setf (wme-type-size definition) slot-index)
       name)
     (print-wmetypes)))

(defun pprint-instantiation (&optional (instantiation *instantiation*)
                                        (trace *command-trace*)
                                        (format *production-trace*))
   "Pretty-prints an instantiation."
   (let ((production (instantiation-production instantiation)))
     (when (eq trace 'short) (setf trace t))
     (signal-output trace "~S  ~8,3F  ~8,3F" production
                    (instantiation-latency instantiation)
                    (instantiation-gain instantiation))
     (if (eq format 'short)
       (dolist (binding (production-bindings production))
         (signal-output trace "   ~A: ~A" (variable-name binding)
                        (if (integerp (variable-index binding))
                          (or (instantiation-variable instantiation 
(variable-index binding))
                              "VARIABLE STILL UNBOUND")
                          "RETURN VARIABLE STILL UNDETERMINED")))
       (let ((bindings nil)
             (text nil))
         (dolist (binding (production-bindings production))
           (when (integerp (variable-index binding))
             (let ((value (instantiation-variable instantiation 
(variable-index binding))))
               (when value
                 (push (cons (variable-name binding) value) bindings)
                 (push (cons (var-var> (variable-name binding))
                             (var-var> value))
                   bindings)))))
         (setf text (sublis bindings (production-text production)))
         (pprint-production production trace text)))))

(defun pprint-instantiations (&optional (instantiations *conflict-set*)
                                         (trace *command-trace*)
                                         (format *production-trace*))
   "Pretty-prints instantiations on trace."
   (let ((index 0))
     (when (eq trace 'short) (setf trace t))
     (dolist (instantiation instantiations)
       (incf index 1)
       (signal-output trace "Instantiation ~D:" index)
       (pprint-instantiation instantiation trace format))))

;;; WME Creation

(defun create-wme (name type &key (given nil) (compute-ia t))
   "Creates a wme of a given name and type, with the default slot values.
    If wme is given, then reuse it.  If not, then initialize the structure.
    Install wme in the type memory and the hash table."
   (let ((wme (or given (make-wme)))
         (rji* 1.0)
         (sji 0.0))
     (incf *wme-number* 1.0)
     (setf (wme-name wme) name)
     (setf (wme-type wme) type)
     (setf (wme-slots wme) (make-array (wme-type-size type) 
:initial-element nil))
     (unless given
       (when *permanent-activation-noise*
         (setf (wme-permanent-noise wme) (noise *permanent-activation-noise*)))
       (setf (wme-fan wme) (list 1.0 wme))
       (when compute-ia
         (setf rji* (default-rji* wme))
         (setf sji (rji-sji rji*)))
       (create-ia wme wme :count 1 :sji sji :rji* rji*)
       (setf (wme-similarities wme) (list (cons wme *max-sim*))))
     (dolist (slot (wme-type-slots type))
       (when (slot-default slot)
         (set-slot-value wme (slot-index slot) (slot-default slot)
                         :compute-ia compute-ia)))
     (setf (get-wme name) wme)
     (push-last wme (wme-type-wmes type))
     (save-state-change :create-wme wme)
     wme))

(defun new-name-fct (name)
   "Returns a unique symbol as generated by gentemp based on name,
    which can be either a string, a symbol, or else defaults to CHUNK."
   (cond ((stringp name) (safe-gentemp (string-upcase name)))
         ((symbolp name) (safe-gentemp (symbol-name name)))
         (t (signal-warn "ARGUMENT ~S TO NEW-NAME IS NOT A SYMBOL OR 
STRING." name)
            (safe-gentemp "CHUNK"))))

(defun add-dm-fct (wmes &key (reset-ia t))
   "Adds the wmes to working memory."
   ; First pass: create the wme structures
   (let ((structures nil)
         (names nil))
     ;; copy once for more effective modification
     (setf wmes (copy-tree wmes))
     (do ((rest-wmes wmes (rest rest-wmes)))
         ((null rest-wmes))
       (let ((wme (first rest-wmes)))
         (when (and (eq (first wme) 'isa) (not (eq (second wme) 'isa)))
           (setf wme (cons (new-name-fct (second wme)) wme))
           (rplaca rest-wmes wme))
         (let* ((wme-name (first wme))
                (slots (if (stringp (second wme)) (cddr wme) (cdr wme))))
           ; check that the format is correct
           (cond ((eq (first slots) 'isa)
                  (let ((wme-structure (get-wme wme-name))
                        (wmetype (get-safe-type (second slots) wme-name)))
                    (when (and wme-structure wmetype)
                      (signal-output *command-trace* "CHUNK ~S ALREADY 
EXISTS.  DELETING IT FIRST."
                                     wme-name)
                      (delete-wme wme-structure))
                    ; create the new wme and install it in declarative 
memory and the hash
                    (if wmetype
                      (setf wme-structure
                            (create-wme wme-name wmetype :given 
wme-structure :compute-ia nil))
                      (setf wmes (delete wme wmes :test #'eq)))))
                 (t
                  (signal-warn "NO TYPE SPECIFIED FOR CHUNK ~S." wme-name)
                  (setf wmes (delete wme wmes :test #'eq)))))))
     ; Second pass: fill the slots with the cross-references
     (dolist (wme wmes)
       (let* ((wme-name (first wme))
              (wme-structure (get-wme wme-name))
              (wmetype (wme-type wme-structure))
              (documentation (when (stringp (second wme)) (second wme)))
              (all-slots (if documentation (cddddr wme) (cdddr wme)))
              (slot nil))
         (push-last wme-structure structures)
         (push-last wme-name names)
         (when documentation
           (setf (wme-documentation wme-structure) documentation))
         (do ((slots all-slots (cddr slots)))
             ((null slots))
           (setf slot (get-safe-slot (first slots) wmetype wme-name))
           (when slot (set-slot-value wme-structure
                                      (slot-index slot)
                                      (get-wme-or-constant (second slots))
                                      :compute-ia nil)))))
     ; Reset all IAs, or just those for the wmes
     (if reset-ia
       (reset-ia-fct)
       (dolist (structure structures)
         (reset-ia-wme structure)))
     names))

(defun set-dm-fct (wmes)
   "Same as addwm-fct."
   (add-dm-fct wmes))

(defun copy-chunks (wmes)
   "Makes a clean copy of wmes and return the copies."
   (let ((copies nil)
         (copy nil))
     (dolist (wme wmes copies)
       (setf wme (get-safe-wme wme))
       (when wme
         (setf copy (create-wme (safe-gentemp (symbol-name (wme-name wme)))
                                (wme-type wme)))
         (dolist (slot (wme-type-slots (wme-type copy)))
           (set-slot-value copy (slot-index slot)
                           (get-slot-value wme (slot-name slot))))
         (push-last copy copies)))))

(defun copy-chunk-fct (wmes)
   "Makes a clean copy of wmes and return the names."
   (get-name-fct (copy-chunks wmes)))

;;; WME Activation

(defun reset-ia-wme (wmei)
   "Resets all the ia values leading to wmei."
   (let ((wmej nil)
         (ia nil))
     (dolist (wme-ia (wme-ias wmei))
       (setf wmej (car wme-ia))
       (setf ia (cdr wme-ia))
       (compute-ia wmej ia wmei))))

(defun reset-ia-fct ()
   "Resets all the ia values, preserving user-specified and learned values.
    Make sure that spreading activation is recomputed."
   (let ((rji* 0.0)
         (sji 0.0)
         (ia nil))
     (for-all-wmes wmej
                   (setf rji* (default-rji* wmej))
                   (setf sji (rji-sji rji*))
                   (dolist (wmei (rest (wme-fan wmej)))
                     (setf ia (get-ia wmej wmei))
                     (setf (ia-rji* ia) (count-rji* ia rji*))
                     (setf (ia-sji ia) (count-sji ia sji))))
     (incf *spread-stamp* 1)
     nil))

(defun ia-fct (wmej wmei)
   "Returns the ia value between wmej and wmei."
   (let* ((*verbose* t)
          (*goal-depth* 1)
          (ia nil))
     (setf wmej (get-safe-wme wmej))
     (setf wmei (get-safe-wme wmei))
     (when (and wmej wmei)
       (setf ia (get-ia wmej wmei)))
     (setf ia (if ia (ia-value ia wmej wmei) 0.0))
     (signal-output *command-trace* "~6,3F" ia)
     ia))

(defun update-activation-spread (&key (focus *wmfocus*))
   "Updates the activation sources to be the slot values of the focus wme."
   (incf *spread-stamp* 1)
   (dolist (source *activation-sources*)
     (setf (wme-source source) nil))
   (setf *activation-sources* nil)
   (when focus
     (let ((level (first (wme-slot-wmes focus))))
       (when (> level 0.0)
         (setf level (/ *goal-activation* level))
         (dolist (source (rest (wme-slot-wmes focus)))
           (cond ((wme-source source)
                  (incf (wme-source source) level))
                 (t
                  (setf (wme-source source) level)
                  (push source *activation-sources*))))))))

(defun compute-spreading-activation (wmei)
   "Updates the spreading activation of wmei.  Maintains activation."
   (let ((wmej nil)
         (ia nil)
         (spread 0.0))
     (decf (wme-activation wmei) (wme-source-spread wmei))
     (setf (wme-source-spread wmei) 0.0)
     (dolist (wme-ia (wme-ias wmei))
       (setf wmej (car wme-ia))
       (when (wme-source wmej)
         (setf ia (cdr wme-ia))
         (setf ia (ia-value ia wmej wmei))
         (setf spread (* (wme-source wmej) ia))
         (signal-output *activation-trace* "   Spreading activation 
~6,3F from source ~S level ~6,3F times IA ~6,3F"
                        spread wmej (wme-source wmej) ia)
         (incf (wme-source-spread wmei) spread)))
     (setf (wme-spread-stamp wmei) *spread-stamp*)
     (incf (wme-activation wmei) (wme-source-spread wmei))
     (wme-source-spread wmei)))

(defun compute-references (n references creation-time minus-decay)
   "Computes generalized decay formula from number and list of references,
    creation time and minus the decay rate."
   (let ((value 0.0)
         (last-reference 0.0))
     (when references
       (dolist (reference references)
         (incf value (exp-log (max *default-action-time* (- *time* reference))
                              minus-decay))
         (setf last-reference reference)))
     (when *optimized-learning*
       (let ((denominator (+ 1.0 minus-decay)))
         (if (numberp *optimized-learning*)
           (when (> n *optimized-learning*)
             (incf value (/ (* (- n *optimized-learning*)
                               (- (exp-log (- *time* creation-time) denominator)
                                  (exp-log (- *time* last-reference) 
denominator)))
                            (* (max *default-action-time* (- 
last-reference creation-time))
                               denominator))))
           (setf value (/ (* n (exp-log (max *default-action-time* (- 
*time* creation-time))
                                        minus-decay))
                          denominator)))))
     (log value)))

(defun compute-base-level-activation (wme)
   "Updates the base level activation of wme when base level learning."
   (setf (wme-base-level wme)
         (+ *base-level-constant*
            (compute-references (car (wme-references wme)) (cdr 
(wme-references wme))
                                (wme-creation-time wme) (- 
*base-level-learning*))))
   (signal-output *activation-trace* "   Computing a base level of 
~6,3F from ~D references from creation time ~6,3F"
                  (wme-base-level wme) (round (first (wme-references 
wme))) (wme-creation-time wme))
   (wme-base-level wme))

(defun activation (wme)
   "Returns the activation of wme.  May involve recomputing the 
spreading activation,
    the base level and adding some noise."
   (declare (inline compute-spreading-activation 
compute-base-level-activation noise))
   (when (and *enable-rational-analysis*
              (< (wme-spread-stamp wme) *spread-stamp*))
     (compute-spreading-activation wme))
   (when (and (or *base-level-learning* *activation-noise*)
              (< (wme-time-stamp wme) *time*))
     (when *base-level-learning*
       (compute-base-level-activation wme))
     (setf (wme-activation wme) (+ (wme-permanent-noise wme)
                                   (wme-base-level wme)
                                   (wme-source-spread wme)))
     (when *activation-noise*
       (let ((noise (noise *activation-noise*)))
         (signal-output *activation-trace* "   Adding noise ~6,3F" noise)
         (incf (wme-activation wme) noise)))
     (setf (wme-time-stamp wme) *time*))
   (wme-activation wme))

(defun update-activation-fct ()
   "Updates the activation of all wmes by recomputing it.
    Also updates the IAs when associative learning is on."
   (let ((*verbose* t)
         (*goal-depth* 1))
     (incf *spread-stamp* 1)
     (for-all-wmes wme
                   (when *associative-learning*
                     (dolist (wme-ia (wme-ias wme))
                       (ia-value (cdr wme-ia) (car wme-ia) wme)))
                   (activation wme))))


;;; WME Parameters and Printing

(defun even-references (start end n &optional (m n))
   "Distributes m references evenly along n intervals between start and end."
   (when (plusp n)
     (let ((decrement (/ (- end start) n))
           (time end)
           (times nil))
       (dotimes (i (round m) times)
         (decf time decrement)
         (push-last time times)))))

(defun adapt-references (references creation-time &optional 
(optimized-learning *optimized-learning*))
   "If optimized learning is off, then erase all reference times.
    If on, then generate equidistant references since creation time.
    Generalize to a fixed number of references."
   (cond ((eq optimized-learning t) (rplacd references nil))
         ((null optimized-learning)
          (nconc references (even-references creation-time
                                             (if (null (rest references)) *time*
                                                 (first (last references)))
                                             (- (first references)
                                                (length (rest references))))))
         ((<= optimized-learning (length (rest references)))
          (rplacd (nthcdr optimized-learning references) nil))
         (t
          (nconc references (even-references creation-time
                                             (if (null (rest references)) *time*
                                                 (first (last references)))
                                             (- (first references)
                                                (length (rest references)))
                                             (- (min 
optimized-learning (first references))
                                                (length (rest references))))))))

(defun get-base-level-fct (wmes)
   "Returns the base level of wmes."
   (let* ((*verbose* t)
          (*goal-depth* 1)
          (baselevel 0.0)
          (baselevels nil))
     (dolist (wme wmes baselevels)
       (setf wme (get-safe-wme wme))
       (when wme
         (setf baselevel
               (if (and *base-level-learning* (< (wme-time-stamp wme) *time*))
                 (compute-base-level-activation wme)
                 (wme-base-level wme)))
         (signal-output *command-trace* "~6,3F" baselevel)
         (push-last baselevel baselevels)))))

(defun set-base-level (wme setting)
   "Sets the base level of wme.  setting is either the base level or the
    references, followed perhaps by the creation time.  Increments activation."
   (let ((old-base-level (wme-base-level wme)))
     (when (second setting)
       (setf (wme-creation-time wme) (coerce (second setting)
                                             *read-default-float-format*)))
     (cond (*base-level-learning*
            (setf (wme-references wme)
                  (list (coerce (first setting) *read-default-float-format*)))
            (unless *optimized-learning*
              (adapt-references (wme-references wme) (wme-creation-time wme)))
            (compute-base-level-activation wme))
           (t
            (setf (wme-base-level wme) (coerce (first setting) 
*read-default-float-format*))))
     (incf (wme-activation wme) (- (wme-base-level wme) old-base-level))
     (wme-base-level wme)))

(defun set-all-base-levels-fct (references &optional (creation-time nil))
   "Sets all individual base levels to these references and creation-time."
   (let ((baselevel nil)
         (*activation-trace* nil))
     (for-all-wmes wme
                   (setf baselevel
                         (set-base-level wme (list references creation-time))))
     baselevel))

(defun set-base-levels-fct (settings)
   "Sets individual base levels.  settings specify either the base level,
    if base level learning is off, or the references and perhaps
    the creation time."
   (let ((wme-or-type nil)
         (baselevels nil)
         (*activation-trace* nil))
     (dolist (setting settings baselevels)
       (setf wme-or-type (first setting))
       (unless (or (wmep wme-or-type) (wme-type-p wme-or-type))
         (setf wme-or-type (get-type wme-or-type))
         (unless wme-or-type
           (setf wme-or-type (get-safe-wme (first setting)))))
       (if (wmep wme-or-type)
         (push-last (set-base-level wme-or-type (rest setting)) baselevels)
         (when (wme-type-p wme-or-type)
           (dolist (wme (wme-type-wmes wme-or-type))
             (push-last (set-base-level wme (rest setting)) baselevels)))))))

(defun set-general-base-levels-fct (settings)
   "Sets individual base levels.  settings specify either the base level,
    if base level learning is off, or the references and perhaps
    the creation time.  Same as set-base-levels-fct."
   (set-base-levels-fct settings))

(defun set-ia-value (wmej wmei sji)
   "Sets ia value from wmej to wmei to sji.
    When wmej is a source, recompute spreading activation for wmei."
   (let ((ia (get-make-ia wmej wmei)))
     (when (wme-source wmej) (decf (wme-spread-stamp wmei) 1))
     (setf (ia-rji* ia) (exp sji))
     (setf (ia-sji ia) sji)
     sji))

(defun add-ia-fct (settings)
   "Sets individual ias.  settings specify Sji as (wmej wmei sji)."
   (let ((wmej nil)
         (wmei nil)
         (ias nil))
     (dolist (setting settings ias)
       (setf wmej (get-safe-wme (first setting)))
       (setf wmei (get-safe-wme (second setting)))
       (when (and wmej wmei)
         (push-last (set-ia-value wmej wmei (third setting)) ias)))))

(defun set-ia-fct (settings)
   "Sets individual ias.  settings specify Sji as (wmej wmei sji). 
Same as add-ia-fct."
   (add-ia-fct settings))

(defun activation-sources-fct ()
   "Displays and returns activation sources."
   (let* ((*verbose* t)
          (*goal-depth* 1)
          (sources nil))
     (dolist (source *activation-sources* sources)
       (push-last (wme-name source) sources)
       (signal-output *command-trace* "~S: ~6,3F" source (wme-source source)))))

(defun chunk-slot-value-fct (wme slot)
   "Returns the slot value of wme."
   (setf wme (get-safe-wme wme))
   (when wme
     (get-wme-name (get-safe-slot-value wme slot))))

(defun mod-chunk-fct (name slot-values)
   "Sets slots of wme name to values.
    Make sure that activation spreading is recomputed for all or just this wme."
   (let* ((wme (get-safe-wme name))
          (type (when wme (wme-type wme)))
          (slot nil))
     (when wme
       (do ((rest-slot-values slot-values (cddr rest-slot-values)))
           ((null rest-slot-values))
         (setf slot (get-safe-slot (first rest-slot-values) type name))
         (when slot (set-slot-value wme
                                    (slot-index slot)
                                    (get-wme-or-constant (second 
rest-slot-values)))))
       (if (eq wme *wmfocus*)
         (update-activation-spread)
         (decf (wme-spread-stamp wme) 1))
       (wme-name wme))))

(defun mod-focus-fct (slot-values)
   "Sets slots of focus to values."
   (mod-chunk-fct *wmfocus* slot-values))

(defun get-name-fct (wmes-or-productions)
   "Given a list of wmes or productions, returns the list of names."
   (let ((*verbose* t)
         (*goal-depth* 1)
         (names nil))
     (dolist (structure wmes-or-productions names)
       (cond ((wmep structure)
              (push-last (wme-name structure) names))
             ((productionp structure)
              (push-last (production-name structure) names))
             ((listp structure)
              (dolist (sublist structure)
                (push-last (get-name-fct sublist) names)))
             (t
              (signal-output *command-trace* "OBJECT ~S IN COMMAND 
NAME IS NEITHER A CHUNK NOR A PRODUCTION."
                             structure))))))

(defun pprint-wme (wme)
   "Given a wme, prints the name, type, and slot values, and returns its name."
   (let ((wmetype (wme-type wme)))
     (signal-output *command-trace* "~A~S   ~6,3F"
                    (if (eq wme *wmfocus*) "**" "") wme (activation wme))
     (when (wme-documentation wme)
       (signal-output *command-trace* "~S" (wme-documentation wme)))
     (signal-output *command-trace* "   isa ~S" wmetype)
     (dolist (slot (wme-type-slots wmetype))
       (let ((slot-value (wme-slot wme (slot-index slot))))
         (signal-output *command-trace* "   ~S ~S" (slot-name slot)
                        slot-value)))
     (wme-name wme)))

(defun dm-fct (wmes)
   "Pretty prints a list of wmes, or all of them if not specified."
   (let ((*verbose* t)
         (*goal-depth* 1)
         (structures nil))
     (if wmes
       (dolist (wme wmes)
         (setf wme (get-safe-wme wme nil))
         (when wme
           (push-last (pprint-wme wme) structures)))
       (for-all-wmes wme
                     (push-last (pprint-wme wme) structures)))
     structures))

(defun sdm-fct (slot-values)
   "Prints wmes having slot values."
   (let ((*verbose* t)
         (*goal-depth* 1)
         (structures nil))
     (dolist (type *declarative-memory* structures)
       (let ((slots (wme-type-slots (cdr type)))
             (slot nil)
             (index nil)
             (index-values nil))
         (when (do ((rest-slot-values slot-values (cddr rest-slot-values)))
                   ((null rest-slot-values) t)
                 (setf slot (first rest-slot-values))
                 (cond ((eq slot 'isa)
                        (unless (eq (second rest-slot-values) (car type))
                          (return nil)))
                       (t
                        (setf index (slot-index (get-slot slot slots)))
                        (if index
                          (push (cons index (or (get-wme (second 
rest-slot-values))
                                                (second rest-slot-values)))
                                index-values)
                          (return nil)))))
           (dolist (wme (wme-type-wmes (cdr type)))
             (dolist (test index-values (push-last (pprint-wme wme) structures))
               (unless (equal (cdr test) (wme-slot wme (car test)))
                 (return nil)))))))))


;;; WME parameters setting and printing

(defun wme-parameters-fct (wme &optional parameters)
   "Returns the value of the wme parameter(s), or print them all if 
none specified."
   (let ((*verbose* t)
         (*goal-depth* 1)
         (value nil)
         (values nil))
     (setf wme (get-safe-wme wme))
     (cond (wme
            (signal-output *command-trace* "Parameters for chunk ~S:" wme)
            ;;; Update activations!!
            (when *enable-rational-analysis*
              (when *associative-learning*
                (dolist (wme-ia (wme-ias wme))
                  (ia-value (cdr wme-ia) (car wme-ia) wme)))
              (activation wme))
            (cond (parameters
                   (dolist (parameter parameters)
                     (setf value
                           (case parameter
                             (:name (wme-name wme))
                             (:activation (wme-activation wme))
                             (:source (wme-source wme))
                             (:base-level (wme-base-level wme))
                             (:creation-time (wme-creation-time wme))
                             (:references (wme-references wme))
                             (:source-spread (wme-source-spread wme))
                             (:ias (wme-ias wme))
                             (:creation-cycle (wme-creation-cycle wme))
                             (:needed (wme-needed wme))
                             (:contexts (wme-contexts wme))
                             (:permanent-noise (wme-permanent-noise wme))
                             (:similarities (wme-similarities wme))
                             (t (signal-warn "NO PARAMETER ~A DEFINED 
FOR CHUNK (TRY : IN FRONT)."
                                             parameter)
                                :error)))
                     (push-last value values)
                     (signal-output *command-trace* "~S ~6,3F" parameter value))
                   (signal-output *command-trace* "")
                   values)
                  (t
                   (when *enable-rational-analysis*
                     (signal-output *command-trace*
                                    ":Activation ~6,3F~% :Source 
~6,3F~% :Base-Level ~6,3F"
                                    (wme-activation wme) (wme-source 
wme) (wme-base-level wme))
                     (when *base-level-learning*
                       (signal-output *command-trace*
                                      ":Creation-Time ~6,3F~% :References ~6,3F"
                                      (wme-creation-time wme) 
(wme-references wme)))
                     (signal-output *command-trace*
                                    ":Source-Spread ~6,3F~% :IAs ~6,3F"
                                    (wme-source-spread wme) (wme-ias wme))
                     (when *associative-learning*
                       (signal-output *command-trace*
                                      ":Creation-Cycle ~6,3F~% :Needed 
~6,3F~% :Contexts ~6,3F"
                                      (wme-creation-cycle wme) 
(wme-needed wme) (wme-contexts wme)))
                     (when *permanent-activation-noise*
                       (signal-output *command-trace* ":Permanent-Noise ~6,#F"
                                      (wme-permanent-noise wme)))
                     (when *partial-matching*
                       (signal-output *command-trace*
                                      ":Similarities ~6,3F"
                                      (wme-similarities wme))))
                   (signal-output *command-trace* "")
                   wme)))
           (t :error))))

(defun set-wme-parameters-fct (wme parameters)
   "Sets the parameters of wme."
   (let ((values nil))
     (setf wme (get-safe-wme wme))
     (if wme
       (loop
         (unless parameters (return values))
         (let* ((parameter (pop parameters))
                (value (pop parameters)))
           (when (and (listp value) (eq (first value) 'quote))
             (setf value (second value)))  ;; for compatibility with 
evaluating versions
           (push-last
            (case parameter
              (:name
               (signal-warn "CHUNK NAME CANNOT BE SET.")
               :error)
              (:activation
               (signal-warn "CHUNK ACTIVATION CANNOT BE SET DIRECTLY: 
SET BASE-LEVEL AND/OR SOURCE INSTEAD.")
               :error)
              (:base-level
               (cond (*base-level-learning*
                      (signal-warn "CHUNK BASE-LEVEL CANNOT BE SET 
DIRECTLY WHEN BASE LEVEL LEARNING IS ENABLED: SET CREATION-TIME 
AND/OR REFERENCES INSTEAD.")
                      :error)
                     ((numberp value)
                      (incf (wme-activation wme) (- value (wme-base-level wme)))
                      (setf (wme-base-level wme) value))
                     (t
                      (signal-warn "CHUNK BASE-LEVEL MUST BE SET TO A NUMBER.")
                      :error)))
              (:source
               (cond ((or (numberp value) (null value))
                      (incf *spread-stamp* 1)
                      (setf (wme-source wme) value))
                     (t
                      (signal-warn "CHUNK SOURCE MUST BE SET TO NIL OR 
A NUMBER.")
                      :error)))
              (:creation-time
               (cond ((numberp value)
                      (decf (wme-time-stamp wme) 1.0)
                      (setf (wme-creation-time wme) value))
                     (t
                      (signal-warn "CHUNK CREATION-TIME MUST BE SET TO 
A NUMBER.")
                      :error)))
              (:references
               (cond ((listp value)
                      (decf (wme-time-stamp wme) 1.0)
                      (setf (wme-references wme)
                            (cons (length value)
                                  (unless *optimized-learning* 
(copy-list value))))
                      (adapt-references (wme-references wme) 
(wme-creation-time wme))
                      (wme-references wme))
                     ((numberp value)
                      (decf (wme-time-stamp wme) 1.0)
                      (setf (first (wme-references wme)) value)
                      (adapt-references (wme-references wme) 
(wme-creation-time wme))
                      (wme-references wme))
                     (t
                      (signal-warn "CHUNK REFERENCES MUST BE SET TO A 
NUMBER OR A LIST.")
                      :error)))
              (:source-spread
               (signal-warn "CHUNK SOURCE-SPREAD CANNOT BE SET 
DIRECTLY: SET SOURCE AND/OR IAS INSTEAD.")
               :error)
              (:ias
               (cond ((listp value)
                      (incf *spread-stamp* 1)
                      (dolist (ia-pair value)
                        (let ((wmei (get-safe-wme (car ia-pair)))
                              (ia (if (numberp (cdr ia-pair))
                                    (cdr ia-pair) (cadr ia-pair))))
                          (if (numberp ia)
                            (when wmei (set-ia-value wmei wme ia))
                            (signal-warn "CHUNK IA VALUE ~S IS NOT A NUMBER."
                                           ia))))
                      (wme-ias wme))
                     (t
                      (signal-warn "CHUNK IAS MUST BE SET TO A LIST OF 
CHUNK-NUMBER PAIRS.")
                      :error)))
              (:needed
               (cond ((numberp value)
                      (incf *spread-stamp* 1)
                      (setf (wme-needed wme) value))
                     (t
                      (signal-warn "CHUNK NEEDED MUST BE SET TO A NUMBER.")
                      :error)))
              (:contexts
               (cond ((numberp value)
                      (incf *spread-stamp* 1)
                      (setf (wme-contexts wme) value))
                     (t
                      (signal-warn "CHUNK CONTEXTS MUST BE SET TO A NUMBER.")
                      :error)))
              (:creation-cycle
               (cond ((numberp value)
                      (incf *spread-stamp* 1)
                      (setf (wme-creation-cycle wme) value))
                     (t
                      (signal-warn "CHUNK CREATION-CYCLE MUST BE SET 
TO A NUMBER.")
                      :error)))
              (:permanent-noise
               (cond ((numberp value)
                      (incf (wme-activation wme) (- value 
(wme-permanent-noise wme)))
                      (setf (wme-permanent-noise wme) value))
                     (t
                      (signal-warn "CHUNK PERMANENT-NOISE MUST BE SET 
TO A NUMBER.")
                      :error)))
              (:similarities
               (cond ((listp value)
                      (dolist (similarity-pair value)
                        (let ((wmei (get-safe-wme (car similarity-pair)))
                              (similarity (if (numberp (cdr similarity-pair))
                                            (cdr similarity-pair)
                                            (cadr similarity-pair))))
                          (if (numberp similarity)
                            (when wmei
                              (set-similarity wme wmei similarity))
                            (signal-warn "CHUNK SIMILARITY VALUE ~S IS 
NOT A NUMBER."
                                           similarity))))
                      (wme-similarities wme))
                     (t
                      (signal-warn "CHUNK SIMILARITIES MUST BE SET TO 
A LIST OF CHUNK-NUMBER PAIRS.")
                      :error)))
              (t (signal-warn "NO PARAMETER ~A DEFINED FOR CHUNKS (TRY 
: IN FRONT)."
                              parameter)
                 :error))
            values)))
       :error)))

(defun sdp-fct (parameters)
   "Inspects and sets wme parameters."
   (let ((results nil))
     (if (null parameters) ; print all parameters for all wmes
       (for-all-wmes wme (push-last (wme-parameters-fct wme) results))
       (dolist (description (if (or (keywordp (first parameters))
                                    (keywordp (second parameters))
                                    (and (listp (first parameters))
                                         (null (second parameters))
                                         (not (keywordp (second (first 
parameters))))))
                              (list parameters) parameters))
         (when (atom description) (setf description (list description)))
         (if (keywordp (first description))
           (for-all-wmes
            wme
            (push-last
             (if (and (cdr description)
                      (not (keywordp (second description))))
               (set-wme-parameters-fct wme description)
               (wme-parameters-fct wme description))
             results))
           (dolist (wme (if (atom (first description))
                          (list (first description))
                          (first description)))
             (push-last
              (if (and (cddr description)
                       (not (keywordp (third description))))
                (set-wme-parameters-fct wme (rest description))
                (wme-parameters-fct wme (rest description)))
              results)))))
     results))


;;; Common similarity and blending functions.

(defun linear-similarity (wmej wmei)
   "Implements the linear similarity scale scaled by *linear-similarity-scale*.
    Suitable for use as the value of *similarity-hook-fn*.
    Returns the similar defined as the difference divided by scale,
    or nil if both arguments are not numbers."
   (when (and (numberp wmej) (numberp wmei))
     (/ (abs (- wmej wmei)) *linear-similarity-scale*)))

(defun blending-arithmetic-mean (value-probs)
   "Averages the value-probabilities using arithmetic mean.
    Suitable for linear similarities between numbers."
   (let ((sum 0.0))
     ;; Return the sum of all values multiplied by their probabilities
     (dolist (value-prob value-probs sum)
       (incf sum (* (car value-prob) (cdr value-prob))))))

(defun ratio-similarity (wmej wmei)
   "Implements the ratio similarity scale (no need for scaling).
    Suitable for use as the value of *similarity-hook-fn*.
    Returns the similar defined as the ratio of smallest to largest,
    or nil if both arguments are not numbers."
   (when (and (numberp wmej) (numberp wmei))
     (let ((min (min (abs wmej) (abs wmei)))
           (max (max (abs wmej) (abs wmei))))
       (if (zerop max) 1.0 ;; if max is 0 then wmej=wmei=0
           (/ min max)))))

(defun blending-geometric-mean (value-probs)
   "Averages the value-probabilities using geometric mean.
    Suitable for ratio similarities between numbers"
   (let ((sum 1.0))
     ;; Return the product of all values to the exponent of their probabilities
     ;; This will not work for negative values, but the ratio scale really only
     ;; applies to positive numbers anyway.
     (dolist (value-prob value-probs sum)
       (setf sum (* sum (expt (car value-prob) (cdr value-prob)))))))

(defun first-equation (best-value value-probs total-prob)
   "First activation equation (see ACT-R Workshop 99 slides)."
   (let ((activation 0.0))
     (dolist (value-prob value-probs)
       (let ((temperature (or *temperature* (* (sqrt 2.0) *activation-noise*)))
             (match-score (cdr value-prob)))
         ;; recover chunk matching score from its probability
         (unless (zerop total-prob)
           (setf match-score (* match-score total-prob)))
         (setf match-score (* temperature (log match-score)))
         ;; apply the mistatch penalty between values
         (decf match-score (- 1.0 (or (get-similarity (car value-prob)
                                                      best-value) 0.0)))
         ;; add the exponential of the new match scores
         (incf activation (exp match-score))))
     (if (zerop activation) ;; just in case
       *retrieval-threshold*
       (log activation))))

(defun second-equation (best-value value-probs total-prob)
   "Second activation equation (see ACT-R Workshop 99 slides)."
   (let ((activation 0.0))
     (dolist (value-prob value-probs)
       (let ((temperature (or *temperature* (* (sqrt 2.0) *activation-noise*)))
             (match-score (cdr value-prob)))
         ;; recover chunk matching score from its probability
         (unless (zerop total-prob)
           (setf match-score (* match-score total-prob)))
         (setf match-score (* temperature (log match-score)))
         ;; add the exponential of the new match scores weighted by similarity
         (incf activation (* (exp match-score)
                             (or (get-similarity (car value-prob)
                                                 best-value) 0.0)))))
     (if (zerop activation) ;; just in case
       *retrieval-threshold*
       (log activation))))

(defun third-equation (best-value value-probs total-prob)
   "Third activation equation (see ACT-R Workshop 99 slides)."
   (declare (ignore total-prob))
   (let ((activation 0.0))
     (dolist (value-prob value-probs)
       (incf activation (* (cdr value-prob)
                           (or (get-similarity (car value-prob)
                                               best-value) 0.0))))
     (if (>= activation 1.0) ;; perfect agreement on the same value
       ;; which is only possible if it is retrieval threshold
       *retrieval-threshold*
       (log (/ activation (- 1.0 activation))))))

;;; Latencies

(defun old-latency (activation)
   "Old latency equation: scaled negative exponential of chunk activation.
    The activation of other chunks and threshold is not used for scaling."
   (* *latency-factor* (exp (- (* *latency-exponent*
                                  (+ (if *instantiation*
                                       (strength 
(instantiation-production *instantiation*))
                                       0.0)
                                     activation))))))

(defun competitive-latency-bounded (activation)
   "Competitive latency equation: scaled the old latency (exponential of
    activation) by the sum of the exponential of other chunks activation
    passed as second argument. Includes the chunk itself and the threshold
    and thus will always be greater than the latency factor."
   (* *latency-factor*
      (expt (/ *sum-exp-act* (exp (/ activation *temperature*)))
            *latency-exponent*)))

(defun competitive-latency (activation)
   "Competitive latency equation: scaled the old latency (exponential of
    activation) by the sum of the exponential of other chunks activation
    passed as second argument. Includes the threshold but not the chunk
    itself and thus can be arbitrarily small."
   (let ((chunk-itself (exp (/ activation *temperature*))))
     (* *latency-factor*
        (expt (/ (- *sum-exp-act* chunk-itself) chunk-itself)
              *latency-exponent*))))

(defmacro activation-latency (activation)
   "Given the activation, returns the latency according *latency-fn*."
   `(funcall *latency-fn* ,activation))


;;; Learning

(defmacro build-functional-parameter (expression bindings)
   "Builds a functional parameter from the expression and variable bindings."
   `(make-functional-parameter :expression ,expression
                               :function (sub-eval-vars ,expression ,bindings)))

(defmacro get-functional-parameter (production-parameter)
   "Returns the value of parameter for production.  Tests for 
functional values."
   `(if (functional-parameter-p ,production-parameter)
      (funcall (functional-parameter-function ,production-parameter))
      ,production-parameter))

(defmacro production-action-probability (production)
   "The probability that the action of production executes successfully
    is either chance if specified or P."
   `(or (get-functional-parameter (production-chance ,production))
        (production-p ,production)))

(defmacro production-action-cost (production)
   "The action cost of a production is either the effort if specified or C."
   `(or (get-functional-parameter (production-effort ,production))
        (production-c ,production)))

(defun add-reference (references &optional (optimized-learning 
*optimized-learning*)
                                  (count 1.0) (reference *time*))
   "Increments the reference count and pushes an extra reference if
    optimized learning is off.  Works for both wme and production."
   (save-state-change :add-reference references)
   (incf (first references) count)
   (unless (eq optimized-learning t)
     (dotimes (i (round count))
       (push reference (rest references))))
   ;;; when keeping a fixed number of references and there are too 
many, lose the oldest
   (when (and (numberp optimized-learning) (> (first references) 
optimized-learning))
     (nbutlast references)))

(defun learn-matching (&optional (instantiation *instantiation*))
   "Applies the learning equations 4.3, 4.5 and 4.6 to instantiation."
   (let ((production (instantiation-production instantiation))
         (retrievals nil)
         (ia nil)
         (level 1.0))
     (unless *blending*
       (when (or *base-level-learning* *associative-learning*)
         (dolist (retrieval (production-retrievals production))
           (push-last (instantiation-variable instantiation retrieval)
                      retrievals)))
       ;; For every WME matched on the LHS, accumulate the reference times
       ;; for use in Equation 4.3 (and Equation 4.5)
       (when *base-level-learning*
         (dolist (retrieval retrievals)
           (add-reference (wme-references retrieval))))
       ;; For every context element (activation source) and every needed WME,
       ;; increment the number of times in context and needed, respectively,
       ;; and the number of coincidences for every pair for use in Equation 4.5.
       ;; DO NOT update the Sji since it changes every epoch
       (when *associative-learning*
         (dolist (retrieval retrievals)
           (incf (wme-needed retrieval) 1.0))
         (dolist (wmej *activation-sources*)
           (incf (wme-contexts wmej) level)
           (dolist (retrieval retrievals)
             (setf ia (get-make-ia wmej retrieval))
             (incf (ia-fnicj ia) level)))))
     ;; Adds the reference time for the selected production in Equation 4.6
     (when *strength-learning*
       (add-reference (production-references production)))))

(defun compute-probabilities (successes-list failures-list)
   "Computes probabilities by taking the ratio of successes to the sum 
of successes and
   failures.  Computes those as decaying ratios if parameters learning 
is a number."
   (let ((successes 0.0)
         (failures 0.0))
     (cond ((numberp *parameters-learning*)
            (let ((minus-d (- *parameters-learning*)))
              (dolist (success (rest successes-list))
                (incf successes (exp-log (max *default-action-time* (- 
*time* success))
                                         minus-d)))
              (dolist (failure (rest failures-list))
                (incf failures (exp-log (max *default-action-time* (- 
*time* failure))
                                        minus-d)))))
           (t
            (setf successes (first successes-list))
            (setf failures (first failures-list))))
     (/ successes (+ successes failures))))

(defun compute-p (p)
   "Computes the p parameter according to ACT Parameters Learning Equation."
   (setf (production-p p)
         (compute-probabilities (production-successes p)
                                (production-failures p))))

(defun compute-costs (successes-list failures-list efforts-list)
   "Computes probabilities by taking the ratio of efforts to the sum 
of successes and
   failures.  Computes those as decaying ratios if parameters learning 
is a number."
   (let ((successes 0.0)
         (failures 0.0)
         (efforts 0.0))
     (cond ((numberp *parameters-learning*)
            (let ((minus-d (- *parameters-learning*))
                  (rest-successes (rest successes-list))
                  (rest-failures (rest failures-list))
                  (rest-efforts (rest efforts-list))
                  (decay 0.0))
              (loop
                (when (or (and (null rest-successes) (null rest-failures))
                          (null rest-efforts))
                  (return))
                (setf decay
                      (if (and rest-successes
                               (or (null rest-failures)
                                   (> (first rest-successes) (first 
rest-failures))))
                        (pop rest-successes) (pop rest-failures)))
                (setf decay (exp-log (max *default-action-time* (- 
*time* decay))
                                     minus-d))
                (incf successes decay)
                (incf efforts (* (pop rest-efforts) decay)))))
           (t
            (setf successes (first successes-list))
            (setf failures (first failures-list))
            (setf efforts (first efforts-list))))
     (/ efforts (+ successes failures))))

(defun compute-c (p)
   "Computes the c parameter according to ACT Parameters Learning Equation."
   (setf (production-c p)
         (compute-costs (production-successes p) (production-failures p)
                        (production-efforts p))))

(defmacro pg-c (production)
   "Computes PG-C of a production."
   `(setf (production-pg-c ,production)
          (- (* (production-p ,production) *g*)
             (production-c ,production))))

(defun all-pg-c ()
   "Recomputes the pg-c of all productions."
   (dolist (production *procedural-memory*)
     (let ((p (cdr production)))
       (pg-c p))))

(defun recompute-production-parameters (production)
   "Recomputes all parameters for production."
   (when *parameters-learning*
     (compute-p production)
     (compute-c production))
   (pg-c production))

(defun get-pg-c (production)
   "Returns the current pg-c of a production, which means the value of 
slot pg-c,
    unless *parameters-learning* is a number, in case the decaying 
value is computed."
   (when (numberp *parameters-learning*)
     (recompute-production-parameters production))
   (production-pg-c production))

(defun learn-parameters (success failure &key (latency 0.0) 
(instantiation *instantiation*))
   "Applies the parameters learning equations to instantiation.  The 
success and/or
    failure of the goal has already been determined and is passed 
along with the latency
    of this instantiation and the instantiation itself (if it exists)."
   (let ((production (when instantiation (instantiation-production 
instantiation))))
; removed for compatibility with production compilation version
;    (when (and (not success) (not failure) instantiation) ;; see if 
goal changes: success
;      (let ((goal-index (car (rassoc '*wmfocus* 
(production-initializations production)))))
;        (when (and goal-index  ;; not always mention of the goal in 
the production
;                   (not (equal *wmfocus* (instantiation-variable 
instantiation goal-index))))
;          (setf success t))))  ;;; success by default upon goal changes
     (cond ((and success failure)  ;; clear the history
            (setf *previous-instantiations* nil))
           ((or success failure)  ;; register success or failure for 
all productions
            (when production
              (push (cons production (- *time* latency)) 
*previous-instantiations*))
            (dolist (production-time *previous-instantiations*)
              (let* ((previous-production (car production-time))
                     (previous-time (cdr production-time))
                     (effort (- *time* previous-time)))
                (add-reference (if success (production-successes 
previous-production)
                                   (production-failures previous-production))
                               (not (numberp *parameters-learning*))
                               1.0 previous-time)
                (add-reference (production-efforts previous-production)
                               (not (numberp *parameters-learning*))
                               effort effort)
                (recompute-production-parameters previous-production)))
            (setf *previous-instantiations* nil))
           (t  ;; simply add the production
            (when production
              (push (cons production (- *time* latency)) 
*previous-instantiations*))))))

(defun strength (production)
   "Returns the production strength."
   (when (and *strength-learning*
            (< (production-time-stamp production) *time*))
     (setf (production-strength production)
           (compute-references (car (production-references production))
                               (cdr (production-references production))
                               (production-creation-time production) 
(- *strength-learning*)))
     (setf (production-time-stamp production) *time*)
     (signal-output *activation-trace* "Computing a production 
strength of ~6,3F from ~D references from creation time ~6,3F"
                    (production-strength production)
                    (round (first (production-references production)))
                    (production-creation-time production)))
   (production-strength production))

;;; Production Parsing and Compiling

(defmacro sublist (list index)
   "Makes the sublist from 0 to index the first element of list,
    with the sublist from index to the end being the rest.  Destructively.
    Needs a special handling when index is zero."
   `(if (zerop ,index)
      (rplaca ,list (list (first ,list)))
      (let ((previous (nthcdr ,index ,list)))
        (rplaca ,list (cons (first ,list) (rest ,list)))
        (rplacd ,list (cdr previous))
        (when previous (rplacd previous nil)))))

(defmacro unflatten (expr index &key (subproc nil))
   "Makes a list of sublists of expr by index.
    Every sublist is processed by subproc is present."
   `(let ((list ,expr))
      (loop
        (unless list (return ,expr))
        (sublist list (,index list))
        ,@(when subproc (list `(,subproc (first list))))
        (setf list (rest list)))))

(defun sub-eval-vars (expr bindings)
   "Substitute stack reference for production variables in evaled expressions.
    Return a function to be funcalled rather than a form to be evaled, 
which for all
    but the simplest ones causes the compiler to be called every time, unless
    *compile-eval-calls* has been turned off."
   (let ((new-expr (list (copy-tree expr))))
     (dolist (binding bindings (if *compile-eval-calls*
                                 (compile nil `(lambda () ,(first new-expr)))
                                 (eval `(function (lambda () ,(first 
new-expr))))))
       (nsubst `(get-wme-name (svref *instantiation* ,(variable-index binding)))
               (variable-name binding) new-expr :test #'eq))))

(defmacro process-clause (clause)
   `(when (retrievalp (first ,clause))
      (unflatten (rest ,clause) next-slot)))

(defun structure-production (side)
   "Structures the definition of a production side."
   (unflatten side next-delimiter :subproc process-clause))

(defun parse-production (definition)
   "Parses a production on the basic format of name-lhs-==>-rhs,
    where lhs and rhs are lists of retrievals and commands.
    Each retrieval is assembled into the wme name, and a list
    of attribute-value pairs.  Values can be negative or !eval!.
    Returns the name, the goal type, and the lhs and rhs."
   ; basic parsing; also copies the definition
   (let ((delimiter (position-or-last definition separatorp))
         (documentation (when (stringp (second definition)) (second 
definition))))
     (values (first definition)
;            (if documentation (fifth definition) (fourth definition))
             (structure-production (subseq definition (if 
documentation 2 1) delimiter))
             (if (= delimiter (length definition))
               (signal-warn "NO SEPARATOR ==> DEFINED IN PRODUCTION ~S"
                            (first definition))
               (structure-production (subseq definition (+ delimiter 1))))
             documentation)))

(defmacro set-variable-type (production type key pair)
   "Sets the type of variable key, or prints warning message if non-existent.
    First assigns type because usually given by pop.
    Also replaces type name with structure in text for better printing."
   `(let ((type-info ,pair))
      (if (eq 'isa (first type-info))
        (let ((type-structure (get-safe-type (second type-info) ,production)))
          (setf ,type type-structure)
          (when type-structure
            (setf (second type-info) type-structure)))
        (signal-warn "NO TYPE DEFINED FOR VARIABLE ~S IN ~A." ,key 
,production))))

(defmacro compile-lhs-slots (bound-list unbound-list)
   "Compile slot-value pairs into a bound list and unbound list.
    Also update the text to replace constants with actual chunks for printing."
   `(dolist (slot-value clause)
      (setf negation (if (test-modifier (first slot-value)) (pop 
slot-value) nil))
      (setf slot (first slot-value))
      (setf slot (get-safe-slot slot type production))
      (setf value (second slot-value))
      (cond ((null slot))
            ((and (listp value) (eq '!eval! (first value)))
             (push-last (make-action :name (slot-name slot) :slot 
(slot-index slot)
                                     :value (sub-eval-vars (second 
value) bindings)
                                     :dispatch :eval :negation negation)
                        ,bound-list))
            ((and (not (variablep value)) (not (assoc value *buffer-keywords*)))
             (let ((wme-or-constant (get-wme-or-constant value)))
               (push-last (make-action :name (slot-name slot) :slot 
(slot-index slot)
                                       :value wme-or-constant
                                       :dispatch :literal :negation negation)
                          ,bound-list)
               (setf (second slot-value) wme-or-constant)))
            (t
             (with-binding value-binding bound value bindings index
               (cond (bound
                      (push-last
                       (make-action :name (slot-name slot) :slot 
(slot-index slot)
                                    :value (variable-index value-binding)
                                    :dispatch :stack :negation negation)
                       ,bound-list))
                     (t
                      (when negation
                        (signal-warn "TEST MODIFIER ~S CANNOT BE USED 
TO SET ~S IN SLOT ~S IN PRODUCTION ~A: IGNORED."
                                     negation value slot production))
                      (setf (variable-slot value-binding) (slot-index slot))
                      (push-last
                       (make-action :name (slot-name slot) :slot 
(slot-index slot)
                                    :value (variable-index value-binding))
                       ,unbound-list))))))))

(defun first-retrieval-index (lhs initializations)
   "Returns the index of the first retrieval in lhs."
   (let ((index 0)
         (form lhs))
     (loop
       (unless form
         (return (length lhs)))
       (if (and (member (first form) '(direct-test-and-bind 
indirect-test-and-bind
                                       direct-test-and-bind-pm 
indirect-test-and-bind-pm)
                        :test #'eq)
                (not (assoc (second form) initializations :test #'=)))
         (return index)
         (incf index 1))
       (setf form (rest form)))))

(defun compile-lhs (production lhs initializations bindings index)
   "Compiles the left-hand side of production.
    Add the instantiation-adding call."
   (let ((code nil)
         (form nil))
     (dolist (clause lhs)
       (let ((key (pop clause))
             (type nil)
             (tests nil)
             (binds nil)
             (slot nil)
             (value nil)
             (negation nil))
         (setf form
               (cond
                ((retrievalp key)
                 (setf key (var>var key))
                 (with-binding binding direct key bindings index
                   (set-variable-type production type key (pop clause))
                   (when type
                     (setf (variable-type binding) type)
                     (compile-lhs-slots tests binds)
                     (list (if (assoc (variable-index binding) 
initializations :test #'=)
                             ;; Fixed buffers have their special test 
to avoid activation
                             'direct-test-and-bind-buffer
                             (if *enable-rational-analysis*
                               (if direct 'direct-test-and-bind-pm
                                   'indirect-test-and-bind-pm)
                               (if direct 'direct-test-and-bind
                                   'indirect-test-and-bind)))
                           (variable-index binding) type tests binds))))
                ((eq '!eval! key)
                 (list 'eval-test (sub-eval-vars (first clause) bindings)))
                ((eq '!bind! key)
                 (with-binding binding bound (first clause) bindings index
                   (when bound
                     (signal-warn "VARIABLE ~S ALREADY BOUND IN PRODUCTION ~A."
                                  (first clause) production))
                   (list 'bind-lhs (variable-index binding)
                         (sub-eval-vars (second clause) bindings))))
                ((eq '!find-location! key)
                 (with-binding binding bound (first clause) bindings index
                   (when bound
                     (signal-warn "VARIABLE ~S ALREADY BOUND IN PRODUCTION ~A."
                                  (first clause) production))
                   (list 'bind-find-location (variable-index binding)
                         (sub-eval-vars (cons 'list (quote-arguments 
(rest clause)))
                                        bindings))))
                (t (signal-warn "UNKNOWN COMMAND ~S IN PRODUCTION ~A."
                                key production))))
         (setf code (nconc code form))))
     ;; FIX: split into goal and retrievals when ERA is enabled.
     (values (if *enable-rational-analysis*
               (let ((direct-length (first-retrieval-index code 
initializations)))
                 (cons (nconc (subseq code 0 direct-length) (list 
'add-instantiation-to-conflict-set))
                       (nconc (subseq code direct-length) (list 'not))))
               (nconc code (list 'add-instantiation-to-conflict-set)))
             bindings index)))

(defmacro compile-rhs-slots (bound-list unbound-list parent)
   "Compile slot-value pairs into a bound list and unbound (returns) list.
    Parent is used to know which goal this stack slot belongs to.
    Also update the text to replace constants with actual chunks for printing."
   `(dolist (slot-value clause)
      (setf negation (if (test-modifier (first slot-value)) (pop 
slot-value) nil))
      (setf slot (first slot-value))
      (setf slot (get-safe-slot slot type production))
      (setf value (second slot-value))
      (cond ((null slot))
            ((and (listp value) (eq '!eval! (first value)))
             (push-last (make-action :name (slot-name slot) :slot 
(slot-index slot)
                                     :value (sub-eval-vars (second 
value) bindings)
                                     :dispatch :eval :negation negation)
                        ,bound-list))
            ((and (not (variablep value)) (not (get-variable-binding 
value bindings)))
             (let ((wme-or-constant (get-wme-or-constant value)))
               (push-last (make-action :name (slot-name slot) :slot 
(slot-index slot)
                                       :value wme-or-constant
                                       :dispatch :literal :negation negation)
                          ,bound-list)
               (setf (second slot-value) wme-or-constant)))
            (t
             (with-binding value-binding bound value bindings index
               (cond (bound
                      (if (numberp (variable-index value-binding))
                        ; if a normal variable, then push the action
                        (push-last
                         (make-action :name (slot-name slot) :slot 
(slot-index slot)
                                      :value (variable-index value-binding)
                                      :dispatch :stack :negation negation)
                         ,bound-list)
                        ; otherwise, add the reference to the return stack
                        (let ((variable-references
                               (get-variable-binding value ,unbound-list)))
                          (push-last (cons (variable-name ,parent) 
(slot-index slot))
                                     (variable-returns variable-references)))))
                     (t
                      (when negation
                        (signal-warn "TEST MODIFIER ~S CANNOT BE USED 
TO SET ~S IN SLOT ~S IN PRODUCTION ~A: IGNORED."
                                     negation value slot production))
                      ; Return values do not need instantiation representation
                      ; stack index is the parent's name
                      (decf index)
                      (setf (variable-index value-binding) ,parent)
                      (setf (variable-slot value-binding) (slot-index slot))
                      (push-last value-binding ,unbound-list))))))))

(defmacro subgoal-returns (subgoal returns)
   "Select the returns from slots of subgoal."
   `(let ((selected nil))
      (dolist (return ,returns selected)
        (when (eq (variable-name (variable-index return)) ,subgoal)
          (push (variable-slot-and-returns return)
                selected)))))

(defun interpret-output-argument (argument bindings production)
   "Interprets a production variable as its stack index,
    and returns more complex arguments as functions."
   (if (variablep argument)
     (variable-index (get-safe-variable-binding argument bindings production))
     (sub-eval-vars argument bindings)))

(defun compile-output (clause bindings production)
   "Compiles an output clause for a production given bindings."
   (let ((output-string "~&~VT")
         (output-args nil))
     (when (and (listp (first clause)) (null (rest clause)))
       (setf clause (first clause)))
     (cond ((stringp (first clause))
            (setf output-string (concatenate 'string output-string 
(first clause)))
            (dolist (arg (rest clause))
              (push-last (interpret-output-argument arg bindings production)
                         output-args)))
           (t
            (dolist (arg clause)
              (cond ((or (variablep arg) (listp arg))
                     (setf output-string (concatenate 'string 
output-string "~S "))
                     (push-last (interpret-output-argument arg 
bindings production)
                                output-args))
                    (t
                     (setf output-string
                           (concatenate 'string output-string 
(coerce-string arg) " ")))))))
     (cons output-string output-args)))

(defmacro simulate-call (arguments)
   "Simulate production compilation by funcalling the function with the rest
    of the arguments."
   `(funcall (first ,arguments) (rest ,arguments)))

(defun assign-retrieval (arguments)
   "Assigns to the variable *retrieval-scheduler* the result and 
latency of the retrieval.
    The variable *retrieval* is also reset to nil waiting for the result."
   (let ((retrieval (if (first arguments)
                      (instantiation-variable *instantiation* (pop arguments))
                      *retrieval-scheduler*)))
     (signal-output *latency-trace* "Latency ~6,3F: ~A Retrieval" 
*latency* retrieval)
     (setf *retrieval* nil)
     (setf *retrieval-scheduler* (cons (+ *time* *latency*) retrieval))))

(defun handle-failure (arguments)
   "Calls whatever test-and-bind function is given as arguments.  If it fails,
    clean the bindings and set them as well as retrieval to the chunk failure.
    Failure is defined as being of the default type error with itself 
as condition."
   (unless (simulate-call arguments) ; if matching fails set the 
bindings to failure
     (let ((failure (get-wme 'failure)))
       (unless failure ; if failure isn't yet defined then add it
         (add-dm-fct '((failure isa error condition failure)) :reset-ia nil)
         (setf failure (get-wme 'failure)))
       (dolist (action (fifth arguments))
         (setf (instantiation-variable *instantiation* (action-value action))
               failure))
       (when (and (second arguments)
                  (member (first arguments) '(indirect-test-and-bind
                                              indirect-test-and-bind-pm)))
         (setf (instantiation-variable *instantiation* (second arguments))
               failure))

       (signal-output *latency-trace* "Latency ~6,3F: Failure 
Retrieval" *latency*)
       (setf *retrieval* nil)
       (setf *retrieval-scheduler* (cons (+ *time* *latency*) failure)))))

(defun assign-buffer (buffer-index)
   "Assigns value of instantiation variable index or function to buffer."
   (buffers-fct (list (first buffer-index)
                      (let ((value (second buffer-index)))
                        (when value
                          (if (numberp value)
                            (instantiation-variable *instantiation* value)
                            (get-wme-or-constant (funcall value))))))))

(defun compile-rhs (production rhs bindings index)
   "Compiles the right-hand side of production."
   (let ((code nil)
         (returns nil)
         (goal-stack (list (variable-name (first bindings)))))
     (dolist (clause rhs)
       (let ((key (pop clause))
             (type nil)
             (assigns nil)
             (slot nil)
             (value nil)
             (negation nil))
         (setf code (nconc code
          (cond ((retrievalp key)
                 (setf key (var>var key))
                 (when (actionp key) (setf key (var=var key))) ;; 
strip out the +
                 (cond ((clearp key)  ;; clearing buffers
                        (setf key (var=var key))  ;; strip out the -
                        (if (assoc key *buffer-keywords*)  ;; clearing 
ACT-R buffers
                          (list (list 'assign-buffer key nil))
                          (signal-warn "UNKNOWN BUFFER ~S CANNOT CLEAR." key)))
                       ((and (assoc key *buffer-keywords*) (null (rest clause))
                             (null (rest (first clause))) (listp 
(first (first clause))))
                        ;; assignment to buffer of result of function call
                        (list (list 'assign-buffer key
                                    (sub-eval-vars (first (first 
clause)) bindings))))
                       ((and (not (variablep key)) (assoc key *buffer-keywords*)
                             (null (rest clause)) (null (rest (first clause))))
                        ;; direct assignment to buffers, including 
goal focus and direct retrieval
                        (let ((binding (get-variable-binding (first 
(first clause)) bindings)))
                          (cond ((eq key 'goal)  ;; focus on goal
                                 (setf goal-stack (butlast goal-stack))
                                 (push-last key goal-stack)
                                 (list (list 'focus-fct
                                             (variable-index binding)
                                             (subgoal-returns key returns))))
                                ((eq key 'retrieval)   ;; direct retrieval
                                 (list (list 'handle-failure
                                             (if *enable-rational-analysis*
                                               'direct-test-and-bind-pm
                                               'direct-test-and-bind)
                                             (variable-index binding)
                                             type nil nil
                                             'assign-retrieval
                                             (variable-index binding))))
                                (t  ;; other buffer assignment
                                 (list (list 'assign-buffer key 
(variable-index binding)))))))
                       (t
                        (with-binding binding modify key bindings index
                          (cond (modify
                                 (setf type (variable-type binding))
                                 (if (and type (not (integerp type)))
                                   (when (eq 'isa (caar clause))
                                     (set-variable-type production 
type key (pop clause))
                                     (unless (or (eq type 
(variable-type binding))
                                                 (assoc key *buffer-keywords*))
                                       (signal-warn "TYPE OF VARIABLE 
~S IS BEING REDEFINED IN PRODUCTION ~A."
                                                    key production)))
                                   (set-variable-type production type 
key (pop clause))))
                                (t
                                 (set-variable-type production type 
key (pop clause))))
                          (when type
                            (cond ((or (eq 'retrieval key)
                                       (member (list '!retrieve! key) 
rhs :test #'equal))
                                   (let ((tests nil)
                                         (binds nil))
                                     (compile-lhs-slots tests binds)
                                     (list (list 'handle-failure
                                                 (if *enable-rational-analysis*
                                                   (if modify
                                                     'direct-test-and-bind-pm
                                                     'indirect-test-and-bind-pm)
                                                   (if modify
                                                     'direct-test-and-bind
                                                     'indirect-test-and-bind))
                                                 nil
                                                 type tests binds
                                                 'assign-retrieval
                                                 nil))))
                                  (t
                                   (compile-rhs-slots assigns returns binding)
                                   (cons
                                    (if modify
                                      (list 'modify-old-wme 
(variable-index binding)
                                            type assigns)
                                      (list 'create-new-wme 
(variable-index binding)
                                            (if (variablep key) 
(var=var key) key) type assigns))
                                    (when (and (or (eq '=newgoal key) 
(eq 'newgoal key) (eq 'goal key))
                                               (not (member (list 
'!push! key) rhs :test #'equal))
                                               (not (member (list 
'!focus-on! key) rhs :test #'equal)))
                                      (setf goal-stack (butlast goal-stack))
                                      (push-last key goal-stack)
                                      (list (list 'focus-fct
                                                  (variable-index binding)
                                                  (subgoal-returns key 
returns))))))))))))
                ((eq '!retrieve! key) ;; do nothing since retrieval already done
                 nil)
                ((eq '!push! key)
                 (let* ((subgoal (first clause))
                        (binding (get-safe-variable-binding subgoal 
bindings production)))
                   (when binding
                     (push-last subgoal goal-stack)
                     (list (list 'push-fct
                                 (variable-index binding)
                                 (subgoal-returns subgoal returns))))))
                ((eq '!pop! key)
                 ;;; FIX: pop from the end of the stack
                 (setf goal-stack (butlast goal-stack))
                 (list (list 'pop-fct)))
                ((eq '!focus-on! key)
                 (let* ((subgoal (first clause))
                        (binding (get-safe-variable-binding subgoal 
bindings production)))
                   (when binding
                     ;;; FIX: do not assume that there is something on the stack
                     (setf goal-stack (butlast goal-stack))
                     (push-last subgoal goal-stack)
                     (list (list 'focus-fct
                                 (variable-index binding)
                                 (subgoal-returns subgoal returns))))))
                ((eq '!output! key)
                 (list (list 'output (compile-output clause bindings 
production))))
                ((eq '!eval! key)
                 (list (list 'eval-side (sub-eval-vars (first clause) 
bindings))))
                ((eq '!bind! key)
                 (with-binding binding bound (first clause) bindings index
                   (when bound
                     (signal-warn "VARIABLE ~S ALREADY BOUND IN PRODUCTION ~A."
                                  (first clause) production))
                   (list (list 'bind-rhs (variable-index binding)
                               (sub-eval-vars (second clause) bindings)))))
                ((eq '!move-attention! key)
                 (with-binding binding bound (first clause) bindings index
                   (when bound
                     (signal-warn "VARIABLE ~S ALREADY BOUND IN PRODUCTION ~A."
                                  (first clause) production))
                   (list (list 'bind-move-attention (variable-index binding)
                               (sub-eval-vars (cons 'list 
(quote-arguments (rest clause)))
                                              bindings)))))
                ((eq '!press-key! key)
                 (list (list 'visual-action 'press-key
                             (sub-eval-vars (cons 'list 
(quote-arguments clause))
                                            bindings))))
                ((eq '!move-mouse! key)
                 (list (list 'visual-action 'move-mouse
                             (sub-eval-vars (cons 'list 
(quote-arguments clause))
                                            bindings))))
                ((eq '!click-mouse! key)
                 (list (list 'visual-action 'click-mouse
                             (sub-eval-vars (cons 'list 
(quote-arguments clause))
                                            bindings))))
                ((eq '!send-command! key)
                 (list (list 'action-command
                             (sub-eval-vars (cons 'list 
(quote-arguments clause))
                                            bindings))))
                ((eq '!delete! key)
                 (let ((binding (get-safe-variable-binding (first 
clause) bindings production)))
                   (when binding
                     (list (list 'delete-wme-variable (variable-index 
binding))))))
                ((or (eq '!copy! key) (eq '!copywme! key))
                 (with-binding binding bound (first clause) bindings index
                   (when bound
                     (signal-warn "VARIABLE ~S ALREADY BOUND IN PRODUCTION ~A."
                                  (first clause) production))
                   (list (list 'copy-chunk-variable (variable-index binding)
                               (sub-eval-vars (cons 'list (rest clause))
                                              bindings)))))
                ((eq '!stop! key)
                 (list (list 'stop)))
                ((eq '!restart! key)
                 (list (list 'restart-top-goal)))
                (t (signal-warn "UNKNOWN COMMAND ~S IN PRODUCTION ~A." 
key production)))))))
     ; remove the unknown commands
     ; (setf code (delete nil code :test #'eq))
     ; translate wme variables into relative goal stack indices for 
value returns
     (dolist (return returns)
       (let ((from-position
              (position (variable-name (variable-index return))
                        goal-stack :test #'eq)))
         (if from-position
           (dolist (destination (variable-returns return))
             (let ((to-position (position (first destination) 
goal-stack :test #'eq)))
               (if (and (numberp to-position) (> from-position to-position))
                 (rplaca destination (- from-position to-position 1))
                 (signal-warn "VARIABLE ~A CANNOT BE RETURNED BECAUSE 
CHUNK ~A IS NOT ON THE STACK BELOW SUBGOAL ~A IN PRODUCTION ~A."
                        (variable-name return) (first destination)
                        (variable-name (variable-index return)) production))))
           (signal-warn "VARIABLE ~A CANNOT BE RETURNED BECAUSE CHUNK 
~A IS NOT ON THE STACK IN PRODUCTION ~A."
                        (variable-name return)
                        (variable-name (variable-index return)) production))))
     (values code bindings index)))

(defun compile-buffers (production lhs bindings index)
   "Compiles the left-hand side references to pre-defined buffers such 
as goal and retrieval."
   (declare (ignore production))
   (let ((initializations nil)
         (type t))
     (dolist (clause lhs)
       (let ((key (first clause)))
         (when (retrievalp key)
           (setf key (var>var key))
           (let ((buffer (assoc key *buffer-keywords*)))
             ;;; sets the type of the goal
             (when (or (eq key '=goal) (eq key 'goal))
               (setf type (second (assoc 'isa (rest clause)))))
             (when buffer
               ;;; When the retrieval refers to a buffer, create a new binding
               (with-binding binding existing key bindings index
                 (unless existing
                   (push-last (cons index (rest buffer))
                              initializations))))))))
;    (signal-output *command-trace* "The special buffers in 
production ~S are ~S"
;                   production initializations)
     (values type initializations bindings index)))

(defun compile-production (name lhs rhs &optional (documentation nil))
   "Compile production name, type, lhs, rhs and optional documentation."
   (let ((production nil)
         (type nil)
         (initializations nil)
         (bindings nil)
         (retrievals nil)
         (lhs-code nil)
         (rhs-code nil)
         (stack-index (1- *instantiation-slots*)))
     (setf production (get-production name))
     (multiple-value-setq (type initializations bindings stack-index)
       (compile-buffers name lhs bindings stack-index))
     (setf type (get-safe-type type name))
     (when type
       (cond (production
              (signal-warn "PRODUCTION ~S IS BEING REDEFINED." name)
              (delete-production production))
             (t
              (setf production (make-production :name name))
              (save-state-change :compile-production production)))
       (push-last (cons name production) *procedural-memory*)
       (setf (production-documentation production) documentation)
       (setf (production-goal-type production) type)
       (push-last production (wme-type-productions type))
       (setf (production-text production) (cons lhs rhs))
;      (setf bindings (list (make-variable-binding (var>var (first 
(first lhs)))
;                                                  stack-index)))
       (setf (production-initializations production) initializations)
       (multiple-value-setq (lhs-code bindings stack-index)
         (compile-lhs name lhs initializations bindings stack-index))
       (setf (production-lhs production) lhs-code)
       (multiple-value-setq (rhs-code bindings stack-index)
         (compile-rhs name rhs bindings stack-index))
       (setf (production-rhs production) rhs-code)
       (setf (production-bindings production) bindings)
       (dolist (binding (rest bindings))
         (when (typep (variable-type binding) 'wme-type)
           (push-last (variable-index binding) retrievals)))
       (setf (production-retrievals production) retrievals)
       (setf (production-size production) (+ stack-index 1))
       (setf (production-instantiation production) (make-instantiation 
production))
       ;; FIX: no more setting of extra-instantiation
       (pg-c production)
       production)))

(defun p-fct (definition)
   "Defines a production by parsing then compiling it."
   (multiple-value-bind (name lhs rhs documentation)
                        (parse-production definition)
     (let ((production (compile-production name lhs rhs documentation)))
       (when production (production-name production)))))

(defun penable-fct (names)
   "Enables disabled productions."
   (let ((production nil))
     (save-state-change :penable-fct names)
     (dolist (name names (mapcar #'car *failed-productions*))
       (setf production (get-safe-production name *failed-productions*))
       (when production
         (setf *failed-productions* (delete (production-name 
production) *failed-productions*
                                            :test #'eq :key #'car :count 1))
         (push-last (cons (production-name production) production) 
*procedural-memory*)
         (push-last production (wme-type-productions 
(production-goal-type production)))
         (pg-c production)))))

(defun pdisable-fct (names)
   "Disables productions."
   (let ((production nil))
     (save-state-change :pdisable-fct names)
     (dolist (name names (mapcar #'car *failed-productions*))
       (setf production (get-safe-production name))
       (when production
         (delete-production production)
         (push-last (cons (production-name production) production)
                    *failed-productions*)))))

(defun pbreak-fct (names)
   "Sets break points for productions."
   (let ((production nil))
     (dolist (name names *break-productions*)
       (setf production (get-safe-production name))
       (when production
         (push-last (production-name production) *break-productions*)))))

(defun punbreak-fct (names)
   "Removes break points for productions."
   (let ((production nil))
     (dolist (name (or names *break-productions*) *break-productions*)
       (setf production (get-safe-production name))
       (when production
         (setf *break-productions* (delete (production-name production)
                                           *break-productions*
                                           :test #'eq :count 1))))))

(defmacro print-side (side)
   "Prints one side of a production, i.e. a list of commands and wme 
retrievals."
   `(dolist (clause ,side)
      (cond ((retrievalp (first clause))
             (signal-output trace "   ~S" (first clause) )
             (dolist (slot-value (rest clause))
               (if (null (rest slot-value))
                 (signal-output trace "      ~S" (first slot-value))
                 (signal-output trace "    ~A ~S ~S"
                                (if (test-modifier (first slot-value)) 
(pop slot-value) " ")
                                (first slot-value)
                                (second slot-value)))))
            (t
             (signal-output trace "  ~{ ~S~}" clause)))))


(defun pprint-production (production &optional (trace *command-trace*)
                                      (text (production-text production))
                                      (documentation 
(production-documentation production)))
   "Pretty prints production.  Pretty basic."
   (signal-output trace "(p ~S" production)
   (when documentation
     (signal-output trace "   ~S" documentation))
   (print-side (car text))
   (signal-output trace "==>")
   (print-side (cdr text))
   (signal-output trace ")")
   (production-name production))

(defun pp-fct (productions)
   "Prints the list of productions, or all the active ones if none specified."
   (let ((*verbose* t)
         (*goal-depth* 1)
         (structures nil))
     (if productions
       (dolist (production productions)
         (setf production
               (or (get-production production)
                   (get-safe-production production *failed-productions*)))
         (when production
           (push-last (pprint-production production) structures)))
       (dolist (production *procedural-memory*)
         (setf production (cdr production))
         (push-last (pprint-production production) structures)))
     structures))


;;; Production parameters setting and printing

(defun displayable-production-parameters ()
   "Returns the list of displayable production parameters given
    the current values of global parameters.  Used by the interface."
   (nconc
    (list :chance :effort)
    (if *enable-rational-analysis*
      (nconc
       (list :strength)
       (when (or *strength-learning*
                 (numberp *parameters-learning*))
         (list :creation-time))
       (when *strength-learning*
         (list :references))
       (list :q :a :r :b :pg-c)
       (when *parameters-learning*
         (list :successes :failures :efforts
               :eventual-successes :eventual-failures :eventual-efforts
               :success :failure)))
      (list :value))))

(defun settable-production-parameters ()
   "Returns the list of settable production parameters given
    the current values of global parameters.  Used by the interface."
   (nconc
    (list :chance :effort)
    (if *enable-rational-analysis*
      (nconc
       (when (or *strength-learning*
                 (numberp *parameters-learning*))
         (list :creation-time))
       (if *strength-learning*
         (list :references)
         (list :strength))
       (if *parameters-learning*
         (list :successes :failures :efforts
               :eventual-successes :eventual-failures :eventual-efforts
               :success :failure)
         (list :q :a :r :b)))
      (list :value))))

(defun default-production-parameters ()
   "Returns the production parameters with their default values.
    Used by the interface."
   (nconc
    (list (cons :chance 1.0) (cons :effort *default-action-time*))
    (if *enable-rational-analysis*
      (nconc
       (when (or *strength-learning*
                 (numberp *parameters-learning*))
         (list (cons :creation-time *time*)))
       (if *strength-learning*
         (list (cons :references (cons 1.0 (when (and 
*strength-learning* (not *optimized-learning*)) (list *time*)))))
         (list (cons :strength 0.0)))
       (if *parameters-learning*
         (list (cons :successes (cons 1.0 (when (numberp 
*parameters-learning*) *time*)))
               (cons :eventual-successes (cons 1.0 (when (numberp 
*parameters-learning*) *time*)))
               (cons :failures (list 0.0)) (cons :eventual-failures (list 0.0))
               (cons :efforts (cons *default-action-time* (when 
(numberp *parameters-learning*)
 
*default-action-time*)))
               (cons :eventual-efforts (cons 1.0 (when (numberp 
*parameters-learning*) 1.0))))
         (list (cons :q 1.0) (cons :a *default-action-time*)
               (cons :r 1.0) (cons :b 1.0))))
      (list :value))))

(defun displayable-declarative-parameters ()
    "Returns the list of displayable declarative parameters given
    the current values of global parameters.  Used by the interface."
    (when *enable-rational-analysis*
      (nconc
       (list :activation :source :base-level)
       (when *base-level-learning*
         (list :creation-time :references))
       (list :source-spread :ias)
       (when *associative-learning*
         (list :creation-cycle :needed :contexts))
       (when *permanent-activation-noise*
         (list :permanent-noise))
       (when *partial-matching*
         (list :similarities)))))

(defun settable-declarative-parameters ()
    "Returns the list of settable declarative parameters given
    the current values of global parameters.  Used by the interface."
    (when *enable-rational-analysis*
      (nconc
       (if *base-level-learning*
         (list :creation-time :references)
         (list :base-level))
       (when *associative-learning*
         (list :creation-cycle :needed :contexts))
       (when *permanent-activation-noise*
         (list :permanent-noise)))))

(defun production-parameter-fct (production &optional parameters)
   "Returns the value of the production parameter(s), or print all if 
none given."
   (let ((*verbose* t)
         (*goal-depth* 1)
         (value nil)
         (values nil))
     (setf production (get-safe-production production))
     (cond (production
            (signal-output *command-trace* "Parameters for production 
~S:" production)
            ;;; updates production strength and parameters.
            (when *strength-learning*
              (strength production))
            (when (numberp *parameters-learning*)
              (recompute-production-parameters production))
            (cond (parameters
                   (dolist (parameter parameters)
                     (setf value
                           (case parameter
                             (:name (production-name production))
                             (:strength (production-strength production))
                             (:creation-time (production-creation-time 
production))
                             (:references (production-references production))
                             (:p (production-p production))
                             (:c (production-c production))
                             (:pg-c (production-pg-c production))
                             (:value (production-value production))
                             (:successes (production-successes production))
                             (:failures (production-failures production))
                             (:efforts (production-efforts production))
                             (:chance (production-chance production))
                             (:effort (production-effort production))
                             (:success (production-success production))
                             (:failure (production-failure production))
                             (t (signal-warn "NO PARAMETER ~A DEFINED 
FOR PRODUCTIONS (TRY : IN FRONT)."
                                             parameter)
                                :error)))
                     (push-last value values)
                     (signal-output *command-trace* "~S ~6,3F" parameter value))
                   (signal-output *command-trace* "")
                   values)
                  (t
                   (signal-output *command-trace* ":Chance ~6,3F~% 
:Effort ~6,3F"
                                  (production-chance production) 
(production-effort production))
                   (when *enable-rational-analysis*
;                    (signal-output *command-trace* ":Strength ~6,3F" 
(strength production))
                     (when (or *strength-learning*
                               (numberp *parameters-learning*))
                       (signal-output *command-trace* ":Creation-Time 
~6,3F" (production-creation-time production)))
                     (when *strength-learning*
                       (signal-output *command-trace* ":References 
~6,3F" (production-references production))))
                   (if *enable-rational-analysis*
                     (signal-output *command-trace*
                                    ":P ~6,3F~% :C ~6,3F~% :PG-C ~6,3F~%"
                                    (production-p production) 
(production-c production)
                                    (production-pg-c production))
                     (signal-output *command-trace* ":Value ~6,3F"
                                    (production-value production)))
                   (when *parameters-learning*
                     (signal-output *command-trace*
                                    ":Successes ~6,3F~% :Failures 
~6,3F~% :Efforts ~6,3F~%~
                                     ~1T:Success ~6,3F~% :Failure ~6,3F"
                                    (production-successes production) 
(production-failures production) (production-efforts production)
                                    (production-success production) 
(production-failure production)))
                   (signal-output *command-trace* "")
                   production)))
           (t :error))))

(defmacro set-parameter (slot parameter test warning &rest housekeeping)
   "Sets parameter of production p in slot if value passes test,
    otherwise issue warning."
   `(cond (,test
           (setf (,slot p) value)
           ,@housekeeping
           value)
          (t
           (signal-warn "PARAMETER ~A CANNOT TAKE VALUE ~S BECAUSE IT 
MUST BE ~:@(~A~)."
                          ,parameter value ,warning)
           :error)))

(defmacro pre-process-production-references (p value optimized)
   "Pre-process a specification of references into the proper format."
   `(progn
      (decf (production-time-stamp ,p) 1.0)
      ; pre-process references
      (when (listp ,value)
        (setf ,value (cons (length ,value) (copy-list ,value)))
        (let ((*optimized-learning* ,optimized))
          (adapt-references ,value (production-creation-time ,p))))
      (when (numberp ,value)
        (setf ,value (list ,value))
        (let ((*optimized-learning* ,optimized))
          (adapt-references ,value (production-creation-time ,p))))))

(defmacro pre-process-production-efforts (p value optimized references)
   "Pre-process a specification of efforts into the proper format."
   `(progn
      (decf (production-time-stamp ,p) 1.0)
      ; pre-process references
      (when (listp ,value)
        (let ((efforts 0.0))
          (dolist (effort ,value)
            (incf efforts effort))
          (setf ,value (cons efforts (copy-list ,value)))))
      (when (numberp ,value)
        (let ((ratio (round ,references)))
          (setf ,value
                (cons ,value
                      (unless ,optimized
                        (make-list ratio :initial-element (/ ,value 
ratio)))))))))

(defun parameters-fct (p parameters)
   "Sets the parameters of production.  Keyword arguments have been 
discontinued."
   (let ((values nil))
     (setf p (get-safe-production p))
     (if p
       (loop
         (unless parameters (recompute-production-parameters p) (return values))
         (let* ((parameter (pop parameters))
                (value (pop parameters)))
           (when (and (listp value) (eq (first value) 'quote))
             (setf value (second value)))  ;; for compatibility with 
evaluating versions
           (push-last
            (case parameter
              (:name
               (signal-warn "PARAMETER NAME CANNOT BE SET.")
               :error)
              (:strength
               (cond (*strength-learning*
                      (signal-warn "PARAMETER STRENGTH CANNOT BE SET 
DIRECTLY WHEN STRENGTH LEARNING IS ENABLED: SET CREATION-TIME AND 
REFERENCES INSTEAD.")
                      :error)
                     (t
                      (set-parameter production-strength :strength 
(numberp value) "a number"))))
              (:creation-time
               (decf (production-time-stamp p) 1.0)
               (set-parameter production-creation-time :creation-time
                              (numberp value) "a number"))
              (:references
               (pre-process-production-references p value *optimized-learning*)
               (set-parameter production-references :references
                              (or (numberp value) (listp value))
                              "a number or list of numbers"))
              (:value
               (unless (constantp value)
                 (setf value (build-functional-parameter value 
(production-bindings p))))
               (set-parameter production-value :value
                              (or (numberp value) 
(functional-parameter-p value))
                              "a number of function"))
              (:pg-c
               (signal-warn "PRODUCTION PG-C CANNOT BE SET DIRECTLY: 
SET INDIVIDUAL PARAMETERS INSTEAD.")
               :error)
              (:p
               (cond (*parameters-learning*
                      (signal-warn "PARAMETER P CANNOT BE SET DIRECTLY 
WHEN PARAMETERS LEARNING IS ENABLED: SET SUCCESSES AND FAILURES 
INSTEAD.")
                      :error)
                     (t
                      (set-parameter production-p :p
                                     (and (numberp value) (>= value 
0.0) (<= value 1.0))
                                     "a number between 0.0 and 1.0"))))
              (:c
               (cond (*parameters-learning*
                      (signal-warn "PARAMETER C CANNOT BE SET DIRECTLY 
WHEN PARAMETERS LEARNING IS ENABLED: SET SUCCESSES AND EFFORTS 
INSTEAD.")
                      :error)
                     (t
                      (set-parameter production-c :c (and (numberp 
value) (>= value 0.0))
                                     "a non-negative number"))))
              (:successes
               (pre-process-production-references p value
                                                  (not (numberp 
*parameters-learning*)))
               (set-parameter production-successes :successes
                              (or (numberp value) (listp value))
                              "a number or list of numbers"))
              (:failures
               (pre-process-production-references p value
                                                  (not (numberp 
*parameters-learning*)))
               (set-parameter production-failures :failures
                              (or (numberp value) (listp value))
                              "a number or list of numbers"))
              (:efforts
               (pre-process-production-efforts p value
                                               (not (numberp 
*parameters-learning*))
                                               (first (production-successes p)))
               (set-parameter production-efforts :efforts
                              (or (numberp value) (listp value))
                              "a number or list of numbers"))
              (:chance
               (unless (constantp value)
                 (setf value (build-functional-parameter value 
(production-bindings p))))
               (set-parameter production-chance :chance
                              (or (and (numberp value) (>= value 0.0) 
(<= value 1.0))
                                  (null value) (functional-parameter-p value))
                              "NIL or a function or number between 0.0 
and 1.0"))
              (:effort
               (unless (constantp value)
                 (setf value (build-functional-parameter value 
(production-bindings p))))
               (set-parameter production-effort :effort
                              (or (and (numberp value) (>= value 0.0))
                                  (null value) (functional-parameter-p value))
                              "NIL or a non-negative number or function"))
              (:success
               (unless (constantp value)
                 (setf value (build-functional-parameter value 
(production-bindings p))))
               (set-parameter production-success :success
                              (or (null value) (eq value t) 
(functional-parameter-p value))
                              "T or NIL or a function"))
              (:failure
               (unless (constantp value)
                 (setf value (build-functional-parameter value 
(production-bindings p))))
               (set-parameter production-failure :failure
                              (or (null value) (eq value t) 
(functional-parameter-p value))
                              "T or NIL or a function"))
              (t
               (signal-warn "NO PARAMETER ~A DEFINED FOR PRODUCTIONS." 
parameter)
               :error))
            values)))
       :error)))

(defun spp-fct (parameters)
   "Inspects and sets production parameters."
   (let ((results nil))
     (if (null parameters) ; print all parameters for all productions
       (dolist (production *procedural-memory*)
         (push-last (production-parameter-fct (cdr production)) results))
       (dolist (description (if (or (keywordp (first parameters))
                                    (keywordp (second parameters))
                                    (and (listp (first parameters))
                                         (null (second parameters))
                                         (not (keywordp (second (first 
parameters))))))
                              (list parameters) parameters))
         (when (atom description) (setf description (list description)))
         (if (keywordp (first description))
           (dolist (production *procedural-memory*)
             (push-last
              (if (and (cdr description) (not (keywordp (second description))))
                (parameters-fct (cdr production) description)
                (production-parameter-fct (cdr production) description))
              results))
           (dolist (production (if (atom (first description))
                                 (list (first description))
                                 (first description)))
             (push-last
              (if (and (cddr description) (not (keywordp (third description))))
                (parameters-fct production (rest description))
                (production-parameter-fct production (rest description)))
              results)))))
     results))


;;; Run Time

(defmacro subtype (sub type)
   "Tests whether sub is a subtype of supertype.  Actually, the other way
    around since the listof supertypes is likely to be shorter."
   `(member ,type (wme-type-supertypes ,sub)))

(defun match-lhs (production)
   "Matches the lhs of a production."
   (let ((gain 0.0))
     (when *enable-rational-analysis*
       (setf gain (get-pg-c production))
       (when *exp-gain-noise*
         (incf gain (noise *exp-gain-noise*))))
     (if (and *utility-threshold* (< gain *utility-threshold*))
       (signal-output (or *exact-matching-trace* *partial-matching-trace*)
                      "Production ~S PG-C ~6,3F is below threshold: rejected."
                      production (production-pg-c production))
       (let ((i (production-size production))
             (lhs (production-lhs production)))
         (signal-output (or *exact-matching-trace* *partial-matching-trace*)
                        "Matching production ~S." production)
         (setf *instantiation* (production-instantiation production))
         (loop (decf i 1) (when (= i 0) (return))
               (setf (instantiation-variable *instantiation* i) nil))
;        (setf (instantiation-variable *instantiation* *instantiation-slots*)
;              *wmfocus*)
         (dolist (initialization (production-initializations production))
           (setf (instantiation-variable *instantiation* (car initialization))
                 (symbol-value (cdr initialization))))
         (setf *extra-instantiation* (production-extra-instantiation 
production))
         ; FIX: call just the car of lhs if :era is enabled.
         (when *enable-rational-analysis*
           (setf (instantiation-gain *instantiation*) gain)
           (setf lhs (car lhs)))
         (simulate-call lhs)))
     *conflict-set*))

;;; Analogy

(defun get-wmes (tree &optional (constants nil))
   "Returns the list of wmes in tree.  If constants is t, they are preserved."
   (let ((wme-list nil))
     (dolist (leaf (if (consp tree) tree (when tree (list tree))) wme-list)
       (if (consp leaf)
         (setf wme-list (nconc wme-list (get-wmes leaf constants)))
         (let ((wme (if (wmep leaf) leaf
                        (or (get-wme leaf) (if constants leaf :no)))))
           (unless (eq wme :no) (push-last wme wme-list)))))))

(defun add-retrievals (retrievals variables constants singles
                                   &optional (differents nil))
   "Adds components of retrievals to either variables or singles."
   (dolist (retrieval retrievals (values variables constants singles))
     (when (and (atom retrieval) (not (wmep retrieval)))
       (setf retrieval (get-safe-wme retrieval)))
     (let ((wme (if (atom retrieval) retrieval (get-wme (first retrieval)))))
       (when (and wme (not (member wme variables :test #'equal)))
         (push wme variables)))
     (let ((wme-list nil))
       (cond ((wmep retrieval)
              (setf wme-list (rest (wme-slot-wmes retrieval)))
              (when differents
                (do ((rest-list wme-list (rest rest-list)))
                    ((null rest-list))
                  (setf wme-list (append (cdr (assoc (first rest-list) 
differents
                                                     :test #'equal))
                                         wme-list)))))
             (t
              (setf wme-list (get-wmes (rest retrieval)))))
       (dolist (wme wme-list)
         (unless (or (member wme variables :test #'equal)
                     (member wme constants :test #'equal))
           (cond ((member wme singles :test #'equal)
                  (push wme variables)
                  (setf singles (delete wme singles :test #'equal :count 1)))
                 (t
                  (push wme singles))))))))

(defun get-name-variable (value variables &optional (role nil))
   "Gets the variable associated with value from the a-list variables.
    If no variable has been associated with value, then create one 
according to role.
    If no role is specified, then just variabilize the name value.
    If the name is taken, increment a counter until a free one is found."
   (let* ((name (if (wmep value) value (or (get-wme value) value)))
          (pair (assoc name variables :test #'equal)))
     (if pair
       (or (rest pair)
           (let* ((variable-name
                   (concatenate 'string "=" (coerce-string (or role name))))
                  (variable (intern variable-name))
                  (counter 0))
             (loop
               (if (and (not (eq role 'goal))
                        (rassoc variable variables))
                 (setf variable (intern (concatenate 'string variable-name
                                                     (coerce-string 
(incf counter)))))
                 (return)))
             (rplacd pair variable)
             variable))
       name)))

(defun wme-description (wme variables dont-cares
                             &key (differents nil) (isa-slot t) (name 
wme) (role nil))
   "Generates a pre-parsed production description of a wme, 
variabilizing variables.
    All slots are generated, except for dont-cares values.
    Slot negations are generated using differents.
    Also insert chunks and chunk types directly rather than as their names."
   (let* ((wmetype (wme-type wme))
          (wmename (var-var> (get-name-variable name variables
                                                (or role 
(wme-type-name wmetype)))))
          (slot-value nil)
          (slot-list nil)
          (different nil))
     (dolist (slot (wme-type-slots wmetype)
                   (when (or slot-list isa-slot)
                     (nconc (list wmename)
                            (when isa-slot (list (list 'isa wmetype)))
                            slot-list)))
       (setf slot-value (wme-slot wme (slot-index slot)))
       (when (and (or isa-slot
                      (not (eq slot-value (wme-slot name (slot-index slot)))))
                  (not (member slot-value dont-cares :test #'equal)))
         (push-last (list (slot-name slot) (get-name-variable 
slot-value variables
                                                              (slot-name slot)))
                    slot-list)
         (setf different (cdr (assoc slot-value differents :test #'equal)))
         (dolist (not different)
           (push-last (list '- (slot-name slot) (get-name-variable not 
variables))
                      slot-list))))))

(defun replace-variable-names (expression variables)
   "Replaces the values in expression using the variables alist."
   (if (listp expression)
     (let ((list nil))
       (dolist (value expression list)
         (push-last (replace-variable-names value variables) list)))
     (get-name-variable expression variables)))

(defun create-production (problem constraints solutions modified actions pop
                                   variables dont-cares differents)
   "Generates a production from analogy."
   ; production name based on goal type
   (let* ((type (wme-type-name (wme-type problem)))
          (name (safe-gentemp (coerce-string type)))
          (wme-variables nil)
          (wme nil)
          (lhs nil)
          (rhs nil))
     ; associate the variable wmes to their variablized name, initialized to NIL
     (dolist (variable variables)
       (push (list variable) wme-variables))
     ; problem and retrievals and lhs
     (push-last (wme-description problem wme-variables dont-cares
                                 :differents differents :role 'goal)
                lhs)
     (dolist (constraint constraints)
       (cond ((atom constraint)
              (setf wme (get-safe-wme constraint))
              (when wme
                (push-last (wme-description wme wme-variables 
dont-cares :differents differents)
                           lhs)))
             ((commandp (first constraint))
              (push-last (replace-variable-names constraint wme-variables) lhs))
             (t
              (setf wme (replace-variable-names constraint wme-variables))
              (rplaca wme (var-var> (first wme)))
              (process-clause wme)
              (push-last wme lhs))))
     ; subgoals in rhs
     (dolist (solution solutions)
       (push-last (wme-description solution wme-variables dont-cares 
:role 'subgoal)
                  rhs))
     (setf solutions (nreverse solutions))
     (when (and modified (eq (wme-type problem) (wme-type modified)))
       (let ((main-goal (wme-description modified wme-variables dont-cares
                                         :isa-slot nil :name problem 
:role 'goal)))
         (when main-goal (push-last main-goal rhs))))
     (let ((subgoal (pop solutions)))
       (if subgoal
         (push-last (list (if pop '!focus-on! '!push!)
                          (get-name-variable subgoal wme-variables 'subgoal))
                    rhs)
         (when pop
           (push-last (list '!pop!) rhs))))
     (dolist (solution solutions)
       (push-last (list '!push! (get-name-variable solution 
wme-variables 'subgoal))
                  rhs))
     (dolist (action actions)
       (push-last (replace-variable-names action wme-variables) rhs))
     (values name type lhs rhs)))

(defun identical-productions (new old &optional (vars nil))
   "Checks whether the production bodies old and new are identical."
   (do ((rest-new new (rest rest-new))
        (rest-old old (rest rest-old)))
       ((or (null rest-new) (null rest-old))
        (when (and (null rest-new) (null rest-old)) vars))
     (let ((first-new (first rest-new))
           (first-old (first rest-old)))
       ;; Fix: make sure that it both ends with > AND starts with =
       (when (and (retrievalp first-new) (variablep first-new))
         (setf first-new (var>var first-new)))
       (when (and (retrievalp first-old) (variablep first-old))
         (setf first-old (var>var first-old)))
       (cond ((and (variablep first-new) (variablep first-old))
              (let ((first-new-assoc (cdr (assoc first-new vars :test #'eq)))
                    (first-old-assoc (car (rassoc first-old vars :test #'eq))))
                (if (or first-new-assoc first-old-assoc)
                  (unless (and (eq first-old first-new-assoc)
                               (eq first-new first-old-assoc))
                    (return nil))
                  (push (cons first-new first-old) vars))))
             ((and (listp first-new) (listp first-old))
              (unless (setf vars (identical-productions first-new 
first-old vars))
                (return nil)))
             ((equal first-new first-old))
             (t (return nil))))))

(defun reinforce-analogized-production (production)
   "Reinforces production by increasing the number of references."
   (when *strength-learning*
     (signal-output *production-compilation-trace* "Reinforcing 
production ~S." production)
     (add-reference (production-references production)))
   (when *parameters-learning*
     (signal-output *production-compilation-trace* "Updating 
parameters of production ~S."
                    production)
     (add-reference (production-successes production) (not (numberp 
*parameters-learning*)))
     (add-reference (production-efforts production) (not (numberp 
*parameters-learning*))
                    (production-effort production) (production-effort 
production))
     (recompute-production-parameters production)))

(defun compile-or-select-production (name type lhs rhs success failure
                                           &optional (documentation nil))
   "Either create a new production or select an existing identical one.
    Return a second value indicating whether it is an existing 
production (t) or not (nil)."
   (dolist (production (wme-type-productions (get-safe-type type name))
                       (let ((new-production (compile-production name 
lhs rhs documentation)))
                         (signal-output *production-compilation-trace* 
"Compiling Production ~A." new-production)
                         (parameters-fct name (nconc (list :success 
(if success t nil)
                                                           :failure 
(if failure t nil))
 
*production-compilation-parameters*))
                         (values new-production nil)))
     (when (identical-productions (cons lhs rhs) (production-text production))
       (signal-output *production-compilation-trace* "Recreating 
Production ~A." production)
       (when *reinforce-analogized-production*
         (reinforce-analogized-production production))
       (return (values production t)))))

(defun solve-by-analogy (dependency)
   "Main function to generate a production based on dependency.
    Returns the new analogized production."
   (signal-output *production-compilation-trace* "Analogizing to 
dependency ~S" dependency)
   (let ((stack-values (get-slot-value dependency 'stack))
         (stack-solutions nil)
         (stack-success nil)
         (stack-failure nil))
     (dolist (value (cond ((listp stack-values) stack-values)
                          ((wmep stack-values) (list (wme-name stack-values)))
                          (t nil)))
       (cond ((eq value 'success)
              (setf stack-success t))
             ((eq value 'failure)
              (setf stack-failure t))
             (t
              (push-last (if (wmep stack-values)
                           stack-values
                           (get-wme-or-constant value))
                         stack-solutions))))
     (let ((problem (first (get-wmes (get-slot-value dependency 'goal))))
           (solutions (nconc (get-wmes (get-slot-value dependency 'subgoals))
                             stack-solutions))
           (modified (first (get-wmes (get-slot-value dependency 'modified))))
           (constraints (get-slot-value dependency 'constraints))
           (actions (get-slot-value dependency 'actions))
           (success (or (get-slot-value dependency 'success) stack-success))
           (failure (or (get-slot-value dependency 'failure) stack-failure))
           (variables (get-wmes (get-slot-value dependency 'generals) t))
           (constants (get-wmes (get-slot-value dependency 'specifics) t))
           (dont-cares (get-wmes (get-slot-value dependency 'dont-cares) t))
           (differents (get-slot-value dependency 'differents))
           (pop nil)
           (singles nil))
       ;; Replace wme names in differents with the wmes themselves
       (when (and differents (not (listp (first differents))))
         (setf differents (list differents)))
       (dolist (different differents)
         (loop
           (unless different (return))
           (let ((wme (get-wme (first different))))
             (when wme (rplaca different wme)))
           (pop different)))
       ;; copy the constraints and action lists
       ;; checking for single conditions
       (setf constraints (if (or (not (listp constraints)) ; activation
                                 (commandp (first constraints)) ; !eval!
                                 (eq (second constraints) 'isa)) ; description
                           (list constraints)
                           (copy-list constraints)))
       (setf actions (if (not (listp actions)) ; !pop!
                       (list (list actions))
                       (if (commandp (first actions)) ; (!push! =goal)
                         (list actions)
                         (copy-list actions))))
       ;; check modified goal
       (when (and modified (not (eq (wme-type problem) (wme-type modified))))
         (push-last modified solutions)
         (setf modified nil)
         (setf pop t))
       (signal-output *production-compilation-trace* "The goal is ~S 
and the subgoals are~{ ~S~}"
                      problem (or solutions '(none)))
       ;; determine variables and constants
       (multiple-value-setq (variables constants singles)
         (add-retrievals (cons problem constraints)
                         variables constants singles differents))
       (multiple-value-setq (variables constants singles)
         (add-retrievals (append solutions (when modified (list 
modified)) actions)
                         variables constants singles))
       ;; compile the production
       (multiple-value-bind (name type lhs rhs)
                            (create-production problem constraints 
solutions modified
                                               actions (or success failure pop)
                                               variables dont-cares differents)
         (compile-or-select-production name type lhs rhs success failure)))))

(defun whynot-dependency-fct (dependencies)
   "Tests production compilation with the dependencies."
   (let ((*production-compilation-trace* *command-trace*)
         (*exact-matching-trace* *command-trace*)
         (*partial-matching-trace* *command-trace*)
         (*verbose* t)
         (*goal-depth* 1)
         (productions nil))
     (dolist (dependency dependencies productions)
       (let ((production (solve-by-analogy (get-safe-wme dependency))))
         (push-last (production-name production) productions)
         (pdisable-fct (list production))))))

(defun set-compilation-parameters-fct (params)
   "Sets the parameters for compiled productions."
   (setf *production-compilation-parameters* params))

#|
;;; New production compilation mechanisms

(defmacro condition-value (condition)
   "Return the value in a condition."
   `(if (test-modifier (first ,condition)) (third ,condition) (second 
,condition)))

(defmacro condition-slot (condition)
    "Return the slot in a condition."
  `(if (test-modifier (first ,condition)) (second ,condition) (first 
,condition)))

(defun condition-variables (conditions &optional (retrieval *retrieval*))
   "Returns the variables in a retrieval condition paired with their value."
   (let ((variables nil))
     (dolist (condition conditions variables)
       (let ((value (condition-value condition)))
         (when (variablep value)
           (push (cons value (chunk-slot-value-fct retrieval 
(condition-slot condition)))
                 variables))))))

(defun merge-conditions (dominant other exception)
   "Merge the other condition into the dominant condition after 
removing conflicts
    with exception.  Returns as result the variable-value pairs that 
should be replaced."
     (let ((variables nil))
       (dolist (condition (rest other) variables)
         (let ((conflict (assoc (condition-slot condition) (rest exception))))
           (if conflict
             (when (variablep (condition-value condition))
               (push (cons (condition-value condition) (second 
conflict)) variables))
             (unless (member condition dominant :test #'equal) ; do 
not duplicate conditions
               (push-last condition dominant)))))))

(defun compose-production-parameters (new old1 old2)
   (let ((effort (- (+ (production-effort old1) (production-effort old2))
                    *default-action-time*))
         (c (+ (production-c old1) *cost-penalty*))
         (p (production-p old1)))
     (when *production-compilation-trace*
       (pprint-production new *production-compilation-trace*))
     (if *parameters-learning*
       (spp-fct (list new :effort effort :successes (* p *initial-experience*)
                      :failures (* (- 1.0 p) *initial-experience*)
                      :efforts (* c *initial-experience*)))
       (spp-fct (list new :effort effort :p p :c c)))))

(defun compose (prod1 prod2)
   "Compose productions prod1 and prod2  into a new composite one.
    The perceptual-motor buffers are composed straightforwardly, since
    any problematic intersection has been ruled out.
    The retrieval buffers will be proceduralized if action in prod1 
and test in prod2.
    The goal buffers will be combined according to the special-purpose rules."
   (let ((test1 (copy-tree (first (production-text prod1))))
         (action1 (copy-tree (rest (production-text prod1))))
         (test2 (copy-tree (first (production-text prod2))))
         (action2 (copy-tree (rest (production-text prod2))))
         (lhs nil)
         (rhs nil))
     ;; if request for retrieval in action1 and test in test2, note 
the variables
     ;; appearing in those conditions (including =retrieval), delete 
the retrievals,
     ;; then replace the variables with their values in the remaining conditions
     (let ((retrieval-action1 (assoc '+retrieval> action1))
           (retrieval-test2 (assoc '=retrieval> test2)))
       (when (and retrieval-action1 retrieval-test2)
         (let ((variables-prod1 (condition-variables (rest retrieval-action1)))
               (variables-prod2 (cons (cons '=retrieval *retrieval*)
                                      (condition-variables (rest 
retrieval-test2)))))
           (setf action1 (delete retrieval-action1 action1))
           (setf test2 (delete retrieval-test2 test2))
           (setf test1 (nsublis variables-prod1 test1))
           (setf action1 (nsublis variables-prod1 action1))
           (setf test2 (nsublis variables-prod2 test2))
           (setf action2 (nsublis variables-prod2 action2))
           ;; handle the insertion of !eval! (equal <buffer> <value>) in test1
           (dolist (variable variables-prod1)
             (when (assoc (var-var> (car variable)) test1) ; if buffer 
appears in lhs
               (setf test1 (append test1 `((!eval! (equal ,(car 
variable) ',(cdr variable))))))))
           )))
     ;; handle the goal merging
;    (format t "~%TEST1: ~S ~%ACTION1: ~S~%TEST2: ~S~%ACTION2: ~S~%"
;            test1 action1 test2 action2)
     (let ((c1 (assoc '=goal> test1))
           (c2 (assoc '=goal> test2))
           (a1 (assoc '=goal> action1))
           (a2 (assoc '=goal> action2))
           (n1 (assoc '+goal> action1))
           (n2 (assoc '+goal> action2))
           (variables-prod1 nil)
           (variables-prod2 nil))
       (cond ((not n1) ;; no goal resetting: C1+(C2-A1), A2+(A1-A2), 
N2 if present
              (when (and (not c1) c2)
                (setf c1 (list (first c2) (second c2)))
                (push c1 action1))
              (setf variables-prod2 (append variables-prod2 
(merge-conditions c1 c2 a1))) ;; merge conditions into c1
              (setf test2 (delete c2 test2)) ;; remove c2
              (when (and a1 a2)
                (setf variables-prod1 (append variables-prod1 
(merge-conditions a2 a1 a2))) ;; merge actions into a2
                (setf action1 (delete a1 action1)))) ; remove a1
             ((not n2) ;; 1 goal resetting: C1, A1 and A2+(N1-A2)
              (when a2 ;; merge N1 into A2
                (rplaca a2 '+goal>)
                (unless (eq (first (second a2)) 'isa)
                  (rplacd a2 (cons (second n1) (rest a2))))
                (setf variables-prod1 (append variables-prod1 
(merge-conditions a2 n1 a2)))
                (setf action1 (delete n1 action1))
                (setf test2 (delete c2 test2))))
             (t ;; 2 goal resetting: C1, A1, N2, unless the goal reset 
is the same
              (setf action1 (delete n1 action1))
              (setf test2 (delete c2 test2))
              (setf action2 (delete a2 action2))))
       (setf test1 (nsublis variables-prod1 test1))
       (setf action1 (nsublis variables-prod1 action1))
       (setf test2 (nsublis variables-prod2 test2))
       (setf action2 (nsublis variables-prod2 action2))
       ;; handle the insertion of !eval! (equal <buffer> <value>) in 
test1 and test2
       (dolist (variable variables-prod1)
         (when (assoc (var-var> (car variable)) test1) ; if buffer 
appears in lhs
           (setf test1 (append test1 `((!eval! (equal ,(car variable) 
',(cdr variable))))))))
       (dolist (variable variables-prod2)
         (when (assoc (var-var> (car variable)) test2) ; if buffer 
appears in lhs
           (setf test2 (append test2 `((!eval! (equal ,(car variable) 
',(cdr variable))))))))
       )
;    (format t "~%TEST1: ~S ~%ACTION1: ~S~%TEST2: ~S~%ACTION2: ~S~%"
;            test1 action1 test2 action2)
     ;; merge everything
     (setf lhs (append test1 test2))
     (setf rhs (append action1 action2))
;    (format t "~%LHS: ~S~%RHS: ~S~%" lhs rhs)
     ;; create new production or reinforce existing one
     (let ((*reinforce-analogized-production* nil)
           (success (or (production-success prod1) (production-success prod2)))
           (failure (or (production-failure prod1) (production-failure prod2))))
       (multiple-value-bind (new-production identical)
                            (compile-or-select-production
                             (safe-gentemp "PRODUCTION")
                             (second (assoc 'isa (rest (assoc '=goal> lhs))))
                             lhs rhs success failure)
         (unless identical (compose-production-parameters 
new-production prod1 prod2))
         (spp-fct (list new-production))
         new-production))))

(defun filter-buffers (patterns buffers)
   (let ((keywords nil))
     (dolist (pattern patterns keywords)
       (when (retrievalp (first pattern))
         (let ((keyword (first pattern)))
           (when (member keyword buffers)
             (push-last (var=var keyword) keywords)))))))

(defun composable (first-actions second-tests)
   "Determines whether the productions first and second can be 
composed.  That means:
    No action (+ or -) on a buffer in first that is tested (=) in second.
    No retrieval request in first if second tests against an error."
   (let ((pm-actions '(+visual-location> +visual> +aural> 
+aural-location> +manual> +vocal>
                       -visual-location> -visual> -aural> 
-aural-location> -manual> -vocal>))
         (pm-tests '(=visual-location> =visual> =aural> 
=aural-location> =manual> =vocal>)))
     (and (null (intersection (filter-buffers first-actions 
pm-actions) ;; pm actions in 1st
                              (filter-buffers second-tests pm-tests))) 
;; pm test in 2nd
          (or (not (assoc '+retrieval> first-actions)) ;; no retrieval 
request or
              (not (eq (second (second (assoc '=retrieval> second-tests)))
                       (get-type 'error))) ;; no error test
              ))))

(defun compose-and-proceduralize (&optional (instantiation *instantiation*))
   "Composes instantiation with the previous instantiation stored in a 
special variable.
    Only works for ACT-R 5.0 buffer syntax.  Rules of composition have 
been generalized."
   (let ((new-production nil))
     (when (and *previous-instantiation* (<= *time* (+ (first 
*previous-instantiation*)
                                                      *threshold-time*)))
       (let ((previous-production (instantiation-production (rest 
*previous-instantiation*)))
             (production (instantiation-production instantiation)))
         (when (composable (rest (production-text previous-production))
                           (first (production-text production)))
           (setf new-production (compose previous-production production)))))
     (setf *previous-instantiation* (cons *time* (copy-instantiation 
instantiation)))
     new-production))
|#

;;; moved here before they are used by john's code to prevent warnings

(defmacro no-output (&rest forms)
   "Evaluates forms with *command-trace* turned off."
   `(let ((*command-trace* nil))
      ,@forms))

(defmacro sgp (&rest parameters)
   "Sets global parameters.  Checks values and performs housekeeping duties."
   `(sgp-fct ',parameters))


;;; John's compilation code integrated as is for now

;The change in the code below was motivated to deal with goal merging 
that resulted in different names
;for goals.  It is also hacked up to prevent print-outs
;This function generalizes a test in compose production
;That function makes reference to a global variable *merge*
(defun same-goal-test (g1 g2)
   (or (eq g1 g2)  (eq (headere g1)(car *merge*))))

#|
;;; Removed because of duplication
(defun delete-wme (wme &optional (identical nil))
   "Deletes a given wme node from the type memory and the hash table.
    Zeroes all its slots, and only proceed when it is not referenced. 
If identical
    is specified, any remaining reference to wme will be replaced with 
identical.
    Also replace occurrences of wme in buffers, retrieval scheduler and
    instantiation variables."
   (dolist (parent (rest (wme-fan wme)))
     (unless (eq parent wme)
       (if identical  ; replace references to wme in chunk slots with identical
         (dotimes (index (wme-type-size (wme-type parent)))
           (when (eq (wme-slot parent index) wme)
             (set-slot-value parent index identical)))
         (signal-output *command-trace* "CHUNK ~S IS STILL REFERENCED 
IN CHUNK ~S WHEN DELETED."
                        wme parent))))
   ;; Clear occurences of wme in buffers
   (dolist (buffer *buffer-keywords*)
     (setf buffer (cdr buffer))
     (when (eq (symbol-value buffer) wme)
       (setf (symbol-value buffer) identical)))
   ;; same for retrieval scheduler
   (when (eq (cdr *retrieval-scheduler*) wme)
     (rplacd *retrieval-scheduler* identical))
   ;; Clear occurences of wme in instantiation variables
   (let ((instantiation *instantiation*))
     (when instantiation
       (dotimes (variable (production-size (instantiation-production 
instantiation)))
         (when (eq (instantiation-variable instantiation variable) wme)
           (setf (instantiation-variable instantiation variable) identical)))))
   ;; When merging print a warning message
   (when  identical
;commenting out the print-out
;   (if *verbose* (signal-output *cycle-trace* "Merging chunk ~S into 
chunk ~S" wme identical))
;setting the global variable *merge* for its use in the above
     (setf *merge* (list wme identical)))
   (let ((wmetype (wme-type wme)))
     (decf *wme-number* 1.0)
     (dolist (slot (wme-type-slots wmetype))
       (set-slot-value wme (slot-index slot) nil))
     (remove-name (wme-name wme))
     (setf (wme-type-wmes wmetype)
           (delete wme (wme-type-wmes wmetype) :test #'eq :count 1))
     (save-state-change :delete-wme wme)))

(defun identical-productions (new old &optional (vars nil))
   "Checks whether the production bodies old and new are identical."
   (do ((rest-new new (rest rest-new))
        (rest-old old (rest rest-old)))
       ((or (null rest-new) (null rest-old))
        (when (and (null rest-new) (null rest-old)) vars))
     (let ((first-new (first rest-new))
           (first-old (first rest-old)))
       ;; Fix: make sure that it both ends with > AND starts with =
       (when (and (retrievalp first-new) (variablep first-new))
         (setf first-new (var>var first-new)))
       (when (and (retrievalp first-old) (variablep first-old))
         (setf first-old (var>var first-old)))
       (cond ((and (variablep first-new) (variablep first-old))
              (let ((first-new-assoc (cdr (assoc first-new vars :test #'eq)))
                    (first-old-assoc (car (rassoc first-old vars :test #'eq))))
                (if (or first-new-assoc first-old-assoc)
                  (unless (and (eq first-old first-new-assoc)
                               (eq first-new first-old-assoc))
                    (return nil))
                  (push (cons first-new first-old) vars))))
             ((and (listp first-new) (listp first-old))
              (unless (setf vars (identical-productions first-new 
first-old vars))
                (return nil)))
             ((equal first-new first-old))
             (t (return nil))))))

(defun learn-parameters (success failure &key (latency 0.0) 
(instantiation *instantiation*))
   "Applies the parameters learning equations to instantiation.  The 
success and/or
    failure of the goal has already been determined and is passed 
along with the latency
    of this instantiation and the instantiation itself (if it exists)."
   (let ((production (when instantiation (instantiation-production 
instantiation))))
;    (when (and (not success) (not failure) instantiation) ;; see if 
goal changes: success
;      (let ((goal-index (car (rassoc '*wmfocus* 
(production-initializations production)))))
;        (when (and goal-index  ;; not always mention of the goal in 
the production
;                   (not (equal *wmfocus* (instantiation-variable 
instantiation goal-index))))
;          (setf success t))))  ;;; success by default upon goal changes
     (cond ((and success failure)  ;; clear the history
            (setf *previous-instantiations* nil))
           ((or success failure)  ;; register success or failure for 
all productions
            (when production
              (push (cons production (- *time* latency)) 
*previous-instantiations*))
            (dolist (production-time *previous-instantiations*)
              (let* ((previous-production (car production-time))
                     (previous-time (cdr production-time))
                     (effort (- *time* previous-time)))
                (add-reference (if success (production-successes 
previous-production)
                                   (production-failures previous-production))
                               (not (numberp *parameters-learning*))
                               1.0 previous-time)
                (add-reference (production-efforts previous-production)
                               (not (numberp *parameters-learning*))
                               effort effort)
                (recompute-production-parameters previous-production)))
            (setf *previous-instantiations* nil))
           (t  ;; simply add the production
            (when production
              (push (cons production (- *time* latency)) 
*previous-instantiations*))))))
|#

(defun get-set (ins)
   (cond (ins
   (let ((list (get-instantiation ins)))
     (list (aref ins 0) (second (second (caar list)))
           (first list) (cdr list))))
         (t nil)))

(defun get-instantiation (&optional (instantiation *instantiation*)
                                        (trace *command-trace*)
                                        (format *production-trace*))
   "Pretty-prints an instantiation."
   (let ((production (instantiation-production instantiation)))
     (when (eq trace 'short) (setf trace t))
     (if (eq format 'short)
       (dolist (binding (production-bindings production))
         (signal-output trace "   ~A: ~A" (variable-name binding)
                        (if (integerp (variable-index binding))
                          (or (instantiation-variable instantiation 
(variable-index binding))
                              "VARIABLE STILL UNBOUND")
                          "RETURN VARIABLE STILL UNDETERMINED")))
       (let ((bindings nil)
             (text nil))
         (dolist (binding (production-bindings production))
           (when (integerp (variable-index binding))
             (let ((value (instantiation-variable instantiation 
(variable-index binding))))
               (when value
                 (push (cons (variable-name binding) value) bindings)
                 (push (cons (var-var> (variable-name binding))
                             (var-var> value))
                   bindings)))))
         (setf text (sublis bindings (production-text production)))
         text))))

;THIS PRODUCTION IS CALLED AFTER EACH CYCLE.  IT WILL CALL 
COMPOSE-PRODUCTION TO TRY TO COLLAPSE THE PREVIOUS
;AND CURRENT PRODUCTION UNLESS A PERIOD OF TIME HAS ELAPSED UNUSED 
BETWEEN THE TWO PRODUCTIONS -- IN WHICH
;CASE THE INFERENCE IS THAT WE WERE WAITING FOR SOME EXTERNAL EVENT.
(defun store-instantiation (i)
   (let (hold)
        (cond (*instantiation*
               (setf hold  (get-set i))
               (cond ((and (rest *previous-instantiation*)  (< (- 
*time* (first *previous-instantiation*)) *threshold-time*))
                      (compose-production (rest 
*previous-instantiation*) hold)))
               (setf *previous-instantiation* (cons *time* hold))))))

(defun legal-condition (ins)
   (do ((temp (get-condition ins) (cdr temp)))
       ((null temp) t)
     (cond ((not  (member  (caar temp) '(=goal> =retrieval> =visual> 
=visual-location> =visual-state>
                                       !eval! =manual> =manual-state) 
:test 'equal)) (return nil)))))

(defun legal-action (ins)
   (do ((temp (get-action ins) (cdr temp)))
       ((null temp) t)
     (cond ((not (member (caar temp) '(=goal> +goal> +retrieval> 
+visual> +visual-location> -visual> -visual-location> -retrieval>
                                       +manual>) :test 'equal)) (return nil)))))

(defun legal-pair (x y) (and (legal-condition x) (legal-action x)
                              (legal-condition y) (legal-action y)))

(defun compose-production (x y)
;The legal pair test has been asserted simply to abort any attempt to 
compose productions that have things in them other
;that what is considered kosher.
   (if (legal-pair x y)
;X IS THE FIRST PRODUCTION AND Y THE SECOND
;WE IDENTIFY THE PATTERNS AND INSTANTIONS OF THESE TWO PRODUCTIONS IN 
THE NEXT 8 ASSIGNMENTS
   (let* ((renamings (renamings (car x) (car y)))
;renamings has been introduced to avoid any accidental use of the 
same variable across productions -- this is a poor version of 
achieving
;a thorough unification
          (cond-pat1 (get-condition x)) ;pattern in condition of first 
production
         (cond-pat2  (substitute-vars (get-condition y) renamings)) 
;pattern in condition of second production
         (act-pat1 (get-action x)) ;pattern in action of first production
         (act-pat2 (substitute-vars (get-action y) renamings)) 
;pattern in action of second production
         (cond-ins1 (third x)) ;instantiation of condition of first production
         (cond-ins2 (third y)) ;instantiation of condition of second production
         (act-ins1 (fourth x)) ;instantiation of action of first production
         (act-ins2 (fourth y)) ;instantiation of action of second production
;EXTRACTION OF BUFFERS -- THIS IS REPRESENTED AS A PAIRING OF THE 
PATTERN AND INSTANTIAION
         (gc1 (get-terms cond-pat1 cond-ins1 '=goal>)) ; goal buffer 
in the condition of first production
         (gc2 (get-terms cond-pat2 cond-ins2 '=goal>)) ; goal buffer 
in the condition of second production
         (ga1 (get-terms act-pat1 act-ins1 '=goal>)) ; goal buffer in 
the action of first production
         (ga2 (get-terms act-pat2 act-ins2 '=goal>)) ; goal buffer in 
the action of second production
         (rc1 (get-terms cond-pat1 cond-ins1 '=retrieval>)) ; 
retrieval buffer in the condition of first production
         (rc2 (get-terms cond-pat2 cond-ins2 '=retrieval>)) ; 
retrieval buffer in the condition of second production
         (ra1 (or (get-terms act-pat1 act-ins1 '+retrieval>)(get-terms 
act-pat1 act-ins1 '-retrieval>))) ; retrieval buffer in the action of 
first production
         (ra2 (or (get-terms act-pat2 act-ins2 '+retrieval>)(get-terms 
act-pat2 act-ins2 '-retrieval>))) ; retrieval buffer in the action of 
second production
         (ras1 (get-terms act-pat1 act-ins1 '=retrieval>))
         (ras2 (get-terms act-pat2 act-ins2 '=retrieval>))
;deals with cases where we are resetting the the contents of a chunk
         (vc1 (get-terms cond-pat1 cond-ins1 '=visual>)) ; 
visual-object buffer in the condition of first production
         (vl1 (get-terms cond-pat1 cond-ins1 '=visual-location>)) ; 
visual-location buffer in the condition of first production
         (vs1 (get-terms cond-pat1 cond-ins1 '=visual-state>)) ; 
visual-state buffer in the condition of first production
         (vc2 (get-terms cond-pat2 cond-ins2 '=visual>)) ; 
visual-object buffer in the condition of second production
         (vl2 (get-terms cond-pat2 cond-ins2 '=visual-location>)) ; 
visual-location buffer in the condition of second production
         (vs2 (get-terms cond-pat2 cond-ins2 '=visual-state>)) ; 
visual-state buffer in the condition of second production
         (va1 (or (get-terms act-pat1 act-ins1 '+visual>)(get-terms 
act-pat1 act-ins1 '-visual>))) ; visual-object buffer in the action 
of first production
         (va2  (or (get-terms act-pat2 act-ins2 '+visual>)(get-terms 
act-pat2 act-ins2 '-visual>))) ; visual-object buffer in the action 
of second production
         (vla1 (or (get-terms act-pat1 act-ins1 
'+visual-location>)(get-terms act-pat1 act-ins1 '-visual-location>)))
         (vla2  (or (get-terms act-pat2 act-ins2 
'+visual-location>)(get-terms act-pat2 act-ins2 '-visual-location>)))
         (eval1 (car (get-terms cond-pat1 cond-ins1 '!eval!)))
         (eval2 (car (get-terms cond-pat2 cond-ins2 '!eval!)))
         (mc1 (get-terms cond-pat1 cond-ins1 '=manual>))
         (mc2 (get-terms cond-pat2 cond-ins2 '=manual>))
         (ms1 (get-terms cond-pat1 cond-ins1 '=manual-state>))
         (ms2 (get-terms cond-pat2 cond-ins2 '=manual-state>)) ; 
manual buffer in the condition of second production
;more complete treatment of buffers
         (ma1 (or (get-terms act-pat1 act-ins1 '+manual>) (get-terms 
act-pat1 act-ins1 '-manual>))) ; manual buffer in the action of first 
production
         (ma2 (or (get-terms act-pat2 act-ins2 '+manual>)(get-terms 
act-pat2 act-ins2 '-manual>))) ; manual buffer in the action of 
second production
         (n1 (or (get-terms act-pat1 act-ins1 '+goal>) (get-terms 
act-pat1 act-ins1 '=newgoal>)) ) ; newgoal buffer in the action of 
first production
         (n2 (or (get-terms act-pat2 act-ins2 '+goal>) (get-terms 
act-pat2 act-ins2 '=newgoal>)))) ; newgoal buffer in the action of 
second production
       (declare (ignore-if-unused mc1 mc2))
; THIS DEALS WITH THE CASE IN WHICH WE CAN SIMPLY COMPOSE THE TWO 
CONDITIONS BUT FIRST WE TEST FOR ALL THE CASES WHERE THIS IS FORBIDDEN
     (cond (  (and (not n1) ;one does not want to simply compose over 
a switch in the goal but see below
                 (same-goal-test (car (second  gc1)) (car (second 
gc2))) ;then they should be the same goal
;the line above is the generalized same goal test and the line below 
avoids the situation of direction retrieval of the goal
                 (not (equal (first (second (first ra1))) '=goal))
                 (not (and va1 vc2)) (not (and Va1 va2)) (not (or ras1 ras2))
                 (not (and vla1 vl2)) (not (and vla1 vla2)) ;one does 
not want to compose when there is a contingency between the visual 
processing
                 (not (and ma1 ma2)) ;one does not want to have jamming actions
                 (not (and rc2 (equal (wme-type-name (second (second 
(car rc2)))) 'error)))) ;one also does not want to compose over a 
retrieval failure
;IF WE ARE GOING TO COMPOSE THE PRODUCTIONS WE NEED TO GO ABOUT 
CALCULATING WHAT THE BUFFER SPECIFICATIONS WILL BE IN THE COMPOSED 
PRODUCTION
;IF THERE IS A RETRIEVAL REQUEST IS THE FIRST AND A TEST WE WILL DELETE THESE
;BEYOND THIS WE MUST MAKE SURE THAT THE VARIABLES ARE CONSTRAINED TO 
BE WHAT THEY WOULD HAVE BEEN IN THIS RETRIEVAL REQUEST
;MORE GENERALLY WE NEED TO CALCULATE A CONSISTENT SET OF VARIABLE 
NAMES BETWEEN THE TWO PRODUCTIONS
            (let* ((mapping1 (append (extract-map (first ra1) (second 
ra1))  ;any variables in the first's retrieval request must be 
replaced by constants
                                    (extract-constant-map (first ga1) 
(first gc2)) ;deal with case were second condition constrains 
variable in first action
                                    (modify1 (first ra1) (second ra1))
;Deals with the mapping produced required when there is direct 
assignment to a retrieval request. For
;reasons that are unclear to me any more I re-ordered the retrieval 
and goal mappings
                                     (hack (first ga1) (first gc2) 
(first rc2) (second rc2))))
                   (rt (retrieval-test mapping1 ))
                   (mapping2  (extend-map (append (modify (first ra1) 
(second ra1))
;=retrieval in second production replaced with direct assignment
                                          (extract-map (first rc2) 
(second rc2)) ;any variables in the seconds retrieval test but be 
replaced by constants
                                     (extract-map (first gc2) (first 
ga1)) ;any variables in the second's goal test must be replace by
;extending the mapping to include terms in the retrieval buffer
                                     (extract-map (first vc2) (first vc1))
                                     (extract-map (first gc2) (first 
gc1))) ;corresponding terms from the first action or condition
                                         mapping1));these 
substitutions for the second production must be made consistent with 
the substitution for the first
                   (gc (chunk-merge-condition (substitute-vars (car 
gc1) mapping1) ;the goal buffer must be specific to the retrieval
                                    (chunk-dif (substitute-vars (car 
gc2) mapping2) ;and include any additional tests from the second 
production
                                               (substitute-vars (car 
ga1) mapping1)))) ;that were not created in the first's action
                   (ga (chunk-merge-action (substitute-vars (car ga2) 
mapping2) ;the goal action must combine the action of the second and 
the action of
                                    (substitute-vars (car ga1) 
mapping1))) ;the first giving preference to the second
                   (ma (or (substitute-vars (car ma1) mapping1) 
(substitute-vars (car ma2) mapping2))) ;whichever has a manual 
condition
                   (rc (substitute-vars  (car rc1) mapping1)) 
;maintain the instantiated retrieval test from the first
                   (ra (substitute-vars (car ra2) mapping2)) ;maintain 
the instantiated retrieval request from the second
                   (vl  (or (substitute-vars (car vl1) mapping1) 
(substitute-vars(car vl2) mapping2))) ; one of the tests of visual 
location
                   (vs (or (substitute-vars (car vs1) mapping1) 
(substitute-vars (car vs2) mapping2))) ;one of the visual states -- 
my colon is a hack trying to deal with :visual
;Substitution is required in these cases as well
                   (ms (or (substitute-vars (car ms1) mapping1) 
(substitute-vars (car ms2) mapping2)))
;more complete treatment of buffers
                   (vc  (or (substitute-vars (car vc1) mapping1) 
(substitute-vars (car vc2) mapping2))) ;one of the visual object tests
                   (va (or (substitute-vars (car va1) mapping1) 
(substitute-vars (car va2) mapping2))) ;one of the visual object 
requests
;Substitution is required in these cases as well
                   (vla (location-filter (or(substitute-vars (car 
vla1)mapping1) (substitute-vars (car vla2)mapping2))))
;The location filter is just a hack to deal with troubles I have had 
with wmes versus symbols
                   (eval (eval-merge  rt (substitute-vars eval1 
mapping1) (substitute-vars eval2 mapping2)))
;reatment of evals
                   (na (substitute-vars (car n2) mapping2)) ;the goal 
switch made consistent
;NOW THE ACTUAL CALCULATION OF THE NEW PRODUCTION CAN BEGIN
                   (new-condition (remove-nils(list gc  rc vl vs vc ms 
eval)) ) ;the new condition with all buffers specified
;ms and eval have been added.  The eval computation and the old rt 
have been absorbed by val
                   (new-action (remove-nils  (list vla va ga  ra ma 
na) )) ;the new action with all buffers specified
                      (production-name (new-name-fct "PRODUCTION")) 
;create a new name for the production
                   (production (compile-or-select-production production-name
 
(second (second (first cond-pat1)))
 
new-condition new-action nil nil))) ;call code to create production
                 (when  production (finish-up production (car x) (car 
y))))) ;when a production was created set its parameters etc
;THE CODE BELOW DEALS WITH A CASE IN WHICH ONE CAN COMPOSE TWO 
PRODUCTIONS EVEN IF THEY BOTH INVOLVE NEWGOALS.  THIS IS WHEN THE 
SECOND NEWGOAL IS
;RETURNING TO THE GOAL OF THE FIRST PRODUCTION.  THUS THE FIRST 
PRODUCTION PUSHES AND THE SECOND POPS
             ((and  n1 n2 (equal  (headere (car (second  gc1))) (car 
(second (second  n2)))) ;test for this condition
                   (not (equal (first (second (first ra1))) '=goal))
;the line above is the generalized same goal test
                   (not (and va1 vc2)) (not (and Va1 va2)) (not (or ras1 ras2))
                 (not (and vla1 vl2)) (not (and vla1 vla2)) ;one does 
not want to compose when there is a contingency between the visual 
processing
                 (not (and ma1 ma2)) ;one does not want to have jamming actions
                 (not (and rc2 (equal (wme-type-name (second (second 
(car rc2)))) 'error)))) ;one also does not want to compose over a 
retrieval failure
;Copying of the same tests used for the case above
              (let* ((mapping1 (append (extract-map (first ra1) 
(second ra1))  ;any variables in the first's retrieval request must 
be replaced by constants
                                    (modify1 (first ra1) (second ra1))
;Deals with the mapping produced required when there is direct 
assignment to a retrieval request
                                       (extract-map (first n1) (first 
gc2)))) ;terms in the first production must be specific to how the 
goal was tested
;For reasons that are unclear to me any more I re-ordered the 
retrieval and goal mappings
                     (rt (retrieval-test mapping1 ))
                     (mapping2 (extend-map (append (modify (first ra1) 
(second ra1))
;Correction of a mistake in place of (extract-map (first gc2) (first ga1)
;=retrieval in second production replaced with direct assignment
                                                   (extract-map (first 
rc2) (second rc2));any variables in the seconds retrieval test but be 
replaced by constants
                                     (extract-map (first vc2) (first vc1))
;extending the mapping to include terms in the retrieval buffer
                                     (extract-map (first gc2) (first 
n1))) ;corresponding terms from the first action or condition
;Correction of a mistake
                                         mapping1)) ;these 
substitutions for the second production must be made consistent with 
the substitution for the first
                     (gc (substitute-vars (car gc1)  mapping1)) 
;rename terms in first goal test
                     (ga (substitute-vars (car ga1) mapping1)) ;rename 
terms in first goal change
                     (ma (or (substitute-vars (car ma1) mapping1) 
(substitute-vars (car ma2) mapping2))) ;whichever has a manual 
condition
                     (rc (substitute-vars  (car rc1) mapping1)) 
;maintain the instantiated retrieval test from the first
                     (ra (substitute-vars (car ra2) mapping2)) 
;maintain the instantiated retrieval request from the second
                     (vl (or (substitute-vars (car vl1) 
mapping1)(substitute-vars (car vl2) mapping2))) ; one of the tests of 
visual location
                     (vs (or (substitute-vars (car vs1) mapping1) 
(substitute-vars (car vs2) mapping2)))
;Substitution is required in these cases as well
                     (vla (or(substitute-vars (car 
vla1)mapping1)(substitute-vars (car vla2)mapping2)))
                   (vla (location-filter (or(substitute-vars (car 
vla1)mapping1) (substitute-vars (car vla2)mapping2))))
;Visual locations appearing in the action -- the first setting is dead code
;The location filter is just a hack to deal with troubles I have had 
with wmes versus symbols
                     (ms (or (substitute-vars (car ms1) mapping1) 
(substitute-vars (car ms2) mapping2)))
;more complete treatment of buffers
                   (eval (eval-merge rt (substitute-vars eval1 
mapping1) (substitute-vars eval2 mapping2)))
;treatment of evals
                     (vc (or (substitute-vars (car vc1) mapping1) 
(substitute-vars (car vc2) mapping2))) ;one of the visual object tests
                     (va (or (substitute-vars (car va1) mapping1) 
(substitute-vars (car va2) mapping2))) ;one of the visual object 
requests
;NOW THE ACTUAL CALCULATION OF THE NEW PRODUCTION CAN BEGIN
                     (new-condition (remove-nils (list gc rc vl vs vc 
ms eval) )) ;the new condition with all buffers specified
;ms and eval have been added.  The eval computation and the old rt 
have been absorbed by val
                     (new-action (remove-nils (list vla va  ga ra ma) 
)) ;the new action with all buffers specified
                      (production-name (new-name-fct "PRODUCTION")) 
;create a new name for the production
                   (production (compile-or-select-production production-name
 
(second (second (first cond-pat1))) ;call code to create production
 
new-condition new-action nil nil))) ;call code to create production
                (declare (ignore-if-unused vla))
                (when  production (finish-up production (car x) (car 
y)))))  ;when a production was created set its parameters etc
             ((and n1 (not n2) (equal (car (second (car n1))) 'isa)
                 (not (and va1 vc2)) (not (and Va1 va2)) (not (or ras1 ras2))
;the  line below avoids the situation of direction retrieval of the goal
                 (not (equal (first (second (first ra1))) '=goal))
                 (not (and vla1 vl2)) (not (and vla1 vla2)) ;one does 
not want to compose when there is a contingency between the visual 
processing
                 (not (and ma1 ma2)) ;one does not want to have jamming actions
                 (not (and rc2 (equal (wme-type-name (second (second 
(car rc2)))) 'error)))) ;one also does not want to compose over a 
retrieval failure
                           (let* ((mapping1 (append (extract-map 
(first ra1) (second ra1))  ;any variables in the first's retrieval 
request must be replaced by constants
 
(extract-constant-map (first n1) (first gc2)) ;deal with case were 
second condition constrains variable in first action
                                                    (modify1 (first 
ra1) (second ra1))
                                                    (hack (first ga1) 
(first gc2) (first rc2) (second rc2))))
                     (rt (retrieval-test  mapping1 ))
                     (mapping2 (extend-map (append  (modify (first 
ra1) (second ra1))
                                                    (extract-map 
(first rc2) (second rc2)) ;any variables in the seconds retrieval 
test but be replaced by constants
                                     (extract-map (first gc2) (first 
n1)) ;any variables in the second's goal test must be replace by
;extending the mapping to include terms in the retrieval buffer
                                     (extract-map (first vc2) (first vc1))
                                     (extract-map (first gc2) (first 
gc1))) ;corresponding terms from the first action or condition
                                         mapping1)) ;these 
substitutions for the second production must be made consistent with 
the substitution for the first
                     (gc (substitute-vars (car gc1)  mapping1)) 
;rename terms in first goal test
                     (ga (substitute-vars (car ga1) mapping1)) ;rename 
terms in first goal change
                     (ma (or (substitute-vars (car ma1) mapping1) 
(substitute-vars (car ma2) mapping2))) ;whichever has a manual 
condition
                     (rc (substitute-vars  (car rc1) mapping1)) 
;maintain the instantiated retrieval test from the first
                     (ra (substitute-vars (car ra2) mapping2)) 
;maintain the instantiated retrieval request from the second
                     (vl (or (substitute-vars (car vl1) 
mapping1)(substitute-vars (car vl2) mapping2))) ; one of the tests of 
visual location
                   (vla (location-filter (or(substitute-vars (car 
vla1)mapping1) (substitute-vars (car vla2)mapping2))))
                     (vs (or (substitute-vars (car vs1) 
mapping1)(substitute-vars (car vs2) mapping2))) ;one of the visual 
states
                     (ms (or (substitute-vars (car ms1) mapping1) 
(substitute-vars (car ms2) mapping2)))
                   (eval (eval-merge  rt (substitute-vars eval1 
mapping1) (substitute-vars eval2 mapping2)))
                     (vc (or (substitute-vars (car vc1) mapping1) 
(substitute-vars (car vc2) mapping2))) ;one of the visual object tests
                     (va (or (substitute-vars (car va1) mapping1) 
(substitute-vars (car va2) mapping2))) ;one of the visual object 
requests
                     (na (append (list '+goal> (second (car n1)))
                                 (cdr (chunk-merge-action 
(substitute-vars (car ga2) mapping2) ;the goal action must combine 
the action of the second and the action of
 
(substitute-vars (cons (first (car n1)) (cddr (car n1))) 
mapping1))))) ;the first giving preference to the second
;NOW THE ACTUAL CALCULATION OF THE NEW PRODUCTION CAN BEGIN
                     (new-condition (remove-nils (list gc rc vl vs vc 
ms eval) )) ;the new condition with all buffers specified
                     (new-action (remove-nils (list vla va  ga ra ma 
na) )) ;the new action with all buffers specified
                      (production-name (new-name-fct "PRODUCTION")) 
;create a new name for the production
                   (production (compile-or-select-production production-name
 
(second (second (first cond-pat1))) ;call code to create production
 
new-condition new-action nil nil))) ;call code to create production
                (when  production (finish-up production (car x) (car 
y)))))  ;when a production was created set its parameters etc
             ))) )
;treatment of a third case
(defun location-filter (lis)
   (cond ((atom lis) (chunk-symbol lis))
         (t (cons (location-filter (car lis)) (location-filter (cdr lis))))))

(defun modify (ra-pat ra-ins)
   (if (equal (car (second ra-pat)) 'isa) nil
       (list (list '=retrieval (car (second ra-ins))))))

(defun modify1 (ra-pat ra-ins)
   (if (equal (car (second ra-pat)) 'isa) nil
       (list (list (car (second ra-pat)) (car (second ra-ins))))))

(defun extract-variablesh (lis)
   (cond ((atom lis)
          (cond ((and (variablep lis)
               (not (member lis '(=retrieval =visual =visual-state =goal
                                  =visual-location =manual =manual-state
                                  =retrieval> =visual> =visual-state> =goal>
                                  =visual-location> =manual> =manual-state>))))
                 (list lis))))
         (t (append (extract-variablesh (car lis)) (extract-variablesh 
(cdr lis))))))

(defun extract-variables (production)
   (do ((temp (extract-variablesh (production-text 
(get-safe-production production))) (cdr temp))
        (result nil (cond ((member (car temp) (cdr temp)) result)
                          (t (cons (car temp) result)))))
       ((null temp) result)))

(defun renamings (prod1 prod2)
   (let ((variables1 (extract-variables prod1))
         (variables2 (extract-variables prod2)))
     (do ((temp variables2 (cdr temp))
          (result nil (cond ((member (car temp) variables1)
                             (cons (list (car temp) (gentemp (string 
(car temp)))) result))
                            (t result))))
         ((null temp) result))))



(defun hack (ga1 gc2 rc2p rc2i)
   (do ((temp (intersection (variables rc2p) (variables gc2)) (cdr temp))
         (result nil (cond ((slot-test (car temp) gc2 ga1)
                            (cons (list (slot-test (car temp) gc2 ga1)
                                        (find-constant (car temp) rc2p rc2i)
                                        ) result))
                           (t result))))
       ((null temp) result)))


(defun variables (sexp)
   (cond ((atom sexp)
          (cond ((variablep sexp) (list sexp))
                (t nil)))
         (t (append (variables (car sexp)) (variables (cdr sexp))))))

(defun slot-test (variable condition action)
   (do ((temp (cddr condition) (cdr temp)))
       ((null temp) nil)
     (cond ((and (equal (second (car temp)) variable)
                 (assoc (first (car temp)) (cdr action)))
            (return (second (assoc (first (car temp)) (cdr action))))))))

(defun find-constant (variable pattern ins)
   (cond ((equal pattern variable) ins)
         ((atom pattern) nil)
         (t (or (find-constant variable (car pattern) (car ins))
                (find-constant variable (cdr pattern) (cdr ins))))))

(defun retrieval-test (mappings)
   (let ((critical (assoc '=retrieval mappings)))
     (cond (critical `(!EVAL! (EQUAL =retrieval (quote ,(chunk-symbol 
(second critical)))))))))
;attempt to deal with my problem with wmes and symbols
; eliminated due to duplication below
;(defun eval-merge (lis1 lis2 lis3)
;  (setf lis1 (eval-filter  (second lis1)))
;  (setf lis2 (eval-filter (second lis2)))
;  (setf lis3 (eval-filter (second lis3)))
;  (cond ((and lis1 lis2 lis3) (cons '!eval! (list  (list 'and 
(second lis1) (second lis2) (second lis3)))))
;        ((and lis1 lis2) (cons '!eval! (list  (list 'and (second 
lis1) (second lis2) ))))
;        ((and lis1 lis3) (cons '!eval! (list  (list 'and (second 
lis1)  (second lis3)))))
;        ((and lis2 lis3) (cons '!eval! (list  (list 'and  (second 
lis2) (second lis3)))))
;        ((or lis1 lis2 lis3))))

;my original-eval merge did not work and so all the rewritten green 
functions below
(defun eval-merge (lis1 lis2 lis3)
   (let ((result (remove-nils (mapcar 'eval-filter (append 
(extract-eval lis1) (extract-eval lis2) (extract-eval lis3))))))
     (cond ((null result) nil)
           ((equal (length result) 1) (cons '!eval! result))
           (t (list '!eval! (cons 'and result))))))

(defun extract-eval (lis)
   (cond ((null lis) nil)
         ((equal (car (second lis)) 'and) (cdr (second lis)))
         (t (cdr lis))))

;corrected as an attempt to deal with my problem with wmes and symbols
; eliminated due to duplication below
;(defun eval-filter (lis)
;  (setf test (second lis))
;  (if (and (equal (car test) 'equal) (listp (third test))(equal (car 
(third test)) 'quote)
;           (atom (second test))(equal(chunk-symbol (second test)) 
(second (third test)))) nil lis))
;attempt to deal with my problem with wmes and symbols

(defun eval-filter (lis)
   (cond ((contains-variable lis) lis)
         (t nil)))

(defun contains-variable (lis)
   (cond ((atom lis) (variablep lis))
         (t (or (contains-variable (car lis)) (contains-variable (cdr lis))))))



;from Niels
(defun compile-or-select-production (name type lhs rhs success failure
                                           &optional (documentation nil))
   "Either create a new production or select an existing identical one.
    Return a second value indicating whether it is an existing 
production (t) or not (nil)."
   (if (action-test rhs)
;filter cases of a constant assignment
   (dolist (production (wme-type-productions (get-safe-type type name))
                       (let ((new-production (compile-production name 
lhs rhs documentation)))
                         (signal-output *production-compilation-trace* 
"Compiling Production ~A." new-production)
                         (parameters-fct name (nconc (list :success 
(if success t nil)
                                                           :failure 
(if failure t nil))
 
*production-compilation-parameters*))
                         (values new-production nil)))
     (when (identical-productions (copy-all (cons lhs rhs)) (copy-all 
(production-text production)) )
;more of my attempt to deal with my problem with wmes and symbols
       (signal-output *production-compilation-trace* "Recreating 
Production ~A." production)
;this change enables the change in finish-up
       (return production)))))

(defun action-test (rhs)
   (let ((newgoal (assoc '+goal> rhs))
         (retrieval (assoc '+retrieval> rhs)))
      (not (or (and newgoal (not (equal (car (second newgoal)) 'isa)) 
(not (variablep (car (second newgoal)))))
               (and retrieval (not (equal (car (second retrieval)) 
'isa)) (not (variablep (car (second retrieval)))))))))

(defun copy-all (x)
   (cond ((atom x)
          (cond ((wmep x) (wme-name x)) (t x)))
         (t (cons (copy-all (car x)) (copy-all (cdr x))))))

;largely from Niel -- different definition of new b -- from Niels Thursday
(defun finish-up (production old1 old2)
;this code allows us to recognize when we have recreated a production 
and have yet to try it.  In this case it seems
;wise to reset its parameters according to the current parameters of 
the productions from which it originated.  There
;is a more general version of this idea that I did not implement 
because it is not sorted in the production structure.
;this is that the initialization of the parameters of a production 
should change whenever the originating productions change but
; the production-specific experience should be allowed to accumulate.
   (let ((number (no-output (+ (caaar (eval `(spp ,production :successes)))
                               (caaar (eval `(spp ,production :failures)))))))
     (cond ((<= number *initial-experience*)
   (cond ((and (equal number 1.0) *production-compilation-trace* 
*verbose*) (eval `(pp ,production))))
   (no-output
   (let*
     ((initial-experience  *initial-experience*)
      (effort1 (caar (eval `(spp ,old1 :effort))))
      (effort2 (caar (eval `(spp ,old2 :effort))))
      (effort (+ effort1 effort2 (- *default-action-time*))) ;we save 
the 50 ms by having one fewer productions
      (c2 (caar (eval `(spp ,old2 :c))))
      (p2 (caar (eval `(spp ,old2 :p))))
      (c1 (caar (eval `(spp ,old1 :c))))
      (p1 (caar (eval `(spp ,old1 :p))))
      (s1 (caar (eval `(spp ,old1 :success))))
      (s2 (caar (eval `(spp ,old2 :success))))
      (c  (max 0 (+ c1 *cost-penalty*))) ;this is the pessimism built 
into the productions
;avoid negative costs
      (p p1) ;since this new production must compete with the first it 
makes sense to base its parameters on the first.
      (successes (* p initial-experience))
      (failures (- initial-experience successes))
      (efforts (* c initial-experience))
      (s (or s1 s2))
      (pl (first (no-output (sgp :pl)))))
     (declare (ignore-if-unused p2 c2))
     (cond ((eq pl t)
            (no-output
             (eval `(spp ,production
                         :effort ,effort
                         :efforts ,efforts
                         :success ,s
                         :successes ,successes
                         :failures ,failures))))
           ((null pl)
            (no-output
             (eval `(spp ,production
                         :effort ,effort
                         :c ,c
                         :p ,p))))
           (t
            (no-output
             (eval `(spp ,production
                         :effort ,effort
                         :efforts ,efforts
                         :success ,s
                         :successes ,successes
                         :failures ,failures)))))))

     (when (and *production-compilation-trace* *verbose*) (eval `(spp 
,production)))
))))



(defun extend-map (map2 map1)
   (let (item)
   (do ((temp map2 (cdr temp))
        (result nil (cons (cond ((setf item (assoc (second (car temp)) 
map1)) (list (caar temp) (second item)))
                                (t (car temp))) result)))
       ((null temp) (reverse result)))))


(defun chunk-merge-condition (chunk1 chunk2)
   (cond ((not chunk1) chunk2) (t
   (let ((pair))
   (do ((temp1 (cdr chunk1) (cdr temp1))
        (result (list (car chunk1))
                (cond ((equal (caar temp1) '-)
                       (do ((temp2 (cdr chunk2) (cdr temp2)))
                           ((null temp2) (append result (list (car temp1))))
                         (cond ((and (equal (first (car temp2)) '-)
                                     (equal (second (car temp1)) 
(second (car temp2)))
                                     (equal (third (car temp1)) (third 
(car temp2))))
                                (setf chunk2 (remove (car temp2) chunk2))
                                (return (append result (list (car temp1))))))))
                      ((setf pair (assoc (caar temp1) (cdr chunk2)))
                       (setf chunk2 (remove pair chunk2))
                       (append result (list (max-specific (car temp1) pair))))
                      (t (append result (list (car temp1)))))))
       ((null temp1) (append result (cdr chunk2))))))))

(defun chunk-merge-action (chunk1 chunk2)
   (cond ((not chunk1) chunk2) (t
   (let ((pair))
   (do ((temp1 (cdr chunk1) (cdr temp1))
        (result (list (car chunk1))
                (cond ((equal (caar temp1) '-)
                       (do ((temp2 (cdr chunk2) (cdr temp2)))
                           ((null temp2) (append result (list (car temp1))))
                         (cond ((and (equal (first (car temp2)) '-)
                                     (equal (second (car temp1)) 
(second (car temp2)))
                                     (equal (third (car temp1)) (third 
(car temp2))))
                                (setf chunk2 (remove (car temp2) chunk2))
                                (return (append result (list (car temp1))))))))
                      ((setf pair (assoc (caar temp1) (cdr chunk2)))
                       (setf chunk2 (remove pair chunk2))
                       (append result (list (car temp1))))
                      (t (append result (list (car temp1)))))))
       ((null temp1) (append result (cdr chunk2))))))))

(defun max-specific (pair1 pair2)
   (cond ((variablep (second pair2)) pair1)
         ((variablep (second pair1)) pair2)
         (t pair1)))

(defun remove-nils (lis)
   (do ((temp lis (cdr temp))
        (result nil (cond ((null (car temp)) result)
                          (t (cons (car temp) result)))))
       ((null temp) (reverse result))))

(defun get-terms (pat ins index)
   (let ((element (assoc index pat)))
     (cond (element (list element
                          (nth (position element pat) ins))))))

(defun chunk-dif (condition action)
   (setf action (cdr action))
   (do ((temp2 (cddr condition) (cdr temp2))
        (result2 (list (car condition) (cadr condition))
                 (cond ((assoc (caar temp2) action) result2)
                       ((and (equal (caar temp2) '-) (assoc (cadar 
temp2) action)) result2)
                       (t (append result2 (list (car temp2)))))))
       ((null temp2) result2)))

(defun extract-map (first second)
   (cond ((and first second)
;extended test
   (let (item)
   (do ((temp (cdr first) (cdr temp))
;a test has been expanded here to avoid a situation where one does 
not want the mapping
        (result (if (and (eq (car first) '=goal>) (eq (car second) '+goal>)) nil
                    (list (list (headere (car first)) (headere (car second)))))
                (cond ((equal (caar temp) 'isa) result)
                          ((equal (caar temp) '-)
                           (cond ((and (variablep (third (car temp)))
                                  (setf item (find-pair (car temp) 
(cdr second))))
;extended test
                                  (cons (list (third (car temp)) 
(third item)) result))
                                 (t result)))
                          ((not (variablep (cadar temp))) result)
                          ((and (not (equal (cadar temp) '=goal))
                                (setf item (assoc  (caar temp) (cdr second))))
                           (cons (list (cadar temp) (cadr item)) result))
                          (t result))))
       ((null temp) result))))))

(defun find-pair (triple lis)
   (do ((temp lis (cdr temp)))
       ((null temp) nil)
     (cond ((and (equal (first triple) (first (car temp)))
                 (equal (second triple) (second (car temp)))) (return 
(car temp))))))

(defun extract-constant-map (first second)
   (do ((temp (extract-map first second) (cdr temp))
        (result nil (cond ((and (variablep (first (car temp)))
                                (not (variablep (second (car temp))))) 
(cons (car temp) result))
                          (t result))))
       ((null temp) result)))

;this does the mapping
(defun substitute-vars (sexp mapping)
   (cond ((null sexp) nil)
         ((atom sexp)
          (cond ((variable-map sexp mapping))
                (t sexp)))
         (t (cons (substitute-vars (car sexp) mapping)
                  (substitute-vars (cdr sexp) mapping)))))

(defun variable-map (term mapping)
   (cond ((and (variablep term) (not (member term '(=goal> =retrieval>))))
          (cond ((headerp term) (setf term (headere term))
                 (cond ((assoc term mapping) (header-fn (cadr (assoc 
term mapping))))))
                ((assoc term mapping) (cadr (assoc term mapping)))))))

;Utilities
(defun get-condition (a)
   (first (production-text (get-safe-production (car a)))))


(defun get-action (a)
   (cdr (production-text (get-safe-production (car a)))))

(defun headerp (term)
   (let ((string (string-sym term)))
     (equal (aref string (1- (length string))) #\>)))

(defun headere (term)
   (let* ((string  (string-sym term))
          (bound (1- (length string)))
          (ans (make-string bound)))
     (do ((count 0 (1+ count)))
         ((equal count bound) (let ((r (intern ans)))
;this again deals with situations where merge has changed chunk names
                                (cond ((and *merge* (equal r (wme-name 
(first *merge*)))) (first *merge*))
                                      ((and (not (variablep r)) (not 
(equal r '+goal)) (not (equal r '+retrieval)))  (get-safe-wme r))
                                      (t r))))
       (setf (aref ans count) (aref string count)))))

(defun string-sym (item)
   (cond ((symbolp item) (string1 item))
         (t (string1 (car (no-output (eval `(wm ,item))))))))

(defun string1 (item)
   (cond ((numberp item) (prin1-to-string item))
         (t (string item))))

(defun header-fn (x) (intern (merge 'string (cond ((numberp x) 
(format nil "~d" x)) ((symbolp x) (string x))
                                               (t (string (car 
(no-output (eval `(wm ,x)))))) ) ">" 'eq)))

(defun chunk-symbol (x) (if (wmep x) (get-wme-name x) x))

;;; lhs

(defmacro set-bindings (slots actions)
   "Sets the stack entries to the slots values."
   `(dolist (action ,actions t)
      (unless (setf (instantiation-variable *instantiation* 
(action-value action))
                    (slots-slot ,slots (action-slot action)))
        (signal-output *exact-matching-trace* "Variable in slot ~S 
cannot be bound to nil: binding fails."
                       (action-name action))
        (return nil))))

(defmacro interpret-value (action)
   "Interpret a slot value description in a number of ways."
   `(case (action-dispatch ,action)
      (:literal (action-value ,action))
      (:stack (instantiation-variable *instantiation* (action-value ,action)))
      (:eval (get-wme-or-constant (funcall (action-value ,action))))))

(defmacro test-slots-buffer (wme slots actions)
   "Tests that slots satisfies all the actions.  Specifically for 
buffers such as goal,
    retrieval and p/m buffers that do not require activation computations."
   `(progn
      (signal-output *exact-matching-trace* "Matching CHUNK ~S." ,wme)
      (dolist (action ,actions t)
        (let ((actual (slots-slot ,slots (action-slot action)))
              (desired (interpret-value action))
              (negation (action-negation action))
              (slot (action-name action)))
          (cond ((null negation)
                 (unless (equal actual desired)
                   (signal-output *exact-matching-trace* "Value ~S is 
different from condition ~S in slot ~S: test fails."
                           actual desired slot)
                   (return nil)))
                ((eq negation '-)
                 (when (equal actual desired)
                   (signal-output *exact-matching-trace* "Value ~S is 
equal to condition ~S in slot ~S: negation test fails."
                                  actual desired slot)
                   (return nil)))
                ((fboundp negation)
                 (unless (and (numberp actual) (numberp desired)
                              (funcall negation actual desired))
                   (signal-output *exact-matching-trace* "Value ~S 
does not match test ~S with condition ~S in slot ~S: test fails."
                           actual negation desired slot)
                   (return nil)))
                (t
                 (signal-output *exact-matching-trace* "Unknown test 
~S in slot ~S: ignoring it."
                                negation slot)))))))

(defmacro test-slots (wme slots actions) ; &optional index)
   "Tests that slots satisfies all the actions.
    Also tests that activation is above threshold when applicable.
    Equal test necessary to handle the full potential range of values."
   `(progn
      (signal-output *exact-matching-trace* "Matching CHUNK ~S." ,wme)
      (dolist (action ,actions (if *retrieval-threshold* (activation ,wme) t))
        (let ((actual (slots-slot ,slots (action-slot action)))
              (desired (interpret-value action))
              (negation (action-negation action))
              (slot (action-name action)))
          (cond ((null negation)
                 (unless (equal actual desired)
                   (signal-output *exact-matching-trace* "Value ~S is 
different from condition ~S in slot ~S: test fails."
                           actual desired slot)
                   (return nil)))
                ((eq negation '-)
                 (when (equal actual desired)
                   (signal-output *exact-matching-trace* "Value ~S is 
equal to condition ~S in slot ~S: negation test fails."
                                  actual desired slot)
                   (return nil)))
                ((fboundp negation)
                 (unless (and (numberp actual) (numberp desired)
                              (funcall negation actual desired))
                   (signal-output *exact-matching-trace* "Value ~S 
does not match test ~S with condition ~S in slot ~S: test fails."
                           actual negation desired slot)
                   (return nil)))
                (t
                 (signal-output *exact-matching-trace* "Unknown test 
~S in slot ~S: ignoring it."
                                negation slot)))))))

(defun add-instantiation-to-conflict-set (arguments)
   "Adds *instantiation* to conflict set, sorted by value or PG-C.
    No need to compute latencies."
   (declare (ignore arguments))
   (unless *enable-rational-analysis*
     (setf (instantiation-gain *instantiation*)
           (get-functional-parameter
            (production-value (instantiation-production *instantiation*))))
     (when *exp-gain-noise*
       (incf (instantiation-gain *instantiation*) (noise *exp-gain-noise*))))
   (let ((rest-cset *conflict-set*)
         (item nil)
         (index 0)
         (equals 0))
     (loop
       (setf item (pop rest-cset))
       (when (or (null item)
                 (> (instantiation-gain *instantiation*) (instantiation-gain 
item)))
         (return))
       (if (= (instantiation-gain *instantiation*) (instantiation-gain item))
         (incf equals 1)
         (incf index 1)))
     (when (> equals 0)
       (incf index (if *enable-randomness* (random (+ equals 1)) equals)))
     (if (= index 0)
       (push *instantiation* *conflict-set*)
       (let ((previous (nthcdr (- index 1) *conflict-set*)))
         (push *instantiation* (cdr previous))))))

(defmacro add-latency (wme activation)
   `(let ((latency (activation-latency ,activation)))
      (signal-output *activation-trace* "CHUNK ~S Activation ~6,3F 
Latency ~6,3F"
                     ,wme ,activation latency)
      (incf *latency* latency)))

(defun direct-test-and-bind-buffer (arguments)
   "Implements a direct match.  Tests for type and then slots, then bind
    variables.  Finally, call the function implementing the next clause.
    Arguments is a list of the wme's stack index, its type, a list of slots
    tests and bindings, and the next call if any.
    Returns t if a complete match is found, nil otherwise.
    Specific to fixed buffers such as goal, retrieval, and p/m buffers."
   (let* ((wme-index (pop arguments))
          (wme (instantiation-variable *instantiation* wme-index))
          (wmetype (pop arguments))
          (slots-tested (pop arguments))
          (slots-bound (pop arguments)))
     (if (and (wmep wme) (subtype (wme-type wme) wmetype))
       (let ((slots (wme-slots wme)))
         ;; Set bindings before testing slots
         (and (set-bindings slots slots-bound)
              (test-slots-buffer wme slots slots-tested)
              (simulate-call arguments)))
       (signal-output *exact-matching-trace* "~S is not a CHUNK of type ~S."
                      wme wmetype))))

(defun direct-test-and-bind (arguments)
   "Implements a direct match.  Tests for type and then slots, then bind
    variables.  Finally, call the function implementing the next clause.
    Arguments is a list of the wme's stack index, its type, a list of slots
    tests and bindings, and the next call if any.
    Returns t if a complete match is found, nil otherwise."
   (let* ((wme-index (pop arguments))
          (wme (instantiation-variable *instantiation* wme-index))
          (wmetype (or (pop arguments) (when (wmep wme) (wme-type wme))))
          (slots-tested (pop arguments))
          (slots-bound (pop arguments)))
     (if (and (wmep wme) (subtype (wme-type wme) wmetype))
       (let ((slots (wme-slots wme)))
         ;; Set bindings before testing slots
         (and (set-bindings slots slots-bound)
              (test-slots wme slots slots-tested) ; wme-index)
              (simulate-call arguments)))
       (signal-output *exact-matching-trace* "~S is not a CHUNK of type ~S."
                      wme wmetype))))

(defun indirect-test-and-bind (arguments)
   "Implements an indirect match.  For all subtypes of the wme, try all the wmes
    and test their slots, then bind variables.  Finally, call the function
    implementing the next clause.
    Arguments is a list of the wme's stack index, its type, a list of slots
    tests and bindings, and the next call if any.
    Returns t if a complete match is found, nil otherwise."
   (let* ((wme-index (pop arguments))
          (wmetype (pop arguments))
          (slots nil)
          (slots-tested (pop arguments))
          (slots-bound (pop arguments))
          (retrieval-list nil))
     (signal-output *exact-matching-trace* "Matching CHUNKs of type 
~S." wmetype)
     ;; Return the winning chunk or nil to handle-failure
     ;; If *enable-randomness* is on, then pick randomly otherwise 
pick the first
     (dolist (type (wme-type-subtypes wmetype)
                   (setf *retrieval-scheduler*
                         (if *enable-randomness*
                           (nth (random (length retrieval-list)) retrieval-list)
                           (first retrieval-list))))
       (dolist (wme (wme-type-wmes type))
         (setf slots (wme-slots wme))
         (if wme-index
           (setf (instantiation-variable *instantiation* wme-index) wme)
           (setf *retrieval-scheduler* wme))
         ;; Set bindings before testing slots
         (when (and (set-bindings slots slots-bound)
                    (test-slots wme slots slots-tested)
                    (simulate-call arguments))
           ;; In action retrieval mode, keep the list of retrievals
           (unless wme-index
             (push-last *retrieval-scheduler* retrieval-list))
           ; pick and initialize a new instantiation
           (let* ((production (instantiation-production *instantiation*))
                  (next-instantiation (get-next-instantiation production))
                  (index 1)
                  (size (production-size production)))
             (loop
               (when (= index size) (return))
               (setf (instantiation-variable next-instantiation index)
                     (instantiation-variable *instantiation* index))
               (incf index 1))
             (setf *instantiation* next-instantiation)))))))

(defun eval-test (arguments)
   "Evaluate the first of the arguments, then call the next clause if true."
   (let ((expr (pop arguments)))
     (if (funcall expr)
       (simulate-call arguments)
       (signal-output *exact-matching-trace* "Expression ~S evaluated 
to NIL." expr))))

(defun bind-lhs (arguments)
   "Binds the first argument to the evaluation of the second,
    then call the next clause if true."
   (let ((index (pop arguments))
         (expr (pop arguments)))
     (if (setf (instantiation-variable *instantiation* index)
               (get-wme-or-constant (funcall expr)))
       (simulate-call arguments)
       (signal-output *exact-matching-trace* "Expression ~S evaluated 
to NIL." expr))))

(defun bind-find-location (arguments)
   "Binds the first of the arguments to the value of find-location
    applied to the second."
   (let ((index (pop arguments))
         (expr (pop arguments)))
     (if (setf (instantiation-variable *instantiation* index)
               (get-wme-or-constant (apply #'find-location (funcall expr))))
       (simulate-call arguments)
       (signal-output *exact-matching-trace* "Find-location of ~S 
returned NIL." expr))))


;;; Partial Matching (LHS)

(defun similarity-fct (wmej wmei)
   "Retrieves the similarity between wmej and wmei, in that order."
   (let ((*verbose* t)
         (*goal-depth* 1)
         (similarity 0.0))
     (setf wmej (or (get-wme wmej) wmej))
     (setf wmei (or (get-wme wmei) wmei))
     (setf similarity (get-similarity wmej wmei))
     (signal-output *command-trace* "~6,3F" similarity)
     similarity))

(defun set-similarities-fct (triplets)
   "Sets the similarities between the list of triplets, both ways."
   (let ((similarities nil))
     (dolist (triplet triplets similarities)
       (let ((wmej (get-safe-wme (first triplet)))
             (wmei (get-safe-wme (second triplet)))
             (similarity (third triplet)))
         (when (and wmej wmei)
           (push-last similarity similarities)
           (set-similarity wmej wmei similarity)
           (set-similarity wmei wmej similarity))))))

(defmacro test-slots-pm (wme slots actions)
   "Tests that wme slots satisfy all the actions.  Equal test necessary to
    handle the full potential range of non-wme values.  Partial matching
    on wme values.  Returns the activation of wme if above threshold,
    nil otherwise."
   `(let ((activation (activation ,wme)))
      (signal-output *partial-matching-trace* "Partial matching chunk 
~S with activation ~6,3F"
                     ,wme activation)
      (dolist (action ,actions
                      (progn
                        (signal-output *partial-matching-trace* 
"Matching score of chunk ~S is ~6,3F."
                                       ,wme activation)
                        activation))
        (let* ((value (slots-slot ,slots (action-slot action)))
               (target (interpret-value action))
               (similarity (get-similarity value target))
               (negation (action-negation action)))
          (signal-output *partial-matching-trace* "Similarity between 
chunks ~S and ~S is ~6,3F"
                         value target similarity)
          (cond ((null negation)
                 (if (numberp similarity)
                   (let ((match (* similarity *mismatch-penalty*)))
                     (incf activation match)
                     (signal-output *partial-matching-trace* 
"Adjusting activation by ~6,3F to ~6,3F"
                                    match activation))
                   (unless similarity
                     (signal-output *partial-matching-trace* 
"Non-chunk mismatch between ~S and ~S: failure."
                                    value target)
                     (return nil))))
                ((eq negation '-)
                 (if (numberp similarity)
                   (when (= similarity *max-sim*)
                     (let ((match (* similarity *max-dif*)))
                       (incf activation match)
                       (signal-output *partial-matching-trace* 
"Adjusting activation by ~6,3F to ~6,3F"
                                      match activation)))
                   (when similarity
                     (signal-output *partial-matching-trace* 
"Non-chunk match between ~S and ~S for negation test: failure."
                                    value target)
                     (return nil))))
                ((fboundp negation)
                 (unless (and (numberp value) (numberp target)
                              (funcall negation value target))
                   (signal-output *exact-matching-trace* "Value ~S 
does not match test ~S with condition ~S: test fails."
                                  value negation target)
                   (return nil)))
                (t
                 (signal-output *exact-matching-trace* "Unknown test 
~S: ignoring it."
                                negation)))))))

(defun direct-test-and-bind-pm (arguments)
   "Implements a direct match.  Tests for type and then slots, then bind
    variables.  Finally, call the function implementing the next clause.
    Arguments is a list of the wme's stack index, its type, a list of slots
    tests and bindings, and the next call if any.
    This is the rational analysis version, which handles partial matching too."
   (let* ((wme-index (pop arguments))
          (wme (instantiation-variable *instantiation* wme-index))
          (wmetype (or (pop arguments) (when (wmep wme) (wme-type wme))))
          (slots-tested (pop arguments))
          (slots-bound (pop arguments)))
     (cond ((and (wmep wme) (subtype (wme-type wme) wmetype))
            (let* ((slots (wme-slots wme))
                   ;; Set bindings before testing slots
                   (activation (and (set-bindings slots slots-bound)
                                    (if *partial-matching*
                                      (test-slots-pm wme slots slots-tested)
                                      (test-slots wme slots slots-tested)))))
              (setf *sum-exp-act* (exp (/ *retrieval-threshold* *temperature*)))
              ;; In exact match, only counts the chunk activation if it matches?
              (when activation
                (incf *sum-exp-act* (exp (/ activation *temperature*))))
              ;; If activation is below threshold, then reject it
              (when (and activation (< activation *retrieval-threshold*))
                (if *partial-matching*
                  (signal-output *partial-matching-trace*
                                 "CHUNK ~S match score ~6,3F is below 
threshold ~6,3F: failure."
                                 wme activation *retrieval-threshold*)
                  (signal-output *exact-matching-trace*
                               "CHUNK ~S activation ~6,3F is below 
threshold ~6,3F: failure."
                               wme activation *retrieval-threshold*))
                (setf activation nil))
              (add-latency wme (or activation *retrieval-threshold*))
              (when activation
                (simulate-call arguments))))
           (t
            (setf *sum-exp-act* (exp (/ *retrieval-threshold* *temperature*)))
            (add-latency wme *retrieval-threshold*)
            (signal-output *exact-matching-trace* "~S is not a CHUNK 
of type ~S."
                           wme wmetype)))))

(defmacro set-blending-bindings (chunk-probs actions total-prob)
   "Sets the stack entries to the slots values and returns the lowest
    activation of the matches, on the assumption that it determines retrieval."
   `(let ((worst-activation nil))
      ;; iterate separately for each value binding
      (dolist (action ,actions worst-activation)
        (let ((value-probs nil)
              (value nil)
              (probability nil)
              (value-type nil)
              (value-list nil)
              (best-value nil)
              (best-sum nil))
          ;; get the value and probability for each chunk-probability pair
          (dolist (chunk-prob ,chunk-probs)
            (setf value (wme-slot (car chunk-prob) (action-slot action)))
            (setf probability (/ (cdr chunk-prob)
                                 ;; just in case total-prob is 0 (unlikely)
                                 (if (zerop ,total-prob) 1.0 ,total-prob)))
            (push (cons value probability) value-probs)
            (signal-output *blending-trace* "Chunk ~S Value ~S 
Probability ~6,3F"
                           (car chunk-prob) value probability)
            ;; if the value is nil, then do nothing
            ;; if the value is a chunk, then note the type (t means conflict)
            ;; if the value is a number, then add it to the list and
            ;;    note whether it is integer or float
            ;; otherwise add it to the list if it isn't already numbers
            (cond ((null value))
                  ((wmep value)
                   (let ((type (wme-type value)))
                     (if (null value-type)
                       (setf value-type type)
                       (unless (equal value-type type)
                         (setf value-type t)))))
                  ((numberp value)
                   (let ((type (if (integerp value) 'integer 'float)))
                     (cond ((null value-list)
                            (setf value-list (list type)))
                           ((eq (first value-list) 'integer)
                            (when (eq type 'float)
                              (setf (first value-list) 'float)))
                           ((eq (first value-list) 'float))
                           (t
                            (setf value-list (list type))))
                     (push-last (cons value probability) value-list)))
                  (t
                   (unless (or (eq (first value-list) 'integer)
                               (eq (first value-list) 'float))
                     (push (cons value probability) value-list)))))
          ;; if all values are of the same chunk type, then look at all chunks
          ;; otherwise only consider the chunks from the given type
          ;; if some non-chunks values were present, then add them
          ;; unless they were numbers, which then take precedence
          (cond ((eq (first value-list) 'integer)
                 (setf best-value
                       (round (funcall *blending-hook-fn* (rest value-list)))))
                ((eq (first value-list) 'float)
                 (setf best-value
                       (funcall *blending-hook-fn* (rest value-list))))
                (t
                 (if (eq value-type t)
                   (for-all-wmes wme (push wme value-list))
                   (unless (null value-type)
                     (dolist (wme (wme-type-wmes value-type))
                       (push wme value-list))))
                 ;; compute the fit for all possible values and find the best
                 (dolist (value value-list)
                   (let ((sum 0.0))
                     (dolist (value-prob value-probs)
                       (let ((penalty (- 1.0 (or (get-similarity (car 
value-prob)
                                                                 value) 0.0))))
                         (incf sum (* (cdr value-prob) penalty penalty))))
                     (signal-output *blending-trace* "Value ~S Error ~6,3F"
                                    value sum)
                     (unless (and best-value (> sum best-sum))
                       (setf best-value value)
                       (setf best-sum sum))))))
          ;; compute the activation of the match given the best value
          (when best-value
            (let ((activation (funcall *blending-activation-fn*
                                       best-value value-probs ,total-prob)))
              (signal-output *blending-trace* "Best Value ~S Activation ~6,3F"
                             best-value activation)
              ;; if multiple values are bound, each process is independent
              ;; and the slowest one determines the latency
              (when (or (null worst-activation) (< activation worst-activation))
                (setf worst-activation activation))))
          ;; bind the best value if available or fail and return
          (unless (setf (instantiation-variable *instantiation* 
(action-value action))
                        best-value)
            (signal-output *exact-matching-trace* "Variable in slot ~S 
cannot be bound to nil: binding fails."
                           (action-name action))
            (return nil))))))

(defun indirect-test-and-bind-pm (arguments)
   "Implements an indirect match.  For all subtypes of the wme, try all the wmes
    and test their slots, then bind variables.  Finally, call the function
    implementing the next clause.
    Arguments is a list of the wme's stack index, its type, a list of slots
    tests and bindings, and the next call if any.
    This is the rational analysis version, which handles partial matching too.
    In addition, if blending is enabled then bind the consensus values."
   (let* ((wme-index (pop arguments))
          (wmetype (pop arguments))
          (slots-tested (pop arguments))
          (slots-bound (pop arguments))
          (best-activation (if *blending* most-negative-short-float
                               *retrieval-threshold*))
          (best-wme nil)
          (slots nil)
          (activation nil)
          (temperature (when *blending* (or *temperature* (* (sqrt 
2.0) *activation-noise*))))
          (total-prob (when *blending* (exp (/ *retrieval-threshold* 
temperature))))
          (chunk-probs nil))
     (signal-output *partial-matching-trace* "Matching CHUNKs of type 
~S." wmetype)
     (setf *sum-exp-act* (exp (/ *retrieval-threshold* *temperature*)))
     ;; If blending is on, then do not apply retrieval threshold to 
individual chunks
     (let ((*retrieval-threshold* best-activation))
       (dolist (type (wme-type-subtypes wmetype))
         (dolist (wme (wme-type-wmes type))
           (setf slots (wme-slots wme))
           (if wme-index
             (setf (instantiation-variable *instantiation* wme-index) wme)
             (setf *retrieval-scheduler* wme))
           ;; Set bindings before testing slots
           (setf activation (and (set-bindings slots slots-bound)
                                 (if *partial-matching*
                                   (test-slots-pm wme slots slots-tested)
                                   (test-slots wme slots slots-tested))))
           ;; In exact match, only counts the chunk activation if it matches?
           (when activation
             (incf *sum-exp-act* (exp (/ activation *temperature*))))
           (when (and activation *blending*)
             (let ((prob (exp (/ activation temperature))))
               (push (cons wme prob) chunk-probs)
               (incf total-prob prob)))
           (when (and activation (>= activation best-activation))
             (signal-output *partial-matching-trace* "Activation ~6,3F 
is larger than previous best ~6,3F: selecting ~S."
                            activation best-activation wme)
             (setf best-activation activation)
             (setf best-wme wme)))))
     (if (or (eq *blending* t)
             (and (eq *blending* 'rt)
                  (< best-activation *retrieval-threshold*)))
       (setf best-activation
             (set-blending-bindings chunk-probs slots-bound total-prob))
       (setf chunk-probs nil))
     (unless (or (eq *blending* 'rt)
                 (>= best-activation *retrieval-threshold*))
       (setf best-activation *retrieval-threshold*)
       (setf best-wme nil))
     (add-latency (or best-wme 'failure) best-activation)
     (cond (best-wme
            (setf slots (wme-slots best-wme))
            (if wme-index
              (setf (instantiation-variable *instantiation* wme-index) best-wme)
              (setf *retrieval-scheduler* best-wme))
            (unless chunk-probs (set-bindings slots slots-bound))
            (simulate-call arguments))
           (t
            (signal-output *partial-matching-trace* "No chunk reached 
activation threshold ~6,3F: matching fails."
                           *retrieval-threshold*)))))


;;; rhs

(defmacro set-wmfocus (&key (wme nil) (spread nil) (activation-sources nil))
   "Sets the focus to wme, and update activation spread and goal 
sources, if necessary."
   `(progn
      (setf *wmfocus* ,wme)
      (signal-output *goal-trace* "Switching to goal ~S." *wmfocus*)
      (when *enable-rational-analysis*
        ,(when spread `(update-activation-spread)))
      (setf *goal-sources* (or ,activation-sources
                               (when ,wme
                                 (copy-list (rest (wme-slot-wmes ,wme))))))
      *wmfocus*))

(defmacro reset-frame (stack-frame &key (spread nil))
   "Resets a frame of the goal stack."
   `(let ((frame ,stack-frame))
      (set-wmfocus :wme (goal-frame-focus frame) :spread ,spread
                   :activation-sources (goal-frame-sources frame))))

(defmacro return-values ()
   "Return values from the focus using the top goal frame."
   `(let ((wme nil)
          (slot nil)
          (value nil))
      (dolist (return (goal-frame-return-values (first *goal-stack*)))
        (setf value (wme-slot *wmfocus* (first return)))
        (dolist (destination (rest return))
          (setf wme (goal-frame-focus (nth (car destination) *goal-stack*)))
          (setf slot (cdr destination))
          (set-slot-value wme slot value)))))

(defun rehearse-chunk-fct (chunks &key (repeat 1) (force nil)
                                   (cycle nil) (time nil))
   "Rehearses chunks repeat times.  If a chunk is a list, then the first element
    of the list is the chunk to rehearse and the rest is the list of sources.
    When force is on, update the statistics whether or not learning is on.
    When cycle and/or time is set, increment the equivalent ACT-R counters
    by those amounts (1 by default)."
   (let ((structures nil)
         (level (* 1.0 repeat)))
     (unless (integerp repeat)
       (setf repeat (round repeat)))
     (dolist (spec chunks structures)
       (let ((chunk (get-safe-wme (if (listp spec) (first spec) spec))))
         (when chunk
           (push-last spec structures)
           (when (or force *base-level-learning*)
             ;; call add-reference because generalization needs to be 
implemented properly
             (add-reference (wme-references chunk) 
*optimized-learning* repeat *time*))
           (when (or force *associative-learning*)
             (let ((sources nil))
               (if (listp spec)
                 (dolist (source (rest spec))
                   (setf source (get-safe-wme source))
                   (when source (push source sources)))
                 ; add the chunk itself to the set of sources
                 (setf sources (cons chunk (rest (wme-slot-wmes chunk)))))
               ;; Do not parcel out the sources.
               (incf (wme-needed chunk) level)
               (dolist (source sources)
                 (incf (wme-contexts source) level)
                 (incf (ia-fnicj (get-make-ia source chunk)) level))))
           (when cycle
             (incf *cycle* (* repeat (if (numberp cycle) cycle 1))))
           (when time
             (incf *time* (* level (if (numberp time) time 1.0)))))))))

(defun identical-wme (&optional (goal *wmfocus*))
   "If a wme identical to goal exists, then deletes goal and returns
    the identical wme after rehearsal.  Otherwise, returns goal."
   (when goal
     (let ((type (wme-type goal)))
       (setf goal
             (dolist (wme (wme-type-wmes type) goal)
               (when (and (not (eq goal wme))
                          (dolist (slot (wme-type-slots type) t)
                            (unless (equal (wme-slot goal (slot-index slot))
                                           (wme-slot wme (slot-index slot)))
                              (return nil))))
                 ; delete goal and replace any remaining reference with wme
                 (delete-wme goal wme)
                 ; FIX: rehearse IAs as well as BLLs
                 (rehearse-chunk-fct (list (cons wme *goal-sources*)))
                 (return wme))))
       ;;; If of type dependency, then call solve-by-analogy
       ;;; FIX: only if it has not been popped in failure
       (when (and (eq (wme-type-name type) 'dependency)
                  *instantiation*
                  (not (get-functional-parameter
                        (production-failure
                         (instantiation-production *instantiation*)))))
         (solve-by-analogy goal))
       goal)))

(defun goal-focus-fct (&optional (wmes nil))
   "Sets the focus to the first wme, the list to focus-list,
    or print the current focus if none is selected."
   (let ((*verbose* t)
         (*goal-depth* 1)
         (wme nil))
     (cond (wmes
            (setf wme (get-safe-wme (first wmes)))
            (when wme
              (identical-wme)
              (set-wmfocus :wme wme :spread t))
            (setf *wmfocus-list* (list *wmfocus*))
            (dolist (wme-name (rest wmes))
              (setf wme (get-safe-wme wme-name))
              (when wme (push-last wme *wmfocus-list*))))
           (*wmfocus*
            (pprint-wme *wmfocus*))
           (t
            (signal-output *command-trace* "No focus currently selected.")))
     (when *wmfocus* (wme-name *wmfocus*))))

(defmacro focus-macro (goal &optional return-values)
   "Replaces the current focus with the new goal.  Return values from the old
    goal and install the return value specs for the new one in its place."
   `(progn
      (save-state-change
       :focus-on (make-goal-frame :focus *wmfocus*
                                  :return-values (when *goal-stack*
                                                   (goal-frame-return-values
                                                    (first *goal-stack*)))
                                  :sources *goal-sources*))
      (when *goal-stack*
        (return-values)
        (setf (goal-frame-return-values (first *goal-stack*)) ,return-values))
      (identical-wme)
      (set-wmfocus :wme ,goal)))

(defun focus-on-goal-fct (wme)
   "Replaces the current focus with the new goal.  Return values from the old
    goal and install the return value specs for the new one in its place."
   (let ((subgoal (get-safe-wme wme)))
     (when subgoal
       (focus-macro subgoal)
       (wme-name wme))))

(defun focus-fct (arguments)
   "Replaces the current focus with the new goal.  Return values from 
the old goal
    and install the return value specs for the new one in its place."
   (let* ((subgoal (pop arguments))
          (return-values (pop arguments)))
     (focus-macro (instantiation-variable *instantiation* subgoal) 
return-values)))

(defun buffers-fct (buffers)
   "Displays and sets the contents of buffers."
   (let ((buffer-values nil))
     (cond ((null buffers)
            (dolist (buffer *buffer-keywords*)
              (let ((name (first buffer))
                    (value (rest buffer)))
                (unless (variablep name)
                  (setf value (symbol-value value))
                  (push-last (when value (wme-name value)) buffer-values)
                  (format t "~S~C~S~%" name #\tab value)))))
           (t
            (loop
              (unless buffers (return))
              (let* ((buffer (pop buffers))
                     (name (assoc buffer *buffer-keywords*)))
                (cond (name
                       (unless (or (null buffers)
                                   (and (assoc (first buffers) 
*buffer-keywords*)
                                        (not (equal (first name) 
(first buffers)))))
                         (let ((value (when (first buffers) 
(get-safe-wme (first buffers)))))
                           (if (or (eq buffer 'goal) (eq buffer '=goal))
                             (focus-macro value)
                             (setf (symbol-value (rest name)) value)))
                         (pop buffers))
                       (let ((value (symbol-value (rest name))))
                         (push-last (when value (wme-name value)) 
buffer-values)))
                      (t
                       (signal-warn "UNKNOWN BUFFER ~S" buffer)))))))
     buffer-values))

(defun retrieval-fct (&optional (chunk nil))
   "Displays or changes (if argument is supplied) the value of
    the last chunk retrieved."
   (cond (chunk
          (setf chunk (get-safe-wme chunk))
          (setf *retrieval* chunk))
         (*retrieval*
          (pprint-wme *retrieval*))
         (t
          (signal-output *command-trace* "No retrieval currently present.")))
   (when *retrieval* (wme-name *retrieval*)))

(defmacro push-macro (goal &optional return-values)
   "Pushes the current goal on the stack and install goal as the new focus,
    with optional return values."
   `(progn
      (save-state-change :push-goal)
      (when *wmfocus*
        (push (make-goal-frame :focus *wmfocus*
                               :return-values ,return-values
                               :sources *goal-sources*)
              *goal-stack*)
        (incf *goal-depth* 3))
      (set-wmfocus :wme ,goal)))

(defun push-goal-fct (wme)
   "Pushes the current goal on the stack and install wme as the new focus."
   (let ((subgoal (get-safe-wme wme)))
     (when subgoal
       (push-macro subgoal)
       (wme-name subgoal))))

(defun push-fct (arguments)
   "Pushes the current goal on the stack and install the first argument
    as the new focus."
   (let* ((subgoal (pop arguments))
          (return-values (pop arguments)))
     (push-macro (instantiation-variable *instantiation* subgoal) 
return-values)))

(defmacro pop-macro ()
   "Pops the top goal off the stack and into the focus and return values."
   `(progn
      (save-state-change :pop-goal
                         (make-goal-frame :focus *wmfocus*
                                          :return-values (when *goal-stack*
 
(goal-frame-return-values
                                                            (first 
*goal-stack*)))
                                          :sources *goal-sources*))
      (cond (*goal-stack*
             (return-values)
             (decf *goal-depth* 3)
             (identical-wme)
             (reset-frame (pop *goal-stack*)))
            (t
             (identical-wme)
             (set-wmfocus)))))

(defun pop-goal-fct ()
   "Pops the top goal off the stack and into the focus and return values."
   (pop-macro)
   (when *wmfocus* (wme-name *wmfocus*)))

(defun pop-fct (arguments)
   "Pops the top goal off the stack and into the focus and return values."
   (declare (ignore arguments))
   (pop-macro))

(defun clear-goal-stack-fct ()
   "Clears the goal stack by restoring the top goal."
   (loop
     (unless *goal-stack* (return))
     (pop-macro))
   (when *wmfocus* (wme-name *wmfocus*)))

(defun goal-stack-fct ()
   "Prints the list of wmes on the goal stack."
   (let ((*verbose* t)
         (*goal-depth* 1)
         (goals nil))
     (signal-output *command-trace* "Focus: ~S   ~6,3F" *wmfocus* *g*)
     (when *wmfocus* (push (wme-name *wmfocus*) goals))
     (dolist (frame *goal-stack*)
       (push-last (wme-name (goal-frame-focus frame)) goals)
       (signal-output *command-trace* "~S" (goal-frame-focus frame)))
     goals))

(defmacro set-slots (wme actions)
   "Sets wme slots according to actions."
   `(dolist (action ,actions)
      (set-slot-value ,wme (action-slot action) (interpret-value action))))

(defun modify-old-wme (arguments)
   "Set new slot values of an existing wme."
   (let* ((wme (instantiation-variable *instantiation* (pop arguments)))
          (type (pop arguments)))
     (signal-output *dm-trace* "Modifying CHUNK ~S." wme)
     (if (subtype (wme-type wme) type)
       (set-slots wme (pop arguments))
       (signal-warn "CHUNK ~S IS NOT OF TYPE ~S." wme type))))

(defun create-new-wme (arguments)
   "Creates a new wme, sets its slot values and sets its stack binding."
   (let* ((wme-index (pop arguments))
          (wme-name (safe-gentemp (symbol-name (pop arguments))))
          (wme-type (pop arguments))
          (wme (create-wme wme-name wme-type)))
     (signal-output *dm-trace* "Creating CHUNK ~A." wme-name)
     (setf (instantiation-variable *instantiation* wme-index) wme)
     (set-slots wme (pop arguments))))

(defun output (arguments)
   "Prints the first argument, which is interpreted as a format command."
   (let* ((format-args (pop arguments))
          (format-string (first format-args))
          (format-list (list *goal-depth*)))
     (when (and *verbose* *output-trace*)
       (dolist (index (rest format-args))
         (push-last (if (functionp index)
                      (funcall index)
                      (instantiation-variable *instantiation* index))
                    format-list))
       (format *output-trace* "~?" format-string format-list))))

(defun eval-side (arguments)
   "Evaluate the first of the arguments (for the side-effects),
    then call the next clause."
   (funcall (pop arguments)))

(defun bind-rhs (arguments)
   "Binds the first argument to the evaluation of the second."
   (setf (instantiation-variable *instantiation* (pop arguments))
         (get-wme-or-constant (funcall (pop arguments)))))

(defun bind-move-attention (arguments)
   "Binds the first of the arguments to the value of move-location
    applied to the second."
   (setf (instantiation-variable *instantiation* (pop arguments))
         (get-wme-or-constant (apply #'move-attention (funcall (pop 
arguments))))))

(defun visual-action (arguments)
   "Calls the visual routine with proper evaluation of arguments."
   (apply (pop arguments) (funcall (pop arguments))))

(defun action-command (arguments)
   "Calls the send-command routine with the cycle time and rest of arguments.
    Was later modified to send-RPM-command."
   (apply 'send-rpm-command (- *time* *start-time*)
          (funcall (pop arguments))))

(defun delete-wme-variable (arguments)
   "Delete the wme indexed by the first argument."
   (let ((wme (svref *instantiation* (first arguments))))
     (signal-output *dm-trace* "Deleting CHUNK ~S." wme)
     (delete-wme wme)))

(defun copy-chunk-variable (arguments)
   "Binds the first argument to a list of the copies of the second."
   (setf (instantiation-variable *instantiation* (pop arguments))
         (copy-chunks (funcall (pop arguments)))))

(defun stop (arguments)
   "Stops the run after this cycle."
   (declare (ignore arguments))
   (setf *stop* t))

(defun restart-top-goal (arguments)
   "Pops all goals on the stack."
   (loop
     (unless *goal-stack* (return))
     (pop-fct arguments)))


;;; Run

(defmacro generate-all-instantiations ()
   "Do left-hand side matching of all productions on the current WM state."
   `(progn
      (setf *conflict-set* nil)
;     (if *wmfocus*
        (dolist (goal-type (cons (get-safe-type t 'generate-all-instantiations)
                                 (when *wmfocus*
                                   (wme-type-supertypes (wme-type *wmfocus*))))
                           *conflict-set*)
          (dolist (production (wme-type-productions goal-type))
            (match-lhs production)))))
;       (signal-warn "NO GOAL SELECTED AS FOCUS."))))

(defun pmatches-fct ()
   "Generates and prints instantiations for the current WM state.
    Does NOT guarantee that Expected Gain Noise is going to be the same in run."
   (let ((*verbose* t)
         (*goal-depth* 1)
         (productions nil))
     (pprint-instantiations (generate-all-instantiations)
                            *command-trace* *matches-trace*)
     (dolist (instantiation *conflict-set* productions)
       (push-last (production-name (instantiation-production instantiation))
                  productions))))

(defun whynot-fct (productions)
   "Tries to match production(s) name with exact matching trace on.
    The whole lhs is matched, even when ERA is on."
   (let ((*exact-matching-trace* *command-trace*)
         (*partial-matching-trace* *command-trace*)
         (*verbose* t)
         (*goal-depth* 1))
     (when productions
       (setf *conflict-set* nil)
       (dolist (production productions)
         (setf production (get-safe-production production))
         (when production
           (when (and (match-lhs production) *enable-rational-analysis*)
             (let ((*instantiation* (production-instantiation production)))
               (unless (simulate-call (cdr (production-lhs production)))
                 (setf *conflict-set*
                       (delete *instantiation* *conflict-set* :test #'eq))))))))
     (setf productions nil)
     (pprint-instantiations *conflict-set* *command-trace*)
     (dolist (instantiation *conflict-set* productions)
       (push-last (production-name (instantiation-production instantiation))
                  productions))))

(defun choose-instantiation ()
   "If rational analysis is enabled, then pick the best instantiation.
    Otherwise, pick the first one since it is the one with the highest value.
    Returns the winning instantiation, the latency of the matching process,
    and the latency of the productions which failed before the winning one."
   (let ((index 0)
         (failed-latencies 0.0))
     (setf *instantiation* nil)
     (setf *latency* 0.0)
     (cond ((and (null *conflict-set*) *retrieval-threshold*)
            (setf *latency* (activation-latency *retrieval-threshold*)))
           (*enable-rational-analysis*
            (signal-output *activation-trace* "Sources of activation 
are: ~S" *activation-sources*)
            (dolist (instantiation *conflict-set* (setf *instantiation* nil))
              (let* ((production (instantiation-production instantiation))
                     (lhs (cdr (production-lhs production))))
                 (signal-output (or *exact-matching-trace* 
*partial-matching-trace* *conflict-resolution-trace*)
                               "Matching production ~S" production)
                 (signal-output *activation-trace* "Adding latency of 
production ~A" production)
                 (setf *instantiation* instantiation)
                 (incf index 1)
                 (when (simulate-call lhs)
                   (return))
                 ;;; if matching fails, learn the failure with the 
latency of the failed matching
                 (when *parameters-learning* (learn-parameters nil nil
 
:latency (- *latency* failed-latencies)))
                 (signal-output *conflict-resolution-trace* "Failed 
production ~A"
                                production)
                 (signal-output *conflict-resolution-trace* "Matching 
Latency: ~6,3F"
                                (- *latency* failed-latencies))
                 (setf failed-latencies *latency*)))
            (signal-output *conflict-set-trace* "~D productions out of 
~D considered; expected gain of chosen is: ~6,3F"
                           index (length *conflict-set*)
                           (when *instantiation* (instantiation-gain 
*instantiation*))))
           (t
            (signal-output *conflict-set-trace* "~D instantiations in 
the conflict set" (length *conflict-set*))
            (setf *instantiation* (first *conflict-set*))))
     (when (and *instantiation* *production-trace*)
       (pprint-instantiation *instantiation* *production-trace*))
     (values *instantiation* *latency* failed-latencies)))

(defun matching-cycle (&optional (cycles nil) (retrieval-threshold 
*retrieval-threshold*)
                                  (utility-threshold *utility-threshold*))
   "Implements the production matching (lhs) cycle called by run-fct 
and the PM scheduler.
    Cycles is the time limit for the matching cycle if applicable.
    Returns the latency of the action phase if any, nil otherwise."
   (let ((matching-latency 0.0)
         (failed-latencies 0.0)
         (action nil))
     (when (and *retrieval-threshold* *activation-noise*)
       (let ((noise (noise *activation-noise*)))
         (setf *retrieval-threshold* (+ retrieval-threshold noise))
         (signal-output *activation-trace* "   Adding noise ~6,3F to 
retrieval threshold for a total of ~6,3F"
                        noise *retrieval-threshold*)))
     (when (and *utility-threshold* *exp-gain-noise*)
       (let ((noise (noise *exp-gain-noise*)))
         (setf *utility-threshold* (+ utility-threshold noise))
         (signal-output (or *exact-matching-trace* *partial-matching-trace*)
                        "   Adding noise ~6,3F to utility threshold 
for a total of ~6,3F"
                        noise *utility-threshold*)))
     (generate-all-instantiations)
     (when *matches-trace*
       (pprint-instantiations *conflict-set* *matches-trace* *matches-trace*))
     (setf *instantiation* nil)
     (when *conflict-set-hook-fn*
       (multiple-value-bind (instantiations latency)
                            (funcall *conflict-set-hook-fn* *conflict-set*)
         (declare (ignore latency))
         (when instantiations ; if returns nil, then continue unchanged
           (cond ((listp instantiations) ; if returns a list, then 
interpret as new cset
                  (setf *conflict-set* instantiations))
                 (t ; otherwise, restrict the conflict set to selected 
instantiation
                  (setf *conflict-set* (list instantiations)))))))
     (unless *instantiation*
       (multiple-value-setq (*instantiation* matching-latency failed-latencies)
         (choose-instantiation)))
     ;;; the following used to be part of the action cycle but really 
belongs in matching
     (cond (*instantiation*
            (let ((production (instantiation-production *instantiation*)))
              (cond ((and *abort-instantiation* *enable-rational-analysis*
                          (floatp cycles)
                          (> (+ *time* matching-latency)
                             cycles))
                     (signal-output *latency-trace* "Time ~6,3F: ~A 
Aborted" *time* production))
                    (t
                     (when (or *base-level-learning* *associative-learning*
                               *strength-learning*)
                       (learn-matching))
                     (when *enable-rational-analysis*
                       (incf *time* matching-latency)
                       (when (plusp matching-latency)
                         (signal-output *latency-trace* "Latency 
~6,3F: ~A Matching"
                                        matching-latency production)))
                     (signal-output *cycle-trace* "Time ~6,3F: ~A 
Selected" *time* production)
                     (setf (instantiation-latency *instantiation*)
                           (- matching-latency failed-latencies))
                     (setf action (production-action-cost production))))))
           ((and *enable-rational-analysis* *pop-upon-failure* (null 
*retrieval-scheduler*))
            (incf *time* matching-latency)
            (when (plusp matching-latency)
              (signal-output *latency-trace* "Latency ~6,3F: Failure Matching"
                             matching-latency))
            (setf action *default-action-time*))
           (t
            (signal-output *latency-trace* "Time ~6,3F: No 
Instantiation Found." *time*)))
     action))

(defun action-cycle (action-time)
   "Implements the production action (rhs) cycle called by run-fct and 
the PM scheduler.
    The argument action-time holds the latency of the action cycle"
   ;; Reset *latency* for the action retrievals
   (setf *latency* 0.0)
   (cond (*instantiation*
          (let* ((production (instantiation-production *instantiation*))
                 (success (< (random 1.0)
                             (production-action-probability production))))
            (when (member (production-name production) *break-productions*
                          :test #'eq)
              (pprint-instantiation)
              (break "Production ~S is about to fire.~%" production))
            ;; increment time by action latency before production firing
            (incf *time* action-time)
            (signal-output *latency-trace* "Latency ~6,3F: ~A Action"
                           action-time production)
            (cond (success
                   (when *enable-production-learning* 
(store-instantiation *instantiation*))
                   (when *firing-hook-fn*
                     (funcall *firing-hook-fn* *instantiation*))
                   (dolist (rhs-call (production-rhs production))
                     (simulate-call rhs-call))
                   (signal-output *cycle-trace* "Time ~6,3F: ~A Fired" 
*time* production)
                   (when *enable-rational-analysis*
                     (update-activation-spread)))
                  (t
                   (signal-output *cycle-trace* "Time ~6,3F: ~A Fails" 
*time* production)))
            (when *parameters-learning*
              (learn-parameters (get-functional-parameter 
(production-success production))
                                (get-functional-parameter 
(production-failure production))
                                :latency (+ (instantiation-latency 
*instantiation*)
                                            action-time)))))
         (t
          (when *goal-stack*
            (let ((failure (get-wme 'failure)))
              (unless failure ; if failure isn't yet defined then add it
                (add-dm-fct '((failure isa error condition failure)) 
:reset-ia nil)
                (setf failure (get-wme 'failure)))
              (dolist (return (goal-frame-return-values (first *goal-stack*)))
                (set-slot-value *wmfocus* (first return) failure))))
          (incf *time* action-time)
          (signal-output *latency-trace* "Latency ~6,3F: Failure Action"
                         action-time)
          (signal-output *cycle-trace* "Time ~6,3F: ~A Popped in 
Failure" *wmfocus* *time*)
          (pop-fct "failure")
          (when *parameters-learning*
            (learn-parameters nil t :instantiation nil)))))

(defun retrieval-event (&optional (time *time*))
   "Sets the retrieval if the current time is past the retrieval time. 
If the time passed
    as argument is after the current time, this implements some 
lookahead capability."
   (when (and *retrieval-scheduler* (>= time (car *retrieval-scheduler*)))
     (signal-output *cycle-trace* "Time ~6,3F: ~A Retrieved"
                    (car *retrieval-scheduler*) (cdr *retrieval-scheduler*))
     (setf *retrieval* (cdr *retrieval-scheduler*))
     (setf *retrieval-scheduler* nil))
   )

(defun run-fct (&optional (cycles -1))
   (let ((start-time *time*)
         (start-cycle *cycle*)
         (retrieval-threshold *retrieval-threshold*)
         (utility-threshold *utility-threshold*))
     (cond ((integerp cycles) (incf cycles *cycle*))
           ((floatp cycles) (incf cycles *time*))
           (t (signal-warn "ARGUMENT TO RUN COMMAND MUST BE A NUMBER.")))
     (loop
       ;;; sets the time of the start of the production cycle
       (setf *start-time* *time*)
       (retrieval-event)
       (cond (*stop*
              (signal-output *latency-trace* "Time ~6,3F: Stop 
Requested" *time*)
              (setf *stop* nil)
              (return))
;            ((null *wmfocus*)
;             (signal-output *latency-trace* "Time ~6,3F: No Goal" *time*)
;             (return))
             ((and (integerp cycles) (= *cycle* cycles))
              (signal-output *latency-trace* "Time ~6,3F: Stopped by 
Run Cycle Limit" *time*)
              (return))
             ((and (floatp cycles) (>= *time* cycles))
              (signal-output *latency-trace* "Time ~6,3F: Stopped by 
Run Time Limit" *time*)
              (return))
             (t))
       (save-state-change :run *time* *cycle* *spread-stamp* 
(make-random-state))
       ;;; production cycle
       (let ((action-time (matching-cycle cycles retrieval-threshold 
utility-threshold)))
         (cond (action-time ;;; if production left-hand side match
                (retrieval-event (+ *time* action-time))  ;;; for 
retrievals during action
                (action-cycle action-time))  ;;; then execute the 
right-hand side action
               (*retrieval-scheduler*  ;;; if retrieval event pending
                (setf *time* (if (floatp cycles)  ;; schedule if 
before end of run quantum
                               (min cycles (car *retrieval-scheduler*))
                               (car *retrieval-scheduler*))))
               (t (return))))        ;;; else quit
       (incf *cycle* 1)
       (when *cycle-hook-fn* (funcall *cycle-hook-fn* *instantiation*))
       (when *web-hook-fn* (funcall *web-hook-fn* *instantiation*))
       )
     ;; Reset at the end because of aborted cycles
     (setf *retrieval-threshold* retrieval-threshold)
     (setf *utility-threshold* utility-threshold)
     (when *end-run-hook-fn* (funcall *end-run-hook-fn* (- *time* start-time)))
     (signal-output *latency-trace* "Run Latency: ~6,3F" (- *time* start-time))
     (values (* 0.001 (round (- *time* start-time) 0.001)) (- *cycle* 
start-cycle))))

(defun step-fct (conflict-set)
   "Asks the user to choose between step, stop, run, or select."
   (loop
     (signal-output *command-trace* "Another step?  [Y] step, [N] 
stop, [R] run, [#] select: ")
     (let ((input (read)))
       (cond ((eq input 'y)
              (return conflict-set))
             ((eq input 'n)
              (setf *stop* t)
              (return conflict-set))
             ((eq input 'r)
              (setf *conflict-set-hook-fn* nil)
              (setf *matches-trace* nil)
              (return conflict-set))
             ((and (integerp input)
                   (> input 0) (<= input (length conflict-set)))
              (return (nth (- input 1) conflict-set)))
             (t
              (signal-output *command-trace* "Unknown entry ~S"
                             input))))))

(defun pstep-fct (&optional (cycles -1))
   "Runs for a specified number of cycles (if integer) or time (if real)
    or forever if no value specified.  At each cycle, displays the 
instantiations
    with matches trace, then allow the user to decide what to do next."
   (let ((*matches-trace* (or *matches-trace* t))
         (*verbose* t)
         (*conflict-set-hook-fn* *step-fn*))
     (run-fct cycles)))

(defun run-many-fct (&optional (n 1))
   "Runs the whole wmfocus list n times."
   (dotimes (i n)
     (dolist (goal *wmfocus-list*)
       (set-wmfocus :wme goal :spread t)
       (run-fct))))


;;; Setting of global parameters

(defmacro assign-stream (parameter value)
   "Handles the (de)assigning of streams to traces."
   `(progn
      (when (streamp ,parameter)
        (close ,parameter))
      (when (or (stringp ,value) (pathnamep ,value))
        (setf ,value (open ,value :direction :output
                           :if-exists :append :if-does-not-exist :create)))))

(defmacro sigp (parameter par test warning &rest housekeeping)
   "Sets individual global parameter.  Tests that value (if not no-set)
    satisfies test before setting parameter and doing housekeeping,
    otherwise issue warning."
   `(cond (,test
           (setf ,parameter value)
           ,@housekeeping
           value)
          (t
           (signal-warn "GLOBAL PARAMETER ~A CANNOT TAKE VALUE ~S 
BECAUSE IT MUST BE ~A."
                        ,par value ,warning)
           :error)))

(defmacro variance-to-s (variance)
   "Given a variance, returns the corresponding value."
   `(when ,variance (/ (sqrt (* 3.0 ,variance)) 3.1416)))

(defmacro s-to-variance (s)
   "Given s, returns the corresponding variance."
   `(when ,s
      (let ((pis (* 3.1416 ,s)))
        (/ (* pis pis) 3.0))))

(defun global-parameters-fct (&optional parameters)
   "Return the value of the global parameters, or print them all if 
none specified."
   (let* ((verbose *verbose*)
          (*verbose* t)
          (*goal-depth* 1)
          (value nil)
          (values nil))
     (cond (parameters
            (dolist (parameter parameters values)
              (setf value
                    (case parameter
                      ((:esc :era) *enable-rational-analysis*)
                      (:g *g*)
                      (:egn (s-to-variance *exp-gain-noise*))
                      (:egs *exp-gain-noise*)
                      (:er *enable-randomness*)
                      (:ut *utility-threshold*)
                      (:ga *goal-activation*)
                      (:blc *base-level-constant*)
                      (:an (s-to-variance *activation-noise*))
                      (:ans *activation-noise*)
                      (:pan (s-to-variance *permanent-activation-noise*))
                      (:pas *permanent-activation-noise*)
                      (:lf *latency-factor*)
                      (:le *latency-exponent*)
                      (:dat *default-action-time*)
                      (:pm *partial-matching*)
                      (:mp *mismatch-penalty*)
                      (:ms *max-sim*)
                      (:md *max-dif*)
                      (:rt *retrieval-threshold*)
                      (:tmp *temperature*)
                      (:bln *blending*)
                      (:cp *cost-penalty*)
                      (:ie *initial-experience*)
                      (:tt *threshold-time*)
                      (:epl *enable-production-learning*)
                      (:ol *optimized-learning*)
                      (:bll *base-level-learning*)
                      (:al *associative-learning*)
                      (:sl *strength-learning*)
                      (:pl *parameters-learning*)
                      (:emt *exact-matching-trace*)
                      (:pmt *partial-matching-trace*)
                      (:pct *production-compilation-trace*)
                      (:act *activation-trace*)
                      (:blt *blending-trace*)
                      (:crt *conflict-resolution-trace*)
                      (:cst *conflict-set-trace*)
                      (:mt *matches-trace*)
                      (:pt *production-trace*)
                      (:ct *cycle-trace*)
                      (:lt *latency-trace*)
                      (:ot *output-trace*)
                      (:dmt *dm-trace*)
                      (:gt *goal-trace*)
                      (:v verbose)
                      (t (signal-warn "NO GLOBAL PARAMETER ~A DEFINED" 
parameter)
                         :error)))
              (push-last value values)
              (signal-output *command-trace* "~S ~6,3F" parameter value)))
           (t
            (setf values
                  (list *enable-rational-analysis* *g* *exp-gain-noise*
                        *enable-randomness* *utility-threshold*
                        *goal-activation* *base-level-constant*
                        *activation-noise* *permanent-activation-noise*
                        *latency-factor* *latency-exponent* 
*default-action-time*
                        *partial-matching* *mismatch-penalty* 
*max-sim* *max-dif*
                        *retrieval-threshold* *temperature* *blending*
                        *optimized-learning* *base-level-learning* 
*associative-learning*
                        *strength-learning* *parameters-learning*
                        *cost-penalty* *initial-experience* 
*threshold-time* *enable-production-learning*
                        *exact-matching-trace* 
*partial-matching-trace* *production-compilation-trace*
                        *activation-trace* *blending-trace*
                        *conflict-resolution-trace* *conflict-set-trace*
                        *matches-trace* *production-trace* 
*cycle-trace* *latency-trace*
                        *output-trace* *dm-trace* *goal-trace* verbose))
            (signal-output *command-trace* "~?"
                           "Enable Subsymbolic Computations (esc): 
~S~% G (g): ~S~%~
                            ~1TExpected Gain S (egs): ~S~% Enable 
Randomness (er): ~S~%~
                            ~1TUtility Threshold (ut): ~S~%~
                            ~1T--------------------~%~
                            ~1TGoal Activation (ga): ~S~% Base Level 
Constant (blc): ~S~%~
                            ~1TActivation Noise S (ans): ~S~% 
Permanent Activation S (pas): ~S~%~
                            ~1T--------------------~%~
                            ~1TLatency Factor (lf): ~S~%~
                            ~1TLatency Exponent (le): ~S~% Default 
Action Time (dat): ~S~%~
                            ~1T--------------------~%~
                            ~1TPartial Matching (pm): ~S~% Mismatch 
Penalty (mp): ~S~%~
                            ~1TMaximum Similarity (ms): ~S~% Maximum 
Difference (md): ~S~%~
                            ~1TRetrieval Threshold (rt): ~S~%~
                            ~1TTemperature (tmp): ~S~% Blending (bln): ~S~%~
                            ~1T--------------------~%~
                            ~1TOptimized Learning (ol): ~S~% Base 
Level Learning (bll): ~S~%~
                            ~1TAssociative Learning (al): ~S~% 
Strength Learning (sl): ~S~%~
                            ~1TParameters Learning (pl): ~S~% Cost 
Penalty (cp): ~S~%~
                            ~1TInitial Experience (ie): ~S~% Threshold 
Time (tt): ~S~% Enable Production Learning (epl): ~S~%~
                            ~1T--------------------~%~
                            ~1TExact Matching Trace (emt): ~S~% 
Partial Matching Trace (pmt): ~S~%~
                            ~1TProduction Compilation Trace (pct): ~S~%~
                            ~1TActivation Trace (act): ~S~% Blending 
Trace (blt): ~S~%~
                            ~1TConflict Resolution Trace (crt): ~S~% 
Conflict Set Trace (cst): ~S~%~
                            ~1TMatches Trace (mt): ~S~% Production 
Trace (pt): ~S~% Cycle Trace (ct): ~S~%~
                            ~1TLatency Trace (lt): ~S~% Output Trace (ot): ~S~%~
                            ~1TDeclarative Memory Trace (dmt): ~S~% 
Goal Trace (gt): ~S~% Verbose (v): ~S~%"
                           values)
            nil))))

(defun set-global-parameters-fct (parameters)
   "Sets global parameters."
   (let ((values nil)
         (parameter nil)
         (value nil))
     (loop
       (unless parameters (return values))
       (setf parameter (pop parameters))
       (setf value (pop parameters))
       (when (and (listp value) (eq (first value) 'quote))
         (setf value (second value)))  ;; for compatibility with 
evaluating versions
       (push-last
        (case parameter
          (:dat (sigp *default-action-time* :dat (and (numberp value) 
(>= value 0.0)) "a non-negative number"))
          (:ga  (sigp *goal-activation* :ga (and (numberp value) (>= 
value 0.0)) "a non-negative number"
                      (update-activation-spread)))
          (:g (sigp *g* :g (and (numberp value) (>= value 0.0)) "a 
non-negative number"
                    (all-pg-c)))
          (:egn (sigp *exp-gain-noise* :egn (or (null value) (and 
(numberp value) (>= value 0.0))) "either NIL or a non-negative number"
                      (setf *exp-gain-noise* (variance-to-s *exp-gain-noise*))))
          (:egs (sigp *exp-gain-noise* :egs (or (null value) (and 
(numberp value) (>= value 0.0))) "either NIL or a non-negative 
number"))
          (:ut (sigp *utility-threshold* :ut (or (null value) (numberp 
value)) "NIL or a number"))
          (:lf (sigp *latency-factor* :lf (and (numberp value) (>= 
value 0.0)) "a non-negative number"))
          (:le (sigp *latency-exponent* :le (and (numberp value) (>= 
value 0.0)) "a non-negative number"))
          (:blc (let ((old-blc *base-level-constant*))
                  (sigp *base-level-constant* :blc (numberp value) "a number"
                        (let ((base-level-inc (- value old-blc)))
                          (for-all-wmes wme
                                        (incf (wme-base-level wme) 
base-level-inc)
                                        (incf (wme-activation wme) 
base-level-inc))))))
          (:an (sigp *activation-noise* :an (or (null value) (and 
(numberp value) (>= value 0.0))) "either NIL or a non-negative number"
                     (progn
                       (setf *activation-noise* (variance-to-s 
*activation-noise*))
                       (for-all-wmes wme (decf (wme-time-stamp wme) 1.0)))))
          (:ans (sigp *activation-noise* :as (or (null value) (and 
(numberp value) (>= value 0.0))) "either NIL or a non-negative number"
                     (for-all-wmes wme (decf (wme-time-stamp wme) 1.0))))
          (:pan (sigp *permanent-activation-noise* :pan (or (null 
value) (and (numberp value) (>= value 0.0))) "either NIL or a 
non-negative number"
                      (progn
                        (setf *permanent-activation-noise*
                              (variance-to-s *permanent-activation-noise*))
                        (for-all-wmes wme
                                      (let ((noise (if value (noise 
value) 0.0)))
                                        (incf (wme-activation wme)
                                              (- noise 
(wme-permanent-noise wme)))
                                        (setf (wme-permanent-noise 
wme) noise))))))
          (:pas (sigp *permanent-activation-noise* :pas (or (null 
value) (and (numberp value) (>= value 0.0))) "either NIL or a 
non-negative number"
                      (for-all-wmes wme
                                    (let ((noise (if value (noise value) 0.0)))
                                      (incf (wme-activation wme)
                                            (- noise (wme-permanent-noise wme)))
                                      (setf (wme-permanent-noise wme) noise)))))
          (:mp (sigp *mismatch-penalty* :mp (and (numberp value) (>= 
value 0.0)) "a non-negative number"))
          (:ms (sigp *max-sim* :ms (numberp value) "a number"
                     (for-all-wmes wme (set-similarity wme wme *max-sim*))))
          (:md (sigp *max-dif* :md (numberp value) "a number"))
          (:tmp (sigp *temperature* :tmp (or (null value) (and 
(numberp value) (> value 0.0))) "NIL or a positive number"))
          (:bln (sigp *blending* :bln (or (null value) (eq value t) 
(eq value 'rt)) "NIL, T or RT"))
          ; FIX: switch representation when :era is activated.
          ; Make sure to not re-apply for a noop.
          ((:esc :era)
           (unless (eq *enable-rational-analysis* value)
             ;;; No guarantee of goal or ordering but use of special 
function for buffers:
             ;;; use nsublis for all of the lhs AND the rhs!!
             (sigp *enable-rational-analysis* :era (or (null value) 
(eq value t)) "T or NIL"
                   (if *enable-rational-analysis*
                     (let ((substs '((direct-test-and-bind . 
direct-test-and-bind-pm)
                                     (indirect-test-and-bind . 
indirect-test-and-bind-pm))))
                       (dolist (production *procedural-memory*)
                         (let* ((lhs (production-lhs (cdr production)))
                                (direct-length (first-retrieval-index 
lhs (production-initializations (cdr production)))))
                           (setf (production-lhs (cdr production))
                                 (cons (nconc (subseq lhs 0 
direct-length) (last lhs))
                                       (nconc (butlast (subseq lhs 
direct-length))
                                              (list 'not))))
                           (setf (production-lhs (cdr production))
                                 (nsublis substs (production-lhs (cdr 
production)) :test #'eq))
                           (setf (production-rhs (cdr production))
                                 (nsublis substs (production-rhs (cdr 
production)) :test #'eq))
                           ))
                       (update-activation-spread)
                       (unless *retrieval-threshold*
                         (setf *retrieval-threshold* 0.0)))
                     (let ((substs '((direct-test-and-bind-pm . 
direct-test-and-bind)
                                     (indirect-test-and-bind-pm . 
indirect-test-and-bind))))
                       (dolist (production *procedural-memory*)
                         (let ((lhs (production-lhs (cdr production))))
                           (setf (production-lhs (cdr production))
                                 (nconc (butlast (first lhs)) (butlast 
(rest lhs))
                                        (last (first lhs)))))
                           (setf (production-lhs (cdr production))
                                 (nsublis substs (production-lhs (cdr 
production)) :test #'eq))
                           (setf (production-rhs (cdr production))
                                 (nsublis substs (production-rhs (cdr 
production)) :test #'eq))
                         )
                       (setf *retrieval-threshold* nil))))))
          ; FIX: call sgp-fct recursively instead of setting :era directly
          (:rt (sigp *retrieval-threshold* :rt (or (null value) 
(numberp value)) "NIL or a number"
                     (if *retrieval-threshold*
                       (unless *enable-rational-analysis*
                         (sgp-fct '(:era t)))
                       (when *enable-rational-analysis*
                         (sgp-fct '(:era nil))))))
          ; FIX: now switch representation on :era rather than :pm
          (:pm (sigp *partial-matching* :pm (or (null value) (eq value 
t)) "T or NIL"))
          (:er (sigp *enable-randomness* :er (or (null value) (eq 
value t)) "T or NIL"))
          (:ol (sigp *optimized-learning* :ol (or (null value) (eq 
value t) (and (integerp value) (plusp value))) "T, NIL or a positive 
integer"
                     (for-all-wmes wme
                                   (adapt-references (wme-references wme)
                                                     (wme-creation-time wme))
                                   (decf (wme-time-stamp wme) 1.0))
                     (dolist (production *procedural-memory*)
                       (adapt-references (production-references (cdr 
production))
                                         (production-creation-time 
(cdr production)))
                       (decf (production-time-stamp (cdr production)) 1.0))))
          (:bll (let ((old-bll *base-level-learning*))
                  (sigp *base-level-learning* :bll (or (null value) 
(and (numberp value) (>= value 0.0))) "either NIL or a non-negative 
number"
                        (if (and old-bll (null value))
                          ;;; when turning bll off, update all base levels
                          (let ((*base-level-learning* old-bll))
                            (for-all-wmes wme 
(compute-base-level-activation wme)))
                          (for-all-wmes wme (decf (wme-time-stamp wme) 1.0))))))
          (:al (let ((old-al *associative-learning*))
                 (sigp *associative-learning* :al (or (null value) 
(and (numberp value) (>= value 0.0))) "either NIL or a non-negative 
number"
                       (when (and old-al (null value))
                         ;;; when turning al off, update all IAs
                         (let ((*associative-learning* old-al))
                           (for-all-wmes wme
                                         (dolist (wme-ia (wme-ias wme))
                                           (ia-value (cdr wme-ia) (car 
wme-ia) wme)))))
                       (incf *spread-stamp* 1))))
          (:sl (let ((old-sl *strength-learning*))
                 (sigp *strength-learning* :sl (or (null value) (and 
(numberp value) (>= value 0.0))) "either NIL or a non-negative number"
                       (when (and old-sl (null value))
                         ;;; when turning sl off, update all 
production strengths
                         (let ((*strength-learning* old-sl))
                           (dolist (production *procedural-memory*)
                             (strength (cdr production)))))
                       (dolist (production *procedural-memory*)
                         (decf (production-time-stamp (cdr production)) 1.0)))))
          (:pl (sigp *parameters-learning* :pl (or (null value) (eq 
value t) (numberp value)) "T, NIL or a NUMBER"
                     (when *parameters-learning*
                       (dolist (production *procedural-memory*)
                         (setf production (cdr production))
                         (adapt-references (production-successes 
production) (production-creation-time production)
                                           (not (numberp 
*parameters-learning*)))
                         (adapt-references (production-failures 
production) (production-creation-time production)
                                           (not (numberp 
*parameters-learning*)))
                         (when (numberp *parameters-learning*)
                           (let ((successes (round (first 
(production-successes production))))
                                 (efforts (first (production-efforts 
production))))
                             (setf (production-efforts production)
                                   (cons efforts (make-list successes 
:initial-element (/ efforts successes))))))
                         (recompute-production-parameters production)))))
          (:cp (sigp *cost-penalty* :cp (numberp value) "a number"))
          (:ie (sigp *initial-experience* :ie (and (numberp value) (>= 
value 0.0)) "a non-negative number"))
          (:tt (sigp *threshold-time* :tt (and (numberp value) (>= 
value 0.0)) "a non-negative number"))
          (:epl (sigp *enable-production-learning* :epl (or (null 
value) (eq value t)) "T or NIL"))
          (:ot (assign-stream *output-trace* value)
               (sigp *output-trace* :ot (or (null value) (eq value t) 
(streamp value)) "T, NIL or a valid PATHNAME"))
          (:ct (assign-stream *cycle-trace* value)
               (sigp *cycle-trace* :ct (or (null value) (eq value t) 
(streamp value)) "T, NIL or a valid PATHNAME"))
          (:lt (assign-stream *latency-trace* value)
               (sigp *latency-trace* :lt (or (null value) (eq value t) 
(streamp value)) "T, NIL or a valid PATHNAME"))
          (:pmt (assign-stream *partial-matching-trace* value)
                (sigp *partial-matching-trace* :pmt  (or (null value) 
(eq value t) (streamp value)) "T, NIL or a valid PATHNAME"))
          (:pct (assign-stream *production-compilation-trace* value)
               (sigp *production-compilation-trace* :at (or (null 
value) (eq value t) (streamp value)) "T, NIL or a valid PATHNAME"))
          (:act (assign-stream *activation-trace* value)
                (sigp *activation-trace* :act (or (null value) (eq 
value t) (streamp value)) "T, NIL or a valid PATHNAME"
                      (when *activation-trace*
                        (setf *enable-rational-analysis* t))))
          (:blt (assign-stream *blending-trace* value)
                (sigp *blending-trace* :blt  (or (null value) (eq 
value t) (streamp value)) "T, NIL or a valid PATHNAME"))
          (:crt (assign-stream *conflict-resolution-trace* value)
                (sigp *conflict-resolution-trace* :crt (or (null 
value) (eq value t) (streamp value)) "T, NIL or a valid PATHNAME"))
          (:cst (assign-stream *conflict-set-trace* value)
                (sigp *conflict-set-trace* :cst (or (null value) (eq 
value t) (streamp value)) "T, NIL or a valid PATHNAME"))
          (:gt (assign-stream *goal-trace* value)
               (sigp *goal-trace* :gt (or (null value) (eq value t) 
(streamp value)) "T, NIL or a valid PATHNAME"))
          (:dmt (assign-stream *dm-trace* value)
                (sigp *dm-trace* :dmt (or (null value) (eq value t) 
(streamp value)) "T, NIL or a valid PATHNAME"))
          (:pt (assign-stream *production-trace* value)
               (sigp *production-trace* :pt (or (null value) (eq value 
t) (eq value 'short) (streamp value))
                     "T, SHORT, NIL or a valid PATHNAME"))
          (:mt (assign-stream *matches-trace* value)
               (sigp *matches-trace* :mt (or (null value) (eq value t) 
(eq value 'short) (streamp value))
                     "T, SHORT, NIL or a valid PATHNAME"))
          (:emt (assign-stream *exact-matching-trace* value)
                (sigp *exact-matching-trace* :emt (or (null value) (eq 
value t) (streamp value)) "T, NIL or a valid PATHNAME"))
          (:v (sigp *verbose* :v (or (null value) (eq value t)) "T or NIL"))
          (t (signal-warn "NO GLOBAL PARAMETER ~A DEFINED" parameter)
             :error))
        values))))

(defun sgp-fct (&optional parameters)
   "Inspects and sets global parameters."
   (if (and (rest parameters)
            (not (keywordp (second parameters))))
     (set-global-parameters-fct parameters)
     (global-parameters-fct parameters)))

(defun pset-fct (sets)
   "Prints, defines and activates sets of parameters."
   (let ((*verbose* t)
         (*goal-depth* 1))
     (if (null sets)
       ;; if no argument is given, then displays the current sets
       (dolist (set *parameter-sets*)
         (signal-output *command-trace* "Parameter set ~S:" (first set))
         (dolist (parameter (rest set))
           (signal-output *command-trace* "~S" parameter))
         (signal-output *command-trace* ""))
       (if (listp sets) ; standard format through pset command
         (if (and (atom (first sets)) (null (rest sets)))
           ;; if a single name is given, then activate that set
           (let ((set (assoc (first sets) *parameter-sets* :test #'equal)))
             (if set
               (dolist (parameter (rest set))
                 (cond ((fboundp (first parameter))
                        (eval parameter))
                       ((get-production (first parameter))
                        ;; interpreted as parameters command by default
                        (parameters-fct (first parameter) (rest parameter)))
                       (t
                        (signal-warn "UNKNOWN PARAMETER COMMAND ~S IN SET ~S"
                                     parameter (first sets)))))
               (signal-warn "UNKNOWN PARAMETER SET ~S" (first sets))))
           ; if a list or lists are given, then create the new set(s)
           (dolist (set (if (atom (first sets)) (list sets) sets))
             (let ((old-set (assoc (first set) *parameter-sets* :test #'equal)))
               (cond (old-set
                      (signal-warn "REDEFINING PARAMETER SET ~S" (first set))
                      (rplacd old-set (rest set)))
                     (t
                      (push-last set *parameter-sets*))))))
         (signal-warn "UNKNOWN ARGUMENT FORMAT ~S FOR PSET COMMAND" sets)))))

(defun set-g-fct (g &key threshold)
   "Sets G and perhaps its threshold.  Provided for compatibility 
only.  Use sgp."
   (sgp-fct (list :g g))
   (when threshold (sgp-fct (list :gth threshold))))

(defun output-stream-fct (file &key echo)
   "Switches output trace to file."
   (if (or (stringp file) (pathnamep file))
     (let ((stream (open file :direction :output
                         :if-exists :append :if-does-not-exist :create)))
       (when echo
         (setf stream (make-broadcast-stream stream *standard-output*)))
       (sgp-fct (list :ot stream))
       stream)
     (signal-warn "ARGUMENT ~S TO OUTPUT-STREAM SHOULD BE A VALID FILENAME."
                  file)))

(defun close-output-fct ()
   "Closes the output trace stream."
   (sgp-fct (list :ot t)))

(defun trace-stream-fct (file &key echo)
   "Switches all trace outputs to file."
   (if (or (stringp file) (pathnamep file))
     (let ((stream (open file :direction :output
                         :if-exists :append :if-does-not-exist :create)))
       (when echo
         (setf stream (make-broadcast-stream stream *standard-output*)))
       (sgp-fct (list :ct (and *cycle-trace* stream)
                      :lt (and *latency-trace* stream)
                      :pmt (and *partial-matching-trace* stream)
                      :pct (and *production-compilation-trace* stream)
                      :act (and *activation-trace* stream)
                      :blt (and *blending-trace* stream)
                      :crt (and *conflict-resolution-trace* stream)
                      :cst (and *conflict-set-trace* stream)
                      :gt (and *goal-trace* stream)
                      :dmt (and *dm-trace* stream)
                      :pt (and *production-trace* stream)
                      :mt (and *matches-trace* stream)
                      :emt (and *exact-matching-trace* stream)))
       stream)
     (signal-warn "ARGUMENT ~S TO TRACE-STREAM SHOULD BE A VALID FILENAME."
                  file)))

(defun close-trace-fct ()
   "Closes the trace stream."
   (let ((stream t))
     (sgp-fct (list :ct (and *cycle-trace* stream)
                    :lt (and *latency-trace* stream)
                    :pmt (and *partial-matching-trace* stream)
                    :pct (and *production-compilation-trace* stream)
                    :act (and *activation-trace* stream)
                    :blt (and *blending-trace* stream)
                    :crt (and *conflict-resolution-trace* stream)
                    :cst (and *conflict-set-trace* stream)
                    :gt (and *goal-trace* stream)
                    :dmt (and *dm-trace* stream)
                    :pt (and *production-trace* stream)
                    :mt (and *matches-trace* stream)
                    :emt (and *exact-matching-trace* stream)))))

(defun construct-pathname (file directory)
   "Constructs a complete pathname from file and directory."
   (make-pathname :host (pathname-host directory)
                  :device (pathname-device directory)
                  :directory (pathname-directory directory)
                  :name (pathname-name file)
                  :type (pathname-type file)))

(defun load-model-list (file &optional (save nil))
   (with-open-file (model file)
     (loop
       (let ((expr (read model nil :end)))
         (when (eq expr :end) (return))
         (when (and (not save) (listp expr)
                    (member (first expr)
                            '(clearall clearall-fct
                              clear-all clear-all-fct)))
           (setf save t))
         (when save
           (cond ((eq (first expr) 'load)
                  (load-model-list (second expr) t))
                 ((eq (first expr) 'load-model)
                  (load-model-list
                   (construct-pathname (second expr)
                                       (or (third expr) file))
                   t))
                 (t
                  (push-last expr *model*))))))))

(defun seed (&optional (seed t))
   "Randomized the random number generator by running it seed times."
   (when (eq seed t)
     (setf seed (decode-universal-time (get-universal-time))))
   (cond ((integerp seed)
          (dotimes (i seed)
            (random 1.0)))
         ((random-state-p seed)
          (setf *random-state* (make-random-state seed)))
         (seed
          (signal-warn "UNKNOWN ARGUMENT ~S TO SEED FUNCTION." seed))
         (t)))

(seed)

(defun reset-fct (&optional (seed t))
   "Resets the current model by reevaluating all the commands."
   (cond ((rest *model*)
          (seed seed)
          (dolist (command (rest *model*))
            (eval command)))
         (t
          (reload-fct seed))))

(defun load-model-fct (file &optional (directory *load-pathname*))
   "Loads model file at directory, which defaults to the local folder.
    Sets *load-pathname* for those Lisps where it is not done."
   (let ((*load-pathname* (construct-pathname file directory)))
     (when (load *load-pathname* :verbose *verbose*)
       *load-pathname*)))

(defun reload-fct (&optional (seed t))
   "Updates the current model by reloading the file."
   (cond ((first *model*)
          (seed seed)
          (load (first *model*) :verbose *verbose*))
         (t
          (signal-warn "NO MODEL STORED.  LOAD THE MODEL FILE BEFORE 
USING RESET OR RELOAD.~%~
                        DO NOT LOAD MODEL BY EVALUATING THE BUFFER."))))

(defun import-model-fct (file)
   "Compresses a bunch of environment files into file, which has to be a string
    of the form <directory>:<file> where <directory> is where the 
files are located
    and <file> is their name minus the extensions (Chunk Types, 
Chunks, Productions)."
   (let ((directory (directory-namestring file))
         (name (file-namestring file))
         (lines nil))
     (with-open-file (common file :direction :output :if-exists :supersede
                             :if-does-not-exist :create)
       ; first the code
       (with-open-file (misc (make-pathname :directory directory
                                            :name (concatenate 
'string name " Misc"))
                             :direction :input :if-does-not-exist nil)
         (when misc
           (let ((code nil))
             (loop
               (let ((line (read-line misc nil :end)))
                 (cond ((eq line :end) (return))
                       ((equal line "") (setf code nil))
                       ((equal (subseq line 0 4) "(def") (setf code t)))
                 (if code
                   (format common "~A~%" line)
                   (push-last line lines)))))))
       (format common "~%(clear-all)~2%")
       (clear-all-fct)
       (with-open-file (global (make-pathname :directory directory
                                              :name "Global-Parameters")
                               :direction :input :if-does-not-exist nil)
         (when global
           (let ((keyword-values nil))
             (loop
               (let ((exp (read global nil :end)))
                 (cond ((eq exp :end)
                        (return))
                       ((and (listp exp) (eq (first exp) 'sgp))
                        (pop exp)
                        (loop
                          (unless exp (return))
                          (let ((keyword (pop exp))
                                (value (pop exp)))
                            (unless (equal value
                                           (let ((*command-trace* nil))
                                             (first (sgp-fct (list keyword)))))
                              (push value keyword-values)
                              (push keyword keyword-values)))))
                       (t
                        (signal-warn "UNKNOWN COMMAND ~S IN 
GLOBAL-PARAMETERS FILE"
                                     exp)))))
             (when keyword-values
               (format common "(sgp~{ ~(~S~)~})~2%" keyword-values)))))
         (dolist (extension '("Chunk Types" "Chunks" "Productions"))
           (with-open-file (part (make-pathname :directory directory
                                                :name (concatenate 
'string name " "
                                                                   extension))
                                 :direction :input :if-does-not-exist nil)
             (when part
               (loop
                 (let ((line (read-line part nil :end)))
                   (if (eq line :end)
                     (return)
                     (format common "~A~%" line))))
               (terpri common))))
         (dolist (line lines)
           (format common "~A~%" line)))))

(clear-all-fct nil)

(defun pundo-fct (&optional arg)
   "Undoes production firings.  If arg is nil, toggles the Save State 
Change mode.
    If arg is a number, undoes that number of production firings.  If arg is t,
    undo all production firings saved."
   (cond
    ((null arg)
     (setf *save-state-changes* (if *save-state-changes* nil (list :on))))
    ((or (integerp arg) (eq arg t))
     (let* ((cycles (if (eq arg t) -1 arg))
            (command nil)
            (keyword nil)
            (state-changes *save-state-changes*))
       (setf *save-state-changes* nil)
       (if state-changes
         (loop
           (when (or (zerop cycles) (eq (first state-changes) :on))
             (return arg))
           (decf cycles 1.0)
           (loop
             (setf command (pop state-changes))
             (setf keyword (pop command))
             (case keyword
               (:create-wme
                (delete-wme (first command)))
               (:set-slot-value
                (set-slot-value (first command) (second command) 
(third command)))
               (:delete-wme
                (let ((wme (first command)))
                  (incf *wme-number* 1)
                  (setf (get-wme (wme-name wme)) wme)
                  (push-last wme (wme-type-wmes (wme-type wme)))))
               (:delete-production
                (let ((production (first command)))
                  (push-last (cons (production-name production) production)
                             *procedural-memory*)
                  (push-last production (wme-type-productions
                                         (production-goal-type production)))))
               (:add-reference
                (let ((references (first command)))
                  (decf (first references) 1.0)
                  (pop (rest references))))
               (:compile-production
                (delete-production (first command)))
               (:penable-fct
                (pdisable-fct (first command)))
               (:pdisable-fct
                (penable-fct (first command)))
               (:focus-on
                (let ((frame (first command)))
                  (focus-macro (goal-frame-focus frame)
                               (goal-frame-return-values frame))))
               (:pop-goal
                (let ((frame (first command)))
                  (push-macro (goal-frame-focus frame) 
(goal-frame-return-values frame))))
               (:push-goal
                (pop-macro))
               (:run
                (when *enable-rational-analysis* (update-activation-spread))
                (setf *time* (first command))
                (setf *cycle* (second command))
                (setf *spread-stamp* (third command))
                (setf *random-state* (make-random-state (fourth command)))
                (return))
               (otherwise
                (signal-error "UNKNOWN PUNDO OPERATION ~S" keyword)))))
         (signal-warn "UNDOING MUST FIRST BE TURNED ON WITH (PUNDO)."))
       (setf *save-state-changes* state-changes))
     (for-all-wmes wme
                   (setf (wme-time-stamp wme) (- *time* 1.0))
                   (setf (wme-spread-stamp wme) (- *spread-stamp* 1)))
     (dolist (production *procedural-memory*)
       (setf (production-time-stamp (cdr production)) (- *time* 1.0)))
     *cycle*)
    (t
     (signal-warn "UNKNOWN ARGUMENT TO PUNDO: ~S" arg))))

(defun help-fct (&optional (commands nil))
   "Outputs a short description of a list of ACT-R commands,
    or the full list of commands if none is supplied."
   (let ((*verbose* t)
         (*goal-depth* 1))
     (if commands
       (dolist (command commands)
         (signal-output *command-trace* "~A" command)
         (signal-output *command-trace* "~A"
                        (documentation command 'function)))
       (dolist (command-pair *command-mappings*)
         (signal-output *command-trace* "~A"
                        (first command-pair))))))

;;;
;;; USER-LEVEL MACROS
;;;

(defmacro clear-all (&optional (save-model t))
   "Clears the whole system."
   `(clear-all-fct ',save-model))

(defmacro clear-dm ()
   "Clears working memory elements."
   `(clear-dm-fct))

(defmacro clear-productions ()
   "Clears all productions."
   `(clear-productions-fct))

(defmacro actr-time (&optional inc)
   "Returns the current act-r time, or adds inc to it if specified."
   `(actr-time-fct ',inc))

(defmacro chunk-type (&rest arguments)
   "The user-level command to define a new wme type."
   `(chunk-type-fct ',arguments))

(defmacro new-name (&optional (name "CHUNK"))
   "Returns a unique symbol as generated by gentemp based on name,
    which can be either a string, a symbol, or else defaults to CHUNK."
   `(new-name-fct ',name))

(defmacro add-dm (&rest wmes)
   "Adds the following wmes to working memory."
   `(add-dm-fct ',wmes))

(defmacro set-dm (&rest wmes)
   "Adds the following wmes to working memory."
   `(set-dm-fct ',wmes))

(defmacro copy-chunk (&rest wmes)
   "Makes copies of the wmes."
   `(copy-chunk-fct ',wmes))

(defmacro delete-chunk (&rest wmes)
   "Deletes the following wmes from working memory."
   `(delete-chunk-fct ',wmes))

(defmacro get-base-level (&rest wmes)
   "Returns the base level of wme."
   `(get-base-level-fct ',wmes))

(defmacro set-all-base-levels (references &optional (creation-time nil))
   "Sets all base level activations."
   `(set-all-base-levels-fct ',references ',creation-time))

(defmacro set-base-levels (&rest settings)
   "Sets base level activations."
   `(set-base-levels-fct ',settings))

(defmacro set-general-base-levels (&rest settings)
   "Sets base level activations.  Same as set-base-levels."
   `(set-general-base-levels-fct ',settings))

(defmacro add-ia (&rest settings)
   "Sets individual ias."
   `(add-ia-fct ',settings))

(defmacro set-ia (&rest settings)
   "Sets individual ias."
   `(set-ia-fct ',settings))

(defmacro activation-sources ()
   "Displays activation sources."
   `(activation-sources-fct))

(defmacro update-activation ()
   "Updates the activation of all wmes by recomputing it."
   `(update-activation-fct))

(defmacro chunk-slot-value (wme slot)
   "Returns the slot value of wme."
   `(chunk-slot-value-fct ',wme ',slot))

(defmacro mod-chunk (wme &rest slot-values)
   "Sets slots of wme to values."
   `(mod-chunk-fct ',wme ',slot-values))

(defmacro mod-focus (&rest slot-values)
   "Sets slots of wm focus to values."
   `(mod-focus-fct ',slot-values))

(defmacro get-name (&rest wmes-or-productions)
   "Returns the names of a list of wmes or productions."
   `(get-name-fct ',wmes-or-productions))

(defmacro dm (&rest wmes)
   "Prints the following wmes.  If none specified, print them all."
   `(dm-fct ',wmes))

(defmacro sdm (&rest slot-values)
   "Prints wmes which have values in slots."
   `(sdm-fct ',slot-values))

(defmacro pmatches ()
   "Generates and prints the instantiations which match the current wm state."
   `(pmatches-fct))

(defmacro whynot (&rest productions)
   "Tries to match production(s) with exact matching trace on."
   `(whynot-fct ',productions))

(defmacro whynot-dependency (&rest wmes)
   "Tries analogy with wme(s) as examples."
   `(whynot-dependency-fct ',wmes))

(defmacro reset-ia ()
   "Resets all the ia values, preserving user-specified and learned values."
   `(reset-ia-fct))

(defmacro ia (wmej wmei)
   "Returns the ia value between wmej and wmei, in that order."
   `(ia-fct ',wmej ',wmei))

(defmacro similarity (wmej wmei)
   "Returns the similarity between wmej and wmei, in that order."
   `(similarity-fct ',wmej ',wmei))

(defmacro set-similarities (&rest triples)
   "Sets the similarities, i.e a list of triplets containg wmej wmei and value."
   `(set-similarities-fct ',triples))

(defmacro sdp (&rest wme-parameters)
   "Inspects and sets wme parameters."
   `(sdp-fct ',wme-parameters))

(defmacro p (&rest definition)
   "Production definition."
   `(p-fct ',definition))

(defmacro penable (&rest productions)
   "Enables disabled productions."
   `(penable-fct ',productions))

(defmacro pdisable (&rest productions)
   "Disables productions."
   `(pdisable-fct ',productions))

(defmacro pbreak (&rest productions)
   "Sets break points for productions."
   `(pbreak-fct ',productions))

(defmacro punbreak (&rest productions)
   "Removes break points for productions."
   `(punbreak-fct ',productions))

(defmacro pp (&rest productions)
   "Prints the following productions.  If none specified, print all 
active ones."
   `(pp-fct ',productions))

(defmacro production-parameter (production &rest parameters)
   "Returns value of production parameters, or print them all if none 
is specified."
   `(production-parameter-fct ',production ',parameters))

(defmacro parameters (production &rest parameters)
   "Sets a production parameters using keyword arguments."
   `(parameters-fct ',production ',parameters))

(defmacro set-compilation-parameters (&rest params)
   "Sets the parameters for analogized productions"
   `(set-compilation-parameters-fct ',params))

(defmacro spp (&rest production-parameters)
   "Inspects and sets production parameters."
   `(spp-fct ',production-parameters))

(defmacro pset (&rest sets)
   "Prints, defines and activates sets of parameters."
   `(pset-fct ',sets))

(defmacro set-g (g &key threshold)
   "Sets G and perhaps its threshold.  Provided for compatibility 
only.  Use sgp."
   `(set-g-fct ',g :threshold ',threshold))

(defmacro output-stream (file &key echo)
   "Switches output trace to file."
   `(output-stream-fct ',file :echo ',echo))

(defmacro close-output ()
   "Closes the output trace stream."
   `(close-output-fct))

(defmacro trace-stream (file &key echo)
   "Switches all trace outputs to file."
   `(trace-stream-fct ',file :echo ',echo))

(defmacro close-trace ()
   "Closes the trace stream."
   `(close-trace-fct))

(defmacro rehearse-chunk (&rest chunks)
   "Rehearses chunks.  If a chunk is a list, then the first element of the list
    is the chunk to rehearse and the rest is the list of sources."
   `(rehearse-chunk-fct ',chunks))

(defmacro buffers (&rest buffers)
   "Displays and sets the contents of buffers."
   `(buffers-fct ',buffers))

(defmacro retrieval (&optional (chunk nil))
   "Displays or changes (if argument is supplied) the value of
    the last chunk retrieved."
   `(retrieval-fct ',chunk))

(defmacro goal-focus (&rest wmes)
   "Sets the focus to wme or wmes, or prints the current one if none specified."
   `(goal-focus-fct ',wmes))

(defmacro goal-stack ()
   "Prints the current list of goals on the goal stack."
   `(goal-stack-fct))

(defmacro push-goal (wme)
   "Pushes wme on top of the stack."
   `(push-goal-fct ',wme))

(defmacro pop-goal ()
   "Pops the top goal."
   `(pop-goal-fct))

(defmacro focus-on-goal (wme)
   "Pops the top goal then focuses on wme."
   `(focus-on-goal-fct ',wme))

(defmacro clear-goal-stack ()
   "Clears the goal stack by restoring the top goal."
   `(clear-goal-stack-fct))

(defmacro run (&optional (cycles -1))
   "Runs for a specified number of cycles (if integer) or time (if real)
    or forever if no value specified."
   `(run-fct ',cycles))

(defmacro pstep (&optional (cycles -1))
   "Runs for a specified number of cycles (if integer) or time (if real)
    or forever if no value specified.  At each cycle, displays the 
instantiations
    with matches trace, then allow the user to decide what to do next."
   `(pstep-fct ',cycles))

(defmacro run-many (&optional (n 1))
   "Runs the whole wmfocus list n times."
   `(run-many-fct ',n))

(defmacro pundo (&optional arg)
   "Undoes production firings."
   `(pundo-fct ',arg))

(defmacro reset (&optional (seed t))
   "Resets the model by reevaluating it as stored in *model*.
    Seed can be provided to control reinitialization of random number 
generator."
   `(reset-fct ',seed))

(defmacro load-model (file &optional (directory *load-pathname*))
   "Loads model file in directory (local by default)."
   `(load-model-fct ',file ',directory))

(defmacro reload (&optional (seed t))
   "Reloads the model by reloading the *model* file.
    Seed can be provided to control reinitialization of random number 
generator."
   `(reload-fct ',seed))

(defmacro import-model (file)
   "Compresses a bunch of environment files into file, which has to be a string
    of the form <directory>:<file> where <directory> is where the 
files are located
    and <file> is their name minus the extensions (WMETypes, Productions, etc)."
   `(import-model-fct ',file))

(defmacro help (&rest commands)
   "Outputs a short description of one or more ACT-R command(s),
    or the full list of commands if none is supplied."
   `(help-fct ',commands))

;;;
;;; OLD USER-LEVEL MACROS AND FCT FOR COMPATIBILITY PURPOSES ONLY
;;;

(defmacro clearall (&optional (save-model t))
   "See CLEAR-ALL."
   `(clear-all-fct ',save-model))

(defun clearall-fct (&optional (save-model t))
   "See CLEAR-ALL-FCT."
   (clear-all-fct save-model))

(defmacro clearwm ()
   "See CLEAR-DM."
   `(clear-dm-fct))

(defun clearwm-fct ()
   "See CLEAR-DM-FCT."
   (clear-dm-fct))

(defmacro clearproductions ()
   "See CLEAR-PRODUCTIONS."
   `(clear-productions-fct))

(defun clearproductions-fct ()
   "See CLEAR-PRODUCTIONS-FCT."
   (clear-productions-fct))

(defmacro actrtime (&optional inc)
   "See ACTR-TIME."
   `(actr-time-fct ',inc))

(defun actrtime-fct (&optional inc)
   "See ACTR-TIME-FCT."
   (actr-time-fct inc))

(defmacro wmetype (&rest arguments)
   "See CHUNK-TYPE."
   `(chunk-type-fct ',arguments))

(defun wmetype-fct (arguments)
   "See CHUNK-TYPE-FCT."
   (chunk-type-fct arguments))

(defmacro addwm (&rest wmes)
   "See ADD-DM."
   `(add-dm-fct ',wmes))

(defun addwm-fct (wmes &key (reset-ia t))
   "See ADD-DM-FCT."
   (add-dm-fct wmes :reset-ia reset-ia))

(defmacro setwm (&rest wmes)
   "See SET-DM."
   `(set-dm-fct ',wmes))

(defun setwm-fct (wmes)
   "See SET-DM-FCT."
   (set-dm-fct wmes))

(defmacro copywme (&rest wmes)
   "See COPY-CHUNK."
   `(copy-chunk-fct ',wmes))

(defun copywme-fct (wmes)
   "See COPY-CHUNK-FCT."
   (copy-chunk-fct wmes))

(defmacro deletewm (&rest wmes)
   "See DELETE-CHUNK."
   `(delete-chunk-fct ',wmes))

(defun deletewm-fct (wmes)
   "See DELETE-CHUNK-FCT."
   (delete-chunk-fct wmes))

(defmacro getbaselevel (&rest wmes)
   "See GET-BASE-LEVEL."
   `(get-base-level-fct ',wmes))

(defun getbaselevel-fct (wmes)
   "See GET-BASE-LEVEL-FCT."
   (get-base-level-fct wmes))

(defmacro setallbaselevels (references &optional (creation-time nil))
   "See SET-ALL-BASE-LEVELS."
   `(set-all-base-levels-fct ',references ',creation-time))

(defun setallbaselevels-fct (references &optional (creation-time nil))
   "See SET-ALL-BASE-LEVELS-FCT."
   (set-all-base-levels-fct references creation-time))

(defmacro setbaselevels (&rest settings)
   "See SET-BASE-LEVELS."
   `(set-base-levels-fct ',settings))

(defun setbaselevels-fct (settings)
   "See SET-BASE-LEVELS-FCT."
   (set-base-levels-fct settings))

(defmacro setgeneralbaselevels (&rest settings)
   "See SET-GENERAL-BASE-LEVELS."
   `(set-general-base-levels-fct ',settings))

(defun setgeneralbaselevels-fct (settings)
   "See SET-GENERAL-BASE-LEVELS-FCT."
   (set-general-base-levels-fct settings))

(defmacro addia (&rest settings)
   "See ADD-IA."
   `(add-ia-fct ',settings))

(defun addia-fct (settings)
   "See ADD-IA-FCT."
   (add-ia-fct settings))

(defmacro setia (&rest settings)
   "See SET-IA."
   `(set-ia-fct ',settings))

(defun setia-fct (settings)
   "See SET-IA-FCT."
   (set-ia-fct settings))

(defmacro activationsources ()
   "See ACTIVATION-SOURCES."
   `(activation-sources-fct))

(defun activationsources-fct ()
   "See ACTIVATION-SOURCES-FCT."
   (activation-sources-fct))

(defmacro wmeslotvalue (wme slot)
   "See CHUNK-SLOT-VALUE."
   `(chunk-slot-value-fct ',wme ',slot))

(defun wmeslotvalue-fct (wme slot)
   "See CHUNK-SLOT-VALUE-FCT."
   (chunk-slot-value-fct wme slot))

(defmacro modwme (wme &rest slot-values)
   "See MOD-CHUNK."
   `(mod-chunk-fct ',wme ',slot-values))

(defun modwme-fct (wme slot-values)
   "See MOD-CHUNK-FCT."
   (mod-chunk-fct wme slot-values))

(defmacro modfocus (&rest slot-values)
   "See MOD-FOCUS."
   `(mod-focus-fct ',slot-values))

(defun modfocus-fct (slot-values)
   "See MOD-FOCUS-FCT."
   (mod-focus-fct slot-values))

(defmacro wm (&rest wmes)
   "See DM."
   `(dm-fct ',wmes))

(defun wm-fct (wmes)
   "See DM-FCT."
   (dm-fct wmes))

(defmacro swm (&rest slot-values)
   "See SDM."
   `(sdm-fct ',slot-values))

(defun swm-fct (slot-values)
   "See SDM-FCT."
   (sdm-fct slot-values))

(defmacro resetia ()
   "See RESET-IA."
   `(reset-ia-fct))

(defun resetia-fct ()
   "See RESET-IA-FCT."
   (reset-ia-fct))

(defmacro setsimilarities (&rest triples)
   "See SET-SIMILARITIES."
   `(set-similarities-fct ',triples))

(defun setsimilarities-fct (triples)
   "See SET-SIMILARITIES-FCT."
   (set-similarities-fct triples))

(defmacro swp (&rest wme-parameters)
   "See SDP."
   `(sdp-fct ',wme-parameters))

(defun swp-fct (wme-parameters)
   "See SDP-FCT."
   (sdp-fct wme-parameters))

(defmacro setanalogizedparameters (&rest params)
   "See SET-ANALOGIZED-PARAMETERS."
   `(set-analogized-parameters-fct ',params))

(defmacro setg (g &key threshold)
   "See SET-G."
   `(set-g-fct ',g :threshold ',threshold))

(defun setg-fct (g &key threshold)
   "See SET-G-FCT."
   (set-g-fct g :threshold threshold))

(defmacro outputstream (file &key echo)
   "See OUTPUT-STREAM."
   `(output-stream-fct ',file :echo ',echo))

(defun outputstream-fct (file &key echo)
   "See OUTPUT-STREAM-FCT."
   (output-stream-fct file :echo echo))

(defmacro closeoutput ()
   "See CLOSE-OUTPUT."
   `(closeoutput-fct))

(defun closeoutput-fct ()
   "See CLOSE-OUTPUT-FCT."
   (close-output-fct))

(defmacro tracestream (file &key echo)
   "See TRACE-STREAM."
   `(trace-stream-fct ',file :echo ',echo))

(defun tracestream-fct (file &key echo)
   "See TRACE-STREAM-FCT."
   (trace-stream-fct file :echo echo))

(defmacro closetrace ()
   "See CLOSE-TRACE."
   `(close-trace-fct))

(defun closetrace-fct ()
   "See CLOSE-TRACE-FCT."
   (close-trace-fct))

(defmacro wmfocus (&rest wmes)
   "See GOAL-FOCUS."
   `(goal-focus-fct ',wmes))

(defun wmfocus-fct (&optional (wmes nil))
   "See GOAL-FOCUS-FCT."
   (goal-focus-fct wmes))

(defmacro goalstack ()
   "See GOAL-STACK."
   `(goal-stack-fct))

(defun goalstack-fct ()
   "See GOAL-STACK-FCT."
   (goal-stack-fct))

(defmacro push-wme (wme)
   "See PUSH-GOAL."
   `(push-goal-fct ',wme))

(defun push-wme-fct (wme)
   "See PUSH-GOAL-FCT."
   (push-goal-fct wme))

(defmacro pop-wme ()
   "See POP-GOAL."
   `(pop-goal-fct))

(defun pop-wme-fct ()
   "See POP-GOAL-FCT."
   (pop-goal-fct))

(defmacro focus-on-wme (wme)
   "See FOCUS-ON-GOAL."
   `(focus-on-goal-fct ',wme))

(defun focus-on-wme-fct (wme)
   "See FOCUS-ON-GOAL-FCT."
   (focus-on-goal-fct wme))

(defmacro cleargoalstack ()
   "See CLEAR-GOAL-STACK."
   `(clear-goal-stack-fct))

(defun cleargoalstack-fct ()
   "See CLEAR-GOAL-STACK-FCT."
   (clear-goal-stack-fct))

(defmacro whynot-analogy (&rest wmes)
   "Tries analogy with wme(s) as examples."
   `(whynot-dependency-fct ',wmes))

(defmacro set-analogized-parameters (&rest params)
   "Sets the parameters for analogized productions"
   `(set-compilation-parameters-fct ',params))



;;;  -*- mode: LISP; Package: CL-USER; Syntax: COMMON-LISP;  Base: 10 -*-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Author      : Mike Byrne
;;; Copyright   : (c)2001 Rice U./Mike Byrne, All Rights Reserved
;;; Availability: public domain
;;; Address     : Rice University
;;;             : Psychology Department
;;;             : Houston,TX 77251-1892
;;;             : byrne@acm.org
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Filename    : cognition-module.lisp
;;; Version     : 2.1b4
;;;
;;; Description : Class for wrapping around ACT-R to make cognition a
;;;             : proper object for the scheduler
;;;
;;; Bugs        :
;;;
;;; Todo        : [] :AFTER methods to handle buffer stuffing
;;;
;;; ----- History -----
;;; 01.07.25 Mike Byrne
;;;             :  Incept date.
;;; 01.08.07 mdb
;;;             : Added UPDATE-MODULE and UPDATE-DM-STATE dummy methods.
;;; 01.11.28 mdb/Dan Bothell [b4]
;;;             : Changed EXECUTE-RHS and COMPLETE-RETRIEVAL to deal with
;;;             : time issues.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;



(defclass cognition-module (pm-module)
   ((ps-state :accessor ps-state :initarg :ps-state :initform :idle)
    (last-retrieval-request :accessor last-retrieval-request
                            :initarg :last-retrieval-request :initform nil)
    (min-run-time :accessor min-run-time :initarg :min-run-time
                  :initform 0.050)
    )
   (:default-initargs
     :name :COGNITION
     ))


;;;; 
---------------------------------------------------------------------- 
;;;;
;;;; hadling standard RPM calls

(defmethod reset-module :after ((cog-mod cognition-module))
   (setf (ps-state cog-mod) :IDLE)
   (setf (last-retrieval-request cog-mod) nil))


;;; RUN-MODULE      [Method]
;;; Date        : 01.07.27
;;; Description : Has a slightly different RUN-MODULE method here because we
;;;             : don't want trace output (this is handled by ACT-R 5) and
;;;             : don't need to modify state.

(defmethod run-module ((module cognition-module) the-time)
   (setf (state-change module) nil)
   (while (and (input-q module)
               (>= (ms-round the-time)
                   (ms-round (time-tag (first (input-q module))))))
     (let* ((input-entry (pop (input-q module)))
            (the-cmd (first (params input-entry))))
       (apply the-cmd (append (list module) (rest (params input-entry)))))))


(defmethod update-module ((cog-mod cognition-module))
   nil)


(defmethod update-dm-state ((cog-mod cognition-module))
   nil)

(defmethod print-module-state ((cog-mod cognition-module))
   (format t "~& ACT-R's state is ~A" (ps-state cog-mod)))


;;;; 
---------------------------------------------------------------------- 
;;;;
;;;; Module messages for interacting with ACT-R

(defgeneric select-production (cog-mod &optional max-time)
   (:documentation "Request that the production system select a 
production, given a maximum time constraint."))


;;; SELECT-PRODUCTION      [Method]
;;; Description : A number of things have to be done here.  It's necessary to
;;;             : first check the goal stack, then actually call ACT-R5's
;;;             : MATCHING-CYCLE function, then deal with that result and
;;;             : either schedule the completion of the cycle or note the
;;;             : failure.

(defmethod select-production ((cog-mod cognition-module)
                                  &optional max-time)
   (if (null (first (no-output (goal-stack-fct))))
     (setf (ps-state cog-mod) :NO-GOAL)
     (let* ((rt *retrieval-threshold*)
            (ut *utility-threshold*)
            (action-latency (matching-cycle max-time))
            )
       (setf *retrieval-threshold* rt)
       (setf *utility-threshold* ut)

       (if action-latency
         (progn
           (setf (ps-state cog-mod) :PENDING-EXECUTION)
	  ;; what about time randomization?
           (queue-command :time action-latency
                          :where :COGNITION
                          :command 'execute-rhs
                          :params (list action-latency)
                          :randomize nil
                          ))
         (setf (ps-state cog-mod) :FAILED-SELECTION)))))


;;; EXECUTE-RHS      [Method]
;;; Date        : 01.07.27
;;; Description : Calls the ACT-R5 function ACTION-CYCLE, idles the CP [which
;;;             : will cause a new SELECT-PRODUCTION to be scheduled by the
;;;             : Master Process], and then it's necessary to deal with the
;;;             : retrieval, if any.

(defmethod execute-rhs ((cog-mod cognition-module) (latency number))
   (setf *time* (- *time* latency)) ;; back up in time because action-cycle is
   ;; going to increment *time* and I can't just
   ;; pass 0 because it needs that latency for
   ;; parameter learning purposes...
   (action-cycle latency)
   (setf (ps-state cog-mod) :IDLE)
   (when (and *retrieval-scheduler*
              (not (equal *retrieval-scheduler*
                          (last-retrieval-request cog-mod))))
     (setf (last-retrieval-request cog-mod) (copy-tree *retrieval-scheduler*))
     ;; have to subtract because the first of *retrieval-schuduler* is the
     ;; absolute time of the retrieval completion
     (queue-command :time (- (first *retrieval-scheduler*) (mp-time *mp*))
                    :where :COGNITION
                    :command 'complete-retrieval
                    :params (list (first *retrieval-scheduler*))
                    :randomize nil)))



;;; don't really need the time parameter--the MP knows what time it is.
(defmethod complete-retrieval ((cog-mod cognition-module) (time number))
   (when *retrieval-scheduler*
     (retrieval-event time)))





;;;  -*- mode: LISP; Package: CL-USER; Syntax: COMMON-LISP;  Base: 10 -*-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Author      : Mike Byrne & Dan Bothell
;;; Copyright   : (c)1999-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    : device-interface.lisp
;;; Version     : 2.1b4
;;;
;;; Description : File for managing the device interface.
;;;
;;; Bugs        : None known.
;;;
;;; Todo        : Nothing pending.
;;;
;;; ----- History -----
;;; 01.09.21 mdb [b2]
;;;             : Changed PROCESS-DISPLAY and UPDATE-CURSOR-FEAT to generate
;;;             : fewer gentemps.  Probably faster, too.
;;; 01.11.11 mdb [b3]
;;;             : Added TRACE-MOUSE-P and MOUSE-TRACE slots.
;;;
;;; 02.01.15 Dan [b4]
;;;             : Changed the feature test for ACL in the setting
;;;             : of the pixels-per-inch veriables so that it works
;;;             : in other than ACL 5.0.1.
;;;             : I don't think those values even matter however because
;;;             : when pm-reset gets called the device interface
;;;             : pixels-per-inch gets set to the value of the
;;;             : corresponding parameter which defaults to 72, and
;;;             : not the current "real" values as defined by the
;;;             : system's resolution.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; unless it's MCL define the pixels-per-inch
#-:mcl
(progn
   (defvar *pixels-per-inch-x* 72)
   (defvar *pixels-per-inch-y* 72))


;;; if it's ACL with the IDE (Windows) then find the true units-per-inch
#+:ALLEGRO-IDE
(multiple-value-bind (x y)
                      (stream-units-per-inch  (screen *system*))
   (setf *pixels-per-inch-x* x)
   (setf *pixels-per-inch-y* y))

;;;; 
---------------------------------------------------------------------- 
;;;;
;;; roll in everything that was in "environment-interface"

(defvar *actr-enabled-p* t)

(defun pm-get-time ()
   "If ACT is in control, return simulated time, else return real time (in ms)."
   (if *actr-enabled-p*
     (round (* 1000 (mp-time *mp*)))
     (get-internal-real-time)))



(defun pm-timed-event (time func &rest args)
   "To schedule an external event at a specific time (in seconds), call this"
   (setf (sched-q *mp*)
         (queue-insert (make-instance 'input-queue-entry
                         :time-tag time
                         :destination :EXTERNAL
                         :params (cons func args))
                       (sched-q *mp*))))


(defun pm-delayed-event (delay func &rest args)
   "To schedule an external event at some delay (in seconds) after the 
current time, call this"
   (setf (sched-q *mp*)
         (queue-insert (make-instance 'input-queue-entry
                         :time-tag (+ (mp-time *mp*) delay)
                         :destination :EXTERNAL
                         :params (cons func args))
                       (sched-q *mp*))))


;;;; 
---------------------------------------------------------------------- 
;;;;
;;;; Base DEVICE-INTERFACE class and some quicky methods.

(defclass device-interface ()
   ((pixels-per-inch :accessor ppi :initarg :ppi
                     :initform (/ (+ *pixels-per-inch-x*
                                     *pixels-per-inch-y*) 2.0))
    (viewing-distance :accessor viewing-distance :initform 15.0)
    (device :accessor device :initform nil)
    (key-closure-time :accessor key-closure-time :initform 0.010)
    (microphone-delay :accessor :microphone-delay :initform 0.100)
    (keyboard :accessor keyboard :initform (make-instance 'virtual-keyboard))
    (speech-hook :accessor speech-hook :initform nil)
    (device-speech-p :accessor device-speech-p :initform nil)
    (with-cursor-p :accessor with-cursor-p :initform nil)
    (input-q :accessor input-q :initform nil)
    (device-hook :accessor device-hook :initform nil)
    (mouse-fitts-coeff :accessor mouse-fitts-coeff :initform 0.1)
    (show-focus-p :accessor show-focus-p :initarg :show-focus-p :initform nil)
    (trace-mouse-p :accessor trace-mouse-p :initarg :trace-mouse-p 
:initform nil)
    (mouse-trace :accessor mouse-trace :initarg :mouse-trace :initform nil)
    ))



(defgeneric angle->pixels-mth (devin angle)
   (:documentation  "Determine the number of pixels subtending a 
visual angle."))

(defmethod angle->pixels-mth ((devin device-interface) (angle number))
   (round (* (* (viewing-distance devin) (tan (deg->rad angle)))
             (ppi devin))))


(defgeneric pixels->angle-mth (devin pixels)
   (:documentation  "Determine the amount of visual angle subtended by 
<pixels>."))

(defmethod pixels->angle-mth ((devin device-interface) (pixels number))
   (rad->deg (atan (/ (/ pixels (ppi devin)) (viewing-distance devin)))))


(defgeneric find-viewing-dist-mth (devin angle pixels)
   (:documentation  "Given the number of pixels an angle subtends, 
what's the viewing distance?"))

(defmethod find-viewing-dist-mth ((devin device-interface) angle pixels)
   (floor
    (/ pixels (* (tan (deg->rad angle)) (ppi devin)))))





;;;; 
---------------------------------------------------------------------- 
;;;;
;;;; Interacting with the Master Process


(defmethod reset-device ((devin device-interface))
   (setf (input-q devin) nil)
   (setf (mouse-trace devin) nil))

(defmethod reset-module ((devin device-interface))
   (reset-device devin))


(defgeneric update-device (devin time)
   (:documentation  "Update the device at <time>."))

;;; the default method has to do the following:
;;; [1] Update the attentional focus
;;; [2] Call the device hook
;;; [3] Make sure the cursor synch is maintained
;;; [4] Call the device update method

(defmethod update-device ((devin device-interface) time)
   (when (and (show-focus-p devin)
              (current-marker (vis-m *mp*)))
     (device-update-attended-loc (device devin)
                                 (dmo-to-xy (current-marker (vis-m *mp*)))))
   (awhen (device-hook devin)
     (funcall it time))
   (synch-mouse devin)
   (device-update (device devin) time))


(defgeneric device-update-attended-loc (device xyloc)
   (:documentation  "Tell the device to update the attended location, 
which is passed in."))

(defmethod device-update-attended-loc (device xyloc)
   (declare (ignore device xyloc))
   nil)


(defgeneric device-update (device time)
   (:documentation  "Update the device at <time>.  A method should be 
defined for this if the device is dynamic."))

(defmethod device-update (device time)
   (declare (ignore device time))
   nil)


(defgeneric run-events (devin the-time)
   (:documentation  "Runs the current events in the input queue."))

(defmethod run-events ((devin device-interface) the-time)
   (while (and (input-q devin)
               (>= (ms-round the-time)
                   (ms-round (time-tag (first (input-q devin))))))
     (let ((event (pop (input-q devin))))
       (when (trace-modules *mp*)
         (pm-output the-time "Device running command ~S"
                    (first (params event)) the-time))
       (apply (first (params event))
              (append (list devin) (rest (params event)))))))


(defmethod new-message ((devin device-interface) (entry input-queue-entry))
   (setf (input-q devin) (queue-insert entry (input-q devin))))


(defmethod pm-install-module ((mp master-process) (module device-interface)
                                  &optional (warn t))
   (awhen (assoc :DEVICE (module-lst mp))
     (awhen (and (neq module (rest it)) warn)
       (pm-warning "Overwrite current device interface?  [y/n] ")
       (let ((char (read-char)))
         (when (not (or (eq char #\y) (eq char #\Y)))
           (return-from pm-install-module nil))))
     (setf (module-lst mp) (delete :DEVICE (module-lst mp) :key #'first)))
   (push (cons :DEVICE module) (module-lst mp)))


;;; this just does nothing because the device gets updated before the
;;; schedule queue in DO-UPDATE.  We just need the stub because this call
;;; gets mapped on all the modules during the update, and we don't want the
;;; device updated twice.

(defmethod update-module ((devin device-interface))
   nil)


;;; bascially, same deal with this method
(defmethod silent-events ((devin device-interface))
   nil)


;;;; 
---------------------------------------------------------------------- 
;;;;
;;;; Proc screen stuff

;;; PROCESS-DISPLAY      [Method]
;;; Description : Replacement for old PROC-SCREEN functionality.  A few things
;;;             : have to be done to process the display.  First, make sure
;;;             : a display is attached.  Then, set up the previous icon.
;;;             : This is NIL if we're clearing the display.  Then, ask the
;;;             : device for a new icon.  Then check the new icon against the
;;;             : old one so we don't lose state information.  Update the
;;;             : attended location, make sure everyone is current on the
;;;             : mouse location.  Return the length of the icon, since ya
;;;             : gotta return something.

(defgeneric process-display (devin vis-mod &optional clear)
   (:documentation  "Rebuild the Vision Module's icon based on the 
current display."))

(defmethod process-display ((devin device-interface)
                                (vis-mod vision-module) &optional (clear nil))
   (let ((tmpicon nil)
         (time (pm-time)))
     (unless (device devin)
       (pm-warning "Cannot process display--no device is installed.")
       (return-from process-display nil))
     ;; build the temp visicon
     (setf tmpicon (flatten (build-features-for (device devin) vis-mod)))
     (when (with-cursor-p devin)
       (awhen (cursor-to-feature (device devin))
         (push  it tmpicon)))
     ;; if clear, then make the visicon the temp icon, if not we have to
     ;; check the new vs. the old icon
     (if clear
       (setf (visicon vis-mod) (mapcar #'(lambda (f)
                                           (enter-into-visicon f time))
                                       tmpicon))
       (let ((oldicon (visicon vis-mod)))
         (setf (visicon vis-mod) nil)
         (dolist (feat tmpicon)
           (aif (member feat oldicon :test #'feat=)
             (progn
               (push (checknew (first it) vis-mod) (visicon vis-mod))
               (setf oldicon (delete (first it) oldicon)))
             (push (enter-into-visicon feat time) (visicon vis-mod))))
         (setf (visicon vis-mod) (nreverse (visicon vis-mod)))))
     ;; other bookkeeping
     (check-finsts vis-mod)
     (update-attended-loc vis-mod)
     (synch-mouse devin)
     (length (visicon vis-mod))))


(defgeneric synch-mouse (devin)
   (:documentation  "Make sure everyone agress on the current cursor 
position."))

(defmethod synch-mouse ((devin device-interface))
   (when (and (device devin)
              (not (vpt= (current-cursor (motor-m *mp*))
                         (get-mouse-coordinates (device devin)))))
     (device-move-cursor-to (device devin) (current-cursor (motor-m *mp*))))
   (update-cursor-feat devin (vis-m *mp*)))



(defgeneric update-cursor-feat (devin vis-mod)
   (:documentation  "Updates the feature in the icon with the current 
cursor position."))

(defmethod update-cursor-feat ((devin device-interface)
                                   (vis-mod vision-module))
   (when (and (with-cursor-p devin) (device devin))
     (let ((new-pos (get-mouse-coordinates (device devin)))
           (cur-crsr (first (member 'CURSOR (visicon vis-mod) :key #'kind))))
       (if (null cur-crsr)
         (awhen (cursor-to-feature (device devin))
           (length (push (enter-into-visicon it (pm-time)) (visicon vis-mod))))
         (when (not (vpt= new-pos (xy-loc cur-crsr)))
           (setf (attended-p cur-crsr) nil)
           (setf (screen-x cur-crsr) (px new-pos))
           (setf (screen-y cur-crsr) (py new-pos)))))))




(defgeneric key->cmd (devin key)
   (:documentation  "Given a key, return the appropriate Motor Module 
command to type it."))

(defmethod key->cmd ((devin device-interface) key)
   (key-to-command (keyboard devin) key))


;;; Generic methods which will need to be overridden for specific devices.
;;; These are defined for MCL windows.

(defgeneric get-mouse-coordinates (device)
   (:documentation  "Return the mouse coordinates in #(x y) form."))

(defmethod get-mouse-coordinates (device)
   (error "No method defined for GET-MOUSE-COORDINATES on object ~S." device))

(defgeneric build-features-for (obj vis-mod)
   (:documentation  "Return a list of icon-features for an object."))

(defmethod build-features-for (obj vis-mod)
   (declare (ignore vis-mod))
   (error "No method defined for BUILD-FEATURES-FOR on object ~S." obj))

(defgeneric cursor-to-feature (device)
   (:documentation  "Reaturn an icon feature reprsenting the current cursor."))

(defmethod cursor-to-feature (device)
   (error "No method definded for CURSOR-TO-FEATURE on object ~S." device))


;;;; 
---------------------------------------------------------------------- 
;;;;
;;;; Output functions:  mouse movements, keypress stuff.


(defgeneric output-key (devin keyloc)
   (:documentation  "Request that the device register a key output for 
the key at a given location."))

(defmethod output-key ((devin device-interface) (keyloc vector))
   (let ((the-key (loc->key (keyboard devin) keyloc)))
     (if (eq the-key 'mouse)
       (device-handle-click (device devin))
       (device-handle-keypress (device devin) the-key))))


(defgeneric output-speech (devin text)
   (:documentation  "Requests that the device output the provided text 
as speech."))

(defmethod output-speech ((devin device-interface) (text string))
   (when (device-speech-p devin)
     (device-speak-string (device devin) text))
   (when (speech-hook devin)
     (funcall (speech-hook devin) (mp-time *mp*) text)))


(defgeneric move-cursor-absolute (devin xyloc)
   (:documentation  "Request that the device move the cursor to the 
absolute location <xyloc>."))

(defmethod move-cursor-absolute ((devin device-interface) xyloc)
   (when (trace-mouse-p devin)
     (push (cons (pm-time) xyloc) (mouse-trace devin)))
   (device-move-cursor-to (device devin) xyloc)
   (synch-mouse devin))


(defgeneric move-cursor-polar (devin rtheta)
   (:documentation  "Request that the device move the cursor by <r> in 
direction <theta>."))

(defmethod move-cursor-polar ((devin device-interface) rtheta)
   (device-move-cursor-to
    (device devin)
    (polar-move-xy (get-mouse-coordinates (device devin)) rtheta))
   (synch-mouse devin))


(defgeneric output-click (devin)
   (:documentation  "Output a mouse click to the device."))

(defmethod output-click ((devin device-interface))
   (device-handle-click (device devin)))


;;; Generic methods which will need to be overridden for specific devices.
;;; These are defined for MCL windows.

(defgeneric device-handle-keypress (device key)
   (:documentation  "Handle the press of the given key."))

(defmethod device-handle-keypress (device key)
   (declare (ignore key))
   (error "No method defined for DEVICE-HANDLE-KEYPRESS for object ~S." device))

(defgeneric device-move-cursor-to (device xyloc)
   (:documentation  "Move the cursor to a specified location."))

(defmethod device-move-cursor-to (device xyloc)
   (declare (ignore xyloc))
   (error "No method defined for DEVICE-MOVE-CURSOR-TO for object ~S." device))

(defgeneric device-handle-click (device)
   (:documentation  "Handle a click request."))

(defmethod device-handle-click (device)
   (error "No method defined for DEVICE-HANDLE-CLICK for object ~S." device))

(defgeneric device-speak-string (device string)
   (:documentation  "Handle a speech request."))

(defmethod device-speak-string (device string)
   (declare (ignore string))
   (error "No method defined for DEVICE-SPEAK-STRING for object ~S.") device)


;;;; 
---------------------------------------------------------------------- 
;;;;
;;;; The virtual keyboard.  Override one or more of these methods to
;;;; represent different keyboards.

(defclass virtual-keyboard ()
    ((key->cmd-ht :accessor key->cmd-ht
                   :initform (make-hash-table :test #'equal))
     (key->loc-ht :accessor key->loc-ht
                   :initform (make-hash-table :test #'equal))
     (loc->key-array :accessor loc->key-arr
                      :initform (make-array '(23 7) :initial-element nil))))


(defmethod initialize-instance :after ((vk virtual-keyboard) &key)
   (populate-key-to-command-ht (key->cmd-ht vk))
   (populate-key-to-loc-ht (key->loc-ht vk))
   (populate-loc-to-key-array (loc->key-arr vk)))


;;; LOC-TO-KEY      [Method]
;;; Description : Given a location, return the corresponding character.
;;;             : Accessed via the 'virtual keyboard' array.

(defgeneric loc->key (vk loc)
   (:documentation  "Given an location, return the corresponding key"))

(defmethod loc->key ((vk virtual-keyboard) (loc vector))
   (if (vpt= loc #(28 2))
     'mouse
     (aref (loc->key-arr vk) (px loc) (py loc))))


(defgeneric key-to-command (vk key)
   (:documentation  "Given a key, return the appropriate command."))

(defmethod key-to-command ((vk virtual-keyboard) key)
   (gethash key (key->cmd-ht vk)))


(defmethod key-to-loc ((vk virtual-keyboard) key)
   (gethash key (key->loc-ht vk)))


(defgeneric populate-key-to-command-ht (ht)
   (:documentation  "Populates the hash table that maps keys to motor 
commands"))

(defmethod populate-key-to-command-ht ((ht hash-table))
   (setf (gethash 'space ht) '(punch :hand left :finger thumb))
   (setf (gethash 'backquote ht)
         '(peck-recoil :hand left :finger pinkie :r 2.24 :theta -2.03))
   (setf (gethash 'tab ht)
         '(peck-recoil :hand left :finger pinkie :r 1.41 :theta -2.36))
   (setf (gethash '1 ht)
         '(peck-recoil :hand left :finger pinkie :r 2 :theta -1.57))
   (setf (gethash 'Q ht)
         '(peck-recoil :hand left :finger pinkie :r 1 :theta -1.57))
   (setf (gethash 'A ht) '(punch :hand left :finger pinkie))
   (setf (gethash 'Z ht)
         '(peck-recoil :hand left :finger pinkie :r 1 :theta 1.57))
   (setf (gethash '2 ht)
         '(peck-recoil :hand left :finger ring :r 2 :theta -1.57))
   (setf (gethash 'W ht)
         '(peck-recoil :hand left :finger ring :r 1 :theta -1.57))
   (setf (gethash 'S ht)
         '(punch :hand left :finger ring))
   (setf (gethash 'X ht)
         '(peck-recoil :hand left :finger ring :r 1 :theta 1.57))
   (setf (gethash '3 ht)
         '(peck-recoil :hand left :finger middle :r 2 :theta -1.57))
   (setf (gethash 'E ht)
         '(peck-recoil :hand left :finger middle :r 1 :theta -1.57))
   (setf (gethash 'D ht) '(punch :hand left :finger middle))
   (setf (gethash 'C ht)
         '(peck-recoil :hand left :finger middle :r 1 :theta 1.57))
   (setf (gethash '4 ht)
         '(peck-recoil :hand left :finger index :r 2 :theta -1.57))
   (setf (gethash 'R ht)
         '(peck-recoil :hand left :finger index :r 1 :theta -1.57))
   (setf (gethash 'F ht) '(punch :hand left :finger index))
   (setf (gethash 'V ht)
         '(peck-recoil :hand left :finger index :r 1 :theta 1.57))
   (setf (gethash '5 ht)
         '(peck-recoil :hand left :finger index :r 2.24 :theta -1.11))
   (setf (gethash 'T ht)
         '(peck-recoil :hand left :finger index :r 1.41 :theta -0.79))
   (setf (gethash 'G ht)
         '(peck-recoil :hand left :finger index :r 1 :theta 0))
   (setf (gethash 'B ht)
         '(peck-recoil :hand left :finger index :r 1.41 :theta 0.79))
   (setf (gethash '6 ht)
         '(peck-recoil :hand right :finger index :r 2.24 :theta -2.03))
   (setf (gethash 'Y ht)
         '(peck-recoil :hand right :finger index :r 1.41 :theta -2.36))
   (setf (gethash 'H ht)
         '(peck-recoil :hand right :finger index :r 1 :theta 3.14))
   (setf (gethash 'N ht)
         '(peck-recoil :hand right :finger index :r 1.41 :theta 2.36))
   (setf (gethash '7 ht)
         '(peck-recoil :hand right :finger index :r 2 :theta -1.57))
   (setf (gethash 'U ht)
         '(peck-recoil :hand right :finger index :r 1 :theta -1.57))
   (setf (gethash 'J ht)
         '(punch :hand right :finger index))
   (setf (gethash 'M ht)
         '(peck-recoil :hand right :finger index :r 1 :theta 1.57))
   (setf (gethash '8 ht)
         '(peck-recoil :hand right :finger middle :r 2 :theta -1.57))
   (setf (gethash 'I ht)
         '(peck-recoil :hand right :finger middle :r 1 :theta -1.57))
   (setf (gethash 'K ht) '(punch :hand right :finger middle))
   (setf (gethash 'comma ht)
         '(peck-recoil :hand right :finger middle :r 1 :theta 1.57))
   (setf (gethash '9 ht)
         '(peck-recoil :hand right :finger ring :r 2 :theta -1.57))
   (setf (gethash 'O ht)
         '(peck-recoil :hand right :finger ring :r 1 :theta -1.57))
   (setf (gethash 'L ht)
         '(punch :hand right :finger ring))
   (setf (gethash 'period ht)
         '(peck-recoil :hand right :finger index :r 1 :theta 1.57))
   (setf (gethash '0 ht)
         '(peck-recoil :hand right :finger pinkie :r 2 :theta -1.57))
   (setf (gethash 'P ht)
         '(peck-recoil :hand right :finger pinkie :r 1 :theta -1.57))
   (setf (gethash 'semicolon ht) '(punch :hand right :finger pinkie))
   (setf (gethash 'slash ht)
         '(peck-recoil :hand right :finger pinkie :r 1 :theta 1.57))
   (setf (gethash 'hyphen ht)
         '(peck-recoil :hand right :finger pinkie :r 2.24 :theta 1.11))
   (setf (gethash '[ ht)
         '(peck-recoil :hand right :finger pinkie :r 1.41 :theta -0.78))
   (setf (gethash 'quote ht)
         '(peck-recoil :hand right :finger pinkie :r 1 :theta 0))
   (setf (gethash 'return ht)
         '(peck-recoil :hand right :finger pinkie :r 2 :theta 0))
   ht
   )

(defgeneric populate-key-to-loc-ht (ht)
   (:documentation  "Build a hash table mapping keys to locations."))

(defmethod populate-key-to-loc-ht ((ht hash-table))
   ;; function key row
   (setf (gethash 'escape ht) #(0 0))
   (setf (gethash 'F1 ht) #(2 0))
   (setf (gethash 'F2 ht) #(3 0))
   (setf (gethash 'F3 ht) #(4 0))
   (setf (gethash 'F4 ht) #(5 0))
   (setf (gethash 'F5 ht) #(7 0))
   (setf (gethash 'F6 ht) #(8 0))
   (setf (gethash 'F7 ht) #(9 0))
   (setf (gethash 'F8 ht) #(10 0))
   (setf (gethash 'F9 ht) #(12 0))
   (setf (gethash 'F10 ht) #(13 0))
   (setf (gethash 'F11 ht) #(14 0))
   (setf (gethash 'F12 ht) #(15 0))
   (setf (gethash 'F13 ht) #(17 0))
   (setf (gethash 'F14 ht) #(18 0))
   (setf (gethash 'F15 ht) #(19 0))
   ;; numeric key row
   (setf (gethash 'backquote ht) #(0 2))
   (setf (gethash 1 ht) #(1 2))
   (setf (gethash 2 ht) #(2 2))
   (setf (gethash 3 ht) #(3 2))
   (setf (gethash 4 ht) #(4 2))
   (setf (gethash 5 ht) #(5 2))
   (setf (gethash 6 ht) #(6 2))
   (setf (gethash 7 ht) #(7 2))
   (setf (gethash 8 ht) #(8 2))
   (setf (gethash 9 ht) #(9 2))
   (setf (gethash 0 ht) #(10 2))
   (setf (gethash '- ht) #(11 2))
   (setf (gethash '= ht) #(12 2))
   (setf (gethash 'delete ht) #(13 2))
   (setf (gethash 'help ht) #(15 2))
   (setf (gethash 'home ht) #(16 2))
   (setf (gethash 'pageup ht) #(17 2))
   (setf (gethash 'clear ht) #(19 2))
   (setf (gethash '= ht) #(20 2))
   (setf (gethash '/ ht) #(21 2))
   (setf (gethash '* ht) #(22 2))
   ;; QWERTY row
   (setf (gethash 'tab ht) #(0 3))
   (setf (gethash 'Q ht) #(1 3))
   (setf (gethash 'W ht) #(2 3))
   (setf (gethash 'E ht) #(3 3))
   (setf (gethash 'R ht) #(4 3))
   (setf (gethash 'T ht) #(5 3))
   (setf (gethash 'Y ht) #(6 3))
   (setf (gethash 'U ht) #(7 3))
   (setf (gethash 'I ht) #(8 3))
   (setf (gethash 'O ht) #(9 3))
   (setf (gethash 'P ht) #(10 3))
   (setf (gethash '[ ht) #(11 3))
   (setf (gethash '] ht) #(12 3))
   (setf (gethash 'backslash  ht) #(13 3))
   (setf (gethash 'forward-delete ht) #(15 3))
   (setf (gethash 'end ht) #(16 3))
   (setf (gethash 'page-up ht) #(17 3))
   (setf (gethash 'keypad-7 ht) #(19 3))
   (setf (gethash 'keypad-8 ht) #(20 3))
   (setf (gethash 'keypad-9 ht) #(21 3))
   (setf (gethash 'keypad-hyphen ht) #(22 3))
   ;; "A" row
   (setf (gethash 'caps-lock ht) #(0 4))
   (setf (gethash 'A ht) #(1 4))
   (setf (gethash 'S ht) #(2 4))
   (setf (gethash 'D ht) #(3 4))
   (setf (gethash 'F ht) #(4 4))
   (setf (gethash 'G ht) #(5 4))
   (setf (gethash 'H ht) #(6 4))
   (setf (gethash 'J ht) #(7 4))
   (setf (gethash 'K ht) #(8 4))
   (setf (gethash 'L ht) #(9 4))
   (setf (gethash 'semicolon ht) #(10 4))
   (setf (gethash 'quote ht) #(11 4))
   (setf (gethash 'return ht) #(12 4))
   (setf (gethash 'keypad-4 ht) #(19 4))
   (setf (gethash 'keypad-5 ht) #(20 4))
   (setf (gethash 'keypad-6 ht) #(21 4))
   (setf (gethash 'keypad-plus ht) #(22 4))
   ;; "Z" row
   (setf (gethash 'shift ht) #(0 5))
   (setf (gethash 'Z ht) #(1 5))
   (setf (gethash 'X ht) #(2 5))
   (setf (gethash 'C ht) #(3 5))
   (setf (gethash 'V ht) #(4 5))
   (setf (gethash 'B ht) #(5 5))
   (setf (gethash 'N ht) #(6 5))
   (setf (gethash 'M ht) #(7 5))
   (setf (gethash 'comma ht) #(8 5))
   (setf (gethash 'period ht) #(9 5))
   (setf (gethash 'dot  ht) #(9 5))
   (setf (gethash '/ ht) #(10 5))
   (setf (gethash 'right-shift ht) #(11 5))
   (setf (gethash 'up-arrow ht) #(16 5))
   (setf (gethash 'keypad-1 ht) #(19 5))
   (setf (gethash 'keypad-2 ht) #(20 5))
   (setf (gethash 'keypad-3 ht) #(21 5))
   (setf (gethash 'keypad-enter ht) #(22 5))
   ;; space bar row
   (setf (gethash 'left-control ht) #(0 6))
   (setf (gethash 'left-option ht) #(1 6))
   (setf (gethash 'left-command ht) #(2 6))
   (setf (gethash 'spc ht) #(3 6))
   (setf (gethash 'spc ht) #(4 6))
   (setf (gethash 'spc ht) #(5 6))
   (setf (gethash 'spc ht) #(6 6))
   (setf (gethash 'spc ht) #(7 6))
   (setf (gethash 'spc ht) #(8 6))
   (setf (gethash 'spc ht) #(9 6))
   (setf (gethash 'spc ht) #(10 6))
   (setf (gethash 'right-command ht) #(11 6))
   (setf (gethash 'right-option ht) #(12 6))
   (setf (gethash 'right-control ht) #(13 6))
   (setf (gethash 'left-arrow ht) #(15 6))
   (setf (gethash 'down-arrow ht) #(16 6))
   (setf (gethash 'right-arrow ht) #(17 6))
   (setf (gethash 'keypad-0 ht) #(19 6))
   (setf (gethash 'keypad-period ht) #(21 6))
   (setf (gethash 'enter ht) #(22 6))
   ht)


;;;  -*- mode: LISP; Package: CL-USER; Syntax: COMMON-LISP;  Base: 10 -*-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Author      : Mike Byrne
;;; Copyright   : (c)1998-2001 CMU/Rice U./Mike Byrne, All Rights Reserved
;;; Availability: public domain
;;; Address     : Rice University
;;;             : Psychology Department
;;;             : Houston,TX 77251-1892
;;;             : byrne@acm.org
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Filename    : dmi.lisp
;;; Version     : 2.1b1
;;;
;;; Description : The "Declarative Memory Interface"
;;;             : Defines a class ("declarative memory object," or DMO)
;;;             : and numerous methods to provide an interface layer
;;;             : between the PM stuff and the specific production
;;;             : system in terms of referring to declarative
;;;             : memory elements.  Cleans up a bunch of the PM code.
;;;
;;; Bugs        :
;;;
;;; Todo        :
;;;
;;; ----- History -----
;;; 01.07.27 mdb
;;;             : Removed CLEAR-LOC for 2.1/ACT5
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


(defclass dmo ()
   ((ps-ptr :accessor ps-ptr :initform nil :initarg :ps-ptr)
    (id :accessor id :initform (new-name-fct "DMO") :initarg :id)
    (dmtype :accessor dmtype :initarg :dmtype :initform nil)
    (pm-obj :accessor pm-obj :initform nil :initarg :pm-obj)))


;;; generic methods

(defmethod print-object ((self dmo) stream)
   (print-unreadable-object (self stream :type t)
     (princ (id self) stream)))


(defgeneric find-loc-dmo (loc)
   (:documentation "Given an XY location, return the DMO representing 
that location, if present."))

(defmethod find-loc-dmo ((loc vector))
   (random-item
    (matching-dmos 'visual-location
                   `(screen-x ,(px loc) screen-y ,(py loc)))))

(defmethod find-loc-dmo ((loc list))
   (find-loc-dmo (coerce loc 'vector)))


(defgeneric xy-to-dmo (loc attended-p)
   (:documentation "Given an XY loc and an attended value, find the 
declarative memory representaion for that location, or build it. 
Either way, set the attended flag of the DMO."))

(defmethod xy-to-dmo ((loc vector) (attended-p symbol))
   (let ((loc-dmo (find-loc-dmo loc))
         (name (new-name-fct "LOC")))
     (if loc-dmo
       (if attended-p
         (set-attributes loc-dmo '(attended t))
         loc-dmo)
       (make-dme name 'visual-location
                 `(screen-x ,(px loc) screen-y ,(py loc)
                            attended ,attended-p objects nil)
                 :where :external))))


(defmethod xy-to-dmo ((loc list) (attended-p symbol))
   (xy-to-dmo (coerce loc 'vector) attended-p))


#|
(defgeneric clear-loc (dmo)
   (:documentation "Clears the <objects> slot of a DMO."))

(defmethod clear-loc ((self dmo))
   (set-attributes self '(objects nil)))
|#

(defgeneric dmo-to-xy (dmo)
   (:documentation "Takes a location DMO and returns the XY location."))

(defmethod dmo-to-xy ((self dmo))
   (vector (get-attribute self 'screen-x) (get-attribute self 'screen-y)))



;;; Must be overridden with PS-specific methods.

(defgeneric make-dme (id dmtype attrs &key obj where)
   (:documentation "Creates both a PS-specific DM rep and an abstract 
DMO for a specification."))

(defmethod make-dme (id (dmtype symbol) (attrs list) &key (obj nil) 
(where nil))
   (declare (ignore id dmtype attrs obj where))
   (error "No method defined for MAKE-DME."))


(defgeneric get-attribute (dmo attrname)
   (:documentation "Retuns the value of a DMO's specified attribute."))

(defmethod get-attribute ((self dmo) (attrname symbol))
   (declare (ignore self attrname))
   (error "No method defined for GET-ATTRIBUTE."))


(defgeneric set-attributes (dmo attrs)
   (:documentation "Sets the value of one or more attributes of a DMO."))

(defmethod set-attributes ((self dmo) (attrs list))
   (declare (ignore self attrs))
   (error "No method defined for SET-ATTRIBUTES."))


(defgeneric psdme-to-dmo (psdme)
   (:documentation "Given a PS-specific DME, return the corresponding DMO."))

(defmethod psdme-to-dmo ((psdme null))
   nil)

(defmethod psdme-to-dmo (psdme)
   (declare (ignore psdme))
   (error "No method defined for PSDME-TO-DMO."))


(defgeneric dmo-to-psdme (dmo)
   (:documentation "Return the PS-specific DME form for a given DMO."))

(defmethod dmo-to-psdme ((self null))
   nil)

(defmethod dmo-to-psdme ((self dmo))
   (declare (ignore self))
   (error "No method defined for DMO-TO-PSDME."))


(defgeneric matching-dmos (dmtype attrs)
   (:documentation "Return a list of DMOs matching the given spec."))

(defmethod matching-dmos ((dmtype symbol) (attrs list))
   (declare (ignore self))
   (error "No method defined for DMO-TO-PSDME."))



;;;  -*- mode: LISP; Package: CL-USER; Syntax: COMMON-LISP;  Base: 10 -*-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Author      : Dan Bothell
;;; Copyright   : (c)2001 CMU/Dan Bothell, All Rights Reserved
;;; Availability: public domain
;;; Address     : Carnegie Mellon University
;;;             : Psychology Department
;;;             : Pittsburgh PA 15213
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Filename    : generic-interface.lisp
;;; Version     : 2.0b5
;;;
;;; Description : Functions for RPM other than with MCL or ACL.
;;;
;;; Bugs        :
;;; --- History ---
;;; 01.05.31 Dan Bothell
;;;             : Created for use with LispWorks and hopefully other lisps.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;;; Because the models define methods on it
;;; for key-presses and mouse-clicks it needs to
;;; exist even if it's not used...

(defclass rpm-window ()
   ())

;;; Even though LispWorks allows things like #\f1 I'm using symbols
;;; for everything that's not "normal" so as to hopefully make
;;; it general enough.

(defmethod populate-loc-to-key-array ((ar array))
   "Sets all the keys in the array that need to be set"
   ;; function key row
   (setf (aref ar 0 0) 'ESC)
   (setf (aref ar 2 0) 'f1)
   (setf (aref ar 3 0) 'f2)
   (setf (aref ar 4 0) 'f3)
   (setf (aref ar 5 0) 'f4)
   (setf (aref ar 7 0) 'f5)
   (setf (aref ar 8 0) 'f6)
   (setf (aref ar 9 0) 'f7)
   (setf (aref ar 10 0) 'f8)
   (setf (aref ar 12 0) 'f9)
   (setf (aref ar 13 0) 'f10)
   (setf (aref ar 14 0) 'f11)
   (setf (aref ar 15 0) 'f12)
   (setf (aref ar 17 0) 'print-screen)
   (setf (aref ar 18 0) 'scroll-lock)
   (setf (aref ar 19 0) 'pause)
   ;; numeric key row
   (setf (aref ar 0 2) #\tab)
   (setf (aref ar 1 2) #\1)
   (setf (aref ar 2 2) #\2)
   (setf (aref ar 3 2) #\3)
   (setf (aref ar 4 2) #\4)
   (setf (aref ar 5 2) #\5)
   (setf (aref ar 6 2) #\6)
   (setf (aref ar 7 2) #\7)
   (setf (aref ar 8 2) #\8)
   (setf (aref ar 9 2) #\9)
   (setf (aref ar 10 2) #\0)
   (setf (aref ar 11 2) #\-)
   (setf (aref ar 12 2) #\=)
   (setf (aref ar 13 2) 'Delete)
   (setf (aref ar 15 2) 'help)
   (setf (aref ar 16 2) 'home)
   (setf (aref ar 17 2) 'pageup)
   (setf (aref ar 19 2) 'ESC)
   (setf (aref ar 20 2) #\=)
   (setf (aref ar 21 2) #\/)
   (setf (aref ar 22 2) #\*)
   ;; qwerty row
   (setf (aref ar 0 3) #\Tab)
   (setf (aref ar 1 3) #\q)
   (setf (aref ar 2 3) #\w)
   (setf (aref ar 3 3) #\e)
   (setf (aref ar 4 3) #\r)
   (setf (aref ar 5 3) #\t)
   (setf (aref ar 6 3) #\y)
   (setf (aref ar 7 3) #\u)
   (setf (aref ar 8 3) #\i)
   (setf (aref ar 9 3) #\o)
   (setf (aref ar 10 3) #\p)
   (setf (aref ar 11 3) #\[)
   (setf (aref ar 12 3) #\])
   (setf (aref ar 13 3) #\\)
   (setf (aref ar 15 3) 'DEL)
   (setf (aref ar 16 3) 'End)
   (setf (aref ar 17 3) 'Page)
   (setf (aref ar 19 3) #\7)
   (setf (aref ar 20 3) #\8)
   (setf (aref ar 21 3) #\9)
   (setf (aref ar 22 3) #\-)
   ;; ASDF row
   (setf (aref ar 0 4) 'caps-lock)
   (setf (aref ar 1 4) #\a)
   (setf (aref ar 2 4) #\s)
   (setf (aref ar 3 4) #\d)
   (setf (aref ar 4 4) #\f)
   (setf (aref ar 5 4) #\g)
   (setf (aref ar 6 4) #\h)
   (setf (aref ar 7 4) #\j)
   (setf (aref ar 8 4) #\k)
   (setf (aref ar 9 4) #\l)
   (setf (aref ar 10 4) #\;)
   (setf (aref ar 11 4) #\')
   (setf (aref ar 12 4) #\Newline)
   (setf (aref ar 13 4) #\Newline)
   (setf (aref ar 19 4) #\4)
   (setf (aref ar 20 4) #\5)
   (setf (aref ar 21 4) #\6)
   (setf (aref ar 22 4) #\+)
   ;; Z row
   (setf (aref ar 0 5) 'shift)
   (setf (aref ar 1 5) #\z)
   (setf (aref ar 2 5) #\x)
   (setf (aref ar 3 5) #\c)
   (setf (aref ar 4 5) #\v)
   (setf (aref ar 5 5) #\b)
   (setf (aref ar 6 5) #\n)
   (setf (aref ar 7 5) #\m)
   (setf (aref ar 8 5) #\,)
   (setf (aref ar 9 5) #\.)
   (setf (aref ar 10 5) #\/)
   (setf (aref ar 11 5) 'shift)
   (setf (aref ar 12 5) 'shift)
   (setf (aref ar 16 5) 'UpArrow)
   (setf (aref ar 19 5) #\1)
   (setf (aref ar 20 5) #\2)
   (setf (aref ar 21 5) #\3)
   (setf (aref ar 22 5) 'enter)
   ;; space bar row
   (setf (aref ar 0 6) 'control)
   (setf (aref ar 1 6) 'option)
   (setf (aref ar 2 6) 'command)
   (setf (aref ar 3 6) #\Space)
   (setf (aref ar 4 6) #\Space)
   (setf (aref ar 5 6) #\Space)
   (setf (aref ar 6 6) #\Space)
   (setf (aref ar 7 6) #\Space)
   (setf (aref ar 8 6) #\Space)
   (setf (aref ar 9 6) #\Space)
   (setf (aref ar 10 6) #\Space)
   (setf (aref ar 11 6) 'command)
   (setf (aref ar 12 6) 'option)
   (setf (aref ar 13 6) 'control)
   (setf (aref ar 15 6) 'BackArrow)
   (setf (aref ar 16 6) 'DownArrow)
   (setf (aref ar 17 6) 'ForwardArrow)
   (setf (aref ar 19 6) #\0)
   (setf (aref ar 20 6) #\0)
   (setf (aref ar 21 6) #\.)
   (setf (aref ar 22 6) 'enter)
   ar)



;; build the Master Process
(eval-when (eval load)
   (setf *mp* (make-instance 'master-process)))

;; print stuff out


(defun print-banner ()
   (format t "~&~%ACT-R/PM Version ~A  Report bugs to <byrne@acm.org>~%~
              +------------------------------------------------------------+~%~
              |          ACT-R Perceptual-Motor (ACT-R/PM) ~13A   |~%~
              |                     Å(c)  1997-2002                           |~%~
              |                       Mike Byrne                           |~%~
              |    Department of Psychology, Carnegie Mellon University    |~%~
              |          Department of Psychology, Rice University         |~%~
              +------------------------------------------------------------+~%"
           (version-string *mp*) (version-string *mp*)))


(eval-when (eval load)
   (print-banner))

(eval-when (eval load)
   (pushnew :rpm *features*))


;;;  -*- mode: LISP; Package: CL-USER; Syntax: COMMON-LISP;  Base: 10 -*-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Author      : Mike Byrne [with Dan Bothell]
;;; Copyright   : (c)1997-2001 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.1b2
;;;
;;; 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       : The stepper could still be a little better.
;;;
;;; ----- 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.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

#+:mcl (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)))


(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 nil)
    (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.1b4")
    (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)
    ))


(defmethod initialize-instance :after ((mstr-proc master-process) &key)
   (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))
   (pm-install-module mstr-proc (make-instance 'device-interface))
   (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)))





#|
(defmethod run-master-process ((mstr-proc master-process) duration)
   (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)))))
     (while (< (mp-time mstr-proc) finish-time)
       (pm-output current-time "Running ACT-R" current-time)
       (multiple-value-bind (run-time ps-status)
                            (run-ps mstr-proc
                                    (- (stop-time mstr-proc finish-time)
                                       (start-time mstr-proc)))
         (setf current-time (ms-round (+ current-time run-time)))
         (do-update mstr-proc current-time :real-wait t)
         (cond ((eq ps-status :RUNNING) nil)
               ((eq ps-status :HALTED)
                (pm-output nil "* Production system halted.")
                (maybe-dequeue-events mstr-proc finish-time)
                (return-from run-master-process
                  (values (elapsed-time mstr-proc) current-time)))
               ((and (eq ps-status :WAITING)
                     (null (sched-q mstr-proc))
                     (no-silent-events mstr-proc))
                (pm-output nil "* Nothing to run:  No productions, no events.")
                (return-from run-master-process
                  (values (elapsed-time mstr-proc) current-time)))
               ((and (zerop run-time) (null (next-stop-time mstr-proc)))
                (incf current-time (min-run-time mstr-proc))
                (do-update mstr-proc current-time))
               ((zerop run-time)
                (setf current-time (min finish-time
                                        (stop-time mstr-proc finish-time)))
                (do-update mstr-proc current-time))
               (t (error "Unhandled state--email byrne@acm.org!")))))
     (pm-output nil "~%Elapsed:  ~S  Current:  ~S" (elapsed-time mstr-proc)
                current-time)
     (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)
       (old-pm-output "** Commands are:" (mp-time mstr-proc))
       (old-pm-output "[A]bort (or [q]uit)")
       (old-pm-output "[D]equeue current events only")
       (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]hynot")
       (old-pm-output "Command: ")
       (case (read-char)
         ((#\A #\a #\q #\Q) (setf done t))
         ((#\D #\d) (let ((*debug* t))
                      (do-update mstr-proc (mp-time mstr-proc))))
         ((#\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)))))


#|
(defmethod single-step ((mstr-proc master-process))
   (do-update mstr-proc (mp-time mstr-proc))
   (let ((duration nil))
     (aif (next-stop-time mstr-proc)
          (setf duration (- it (mp-time mstr-proc)))
          (setf duration (min-run-time mstr-proc)))
     (multiple-value-bind (latency state)
                          (run-ps mstr-proc duration)
       (set-clock mstr-proc (+ (mp-time mstr-proc) latency))
       (when (eq state :WAITING)
         (pm-output nil "Production system is spinning.")
         (aif (next-stop-time mstr-proc)
              (set-clock mstr-proc it)
              (set-clock mstr-proc (+ (mp-time mstr-proc)
                                      (min-run-time mstr-proc)))))
       (when (eq state :HALTED)
         (pm-output nil "* Production system has halted.")))))
|#

;;; 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)
                                        :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
;;;; 
---------------------------------------------------------------------- 
;;;;



#|
;;; INTERRUPT-P      [Method]
;;; Date        : 99.03.18
;;; Description : Determine if a queue entry is an interrupt.  If the MP is
;;;             : running in "slave mode"--no interrupts--then it isn't.
;;;             : Then, if interrupting on outputs is disabled, if the event
;;;             : is headed for the outside, it isn't.  Otherwise, do whatever
;;;             : the queue entry says.

(defgeneric interrupt-p (entry mstr-proc)
   (:documentation  "Determine if a queue entry should generate an interrupt."))

(defmethod interrupt-p ((entry queue-entry) (mstr-proc master-process))
   (cond ((slave-p mstr-proc) nil)
         ((and (not (interrupt-on-output-p mstr-proc))
               (or (eq (destination entry) :DEVICE)
                   (eq (destination entry) :EXTERNAL)) nil))
         (t (is-interrupt entry))))
|#

;;; 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))
   (if (null queue)
     (push entry queue)
     (progn
       (let ((pos 0))
         (while (and (nth pos queue)
                     (>= (time-tag entry) (time-tag (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)))


;;;; 
---------------------------------------------------------------------- 
;;;;
;;;;  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)))))




;;;  -*- mode: LISP; Package: CL-USER; Syntax: COMMON-LISP;  Base: 10 -*-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Author      : Mike Byrne
;;; Copyright   : (c)1997-2001 CMU/Rice U./Mike Byrne, All Rights Reserved
;;; Availability: public domain
;;; Address     : Rice University
;;;             : Psychology Department
;;;             : Houston,TX 77251-1892
;;;             : byrne@acm.org
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Filename    : mcl-interface.lisp
;;; Version     : 2.1b2
;;;
;;; Description : MCL-specific functions for RPM.  This consists primarily
;;;             : of stuff for vision (parsing the screen), and output
;;;             : stuff for motor.
;;;
;;; Bugs        : The RPM-LINE-TO functionality is not all it should be; this
;;;             : needs a view-based system.
;;;
;;; --- History ---
;;; 01.09.21 mdb [b2]
;;;             : Fixed an infinte recursion bug in APPROACH-WIDTH.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defparameter *crosshair-cursor*
   (#_GetCursor #$crossCursor) "Crosshair cursor")


(defvar *attn-tracker* nil "Holds the view for the focus ring.")

;;; For the UWI.

(defclass rpm-window (dialog)
   ())



;;;; RPM-LINE-TO is meant to be called in the VIEW-DRAW-CONTENTS method for
;;;; window, which should be called after PM-PROC-DISPLAY.  I know this is
;;;; is stupid, but I'm having trouble getting this to work right with views.

;;; RPM-LINE-TO      [Function]
;;; Date        : 97.03.31
;;; Description : For use in building interfaces.  If there is to be a lot of
;;;             : drawing, then there will probably be a lot of LINE-TO
;;;             : commands.  After making the window in question the current
;;;             : RPM window (via RPM-INSTALL-WINDOW), then call this function
;;;             : instead.  Note that the point should be in the coordinate
;;;             : system of the window.

(defun rpm-line-to (the-view h &optional v)
   "Adds a line to the icon and draws in in the default window. 
Designed to be called by the VIEW-DRAW-CONTENTS method for the 
window."
   (let* ((the-wind (device (device-interface *mp*)))
          (start-point (pen-position the-wind))
          (end-point (if v (make-point h v) h))
          (the-offset (view-position the-view)))
     (line-to the-view end-point)
     (rpm-build-line (p2vpt (add-points start-point the-offset))
                     (p2vpt (add-points the-offset end-point)))
     end-point))



;;; RPM-BUILD-LINE      [Function]
;;; Date        : 97.03.31
;;; Description : Called by RPM-LINE-TO, this creates an icon feature based
;;;             : on the beginning and end points.

(defun rpm-build-line (start-pt end-pt)
   "Build a line feature in the visual interface"
   ;  (declare (point start-pt) (point end-pt))
   (push
    (make-instance 'line-feature
      :end1-x (px start-pt) :end1-y (py start-pt)
      :end2-x (px end-pt) :end2-y (py end-pt)
      :x (loc-avg (px start-pt) (py end-pt))
      :y (loc-avg (px start-pt) (py end-pt))
      :width (abs (- (px start-pt) (py end-pt)))
      :height (abs (- (px start-pt) (py end-pt))))
    (visicon (vis-m *mp*))))



(defun loc-avg (x y)
   "Return the 'location' (integer) average of <x> and <y>."
   (declare (fixnum x) (fixnum y))
   (floor (/ (+ x y) 2)))


;;;; 
---------------------------------------------------------------------- 
;;;;;;;
;;;; MCL screen-to-icon interface
;;;; 
---------------------------------------------------------------------- 
;;;;;;;


;;; BUILD-FEATURES-FOR      [Method]
;;; Description : For an MCL window, just walk the sub-objects (which by
;;;             : default are subviews) and build features.

(defmethod build-features-for ((self window) (vis-mod vision-module))
   (let ((base-ls (flatten
                     (mapcar #'(lambda (obj) (build-features-for obj vis-mod))
                             (get-sub-objects self)))))
     (dolist (feat base-ls)
       (fill-default-dimensions feat))
     base-ls))


(defgeneric get-sub-objects (view)
   (:documentation  "Grabbing the sub-objects of a view by default 
returns the subviews."))

(defmethod get-sub-objects ((v view))
   (subviews v))


;;; BUILD-FEATURES-FOR      [Method]
;;; Date        : 97.04.02
;;; Description : Builder of features for a generic view.  Doesn't do anything
;;;             : based on the view itself, but it will call the
;;;             : feature-builder on all subviews.

(defmethod build-features-for ((self view) (vis-mod vision-module))
   (let ((subs (get-sub-objects self))
         (outlis nil))
     (dolist (sub subs outlis)
       (push (build-features-for sub vis-mod) outlis))))



;;; BUILD-FEATURES-FOR      [Method]
;;; Date        : 97.01.27
;;; Description : The basic method for building features, returns an object
;;;             : of the ICON-FEATURE class with the location and ISA fields
;;;             : set.

(defmethod build-features-for ((self dialog-item) (vis-mod vision-module))
   (declare (ignore vis-mod))
   (make-instance 'icon-feature
     :x (first (view-loc self))
     :y (second (view-loc self))
     :isa 'visual-object
     :value 'unknown
     :screen-obj self))


;;; BUILD-FEATURES-FOR      [Method]
;;; Date        : 97.01.28
;;; Description : Same as for EDIT-BOXes.

(defmethod build-features-for ((self editable-text-dialog-item)
                                   (vis-mod vision-module))
   (let ((font-spec (view-font self))
         (text (dialog-item-text self)))
     (cons
      (make-instance 'rect-feature
        :x (first (view-loc self))
        :y (second (view-loc self))
        :screen-obj self)
      (unless (equal text "")
        (multiple-value-bind (ascent descent)
                             (font-info font-spec)
          (build-string-feats vis-mod :text text
                              :start-x (1+ (point-h (view-position self)))
                              :y-pos (+ (point-v (view-position self))
                                        descent (round ascent 2))
                              :width-fct #'(lambda (str)
                                             (string-width str font-spec))
                              :height ascent :obj self))))))


;;; BUILD-FEATURES-FOR      [Method]
;;; Date        : 99.04.02, delta 99.07.02
;;; Description : A button dialog item is a lot like a static text item,
;;;             : except there's an oval associated with it and the text
;;;             : is centered both horizontally and vertically.

(defmethod build-features-for ((self button-dialog-item)
                                   (vis-mod vision-module))
   (let* ((btn-width (point-h (view-size self)))
          (btn-height (point-v (view-size self)))
          (text (dialog-item-text self)))
     (cons
      (make-instance 'oval-feature
        :x (px (view-loc self)) :y (py (view-loc self))
        :width btn-width :height btn-height
        :screen-obj self)
      (unless (equal text "")
        (let* ((font-spec (view-font self))
               (start-y nil)
               (accum nil)
               (textlines (string-to-lines text))
               (width-fct #'(lambda (str) (string-width str font-spec))))
          (multiple-value-bind (ascent descent) (font-info font-spec)
            (setf start-y (+ (point-v (view-position self))
                             (round (- btn-height (* (length textlines)
                                                     (+ ascent descent))) 2)))
            (dolist (item textlines (nreverse accum))
              (push
               (build-string-feats vis-mod :text item
                                   :start-x
                                   (+ (point-h (view-position self))
                                      (round
                                       (- btn-width (funcall width-fct item))
                                       2))
                                   :y-pos
                                   (+ start-y (round (+ ascent descent) 2))
                                   :width-fct width-fct
                                   :height (min ascent btn-height)
                                   :obj self)
               accum)
              (incf start-y (+ ascent descent)))))))))



(defmethod approach-width ((feat text-feature) (theta number))
   (let ((screen-obj (screen-obj feat)))
     (if (button-p screen-obj)
       (let ((new-feat
              (find-if #'(lambda (f) (and (eq (screen-obj f) screen-obj)
                                           (eq (kind f) 'oval)))
                       (visicon (vis-m *mp*)))))
         (if new-feat
           (approach-width new-feat theta)
           (call-next-method)))
       (call-next-method))))


(defmethod button-p (obj)
   (declare (ignore obj))
   nil)

(defmethod button-p ((obj button-dialog-item))
   (declare (ignore obj))
   t)

;;; BUILD-FEATURES-FOR      [Method]
;;; Date        : 99.04.02
;;; Description : A static text dialog item is really just text, so just
;;;             : build the string features for it.

(defmethod build-features-for ((self static-text-dialog-item)
                                   (vis-mod vision-module))
   (let ((font-spec (view-font self))
         (text (dialog-item-text self)))
     (unless (equal text "")
       (multiple-value-bind (ascent descent)
                            (font-info font-spec)
         (build-string-feats vis-mod :text text
                             :start-x (1+ (point-h (view-position self)))
                             :y-pos (+ (point-v (view-position self))
                                       descent (round ascent 2))
                             :width-fct #'(lambda (str)
                                            (string-width str font-spec))
                             :height ascent :obj self)))))



;;; CURSOR-TO-FEATURE      [Function]
;;; Date        : 97.06.16
;;; Description : Returns a feature representing the current state and shape
;;;             : of the cursor.

(defmethod cursor-to-feature ((the-window window))
   (let ((pos (view-mouse-position the-window))
         (shape (window-cursor the-window)))
     (when (cursor-in-window-p the-window)
       (make-instance 'cursor-feature
         :x (point-h pos) :y (point-v pos)
         :value (case shape
                  (*i-beam-cursor* 'I-BEAM)
                  (*crosshair-cursor* 'CROSSHAIR)
                  (*watch-cursor* 'WATCH)
                  (otherwise 'POINTER))))))


(defgeneric cursor-in-window-p (wind)
   (:documentation  "Returns T if the cursor is over <wind>, NIL otherwise."))

(defmethod cursor-in-window-p ((tw window))
   (when (window-shown-p tw)
     (rlet ((the-rect rect))
       (points-to-rect (view-position tw)
                       (add-points (view-position tw) (view-size tw))
                       the-rect)
       (point-in-rect-p the-rect
                        (local-to-global tw (view-mouse-position tw))))))



(defmethod view-loc ((self view))
   (let ((pos (view-position self))
         (size (view-size self)))
     (vector (round (+ (point-h pos) (/ (point-h size) 2)))
             (round (+ (point-v pos) (/ (point-v size) 2))))))


(defmethod view-loc ((self simple-view))
   (let ((pos (view-position self))
         (size (view-size self)))
     (vector (round (+ (point-h pos) (/ (point-h size) 2)))
             (round (+ (point-v pos) (/ (point-v size) 2))))))


(defmethod view-loc ((self symbol))
   (if (eq self :cursor)
     (get-mouse-coordinates (device (device-interface *mp*)))
     (error "!! Can't find location of ~S" self)))


(defmethod width ((self simple-view))
   (point-h (view-size self)))


(defmethod height ((self simple-view))
   (point-v (view-size self)))



;;; FILL-DEFAULT-DIMENSIONS      [Method]
;;; Date        : 99.04.02
;;; Description : The base methods for most MCL views don't set the height or
;;;             : width attributes of the features they generate, nor their
;;;             : size.  Set that up if necessary.

(defgeneric fill-default-dimensions (feat)
   (:documentation  "Fill in the width, height, and size of an icon feature."))

(defmethod fill-default-dimensions ((feat icon-feature))
   (aif (simple-size feat)
     (setf (size feat) it)
     (if (null (screen-obj feat))
       (setf (size feat) 1.0)              ; should be default size, eh
       (progn
         (unless (width feat) (setf (width feat) (width (screen-obj feat))))
         (unless (height feat) (setf (height feat) (height (screen-obj feat))))
         (setf (size feat) (simple-size feat))))))



;;;; 
---------------------------------------------------------------------- 
;;;;
;;;; Utilities
;;;; 
---------------------------------------------------------------------- 
;;;;

;;; XY->POINT      [Function]
;;; Description : Converts an (X Y) list into an MCL/Quickdraw point.

(defun xy->point (xy)
   "(x y) to point converstion function. Deprecated, use vpt2p instead."
   (declare (list xy))
   (make-point (first xy) (second xy)))


;;; P2XY      [Function]
;;; Description : Takes an MCL/Quickdraw point and returns an XY list

(defun p2xy (p)
   "Coverts an MCL/Quickdraw point to an XY list.  Deprecated, use 
p2vpt instead."
   ;  (declare (point p))
   (list (point-h p) (point-v p)))


(defun p2vpt (p)
   "Convert an MCL/Quickdraw point to #(x y) format."
   (declare (inline p2vpt))
   (vector (point-h p) (point-v p)))


(defun vpt2p (mpt)
   "Convert an #(x y) format point to MCL/Quickdraw format."
   (declare (vector mpt) (inline vpt2p))
   (make-point (px mpt) (py mpt)))


;;;; 
---------------------------------------------------------------------- 
;;;;
;;;; RPM device methods.
;;;; 
---------------------------------------------------------------------- 
;;;;

;;; DEVICE-HANDLE-KEYPRESS      [Method]
;;; Description : Just call VIEW-KEY-EVENT-HANDLER and make sure that the
;;;             : event gets dealt with.

(defmethod device-handle-keypress ((device window) key)
   (view-key-event-handler device key)
   (event-dispatch))

(defmethod view-key-event-handler ((device rpm-window) key)
   (rpm-window-key-event-handler device key)
   ;(call-next-method)
   )

(defmethod rpm-window-key-event-handler ((device rpm-window) key)
   (declare (ignore device key)))


;;; DEVICE-HANDLE-CLICK      [Method]
;;; Description : Again, just call the base MCL method and dispatch.

(defmethod device-handle-click ((device window))
   (view-click-event-handler device (view-mouse-position device))
   (event-dispatch))


(defmethod view-click-event-handler ((device rpm-window) position)
   (rpm-window-click-event-handler device
                                   (list (point-h position) (point-v position)))
   (call-next-method))

(defmethod rpm-window-click-event-handler ((device rpm-window) position)
   (declare (ignore device position)))


;;; DEVICE-MOVE-CURSOR-TO      [Method]
;;; Date        : 97.02.18 [revised 98.10.29]
;;; Description : Since moving the mouse is considered a Bad Thing by
;;;             : Apple's HI police, you can't just make a simple call
;;;             : to do it.  First, there's moving the cursor, which
;;;             : involves blasting into low memory.  Then, if the cursor
;;;             : is being tracked by the system, we have to make sure that
;;;             : the cursor move has really been registered (#$CrsrNew
;;;             : changes from -1 to 255 when this happens) by the OS.  Then
;;;             : make sure it's been registered by MCL with UPDATE-CURSOR.

#-ccl-4.3.1
(defmethod device-move-cursor-to ((device window) (xyloc vector))
   (let ((absloc (local-to-global device (px xyloc) (py xyloc))))
     (without-interrupts
      (ccl::%put-point (%int-to-ptr #$MTemp) absloc)
      (ccl::%put-point (%int-to-ptr #$RawMouse) absloc)
      (%put-word (%int-to-ptr #$CrsrNew) -1))
     (while (eql (%get-signed-word (%int-to-ptr #$CrsrNew)) -1))
     (update-cursor)
     (while (not (vpt= xyloc (p2vpt (view-mouse-position device))))
       (event-dispatch))))

#+ccl-4.3.1
(defmethod device-move-cursor-to ((device window) (xyloc vector))
   (let ((absloc (local-to-global device (px xyloc) (py xyloc))))
     (without-interrupts
      ;(ccl::%put-point (%int-to-ptr #$MTemp) absloc)
      (#_LMSetMouseTemp absloc)
      ;(ccl::%put-point (%int-to-ptr #$RawMouse) absloc)
      (#_LMSetRawMouseLocation absloc)
      ;(%put-word (%int-to-ptr #$CrsrNew) -1)
      (#_LMSetCursorNew -1)
      )
     ;(while (eql (%get-signed-word (%int-to-ptr #$CrsrNew)) -1))
     (while (eql (#_LMGetCursorNew) -1))
     (update-cursor)
     (while (not (vpt= xyloc (p2vpt (view-mouse-position device))))
       (event-dispatch))))



;;; DEVICE-SPEAK-STRING      [Method]
;;; Description : If the Mac Speech Manager is installed, actually speak the
;;;             : string.

(defmethod device-speak-string ((device window) string)
   (when (speech-available-p)
     (speak-string string)))


;;; GET-MOUSE-COORDINATES      [Method]
;;; Description : Return the current mouse loc in (x y) format.

(defmethod get-mouse-coordinates ((device window))
   (p2vpt (view-mouse-position device)))


;;; DEVICE-UPDATE-ATTENDED-LOC      [Method]
;;; Date        : 00.07.11
;;; Description : When the attended location is updated, update the focus
;;;             : ring.

(defmethod device-update-attended-loc ((wind window) xyloc)
   (update-me *attn-tracker* wind xyloc))



(defmethod do-update :after ((mstr-proc master-process) current-time
                                &key (real-wait nil))
   (declare (ignore current-time real-wait))
   (event-dispatch))





(defmethod populate-loc-to-key-array ((ar array))
   "Sets all the keys in the array that need to be set"
   ;; function key row
   (setf (aref ar 0 0) #\ESC)
   (setf (aref ar 2 0) #\2061)
   (setf (aref ar 3 0) #\2062)
   (setf (aref ar 4 0) #\2063)
   (setf (aref ar 5 0) #\2064)
   (setf (aref ar 7 0) #\2065)
   (setf (aref ar 8 0) #\2066)
   (setf (aref ar 9 0) #\2067)
   (setf (aref ar 10 0) #\2070)
   (setf (aref ar 12 0) #\2071)
   (setf (aref ar 13 0) #\2101)
   (setf (aref ar 14 0) #\2102)
   (setf (aref ar 15 0) #\2103)
   (setf (aref ar 17 0) #\2014)
   (setf (aref ar 18 0) #\2015)
   (setf (aref ar 19 0) #\2016)
   ;; numeric key row
   (setf (aref ar 0 2) #\tab)
   (setf (aref ar 1 2) #\1)
   (setf (aref ar 2 2) #\2)
   (setf (aref ar 3 2) #\3)
   (setf (aref ar 4 2) #\4)
   (setf (aref ar 5 2) #\5)
   (setf (aref ar 6 2) #\6)
   (setf (aref ar 7 2) #\7)
   (setf (aref ar 8 2) #\8)
   (setf (aref ar 9 2) #\9)
   (setf (aref ar 10 2) #\0)
   (setf (aref ar 11 2) #\-)
   (setf (aref ar 12 2) #\=)
   (setf (aref ar 13 2) #\Delete)
   (setf (aref ar 15 2) #\help)
   (setf (aref ar 16 2) #\home)
   (setf (aref ar 17 2) #\pageup)
   (setf (aref ar 19 2) #\ESC)
   (setf (aref ar 20 2) #\=)
   (setf (aref ar 21 2) #\/)
   (setf (aref ar 22 2) #\*)
   ;; qwerty row
   (setf (aref ar 0 3) #\Tab)
   (setf (aref ar 1 3) #\q)
   (setf (aref ar 2 3) #\w)
   (setf (aref ar 3 3) #\e)
   (setf (aref ar 4 3) #\r)
   (setf (aref ar 5 3) #\t)
   (setf (aref ar 6 3) #\y)
   (setf (aref ar 7 3) #\u)
   (setf (aref ar 8 3) #\i)
   (setf (aref ar 9 3) #\o)
   (setf (aref ar 10 3) #\p)
   (setf (aref ar 11 3) #\[)
   (setf (aref ar 12 3) #\])
   (setf (aref ar 13 3) #\\)
   (setf (aref ar 15 3) #\DEL)
   (setf (aref ar 16 3) #\End)
   (setf (aref ar 17 3) #\Page)
   (setf (aref ar 19 3) #\7)
   (setf (aref ar 20 3) #\8)
   (setf (aref ar 21 3) #\9)
   (setf (aref ar 22 3) #\-)
   ;; ASDF row
   (setf (aref ar 0 4) 'caps-lock)
   (setf (aref ar 1 4) #\a)
   (setf (aref ar 2 4) #\s)
   (setf (aref ar 3 4) #\d)
   (setf (aref ar 4 4) #\f)
   (setf (aref ar 5 4) #\g)
   (setf (aref ar 6 4) #\h)
   (setf (aref ar 7 4) #\j)
   (setf (aref ar 8 4) #\k)
   (setf (aref ar 9 4) #\l)
   (setf (aref ar 10 4) #\;)
   (setf (aref ar 11 4) #\')
   (setf (aref ar 12 4) #\Newline)
   (setf (aref ar 13 4) #\Newline)
   (setf (aref ar 19 4) #\4)
   (setf (aref ar 20 4) #\5)
   (setf (aref ar 21 4) #\6)
   (setf (aref ar 22 4) #\+)
   ;; Z row
   (setf (aref ar 0 5) 'shift)
   (setf (aref ar 1 5) #\z)
   (setf (aref ar 2 5) #\x)
   (setf (aref ar 3 5) #\c)
   (setf (aref ar 4 5) #\v)
   (setf (aref ar 5 5) #\b)
   (setf (aref ar 6 5) #\n)
   (setf (aref ar 7 5) #\m)
   (setf (aref ar 8 5) #\,)
   (setf (aref ar 9 5) #\.)
   (setf (aref ar 10 5) #\/)
   (setf (aref ar 11 5) 'shift)
   (setf (aref ar 12 5) 'shift)
   (setf (aref ar 16 5) #\UpArrow)
   (setf (aref ar 19 5) #\1)
   (setf (aref ar 20 5) #\2)
   (setf (aref ar 21 5) #\3)
   (setf (aref ar 22 5) #\Enter)
   ;; space bar row
   (setf (aref ar 0 6) 'control)
   (setf (aref ar 1 6) 'option)
   (setf (aref ar 2 6) 'command)
   (setf (aref ar 3 6) #\Space)
   (setf (aref ar 4 6) #\Space)
   (setf (aref ar 5 6) #\Space)
   (setf (aref ar 6 6) #\Space)
   (setf (aref ar 7 6) #\Space)
   (setf (aref ar 8 6) #\Space)
   (setf (aref ar 9 6) #\Space)
   (setf (aref ar 10 6) #\Space)
   (setf (aref ar 11 6) 'command)
   (setf (aref ar 12 6) 'option)
   (setf (aref ar 13 6) 'control)
   (setf (aref ar 15 6) #\BackArrow)
   (setf (aref ar 16 6) #\DownArrow)
   (setf (aref ar 17 6) #\ForwardArrow)
   (setf (aref ar 19 6) #\0)
   (setf (aref ar 20 6) #\0)
   (setf (aref ar 21 6) #\.)
   (setf (aref ar 22 6) #\Enter)
   ar)


;;;; 
---------------------------------------------------------------------- 
;;;;
;;;; Focus ring stuff


(defclass focal-view (view)
   ()
   (:default-initargs
     :view-size #@(19 19)))


;;; VIEW-DRAW-CONTENTS      [Method]
;;; Date        : 00.07.11
;;; Description : Draws a red ring around the attended location.  MCL
;;;             : sometimes draws funny if the pen and such are not
;;;             : restored, so there's a bunch of odd bookkeeping here.

(defmethod view-draw-contents ((self focal-view))
   (let ((oldmode (pen-mode self))
         (oldpat (pen-pattern self))
         (oldsize (pen-size self)))
     (set-pen-mode self :pator)
     (set-pen-pattern self *light-gray-pattern*)
     (set-pen-size self 4 4)
     (with-focused-view self
       (with-fore-color *red-color*
         (frame-oval self 0 0 (point-h (view-size self))
                     (point-v (view-size self)))))
     (set-pen-mode self oldmode)
     (set-pen-pattern self oldpat)
     (set-pen-size self (point-h oldsize) (point-v oldsize))
     ))


;;; UPDATE-ME      [Method]
;;; Date        : 00.07.11
;;; Description : Udating the focus ring means changing its location, possibly
;;;             : adding the subview, and forcing a redraw.

(defmethod update-me ((foc-ring focal-view) window xyloc)
   (set-view-position foc-ring
                      (- (px xyloc) 10)
                      (- (py xyloc) 10))
   (unless (equal (view-window foc-ring) window)
     (add-subviews window foc-ring))
   (event-dispatch)
   (view-draw-contents foc-ring))


;;; BUILD-FEATURES-FOR      [Method]
;;; Date        : 00.07.11
;;; Description : We don't want icon features for the focus ring, and since
;;;             : it'll be a subview a null BUILD-FEATURES-FOR method is
;;;             : necessary.

(defmethod build-features-for ((self focal-view) (vis-mod vision-module))
   (declare (ignore self vis-mod))
   nil)


;;; POINT-IN-CLICK-REGION-P      [Method]
;;; Date        : 00.07.11
;;; Description : The focus ring will generally be the "front" view, but
;;;             : having it receive clicks is a Bad Thing (tm) so it's
;;;             : necessary to override the POINT-IN-CLICK-REGION-P method
;;;             : for this view class.

(defmethod point-in-click-region-p ((self focal-view) where)
   (declare (ignore where))
   nil)

;;; make the fous ring

(eval-when (load eval)
   (setf *attn-tracker* (make-instance 'focal-view)))


;;;  -*- mode: LISP; Package: CL-USER; Syntax: COMMON-LISP;  Base: 10 -*-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Author      : Mike Byrne
;;; Copyright   : (c)1997-2001 CMU/Rice U./Mike Byrne, All Rights Reserved
;;; Availability: public domain
;;; Address     : Rice University
;;;             : Psychology Department
;;;             : Houston,TX 77251-1892
;;;             : byrne@acm.org
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Filename    : motor-module.lisp
;;; Version     : 2.1b1
;;;
;;; Description : Source code for the ACT-R/PM "motor module."
;;;
;;; Bugs        : No known open bugs.
;;;
;;; ----- History -----
;;; 01.08.07 mdb
;;;             : Changed the QUEUE-COMMAND for a cursor-ply so that it
;;;             : doesn't call min-run-time for the MP.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;




;;;; 
---------------------------------------------------------------------- 
;;;;
;;;; the Motor Module class itself
;;;; 
---------------------------------------------------------------------- 
;;;;


(defclass motor-module (pm-module)
   ((left-hand :accessor left-hand :initarg :left-hand
               :initform (make-instance 'hand))
    (right-hand :accessor right-hand :initarg :right-hand
                :initform (make-instance 'hand))
    (current-cursor :accessor current-cursor :initarg :current-cursor
                    :initform #(0 0))
    (feature-prep-time :accessor feat-prep-time  :initarg :feat-prep-time
                       :initform 0.050)
    (movement-initiation-time :accessor init-time :initarg :init-time
                              :initform 0.050)
    (default-target-width :accessor target-width :initarg :target-width
      :initform 1.0)
    (peck-fitts-coeff :accessor peck-fitts-coeff :initarg :peck-fitts-coeff
                      :initform 0.075)
    (min-fitts-time :accessor min-fitts-time :initarg :min-fitts-time
                    :initform 0.100)
    (incremental-mouse-p :accessor incremental-mouse-p
                         :initarg :incremental-mouse-p :initform nil)
    )
   (:default-initargs
     :name :MOTOR))



(defmethod initialize-instance :after ((mtr-mod motor-module) &key)
   (home-hands mtr-mod)
   (setf (state-dmo mtr-mod)
         (make-dme 'motor-state 'module-state
                   '(module :motor modality free processor free preparation free
                     execution free)
                   :where :external)))


;;; RESET-MODULE      [Method]
;;; Date        : 97.03.31
;;; Description : Resetting a motor module includes clearing the motor
;;;             : feature memory and resetting the hands to the 'home row'
;;;             : position.

(defmethod reset-module :after ((mtr-mod motor-module))
   (setf (current-cursor mtr-mod) #(0 0))
   (home-hands mtr-mod))




;;;; 
---------------------------------------------------------------------- 
;;;;
;;;; the HAND class
;;;; 
---------------------------------------------------------------------- 
;;;;

(defclass hand ()
   ((location :accessor loc)
    (finger-offsets :accessor fingers :initarg :fingers)))


(defgeneric finger-loc (the-hand finger)
   (:documentation  "Return the absolute XY coordinate of <finger>"))

(defmethod finger-loc ((the-hand hand) finger)
   (let ((fngr-offset (second (assoc finger (fingers the-hand)))))
     (vector (+ (px (loc the-hand)) (px fngr-offset))
             (+ (py (loc the-hand)) (py fngr-offset)))))


(defgeneric move-finger (the-hand finger r theta)
   (:documentation  "Returns new XY loc of finger after a move of r, 
theta.  Also modifies finger offset."))

(defmethod move-finger ((the-hand hand) finger r theta)
   (unless (= theta 0.)
     (setf (second (assoc finger (fingers the-hand)))
           (polar-move-xy (second (assoc finger (fingers the-hand)))
                          (vector r theta))))
   (finger-loc the-hand finger))


(defgeneric move-hand (the-hand r theta)
   (:documentation  "Moves the hand to a new location"))

(defmethod move-hand ((the-hand hand) r theta)
   (setf (loc the-hand) (polar-move-xy (loc the-hand) (vector r theta))))


;;;; 
---------------------------------------------------------------------- 
;;;;
;;;; Support methods
;;;; 
---------------------------------------------------------------------- 
;;;;


(defmethod current-cursor-loc ()
   (get-mouse-coordinates (device (device-interface *mp*))))


;;; MOVE-A-FINGER      [Method]
;;; Date        : 97.02.14
;;; Description : Moves a finger on the specified hand.

(defgeneric move-a-finger (mtr-mod hand finger r theta)
   (:documentation  "Moves a finger, returning the new XY location"))

(defmethod move-a-finger ((mtr-mod motor-module) hand finger r theta)
   (ecase hand
     (right (move-finger (right-hand mtr-mod) finger r theta))
     (left (move-finger (left-hand mtr-mod) finger r theta))))


;;; MOVE-A-HAND      [Method]
;;; Date        : 97.02.25
;;; Description : Moves a hand to the specified location

(defgeneric move-a-hand (mtr-mod hand r theta)
   (:documentation  "Moves a hand, returning the new XY location"))

(defmethod move-a-hand ((mtr-mod motor-module) hand r theta)
   (ecase hand
     (right (move-hand (right-hand mtr-mod) r theta))
     (left (move-hand (left-hand mtr-mod) r theta))))


;;; FINGER-LOC-M      [Method]
;;; Date        : 97.02.17
;;; Description : Module-level call to determine the location of a finger.

(defgeneric finger-loc-m (mtr-mod hand finger)
   (:documentation  "Return the XY location of the specified finger"))

(defmethod finger-loc-m ((mtr-mod motor-module) hand finger)
   (ecase hand
     (right (finger-loc (right-hand mtr-mod) finger))
     (left (finger-loc (left-hand mtr-mod) finger))))


;;; HOME-HANDS      [Method]
;;; Date        : 97.02.20
;;; Description : Sets the hand and finger locations to the keyboard home row.

(defgeneric home-hands (mtr-mod)
   (:documentation  "Sets the hand and finger locations to home row locations"))

(defmethod home-hands ((mtr-mod motor-module))
   (setf (loc (right-hand mtr-mod)) #(7 4))
   (setf (loc (left-hand mtr-mod)) #(4 4))
   (setf (fingers (right-hand mtr-mod))
         '((index #(0 0)) (middle #(1 0)) (ring #(2 0)) (pinkie #(3 0))
           (thumb #(-1 2))))
   (setf (fingers (left-hand mtr-mod))
         '((index #(0 0)) (middle #(-1 0)) (ring #(-2 0)) (pinkie #(-3 0))
           (thumb #(-1 2))))
   )




;;; LOC-TO-KEY      [Method]
;;; Date        : 97.02.26
;;; Description : Given a location, return the corresponding character.
;;;             : Accessed via the 'virtual keyboard' array.

(defgeneric loc->key (mtr-mod loc)
   (:documentation  "Given an location, return the corresponding key"))

(defmethod loc->key ((mtr-mod motor-module) (loc vector))
   (if (vpt= loc #(28 2))
     'mouse
     (aref (loc->key-arr mtr-mod) (px loc) (py loc))))


;;;; 
---------------------------------------------------------------------- 
;;;;
;;;; Utility functions


(defun distance= (d1 d2)
   "Two distances are not equal if they are more than two degrees apart."
   (when (and d1 d2)
     (< 2.0 (abs (- d1 d2)))))


(defun direction= (d1 d2)
   "Two directions are not equal if they are more than pi/4 apart."
   (when (and d1 d2)
     (< (/ pi 4) (abs (- d1 d2)))))


(defun device->order (device)
   (ecase device
     (MOUSE 0)
     (JOYSTICK-1 1)
     (JOYSTICK-2 2)))


(defun check-specs (&rest specs)
   "If there is an invalid specification, return something, else NIL"
   (member nil specs))


(defgeneric xy-to-polar (from to)
   (:documentation  "Given a starting and ending location in xy, 
return polar difference"))

(defmethod xy-to-polar ((from vector) (to vector))
   (let ((distance (dist from to)))
     (vector distance
             (if (zerop distance)
               0.0
               (atan (- (py to) (py from))
                     (- (px to) (px from)))))))


(defmethod xy-to-polar ((from list) (to list))
   (xy-to-polar (coerce from 'vector) (coerce to 'vector)))


(defgeneric polar-move-xy (loc move)
   (:documentation  "Given an xy location and a polar displacement, 
return new xy"))

(defmethod polar-move-xy ((loc vector) (move vector))
   (round-xy
    (list (+ (px loc) (* (px move) (cos (py move))))
          (+ (py loc) (* (px move) (sin (py move)))))))

(defmethod polar-move-xy ((loc list) (move list))
   (polar-move-xy (coerce loc 'vector) (coerce move 'vector)))


;;; FITTS      [Function]
;;; Date        : 97.02.14, delta 99.06.18
;;; Description : Return Fitts law time for a given coefficient and distance,
;;;             : optionally supplying the target width (default is 1)

(defgeneric fitts (mtr-mod coef d &optional w)
   (:documentation  "Fitts law time for movement"))

(defmethod fitts ((mtr-mod motor-module) coef d &optional (w 1.0))
   (max (min-fitts-time mtr-mod)         ; 99.06.18
        (* coef (log (+ (/ d w) 0.5) 2))))



;;;; 
---------------------------------------------------------------------- 
;;;;
;;;; PUNCH class and methods

(defstyle punch () hand finger)


(defmethod compute-exec-time ((mtr-mod motor-module) (self punch))
   (+ (init-time mtr-mod) (key-closure-time (device-interface *mp*))))


(defmethod compute-finish-time ((mtr-mod motor-module) (self punch))
   (+ (init-time mtr-mod) (* 2 (burst-time mtr-mod))))


(defmethod feat-differences ((p1 punch) (p2 punch))
   (cond ((not (eq (hand p1) (hand p2))) 2)
         ((not (eq (finger p1) (finger p2))) 1)
         (t 0)))


(defmethod queue-output-events ((mtr-mod motor-module) (self punch))
   (queue-command
    :where :DEVICE :command 'OUTPUT-KEY :time (exec-time self)
    :params
    (move-a-finger mtr-mod (hand self) (finger self) 0 0)))


;;;; 
---------------------------------------------------------------------- 
;;;;
;;;; HAND-FINGER-R-THETA class and methods


(defstyle hfrt-movement () hand finger r theta)

(defmethod feat-differences ((m1 hfrt-movement) (m2 hfrt-movement))
   (let ((maxfeats (num-possible-feats m1)))
     (cond ((not (eq (hand m1) (hand m2))) (1- maxfeats))
           ((not (eq (finger m1) (finger m2))) (- maxfeats 2))
           (t
            (let ((nfeats 0))
              (unless (distance= (r m1) (r m2)) (incf nfeats))
              (unless (direction= (theta m1) (theta m2)) (incf nfeats))
              nfeats)))))


;;;; 
---------------------------------------------------------------------- 
;;;;
;;;; PECK class and methods

(defstyle peck hfrt-movement)

(defmethod compute-exec-time ((mtr-mod motor-module) (self peck))
   (+ (init-time mtr-mod)
      (max (burst-time mtr-mod)
           (rand-time
            (fitts mtr-mod (peck-fitts-coeff mtr-mod) (r self))))))   ; 99.06.18


(defmethod queue-output-events ((mtr-mod motor-module) (self peck))
   (queue-command
    :where :DEVICE :command 'OUTPUT-KEY :time (exec-time self)
    :params
    (move-a-finger mtr-mod (hand self) (finger self) (r self) (theta self))))


;;;; 
---------------------------------------------------------------------- 
;;;;
;;;; PECK-RECOIL class and methods

(defclass peck-recoil (hfrt-movement)
   ((move-time :accessor move-time))
   (:default-initargs
     :style-name :PECK))


(defmethod compute-exec-time ((mtr-mod motor-module) (self peck-recoil))
   (setf (move-time self)
         (max (burst-time mtr-mod)
              (fitts mtr-mod (peck-fitts-coeff mtr-mod) (r self))))   ; 99.06.18
   (+ (init-time mtr-mod)
      (max (burst-time mtr-mod)
           (rand-time (move-time self)))))


(defmethod compute-finish-time ((mtr-mod motor-module) (self peck-recoil))
   (+ (exec-time self) (burst-time mtr-mod)
      (max (burst-time mtr-mod)
           (rand-time (move-time self)))))


(defmethod queue-output-events ((mtr-mod motor-module) (self peck-recoil))
   (queue-command
    :where :DEVICE :command 'OUTPUT-KEY :time (exec-time self)
    :params
    (polar-move-xy (finger-loc-m mtr-mod (hand self) (finger self))
                   (vector (r self) (theta self)))))


(defmethod peck-recoil ((mtr-mod motor-module) &key hand finger r theta)
   (unless (or (check-jam mtr-mod) (check-specs hand finger r theta))
     (when (symbolp theta)
       (setf theta (symbol-value theta)))
     (prepare-movement mtr-mod
                       (make-instance 'peck-recoil :hand hand :finger finger
                                      :r r :theta theta))))

;;;; 
---------------------------------------------------------------------- 
;;;;
;;;; PLY classes and methods

(defclass ply (hfrt-movement)
   ((fitts-coeff :accessor fitts-coeff :initarg :fitts-coeff)
    (target-width :accessor target-width :initarg :target-width
                  :initform (target-width (motor-m *mp*))))
   (:default-initargs
     :finger :dummy
     :style-name :PLY))


(defmethod compute-exec-time ((mtr-mod motor-module) (self ply))
   (+ (init-time mtr-mod)
      (rand-time (fitts mtr-mod (fitts-coeff self) (r self)
                        (target-width self)))))


(defmethod num-possible-feats :around ((self ply))
   (- (call-next-method) 1))


(defclass hand-ply (ply)
   ()
   (:default-initargs
     :fitts-coeff (when *mp* (mouse-fitts-coeff (device-interface *mp*)))))


(defmethod queue-output-events ((mtr-mod motor-module) (self hand-ply))
   (queue-command
    :where :MOTOR :command 'MOVE-A-HAND :time (exec-time self)
    :params (list (hand self) (r self) (theta self))))


(defclass cursor-ply (ply)
   ((target-coords :accessor target-coords :initarg :target-coords)
    (control-order :accessor control-order :initarg :control-order :initform 0))
   (:default-initargs
     :hand 'RIGHT
     :fitts-coeff (when *mp* (mouse-fitts-coeff (device-interface *mp*)))))


(defmethod compute-exec-time :before ((mtr-mod motor-module)
                                          (self cursor-ply))
   (setf (fitts-coeff self)
         (* (expt 2 (control-order self)) (fitts-coeff self))))


;;; QUEUE-OUTPUT-EVENTS      [Method]
;;; Date        : 99.04.02
;;; Description : New output queueing for cursor moves.  The move is broken
;;;             : up into pieces to provide the illusion of smooth movement.
;;;             : Queue up the pieces.  The last submovement doesn't move
;;;             : with a polar move, though, because small rounding errors
;;;             : accumulate and the target will be missed by a couple
;;;             : pixels.

(defmethod queue-output-events ((mtr-mod motor-module) (self cursor-ply))
   (let* ((total-time (exec-time self))
          (nsteps (round total-time (min-run-time (cog-m *mp*))))
          (steplen nil))
     (when (incremental-mouse-p mtr-mod)
       (when (= nsteps 0) (setf nsteps 1))
       (setf steplen (/ (r self) nsteps))
       (when (> nsteps 1)
         (dotimes (idx (- nsteps 1))
           (queue-command
            :command 'MOVE-CURSOR-POLAR :where :DEVICE
            :time (* (exec-time self) (/ idx nsteps))
            :params (list (list
                           (pm-angle-to-pixels steplen) (theta self)))))))
     (queue-command
      :command 'MOVE-CURSOR-ABSOLUTE :where :DEVICE
      :time (exec-time self)
      :params (list (target-coords self)))
     (setf (current-cursor mtr-mod) (target-coords self))))


(defmethod point-hand ((mtr-mod motor-module) &key hand r theta)
   (unless (or (check-jam mtr-mod) (check-specs hand r theta))
     (prepare-movement mtr-mod
                       (make-instance 'hand-ply :hand hand :r r :theta theta))))


;;; MOVE-CURSOR      [Method]
;;; Date        : 99.04.02
;;; Description : To get the movement time right, the effective width of the
;;;             : target has to be computed.  Gotta have the target object
;;;             : for that, which should be available through the supplied
;;;             : location or object.

(defmethod move-cursor ((mtr-mod motor-module) &key loc object
                           (device 'MOUSE))
   (unless (or (check-jam mtr-mod) (check-specs (or loc object) device))
     (let ((r-theta nil)
           (feat nil))
       (setf feat
             (if object
               (obj-to-feat (vis-m *mp*) (psdme-to-dmo object))
               (loc-to-feat (vis-m *mp*) (psdme-to-dmo loc))))
       (setf r-theta (xy-to-polar (current-cursor mtr-mod) (xy-loc feat)))
       (when (not (= 0 (vr r-theta)))        ; r=0 is a no-op
         (prepare-movement mtr-mod
                           (make-instance 'cursor-ply
                             :r (pm-pixels-to-angle (vr r-theta))
                             :theta (vtheta r-theta)
                             :target-width (approach-width feat 
(vtheta r-theta))
                             :target-coords (xy-loc feat)
                             :control-order (device->order device)))))))


;;;; 
---------------------------------------------------------------------- 
;;;;
;;;; Re-mapped methods


;;; CLICK-MOUSE      [Method]
;;; Date        : 97.02.13
;;; Description : Clicking the mouse is really just a punch with the right
;;;             : index finger.

(defgeneric click-mouse (mtr-mod)
   (:documentation  "Execute a mouse click operation (a punch)"))

(defmethod click-mouse ((mtr-mod motor-module))
   (if (vpt= (loc (right-hand mtr-mod)) #(28 2))
     (punch mtr-mod :hand 'right :finger 'index)
     (pm-warning "CLICK-MOUSE requested when hand not at mouse!")))


;;; left in for backwards compatibility only
(defmethod move-mouse ((mtr-mod motor-module) location)
   (move-cursor mtr-mod :device 'mouse :loc location))


;;; PRESS-KEY      [Method]
;;; Date        : 97.02.18
;;; Description : Allows execution of key presses without computing movements
;;;             : to the keys and such.  Just does it via hash table lookup,
;;;             : all the 'intelligence' is in the hash table.

(defgeneric press-key (mtr-mod key)
   (:documentation  "High-level interface to press a key: Look up the 
command and execute it."))

(defmethod press-key ((mtr-mod motor-module) key)
   (when (stringp key)
     (setf key (read-from-string key)))
   (let ((command (key->cmd (device-interface *mp*) key)))
     (apply (first command) mtr-mod (rest command))))


(defgeneric point-hand-at-key (mtr-mod &key hand to-key)
   (:documentation  "Move the hand to a new location, specified by the 
key at which the index finger should point."))

(defmethod point-hand-at-key ((mtr-mod motor-module) &key hand to-key)
   (when (stringp to-key)
     (setf to-key (read-from-string to-key)))
   (let* ((cur-hand (ecase hand
                        (right (right-hand mtr-mod))
                        (left (left-hand mtr-mod))))
          (new-polar (xy-to-polar (loc cur-hand)
                                    (key-to-loc (keyboard 
(device-interface *mp*))
                                                to-key))))
     (point-hand mtr-mod :hand hand :r (vr new-polar)
                 :theta (vtheta new-polar))))


;;; HAND-TO-MOUSE      [Method]
;;; Date        : 97.02.25
;;; Description : Moves the right hand to the mouse.  Yes, I know the mouse
;;;             : location is hard-coded, but that's the way life is.  Just
;;;             : translates the movement into a POINT-HAND.

(defgeneric hand-to-mouse (mtr-mod)
   (:documentation  "Moves the right hand to the mouse"))

(defmethod hand-to-mouse ((mtr-mod motor-module))
   (unless (vpt= (loc (right-hand mtr-mod)) #(28 2))
     (let ((polar (xy-to-polar (loc (right-hand mtr-mod)) #(28 2))))
       (point-hand mtr-mod :hand 'right :r (vr polar)
                   :theta (vtheta polar)))))


;;; HAND-TO-HOME      [Method]
;;; Date        : 97.02.25
;;; Description : Same thing as HAND-TO-MOUSE but in the other direction.

(defgeneric hand-to-home (mtr-mod)
   (:documentation  "Moves the right hand to the home row position 
from the mouse loc"))

(defmethod hand-to-home ((mtr-mod motor-module))
   (unless (equal (loc (right-hand mtr-mod)) #(7 4))
     (let ((polar (xy-to-polar (loc (right-hand mtr-mod)) #(7 4))))
       (point-hand mtr-mod :hand 'right :r (vr polar)
                   :theta (vtheta polar)))))



;;;  -*- mode: LISP; Package: CL-USER; Syntax: COMMON-LISP;  Base: 10 -*-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Author      : Mike Byrne
;;; Copyright   : (c)1999 CMU/Mike Byrne, All Rights Reserved
;;; Availability: public domain
;;; Address     : Carnegie Mellon University
;;;             : Psychology Department
;;;             : Pittsburgh,PA 15213-3890
;;;             : byrne@acm.org
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Filename    : patch-support.lisp
;;; Version     : 1.0
;;;
;;; Description : Support functions for adding patches to RPM.
;;;
;;; Bugs        :
;;;
;;; Todo        :
;;;
;;; ----- History -----
;;; 99.07.07 Mike Byrne
;;;             :  Incept date.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


(defmethod add-patchstr ((mstr-proc master-process) patchstr)
   "Add a patch string to the main RPM version string."
   (unless (search patchstr (version-string mstr-proc))
     (setf (version-string mstr-proc)
           (mkstr (version-string mstr-proc) patchstr))))


;;;; 
---------------------------------------------------------------------- 
;;;;
;;;; Stuff for messing with RPM parameters.

(defun add-parameter (param)
   "Add a PM parameter."
   (when (assoc (name param) (param-lis *mp*))
     (delete-parameter (name param)))
   (push (list (name param) param) (param-lis *mp*))
   (setf (param-lis *mp*)
         (sort (param-lis *mp*) #'key-lessp :key #'first)))


(defun delete-parameter (name)
   "Delete a PM parameter."
   (setf (param-lis *mp*)
         (delete name (param-lis *mp*) :key 'first)))


(defun key-lessp (k1 k2)
   "Determine if a keyword name is less than another."
   (string-lessp (mkstr k1) (mkstr k2)))






;;;; Christian's code to patch the production matcher for RPM.  Thanks,
;;;; Christian!!

(defvar *pm-calls*
   '((visual-location
      find-location-fct
      (attended :attended)
      (screen-x :screen-x)
      (screen-y :screen-y)
      (value :value)
      (kind :kind)
      (color :color)
      (size :size)
      (nearest :nearest)
      (time))
     (audio-event
      find-sound-fct
      (attended :attended)
      (onset :onset)
      (offset :offset)
      (pitch :pitch)
      (kind :type)
      (objects)
      (time))
     (module-state
      module-state-fct
      (module :module)
      (preparation :preparation)
      (processor :processor)
      (execution :execution)
      (modality :modality)
      (last-command :last-command))
     (visual-object current-visual-object)
     (sound current-sound-fct))
   "Mapping between chunk types and fcts and if applicable slot names
    and keyword arguments for calls to the perceptual/motor layer.")

#|
(defun test-equal (first second)
   (format t "~%TESTING ~S and ~S~%" first second)
   (equal first second))
|#

(defun sub-eval-vars (expr bindings &optional (fct-call t))
   "Substitute stack reference for production variables in evaled expressions.
    Return a function to be funcalled rather than a form to be evaled, 
which for all
    but the simplest ones causes the compiler to be called every time, unless
    *compile-eval-calls* has been turned off."
   (let ((new-expr (list (copy-tree expr))))
     (dolist (binding bindings (if fct-call
                                 (if *compile-eval-calls*
                                   (compile nil `(lambda () ,(first new-expr)))
                                   (eval `(function (lambda () ,(first 
new-expr)))))
                                 (first new-expr)))
       (nsubst `(get-wme-name (svref *instantiation* ,(variable-index binding)))
               (variable-name binding) new-expr :test #'eq))))


(defun compile-lhs (production lhs bindings index)
   "Compiles the left-hand side of production.  Add the 
instantiation-adding call."
   (let ((code nil)
         (form nil))
     (dolist (clause lhs)
       (let ((key (pop clause))
             (type nil)
             (tests nil)
             (binds nil)
             (slot nil)
             (value nil)
             (negation nil))
         (setf form
               (cond
                ((retrievalp key)
                 (setf key (var>var key))
                 (with-binding binding direct key bindings index
                   (set-variable-type production type key (pop clause))
                   (when type
                     (cond ((or (and (member (wme-type-name type) 
'(visual-location audio-event) :test #'eq)
                                     (member '(time now) clause :test #'equal))
                                (eq (wme-type-name type) 'module-state))
                            (setf clause (delete '(time now) clause 
:test #'equal))
                            (setf (variable-type binding) type)
                            (let* ((fct-args (rest (assoc 
(wme-type-name type) *pm-calls* :test #'eq)))
                                   (pm-call (list (first fct-args)))
                                   (argument-alist (rest fct-args)))
                              (dolist (slot-value clause)
                                (let* ((negation (when (equal (first 
slot-value) '-)
                                                   (pop slot-value)))
                                       (slot (first slot-value))
                                       (value (second slot-value))
                                       (mapping (assoc slot argument-alist)))
                                       (cond (mapping
                                              (when (and (or (not 
(variablep value))
 
(get-variable-binding value bindings))
                                                         (second mapping))
                                                (setf value 
(sub-eval-vars value bindings nil))
                                                (nconc pm-call (list 
(second mapping)
 
(if negation
 
(list 'pm-not-equal value)
 
value)))))
                                             (t
                                              (signal-warn "SLOT ~S OF 
CHUNK ~S TYPE ~S IN PRODUCTION ~S IS UNDEFINED."
                                                           slot key 
type production)))))
                              (compile-lhs-slots tests binds)
                              (list (if (and *enable-rational-analysis* code)
                                      ; the goal cannot be partial-matched
                                      'external-test-and-bind-pm
                                      'external-test-and-bind)
                                    (variable-index binding)
                                    pm-call
                                    type nil binds)))
                           ((and (or (member 'visual-object 
(wme-type-supertypes type)
                                             :test #'eq :key #'wme-type-name)
                                     (member 'sound (wme-type-supertypes type)
                                             :test #'eq :key #'wme-type-name))
                                 (member '(time now) clause :test #'equal))
                            (setf clause (delete '(time now) clause 
:test #'equal))
                            (setf (variable-type binding) type)
                            (compile-lhs-slots tests binds)
                            (list (if (and *enable-rational-analysis* code)
                                  ; the goal cannot be partial-matched
                                    'external-test-and-bind-pm
                                    'external-test-and-bind)
                                  (variable-index binding)
                                  (list (second (assoc (if (member 
'visual-object (wme-type-supertypes type)
 
:test #'eq :key #'wme-type-name)
                                                         'visual-object 'sound)
                                                       *pm-calls* :test #'eq)))
                                  type tests binds))
                         (t
                          (setf (variable-type binding) type)
                          (compile-lhs-slots tests binds)
                          (list (if (and *enable-rational-analysis* code)
                                  ; the goal cannot be partial-matched
                                  (if direct 'direct-test-and-bind-pm
                                      'indirect-test-and-bind-pm)
                                  (if direct 'direct-test-and-bind
                                      'indirect-test-and-bind))
                                (variable-index binding) type tests binds))))))
                ((eq '!eval! key)
                 (list 'eval-test (sub-eval-vars (first clause) bindings)))
                ((eq '!bind! key)
                 (with-binding binding bound (first clause) bindings index
                   (when bound
                     (signal-warn "VARIABLE ~S ALREADY BOUND IN PRODUCTION ~A."
                                  (first clause) production))
                   (list 'bind-lhs (variable-index binding)
                         (sub-eval-vars (second clause) bindings))))
                ((eq '!find-location! key)
                 (with-binding binding bound (first clause) bindings index
                   (when bound
                     (signal-warn "VARIABLE ~S ALREADY BOUND IN PRODUCTION ~A."
                                  (first clause) production))
                   (list 'bind-find-location (variable-index binding)
                         (sub-eval-vars (cons 'list (quote-arguments 
(rest clause)))
                                        bindings))))
                (t (signal-warn "UNKNOWN COMMAND ~S IN PRODUCTION ~A."
                                key production))))
         (setf code (nconc code form))))
     ;; FIX: split into goal and retrievals when ERA is enabled.
     (values (if *enable-rational-analysis*
               (let ((direct-length (first-retrieval-index code)))
                 (cons (nconc (subseq code 0 direct-length) (list 
'add-instantiation-to-conflict-set))
                       (nconc (subseq code direct-length) (list 'not))))
               (nconc code (list 'add-instantiation-to-conflict-set)))
             index)))

(defun external-test-and-bind (arguments)
   "Implements a direct match.  Tests for type and then slots, then bind
    variables.  Finally, call the function implementing the next clause.
    Arguments is a list of the wme's stack index, its type, a list of slots
    tests and bindings, and the next call if any.
    Returns t if a complete match is found, nil otherwise."
   (let* ((wme-index (pop arguments))
          ;; FIX: get the current visual or sound object by calling the PM layer
          ;; If the variable is already bound, test that it is identical
          (external-call (pop arguments))
          (wme (apply (first external-call) (rest external-call)))
          (binding (instantiation-variable *instantiation* wme-index))
          (wmetype (pop arguments))
          (slots-tested (pop arguments))
          (slots-bound (pop arguments)))
     (cond ((and binding (not (eq wme binding)))
            (signal-output *exact-matching-trace* "Current visual 
object ~S does not match existing binding ~S."
                           wme binding))
           (t
            (unless binding
              (setf (instantiation-variable *instantiation* wme-index) wme))
            (if (and (wmep wme) (subtype (wme-type wme) wmetype))
              (let ((slots (wme-slots wme)))
                ;; Set bindings before testing slots
                (and (set-bindings slots slots-bound)
                    ;; FIX: The retrieval threshold does not apply to PM calls
                     (let ((*retrieval-threshold* nil))
                       (test-slots wme slots slots-tested wme-index))
                     (simulate-call arguments)))
              (signal-output *exact-matching-trace* "~S is not a CHUNK 
of type ~S."
                             wme wmetype))))))

(defun external-test-and-bind-pm (arguments)
   "Implements a direct match.  Tests for type and then slots, then bind
    variables.  Finally, call the function implementing the next clause.
    Arguments is a list of the wme's stack index, its type, a list of slots
    tests and bindings, and the next call if any.
    This is the rational analysis version, which handles partial matching too."
   (let* ((wme-index (pop arguments))
          ;; FIX: get the current visual or sound object by calling the PM layer
          ;; If the variable is already bound, test that it is identical
          (external-call (pop arguments))
          (wme (apply (first external-call) (rest external-call)))
          (binding (instantiation-variable *instantiation* wme-index))
          (wmetype (pop arguments))
          (slots-tested (pop arguments))
          (slots-bound (pop arguments)))
     (cond ((and binding (not (eq wme binding)))
            (signal-output *exact-matching-trace* "Current visual 
object ~S does not match existing binding ~S."
                           wme binding))
           ((and (wmep wme) (subtype (wme-type wme) wmetype))
            (unless binding
              (setf (instantiation-variable *instantiation* wme-index) wme))
            (let* ((slots (wme-slots wme))
                   ;; Set bindings before testing slots
                   (activation (and (set-bindings slots slots-bound)
                                    ;; FIX: The retrieval threshold 
does not apply to PM calls
                                    (let ((*retrieval-threshold* 
most-negative-short-float))
                                      (if *partial-matching*
                                        (test-slots-pm wme slots slots-tested)
                                        (test-slots wme slots slots-tested))))))
              ;; FIX: Do not increment the latency
              ;; (add-latency wme (or activation *retrieval-threshold*))
              (when activation
                (simulate-call arguments))))
           (t
            ;; FIX: Do not increment the latency
            ;; (add-latency wme *retrieval-threshold*)
            (signal-output *exact-matching-trace* "~S is not a CHUNK 
of type ~S."
                           wme wmetype)))))

#|
(defun compile-lhs (production lhs bindings index)
   "Compiles the left-hand side of production.
    Add the instantiation-adding call."
   (let ((code nil)
         (form nil))
     (dolist (clause lhs)
       (let ((key (pop clause))
             (type nil)
             (tests nil)
             (binds nil)
             (slot nil)
             (value nil)
             (negation nil))
         (setf form
               (cond
                ((retrievalp key)
                 (setf key (var>var key))
                 (with-binding binding direct key bindings index
                   (set-variable-type production type key (pop clause))
                   (cond ((and (eq (wme-type-name type) 'visual-location)
                               (member '(time now) clause :test #'equal))
                          ;; FIX: match of type visual location with time now
                          ;; is interpreted as a call to the 
perceptual/motor layer
                          ;; instead of a declarative memory retrieval
                          ;; The function find-location-fct takes each slot test
                          ;; as the equivalent keyword value supplied.
                          (let ((find-location-call (list 'find-location-fct))
                                (argument-alist '((attended . :attended)
                                                  (screen-x . :screen-x)
                                                  (screen-y . :screen-y)
                                                  (value . :value)
                                                  (kind . :isa))))
                            (dolist (slot-value clause)
                              (let ((slot (first slot-value)))
                                (unless (eq slot 'time)
                                  (let ((keyword (rest (assoc slot 
argument-alist))))
                                    (if (null keyword)
                                      (signal-warn "SLOT ~S OF VISUAL 
LOCATION ~S IN PRODUCTION ~S IS UNDEFINED."
                                                   slot key production)
                                      (nconc find-location-call
                                             (cons keyword
                                                   (quote-arguments 
(rest slot-value)))))))))
                            (list 'bind-lhs (variable-index binding)
                                  (sub-eval-vars find-location-call bindings))))
                         ((and (eq (wme-type-name type) 'audio-event)
                               (member '(time now) clause :test #'equal))
                          ;; FIX: match of type audio event with time now
                          ;; is interpreted as a call to the 
perceptual/motor layer
                          ;; instead of a declarative memory retrieval
                          ;; The function find-sound-fct takes each slot test
                          ;; as the equivalent keyword value supplied.
                          (let ((find-sound-call (list 'find-sound-fct))
                                (argument-alist '((attended . :attended)
                                                  (onset . :onset)
                                                  (offset . :offset)
                                                  (pitch . :pitch)
                                                  (objects . nil))))
                            (dolist (slot-value clause)
                              (let ((slot (first slot-value)))
                                (unless (eq slot 'time)
                                  (let ((keyword (rest (assoc slot 
argument-alist))))
                                    (if (null keyword)
                                      (signal-warn "SLOT ~S OF AUDIO 
EVENT ~S IN PRODUCTION ~S IS UNDEFINED."
                                                   slot key production)
                                      (when (rest slot-value)
                                        (nconc find-sound-call
                                               (cons keyword
                                                     (quote-arguments 
(rest slot-value))))))))))
                            (list 'bind-lhs (variable-index binding)
                                  (sub-eval-vars find-sound-call bindings))))
                         ((and (eq (wme-type-name type) 'module-state))
                          ;; FIX: match of type audio event with time now
                          ;; is interpreted as a call to the 
perceptual/motor layer
                          ;; instead of a declarative memory retrieval
                          ;; The function module-state-fct takes each slot test
                          ;; as the equivalent keyword value supplied.
                          (let ((module-state-call (list 'module-state-fct))
                                (argument-alist '((module . :module)
                                                  (preparation . :preparation)
                                                  (execution . :execution)
                                                  (modality . :modality)
                                                  (last-command . 
:last-command))))
                            (dolist (slot-value clause)
                              (let ((slot (first slot-value)))
                                (let ((keyword (rest (assoc slot 
argument-alist))))
                                  (if (null keyword)
                                    (signal-warn "SLOT ~S OF MODULE 
STATE ~S IN PRODUCTION ~S IS UNDEFINED."
                                                 slot key production)
                                    (when (rest slot-value)
                                      (nconc module-state-call
                                             (cons keyword
                                                   (quote-arguments 
(rest slot-value)))))))))
                            (list 'bind-lhs (variable-index binding)
                                  (sub-eval-vars module-state-call bindings))))
                         ((and (member 'visual-object (wme-type-supertypes type)
                                       :test #'eq :key #'wme-type-name)
                               (member '(time now) clause :test #'equal))
                          ;; FIX: match of type visual-object (or 
subtype) with time now
                          ;; is interpreted as a call to the 
perceptual/motor layer
                          ;; instead of a declarative memory retrieval
                          ;; current-visual-object returns the current focus
                          (setf clause (delete '(time now) clause 
:test #'equal))
                          (setf (variable-type binding) type)
                          (compile-lhs-slots tests binds)
                          (list (if (and *enable-rational-analysis* code)
                                  ; the goal cannot be partial-matched
                                  'external-test-and-bind-pm
                                  'external-test-and-bind)
                                (variable-index binding) 
'current-visual-object type tests binds))
                         ((and (member 'sound (wme-type-supertypes type)
                                       :test #'eq :key #'wme-type-name)
                               (member '(time now) clause :test #'equal))
                          ;; FIX: match of type sound (or subtype) with time now
                          ;; is interpreted as a call to the 
perceptual/motor layer
                          ;; instead of a declarative memory retrieval
                          ;; current-sound-fct returns the current focus
                          (setf clause (delete '(time now) clause 
:test #'equal))
                          (setf (variable-type binding) type)
                          (compile-lhs-slots tests binds)
                          (list (if (and *enable-rational-analysis* code)
                                  ; the goal cannot be partial-matched
                                  'external-test-and-bind-pm
                                  'external-test-and-bind)
                                (variable-index binding) 
'current-sound-fct type tests binds))
                         (type
                          (setf (variable-type binding) type)
                          (compile-lhs-slots tests binds)
                          (list (if (and *enable-rational-analysis* code)
                                  ; the goal cannot be partial-matched
                                  (if direct 'direct-test-and-bind-pm
                                      'indirect-test-and-bind-pm)
                                  (if direct 'direct-test-and-bind
                                      'indirect-test-and-bind))
                                (variable-index binding) type tests binds))
                         (t))))
                ((eq '!eval! key)
                 (list 'eval-test (sub-eval-vars (first clause) bindings)))
                ((eq '!bind! key)
                 (with-binding binding bound (first clause) bindings index
                   (when bound
                     (signal-warn "VARIABLE ~S ALREADY BOUND IN PRODUCTION ~A."
                                  (first clause) production))
                   (list 'bind-lhs (variable-index binding)
                         (sub-eval-vars (second clause) bindings))))
                ((eq '!find-location! key)
                 (with-binding binding bound (first clause) bindings index
                   (when bound
                     (signal-warn "VARIABLE ~S ALREADY BOUND IN PRODUCTION ~A."
                                  (first clause) production))
                   (list 'bind-find-location (variable-index binding)
                         (sub-eval-vars (cons 'list (quote-arguments 
(rest clause)))
                                        bindings))))
                (t (signal-warn "UNKNOWN COMMAND ~S IN PRODUCTION ~A."
                                key production))))
         (setf code (nconc code form))))
     ;; FIX: split into goal and retrievals when ERA is enabled.
     (values (if *enable-rational-analysis*
               (let ((direct-length (first-retrieval-index code)))
                 (cons (nconc (subseq code 0 direct-length) (list 
'add-instantiation-to-conflict-set))
                       (nconc (subseq code direct-length) (list 'not))))
               (nconc code (list 'add-instantiation-to-conflict-set)))
             index)))
|#



;;;  -*- mode: LISP; Package: CL-USER; Syntax: COMMON-LISP;  Base: 10 -*-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Author      : Mike Byrne
;;; Copyright   : (c)2000-2002 Rice U./Mike Byrne, All Rights Reserved
;;; Availability: public domain
;;; Address     : Rice University
;;;             : Psychology Department
;;;             : Houston,TX 77251-1892
;;;             : byrne@acm.org
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Filename    : pm-module.lisp
;;; Version     : 2.1b4
;;;
;;; Description : Base class for the perceptual-motor modules.
;;;
;;; Bugs        :
;;;
;;; Todo        : [] Remove state chunk stuff.
;;;
;;; ----- History -----
;;; 01.07.27 mdb
;;;             : Started 5.0 conversion.
;;; 02.01.21 mdb
;;;             : Removed obsolete PROC-S function, renamed slot value function
;;;             : to be PROC-S.  Added INITIAITON-COMPLETE call.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;;;; 
---------------------------------------------------------------------- 
;;;;
;;;; Perceptual/motor Modules base class
;;;; 
---------------------------------------------------------------------- 
;;;;

;;; PM-MODULE      [Class]
;;; Date        : 97.01.15, delta 99.06.24
;;; Description : Base class for the various modules, includes input
;;;             : queue and basic state information.

(defclass pm-module ()
   ((input-queue :accessor input-q :initform nil)
    (modality-state :accessor mode-s :initform 'FREE :initarg :modality)
    (processor-state :accessor proc-s :initform 'FREE :initarg :processor)
    (preparation-state :accessor prep-s :initform 'FREE :initarg :preparation)
    (execution-state :accessor exec-s :initform 'FREE :initarg :execution)
    (state-change-flag :accessor state-change :initarg :state-change
                       :initform nil)
    (state-dmo :accessor state-dmo :initarg :state-dmo :initform nil)
    (module-name :accessor my-name :initarg :name :initform nil)
    (last-command :accessor last-cmd :initform nil :initarg :last-command)
    (last-prep :accessor last-prep :initarg :last-prep :initform nil)
    (exec-queue :accessor exec-queue :initarg :exec-queue :initform nil)
    (feature-prep-time :accessor feat-prep-time  :initarg :feat-prep-time
                       :initform 0.050 :allocation :class)
    (movement-initiation-time :accessor init-time :initarg :init-time
                              :initform 0.050 :allocation :class)
    (init-stamp :accessor init-stamp :initarg :init-stamp :initform -0.1)
    (burst-time :accessor burst-time :initarg :burst-time :initform 0.050
                :allocation :class )
    (waiting-for-proc-p :accessor waiting-for-proc-p :allocation :class
                        :initarg :waiting-for-proc-p :initform nil)
))

#|
(defmethod proc-s ((module pm-module))
   (if (or (eq (prep-s module) 'busy)
           (and (eq (exec-s module) 'busy) (eq (prep-s module) 'free)
                (< (mp-time *mp*) (+ (init-stamp module) (init-time module)))))
     'busy
     'free))


(defmethod proc-s ((mod pm-module))
   (proc-stub mod))
|#


(defmethod new-message ((module pm-module) (entry input-queue-entry))
   (setf (input-q module) (queue-insert entry (input-q module))))


;;; RUN-MODULE      [Method]
;;; Date        : 97.01.17
;;; Description : Running a module means processing the items in the input
;;;             : queue that have a current time tag.  Once that's been done,
;;;             : we need to update the state of declarative memory in the
;;;             : Cognitive Layer.

(defgeneric run-module (module the-time)
   (:documentation  "Runs a PM module up to time <the-time>."))

(defmethod run-module ((module pm-module) the-time)
   (setf (state-change module) nil)
   (while (and (input-q module)
               (>= (ms-round the-time)
                   (ms-round (time-tag (first (input-q module))))))
     (let* ((input-entry (pop (input-q module)))
            (the-cmd (first (params input-entry))))
       (when (and (act-cmd-p input-entry)
                  (not (eql (last-cmd module) the-cmd)))
         (change-state module :last the-cmd))
       (when (trace-modules *mp*)
         (pm-output the-time "Module ~S running command ~S"
                    (my-name module) the-cmd the-time))
       (apply the-cmd (append (list module) (rest (params input-entry))))))
   (when (state-change module)
     (update-dm-state module)))


(defgeneric pm-install-module (mstr-proc module &optional warn)
   (:documentation "Installs <module> into <mstr-proc>.  Set <warn> to 
NIL to disable interactive warnings."))

(defmethod pm-install-module ((mp master-process) (module pm-module)
                                  &optional (warn t))
   (let ((name (my-name module)))
     (awhen (assoc name (module-lst mp))
       (awhen (and (neq module (rest it)) warn)
         (pm-warning "Overwrite current ~S module?  [y/n] " name)
         (let ((char (read-char)))
           (when (not (or (eq char #\y) (eq char #\Y)))
             (return-from pm-install-module nil))))
       (setf (module-lst mp) (delete name (module-lst mp) :key #'first)))
     (push (cons name module) (module-lst mp))))


;;; UPDATE-DM-STATE      [Method]
;;; Date        : 97.01.17
;;; Description : Updates the state DMO for a module.

(defgeneric update-dm-state (module)
   (:documentation  "Updates the state DMO for a PM module."))

(defmethod update-dm-state ((module pm-module))
   (set-attributes (state-dmo module)
                   `(modality ,(mode-s module) processor ,(proc-s module)
                              preparation ,(prep-s module)
                              execution ,(exec-s module)
                              last-command ,(last-cmd module))))


;;; CHANGE-STATE      [Method]
;;; Date        : 97.02.10
;;; Description : Change one or more of a module's state flags.

(defgeneric change-state (module &key proc exec prep last)
   (:documentation  "Change one or more of a module's state flags."))

(defmethod change-state ((module pm-module) &key proc exec prep last)
   (when proc (setf (proc-s module) proc))
   (when exec (setf (exec-s module) exec))
   (when prep (setf (prep-s module) prep))
   (when last (setf (last-cmd module) last))
   (if (or (eq (proc-s module) 'busy) (eq (exec-s module) 'busy)
           (eq (prep-s module) 'busy))
     (setf (mode-s module) 'busy)
     (setf (mode-s module) 'free))
   (update-dm-state module)
   (setf (state-change module) t))


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

(defgeneric print-input-queue (module)
   (:documentation  "Prints out all the entries in a PM module's input queue."))

(defmethod print-input-queue ((module pm-module))
   (dolist (entry (input-q module))
     (print-entry entry)))


;;; TEST-MOD-MSG      [Method]
;;; Date        : 97.01.24
;;; Description : Runs a test to make sure the module is processing messages
;;;             : Correctly.

(defgeneric test-mod-msg (module &rest params)
   (:documentation  "Prints out the PM module name, the parameters 
passed, and the time."))

(defmethod test-mod-msg ((module pm-module) &rest params)
   (pm-output (mp-time *mp*) "Module ~S ran test with params ~S"
              (my-name module) params))


;;; CLEAR      [Method]
;;; Date        : 97.03.03
;;; Description : Clears a module's state, takes one feature prep time.

#| CLEAR is already a generic function in MCL.
(defgeneric clear (module)
   (:documentation  "Clears a PM module."))
|#

(defmethod clear ((module pm-module))
   (when (not (check-jam module))
     (change-state module :prep 'busy)
     (queue-command :time 0.050 :where (my-name module) :command 'change-state
                    :params '(:last none :prep free))
     (setf (last-prep module) nil)
     (setf (exec-queue module) nil)
     (setf (init-stamp module) -0.1)
     ))


;;; CHECK-JAM      [Method]
;;; Date        : 97.02.18
;;; Description : Modules can't take certain types of commands if they are
;;;             : already busy, and this checks the preparation state of a
;;;             : module for just this problem.

(defgeneric check-jam (module)
   (:documentation "Returns NIL if the PM module is free, otherwise 
prints an error message and returns T."))

(defmethod check-jam ((module pm-module))
   (if (not (eq (prep-s module) 'busy))
     nil
     (progn
       (pm-warning "Module ~S jammed at time ~S~%"
               (my-name module) (mp-time *mp*))
       t)))


;;; RESET-MODULE      [Method]
;;; Date        : 97.02.18
;;; Description : When a module needs to be reset, that means both that all
;;;             : state indicators should be set to FREE and the input queue
;;;             : should be cleared.

(defgeneric reset-module (module)
   (:documentation "Resets a PM module to base state:  all flags free, 
empty input queue."))

(defmethod reset-module ((module pm-module))
   (setf (proc-s module) 'free)
   (setf (exec-s module) 'free)
   (setf (prep-s module) 'free)
   (setf (mode-s module) 'free)
   (setf (last-cmd module) nil)
   (update-dm-state module)
   (setf (input-q module) nil)
   (setf (last-prep module) nil)
   (setf (exec-queue module) nil)
   (setf (init-stamp module) -0.1)
   )

;;; UPDATE-MODULE      [Method]
;;; Date        : 98.05.28
;;; Description : Called each time the PS is run.  This will update the
;;;             : module's state.  If a specific module has other things
;;;             : that need to be updated besides the DME state of that
;;;             : module, define :BEFORE or :AFTER methods.

(defgeneric update-module (module)
   (:documentation "Update the state of a PM module."))

(defmethod update-module ((mod pm-module))
   (update-dm-state mod))



;;; PRINT-MODULE-STATE      [Method]
;;; Date        : 98.05.28
;;; Description : For debugging help, this prints the state of the module
;;;             : to stdout.

(defgeneric print-module-state (module)
   (:documentation "Prints a representation of a PM module's state."))

(defmethod print-module-state ((mod pm-module))
   (format t "~& State of module ~S" (my-name mod))
   (format t "~% Modality:     ~S" (mode-s mod))
   (format t "~% Preparation:  ~S" (prep-s mod))
   (format t "~% Processor:    ~S" (proc-s mod))
   (format t "~% Execution:    ~S" (exec-s mod))
   (format t "~% Last command: ~S" (last-cmd mod)))



(defgeneric check-state (module &key modality preparation
                                    execution processor last-command)
   (:documentation "Does a quick test of the state of a PM module, 
returning T iff all the specified states match."))


(defmethod check-state ((mod pm-module) &key modality preparation
                           execution processor last-command)
   (cond ((and modality (not (eq modality (mode-s mod)))) nil)
         ((and preparation (not (eq preparation (prep-s mod)))) nil)
         ((and execution (not (eq execution (exec-s mod)))) nil)
         ((and processor (not (eq processor (proc-s mod)))) nil)
         ((and last-command (not (eq last-command (last-cmd mod)))) nil)
         (t t)))


(defgeneric silent-events (module)
   (:documentation "Returns NIL if there are no non-queue events for a 
module."))

(defmethod silent-events ((mod pm-module))
   nil)


;;;; 
---------------------------------------------------------------------- 
;;;;
;;;; preparation and execution stuff



;;; PREPARATION-COMPLETE      [Method]
;;; Date        : 98.07.22
;;; Description : When movement preparation completes: change the prep
;;;             : state, check to see if the movement just prepared wants
;;;             : to execute right away, and then possibly execute a
;;;             : movement.

(defgeneric preparation-complete (module)
   (:documentation "Method to be called when movement preparation is 
complete."))

(defmethod preparation-complete ((module pm-module))
   (change-state module :prep 'free)
   (when (and (last-prep module)
              (exec-immediate-p (last-prep module)))
     (setf (exec-queue module)
           (append (exec-queue module) (mklist (last-prep module)))))
   (maybe-execute-movement module))


;;; FINISH-MOVEMENT      [Method]
;;; Date        : 98.07.22
;;; Description : When a movement completes, FREE the execution state, and
;;;             : check to see if there were any movements queued.

(defgeneric finish-movement (module)
   (:documentation "Method called when a movement finishes completely."))

(defmethod finish-movement ((module pm-module))
   (change-state module :exec 'free)
   (maybe-execute-movement module))


;;; MAYBE-EXECUTE-MOVEMENT      [Method]
;;; Date        : 98.07.22
;;; Description : If there is a movement queued and the motor state is FREE,
;;;             : then execute the movment.  Also, free the processor state
;;;             : with an event if necessary.

(defgeneric maybe-execute-movement (module)
   (:documentation "If there are any movements in <module>'s execution 
queue, execute one."))

(defmethod maybe-execute-movement ((module pm-module))
   (when (and (exec-queue module) (eq (exec-s module) 'FREE))
     (perform-movement module (pop (exec-queue module)))))


;;; PREPARE      [Method]
;;; Date        : 98.08.21
;;; Description : Build a movement style instance via APPLY, set it to not
;;;             : automatically execute itself, and prepare it.

(defgeneric prepare (module &rest params)
   (:documentation "Prepare a movement to be executed, but don't 
execute it. The first of <params> should be the name of a movement 
style class."))

(defmethod prepare ((module pm-module) &rest params)
   (let ((inst (apply #'make-instance params)))
     (setf (exec-immediate-p inst) nil)
     (prepare-movement module inst)))


;;; EXECUTE      [Method]
;;; Date        : 98.08.21
;;; Description : Executing the previously prepared command requires
;;;             : [1] A previously-prepared command, and
;;;             : [2] No command currently being prepared.
;;;             : If those are OK, put the current style instance in the
;;;             : execution queue and go for it.

(defgeneric execute (module)
   (:documentation "Tells <module> to execute the last movement prepared."))

(defmethod execute ((module pm-module))
   (cond ((not (last-prep module))
          (pm-warning "Motor Module has no movement to EXECUTE."))
         ((eq (prep-s module) 'BUSY)
          (pm-warning "Motor Module cannot EXECUTE features being prepared."))
         (t
          (setf (exec-queue module)
                (append (exec-queue module) (mklist (last-prep module))))
          (maybe-execute-movement module))))


;;; PM-PREPARE-MOTOR-MTH      [Method]
;;; Date        : 98.09.24
;;; Description : If RPM is to begin a run with features already prepared,
;;;             : this is the method to do it.  Create a movement instance,
;;;             : kill the exec-immediate, and set the last prepared movement
;;;             : to the created movement.

(defgeneric pm-prepare-mvmt-mth (module params)
   (:documentation "Create the movement specified in <params>, which 
should begin with the name of a movement style, and consider it 
prepared. To be called only at model initialization."))

(defmethod pm-prepare-mvmt-mth ((module pm-module) params)
   (let ((inst (apply #'make-instance params)))
     (setf (exec-immediate-p inst) nil)
     (setf (last-prep module) inst)))





;;;; 
---------------------------------------------------------------------- 
;;;;
;;;; MOVEMENT-STYLE class and methods
;;;; 
---------------------------------------------------------------------- 
;;;;

(defclass movement-style ()
   ((fprep-time :accessor fprep-time :initform nil :initarg :fprep-time)
    (exec-time :accessor exec-time :initform nil :initarg :exec-time)
    (finish-time :accessor finish-time :initform nil :initarg :finish-time)
    (exec-immediate-p :accessor exec-immediate-p :initform t
                      :initarg :exec-immediate-p)
    (num-features :accessor num-features :initform nil
                  :initarg :num-features)
    (style-name :accessor style-name :initarg :style-name :initform nil)
    (feature-slots :accessor feature-slots :initarg :feature-slots
                   :initform nil)
    (set-proc-p :accessor set-proc-p :initarg :set-proc-p :initform nil)
))


;;; PREPARE-MOVEMENT      [Method]
;;; Date        : 98.07.22
;;; Description : Change the prep state, compute the feature prep time,
;;;             : note that we're the last feature the MM has prepared,
;;;             : and queue the preparation complete event.

(defgeneric prepare-movement (module movement)
   (:documentation "Tell <module> to prepare <movement>."))

(defmethod prepare-movement ((module pm-module) (mvmt movement-style))
   (change-state module :prep 'BUSY)
   (setf (fprep-time mvmt)
         (rand-time (compute-prep-time module mvmt)))
   (setf (last-prep module) mvmt)
   (queue-command :command 'preparation-complete :where (my-name module)
                :time (fprep-time mvmt) :randomize nil)
   (when (and (waiting-for-proc-p module) (null (exec-queue module))
              (exec-immediate-p mvmt))
     (setf (set-proc-p mvmt) t)
     (queue-command :time (+ (fprep-time mvmt) (init-time module))
                    :where (my-name module) :command 'change-state
                    :params '(:proc free) :randomize nil)))



;;; COMPUTE-PREP-TIME      [Method]
;;; Date        : 98.07.22
;;; Description : Computing the prep time.  If this is a different kind of
;;;             : movement or a totall new movement, then just return the
;;;             : number of features times the time per feature.  If the
;;;             : old movement is similar, compute the differences (a
;;;             : method for this must be supplied).

(defgeneric compute-prep-time (module movement)
   (:documentation "Return the feature preparation time for <movement>."))

(defmethod compute-prep-time ((module pm-module) (mvmt movement-style))
   (if (or (null (last-prep module))
           (not (eq (style-name mvmt) (style-name (last-prep module)))))
     (* (feat-prep-time module) (num-to-prepare mvmt))
     (* (feat-prep-time module)
        (feat-differences mvmt (last-prep module)))))




;;; PERFORM-MOVEMENT      [Method]
;;; Date        : 98.07.22
;;; Description : Performing a movement has several pieces to it.  First,
;;;             : bookkeeping (exec state and start time).  Next we need
;;;             : to compute times.  Then, queue the events (movement
;;;             : specific) that reflect our output, and finally queue
;;;             : the event indicating completion of the movement.

(defgeneric perform-movement (module movement)
   (:documentation "Have <module> perform <movement>."))

(defmethod perform-movement ((module pm-module) (mvmt movement-style))
   (queue-command :time (init-time module) :where (my-name module)
                  :command 'INITIATION-COMPLETE)
   (change-state module :proc 'BUSY :exec 'BUSY)
   (setf (init-stamp module) (mp-time *mp*))
   (setf (exec-time mvmt) (compute-exec-time module mvmt))
   (setf (finish-time mvmt) (compute-finish-time module mvmt))
   (queue-output-events module mvmt)
   (queue-finish-event module mvmt))


(defmethod initiation-complete ((module pm-module))
   (change-state module :proc 'FREE))


;;; COMPUTE-FINISH-TIME      [Method]
;;; Date        : 98.07.22
;;; Description : Default finish time is simply execution time plus the
;;;             : burst time--some styles will need to override this.

(defgeneric compute-finish-time (module movement)
   (:documentation "Return the finish time of <movement>."))

(defmethod compute-finish-time ((module pm-module) (mvmt movement-style))
   "Return the finish time of the movement."
   (+ (burst-time module) (exec-time mvmt)))


;;; QUEUE-FINISH-EVENT      [Method]
;;; Date        : 98.07.22
;;; Description : Queue the event that frees the exec of the MM.

(defgeneric queue-finish-event (module movement)
   (:documentation "Queue the FINISH-MOVEMENT associated with <movement>."))

(defmethod queue-finish-event ((module pm-module) (mvmt movement-style))
   (queue-command :time (finish-time mvmt) :command 'finish-movement
                  :where (my-name module)))


;;; Stubs that require overrides.

(defgeneric compute-exec-time (module movement)
   (:documentation "Return the execution time of <movement>."))

(defmethod compute-exec-time ((module pm-module) (mvmt movement-style))
   (error "No method defined for COMPUTE-EXEC-TIME."))


(defgeneric queue-output-events (module movement)
   (:documentation "Queue the events--not including the 
FINISH-MOVEMENT--that <movement> will generate."))

(defmethod queue-output-events ((module pm-module) (mvmt movement-style))
   (error "No method defined for QUEUE-OUTPUT-EVENTS."))


(defgeneric feat-differences (movement1 movement2)
   (:documentation "Return the number of different features that need 
to be prepared."))

(defmethod feat-differences ((move1 movement-style) (move2 movement-style))
   ;(declare (ignore move1 move2))
   (error "No method defined for FEAT-DIFFERENCES."))




(defgeneric num-possible-feats (movement)
   (:documentation "Return the maximum number of features that could 
possibly need to be prepared."))

(defmethod num-possible-feats ((mvmt movement-style))
   (1+ (length (feature-slots mvmt))))


(defgeneric num-to-prepare (movement)
   (:documentation "Return the number of features actually needed to 
prepare <movement>."))

(defmethod num-to-prepare ((mvmt movement-style))
   (1+ (length (remove :DUMMY
                       (remove nil
                               (mapcar #'(lambda (name)
                                           (slot-value mvmt name))
                                       (feature-slots mvmt)))))))



(defmacro defstyle (name base-class &rest params)
   "Macro that defines new motor movement styles.  Pass in the name 
and the base class
[if NIL is passed, it will default to MOVEMENT-STYLE] and the base parameters.
This will create a class and a method for any PM Module for the class."
   `(progn
      (defclass ,name (,(if (not base-class) 'movement-style base-class))
        ,(build-accessors params)
        (:default-initargs
          :style-name ,(sym->key name)
          :feature-slots ',params))
      (defmethod ,name ((module pm-module) &key ,@params)
        (unless (or (check-jam module) (check-specs ,@params))
          (prepare-movement module
                            (make-instance ',name
                              ,@(build-initializer params)))))))


;;; BUILD-ACCESSORS      [Function]
;;; Date        : 98.11.02
;;; Description : Helper function for DEFSTYLE.

(defun build-accessors (params)
   "From a list of parameters, a list of slot definitions."
   (let ((accum nil))
     (dolist (param params (nreverse accum))
       (push (list param :accessor param :initarg (sym->key param)
                   :initform nil) accum))))


;;; BUILD-INITIALIZER      [Function]
;;; Date        : 98.11.02
;;; Description : Helper function for DEFSTYLE.

(defun build-initializer (params)
   "From a list of parameters, build a list for the make-instance initializer."
   (let ((accum nil))
     (dolist (param params (nreverse accum))
       (push (sym->key param) accum)
       (push param accum))))


;;;; 
---------------------------------------------------------------------- 
;;;;
;;;; Attentional modules
;;;; 
---------------------------------------------------------------------- 
;;;;

;;; ATTN-MODULE      [Class]
;;; Date        : 00.06.09
;;; Description : Class for modules that have attentional capability.
;;;             : CURRENTLY-ATTENDED hold the focus object
;;;             : SOURCE-ACTIVATION tells how much source activation the focus
;;;             : object gets
;;;             : CURRENT-MARKER denotes the location/event currently attended

(defclass attn-module (pm-module)
   ((currently-attended :accessor currently-attended
                        :initarg :currently-attended :initform nil)
    (source-activation :accessor source-act :initarg :source-act :initform 1.0)
    (current-marker :accessor current-marker :initarg :current-marker
                    :initform nil)
    ))


(defmethod reset-module ((module attn-module))
   (call-next-method)
   (clear-attended module)
   (setf (current-marker module) nil)
   )

(defmethod clear ((module attn-module))
   (call-next-method)
   (setf (current-marker module) nil)
   (clear-attended module))


;;; the bizarre machinations here with CLEAR-ATTENDED and
;;; PARTIAL-CLEAR-ATTENDED have to do with activation management in ACT-R.
;;; They get handled slightly differently by ACT-R, so they have to be
;;; separate methods.  Really.

(defgeneric clear-attended (module)
   (:documentation "Set <module> so that it is attending nothing."))

(defmethod clear-attended ((module attn-module))
   (partial-clear-attended module))


(defgeneric partial-clear-attended (module)
   (:documentation "Actually clear the CURRENTLY-ATTENDED slot for <module>."))

(defmethod partial-clear-attended ((module attn-module))
   (setf (currently-attended module) nil))


(defgeneric set-attended (module object)
   (:documentation "Note that <module> is now attending <object>."))

(defmethod set-attended ((module attn-module) obj)
   (partial-clear-attended module)
   (setf (currently-attended module) obj))





;;;  -*- mode: LISP; Package: CL-USER; Syntax: COMMON-LISP;  Base: 10 -*-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Author      : Mike Byrne
;;; Copyright   : (c)1998-2001 CMU/Rice U./Mike Byrne, All Rights Reserved
;;; Availability: public domain
;;; Address     : Rice University
;;;             : Psychology Department
;;;             : Houston,TX 77251-1892
;;;             : byrne@acm.org
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Filename    : rpm-parameters.lisp
;;; Version     : 2.1b1
;;;
;;; Description : All the code that handles the global parameters for RPM.
;;;             : This is where default values are defined as well.
;;;
;;; Bugs        : No known open bugs.
;;;
;;; Todo        : Nothing pending.
;;;
;;; ----- History -----
;;; 01.07.29 mdb
;;;             : 2.1/ACT5 work began
;;;             : [x] Remove obsolete :DISABLE-INTERRUPTS and
;;;             :     :INTERRUPT-ON-OUTPUT parameters.
;;; 01.08.07 mdb
;;;             : Changed attn shift latency to 0.085 sec.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;;; PM-PARAM      [Class]
;;; Date        : 97.03.07
;;; Description : Class for storing info about global PM parameters.

(defclass pm-param ()
   ((name :accessor name :initarg :name)
    (place :accessor place :initarg :place)
    (test :accessor restrict :initarg :test)
    (message :accessor msg :initarg :msg)
    (default :accessor default :initarg :default)))



;;; SET-PLACE      [Function]
;;; Date        : 97.03.07
;;; Description : Sets the value of PLACE, but evaluates PLACE first.
;;;             : Why the following macro doesn't work is still something
;;;             : of a mystery to me:
;;;             : (defmacro set-mac (place value)
;;;             :   `(setf ,place ,value))

(defun set-place (place value)
   "Sets <place> to <value>, but evaulates <place> first"
   (eval `(setf ,place ,value)))


;;; SET-PARAM      [Method]
;;; Date        : 97.03.07
;;; Description : Sets the value of a parameter, potentially.  First tests
;;;             : to see if the value matches the test supplied for that
;;;             : parameter.  If so, set it, if not, print a warning message.

(defgeneric set-param (pm-param value)
   (:documentation "Set a PM parameter to <value> assuming it passes 
the stored test."))

(defmethod set-param ((the-param pm-param) value)
   (if (funcall (restrict the-param) value)
     (set-place (place the-param) value)
     (pm-warning "Parameter ~S cannot take value ~A because it must be ~A."
                 (name the-param) value (msg the-param))))


;;; RESTORE-DEFAULT      [Method]
;;; Date        : 98.01.12
;;; Description : Restore a parameter to its default value.

(defgeneric restore-default (pm-param)
   (:documentation "Restores a PM parameter to its default."))

(defmethod restore-default ((the-param pm-param))
   (set-place (place the-param) (default the-param)))


;;; PRINT-PARAM      [Method]
;;; Date        : 97.03.07
;;; Description : Prints the value of a parameter

(defgeneric print-param (pm-param)
   (:documentation "Prints the value of a PM parameter."))

(defmethod print-param ((the-param pm-param))
   (format t "~%Parameter ~S has value: ~A" (name the-param)
           (eval (place the-param))))



;;; BUILD-PARAM-LIST      [Function]
;;; Date        : 97.03.07
;;; Description : Builds the list of parameter objects.

(defun build-param-list ()
   "Build the list of global parameters"
   (list
    `(:audio-source-activation
      ,(make-instance 'pm-param :name :audio-source-activation :test #'posnum
                      :place '(source-act (audio-m *mp*)) :default 1.0
                      :msg "a non-negative number"))
    `(:auto-dequeue
      ,(make-instance 'pm-param :name :auto-dequeue :test #'tornil :default nil
                      :place '(auto-dequeue-p *mp*) :msg "T or NIL"))
    `(:conservative-update-visual
      ,(make-instance 'pm-param :name :conservative-update-visual :test #'tornil
                      :place '(conservative-p (vis-m *mp*)) :default nil
                      :msg "T or NIL"))
    `(:default-target-width
       ,(make-instance 'pm-param :name :default-target-width :test #'posnum
                       :place '(target-width (motor-m *mp*))
                       :msg "a non-negative number" :default 1.0))
    `(:device-updater-fct
      ,(make-instance 'pm-param :name :device-updater-fct :test #'functionp
                      :place '(device-hook (device-interface *mp*))
                      :msg "a function" :default nil))
    `(:digit-detect-delay
      ,(make-instance 'pm-param :name :digit-detect-delay :test #'posnum
                      :place '(digit-dtct-dly (audio-m *mp*))
                      :msg "a non-negative number" :default 0.3))
    `(:digit-duration
      ,(make-instance 'pm-param :name :digit-duration :test #'posnum
                      :place '(digit-duration (audio-m *mp*))
                      :msg "a non-negative number" :default 0.6))
    `(:digit-recode-delay
      ,(make-instance 'pm-param :name :digit-recode-delay :test #'posnum
                      :place '(digit-rec-dly (audio-m *mp*))
                      :msg "a non-negative number" :default 0.5))
#|
    `(:disable-interrupts
      ,(make-instance 'pm-param :name :disable-interrupts :test #'tornil
                      :place '(slave-p *mp*) :default nil
                      :msg "T or NIL"))
|#
    `(:incremental-mouse-moves
      ,(make-instance 'pm-param :name :incremental-mouse-moves :test #'tornil
                      :place '(incremental-mouse-p (motor-m *mp*)) :default NIL
                      :msg "T or NIL"))
#|
    `(:interrupt-on-output
      ,(make-instance 'pm-param :name :interrupt-on-output :test #'tornil
                      :place '(interrupt-on-output-p *mp*) :default T
                      :msg "T or NIL"))
|#
    `(:min-fitts-time
      ,(make-instance 'pm-param :name :min-fitts-time :test #'posnum
                      :place '(min-fitts-time (motor-m *mp*))
                      :default 0.100  :msg "a non-negative number"))
    `(:motor-burst-time
      ,(make-instance 'pm-param :name :motor-burst-time :test #'posnum
                      :place '(burst-time (motor-m *mp*))
                      :msg "a non-negative number" :default 0.05))
    `(:motor-initiation-time
      ,(make-instance 'pm-param :name :motor-initiation-time :test #'posnum
                      :place '(init-time (motor-m *mp*))
                      :msg "a non-negative number" :default 0.05))
    `(:motor-feature-prep-time
      ,(make-instance 'pm-param :name :motor-feature-prep-time :test #'posnum
                      :place '(feat-prep-time (motor-m *mp*))
                      :msg "a non-negative number" :default 0.05))
    `(:motor-proc-events
      ,(make-instance 'pm-param :name :motor-proc-events :test #'tornil
                      :default NIL :msg "T or NIL"
                      :place '(waiting-for-proc-p (motor-m *mp*))))
    `(:mouse-fitts-coeff
      ,(make-instance 'pm-param :name :mouse-fitts-coeff :test #'posnum
                      :place '(mouse-fitts-coeff (device-interface *mp*))
                      :default 0.1  :msg "a non-negative number"))
    `(:optimize-visual
      ,(make-instance 'pm-param :name :optimize-visual :test #'tornil :default T
                      :place '(optimize-p (vis-m *mp*)) :msg "T or NIL"))
    `(:output-speech
      ,(make-instance 'pm-param :name :output-speech :test #'tornil :default NIL
                      :place '(device-speech-p (device-interface *mp*))
                      :msg "T or NIL"))
    `(:peck-fitts-coeff
      ,(make-instance 'pm-param :name :peck-fitts-coeff :test #'posnum
                      :place '(peck-fitts-coeff (motor-m *mp*))
                      :default 0.075  :msg "a non-negative number"))
    `(:pixels-per-inch
      ,(make-instance 'pm-param :name :pixels-per-inch :test #'posnum
                      :place '(ppi (device-interface *mp*)) :default 72.0
                      :msg "a non-negative number"))
    `(:print-viewed
      ,(make-instance 'pm-param :name :print-viewed :test #'tornil :default NIL
                      :place '(print-view-p (vis-m *mp*)) :msg "T or NIL"))
    `(:process-cursor
      ,(make-instance 'pm-param :name :process-cursor :test #'tornil
                      :place '(with-cursor-p (device-interface *mp*))
                      :msg "T or NIL" :default NIL))
    `(:randomize-time
      ,(make-instance 'pm-param :name :randomize-time :test #'tornil 
:default NIL
                      :place '(randomize-time *mp*) :msg "T or NIL"))
    `(:real-time
      ,(make-instance 'pm-param :name :real-time :test #'tornil :default NIL
                      :place '(real-time-p *mp*) :msg "T or NIL"))
    `(:show-focus
      ,(make-instance 'pm-param :name :show-focus :test #'tornil :default NIL
                      :place '(show-focus-p (device-interface *mp*))
                      :msg "T or NIL"))
    `(:sound-decay-time
      ,(make-instance 'pm-param :name :sound-decay-time :test #'posnum
                      :place '(decay-time (audio-m *mp*)) :default 3.0
                      :msg "a non-negative number"))
    #|
    `(:sound-base-level
      ,(make-instance 'pm-param :name :sound-base-level :test #'posnum
                      :place '(snd-base-lvl (audio-m *mp*)) :default 10.0
                      :msg "a non-negative number"))
|#
    `(:speech-hook-fct
      ,(make-instance 'pm-param :name :speech-hook-fct :test #'functionp
                      :place '(speech-hook (device-interface *mp*))
                      :msg "a function" :default nil))
    `(:syllable-rate
      ,(make-instance 'pm-param :name :syllable-rate :test #'posnum
                      :place '(s-rate (speech-m *mp*)) :default 0.15
                      :msg "a non-negative number"))
    `(:tone-detect-delay
      ,(make-instance 'pm-param :name :tone-detect-delay :test #'posnum
                      :place '(tone-dtct-dly (audio-m *mp*)) :default 0.05
                      :msg "a non-negative number"))
    `(:tone-recode-delay
      ,(make-instance 'pm-param :name :tone-recode-delay :test #'posnum
                      :place '(tone-rec-dly (audio-m *mp*)) :default 0.285
                      :msg "a non-negative number"))
    `(:trace-modules
      ,(make-instance 'pm-param :name :trace-modules :test #'tornil :default T
                      :place '(trace-modules *mp*) :msg "T or NIL"))
    `(:visual-finst-span
      ,(make-instance 'pm-param :name :visual-finst-span :test #'posnum
                      :place '(finst-span (vis-m *mp*)) :default 3.0
                      :msg "a non-negative number"))
    `(:visual-movement-tolerance
      ,(make-instance 'pm-param :name :visual-movement-tolerance :test #'posnum
                      :place '(move-allowance (vis-m *mp*)) :default 0.0
                      :msg "a non-negative number"))
    `(:visual-num-finsts
      ,(make-instance 'pm-param :name :visual-num-finsts :test #'posnum
                      :place '(num-finst (vis-m *mp*)) :default 4
                      :msg "a non-negative number"))
    `(:visual-onset-span
      ,(make-instance 'pm-param :name :visual-onset-span :test #'posnum
                      :place '(new-span (vis-m *mp*)) :default 0.5
                      :msg "a non-negative number"))
    `(:visual-source-activation
      ,(make-instance 'pm-param :name :visual-source-activation :test #'posnum
                      :place '(source-act (vis-m *mp*)) :default 1.0
                      :msg "a non-negative number"))
    `(:viewing-distance
      ,(make-instance 'pm-param :name :viewing-distance :test #'posnum
                      :place '(viewing-distance (device-interface *mp*))
                      :default 15.0  :msg "a non-negative number"))
    `(:visual-attention-latency
      ,(make-instance 'pm-param :name :visual-attention-latency :test #'posnum
                      :place '(move-attn-latency (vis-m *mp*)) :default 0.085
                      :msg "a non-negative number"))
    ))



;;;  -*- mode: LISP; Package: CL-USER; Syntax: COMMON-LISP;  Base: 10 -*-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Author      : Mike Byrne
;;; Copyright   : (c)1997-2001 CMU/Rice U./Mike Byrne, All Rights Reserved
;;; Availability: public domain
;;; Address     : Rice University
;;;             : Psychology Department
;;;             : Houston,TX 77251-1892
;;;             : byrne@acm.org
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Filename    : rpm-toplevel.lisp
;;; Version     : 2.1b3
;;;
;;; Description : Top-level functions for RPM, nothing fancy.
;;;
;;; To do       :
;;;
;;; ----- History -----
;;; 01.07.27 mdb
;;;             : Started 2.1/ACT5 conversion.
;;;             : [x] Parameterize buffer-stuffing
;;; 01.10.05 mdb [b3]
;;;             : Fixed bug in PM-SET-HAND-LOCATION.
;;; 01.11.05 mdb
;;;             : Restored :full-time in PM-RUN.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


(defmacro pm-set-cursor-position (x y)
   "Sets the position of the cursor."
   (pm-set-cursor-position-fct (vector x y)))


(defmacro pm-attend-location (x y)
   (pm-attend-location-fct (vector x y)))


(defmacro pm-set-hand-location (hand &rest loc)
   "Sets the location of the given hand to LOC"
   `(pm-set-hand-location-fct ',hand ',loc))


(defmacro pm-set-params (&rest parameters)
   `(set-pm-params-mth ,*mp* ',parameters))


(defmacro pm-show-params (&rest parameters)
   `(show-pm-params-mth ,*mp* ',parameters))


(defmacro pm-prepare-motor (&rest lis)
   "Tells the Motor Module to prepare the supplied movement."
   `(pm-prepare-mvmt-mth ,(motor-m *mp*) ',lis))


(defun pm-reset (&key (initialize-dm t))
   "Resets the Master Process"
   (setf *pop-upon-failure* nil)
   ;(setf *external-sources* nil)
   (reset-mp *mp*)
   (when initialize-dm
     (pm-initialize-dm)))


(defun pm-add-chunks ()
   "Adds the chunks used by the PM layer"
   (add-pm-state-chunks)
)


(defun pm-add-types-and-chunks ()
   "Deprecated function from RPM 1.0"
   (pm-warning "PM-ADD-TYPES-AND-CHUNKS deprecated, use PM-RESET or 
PM-INITIALIZE-DM.")
   (pm-initialize-dm))


(defun pm-initialize-dm ()
   "Defines chunk types and adds chunks for the PM layer"
   (def-pm-chunk-types)
   (pm-add-chunks))


(defun pm-time ()
   "Return the current time, in seconds, of the Master Process"
   (mp-time *mp*))


(defun pm-proc-screen (&key clear with-cursor)
   "Processes the current display.  For backward compatibility only, 
use PM-PROC-DISPLAY."
   (when with-cursor
     (setf (with-cursor-p (device-interface *mp*)) t))
   (process-display (device-interface *mp*) (vis-m *mp*) clear))


(defun pm-proc-display (&key clear)
   "Processes the current display."
   (process-display (device-interface *mp*) (vis-m *mp*) clear))


(defun pm-install-window (window)
   "Installs <window> as the action window for the PM layer.  Included 
purely fo backward compatibility only. Use PM-INSTALL-DEVICE instead."
   (setf (device (device-interface *mp*)) window)
   (update-device (device-interface *mp*) (mp-time *mp*)))


(defun pm-install-device (device)
   "Installs <device> as the active device for the perceptual-motor layer."
   (setf (device (device-interface *mp*)) device))


(defun pm-pixels-to-angle (pixels)
   "Convert <pixels> to degress of visual angle."
   (pixels->angle-mth (device-interface *mp*) pixels))


(defun pm-angle-to-pixels (angle)
   "Convert visual <angle> in degress to pixels."
   (angle->pixels-mth (device-interface *mp*) angle))


(defun pm-set-cursor-position-fct (xyloc)
   (setf (current-cursor (motor-m *mp*)) xyloc)
   (synch-mouse (device-interface *mp*))
   (current-cursor (motor-m *mp*)))


(defun pm-attend-location-fct (loc)
   "Tells the Vision Moddule to start with attention at a certain location."
   (setf (current-marker (vis-m *mp*)) (xy-to-dmo loc t))
   (setf (current-lof (vis-m *mp*)) loc))


(defun pm-remove-features (loc &optional scale)
   "Removes features at the specified visual location."
   (delete-features (vis-m *mp*) loc scale))


(defun pm-start-hand-at-mouse ()
   "Starts the right hand on the mouse instead of the default 'home 
row' location"
   (let ((the-hand (right-hand (motor-m *mp*))))
     (setf (loc the-hand) #(28 2))))


(defun pm-set-char-feature-set (setname)
   "Sets the feature set used to represent characters when optimizing 
is off. <setname> should be a keyword."
   (set-cfs-mth (vis-m *mp*) setname))


(defun pm-set-hand-location-fct (hand loc)
   "Function to set the location of the given hand to LOC"
   (setf loc (coerce loc 'vector))
   (ecase hand
     (right (setf (loc (right-hand (motor-m *mp*))) loc))
     (left (setf (loc (left-hand (motor-m *mp*))) loc))))


(defun pm-step ()
   "Enters the ACT-R/PM stepper"
   (step-rpm-mth *mp*))


(defun pm-run (duration &key (full-time nil))
   "Runs ACT-R/PM for the specifed duration (in seconds).
    If full-time is t then it gurantees that time is advanded by 
duration seconds"
   (when full-time
     (pm-delayed-event duration #'(lambda ()
                                    (pm-output nil "* Running stopped 
because time limit reached."))))

   (run-master-process *mp* duration))


(defun pm-print-icon ()
   "Print the Vision Manager's icon. For debugging."
   (dolist (feat (visicon (vis-m *mp*)))
     (print-icon-feature feat)))


(defun pm-print-sched ()
   "Print the schedule queue. For debugging."
   (print-sched-queue *mp*))


(defun pm-print-input-q (module)
   "Print the input queue of the specified (by keyword) module.  For debugging."
   (print-input-queue (key->mgr *mp* module)))


(defun pm-print-module-state (module-name)
   "Print the state of the specified (by keyword) module."
   (print-mod-state-mth *mp* module-name))


(defun pm-version ()
   "Returns the version string for RPM."
   (version-string *mp*))


(defmacro pm-set-visloc-default (&rest params)
   (setf (default-spec (vis-m *mp*))
         (apply #'construct-findloc-spec params)))


;;; left in for backward compatibilty only
(defun run-mp (duration)
   (run-master-process *mp* duration))




;;;  -*- mode: LISP; Package: CL-USER; Syntax: COMMON-LISP;  Base: 10 -*-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Author      : Mike Byrne & 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    : rpm-utils.lisp
;;; Version     : 2.1b4
;;;
;;; Description : Utility macros and functions for ACT-R/PM, stuff that I
;;;             : thought shouldn't be file-specific.
;;;
;;; Bugs        : None known.
;;;
;;; Todo        : none
;;;
;;; ----- History -----
;;; 97.01.15 Mike Byrne
;;;             : Genesis.  No notes kept for this file (dumb, sorry), until
;;;             : alpha 4.
;;; 97.06.20 Mike Byrne
;;;             : Added all the stuff for converting pixels to degrees and
;;;             : such.
;;; 97.06.25 Mike Byrne
;;;             : Added AWHEN.  Duh.
;;; 97.07.02 Mike Byrne
;;;             : Added MKSTR for the new string parsing in the Vision Manager.
;;; 98.01.12 Mike Byrne
;;;             : Added PM-OUTPUT and PM-WARNING macros.
;;; 98.01.21 Mike Byrne
;;;             : Added additional safety check in DME-TO-XY.
;;; 98.06.02 Mike Byrne
;;;             : Prepped for b3 release--many functions moved from here to
;;;             : where they should be (like "mcl-interface").
;;; 98.11.11 mdb
;;;             : b5 change, SYM->KEY utility function.
;;; 99.04.07 mdb
;;;             : Added OBJ-MATCH-* functions, commented out old screen crap.
;;; 99.07.06 mdb
;;;             : 1.0 changes.  Added a couple utils.
;;; 00.01.27 mdb
;;;             : Fixnum declaration in DEG->RAD changed to number for ACL.
;;; 99.12.21 Dan Bothell
;;;             : wrapped the while macro to avoid evaluation under ACL,
;;;             : because a while function already exists.
;;; 00.06.08 mdb
;;;             : Started 2.0 work, added NEQ for ACL.
;;; 00.08.09 mdb
;;;             : Changed MATCH-SPEC-P to use vectors instead of lists.
;;; 00.08.10 mdb
;;;             : Started work to change internal representation of points
;;;             : from lists to vectors.
;;; 01.03.26 mdb
;;;             : Added DEFGENERICs and doc strings.
;;; 01.05.31 Dan Bothell
;;;             : Changed random-item so that it doesn't call random on 0
;;;             : because that causes problems for LispWorks.  Interestingly
;;;             : (random 0) causes an error in ACL as well, but 
(random-item nil)
;;;             : in its old form didn't...weird.  [mdb note:  I changed this
;;;             : so it doesn't call LENGTH twice, which will be slow on a
;;;             : long list]
;;; 01.06.15 Dan
;;;             : Removed the (declare (float x)) from ms-round
;;;             : because it was causing problems in CMUCL.
;;;             : It was being called with non-floats (in particular
;;;             : things like 4/1000 by maybe-wait) and apparently
;;;             : the other Lisps just ignored it...  [mdb:  changed to NUBMER
;;;             : rather than FIXNUM].
;;; 01.06.15 Dan
;;;             : Put a feature check on pm-not-equal ((val fixnum))
;;;             : because lispworks and clisp don't like using fixnum as
;;;             : a class.
;;; 01.07.02 mdb
;;;             : Replaced PM-OUTPUT with Dan Bothell's NEW-PM-OUTPUT macro,
;;;             : to make things consistent.
;;;
;;; 02.01.07 Dan
;;;             : changed the fixnum declaration in rad->deg to number for ACL
;;;             : (I can't believe I hadn't caught that when deg->rad 
was changed
;;;             : because without it that computation is really messed up which
;;;             : should have been noticed in approach width calculations...)
;;; 02.01.09 Dan
;;;             : added 2 more within methods to handle a mixture of variables
;;;             : (chunks) and numbers
;;; 02.01.15 Dan
;;;             : Changed the feature check on the defmacro of while
;;;             : because only ACL with the IDE has it, not every ACL.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(declaim (optimize (speed 3)))



;;;; 
---------------------------------------------------------------------- 
;;;;
;;;; Macros
;;;; 
---------------------------------------------------------------------- 
;;;;

;;; WHILE      [Macro]
;;; Description : While test is true, do body.  From _On Lisp_.

#-:allegro-ide
(defmacro while (test &body body)
   `(do ()
        ((not ,test))
      ,@body))


;;; AIF      [Macro]
;;; Date        : 97.02.09
;;; Description : From _On Lisp_, anaphoric if.  That is, can use variable
;;;             : "it" to refer to result of the test-form.

(defmacro aif (test-form then-form &optional else-form)
   `(let ((it ,test-form))
      (if it ,then-form ,else-form)))


(defmacro awhen (test-form &body body)
   `(aif ,test-form
      (progn ,@body)))



#-:mcl
(defmacro dovector ((varsym vec &optional ret) &body body)
   (let ((idx (gensym)))
     `(let (,varsym)
        (dotimes (,idx (length ,vec) ,ret)
          (setq ,varsym (aref ,vec ,idx))
          ,@body
          ))))


(defmacro px (vpt)
   "X coordinate of an XY vector."
   `(aref ,vpt 0))

(defmacro py (vpt)
   "Y coordinate of an XY vector."
   `(aref ,vpt 1))

(defmacro vr (vrt)
   "R component of an r-theta vector."
   `(aref ,vrt 0))

(defmacro vtheta (vrt)
   "Theta component of an r-theta vector."
   `(aref ,vrt 1))

;;;; 
---------------------------------------------------------------------- 
;;;;
;;;; Utility functions
;;;; 
---------------------------------------------------------------------- 
;;;;

#-:mcl
(defun neq (x y)
   "The NOT of EQ."
   (declare (inline neq))
   (not (eq x y)))

(defun vpt= (vpt1 vpt2)
   (and (= (px vpt1) (px vpt2))
        (= (py vpt1) (py vpt2))))

(defun sym->key (symbol)
   "Given a symbol, return the corresponding keyword."
   (read-from-string (mkstr ":" symbol)))


(defun key->sym (keyword)
   "Given a keyword, return the corresponding symbol."
   (read-from-string (mkstr keyword) 1))


;;; FLATTEN      [Function]
;;; Description : From Graham's _On Lisp_, takes a nested list and turns it
;;;             : into a flat one.  "Fast" version.

(defun flatten (lis)
   "Takes a nested list and makes in into a single-level list"
   (declare (list lis))
   (labels ((rec (lis acc)
              (cond ((null lis) acc)
                    ((atom lis) (cons lis acc))
                    (t (rec (car lis) (rec (cdr lis) acc))))))
     (rec lis nil)))


;;; MKLIST      [Function]
;;; Description : From Graham's _On Lisp_, make sure we have a list.

(defun mklist (obj)
   "If the object is not a list, return a list containing the object"
   (if (listp obj) obj (list obj)))


;;; MKSTR      [Function]
;;; Date        : 97.07.02
;;; Description : From Graham's _On Lisp_, makes sure we have a string.

(defun mkstr (&rest args)
   "Return a concatenated string representation of the arguments"
   (with-output-to-string (s)
     (dolist (a args) (princ a s))))


;;; RANDOM-ITEM      [Function]
;;; Date        : 97.02.05
;;; Description : Returns a random item from a list.

(defun random-item (lst)
   "Returns a random element of a list"
   (declare (list lst))
   (if (null lst)
     nil
     (nth (random (length lst)) lst)))


;;; DIST      [Function]
;;; Description : Computes the distance between two locations (xy pairs, not
;;;             : chunks) using the  'real' hypoteneuse distance.

(defgeneric dist (loc1 loc2)
   (:documentation "Computes the distance in pixels between two XY locations"))

(defmethod dist ((loc1 vector) (loc2 vector))
   (sqrt (+ (expt (- (px loc1) (px loc2)) 2)
            (expt (- (py loc1) (py loc2)) 2))))

(defmethod dist ((loc1 list) (loc2 list))
   (dist (coerce loc1 'vector) (coerce loc2 'vector)))

;;; ROUND-XY      [Function]
;;; Date        : 97.02.13
;;; Description : Rounds an xy location to integer values

(defun round-xy (loc)
   (map 'vector #'round loc))

(defun ms-round (x)
   "Rounds a time to the nearest millisecond"
   (declare (number x))
   (* 0.001 (round x 0.001)))


(defun tornil (x)
   "Checks if a symbol is T or NIL"
   (or (eq x t) (eq x nil)))


(defun posnum (x)
   "Returns T only if <x> is a positive number"
   (and (numberp x) (>= x 0.)))


(defun rad->deg (r)
   "Converts radians into degrees."
   (declare (number r))
   (* r (/ 180 pi)))


(defun deg->rad (d)
   "Converts degrees into radians."
   (declare (number d))
   (* (/ pi 180) d))



(defmacro old-pm-output (message &rest args)
   `(when *verbose*
      (format t (concatenate 'string "~%<PM> " ,message) ,@args)))


(defmacro pm-output (time message &rest args)
   `(when *verbose*
      (if ,time
        (format t "~%~VTTime ~6,3F: " *goal-depth* ,time)
        (format t  "~%~VTTime ~6,3F: " *goal-depth* (mp-time *mp*)))
      (format t ,message ,@args)))

(defmacro pm-warning (message &rest args)
   `(format *error-output* (concatenate 'string "~%#PM Warning# " ,message)
            ,@args))



(defgeneric objs-match-slotval (lst slot-name value)
   (:documentation "Takes a list of CLOS objects and returns a list 
containing those items which have the slot <slot-name> equal to 
<value>."))

(defmethod objs-match-slotval ((ls list) (slot-name symbol) value)
   (when ls
     (let (accum)
       (dolist (obj ls (nreverse accum))
         (when (equal value (slot-value obj slot-name))
           (push obj accum))))))


(defmethod objs-match-slotval ((ls list) (slot-name symbol)
                                   (value number))
   (when ls
     (let (accum)
       (dolist (obj ls (nreverse accum))
         (when (= value (slot-value obj slot-name))
           (push obj accum))))))


(defmethod objs-match-slotval ((ls list) (slot-name symbol)
                                   (value symbol))
   (when ls
     (let (accum)
       (dolist (obj ls (nreverse accum))
         (when (eq value (slot-value obj slot-name))
           (push obj accum))))))


(defgeneric objs-min-slotval (lst slot-name)
   (:documentation "Given a list of CLOS objects and a slot name, 
return a list containing the object(s) with the lowest value for that 
slot."))

(defmethod objs-min-slotval ((ls list) (slot-name symbol))
   (when ls
     (let ((best (slot-value (first ls) slot-name))
           (current nil)
           (out-ls (list (first ls))))
       (dolist (obj (rest ls) (nreverse out-ls))
         (setf current (slot-value obj slot-name))
         (cond ((= current best) (push obj out-ls))
               ((< current best)
                (setf best current)
                (setf out-ls (list obj))))))))


(defgeneric objs-max-slotval (lst slot-name)
   (:documentation "Given a list of CLOS objects and a slot name, 
return a list containing the object(s) with the highest value for 
that slot."))

(defmethod objs-max-slotval ((ls list) (slot-name symbol))
   (when ls
     (let ((best (slot-value (first ls) slot-name))
           (current nil)
           (out-ls (list (first ls))))
       (dolist (obj (rest ls) (nreverse out-ls))
         (setf current (slot-value obj slot-name))
         (cond ((= current best) (push obj out-ls))
               ((> current best)
                (setf best current)
                (setf out-ls (list obj))))))))


(defclass spec ()
   ((check-slots :accessor check-slots :initform nil :initarg :check-slots)))


(defmethod initialize-instance :after ((self spec) &key)
   (let (val)
     (dovector (slotname (check-slots self))        ; was dolist
       (setf val (slot-value self slotname))
       (when (and val (listp val) (symbol-function (first val)))
         (setf (slot-value self slotname)
               (apply (first val) (rest val)))))))


(defgeneric match-spec-p (ts obj)
   (:documentation "Returns T if <obj> matches <spec>."))

(defmethod match-spec-p ((ts spec) (obj standard-object))
   (dovector (slotname (check-slots ts) t)
     (unless (slot-match-p ts obj slotname)
       (return-from match-spec-p nil))))


;;; SLOT-MATCH-P      [Function]
;;; Date        : 99.06.18
;;; Description : A slot matches the spec if the spec is :IGNORE, or if the
;;;             : the spec is a value and it EQUALs the value.  If the spec
;;;             : is a function, just return the result of the function
;;;             : call.

(defgeneric slot-match-p (spec object slotname)
   (:documentation "Determines if an object matches a spec on a 
particular slot."))

(defmethod slot-match-p ((ts spec) (obj standard-object)
                            (slotname symbol))
   (let ((condition (slot-value ts slotname))
         (value (slot-value obj slotname)))
     (cond ((eq condition :IGNORE) t)
           ((functionp condition)
            (funcall condition (slot-value obj slotname)))
           (t (equal condition value)))))


(defgeneric objs-match-spec (lst ts)
   (:documentation "Returns a list of objects from <lst> that match 
the spec <ts>."))

(defmethod objs-match-spec ((ls list) (ts spec))
   (remove-if #'(lambda (obj)
                  (not (match-spec-p ts obj))) ls))



(defgeneric pm-not-equal (val)
   (:documentation "Returns a closure that will evaluate if an 
argument is equal to <val>."))

;;; for symbols and integers (fixnums) we can use EQ.

(defmethod pm-not-equal ((val symbol))
   (lambda (s) (neq val s)))


#-(or :lispworks :clisp)
(defmethod pm-not-equal ((val fixnum))
   (lambda (s) (neq val s)))

;;; for floats, we have to round and then use EQ.

(defmethod pm-not-equal ((val float))
   (lambda (s) (not (eq (round s) (round val)))))

;;; for everything else, just use EQUAL.

(defmethod pm-not-equal (val)
   (setf val (check-gwn val))
   (lambda (s) (not (equal val s))))



(defgeneric within (min max)
   (:documentation "Returns a closure that will test whether the 
argument is betwen <min> and <max>, inclusive."))

(defmethod within ((min number) (max number))
   (lambda (val)
     (and (<= val max) (>= val min))))

(defmethod within ((min list) (max list))
   (within (check-fct min) (check-fct max)))

(defmethod within ((min number) (max list))
   (within min (check-fct max)))

(defmethod within ((min list) (max number))
   (within (check-fct min) max))


(defgeneric greater-than (criterion)
   (:documentation "Returns a closure that will return whether or not 
the argument is greater than <criterion>."))

(defmethod greater-than ((criterion number))
   (lambda (val)
     (> val criterion)))

(defmethod greater-than ((criterion list))
   (greater-than (check-fct criterion)))



(defgeneric less-than (criterion)
   (:documentation "Returns a closure that will return whether or not 
the argument is less than <criterion>."))

(defmethod less-than ((criterion number))
   (lambda (val)
     (< val criterion)))


(defmethod less-than ((criterion list))
   (less-than (check-fct criterion)))


(defgeneric string-to-lines (s)
   (:documentation "Given a string, break it into a list by #\Newline 
characters."))

(defmethod string-to-lines ((s string))
   (aif (position #\Newline s)
     (append (mklist (subseq s 0 it))
             (string-to-lines (subseq s (1+ it) (length s))))
     (list s)))


(defun check-gwn (x)
   "Checks to see if something is a GET-WME-NAME list.  If it is, it 
just evaluates it."
   (if (and (listp x) (eq (first x) 'GET-WME-NAME))
     (apply #'get-wme-name (list x))	;(eval x) mdb 01.07.28
     x))


(defgeneric check-fct (lst)
   (:documentation "If the input list represents a function call, 
return the value of that call.  Otherwise return the list."))

(defmethod check-fct ((ls list))
   (if (symbol-function (first ls))
     (eval ls)
     ls))


;;;  -*- mode: LISP; Package: CL-USER; Syntax: COMMON-LISP;  Base: 10 -*-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Author      : Mike Byrne
;;; Copyright   : (c)1997-2000 CMU/Rice U./Mike Byrne, All Rights Reserved
;;; Availability: public domain
;;; Address     : Rice University
;;;             : Psychology Department
;;;             : Houston,TX 77251-1892
;;;             : byrne@acm.org
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Filename    : speech-module.lisp
;;; Version     : 2.0
;;;
;;; Description : Source code for the ACT-R/PM Speech Module.  This Module
;;;             : is pretty brain-damaged but should get the job done
;;;             : for short, simple strings.
;;;
;;; Bugs        :
;;;
;;; Todo        :
;;;
;;; ----- History -----
;;; 97.04.02 Mike Byrne
;;;             : Incept date.
;;; 97.05.19 Mike Byrne
;;;             : Several minor bugs fixed, just clean-up stuff.
;;; 98.01.15 Mike Byrne
;;;             : Switched to use of OUTPUT-COMMAND.
;;; 98.01.19 Mike Byrne
;;;             : Added necessary RESET-MODULE command.
;;; 98.01.21 Mike Byrne
;;;             : Switched to use of QUEUE-EVENT command.
;;; 98.06.01 Mike Byrne
;;;             : Made relevant changes for b3.
;;; 99.04.06 mdb
;;;             : Tweaked SPEAK to send events to the device.
;;; 00.06.09 mdb
;;;             : Made SPEAK a regular movement style, which cleaned up the
;;;             : code considerably.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defparameter *char-per-syllable 3)


(defclass speech-module (pm-module)
   ((syllable-rate :accessor s-rate :initform 0.150)
    )
   (:default-initargs
     :name :SPEECH))


(defmethod initialize-instance :after ((spch-mod speech-module) &key)
   (setf (state-dmo spch-mod)
         (make-dme 'speech-state 'module-state
                   '(module :speech modality free processor free 
preparation free
                     execution free)
                   :where :external)))


;;;; 
---------------------------------------------------------------------- 
;;;;
;;;; SPEAK movement style


(defstyle speak () text)

(defmethod num-to-prepare ((mvmt speak))
   3)

(defmethod compute-exec-time ((spch-mod speech-module) (mvmt speak))
   (init-time spch-mod))

(defmethod compute-finish-time ((spch-mod speech-module) (mvmt speak))
   (+ (exec-time mvmt)
      (* (s-rate spch-mod) (/ (length (text mvmt)) *char-per-syllable))))


(defmethod feat-differences ((s1 speak) (s2 speak))
   (if (string= (text s1) (text s2))
     0
     2))


(defmethod queue-output-events ((spch-mod speech-module) (mvmt speak))
   (queue-command
    :time (exec-time mvmt) :where :DEVICE :command 'output-speech
    :params (text mvmt)))






;;;-*- Mode: Lisp; Package: CCL -*-

;;;  speech-utils.lisp
;;;
;;;  Some simple functions demonstrating use of
;;;  the new Macintosh Speech Manager
;;;
;;;  Bill Andersen (waander@cs.umd.edu)
;;;  University of Maryland
;;;  Department of Computer Science
;;;
;;;  August, 1993
;;;
;;;  Notes: To use these functions, you need to install the Macintosh
;;;  Speech Manager.  You can get this from ftp.apple.com.  You also
;;;  need the MCL interface file speech.lisp, which is available from
;;;  cambridge.apple.com.  Don't forget to call (reindex-interfaces)
;;;  after you get the interface file.
;;;
;;; Function documentation:
;;;
;;; SPEECH-AVAILABLE-P ()                                            [FUNCTION]
;;;    Returns T if the Speech Manager is installed, else NIL.
;;;
;;; SPEAK-STRING (s)                                                 [FUNCTION]
;;;    Speaks the string in the (crummy) default voice.
;;;
;;; SPEECH-BUSY-P ()                                                 [FUNCTION]
;;;    Returns T if text is currently being spoken, else NIL.
;;;
;;; COUNT-VOICES ()                                                  [FUNCTION]
;;;    Returns the number of voice resources defined in the system.
;;;
;;; SAMPLE-VOICES ()                                                 [FUNCTION]
;;;    Goes through the list of all voice resources defined in the
;;;    system and speaks the description text associated with each
;;;    one.
;;;
;;; SPEAK-IN-VOICE (index string)                                    [FUNCTION]
;;;    Speaks <string> in the voice specified by <index>.  Index must be
;;;    in the range of voice resource indexes known to the Speech Manager.
;;;    There is no limit to the length of the string which can be spoken.
;;;

(in-package :ccl)

(export '(speech-available-p
           speak-string
           speech-busy-p
           count-voices
           sample-voices
           speak-in-voice))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;;  Error Handling Stuff
;;;

(defun handle-speech-error (err)
   (let ((string
          (cond ((eql err #$paramErr)
                 "Parameter error")
                ((eql err #$memFullErr)
                 "Not enough memory to speak")
                ((eql err #$nilHandleErr)
                 "Handle argument is nil")
                ((eql err #$siUnknownInfoType)
                 "Feature not implemented on synthesizer")
                ((eql err #$noSynthFound)
                 "Could not find the specified speech synthesizer")
                ((eql err #$synthOpenFailed)
                 "Could not open another speech synthesizer channel")
                ((eql err #$synthNotReady)
                 "Speech synthesizer is still busy speaking")
                ((eql err #$bufTooSmall)
                 "Output buffer is too small to hold result")
                ((eql err #$voiceNotFound)
                 "Voice resource not found")
                ((eql err #$incompatibleVoice)
                 "Specified voice cannot be used with synthesizer")
                ((eql err #$badDictFormat)
                 "Problem with pronunciation dictionary")
                ((eql err #$invalidComponentID)
                 "Invalid SpeechChannel parameter")
                (t nil))))
     (if string
       (error "~a, (code = ~d)" string err)
       (error "An unknown speech error occurred, (code = ~d)" err))))

(defmacro with-spch-errors (form)
   (let ((code (gensym)))
     `(let ((,code ,form))
        (unless (eql ,code #$noErr)
          (handle-speech-error ,code))
        ,code)))

(defmacro check-for-speech ()
   `(unless (speech-available-p)
      (error "The Speech Manager is not installed on this machine.")))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;;  Interface Functions
;;;

;; SPEECH-AVAILABLE-P
;;
;; Returns T if the Speech Manager is installed, else NIL.

(defun speech-available-p ()
   "Returns T if the Speech Manager is installed, else NIL."
   (%stack-block ((result 8))
     (let ((err (#_Gestalt #$gestaltSpeechAttr result)))
       (if (or (/= err #$noErr)
               (not (logand (%get-signed-long result)
                            (ash 1 #$gestaltSpeechMgrPresent))))
         nil
         t))))

;; SPEAK-STRING
;;
;; Speaks the string in the (crummy) default voice.

(defun speak-string (s)
   "Speaks the string in the (crummy) default voice."
   (check-for-speech)
   (check-type s string)
   (with-pstrs ((pstr s))
     (with-spch-errors (#_SpeakString pstr))))

;; SPEECH-BUSY-P
;;
;; Returns T if text is currently being spoken, else NIL.

(defun speech-busy-p ()
   "Returns T if text is currently being spoken, else NIL."
   (check-for-speech)
   (= (#_SpeechBusy) 1))

;; COUNT-VOICES
;;
;; Returns the number of voice resources defined in the system.

(defun count-voices ()
   "Returns the number of voice resources defined in the system."
   (check-for-speech)
   (%stack-block ((voiceCount 2))
     (with-spch-errors (#_CountVoices voiceCount))
     (%get-word voiceCount)))

;; SAMPLE-VOICES
;;
;; Goes through the list of all voice resources defined in the
;; system and speaks the description text associated with each
;; one.

(defun sample-voices ()
   "Goes through the list of all voice resources defined in the
system and speaks the description text associated with each
one."
   (check-for-speech)
   (rlet ((voice :VoiceSpec)
          (info  :VoiceDescription)
          (chan  :SpeechChannel))
     (loop
       for i from 1 to (count-voices)
       do (progn
            (with-spch-errors
              (#_GetIndVoice i voice))
            (with-spch-errors
              (#_GetVoiceDescription voice info (record-length 
:VoiceDescription)))
            (with-spch-errors
              (#_NewSpeechChannel voice chan))
            (let ((string (format nil "Voice #~d: ~a. ~a." i
                                  (rref info :VoiceDescription.name)
                                  (rref info :VoiceDescription.comment))))
              (format t "~&~a~%" string)
              (with-pstrs ((pstr string))
                (unwind-protect
                  (progn
                    (with-spch-errors
                      (#_SpeakText (%get-ptr chan) (%inc-ptr pstr 1) 
(%get-byte pstr)))
                    (loop while (= (#_SpeechBusy) 1)))
                  (with-spch-errors
                    (#_DisposeSpeechChannel (%get-ptr chan))))))))))

;; SPEAK-IN-VOICE
;;
;; Speaks <string> in the voice specified by <index>.  Index must be
;; in the range of voice resource indexes known to the Speech Manager.
;; There is no limit to the length of the string which can be spoken.

(defun speak-in-voice (index string)
   "Speaks <string> in the voice specified by <index>.  Index must be
in the range of voice resource indexes known to the Speech Manager.
There is no limit to the length of the string which can be spoken."
   (check-for-speech)
   (check-type string string)
   (count-voices)                        ; not sure if I have to call this but
                                         ; it didn't work once until I did
   (rlet ((voice :VoiceSpec)
          (chan  :SpeechChannel))
     (with-spch-errors
       (#_GetIndVoice index voice))
     (with-spch-errors
       (#_NewSpeechChannel voice chan))
     (let* ((length (length string))
            (strptr (#_NewPtr length)))
       (%put-cstring strptr string)
       (unwind-protect
         (progn
           (with-spch-errors
             (#_SpeakText (%get-ptr chan) strptr length))
           (loop while (= (#_SpeechBusy) 1)))
         (with-spch-errors
           (#_DisposeSpeechChannel (%get-ptr chan)))
         (#_DisposPtr strptr)))))






;;; windows

;;; Windows

(defmethod close-rpm-window ((win rpm-window))
   (close win))


#+:allegro-V5.0.1
(defmethod open-rpm-window? ((win rpm-window))
   (not (or (equal (type-of win) 'closed-stream) (null win))))

#+:allegro-V5.0.1
(defmethod open-rpm-window? ((win closed-stream))
   nil)

#+(version>= 6)
(defmethod open-rpm-window? ((win rpm-window))
   (not (or (null (handle win)) (null win))))

;;; Windows

(defmethod select-rpm-window ((win rpm-window))
   (select-window win))

;;; Windows

(defmethod add-visual-items-to-rpm-window ((win rpm-window) &rest items )
  (let ((key-catcher (find-named-object 'key-catcher win)))
    (setf (dialog-items win) (remove key-catcher (dialog-items win)))
    (dolist (item (reverse (cons key-catcher items)))
      (setf (dialog-items win) (cons item (copy-list (dialog-items win))))
      )))


;;; Windows

(defmethod remove-visual-items-from-rpm-window ((win rpm-window) &rest items )
   (dolist (item items)
     (setf (dialog-items win) (remove item (dialog-items win)))))

;;; Windows

(defmethod remove-all-items-from-rpm-window ((win rpm-window))
   (let ((key-catcher (find-named-object 'key-catcher win)))
     (setf (dialog-items win) (list key-catcher))))

;;; windows

(defmethod make-button-for-rpm-window ((win rpm-window) &key (x 0) (y 
0) (text "Ok")  (action nil) (height 18)  (width 60))
     (make-instance 'button
             :left x
             :width width
             :height height
             :on-click #'(lambda (window button) (when action (funcall 
action window)))
             :title text
             :top y))

;;; Windows

(defmethod make-static-text-for-rpm-window ((win rpm-window) &key (x 
0) (y 0) (text "") (height 20) (width 20))
   (make-instance 'static-text
     :left x
     :width width
     :height height
     :value text
     :top y
     :on-click #'(lambda (x y) (mouse-left-down win nil nil))))

;;; Windows

(defmethod set-dialog-item-position-in-rpm-window ((win rpm-window) 
(item dialog-item) position)
   (setf (left item) (car position))
   (setf (top item) (cadr position)))



;;; windows

;;; It turns out that due to the bottom up nature of
;;; the event handling in ACL that a key press on a window
;;; only goes to the dialog items, it doesn't get passed
;;; back up the chain.  Also, certain types of dialog
;;; items (static-text) do not have a virtual-key-down method,
;;; so they will not respond to a key press and thus it can't be
;;; passed "back up the chain".  This causes problems because
;;; R/PM was designed around MCL where the events go top down
;;; i.e. the window gets first crack at handling them.
;;; This hack will allow certain experiments to be written
;;; for the UWI, but unfortunatly is not a general solution.
;;; As long as no dialog-item in the rpm-window is selected
;;; as the focus this should allow key presses to be passed
;;; up to the window for handling by the rpm-window-key-event-handler.
;;;

#+(version>= 6 1) (defclass key-catcher (group-box)
   ()
   (:default-initargs
    :name 'key-catcher
    :width 5
     :height 5
     :left -50
     :top 0))

#-(version>= 6 1) (defclass key-catcher (lisp-group-box)
   ()
   (:default-initargs
    :name 'key-catcher
    :width 5
     :height 5
     :left -50
     :top 0))

(defmethod build-features-for ((self key-catcher)
                                   (vis-mod vision-module))
   nil)

#+(version>= 6 1) (defmethod virtual-key-down :before ((catcher 
cg::group-box-pane) buttons key-code)
   (when (subtypep (type-of (parent catcher)) 'rpm-window)
     (virtual-key-down (parent catcher) buttons key-code)))

#-(version>= 6 1) (defmethod virtual-key-down :before ((catcher 
cg::lisp-group-box-pane) buttons key-code)
   (when (subtypep (type-of (parent catcher)) 'rpm-window)
     (virtual-key-down (parent catcher) buttons key-code)))


(defun make-rpm-window (&key (visible nil) (class nil) (title "RPM 
Window") (width 100) (height 100) (x 0 ) (y 0))
   (if visible
       (let ((win (make-window (gensym "rpm-window") :device (if class 
class 'rpm-window) :title title :width width :height height :left x 
:top y))
             (catcher (make-instance 'key-catcher)
                      )
             )
         ;(setf (window catcher) catch-pane)
         (setf (dialog-items win) (list catcher))
         win)
       (make-instance (if class class 'rpm-virtual-window) 
:window-title title :width width :height height :x-pos x :y-pos y)))


(defmethod rpm-window-title ((win rpm-window))
   (title win))

(defmethod rpm-window-visible-status ((win rpm-window))
   t)

(defmethod allow-event-manager ((win rpm-window))
   (let ((interior (window-interior win)))
     (erase-contents-box win (make-box 0 0 (box-width interior)
                                       (box-height interior))))
   (dolist (x (dialog-items win))
     (when (subtypep (type-of x) 'drawable)
       (when (on-redisplay x)
         (funcall (on-redisplay x) x win))))
   (process-pending-events))

(defmethod make-line-for-rpm-window ((wind rpm-window) start-pt 
end-pt &optional (color 'black))
   "returns a view for the specified window which will draw a line 
from the start-pt to the end-pt
    using the optional color specified (defaulting to black).  The 
start and end points are
    specified in list form (x y) for uniformity among systems."
   (make-instance 'liner
     :color (color-symbol->win-color color)
     :start-pt start-pt
     :end-pt end-pt))


(defvar *library-experiment-window* nil)

(defun permute-list (lis)
   (do* ((item (nth (random (length lis)) lis) (nth (random (length 
temp)) temp))
         (temp (remove item lis :count 1) (remove item temp :count 1))
         (result (list item) (cons item result)))
        ((null temp) result)))

(defun open-exp-window (title &key (width 300) (height 300) (visible 
t) (x 300) (y 300))
   ;(pprint visible)
   (if (open-rpm-window? *library-experiment-window*)
       (if (and (string-equal title (rpm-window-title 
*library-experiment-window*))
                (eql visible (rpm-window-visible-status 
*library-experiment-window*)))
           (progn
             (remove-all-items-from-rpm-window *library-experiment-window*)
             *library-experiment-window*)
         (progn
           (close-rpm-window *library-experiment-window*)

           (setf *library-experiment-window* (make-rpm-window
                                              :visible visible
                                              :title title
                                              :width width
                                              :height height
                                              :x x
                                              :y y)))
         )
     (setf *library-experiment-window* (make-rpm-window
                                        :visible visible
                                        :title title
                                        :width width
                                        :height height
                                        :x x
                                        :y y)))
   (select-rpm-window *library-experiment-window*)
   *library-experiment-window*)


(defun add-text-to-exp-window (&key (x 0) (y 0) (text "") (height 20) 
(width 75))
  (add-visual-items-to-rpm-window *library-experiment-window*
                                   (make-static-text-for-rpm-window
                                    *library-experiment-window*
                                    :text text
                                    :x x
                                    :y y
                                    :width width
                                    :height height)))
(defun clear-exp-window ()
   (remove-all-items-from-rpm-window *library-experiment-window*))







;;; mac

(defmethod open-rpm-window? ((win rpm-window))
   (wptr win))

;;; Mac

(defmethod close-rpm-window  ((win rpm-window))
   (window-close win))
;;; MAC

(defmethod select-rpm-window ((win rpm-window))
   (window-select win))
;;; Mac

(defmethod add-visual-items-to-rpm-window ((win rpm-window) &rest items )
   (dolist (item items)
     (add-subviews win item))
   (view-draw-contents win)
   (event-dispatch))
;;; Mac

(defmethod remove-visual-items-from-rpm-window ((win rpm-window) &rest items )
   (dolist (item items)
     (remove-subviews win item))
    (view-draw-contents win)
   (event-dispatch))
;;; Mac

(defmethod remove-all-items-from-rpm-window ((win rpm-window))
   (apply #'remove-subviews win (subviews win))
    (view-draw-contents win)
   (event-dispatch))
;;; mac

(defmethod make-button-for-rpm-window ((win rpm-window) &key (x 0) (y 
0) (text "Ok")  (action nil) (height 18)  (width 60))
   (make-dialog-item 'button-dialog-item
                         (make-point x y)
                         (make-point width height)
                         text
                         action
                         :default-button nil))
;;; Mac

(defmethod make-static-text-for-rpm-window ((win rpm-window) &key (x 
0) (y 0) (text "") (height 20) (width 80))
   (make-dialog-item 'static-text-dialog-item
                         (make-point x y)
                         (make-point width height)
                         text))
;;; mac

(defmethod set-dialog-item-position-in-rpm-window ((win rpm-window) 
(item dialog-item) position)
   (set-view-position item (car position) (cadr position)))
;;; mac

(defun make-rpm-window (&key (visible nil) (class nil) (title "RPM 
Window") (width 100) (height 100) (x 0 ) (y 0))
   (if visible
       (make-instance (if class class 'rpm-window) :window-title title 
:view-size (make-point width height) :view-position (make-point x y))
       (make-instance (if class class 'rpm-virtual-window) 
:window-title title :width width :height height :x-pos x :y-pos y)))


(defmethod rpm-window-title ((win rpm-window))
   (window-title win))

(defmethod rpm-window-visible-status ((win rpm-window))
   t)

(defmethod allow-event-manager ((win rpm-window))
   (event-dispatch))

(defmethod make-line-for-rpm-window ((wind rpm-window) start-pt 
end-pt &optional (color 'black))
   "returns a view for the specified window which will draw a line 
from the start-pt to the end-pt
    using the optional color specified (defaulting to black).  The 
start and end points are
    specified in list form (x y) for uniformity among systems."
   (let* ((gx (> (first end-pt) (first start-pt)))
          (gy (> (second end-pt) (second start-pt)))
          (vs (make-point (+ 1 (abs (- (first end-pt) (first start-pt))))
                          (+ 1 (abs (- (second end-pt) (second start-pt)))))))
     (cond ((and gx gy)
            (make-instance 'td-liner
              :color (color-symbol->mac-color color)
              :view-position (make-point (first start-pt) (second start-pt))
              :view-size vs))
           ((and (not gx) (not gy))
            (make-instance 'td-liner
              :color (color-symbol->mac-color color)
              :view-position (make-point (first end-pt) (second end-pt))
              :view-size vs))
           ((and gx (not gy))
            (make-instance 'bu-liner
              :color (color-symbol->mac-color color)
              :view-position (make-point (first start-pt) (second end-pt))
              :view-size vs))
           (t
            (make-instance 'bu-liner
              :color (color-symbol->mac-color color)
              :view-position (make-point (first end-pt) (second start-pt))
                                 :view-size vs)))))




;;; virtual


(defclass rpm-virtual-window (virtual-window)
   ((open :initform t :accessor window-open?)))


(defmethod close-rpm-window ((win rpm-virtual-window))
     (setf (window-open? win) nil))

(defmethod open-rpm-window? ((win rpm-virtual-window))
   (window-open? win))

(defmethod open-rpm-window? ((win null))
   nil)

;;; virtual

(defmethod select-rpm-window ((win rpm-virtual-window))
   (window-select win))


;;; virtual

(defmethod add-visual-items-to-rpm-window ((win rpm-virtual-window) 
&rest items)
   (dolist (item items)
     (add-subviews win item)))



;;; virtual

(defmethod remove-visual-items-from-rpm-window ((win 
rpm-virtual-window) &rest items)
   (dolist (item items)
     (remove-subviews win item)))



;;; virtual

(defmethod remove-all-items-from-rpm-window ((win rpm-virtual-window))
   (apply #'remove-subviews win (subviews win)))



;;; virtual

(defmethod make-button-for-rpm-window ((win rpm-virtual-window) &key 
(x 0) (y 0) (text "Ok")  (action nil) (height 18)  (width 60))
   (make-instance 'button-vdi
     :x-pos x :y-pos y
     :dialog-item-text text
     :action action
     :height height
     :width width))


;;; virtual

(defmethod make-static-text-for-rpm-window ((win rpm-virtual-window) 
&key (x 0) (y 0) (text "") (height 20) (width 80))
   (make-instance 'static-text-vdi
     :x-pos x :y-pos y
     :dialog-item-text text
     :height height
     :width width
     ))



;;; virtual

(defmethod set-dialog-item-position-in-rpm-window ((win 
rpm-virtual-window) (item virtual-dialog-item) position)
   (setf (x-pos item) (car position))
   (setf (y-pos item) (cadr position)))

(defun make-rpm-window (&key (visible nil) (class nil) (title "RPM 
Window") (width 100) (height 100) (x 0 ) (y 0))
   (if visible
       (format t "Cannot make a visible window, you must use virtual.~%")
       (make-instance (if class class 'rpm-virtual-window) 
:window-title title :width width :height height :x-pos x :y-pos y)))


(defmethod rpm-window-title ((win rpm-virtual-window))
   (window-title win))

(defmethod rpm-window-visible-status ((win rpm-virtual-window))
   nil)


(defmethod allow-event-manager ((win rpm-virtual-window))
   )

(defmethod make-line-for-rpm-window ((wind rpm-virtual-window) 
start-pt end-pt &optional (color 'black))
   "returns a view for the specified window which will draw a line 
from the start-pt to the end-pt
    using the optional color specified (defaulting to black).  The 
start and end points are
    specified in list form (x y) for uniformity among systems."
   (make-instance 'v-liner
     :color color
     :x-pos (first start-pt)
     :y-pos (second start-pt)
     :width (first end-pt)
     :height (second end-pt)))



;;;  -*- mode: LISP; Package: CL-USER; Syntax: COMMON-LISP;  Base: 10 -*-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Author      : Dan Bothell
;;; Copyright   : (c)2000 CMU/Dan Bothell, All Rights Reserved
;;; Availability: public domain
;;; Address     : Carnegie Mellon University
;;;             : Psychology Department
;;;             : Pittsburgh,PA 15213-3890
;;;             : db30+@andrew.cmu.edu
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Filename    : view-line-acl.lisp
;;; Version     : r0
;;;
;;; Description : Allows for drawing lines in ACL windows using a 
dialog-item (transparent pane),
;;;             : and therefore can generate features for the window. 
That way R/PM will see
;;;             : the lines without using rpm-line-to and having to deal with
;;;             : making sure the lines are redrawn when there is a 
pm-proc-display.
;;;             : Based entirely on Mike's view-line.lisp.
;;; Bugs        :
;;;
;;; Todo        :
;;; ----- History -----
;;; 01.02.14 Dan Bothell
;;;             : incept date
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;;; The base class for the dialog based lines.  All it adds is a color slot.

(defclass liner (drawable)
   ((color :accessor color :initarg :color :initform 'black)
    (start-pt :accessor start-pt :initarg :start-pt :initform (list 0 0))
    (end-pt :accessor end-pt :initarg :end-pt :initform (list 0 0)))
   (:default-initargs
    :width 1
     :height 1
     :left -2
     :top 0
     :on-redisplay 'draw-view-line))


(defun draw-view-line (di stream)
   (declare ignore-if-unused stream)
   (let* ((real-stream (parent di)))
     (with-foreground-color (real-stream (color di))
       (draw-line real-stream (make-position (first (start-pt di)) 
(second (start-pt di)))
                  (make-position (first (end-pt di)) (second (end-pt di)))))))


(defmethod build-features-for ((lnr liner) (vis-mod vision-module))
   "Convert the view to a feature to be placed into the visual icon"
   (make-instance 'line-feature
      :color (win-color->symbol (color lnr))
      :end1-x (first (start-pt lnr))
      :end1-y (second (start-pt lnr))
      :end2-x (first (end-pt lnr))
      :end2-y (second (end-pt lnr))
      :x (loc-avg (first (start-pt lnr)) (first (end-pt lnr)))
      :y (loc-avg (second (start-pt lnr)) (second (end-pt lnr)))
      :width (abs (- (first (start-pt lnr)) (first (end-pt lnr))))
      :height (abs (- (second (start-pt lnr)) (second (end-pt lnr))))))





(defun rpm-view-line (wind start-pt end-pt &optional (color black))
   "Adds a dialog-item representing the line to the specified window
    which will draw a line from the start-pt to the end-pt on the window
    using the optional color specified (defaulting to black). "
   (let* ((dis (dialog-items wind)))
     (setf (dialog-items wind) (cons (make-instance 'liner
                                       :color color
                                       :start-pt start-pt
                                       :end-pt end-pt) dis))))



(defun win-color->symbol (color)
   "Return a symbol that names the color for the 'recognized' colors.
    Any other color gets mapped to a symbol color-RRRRR-GGGGG-BBBBB where the
    R's, G's, and B's are the red, green, and blue components of the
    color left padded with zeros to 5 digits."
   (cond ((equal color red) 'red)
         ((equal color blue) 'light-blue)
         ((equal color green) 'green)
         ((equal color black) 'black)
         ((equal color white) 'white)
         ((equal color magenta) 'pink)
         ((equal color yellow) 'yellow)
         ((equal color dark-green) 'dark-green)
         ((equal color dark-blue) 'blue)
         ((equal color dark-magenta) 'purple)
         ((equal color dark-yellow) 'brown)
         ((equal color light-gray) 'light-gray)
         ((equal color gray) 'gray)
         ((equal color dark-gray) 'dark-gray)
         (t (intern (format nil "COLOR-~5,'0d-~5,'0d-~5,'0d"
                                 (rgb-red color)
                                 (rgb-green color)
                                 (rgb-blue color))))))

(defun color-symbol->win-color (color)
   "this may look like it should do the inverse of the above, but right now
    it doesn't exactly.  If the color isn't one of the default ones then
    the black color is returned.  It's only being used by the UWI right now,
    so it's simplified for that purpose."
   (cond ((equal color 'red) red)
         ((equal color 'blue) dark-blue)
         ((equal color 'green) green)
         ((equal color 'black) black)
         ((equal color 'white) white)
         ((equal color 'pink)  magenta)
         ((equal color 'yellow) yellow)
         ((equal color 'dark-green) dark-green)
         ((equal color 'light-blue) blue)
         ((equal color 'purple) dark-magenta)
         ((equal color 'brown) dark-yellow)
         ((equal color 'light-gray) light-gray)
         ((equal color 'gray) gray)
         ((equal color 'dark-gray) dark-gray)
         (t black)))






;;;  -*- mode: LISP; Package: CL-USER; Syntax: COMMON-LISP;  Base: 10 -*-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Author      : Mike Byrne
;;; Copyright   : (c)2000 Rice U./Mike Byrne, All Rights Reserved
;;; Availability: public domain
;;; Address     : Rice University
;;;             : Psychology Department
;;;             : Houston,TX 77251-1892
;;;             : byrne@acm.org
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Filename    : view-line.lisp
;;; Version     : r2
;;;
;;; Description : Allows for drawing lines in MCL windows that creates views,
;;;             : and therefore features, for the window.  That way 
R/PM will see
;;;             : the lines without using rpm-line-to and having to deal with
;;;             : making sure the lines are redrawn when there is a 
pm-proc-display.
;;;
;;; Bugs        :
;;;
;;; Todo        :
;;;
;;; ----- History -----
;;; 00.08.23 Mike Byrne
;;;             :  Incept date.
;;;
;;; 01.01.22 Dan Bothell
;;;             :  Changed the view-draw-contents for the line view so that it
;;;             :  actually draws on the parent window and not 
directly on the subview
;;;             :  (I assumed that was kosher, since the original did 
that the first
;;;             :  time, but not in the view-draw-contents - though 
I've not done a lot
;;;             :  of Mac interface work, so I may be violating some 
rule of what a subview
;;;             :  is allowed to do).
;;;             :  Fixed the horizontal (and vertical) line problem 
by always having
;;;             :  the view-size be 1 larger in each direction, so 
the 0 height views
;;;             :  are now 1 high and get updated (the 
view-draw-contents compensates
;;;             :  for the extra height by subtracting 1).
;;;             :  Added a color option to the line, and put in a 
function that converts
;;;             :  a default Mac color to a symbol (*red-color* for 
example to the symbol red)
;;;             :  for use in creating the chunks.  The nondefault 
colors get converted to
;;;             :  the symbol color-RRRRR-GGGGG-BBBBB where the R's, 
G's, and B's are the
;;;             :  red, green, and blue components of the color left 
padded with zeros
;;;             :  to 5 digits.
;;;             :  Added the feat-to-dmo method for a line-feature 
because R/PM 2.0b4 doesn't
;;;             :  seem to have one anymore (which caused some 
problems for rpm-line-to also).
;;;             :  Updated the version from r1 to r2.  (Why is it r? 
What does that mean?)
;;;             :  Various comments added to help make this clearer. 
You don't know how long
;;;             :  it took me to figure out what td and bu meant...
;;;             :
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;;; The base class for the view based lines.  All it adds is a color slot.

(defclass liner (simple-view)
   ((color :accessor color :initarg :color :initform *black-color*)))



(defmethod point-in-click-region-p ((self liner) where)
   "Method needed by R/PM so that if the mouse is clicked on the view it
    doesn't get handled by this view, and is passed on to the next"
   (declare (ignore where))
   nil)


;;;  A view that represents a line which is drawn top-down i.e. from the
;;;  view-position (upper-left) to the [view-size - (1,1)] (lower-right) in the
;;;  container window

(defclass td-liner (liner)
   ()
   )

;;;  A view that represents a line which is drawn bottom-up i.e. from the
;;;  view's lower-left to the view's upper-right in the container window.

(defclass bu-liner (liner)
   ()
   )


(defmethod view-draw-contents ((lnr td-liner))
   "Draws the line on the view-container window using the color specified
    and restoring the previous draw color and pen position"
   (let* ((parent (view-container lnr))
          (old-point (pen-position parent))
          (old-color (get-fore-color parent))
          (other-end (add-points (view-size lnr) (view-position lnr))))
     (set-fore-color parent (color lnr))
     (move-to parent (view-position lnr))
     (line-to parent (make-point (1- (point-h other-end))
                                 (1- (point-v other-end))))
     (set-fore-color parent old-color)
     (move-to parent old-point)))



(defmethod view-draw-contents ((lnr bu-liner))
   "Draws the line on the view-container window using the color specified
    and restoring the previous draw color and pen position"
   (let* ((parent (view-container lnr))
          (old-point (pen-position parent))
          (old-color (get-fore-color parent)))
     (set-fore-color parent (color lnr))
     (move-to parent (make-point (point-h (view-position lnr))
                                 (1- (point-v (add-points 
(view-position lnr) (view-size lnr))))))
     (line-to parent (make-point (1- (point-h (add-points (view-size 
lnr) (view-position lnr))))
                                 (point-v (view-position lnr))))
     (set-fore-color parent old-color)
     (move-to parent old-point)))


(defmethod build-features-for ((lnr td-liner) (vis-mod vision-module))
   "Convert the view to a feature to be placed into the visual icon"
   (let ((start-pt (view-position lnr))
         (end-pt (subtract-points (add-points (view-position lnr) 
(view-size lnr))
                                   (make-point 1 1))))
     (make-instance 'line-feature
       :color (mac-color->symbol (color lnr))
       :end1-x (point-h start-pt)
       :end1-y (point-v start-pt)
       :end2-x (point-h end-pt)
       :end2-y (point-v end-pt)
       :x (loc-avg (point-h start-pt) (point-h end-pt))
       :y (loc-avg (point-v start-pt) (point-v end-pt))
       :width (abs (- (point-h start-pt) (point-h end-pt)))
       :height (abs (- (point-v start-pt) (point-v end-pt))))))


(defmethod build-features-for ((lnr bu-liner) (vis-mod vision-module))
   "Convert the view to a feature to be placed into the visual icon"
   (let ((start-pt (add-points (view-position lnr)
                                 (make-point 0 (1- (point-v (view-size lnr))))))


         (end-pt (add-points (view-position lnr)
                              (make-point (1- (point-h (view-size lnr))) 0))))
     (make-instance 'line-feature
       :color (mac-color->symbol (color lnr))
       :end1-x (point-h start-pt)
       :end1-y (point-v start-pt)
       :end2-x (point-h end-pt)
       :end2-y (point-v end-pt)

       :x (loc-avg (point-h start-pt) (point-h end-pt))
       :y (loc-avg (point-v start-pt) (point-v end-pt))
       :width (abs (- (point-h start-pt) (point-h end-pt)))
       :height (abs (- (point-v start-pt) (point-v end-pt))))))


(defun rpm-view-line (wind start-pt end-pt &optional (color *black-color*))
   "Adds a view in the specified window which draws a line from the 
start-pt to the end-pt
    using the optional color specified (defaulting to black).  This 
view will add features
    to the icon on PM-PROC-DISPLAY."
   (let* ((gx (> (point-h end-pt) (point-h start-pt)))
          (gy (> (point-v end-pt) (point-v start-pt)))
          (vs (subtract-points start-pt end-pt)))
     (setf vs (make-point (+ 1 (abs (point-h vs)))
                          (+ 1 (abs (point-v vs)))))
     (add-subviews wind (cond ((and gx gy)
                               (make-instance 'td-liner
                                 :color color
                                 :view-position start-pt
                                 :view-size vs))
                              ((and (not gx) (not gy))
                               (make-instance 'td-liner
                                 :color color
                                 :view-position end-pt
                                 :view-size vs))
                              ((and gx (not gy))
                               (make-instance 'bu-liner
                                 :color color
                                 :view-position (make-point (point-h 
start-pt) (point-v end-pt))
                                 :view-size vs))
                              (t
                               (make-instance 'bu-liner
                                 :color color
                                 :view-position (make-point (point-h 
end-pt) (point-v start-pt))
                                 :view-size vs))))))



(defun mac-color->symbol (color)
   "Return a symbol that names the color.  For a default Mac color the symbol
    is the corresponding name i.e. *red-color* maps to red, but only for the
    'recognized' colors (those that basically map between win and mac).
    Any other color gets mapped to a symbol color-RRRRR-GGGGG-BBBBB 
where the R's,
    G's, and B's are the red, green, and blue components of the color 
left padded
    with zeros to 5 digits."
   (cond ((equal color *red-color*) 'red)
         ((equal color *blue-color*) 'blue)
         ((equal color *green-color*) 'green)
         ((equal color *black-color*) 'black)
         ((equal color *white-color*) 'white)
         ((equal color *pink-color*) 'pink)
         ((equal color *yellow-color*) 'yellow)
         ((equal color *dark-green-color*) 'dark-green)
         ((equal color *light-blue-color*) 'light-blue)
         ((equal color *purple-color*) 'purple)
         ((equal color *brown-color*) 'brown)
         ((equal color *light-gray-color*) 'light-gray)
         ((equal color *gray-color*) 'gray)
         ((equal color *dark-gray-color*) 'dark-gray)
         (t (intern (format nil "COLOR-~5,'0d-~5,'0d-~5,'0d"
                            (color-red color)
                            (color-green color)
                            (color-blue color))))))

(defun color-symbol->mac-color (color)
   "this may look like it should do the inverse of the above, but right now
    it doesn't exactly.  If the color isn't one of the default ones then
    the black color is returned.  It's only being used by the UWI right now,
    so it's simplified for that purpose.  Only colors that the systems have
    in 'common' are used - with the Mac names being the default, in keeping
    with the usual bias :) "
   (cond ((equal color 'red) *red-color*)
         ((equal color 'blue) *blue-color*)
         ((equal color 'green) *green-color*)
         ((equal color 'black) *black-color*)
         ((equal color 'white) *white-color*)
         ((equal color 'pink)  *pink-color*)
         ((equal color 'yellow) *yellow-color*)
         ((equal color 'dark-green) *dark-green-color*)
         ((equal color 'light-blue) *light-blue-color*)
         ((equal color 'purple) *purple-color*)
         ((equal color 'brown) *brown-color*)
         ((equal color 'light-gray) *light-gray-color*)
         ((equal color 'gray) *gray-color*)
         ((equal color 'dark-gray) *dark-gray-color*)
         (t *black-color*)))


;;;  -*- mode: LISP; Package: CL-USER; Syntax: COMMON-LISP;  Base: 10 -*-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Author      : Dan Bothell
;;; Copyright   : (c)2000 CMU/Dan Bothell, All Rights Reserved
;;; Availability: public domain
;;; Address     : Carnegie Mellon University
;;;             : Psychology Department
;;;             : Pittsburgh, PA 15213
;;;             : db30+@andrew.cmu.edu
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Filename    : view-line-virtual.lisp
;;; Version     : r0
;;;
;;; Description : virtual version of the view-line.lisp file - works with the
;;;             : R/PM virtual views.
;;; Bugs        :
;;;
;;; Todo        :
;;;
;;; ----- History -----
;;;
;;; 01.02.13 Dan Bothell
;;;             : Incept date.  Basically copied from the view-line.lisp
;;;             : file and simplified because it doesn't need to be able to
;;;             : draw itself, or be concerned about which end is which.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;;; The base class for the view based lines.

(defclass v-liner (virtual-view)
   ())


(defmethod point-in-click-region-p ((self v-liner) where)
   "Method needed by R/PM so that if the mouse is clicked on the view it
    doesn't get handled by this view, and is passed on to the next"
   (declare (ignore where))
   nil)


(defmethod build-features-for ((lnr v-liner) (vis-mod vision-module))
   "Convert the view to a feature to be placed into the visual icon"

   (make-instance 'line-feature
      :color  (color lnr)
      :end1-x (x-pos lnr)
      :end1-y (y-pos lnr)
      :end2-x (width lnr)
      :end2-y (height lnr)
      :x (floor (/ (+ (x-pos lnr) (width lnr)) 2))
      :y (floor (/ (+ (y-pos lnr) (height lnr)) 2))
      :width (abs (- (x-pos lnr) (width lnr)))
      :height (abs (- (y-pos lnr) (height lnr)))))


(defmethod feat-to-dmo ((feat line-feature))
   "Convert the line-feature from the visual icon to a DMO (chunk in ACT-R)
    when the feature is attended to"
   (setf (attended-p feat) t)
   (make-dme (dmo-id feat) (kind feat)
             `(screen-pos ,(id (xy-to-dmo (xy-loc feat) t))
               value ,(val feat)
               color ,(color feat)
               height ,(height feat)
               width ,(width feat)
               end1-x ,(end1-x feat)
               end1-y ,(end1-y feat)
               end2-x ,(end2-x feat)
               end2-y ,(end2-y feat))
             :obj (screen-obj feat)
             :where :external))




;;;  -*- mode: LISP; Package: CL-USER; Syntax: COMMON-LISP;  Base: 10 -*-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Author      : Mike Byrne & Dan Bothell
;;; Copyright   : (c)2000-1 Rice U./Mike Byrne, All Rights Reserved
;;; Availability: public domain
;;; Address     : Rice University
;;;             : Psychology Department
;;;             : Houston,TX 77251-1892
;;;             : byrne@acm.org
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Filename    : virtual-view.lisp
;;; Version     : 2.1b4
;;;
;;; Description : Instantiates "virtual views" so that RPM can act on things
;;;             : other than MCL windows.
;;;
;;; Bugs        :
;;;
;;; Todo        :
;;;
;;; ----- History -----
;;; 00.06.08 Mike Byrne
;;;             :  Date for new header.
;;; 00.09.13 mdb
;;;             : Updated for vectors.
;;; 00.11.15 mdb
;;;             : Fixed minor compiler warnings, cleaned up some lingering
;;;             : vector bugs.
;;; 01.07.03 mdb
;;;             : Added defgenerics and doc strings.
;;;
;;; 02.01.15 Dan
;;;             : Changed the declaration of ignore to
;;;             : ignore-if-unused for the subviews method
;;;             : to eliminate an ugly warnings in ACL.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;; 
---------------------------------------------------------------------- 
;;;;
;;;; Base Virtual View class.

(defclass virtual-view ()
   ((view-subviews :accessor view-subviews :initarg :subviews
                   :initform (make-hash-table))
    (x-pos :accessor x-pos :initform nil :initarg :x-pos)
    (y-pos :accessor y-pos :initform nil :initarg :y-pos)
    (width :accessor width :initform nil :initarg :width)
    (height :accessor height :initform nil :initarg :height)
    (id :accessor id :initarg :id :initform (new-name-fct "VV"))
    (handles-click-p :accessor handles-click-p :initform t
                     :initarg :handles-click-p)
    (view-container :accessor view-container :initform nil)
    (color :accessor color :initarg :color :initform 'black)
    ))

#-:mcl
(defgeneric subviews (view &optional subview-type)
   (:documentation "Returns a list of subviews of <view>."))

(defmethod subviews ((vv virtual-view) &optional subview-type)
   (declare (ignore subview-type))
   (let (accum)
     (maphash #'(lambda (x y) (declare (ignore x))
                 (push y accum))
              (view-subviews vv))
     accum))

#-:mcl
(defgeneric set-view-position (view x &optional y)
   (:documentation  "Sets the position of <view> to the supplied location."))

(defmethod set-view-position ((vv virtual-view) x &optional y)
   (setf (x-pos vv) x)
   (when y
     (setf (y-pos vv) y)))


#-:mcl
(defgeneric set-view-size (view x &optional y)
   (:documentation  "Set the size of <view> to the provided dimensions."))

(defmethod set-view-size ((vv virtual-view) x &optional y)
   (setf (width vv) x)
   (when y
     (setf (height vv) y)))


#-:mcl
(defgeneric view-size (view)
   (:documentation  "Return the size of <view> as #(x y)."))

(defmethod view-size ((vv virtual-view))
   (vector (width vv) (height vv)))


#-:mcl
(defgeneric view-position (view)
   (:documentation  "Return the top left position of <view> in its 
container as #(x y)."))

(defmethod view-position ((vv virtual-view))
   (vector (x-pos vv) (y-pos vv)))


(defmethod view-loc ((vv virtual-view))
   (vector (+ (x-pos vv) (/ (width vv) 2))
           (+ (y-pos vv) (/ (height vv) 2))))


#-:mcl
(defgeneric add-subviews (view &rest subviews)
   (:documentation  "Add subviews to <view>."))

(defmethod add-subviews ((vv virtual-view) &rest subviews)
   (dolist (sub subviews)
     (setf (gethash (id sub) (view-subviews vv)) sub)
     (setf (view-container sub) vv)))


#-:mcl
(defgeneric remove-subviews (view &rest subviews)
   (:documentation  "Remove subviews from <view>."))

(defmethod remove-subviews ((vv virtual-view) &rest subviews)
   (dolist (sub subviews)
     (remhash (id sub) (view-subviews vv))
     (setf (view-container sub) nil)))


(defgeneric point-in-vv-p (vview point)
   (:documentation  "Determine if the supplied point is inside the 
supplied view."))

(defmethod point-in-vv-p ((vv virtual-view) point)
   (let ((x (the fixnum (px point)))
         (y (the fixnum (py point))))
     (and (>= x (the fixnum (x-pos vv)))
          (>= y (the fixnum (y-pos vv)))
          (<= x (the fixnum (+ (x-pos vv) (width vv))))
          (<= y (the fixnum (+ (y-pos vv) (height vv)))))))


(defgeneric vv-click-event-handler (vview point)
   (:documentation  "Handle a click in <vview> at point <point>."))

(defmethod vv-click-event-handler ((vv virtual-view) point)
   (declare (ignore point))
   nil)


;;;; 
---------------------------------------------------------------------- 
;;;;
;;;; Virtual Window class and methods.

(defclass virtual-window (virtual-view)
   ((window-title :accessor window-title :initarg :window-title
                  :initform "Virtual Window")
    (outstrm :accessor outstrm :initarg :outstrm :initform t)
    (cursor-pos :accessor cursor-pos :initform #(0 0) :initarg :cursor-pos)
    (cursor-shape :accessor cursor-shape :initform 'POINTER
                  :initarg :cursor-shape)
    )
   (:default-initargs
     :x-pos 0
     :y-pos 0
     :id (new-name-fct "VW")
     ))


(defmethod get-mouse-coordinates ((vw virtual-window))
   (cursor-pos vw))


(defmethod build-features-for ((vw virtual-window)
                                   (vis-mod vision-module))
    (mapcar #'(lambda (obj) (build-features-for obj vis-mod))
            (subviews vw)))


(defmethod cursor-to-feature ((vw virtual-window))
   (when (point-in-vv-p vw (cursor-pos vw))
     (make-instance 'cursor-feature
         :x (px (cursor-pos vw)) :y (py (cursor-pos vw))
         :value (cursor-shape vw))))


(defmethod device-move-cursor-to ((vw virtual-window) (xyloc list))
   (device-move-cursor-to vw (coerce xyloc 'vector))
   )


(defmethod device-move-cursor-to ((vw virtual-window) (loc vector))
   (setf (cursor-pos vw) loc)
   (when (with-cursor-p (device-interface *mp*))
       (pm-proc-display)))


(defmethod device-handle-keypress ((vw virtual-window) key)
   (rpm-window-key-event-handler vw key)
   (when (car (no-output (sgp :v)))
     (vw-output vw "got key ~S at time ~S" key (pm-get-time))
   ))


(defmethod rpm-window-key-event-handler ((vw virtual-window) key)
   (declare (ignore key))
   )


(defmethod device-speak-string ((vw virtual-window) string)
   (vw-output vw "heard speech '~A' at time ~S" string (pm-get-time))
   )


(defmethod device-handle-click ((vw virtual-window))
   (rpm-window-click-event-handler vw (cursor-pos vw))
   (dolist (sub (subviews vw))
     (when (and (handles-click-p sub)
                (point-in-vv-p sub (cursor-pos vw)))
       (vv-click-event-handler sub (cursor-pos vw))
       (return-from device-handle-click t)))
   (when (car (no-output (sgp :v)))
     (vw-output vw "was clicked at time ~S" (pm-get-time))))


(defmethod rpm-window-click-event-handler ((vw virtual-window) pos)
   (declare (ignore pos))
   )


(defgeneric vw-output (vwind base &rest args)
   (:documentation  "Print some output to a virtual window."))

(defmethod vw-output ((vw virtual-window) (base string) &rest args)
   (push base args)
   (push nil args)
   (format (outstrm vw)
           "~&~%<< Window ~S ~A >>~%"
           (window-title vw)
           (apply #'format args)))


#-:mcl
(defgeneric view-window (view)
   (:documentation  "Returns the window associated with <view> (if 
any), or <view> if <view> is a window."))

(defmethod view-window ((vw virtual-window))
   vw)


#-:mcl
(defgeneric window-close (wind)
   (:documentation  "Closes a window."))

;;; there isn't really anything to close in a virtual window, so do nothing
(defmethod window-close ((vw virtual-window))
   nil)

#-:mcl
(defgeneric window-select (wind)
   (:documentation  "Brings <wind> to the front."))

;;; there's no "front" in virtual windows, so do nothing.
(defmethod window-select ((vw virtual-window))
   nil)


#-:mcl
(defgeneric set-window-title (wind new-title)
   (:documentation  "Set the title of <wind> to <new-title>."))

(defmethod set-window-title ((window virtual-window) (new-title string))
   (setf (window-title window) new-title))


;;;; 
---------------------------------------------------------------------- 
;;;;
;;;; View classes:  static-text-vv, button-vv,


(defclass virtual-dialog-item (virtual-view)
   ((text :accessor dialog-item-text :initform "Untitled"
          :initarg :dialog-item-text)
    (action-function :accessor action-function :initarg :action :initform nil)
    (text-height :accessor text-height :initarg :text-height :initform 10)
    (str-width-fct :accessor str-width-fct :initarg :str-width-fct
                   :initform #'(lambda (str)
                                 (* 7 (length str))))
    )
   (:default-initargs
        :height 18
        :width 60
        :subviews nil))


#-:mcl
(defgeneric set-dialog-item-text (dialog-item text)
   (:documentation  "Set the text associated with <dialog-item> to <text>."))

(defmethod set-dialog-item-text ((vdi virtual-dialog-item) (text string))
   (setf (dialog-item-text vdi) text))


(defmethod subviews ((vdi virtual-dialog-item) &optional subview-type)
   (declare (ignore-if-unused vdi subview-type))
   nil)


(defmethod view-window ((vdi virtual-dialog-item))
   (let ((vc (view-container vdi)))
     (if (null vc)
       nil
       (if (typep vc 'virtual-window)
         vc
         (view-window vc)))))


(defclass static-text-vdi (virtual-dialog-item)
   ()
   (:default-initargs
        :id (new-name-fct "TEXT-VDI")
        :handles-click-p nil))


(defmethod build-features-for ((self static-text-vdi)
                                   (vis-mod vision-module))
   (build-string-feats vis-mod :text (dialog-item-text self)
                       :start-x (1+ (x-pos self))
                       :y-pos (py (view-loc self))
                       :width-fct (str-width-fct self)
                       :height (text-height self)
                       :obj self))




(defclass button-vdi (virtual-dialog-item)
   ()
   (:default-initargs
        :id (new-name-fct "BUTTON-VDI")
        :action #'default-button-action
        ))


(defmethod vv-click-event-handler ((btn button-vdi) where)
   (declare (ignore where))
   (awhen (functionp (action-function btn))
     (funcall it btn)))


(defmethod default-button-action ((btn button-vdi))
   (format t "~%Button '~S' clicked at time ~S."
           (dialog-item-text btn) (pm-get-time)))



(defmethod build-features-for ((self button-vdi) (vis-mod vision-module))
   (cons
    (make-instance 'oval-feature
      :x (px (view-loc self))
      :y (py (view-loc self))
      :screen-obj self
      :width (width self)
      :height (height self))
    (build-string-feats vis-mod :text (dialog-item-text self)
                        :start-x
                        (+ (x-pos self)
                           (round
                            (funcall (str-width-fct self)
                                     (dialog-item-text self))
                            2))
                        :y-pos (y-pos self)
                        :width-fct (str-width-fct self)
                        :height (text-height self)
                        :obj self)))



;;;  -*- mode LISP; Package CL-USER; Syntax COMMON-LISP;  Base 10 -*-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Author       Mike Byrne
;;; Copyright    (c)1999-2001 CMU/Rice U./Mike Byrne, All Rights Reserved
;;; Availability public domain
;;; Address     : Rice University
;;;             : Psychology Department, MS-25
;;;             : Houston, TX  777005-1892
;;;             : byrne@acm.org
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Filename     vision-categorization.lisp
;;; Version      2.0
;;;
;;; Description  Class and constants for different feature sets.
;;;
;;; Bugs
;;;
;;; Todo
;;;
;;; ----- History -----
;;; 99.06.10 Mike Byrne
;;;               Header date.
;;; 99.07.30 mdb
;;;              Added GETFEATS.
;;; 99.08.08 mdb
;;;             : Removed keywords from feature lists, added PROB-BEST-CHAR.
;;; 99.09.08 mdb
;;;             : Corrected RM set from Mike Matessa's comments.
;;; 00.06.09 mdb
;;;             : Conversion of "new-feats.lisp" file to
;;;             : "vision-categorization" for inclusion in RPM 2.0.
;;; 01.06.29 mdb
;;;             : Added defgenerics and doc strings.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


(defclass char-feats ()
   ((feature-ls :accessor feature-ls :initarg :feat-ls)
    (fhash :accessor fhash :initform (make-hash-table :test #'equal))
    (letters :accessor letters :allocation :class
             :initform '("A" "B" "C" "D" "E" "F" "G" "H" "I" "J" "K" "L" "M"
                           "N" "O" "P" "Q" "R" "S" "T" "U" "V" "W" "X" "Y" "Z"))
    (digits :accessor digits :allocation :class
            :initform '("1" "2" "3" "4" "5" "6" "7" "8" "9" "0"))
    (average-match-prob :accessor average-match-prob :initform nil)
    (name :accessor name :initarg :name :initform nil)
    (number-of-features :accessor number-of-features :initform nil)
    (true->icon :accessor true->icon :initarg :true->icon :initform #'identity)
    ))


(defmethod print-object ((self char-feats) stream)
   (print-unreadable-object (self stream :type t)
     (format stream "~S" (name self))))


(defgeneric numfeats (chr-feat-set)
   (:documentation  "Return the number of features in the feature set."))

(defmethod numfeats ((self char-feats))
   (aif (number-of-features self) it (length (feature-ls self))))


(defgeneric has-match-p (chr-feat-set str1 str2)
   (:documentation  "Given two letters, return the list of features 
that appear in both."))

(defmethod has-match-p ((self char-feats) (s1 string) (s2 string))
   (intersection (gethash s1 (fhash self)) (gethash s2 (fhash self))))


(defgeneric prob-match (chr-feat-set str1 str2)
   (:documentation  "Return the probabily that a random feature in s1 
will appear in s2."))

(defmethod prob-match ((self char-feats) (s1 string) (s2 string))
   (if (string= s1 s2)
     -1
     (float (/ (length (remove-duplicates (has-match-p self s1 s2)))
               (length (gethash s1 (fhash self)))))))


(defgeneric setfeats (chr-feat-set str feat-lst)
   (:documentation  "Set the feature list for a string (character)."))

(defmethod setfeats ((self char-feats) (s1 string) (feat-ls list))
   (setf (gethash s1 (fhash self)) feat-ls))


(defgeneric getfeats (chr-feat-set chr)
   (:documentation "Returns the feature list for a character."))

(defmethod getfeats ((self char-feats) (s string))
   (gethash s (fhash self)))

(defmethod getfeats ((self char-feats) (c character))
   (gethash (mkstr c) (fhash self)))


(defgeneric get-icon-feats (chr-feat-set char)
   (:documentation "Return the icon feature list for a given character."))

(defmethod get-icon-feats ((self char-feats) char)
   (let ((ti (true->icon self)))
     (cond ((functionp ti) (mapcar ti (getfeats self char)))
           ((listp ti) (mapcar #'(lambda (feat)
                                   (second (assoc feat ti)))
                               (getfeats self char)))
           (t (getfeats self char)))))


(defgeneric exact-character (char-feat-set feat-lst)
   (:documentation "Return the character exactly matching a feature set."))

(defmethod exact-character ((self char-feats) (feat-ls list))
   (setf feat-ls (mapcar #'sym->key feat-ls))
   (let (realfeats)
     (dolist (char (chars self))
       (setf realfeats (getfeats self char))
       (when (= (length realfeats) (length feat-ls)
                (length (intersection feat-ls realfeats)))
         (return-from exact-character char)))))


(defgeneric prob-best-character (char-feat-set feat-lst)
   (:documentation "Return the character with the best probability of 
match to a feature list."))

(defmethod prob-best-character ((self char-feats) (feat-ls list))
   (let ((bestval 0) (bestchar nil) cur-val)
     (dolist (char (chars self))
       (setf cur-val (feat-ls-prob-match self feat-ls (getfeats self char)))
       (when (= cur-val bestval)
         (push char bestchar))
       (when (> cur-val bestval)
         (setf bestval cur-val)
         (setf bestchar (mklist char))))
     (values (random-item bestchar) (* 100. bestval))))


(defgeneric feat-ls-prob-match (char-feat-set lst1 lst2)
   (:documentation "Return the probability that two feature lists 
represent a match."))

(defmethod feat-ls-prob-match ((self char-feats) (l1 list) (l2 list))
   (let* ((overlap (length (remove-duplicates (intersection l1 l2))))
          (num-miss (+ (- (length l1) overlap)
                         (- (length l2) overlap))))
     (float (* (expt 2/3 (- (numfeats self) num-miss))
               (expt 1/3 num-miss)))))


(defmethod chars ((char-feat-set char-feats))
   (append (letters char-feat-set) (digits char-feat-set)))


(defgeneric avg-match-prob (char-feat-set)
   (:documentation "Returns the average match probability for an 
entire feature set."))

(defmethod avg-match-prob ((self char-feats))
   (aif (average-match-prob self)
     it
     (let ((accum))
       (dolist (targ (chars self))
         (dolist (item (chars self))
           (when (not (string= targ item))
             (push (prob-match self targ item) accum))))
       (setf (average-match-prob self)
             (/ (reduce #'+ accum) (length accum))))))



(defgeneric print-match-table (char-feat-set)
   (:documentation "Print out a table of matc probabilities."))

(defmethod print-match-table ((self char-feats))
   (dolist (targ (append (letters self) (digits self)))
     (format t "~%~A	" targ)
     (dolist (char (append (letters self) (digits self)))
       (format t "~3,2F	" (prob-match self targ char)))))


(defgeneric print-num-feats (char-feat-set)
   (:documentation "Print the number of features for each character."))

(defmethod print-num-feats ((self char-feats))
   (dolist (targ (append (letters self) (digits self)))
     (format t "~%~A has ~S" targ (length (gethash targ (fhash self))))))


(defgeneric check-integrity (thing)
   (:documentation "Check the internal integrity of <thing>."))

(defmethod check-integrity ((self char-feats))
   (let ((feat-ls))
     (dolist (char (append (letters self) (digits self)))
       (setf feat-ls (gethash char (fhash self)))
       (awhen (set-difference feat-ls (feature-ls self))
         (format t "~&~A has a feature not in the set ~S" char it))
       (dolist (item (append (letters self) (digits self)))
         (when (and (not (string= char item))
                    (equal feat-ls (gethash item (fhash self))))
           (format t "~&~A and ~A have identical features" char item)))
       (let ((bestchar (prob-best-character self feat-ls)))
         (when (not (string= char bestchar))
           (format t "~&~A has ~A as its best char." char bestchar)))
       )))


(defgeneric feature-freq (char-feat-set)
   (:documentation "Print the frequency of occurrence for each feature 
in the set."))

(defmethod feature-freq ((self char-feats))
   (let ((counter))
     (dolist (feat (feature-ls self))
       (setf counter 0)
       (dolist (char (chars self))
         (when (member feat (gethash char (fhash self)))
           (incf counter)))
       (format t "~&Feature ~S occurs in ~S chars" feat counter))))


;;;; 
---------------------------------------------------------------------- 
;;;;
;;;; The Gibson (1969) feature set

(defun build-gibson-set ()
   "Returns the Gibson (1969) character feature set."
   (let ((tmp (make-instance 'char-feats :name :GIBSON :feat-ls
                              '(HORIZONTAL VERTICAL DIAGONAL-SLASH
                                DIAGONAL-BACK DIAGONAL-SLASH CLOSED-CURVE
                                OPEN-V-CURVE OPEN-H-CURVE INTERSECTION
                                CYCLIC-CHANGE SYMMETRY VERTICAL-DISCONT
                                HORIZONTAL-DISCONT))))
     (setfeats tmp "A" '(SYMMETRY HORIZONTAL DIAGONAL-SLASH 
DIAGONAL-BACK INTERSECTION VERTICAL-DISCONT))
     (setfeats tmp "B" '(SYMMETRY CYCLIC-CHANGE INTERSECTION 
HORIZONTAL VERTICAL CLOSED-CURVE ))
     (setfeats tmp "C" '(SYMMETRY OPEN-H-CURVE ))
     (setfeats tmp "D" '(SYMMETRY VERTICAL CLOSED-CURVE ))
     (setfeats tmp "E" '(HORIZONTAL-DISCONT SYMMETRY CYCLIC-CHANGE 
HORIZONTAL VERTICAL INTERSECTION ))
     (setfeats tmp "F" '(HORIZONTAL-DISCONT VERTICAL-DISCONT 
HORIZONTAL VERTICAL INTERSECTION ))
     (setfeats tmp "G" '(HORIZONTAL OPEN-H-CURVE ))
     (setfeats tmp "H" '(VERTICAL-DISCONT SYMMETRY HORIZONTAL VERTICAL 
INTERSECTION ))
     (setfeats tmp "I" '(VERTICAL-DISCONT SYMMETRY VERTICAL ))
     (setfeats tmp "J" '(OPEN-V-CURVE OPEN-H-CURVE ))
     (setfeats tmp "K" '(VERTICAL-DISCONT SYMMETRY CYCLIC-CHANGE 
VERTICAL DIAGONAL-SLASH DIAGONAL-BACK INTERSECTION ))
     (setfeats tmp "L" '(HORIZONTAL-DISCONT HORIZONTAL VERTICAL ))
     (setfeats tmp "M" '(CYCLIC-CHANGE VERTICAL-DISCONT SYMMETRY 
VERTICAL DIAGONAL-SLASH DIAGONAL-BACK ))
     (setfeats tmp "N" '(VERTICAL-DISCONT VERTICAL DIAGONAL-BACK ))
     (setfeats tmp "O" '(SYMMETRY CLOSED-CURVE ))
     (setfeats tmp "P" '(VERTICAL-DISCONT INTERSECTION VERTICAL CLOSED-CURVE ))
     (setfeats tmp "Q" '(INTERSECTION DIAGONAL-BACK CLOSED-CURVE ))
     (setfeats tmp "R" '(VERTICAL-DISCONT INTERSECTION VERTICAL 
DIAGONAL-BACK CLOSED-CURVE ))
     (setfeats tmp "S" '(CYCLIC-CHANGE OPEN-H-CURVE ))
     (setfeats tmp "T" '(HORIZONTAL-DISCONT VERTICAL-DISCONT SYMMETRY 
HORIZONTAL VERTICAL INTERSECTION ))
     (setfeats tmp "U" '(SYMMETRY OPEN-V-CURVE ))
     (setfeats tmp "V" '(SYMMETRY DIAGONAL-SLASH DIAGONAL-BACK ))
     (setfeats tmp "W" '(SYMMETRY CYCLIC-CHANGE DIAGONAL-SLASH DIAGONAL-BACK ))
     (setfeats tmp "X" '(SYMMETRY INTERSECTION DIAGONAL-SLASH DIAGONAL-BACK ))
     (setfeats tmp "Y" '(VERTICAL-DISCONT SYMMETRY VERTICAL 
DIAGONAL-SLASH DIAGONAL-BACK ))
     (setfeats tmp "Z" '(HORIZONTAL-DISCONT HORIZONTAL DIAGONAL-SLASH ))

     (setfeats tmp "1" '(HORIZONTAL-DISCONT HORIZONTAL VERTICAL INTERSECTION))
     (setfeats tmp "2" '(HORIZONTAL-DISCONT HORIZONTAL OPEN-H-CURVE))
     (setfeats tmp "3" '(SYMMETRY OPEN-H-CURVE CYCLIC-CHANGE))
     (setfeats tmp "4" '(VERTICAL-DISCONT HORIZONTAL-DISCONT 
HORIZONTAL VERTICAL DIAGONAL-SLASH INTERSECTION))
     (setfeats tmp "5" '(HORIZONTAL-DISCONT HORIZONTAL OPEN-H-CURVE 
CYCLIC-CHANGE))
     (setfeats tmp "6" '(HORIZONTAL-DISCONT CLOSED-CURVE OPEN-H-CURVE))
     (setfeats tmp "7" '(VERTICAL-DISCONT HORIZONTAL DIAGONAL-SLASH))
     (setfeats tmp "8" '(SYMMETRY CLOSED-CURVE INTERSECTION))
     (setfeats tmp "9" '(VERTICAL-DISCONT CLOSED-CURVE OPEN-H-CURVE))
     (setfeats tmp "0" '(SYMMETRY CLOSED-CURVE DIAGONAL-SLASH))
     tmp))


;;;; 
---------------------------------------------------------------------- 
;;;;
;;;; The Briggs & Hocevar (1975) feature set

(defun build-bh-set ()
   "Returns the Briggs & Hocevar (1975) character feature set."
   (let ((tmp (make-instance 'char-feats :name :BRIGGS-HOCEVAR :feat-ls
                              '(H-TOP H-CENTER H-BOTTOM SINGLE-V DOUBLE-V
                                ANG-OPEN-TOP ANG-OPEN-DOWN ANG-OPEN-HORIZ
                                SM-CURVE-CONVEX-RIGHT SM-CURVE-CONVEX-BOTTOM
                                LARGE-CURVE CONTINUOUS-CURVE CLOSED-CURVE
                                SM-CURVE-CONVEX-LEFT))))

     (setfeats tmp "A" '(H-CENTER ANG-OPEN-DOWN))
     (setfeats tmp "B" '(H-TOP H-CENTER H-BOTTOM SINGLE-V 
SM-CURVE-CONVEX-RIGHT CLOSED-CURVE))
     (setfeats tmp "C" '(LARGE-CURVE CONTINUOUS-CURVE ))
     (setfeats tmp "D" '(SINGLE-V LARGE-CURVE CLOSED-CURVE))
     (setfeats tmp "E" '(H-TOP H-CENTER H-BOTTOM SINGLE-V ))
     (setfeats tmp "F" '(H-TOP H-CENTER SINGLE-V ))
     (setfeats tmp "G" '(SM-CURVE-CONVEX-RIGHT LARGE-CURVE ))
     (setfeats tmp "H" '(H-CENTER DOUBLE-V ))
     (setfeats tmp "I" '(SINGLE-V ))
     (setfeats tmp "J" '(SINGLE-V SM-CURVE-CONVEX-BOTTOM ))
     (setfeats tmp "K" '(SINGLE-V ANG-OPEN-TOP ANG-OPEN-DOWN ANG-OPEN-HORIZ ))
     (setfeats tmp "L" '(H-BOTTOM SINGLE-V ))
     (setfeats tmp "M" '(DOUBLE-V ANG-OPEN-DOWN ))
     (setfeats tmp "N" '(DOUBLE-V ANG-OPEN-TOP ANG-OPEN-DOWN ))
     (setfeats tmp "O" '(LARGE-CURVE CONTINUOUS-CURVE CLOSED-CURVE))
     (setfeats tmp "P" '(H-TOP H-CENTER SINGLE-V SM-CURVE-CONVEX-RIGHT 
CLOSED-CURVE))
     (setfeats tmp "Q" '(LARGE-CURVE CLOSED-CURVE))
     (setfeats tmp "R" '(H-TOP H-CENTER SINGLE-V ANG-OPEN-DOWN 
SM-CURVE-CONVEX-RIGHT CLOSED-CURVE))
     (setfeats tmp "S" '(SM-CURVE-CONVEX-RIGHT CONTINUOUS-CURVE))
     (setfeats tmp "T" '(H-TOP SINGLE-V ))
     (setfeats tmp "U" '(DOUBLE-V SM-CURVE-CONVEX-BOTTOM ))
     (setfeats tmp "V" '(ANG-OPEN-TOP ))
     (setfeats tmp "W" '(ANG-OPEN-TOP ANG-OPEN-DOWN ))
     (setfeats tmp "X" '(ANG-OPEN-TOP ANG-OPEN-DOWN ANG-OPEN-HORIZ ))
     (setfeats tmp "Y" '(SINGLE-V ANG-OPEN-TOP ANG-OPEN-HORIZ ))
     (setfeats tmp "Z" '(H-TOP H-BOTTOM ANG-OPEN-HORIZ ))

     (setfeats tmp "1" '(H-BOTTOM SINGLE-V ANG-OPEN-DOWN))
     (setfeats tmp "2" '(H-BOTTOM SM-CURVE-CONVEX-LEFT))
     (setfeats tmp "3" '(SM-CURVE-CONVEX-LEFT))
     (setfeats tmp "4" '(SINGLE-V CLOSED-CURVE H-CENTER))
     (setfeats tmp "5" '(SM-CURVE-CONVEX-LEFT H-TOP))
     (setfeats tmp "6" '(CLOSED-CURVE SM-CURVE-CONVEX-RIGHT))
     (setfeats tmp "7" '(H-TOP ANG-OPEN-HORIZ))
     (setfeats tmp "8" '(CLOSED-CURVE CONTINUOUS-CURVE))
     (setfeats tmp "9" '(CLOSED-CURVE SM-CURVE-CONVEX-LEFT))
     (setfeats tmp "0" '(CLOSED-CURVE CONTINUOUS-CURVE LARGE-CURVE 
ANG-OPEN-HORIZ))
     tmp))

;;;; 
---------------------------------------------------------------------- 
;;;;
;;;; Original Rumelhart and McClelland feature set

(defun build-rm-orig-set ()
   "Returns the Rumelhart & McClelland (1981) character feature set."
   (let ((tmp (make-instance 'char-feats :name :RM-ORIG
                              :feat-ls
                              '(horizontal-t0 vertical-l1
                                back-diagonal-u1 vertical-c1 front-diagonal-u1
                                vertical-r1 horizontal-c1 horizontal-c2
                                vertical-l2 front-diagonal-l2 vertical-c2
                                back-diagonal-l2 vertical-r2 horizontal-l0
                                left-facing symmetric right-facing))))

     (setfeats tmp "A" '(HORIZONTAL-T0 VERTICAL-L1 VERTICAL-R1 HORIZONTAL-C1
                         HORIZONTAL-C2 VERTICAL-L2 VERTICAL-R2 SYMMETRIC))
     (setfeats tmp "B" '(HORIZONTAL-T0 VERTICAL-C1 VERTICAL-R1 HORIZONTAL-C2
                         VERTICAL-C2 VERTICAL-R2 HORIZONTAL-L0 RIGHT-FACING))
     (setfeats tmp "C" '(HORIZONTAL-T0 VERTICAL-L1 VERTICAL-L2 HORIZONTAL-L0
                         RIGHT-FACING))
     (setfeats tmp "D" '(HORIZONTAL-T0 VERTICAL-C1 VERTICAL-R1 VERTICAL-C2
                         VERTICAL-R2 HORIZONTAL-L0 RIGHT-FACING))
     (setfeats tmp "E" '(HORIZONTAL-T0 VERTICAL-L1 HORIZONTAL-C1 VERTICAL-L2
                         HORIZONTAL-L0 RIGHT-FACING))
     (setfeats tmp "F" '(HORIZONTAL-T0 VERTICAL-L1 HORIZONTAL-C1 VERTICAL-L2
                         RIGHT-FACING))
     (setfeats tmp "G" '(HORIZONTAL-T0 VERTICAL-L1 HORIZONTAL-C2 VERTICAL-L2
                         VERTICAL-R2 HORIZONTAL-L0 RIGHT-FACING))
     (setfeats tmp "H" '(VERTICAL-L1 VERTICAL-R1 HORIZONTAL-C1 HORIZONTAL-C2
                         VERTICAL-L2 VERTICAL-R2 SYMMETRIC))
     (setfeats tmp "I" '(HORIZONTAL-T0 VERTICAL-C1 VERTICAL-C2 HORIZONTAL-L0
                         SYMMETRIC))
     (setfeats tmp "J" '(VERTICAL-R1 VERTICAL-L2 VERTICAL-R2 HORIZONTAL-L0
                         LEFT-FACING))
     (setfeats tmp "K" '(VERTICAL-L1 FRONT-DIAGONAL-U1 HORIZONTAL-C1
                         VERTICAL-L2 BACK-DIAGONAL-L2 RIGHT-FACING))
     (setfeats tmp "L" '(VERTICAL-L1 VERTICAL-L2 HORIZONTAL-L0 RIGHT-FACING))
     (setfeats tmp "M" '(VERTICAL-L1 BACK-DIAGONAL-U1 FRONT-DIAGONAL-U1
                         VERTICAL-R1 VERTICAL-L2 VERTICAL-R2 SYMMETRIC))
     (setfeats tmp "N" '(VERTICAL-L1 BACK-DIAGONAL-U1 VERTICAL-R1 VERTICAL-L2
                         BACK-DIAGONAL-L2 VERTICAL-R2 SYMMETRIC))
     (setfeats tmp "O" '(HORIZONTAL-T0 VERTICAL-L1 VERTICAL-R1 VERTICAL-L2
                         VERTICAL-R2 HORIZONTAL-L0 SYMMETRIC))
     (setfeats tmp "P" '(HORIZONTAL-T0 VERTICAL-L1 VERTICAL-R1 HORIZONTAL-C1
                         HORIZONTAL-C2 VERTICAL-L2 RIGHT-FACING))
     (setfeats tmp "Q" '(HORIZONTAL-T0 VERTICAL-L1 VERTICAL-R1 VERTICAL-L2
                         BACK-DIAGONAL-L2 VERTICAL-R2 HORIZONTAL-L0
                         RIGHT-FACING))
     (setfeats tmp "R" '(HORIZONTAL-T0 VERTICAL-L1 VERTICAL-R1 HORIZONTAL-C1
                         HORIZONTAL-C2 VERTICAL-L2 BACK-DIAGONAL-L2
                         RIGHT-FACING))
     (setfeats tmp "S" '(HORIZONTAL-T0 VERTICAL-L1 HORIZONTAL-C1 HORIZONTAL-C2
                         VERTICAL-R2 HORIZONTAL-L0 SYMMETRIC))
     (setfeats tmp "T" '(HORIZONTAL-T0 VERTICAL-C1 VERTICAL-C2 SYMMETRIC))
     (setfeats tmp "U" '(VERTICAL-L1 VERTICAL-R1 VERTICAL-L2 VERTICAL-R2
                         HORIZONTAL-L0 SYMMETRIC))
     (setfeats tmp "V" '(VERTICAL-L1 FRONT-DIAGONAL-U1 VERTICAL-L2
                         FRONT-DIAGONAL-L2 SYMMETRIC))
     (setfeats tmp "W" '(VERTICAL-L1 VERTICAL-R1 VERTICAL-L2 FRONT-DIAGONAL-L2
                         BACK-DIAGONAL-L2 VERTICAL-R2 SYMMETRIC))
     (setfeats tmp "X" '(BACK-DIAGONAL-U1 FRONT-DIAGONAL-U1 FRONT-DIAGONAL-L2
                         BACK-DIAGONAL-L2 SYMMETRIC))
     (setfeats tmp "Y" '(BACK-DIAGONAL-U1 FRONT-DIAGONAL-U1 VERTICAL-C2
                         SYMMETRIC))
     (setfeats tmp "Z" '(HORIZONTAL-T0 FRONT-DIAGONAL-U1 FRONT-DIAGONAL-L2
                         HORIZONTAL-L0 SYMMETRIC))

     (setfeats tmp "1" '(VERTICAL-R1 VERTICAL-R2 LEFT-FACING))
     (setfeats tmp "2" '(HORIZONTAL-T0 VERTICAL-R1 HORIZONTAL-C1 HORIZONTAL-C2
                         VERTICAL-L2 HORIZONTAL-L0 LEFT-FACING))
     (setfeats tmp "3" '(HORIZONTAL-T0 VERTICAL-R1 HORIZONTAL-C1 HORIZONTAL-C2
                         VERTICAL-R2 HORIZONTAL-L0 LEFT-FACING))
     (setfeats tmp "4" '(VERTICAL-L1 VERTICAL-R1 HORIZONTAL-C1 HORIZONTAL-C2
                         VERTICAL-R2 LEFT-FACING))
     (setfeats tmp "5" '(HORIZONTAL-T0 VERTICAL-L1 HORIZONTAL-C1
                         BACK-DIAGONAL-L2 HORIZONTAL-L0 RIGHT-FACING))
     (setfeats tmp "6" '(HORIZONTAL-T0 VERTICAL-L1 HORIZONTAL-C1 HORIZONTAL-C2
                         VERTICAL-L2 VERTICAL-R2 HORIZONTAL-L0 RIGHT-FACING))
     (setfeats tmp "7" '(HORIZONTAL-T0 VERTICAL-R1 VERTICAL-R2 LEFT-FACING))
     (setfeats tmp "8" '(HORIZONTAL-T0 VERTICAL-L1 VERTICAL-R1 HORIZONTAL-C1
                         HORIZONTAL-C2 VERTICAL-L2 VERTICAL-R2 HORIZONTAL-L0
                         SYMMETRIC))
     (setfeats tmp "9" '(HORIZONTAL-T0 VERTICAL-L1 VERTICAL-R1 HORIZONTAL-C1
                         HORIZONTAL-C2 VERTICAL-R2 HORIZONTAL-L0 LEFT-FACING))
     (setfeats tmp "0" '(HORIZONTAL-T0 VERTICAL-L1 BACK-DIAGONAL-U1 VERTICAL-R1
                         VERTICAL-L2 BACK-DIAGONAL-L2 VERTICAL-R2 HORIZONTAL-L0
                         SYMMETRIC))
     tmp))


;;;; 
---------------------------------------------------------------------- 
;;;;
;;;; "Clean" Rumelhart and McClelland (??) feature set

(defun cliplast (sym)
   "Removes the last character from a symbol."
   (let ((str (mkstr sym)))
     (read-from-string str :start 0 :end (- (length str) 1))))

(defun build-rm-clean-set ()
   (let ((tmp (make-instance 'char-feats :name :RM-CLEAN :true->icon #'cliplast
                             :feat-ls
                             '(horizontal-t0 vertical-l1
                               back-diagonal-u1 vertical-c1 front-diagonal-u1
                               vertical-r1 horizontal-c1 horizontal-c2
                               vertical-l2 front-diagonal-l2 vertical-c2
                               back-diagonal-l2 vertical-r2 horizontal-l0
                               left-facing+ symmetric+ right-facing+))))

     (setfeats tmp "A" '(HORIZONTAL-T0 VERTICAL-L1 VERTICAL-R1 HORIZONTAL-C1
                         HORIZONTAL-C2 VERTICAL-L2 VERTICAL-R2 SYMMETRIC+))
     (setfeats tmp "B" '(HORIZONTAL-T0 VERTICAL-C1 VERTICAL-R1 HORIZONTAL-C2
                         VERTICAL-C2 VERTICAL-R2 HORIZONTAL-L0 RIGHT-FACING+))
     (setfeats tmp "C" '(HORIZONTAL-T0 VERTICAL-L1 VERTICAL-L2 HORIZONTAL-L0
                         RIGHT-FACING+))
     (setfeats tmp "D" '(HORIZONTAL-T0 VERTICAL-C1 VERTICAL-R1 VERTICAL-C2
                         VERTICAL-R2 HORIZONTAL-L0 RIGHT-FACING+))
     (setfeats tmp "E" '(HORIZONTAL-T0 VERTICAL-L1 HORIZONTAL-C1 VERTICAL-L2
                         HORIZONTAL-L0 RIGHT-FACING+))
     (setfeats tmp "F" '(HORIZONTAL-T0 VERTICAL-L1 HORIZONTAL-C1 VERTICAL-L2
                         RIGHT-FACING+))
     (setfeats tmp "G" '(HORIZONTAL-T0 VERTICAL-L1 HORIZONTAL-C2 VERTICAL-L2
                         VERTICAL-R2 HORIZONTAL-L0 RIGHT-FACING+))
     (setfeats tmp "H" '(VERTICAL-L1 VERTICAL-R1 HORIZONTAL-C1 HORIZONTAL-C2
                         VERTICAL-L2 VERTICAL-R2 SYMMETRIC+))
     (setfeats tmp "I" '(HORIZONTAL-T0 VERTICAL-C1 VERTICAL-C2 HORIZONTAL-L0
                         SYMMETRIC+))
     (setfeats tmp "J" '(VERTICAL-R1 VERTICAL-L2 VERTICAL-R2 HORIZONTAL-L0
                         LEFT-FACING+))
     (setfeats tmp "K" '(VERTICAL-L1 FRONT-DIAGONAL-U1 HORIZONTAL-C1
                         VERTICAL-L2 BACK-DIAGONAL-L2 RIGHT-FACING+))
     (setfeats tmp "L" '(VERTICAL-L1 VERTICAL-L2 HORIZONTAL-L0 RIGHT-FACING+))
     (setfeats tmp "M" '(VERTICAL-L1 BACK-DIAGONAL-U1 FRONT-DIAGONAL-U1
                         VERTICAL-R1 VERTICAL-L2 VERTICAL-R2 SYMMETRIC+))
     (setfeats tmp "N" '(VERTICAL-L1 BACK-DIAGONAL-U1 VERTICAL-R1 VERTICAL-L2
                         BACK-DIAGONAL-L2 VERTICAL-R2 SYMMETRIC+))
     (setfeats tmp "O" '(HORIZONTAL-T0 VERTICAL-L1 VERTICAL-R1 VERTICAL-L2
                         VERTICAL-R2 HORIZONTAL-L0 SYMMETRIC+))
     (setfeats tmp "P" '(HORIZONTAL-T0 VERTICAL-L1 VERTICAL-R1 HORIZONTAL-C1
                         HORIZONTAL-C2 VERTICAL-L2 RIGHT-FACING+))
     (setfeats tmp "Q" '(HORIZONTAL-T0 VERTICAL-L1 VERTICAL-R1 VERTICAL-L2
                         BACK-DIAGONAL-L2 VERTICAL-R2 HORIZONTAL-L0
                         RIGHT-FACING+))
     (setfeats tmp "R" '(HORIZONTAL-T0 VERTICAL-L1 VERTICAL-R1 HORIZONTAL-C1
                         HORIZONTAL-C2 VERTICAL-L2 BACK-DIAGONAL-L2
                         RIGHT-FACING+))
     (setfeats tmp "S" '(HORIZONTAL-T0 VERTICAL-L1 HORIZONTAL-C1 HORIZONTAL-C2
                         VERTICAL-R2 HORIZONTAL-L0 SYMMETRIC+))
     (setfeats tmp "T" '(HORIZONTAL-T0 VERTICAL-C1 VERTICAL-C2 SYMMETRIC+))
     (setfeats tmp "U" '(VERTICAL-L1 VERTICAL-R1 VERTICAL-L2 VERTICAL-R2
                         HORIZONTAL-L0 SYMMETRIC+))
     (setfeats tmp "V" '(VERTICAL-L1 FRONT-DIAGONAL-U1 VERTICAL-L2
                         FRONT-DIAGONAL-L2 SYMMETRIC+))
     (setfeats tmp "W" '(VERTICAL-L1 VERTICAL-R1 VERTICAL-L2 FRONT-DIAGONAL-L2
                         BACK-DIAGONAL-L2 VERTICAL-R2 SYMMETRIC+))
     (setfeats tmp "X" '(BACK-DIAGONAL-U1 FRONT-DIAGONAL-U1 FRONT-DIAGONAL-L2
                         BACK-DIAGONAL-L2 SYMMETRIC+))
     (setfeats tmp "Y" '(BACK-DIAGONAL-U1 FRONT-DIAGONAL-U1 VERTICAL-C2
                         SYMMETRIC+))
     (setfeats tmp "Z" '(HORIZONTAL-T0 FRONT-DIAGONAL-U1 FRONT-DIAGONAL-L2
                         HORIZONTAL-L0 SYMMETRIC+))

     (setfeats tmp "1" '(VERTICAL-R1 VERTICAL-R2 LEFT-FACING+))
     (setfeats tmp "2" '(HORIZONTAL-T0 VERTICAL-R1 HORIZONTAL-C1 HORIZONTAL-C2
                         VERTICAL-L2 HORIZONTAL-L0 LEFT-FACING+))
     (setfeats tmp "3" '(HORIZONTAL-T0 VERTICAL-R1 HORIZONTAL-C1 HORIZONTAL-C2
                         VERTICAL-R2 HORIZONTAL-L0 LEFT-FACING+))
     (setfeats tmp "4" '(VERTICAL-L1 VERTICAL-R1 HORIZONTAL-C1 HORIZONTAL-C2
                         VERTICAL-R2 LEFT-FACING+))
     (setfeats tmp "5" '(HORIZONTAL-T0 VERTICAL-L1 HORIZONTAL-C1
                         BACK-DIAGONAL-L2 HORIZONTAL-L0 RIGHT-FACING+))
     (setfeats tmp "6" '(HORIZONTAL-T0 VERTICAL-L1 HORIZONTAL-C1 HORIZONTAL-C2
                         VERTICAL-L2 VERTICAL-R2 HORIZONTAL-L0 RIGHT-FACING+))
     (setfeats tmp "7" '(HORIZONTAL-T0 VERTICAL-R1 VERTICAL-R2 LEFT-FACING+))
     (setfeats tmp "8" '(HORIZONTAL-T0 VERTICAL-L1 VERTICAL-R1 HORIZONTAL-C1
                         HORIZONTAL-C2 VERTICAL-L2 VERTICAL-R2 HORIZONTAL-L0
                         SYMMETRIC+))
     (setfeats tmp "9" '(HORIZONTAL-T0 VERTICAL-L1 VERTICAL-R1 HORIZONTAL-C1
                         HORIZONTAL-C2 VERTICAL-R2 HORIZONTAL-L0 LEFT-FACING+))
     (setfeats tmp "0" '(HORIZONTAL-T0 VERTICAL-L1 BACK-DIAGONAL-U1 VERTICAL-R1
                         VERTICAL-L2 BACK-DIAGONAL-L2 VERTICAL-R2 HORIZONTAL-L0
                         SYMMETRIC+))
     tmp))



#|
;;;; 
---------------------------------------------------------------------- 
;;;;
;;;; XXXX () feature set

(defun build-XX-set ()

   (let ((tmp (make-instance 'char-feats feat-ls
                             '())))
     (setfeats tmp "A" '())
     (setfeats tmp "B" '())
     (setfeats tmp "C" '())
     (setfeats tmp "D" '())
     (setfeats tmp "E" '())
     (setfeats tmp "F" '())
     (setfeats tmp "G" '())
     (setfeats tmp "H" '())
     (setfeats tmp "I" '())
     (setfeats tmp "J" '())
     (setfeats tmp "K" '())
     (setfeats tmp "L" '())
     (setfeats tmp "M" '())
     (setfeats tmp "N" '())
     (setfeats tmp "O" '())
     (setfeats tmp "P" '())
     (setfeats tmp "Q" '())
     (setfeats tmp "R" '())
     (setfeats tmp "S" '())
     (setfeats tmp "T" '())
     (setfeats tmp "U" '())
     (setfeats tmp "V" '())
     (setfeats tmp "W" '())
     (setfeats tmp "X" '())
     (setfeats tmp "Y" '())
     (setfeats tmp "Z" '())

     (setfeats tmp "1" '())
     (setfeats tmp "2" '())
     (setfeats tmp "3" '())
     (setfeats tmp "4" '())
     (setfeats tmp "5" '())
     (setfeats tmp "6" '())
     (setfeats tmp "7" '())
     (setfeats tmp "8" '())
     (setfeats tmp "9" '())
     (setfeats tmp "0" '())
     tmp))

|#


;;;; 
---------------------------------------------------------------------- 
;;;;

(defun all-feature-sets ()
   (list (build-gibson-set) (build-bh-set) (build-rm-orig-set)
         (build-rm-clean-set)))


;;;  -*- mode: LISP; Package: CL-USER; Syntax: COMMON-LISP;  Base: 10 -*-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Author      : Mike Byrne
;;; 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    : vision-module.lisp
;;; Version     : 2.1b4
;;;
;;; Description : Source code for the ACT-R/PM Vision Module.
;;;
;;; Bugs        : [] Need to split object identification and chunk
;;;             :    construction in GET-OBJECT-AT because of EMMA.
;;;
;;; Todo        : [] Ordering of screen-x and screen-y tests.
;;;             : [] General feature synthesis.
;;;
;;;
;;; ----- History ----- [look also at function comments]
;;;
;;; 01.07.27 mdb
;;;             : Started the 2.1/ACT5 recoding.
;;;             : [x] Split up FL into pieces to be callable.
;;;             : [x] Remove OBJECTS slot from visual-locations.
;;;             : [x] VALUE slot should not be available for text features.
;;; 01.09.17 mdb
;;;             : Fixed bug in REMAP-SPEC-TO-CURRENT.
;;; 01.09.21 mdb [b2]
;;;             : * Made a bunch of changes to reduce the number of gentemps
;;;             : created by the system.  It probably rebuilds the icon
;;;             : faster, also.
;;;             : * Corrected another stupidity in UPDATE-ATTENDED-LOC.
;;; 01.10.31 mdb [b3]
;;;             : Added COPY-INSTANCE method for non-MCL Lisps.
;;; 01.11.05 mdb
;;;             : Added CURRENT-LOF slot to ease certain problems related to
;;;             : where attention is focussed vs. the chunk describing where
;;;             : its focussed.
;;; 01.11.11 mdb
;;;             : Added ATTN-TRACE and TRACE-ATTN-P slots to support replay as
;;;             : well as SET-CLOF function.  This changed the tracking code
;;;             : a teensy bit as well.
;;; 02.01.17 mdb [b4]
;;;             : Adopted Dan's fix on ENTER-INTO-VISICON.
;;; 02.01.21 mdb
;;;             : Fixed GREATER-THAN-CURRENT and LESS-THAN-CURRENT.
;;;             : Fixed NEAREST broken, only relative to current.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


(proclaim '(optimize (speed 3) (space 0)))

;;;; 
---------------------------------------------------------------------- 
;;;;
;;;; Class declarations
;;;; 
---------------------------------------------------------------------- 
;;;;

(defclass vision-module (attn-module)
   ((visicon :accessor visicon :initarg :visicon :initform nil)
    ; (old-visicon :accessor old-visicon :initarg :old-visicon :initform nil)
    (optimize-visual :accessor optimize-p :initarg :optimize-p :initform t)
    (print-viewed :accessor print-view-p :initarg :print-view-p :initform nil)
    (conservative-update :accessor conservative-p :initarg 
:conservative-p :initform nil)
    (move-attention-latency :accessor move-attn-latency
                            :initarg :move-attn-latency :initform 0.085)
    (tracked-object :accessor tracked-obj :initarg :tracked-obj :initform nil)
    (tracked-object-last-location :accessor tracked-obj-lastloc
                                  :initarg :tracked-obj-lastloc :initform nil)
    (last-scale :accessor last-scale :initarg :last-scale :initform nil)
    (moving-attention :accessor moving-attention :initarg :moving-attention
                      :initform nil)
    (move-allowance :accessor move-allowance :initarg :move-allowance
                    :initform 0)
    (synthd-objs :accessor synthd-objs :initarg :synthd-objs
                 :initform (make-hash-table))
    (found-locs :accessor found-locs :initarg :found-locs
                :initform (make-hash-table))
    (feature-sets :accessor feature-sets :initarg :feature-sets
                  :initform (all-feature-sets))
    (active-cfs :accessor active-cfs :initarg :active-cfs
                :initform nil)
    (num-finst :accessor num-finst :initarg :num-finst :initform 4)
    (finst-lst :accessor finst-lst :initarg :finst-lst :initform nil)
    (finst-span :accessor finst-span :initarg :finst-span :initform 3.0)
    (new-span :accessor new-span :initarg :new-span :initform 0.5)
    (default-spec :accessor default-spec :initarg :default-spec
      :initform nil)
    (current-lof :accessor current-lof :initarg :current-lof :initform #(0 0))
    (trace-attn-p :accessor trace-attn-p :initarg :trace-attn-p :initform nil)
    (attn-trace :accessor attn-trace :initarg :attn-trace :initform nil)
    )
   (:default-initargs
     :name :VISION))

(defclass found-spec ()
   ((spec :accessor spec :initarg :spec :initform nil)
    (feat :accessor feat :initarg :feat :initform nil)))


(defclass finst ()
   ((id :accessor id :initarg :id :initform nil)
    (tstamp :accessor tstamp :initarg :tstamp :initform 0.0)
    (synthed-from :accessor synthed-from :initarg :synthed-from :initform nil)))


;;; ICON-FEATURE      [Class]
;;; Description : Coordinates (x, y, width, height) should be in pixels to
;;;             : relate directly to the screen.  However, the SIZE attribute
;;;             : should be in degrees of visual angle (squared, of course)
;;;             : for FIND-LOCATION calls.
;;;             : Beta6 added WIDTH, HEIGHT, and SIZE attributes.

(defclass icon-feature ()
   ((screen-x :accessor screen-x :initarg :x :initform nil)
    (screen-y :accessor screen-y :initarg :y :initform nil)
    (attended-p :accessor attended-p :initarg :attended-p :initform 'NEW)
    (kind :accessor kind :initarg :kind :initform 'visual-object)
    (val :accessor val :initarg :value :initform nil)
    (color :accessor color :initarg :color :initform 'black)
    (dmo-id :accessor dmo-id :initarg :dmo-id :initform nil)     	; new
    (screen-obj :accessor screen-obj :initarg :screen-obj :initform nil)
    (height :accessor height :initarg :height :initform nil)
    (width :accessor width :initarg :width :initform nil)
    (size :accessor size :initarg :size :initform nil)
    (tstamp :accessor tstamp :initarg :tstamp :initform nil)     	; new
    (obj-freq :accessor obj-freq :initarg :obj-freq :initform 0.01)
    ))


(defclass oval-feature (icon-feature)
   ()
   (:default-initargs
     :kind 'oval
     :value 'oval
     ))


(defclass led-line-feature (icon-feature)
   ((line-pos :accessor line-pos :initarg :line-pos :initform nil)
    (left-edge :accessor left-edge :initarg :left :initform nil)
    (right-edge :accessor right-edge :initarg :right :initform nil))
   (:default-initargs
     :kind 'text))


(defclass cursor-feature (icon-feature)
   ()
   (:default-initargs
     :kind 'cursor
     :value 'pointer))


(defclass rect-feature (icon-feature)
   ()
   (:default-initargs
     :kind 'visual-object
     :value 'box))


(defclass line-feature (icon-feature)
   ((end1-x :accessor end1-x :initarg :end1-x :initform nil)
    (end1-y :accessor end1-y :initarg :end1-y :initform nil)
    (end2-x :accessor end2-x :initarg :end2-x :initform nil)
    (end2-y :accessor end2-y :initarg :end2-y :initform nil)
    )
   (:default-initargs
     :kind 'line
     :value 'line))


(defclass text-feature (icon-feature)
   ()
   (:default-initargs
     :kind 'text))


(defclass empty-feature (icon-feature)
   ()
   (:default-initargs
     :kind 'EMPTY-SPACE
     :value nil
     :color nil))


(defclass feature-spec (icon-feature spec)
   ((nearest :accessor nearest :initarg :nearest :initform nil))
   (:default-initargs
     :check-slots #(attended-p screen-x screen-y kind val color size)
     :x :IGNORE
     :y :IGNORE
     :attended-p :IGNORE
     :value :IGNORE
     :color :IGNORE
     :kind :IGNORE
     :size :IGNORE
     ))

(defmethod initialize-instance :after ((feat feature-spec) &key)
   (setf (dmo-id feat) (gensym "SPEC")))


(defclass char-primitive-feature (icon-feature)
   ((true-feat :accessor true-feat :initarg :true-feat :initform nil)
    (left-edge :accessor left-edge :initarg :left :initform nil)
    (right-edge :accessor right-edge :initarg :right :initform nil))
   (:default-initargs
     :kind 'text))



;;; SYNTHD-FEAT      [Class]
;;; Date        : 99.04.02
;;; Description : When an object (word or phrase) is synthesized out of
;;;             : primitive features, some record of that has to be kept
;;;             : around for things like mouse targeting.  Synthetic
;;;             : features are hashed by ID, and store the IDs of the
;;;             : features from which they were constructed.

(defclass synthd-feat (icon-feature)
   ((built-from :accessor built-from :initform nil :initarg :built-from)))


(defclass dummy-feature ()
   ((xy-loc :accessor xy-loc :initarg :xy-loc :initarg nil)))


(defgeneric approach-width (feat theta)
   (:documentation "Returns the width of a feature in degrees given an 
approach angle."))

(defmethod approach-width ((feat dummy-feature) (theta float))
   (default-target-width (motor-m *mp*)))


;;;; 
---------------------------------------------------------------------- 
;;;;
;;;; Module-level stuff stuff

(defmethod initialize-instance :after ((vis-mod vision-module) &key)
   "Initializes a vision module"
   (setf (state-dmo vis-mod)
         (make-dme 'vision-state 'module-state
                   '(module :vision modality free processor free 
preparation free
                     execution free)
                   :where :external))
   (setf (default-spec vis-mod)
         (make-instance 'feature-spec :attended-p 'NEW :x 'LOWEST :tstamp 0))
   (set-cfs-mth vis-mod :RM-ORIG))


;;; RESET-MODULE      [Method]
;;; Date        : 97.03.31
;;; Description : Besides the basics, clear the icon and reset the
;;;             : current location to be nil.

(defmethod reset-module :after ((vis-mod vision-module))
   "Resets the state of a Vision Module"
   (setf (visicon vis-mod) nil)
   (remove-tracking vis-mod)
   (setf (last-scale vis-mod) nil)
   (set-cfs-mth vis-mod :RM-ORIG)
   (setf (synthd-objs vis-mod) (clrhash (synthd-objs vis-mod)))
   (setf (found-locs vis-mod) (clrhash (found-locs vis-mod)))
   (setf (finst-lst vis-mod) nil)
   (setf (default-spec vis-mod)
         (make-instance 'feature-spec :attended-p 'NEW :x 'LOWEST :tstamp 0))
   (setf (attn-trace vis-mod) nil)
   (set-clof vis-mod #(0 0))
   )


(defmethod clear :after ((vis-mod vision-module))
   (remove-tracking vis-mod))


(defmethod update-module :after ((vis-mod vision-module))
   (when (tracked-obj vis-mod)
     (update-tracking-mth vis-mod))
   (check-finsts vis-mod)
   (mapc #'(lambda (f) (checknew f vis-mod)) (visicon vis-mod)))


(defmethod silent-events ((vis-mod vision-module))
   (tracked-obj vis-mod))


(defgeneric set-cfs-mth (vis-mod kwrd)
   (:documentation "Set the current character feature set."))

(defmethod set-cfs-mth ((vis-mod vision-module) kwrd)
   (setf (active-cfs vis-mod) (get-cfs-mth vis-mod kwrd)))


(defgeneric get-cfs-mth (vis-mod kwrd)
   (:documentation "Given a keyword, find a character feature set."))

(defmethod get-cfs-mth ((vis-mod vision-module) kwrd)
   (aif (member kwrd (feature-sets vis-mod) :key #'name)
     (first it)
     (pm-warning "Feature set ~S is unknown" kwrd)))


;;;; 
---------------------------------------------------------------------- 
;;;;
;;;; Moving attention and its immediate support functions, such
;;;;     as FOCUS-ON and the various GET- functions.
;;;; 
---------------------------------------------------------------------- 
;;;;

;;; MOVE-ATTENTION      [Method]
;;; Date        : 97.02.09
;;; Description : This is a toplevel command for the Vision Module, causing
;;;             : attention to move.  Latencey is 185 ms, so nothing actually
;;;             : happens right away other than setting state variables.
;;;             : A method is dispatched based on the scale that's passed.

(defgeneric move-attention (vis-mod &key location scale)
   (:documentation "Shift attention to a particular location at a 
particular scale."))

(defmethod move-attention ((vis-mod vision-module) &key location scale)
   (declare (symbol scale))
   (if (eq (exec-s vis-mod) 'BUSY)
     (pm-warning "Attention shift requested at ~S while one was 
already in progress."
                 (mp-time *mp*))
     (progn
       (when (tracked-obj vis-mod) (remove-tracking vis-mod))
       (setf (input-q vis-mod) nil)
       (setf (moving-attention vis-mod) t)
       (clear-attended vis-mod)
       (setf (last-scale vis-mod) scale)
       (setf location (psdme-to-dmo location))
       (queue-command
        :time (move-attn-latency vis-mod) :where :VISION :command 'focus-on
        :randomize t :params `(,location ,scale))
       (setf (current-marker vis-mod) location)
       (set-clof vis-mod (dmo-to-xy location))
       (change-state vis-mod :exec 'busy))))



;;; FOCUS-ON      [Method]
;;; Date        : 97.06.01
;;; Description : Several things to do when focusing attention on a location.
;;;             : [1] Make the location attended, set state to FREE.
;;;             : [2] Make it an external source (and null the old source).
;;;             : [3] If there was nothing there, or we were non-conserving
;;;             :     get the thing at that location.
;;;             : [4] If there is something, synch it up with the location
;;;             :     chunk.
;;;             : [5] If requested, print it.


(defgeneric focus-on (vis-mod loc-dmo scale)
   (:documentation "When MOVE-ATTENTION completes, focus on a place 
with this."))

(defmethod focus-on ((vis-mod vision-module) (loc-dmo dmo) scale)
   (declare (symbol scale))
   (set-attributes loc-dmo '(attended t))
   (setf (moving-attention vis-mod) nil)
   (change-state vis-mod :exec 'free)
   ;(setf (current-marker vis-mod) loc-dmo)
   (let ((return-obj (get-obj-at-location vis-mod loc-dmo scale)))
     (unless return-obj
       ;(clear-loc loc-dmo)
       (clear-attended vis-mod)
       (return-from focus-on nil))
     (set-attended vis-mod return-obj)
     (when (print-view-p vis-mod)
       (format t "~% <> MOVE-ATTENTION generated DMO ~S~%" (id return-obj)))
     return-obj))


(defgeneric get-obj-at-location (vis-mod loc-dmo scale)
   (:documentation  "Given a location and a scale, return a DMO 
representing what's there."))

(defmethod get-obj-at-location ((vis-mod vision-module) (loc-dmo dmo)
                                scale)
   (declare (symbol scale))
   (let ((return-obj nil)
         (xy-loc (dmo-to-xy loc-dmo)))
     (if (conservative-p vis-mod)
       (setf return-obj (conservative-get-object vis-mod loc-dmo))
       (progn
         (setf return-obj
               (cond ((eq scale 'PHRASE)
                      (get-phrase-at vis-mod xy-loc))
                     ((and (eq scale 'WORD) (not (optimize-p vis-mod)))
                      (get-word-at-noopt vis-mod loc-dmo))
                     (t
                      (let ((feat-lis (within-move vis-mod xy-loc)))
                        (when (eq scale 'WORD)
                          (setf feat-lis (text-feats feat-lis)))
                        (when feat-lis
                          (featlis-to-focus vis-mod loc-dmo feat-lis))))))))
     return-obj))



;;; CONSERVATIVE-GET-OBJECT      [Method]
;;; Date        : 99.03.29
;;; Description : When CONSERVATIVE is on, try to grab an object that's
;;;             : present in the current location chunk.

(defgeneric conservative-get-object (vis-mod loc-dmo)
   (:documentation "Create a DMO for the object at the given location, 
when :CONSERVATIVE-UPDATE-VISUAL is true."))

(defmethod conservative-get-object ((vis-mod vision-module)
                                         (loc-dmo dmo))
   (let ((present-objects
          (remove-if-not #'(lambda (o) (object-present-p vis-mod o))
                         (get-attribute loc-dmo 'objects)))
         (best-object nil)
         (base-feat (feat (gethash (id loc-dmo) (found-locs vis-mod)))))
     (when present-objects
       (if (null base-feat)
         (setf best-object (random-item present-objects))
         (progn
           (setf best-object
                 (determine-focus-dmo vis-mod present-objects base-feat))
           (setf (attended-p base-feat) t)))
       (setf (currently-attended vis-mod) best-object)
       best-object)))


;;; SYNCH-LOCS      [Method]
;;; Date        : 98.07.26, last delta 99.06.24
;;; Description : When an object is focused on, some objects might need to
;;;             : be updated.  This should keep the location chunk in
;;;             : synch with the world and with the object chunk.

(defgeneric synch-locs (vis-mod object location)
   (:documentation "Given an object and location DM rep, synchronizes 
the appropriate slots."))

(defmethod synch-locs ((vis-mod vision-module) (object dmo) (location dmo))
   (let ((still-around nil))
     (dolist (obj (mklist (get-attribute location 'objects)))
       (when (object-present-p vis-mod obj)
         (push obj still-around)))
     (set-attributes object `(screen-pos ,(id location)))
     (if (null still-around)
       (setf still-around (id object))
       (push (id object) still-around))
     (set-attributes location `(objects ,still-around))))


;;; WITHIN-MOVE      [Method]
;;; Date        : 99.03.29
;;; Description : Simply walk the icon and accumulate features that are within
;;;             : the movement tolerance.

(defgeneric within-move (vis-mod loc)
   (:documentation "Return a list of icon feature within the move 
allowance of loc."))

(defmethod within-move ((vis-mod vision-module) (loc vector))
   (if (= (move-allowance vis-mod) 0)
     (feat-match-xy (visicon vis-mod) loc)
     (let ((max (pm-angle-to-pixels (move-allowance vis-mod)))
           (accum nil))
       (dolist (feat (visicon vis-mod) accum)
         (when (>= max (dist (xy-loc feat) loc))
           (push feat accum))))))


;;; FEATLIS-TO-FOCUS      [Method]
;;; Date        : 99.03.29
;;; Description : First, determine which feature in the icon is the "best"
;;;             : feature, given the location that is the focus.  That
;;;             : location will have associate with it the feature and the
;;;             : spec used to generate it (in FIND-LOCATION).  Find the best
;;;             : feature, generate the list of DMOs at that location,
;;;             : determinine the focus, and make sure the location chunks and
;;;             : visual object chunks are synched up.

(defgeneric featlis-to-focus (vis-mod loc-dmo feat-lst)
   (:documentation  "Given the source location and a list of features, 
return the DMO that should be the focus."))

(defmethod featlis-to-focus ((vis-mod vision-module) (loc-dmo dmo) 
(feat-lis list))
   (let* ((best-feature
           (find-best-feature feat-lis
                              (gethash (id loc-dmo) (found-locs vis-mod))))
          (dmo-lis (featlis-to-dmos vis-mod (xy-loc best-feature)
                                      (feat-match-xy feat-lis
                                                     (xy-loc best-feature))))
          (return-dmo (determine-focus-dmo vis-mod dmo-lis best-feature)))
     (dolist (obj dmo-lis)
       (set-attributes obj `(screen-pos ,(id loc-dmo))))
     return-dmo))


;;; FEATLIS-TO-DMOS      [Method]
;;; Date        : 99.03.29
;;; Description : Actually, some of the features could be CHAR-PRIMITIVE
;;;             : features, in which case they're part of characters.  Save
;;;             : those out and make a character out of 'em.

(defgeneric featlis-to-dmos (vis-mod loc feat-lis)
   (:documentation  "Given a list of features, make a DMO for each."))

(defmethod featlis-to-dmos ((vis-mod vision-module) (loc vector) 
(feat-lis list))
   (let ((primitive-feats nil)
         (dmo-lis nil))
     (dolist (feat (feat-match-xy feat-lis loc))
       (setf (attended-p feat) t)
       ;; If it's a char primitive, push the feature, else push the 
feature chunk.
       (if (typep feat 'char-primitive-feature)
         (push  feat primitive-feats)
         (push (feat-to-dmo feat) dmo-lis)))
     (when primitive-feats
       (push (synthesize-letter vis-mod primitive-feats) dmo-lis))
     dmo-lis))


;;; DETERMINE-FOCUS-DMO      [Method]
;;; Date        : 99.03.29
;;; Description : Basically, look for a DMO with the same ID as the feature.
;;;             : If none, see if the DMO was synthesized from that feature.
;;;             : If none of those, return a random one.

(defgeneric determine-focus-dmo (vis-mod dmo-lst feat)
   (:documentation  "Determine which DMO corresponds to <feat>, which 
should be the 'best' feature."))

(defmethod determine-focus-dmo ((vis-mod vision-module) (dmo-lis 
list) (feat icon-feature))
   (when (= 1 (length dmo-lis))
     (return-from determine-focus-dmo (first dmo-lis)))
   (aif (member (dmo-id feat) dmo-lis :key #'id)
     (first it)
     (dolist (dmo dmo-lis (random-item dmo-lis))
       (when (member (dmo-id feat)
                     (synthed-to-features vis-mod (id dmo) nil))
         (return-from determine-focus-dmo dmo)))))


;;; GET-WORD-AT-NOOPT      [Method]
;;; Date        : 99.04.02
;;; Description : Getting a word when optimizing is off involves calling
;;;             : SYNTHESIZE-WORD method, but we need to collect the
;;;             : locations first, and also check the return if what was
;;;             : sent in was a DMO.

(defgeneric get-word-at-noopt (vis-mod loc-dmo)
   (:documentation  "Synthesize a word at the given location and synch 
it with the location."))

(defmethod get-word-at-noopt ((vis-mod vision-module) (loc-dmo dmo))
   (multiple-value-bind (locs xmin xmax)
                        (adjoining-led-locs vis-mod (dmo-to-xy loc-dmo))
     (when locs
       (let ((rtn-dmo (synthesize-word vis-mod locs
                                         (- xmax xmin) (dmo-to-xy loc-dmo))))
         (when rtn-dmo
           (set-attributes rtn-dmo `(screen-pos ,(id loc-dmo)))
           (values rtn-dmo xmin xmax))))))


(defgeneric get-word-at-noopt (vis-mod loc)
   (:documentation  "Synthesize a word at the given location."))

(defmethod get-word-at-noopt ((vis-mod vision-module) (loc vector))
   (multiple-value-bind (locs xmin xmax)  (adjoining-led-locs vis-mod loc)
     (when locs
       (let ((rtn-dmo (synthesize-word vis-mod locs
                                         (- xmax xmin) loc)))
         (when rtn-dmo
           (values rtn-dmo xmin xmax))))))


;;; GET-WORD-DMOS-NOOPT      [Method]
;;; Date        : 99.04.02
;;; Description : OK, when optimizing is off and a phrase needs to be built,
;;;             : the tricky bit is figuring out which locations you need
;;;             : to grab words from, since if you hit every x location,
;;;             : you'll generate multiple copies of each word.

(defgeneric get-word-dmos-noopt (vis-mod x-lst y)
   (:documentation  "Return a list of DMOs representing words at the 
given xlocs, with optimizing off."))

(defmethod get-word-dmos-noopt ((vis-mod vision-module) (x-ls list) y)
   (let ((rtn-dmos nil)
         (curr-x -1))
     (dolist (x x-ls (remove nil (nreverse rtn-dmos)))
       (when (> x curr-x)
         (multiple-value-bind (word min max)
                              (get-word-at-noopt vis-mod (vector x y))
           (declare (ignore min))
           (push word rtn-dmos)
           (setf curr-x max))))))


;;; GET-WORD-DMOS-OPT      [Method]
;;; Date        : 99.04.02
;;; Description : This is simpler when optimizing--just walk the xlist
;;;             : and accumulate words.
;;;             : Might be vestigial as of beta 6.

(defgeneric get-word-dmos-opt (vis-mod x-lst y)
   (:documentation  "Return a list of DMOs representing words at the 
given xlocs, with optimizing on."))

(defmethod get-word-dmos-opt ((vis-mod vision-module) (x-ls list) y)
   (let (accum)
     (dolist (x x-ls (nreverse accum))
       (dolist (feat (text-feats (feat-match-xy (visicon vis-mod) 
(vector x y))))
         (push (feat-to-dmo feat) accum)))))


;;; GET-ICON-OBJECT-AT      [Method]
;;; Date        : 97.06.01
;;; Description : Returns the DMO representing the feature(s) at a
;;;             : location.  If there are a whole bunch of the little line
;;;             : features that comprise letters, then do the categorization
;;;             : bit on the letters.

(defgeneric get-icon-object-at (vis-mod loc)
   (:documentation  "Return the chunk representing the icon feature(s) 
at the given <loc>"))

(defmethod get-icon-object-at ((vis-mod vision-module) (loc vector))
   (let ((led-feats nil)
         (dmo-lis nil)
         (return-dmo nil))
     (dolist (feat (within-move vis-mod loc))
       (setf (attended-p feat) t)
       ;; If it's an LED line, push the feature, else push the feature chunk.
       (if (eq (kind feat) 'led-line)
         (push  feat led-feats)
         (push (feat-to-dmo feat) dmo-lis)))
     (when led-feats
       (push (synthesize-letter vis-mod led-feats) dmo-lis))
     (setf return-dmo (random-item dmo-lis))
     return-dmo))


#|
;;; GET-WORD-AT      [Method]
;;; Date        : 97.06.01
;;; Description : Getting a word can be either hard or easy, depending on
;;;             : whether we're optimizing.  If we're optimizing, then the
;;;             : features are already words, so life is easy--just return
;;;             : the chunk for one of the features. If optimizing
;;;             : is off, then we have to synthesize a word from the letters.
;;;             : Vestigial in beta 6?  Not sure.

(defmethod get-word-at ((vis-mod vision-module) (loc list))
   "Return a chunk for the word at the given <loc>"
   (let ((dmo-lis nil))
     (if (optimize-p vis-mod)
       (let ((loc-feats (text-feats (within-move vis-mod loc)))
             (new-dmo nil))
         (unless (null loc-feats)
           (dolist (feat loc-feats (random-item dmo-lis))
             (setf new-dmo (feat-to-dmo feat))
             (push new-dmo dmo-lis))))
       ;; not optimizing
       (awhen (contiguous-locs loc (feat-match-y (visicon vis-mod) 
(second loc)))
         (synthesize-word vis-mod it)))))
|#


(defun text-feats (feat-lst)
   "Given a list, return only those features which are TEXT features."
   (remove-if #'(lambda (f) (not (eq (kind f) 'text))) feat-lst))


;;;; 
---------------------------------------------------------------------- 
;;;;
;;;; Finst support


(defmethod print-object ((fnst finst) strm)
   (print-unreadable-object (fnst strm :type t)
     (format strm "~S ~4,2F" (id fnst) (tstamp fnst))))


(defgeneric elapsed (object)
   (:documentation  "Return the time since this object was time-stamped."))

(defmethod elapsed ((fnst finst))
   (- (mp-time *mp*) (tstamp fnst)))


(defmethod in-finst ((name symbol) (fnst finst))
   (or (eq name (id fnst))
       (member name (synthed-from fnst))))


(defgeneric feat-attended (feat vis-mod)
   (:documentation  "Return the attended status of a visicon feature object."))

(defmethod feat-attended ((feat icon-feature) (vis-mod vision-module))
   (if (eq (attended-p feat) 'NEW)
     'NEW
     (consp (member (dmo-id feat) (finst-lst vis-mod)
                    :test #'in-finst))))


(defgeneric test-attended (spec feat)
   (:documentation  "Test a visicon feature against a spec, return T 
if they match on ATTENDED."))

(defmethod test-attended ((spec icon-feature) (feat icon-feature))
   (cond ((eq (attended-p spec) :IGNORE) t)
         ((and (null (attended-p spec)) (eq (attended-p feat) 'NEW)) t)
         (t (eq (attended-p spec)
                (feat-attended feat (vis-m *mp*))))))


(defmethod set-attended :after ((vis-mod vision-module) obj)
   (aif (member (id obj) (finst-lst vis-mod) :key #'id)
     (setf (tstamp (first it)) (mp-time *mp*))
     (push
      (make-instance 'finst :id (id obj) :tstamp (mp-time *mp*)
                     :synthed-from (synthed-to-features vis-mod (id obj) nil))
      (finst-lst vis-mod)))
   (sort-finsts vis-mod)
   (when (> (length (finst-lst vis-mod)) (num-finst vis-mod))
     (pop (finst-lst vis-mod))))


(defgeneric sort-finsts (vis-mod)
   (:documentation  "Sort finsts according to time stamp."))

(defmethod sort-finsts ((vis-mod vision-module))
   (setf (finst-lst vis-mod) (sort (finst-lst vis-mod) #'< :key #'tstamp)))


(defgeneric check-finsts (vis-mod)
   (:documentation  "Update finsts against what's on the display and sort."))

(defmethod check-finsts ((vis-mod vision-module))
   (setf (finst-lst vis-mod)
         (delete-if #'(lambda (f)
                        (or (not (object-present-p vis-mod (id f)))
                            (> (elapsed f)
                               (finst-span vis-mod))))
                    (finst-lst vis-mod)))
   (sort-finsts vis-mod))


;;;; 
---------------------------------------------------------------------- 
;;;;
;;;;  Supporting NEW tags


(defmethod elapsed ((feat icon-feature))
   (- (mp-time *mp*) (tstamp feat)))


(defgeneric checknew (feat vis-mod)
   (:documentation  "Check to see if a visicon feature is still NEW."))

(defmethod checknew ((feat icon-feature) (vis-mod vision-module))
   (when (and (eq (attended-p feat) 'NEW)
              (> (elapsed feat) (new-span vis-mod)))
     (setf (attended-p feat) nil))
   feat)





;;;; 
---------------------------------------------------------------------- 
;;;;
;;;; Synthetic features (letters, words, and phrases).
;;;; 
---------------------------------------------------------------------- 
;;;;

(defgeneric record-synth (vis-mod the-dmo &key x y width height built-from)
   (:documentation  "Record the id of a synthesized object and its 
properties."))

(defmethod record-synth ((vis-mod vision-module) (the-dmo dmo)
                            &key x y width height built-from)
   (declare (fixnum x y width height))
   (when (not (and x y width height built-from))
     (error "NIL passed to RECORD-SYNTH."))
   (setf (gethash (id the-dmo) (synthd-objs vis-mod))
         (make-instance 'synthd-feat :dmo-id (id the-dmo)
                        :built-from (mklist built-from)
                        :width width :height height
                        :x x :y y)))


;;; SYNTHED-TO-FEATURES      [Method]
;;; Description : If the ID is in the hash table of synthed IDs, then
;;;             : recurse on those.

(defgeneric synthed-to-features (vis-mod objid accum)
   (:documentation  "Given a synthetic object, return a list of icon 
features comprising it."))

(defmethod synthed-to-features ((vis-mod vision-module) objid accum)
   (aif (gethash objid (synthd-objs vis-mod))
     (flatten (mapcar #'(lambda (f) (synthed-to-features vis-mod f nil))
                      (built-from it)))
     (cons objid accum)))


;;; FEAT-OR-SYNTH      [Method]
;;; Date        : 99.04.02
;;; Description : VISUAL-OBJECTs should correspond to either real features
;;;             : or synthetic ones.  Look in both places.

(defgeneric feat-or-synth (vis-mod id)
   (:documentation  "Return the icon feature or synthetic object 
associated with <id>."))

(defmethod feat-or-synth ((vis-mod vision-module) id)
   (aif (member id (visicon vis-mod) :key #'dmo-id)
     (first it)
     (awhen (gethash id (synthd-objs vis-mod))
       it)))


;;; GET-PHRASE-AT      [Method]
;;; Date        : 98.07.27
;;; Description : The only way to get a phrase is to synthesize one, there is
;;;             : no "phrase" primitive in RPM.

(defgeneric get-phrase-at (vis-mod loc)
   (:documentation  "Mostly a stub for SYNTHESIZE-PHRASE."))

(defmethod get-phrase-at ((vis-mod vision-module) (loc vector))
   (awhen (feat-match-y (visicon vis-mod) (py loc))
     (synthesize-phrase vis-mod it (py loc))))


;;; SYNTHESIZE-LETTER      [Method]
;;; Date        : 98.07.27
;;; Description : From a list of LED-style icon features, synthesize a letter
;;;             : feature and note the synthesis.  The real worker here is
;;;             : Mike Matessa's FIND-BEST-OBJECT function, which is based on
;;;             : "rational categorization" of the features into a letter.

(defgeneric synthesize-letter (vis-mod feats)
   (:documentation  "Build a DMO representing a letter from a list of 
LED features."))

(defmethod synthesize-letter ((vis-mod vision-module) (feats list))
   (let ((base-feat (first feats))
         (letter (prob-best-character (active-cfs vis-mod)
                                       (mapcar #'true-feat feats)))
         (return-dmo nil)
         )
     (dolist (feat feats)
       (setf (attended-p feat) t))
     (setf return-dmo
           (make-dme (new-name-fct "LETTER") 'visual-object
                     `(screen-pos ,(id (current-marker vis-mod))
                                  value ,letter
                                  color black)
                     :obj (screen-obj base-feat)
                     ))
     (record-synth vis-mod return-dmo :x (screen-x base-feat)
                   :y (screen-y base-feat) :width (width base-feat)
                   :height (height base-feat)
                   :built-from (mapcar #'dmo-id feats))
     return-dmo))


;;; SYNTHESIZE-WORD      [Method]
;;; Date        : 98.07.27
;;; Description : Given the list of contiguous locations, get the letter
;;;             : at each location, and then build the word from the list
;;;             : of letters.

(defgeneric synthesize-word (vis-mod loc-lis width center)
   (:documentation  "Build a DMO representing a word from a location."))

(defmethod synthesize-word ((vis-mod vision-module) (loc-lis list)
                                (width number) (center vector))
   (let ((return-dmo nil)
         (letter-dmos nil))
     (dolist (xloc loc-lis)
       (push (synthesize-letter vis-mod (feat-match-xy (visicon vis-mod) xloc))
             letter-dmos)
       (when (not (stringp (get-attribute (first letter-dmos) 'value)))
         (pop letter-dmos)))
     (when letter-dmos
       (setf letter-dmos (nreverse letter-dmos))
       (setf return-dmo
             (make-dme (new-name-fct "WORD") 'TEXT
                       `(screen-pos ,(id (current-marker vis-mod))
                                    value ,(word-accum
                                            (mapcar #'(lambda (x) 
(get-attribute x 'value))
                                                    letter-dmos)))))
       (record-synth vis-mod return-dmo :x (px center) :y (py center)
                     :width width
                     :height
                     (height (feat-or-synth vis-mod (id (first letter-dmos))))
                     :built-from (mapcar #'id letter-dmos))
       return-dmo)))


;;; GET-PHRASE-AT      [Method]
;;; Date        : 98.07.27
;;; Description : The only way to get a phrase is to synthesize one, there is
;;;             : no "phrase" primitive in RPM.

(defgeneric get-phrase-at (vis-mod loc)
   (:documentation  "Mostly a stub for SYNTHESIZE-PHRASE."))

(defmethod get-phrase-at ((vis-mod vision-module) (loc vector))
   (awhen (feat-match-y (visicon vis-mod) (py loc))
     (synthesize-phrase vis-mod it loc)))


(defgeneric synthesize-phrase (vis-mod feature-locs loc)
   (:documentation  "Build a DMO representing a phrase."))

(defmethod synthesize-phrase ((vis-mod vision-module) (feature-locs list)
                                  (loc vector))
   (let ((x-locs (mapcar #'screen-x feature-locs))
         (word-dmos nil)
         (words nil)
         (return-dmo nil))
     (setf x-locs (sort (remove-duplicates x-locs) #'<))
     (if (optimize-p vis-mod)
       (setf word-dmos (get-word-dmos-opt vis-mod x-locs (py loc)))
       (setf word-dmos (get-word-dmos-noopt vis-mod x-locs (py loc))))
     ;(setf word-lis (nreverse word-lis))
     (when word-dmos
       (setf words (mapcar #'(lambda (x)
                               (get-attribute x 'value)) word-dmos))
       (setf word-dmos (mapcar #'id word-dmos))
       (setf return-dmo
             (make-dme (new-name-fct "PHRASE") 'phrase!
                       `(screen-pos
                         ,(id (current-marker vis-mod))
                         objects ,word-dmos
                         words ,words
                         color black
                         value ,(phrase-accum words))))
       (record-synth vis-mod return-dmo :x (px loc) :y (py loc)
                     :width
                     (reduce #'+
                             (mapcar #'(lambda (s)
                                         (width (feat-or-synth vis-mod s)))
                                     word-dmos))
                     :height
                     (height (feat-or-synth vis-mod (first word-dmos)))
                     :built-from word-dmos)
       return-dmo)))



;;;; 
---------------------------------------------------------------------- 
;;;;
;;;; Stuff for supporting other modules (mostly motor).
;;;; 
---------------------------------------------------------------------- 
;;;;

;;; UPDATE-ATTEDED-LOC      [Method]
;;; Date        : 97.06.01
;;; Description : What is at the focus of visual attention can change.
;;;             : If this might be happening, call this after PM-PROC-SCREEN
;;;             : to make sure the attended location is updated.
;;;             : UNLESS clause added 98.07.17

(defgeneric update-attended-loc (vis-mod)
   (:documentation  "Update whatever is at the attended location"))

(defmethod update-attended-loc ((vis-mod vision-module))
   (when (and (current-marker vis-mod)
              (currently-attended vis-mod)
              (null (tracked-obj vis-mod))
              (not (moving-attention vis-mod))
              (eq 'FREE (exec-s vis-mod))
              )
     (unless (and (currently-attended vis-mod)
                  (object-present-p vis-mod (id (currently-attended vis-mod))))
       (queue-command
        :time (move-attn-latency vis-mod)
        :where :VISION
        :command 'focus-on
        :randomize t
        :params `(,(current-marker vis-mod) ,(last-scale vis-mod)))
       (change-state vis-mod :exec 'busy))))



;;; OBJECT-PRESENT-P      [Method]
;;; Description : A visual object is present if its ID is still in the icon
;;;             : or if all the features from which it was synthesized are
;;;             : still in the icon.

(defgeneric object-present-p (vis-mod obj-id)
   (:documentation  "Returns NIL if the object ID passed to it is no 
longer in the icon."))

(defmethod object-present-p ((vis-mod vision-module) obj-id)
   (if (member obj-id (visicon vis-mod) :key #'dmo-id)
     t
     (let ((synthed (gethash obj-id (synthd-objs vis-mod))))
       (when synthed
         (dolist (obj (built-from synthed) t)
           (unless (object-present-p vis-mod obj)
             (return-from object-present-p nil)))))))


;;; LOC-TO-FEAT      [Method]
;;; Date        : 99.04.02
;;; Description : Since each location has associated with it the feature
;;;             : and the spec used to generate that location, it's possible
;;;             : to do a "best match" here vs. the current icon.  If there
;;;             : isn't a best match, then return a dummy feature which will
;;;             : generate the default width.

(defgeneric loc-to-feat (vis-mod loc)
   (:documentation  "Given a location DMO, return the corresponding 
icon feature."))

(defmethod loc-to-feat ((vis-mod vision-module) (loc dmo))
   (aif (find-best-feature (visicon vis-mod)
                           (gethash (id loc) (found-locs vis-mod)))
     it
     (make-instance 'dummy-feature :xy-loc (dmo-to-xy loc))))


;;; OBJ-TO-FEAT      [Method]
;;; Date        : 99.04.02
;;; Description : Visual objects should be associated with either real or
;;;             : synthetic features.  If neither of those can be found, at
;;;             : least the location of the object is known, so we can try
;;;             : to find something based on that.

(defgeneric obj-to-feat (vis-mod obj)
   (:documentation  "Given a visual object DMO, return the 
corresponding icon feature."))

(defmethod obj-to-feat ((vis-mod vision-module) (obj dmo))
   (aif (feat-or-synth vis-mod (id obj))
     it
     (loc-to-feat vis-mod (psdme-to-dmo (get-attribute obj 'screen-pos)))))



;;;; 
---------------------------------------------------------------------- 
;;;;
;;;; Finding locations.
;;;; 
---------------------------------------------------------------------- 
;;;;



;;; FIND-BEST-FEATURE      [Method]
;;; Date        : 99.03.29
;;; Description : The "best" feature is the one with the same ID as the spec.
;;;             : The next best feature is one that matches the spec and is
;;;             : nearest to that location.  Failing any matches to the spec,
;;;             : then return the nearest feature.

(defgeneric find-best-feature (feat-lst fs)
   (:documentation  "Given a list of features and a spec, return the 
'best' feature."))

(defmethod find-best-feature ((feat-lis list) (fs found-spec))
   (awhen (member (dmo-id (feat fs)) feat-lis :key #'dmo-id)
     (return-from find-best-feature (first it)))
   (let ((matches (matching-feats (spec fs) feat-lis)))
     (if matches
       (random-item (nearest-feat matches (xy-loc (feat fs))))
       (random-item (nearest-feat feat-lis (xy-loc (feat fs)))))))


;;; FIND-BEST-FEATURE      [Method]
;;; Date        : 99.03.29
;;; Description : When the spec is null, return a random feature.

(defgeneric find-best-feature (feat-lst fs)
   (:documentation  "Given a list of features and a spec, return the 
'best' feature."))

(defmethod find-best-feature ((feat-lis list) (fs null))
   (declare (ignore fs))
   (random-item feat-lis))


;;; FIND-LOCATION      [Method]
;;; Date        : 98.08.11R (rewrite), delta 99.06.24
;;; Description : To find a location, we need to search the icon.  To do this,
;;;             : construct a feature spec based on the parameters passed,
;;;             : and filter the list to those that match the spec.  This
;;;             : should be faster for large icons because it makes only
;;;             : one pass over the icon.  Regardless, some
;;;             : post-processing of that list might be necessary if LOWEST
;;;             : or HIGHEST was passed as a coordinate or if NEAREST is
;;;             : true.
;;;             : Once we have a list, randomly pick one (that may change in
;;;             : the future) feature and build a location out of it.

(defgeneric find-location (vis-mod &key kind attended value color
                                        size screen-x screen-y nearest)
   (:documentation  "Given a set of constraints, build a DMO for that 
screen location if one matches."))


(defmethod find-location ((vis-mod vision-module)
                              &key (kind :IGNORE) (attended :IGNORE)
                              (value :IGNORE) (color :IGNORE) (size :IGNORE)
                              screen-x screen-y nearest)

   (let ((spec (construct-findloc-spec :kind kind :attended attended 
:value value
                                  :color color :size size :screen-x screen-x
                                  :screen-y screen-y :nearest nearest)))
   (awhen (find-current-locs-with-spec vis-mod spec)
     (construct-location vis-mod
                         (random-item (objs-max-slotval it 'tstamp))
                         spec))))


(defun construct-findloc-spec (&key (kind :IGNORE) (attended :IGNORE)
                                         (value :IGNORE) (color :IGNORE)
                                         (size :IGNORE)
                                         screen-x screen-y nearest)
   (make-instance 'feature-spec
     :attended-p attended  :value value  :kind kind  :size size
     :color color :nearest nearest
     :x (if (null screen-x) :IGNORE screen-x)
     :y (if (null screen-y) :IGNORE screen-y)))


(defmethod find-current-locs-with-spec ((vis-mod vision-module)
                                              (base-spec feature-spec))
   (let ((feat-lst nil)
         (temp-spec (copy-instance base-spec)))
     (when (or (member (screen-x temp-spec)
                       '(greater-than-current less-than-current 
current lowest highest))
               (member (screen-y temp-spec)
                       '(greater-than-current less-than-current 
current lowest highest)))
       (setf temp-spec (remap-spec-to-current vis-mod temp-spec)))
     (setf (nearest temp-spec) :IGNORE)
     ;; do the actual search
     (setf feat-lst (objs-match-spec (visicon vis-mod) temp-spec))
     ;; some filtering--there's an ordering issue here!
     (case (screen-x base-spec)
       (lowest (setf feat-lst (objs-min-slotval feat-lst 'screen-x)))
       (highest (setf feat-lst (objs-max-slotval feat-lst 'screen-x))))
     (case (screen-y base-spec)
       (lowest (setf feat-lst (objs-min-slotval feat-lst 'screen-y)))
       (highest (setf feat-lst (objs-max-slotval feat-lst 'screen-y))))
     ;; handle the NEAREST flag
     (when (and (nearest base-spec) feat-lst)
       (if (eq (nearest base-spec) 'CURRENT)
         (setf feat-lst (nearest-feat feat-lst (current-lof vis-mod)))
         (setf feat-lst (nearest-feat feat-lst
                                      (dmo-to-xy
                                       (psdme-to-dmo
                                        (get-safe-wme (nearest base-spec))))))))
     feat-lst)
   )


(defmethod remap-spec-to-current ((vis-mod vision-module)
                                       (spec feature-spec))
   (let ((current-loc (current-lof vis-mod)))
     (setf (screen-x spec)
           (case (screen-x spec)
             (greater-than-current (greater-than (px current-loc)))
             (less-than-current (less-than (px current-loc)))
             (current (px current-loc))
             (lowest :IGNORE)
             (highest :IGNORE)
             (otherwise (screen-x spec))))
     (setf (screen-y spec)
           (case (screen-y spec)
             (greater-than-current (greater-than (py current-loc)))
             (less-than-current (less-than (py current-loc)))
             (current (py current-loc))
             (lowest :IGNORE)
             (highest :IGNORE)
             (otherwise (screen-y spec))))
     spec))






;;;; 
---------------------------------------------------------------------- 
;;;;
;;;;  Tracking stuff
;;;; 
---------------------------------------------------------------------- 
;;;;

;;; START-TRACKING      [Method]
;;; Date        : 97.05.15
;;; Description : Starting tracking is pretty easy, actually.  The target
;;;             : object needs to be found and installed in the relevant
;;;             : slots, and the ACT hook functions need to be set.

(defgeneric start-tracking (vis-mod obj-psdme)
   (:documentation  "Begin tracking an object"))

(defmethod start-tracking ((vis-mod vision-module) obj-psdme)
   (when (not (eql obj-psdme (id (currently-attended vis-mod))))
     (error "Request to track object ~S that is not currently being 
attended (~S)."
            obj-psdme (id (currently-attended vis-mod))))
   (change-state vis-mod :exec 'BUSY)
   (setf (input-q vis-mod) nil)
   (let ((target (pm-obj (currently-attended vis-mod))))
     (setf (tracked-obj vis-mod) target)
     (setf (tracked-obj-lastloc vis-mod) (view-loc target))
     (set-clof vis-mod (view-loc target))
     target))


;;; UPDATE-TRACKING-MTH      [Method]
;;; Date        : 97.05.15
;;; Description : Updating is kind of a pain.  First, if the tracked object
;;;             : hasn't moved, then do nothing.  If it has moved, however,
;;;             : there's a lot of bookkeeping to be done:
;;;             : [1] The old location need to have its object stripped and
;;;             : removed as an activation source.
;;;             : [2] The new location needs to be created, added to the
;;;             : attention focus, and have its OBJECTS slot set.
;;;             : [3] The object chunk needs to have its location changed.

(defgeneric update-tracking-mth (vis-mod)
   (:documentation  "Update the state of a tracked object"))

(defmethod update-tracking-mth ((vis-mod vision-module))
   (let ((oldloc-xy (tracked-obj-lastloc vis-mod))
         (newloc-xy (view-loc (tracked-obj vis-mod))))
     (when (not (equal newloc-xy oldloc-xy))
       (setf (tracked-obj-lastloc vis-mod) newloc-xy)
       (let (;(old-loc-dmo (current-marker vis-mod))
             (new-loc-dmo (xy-to-dmo newloc-xy t))
             (obj-dmo (currently-attended vis-mod)))
         ;(clear-loc old-loc-dmo)
         (set-attributes obj-dmo `(screen-pos ,(id new-loc-dmo)))
         (setf (current-marker vis-mod) new-loc-dmo)))))



;;; REMOVE-TRACKING      [Method]
;;; Date        : 97.05.15
;;; Description : When tracking stops, the slots for tracked objects need to
;;;             : to be cleared, and the ACT hook functions need to be cleared.

(defgeneric remove-tracking (vis-mod)
   (:documentation  "Clears out all the tracking stuff"))

(defmethod remove-tracking ((vis-mod vision-module))
   (setf (tracked-obj vis-mod) nil)
   (awhen (tracked-obj-lastloc vis-mod)
     (set-clof vis-mod it))
   (setf (tracked-obj-lastloc vis-mod) nil))


;;; PM-UPDATE-TRACKING      [Function]
;;; Date        : 97.05.15
;;; Description : To be called by the hook functions.

(defun pm-update-tracking (x)
   "Call the Vision Module's tracking update method."
   (declare (ignore x))
   (update-tracking-mth (vis-m *mp*)))



(defgeneric view-loc (view)
   (:documentation  "Return the location of the center of <view> as #(x y)."))

(defmethod view-loc (x)
   (declare (ignore x))
   (error "No method defined for VIEW-LOC."))


;;;; 
---------------------------------------------------------------------- 
;;;;
;;;; Icon Feature class and its children
;;;; 
---------------------------------------------------------------------- 
;;;;



(defgeneric print-icon-feature (feat)
   (:documentation  "Print out an ASCII representation of the icon."))

(defmethod print-icon-feature ((feat icon-feature))
   (format t "~%(~3D ~3D)  kind: ~A~Catt: ~3A~Cvalue: ~A~Cname: ~A"
           (screen-x feat) (screen-y feat) (kind feat) #\Tab
           (feat-attended feat (vis-m *mp*)) #\Tab (val feat)
           #\Tab (dmo-id feat)))


(defmethod print-object ((feat icon-feature) stream)
   (print-unreadable-object (feat stream :type t)
     (princ (dmo-id feat) stream)))



(defgeneric enter-into-visicon (feat time)
   (:documentation  "Enter at icon feature into the visicon at the 
time specified."))

(defmethod enter-into-visicon ((feat icon-feature) (time number))
   (unless (dmo-id feat)
     (setf (dmo-id feat) (new-name-fct (kind feat))))
   (setf (tstamp feat) time)
   feat)



;;; XY-LOC      [Method]
;;; Date        : 97.02.09
;;; Description : Return the location of a feature as a list.

(defgeneric xy-loc (feat)
   (:documentation  "Return the XY location of a feature as a vector."))

(defmethod xy-loc ((feat icon-feature))
   (vector (screen-x feat) (screen-y feat)))


;;; FEAT-TO-DMO      [Method]
;;; Date        : 98.05.28
;;; Description : From an icon feature, create a chunk.

(defgeneric feat-to-dmo (feat)
   (:documentation  "Build a chunk for an icon feature"))

(defmethod feat-to-dmo ((feat icon-feature))
   (setf (attended-p feat) t)
   (make-dme (dmo-id feat) (kind feat)
             `(screen-pos ,(id (xy-to-dmo (xy-loc feat) t))
                          value ,(val feat)
                          color ,(color feat))
             :obj (screen-obj feat)
             :where :external))

(defmethod feat-to-dmo :around ((feat cursor-feature))
   (let ((the-dmo (call-next-method)))
     (setf (pm-obj the-dmo) :cursor)
     the-dmo))


;;; COORDINATE-FEAT-LOC      [Method]
;;; Date        : 97.03.03
;;; Description : When a location is to correspond to a feature, make sure
;;;             : the ATTENDED slot matches.

(defgeneric coordinate-feat-loc (found-feat found-loc)
   (:documentation  "Matches up a feature and a location"))

(defmethod coordinate-feat-loc ((found-feat icon-feature) (found-loc dmo))
   (set-attributes found-loc `(attended ,(attended-p found-feat)
                                        kind ,(kind found-feat))))


(defgeneric feat-named (vis-mod id)
   (:documentation  "Returns the icon feature with the given <id>, if any."))

(defmethod feat-named ((vis-mod vision-module) id)
   (first (member id (visicon vis-mod) :key #'dmo-id)))



;;;; 
---------------------------------------------------------------------- 
;;;;
;;;;  Feature specifications, used to find features in the icon
;;;; 
---------------------------------------------------------------------- 
;;;;



;;; MATCH-SPEC-P      [Method]
;;; Date        : 98.08.11
;;; Description : Determining a match is based on testing for attribute
;;;             : matches or, in the case of coordinates, acceptable
;;;             : values.  So, check everything and return NIL on the
;;;             : first failure.  If nothing fails to match, return T.

(defgeneric match-spec-p (spec feat)
   (:documentation  "Returns T when <spec> and <feat> match."))

(defmethod match-spec-p ((spec icon-feature) (feat icon-feature))
   (cond ((not (test-attended spec feat)) nil)
         ;((not (attr-exact-match-p spec feat 'attended-p)) nil)
         ((not (attr-exact-match-p spec feat 'kind)) nil)
         ((not (attr-exact-match-p spec feat 'val)) nil)
         ((not (attr-exact-match-p spec feat 'color)) nil)
         ((and (numberp (size spec))
               (not (attr-exact-match-p spec feat 'size))) nil)
         ((and (numberp (screen-x spec))
               (not (attr-exact-match-p spec feat 'screen-x))) nil)
         ((and (numberp (screen-y spec))
               (not (attr-exact-match-p spec feat 'screen-y))) nil)
         ((and (functionp (size spec))
               (not (funcall (size spec) (size feat)))) nil)
         ((and (functionp (screen-x spec))
               (not (funcall (screen-x spec) (screen-x feat)))) nil)
         ((and (functionp (screen-y spec))
               (not (funcall (screen-y spec) (screen-y feat)))) nil)
         (t t)))


(defgeneric matching-feats (spec feat-lst)
   (:documentation  "Return a list of features matching a given feature spec."))

(defmethod matching-feats ((spec feature-spec) (feat-lis list))
   (remove-if-not #'(lambda (f) (match-spec-p spec f)) feat-lis))


;;; ATTR-EXACT-MATCH-P      [Method]
;;; Date        : 98.08.11
;;; Description : If the spec says to ignore that attribute, then return T
;;;             : becuase everything matches a don't care.  Otherwise, the
;;;             : spec and the feature values must be equal.

(defgeneric attr-exact-match-p (spec feat slotname)
   (:documentation  "Returns T when <spec> and <feat> match on 
attribute <slotname> (or if <spec> says :IGNORE)."))

(defmethod attr-exact-match-p ((spec icon-feature) (feat 
icon-feature) slotname)
   (cond ((eq (slot-value spec slotname) :IGNORE) T)
         ((equal (slot-value spec slotname) (slot-value feat slotname)))))


;;; SLOT-MATCH-P      [Method]
;;; Date        : 01.07.27
;;; Description : One should not be able to test TEXT features for their
;;;             : value, so this specializer should short-circuit that.

(defmethod slot-match-p ((ts spec) (obj text-feature)
                            (slotname (eql 'value)))
   t)


;;;; 
---------------------------------------------------------------------- 
;;;;
;;;;  Messing with features:  Doing icon checking, finding, and listing.
;;;; 
---------------------------------------------------------------------- 
;;;;

;;; APPROACH-WIDTH      [Method]
;;; Date        : 99.03.30
;;; Description : Remember in high school when someone asked in trig why we
;;;             : needed to know this crap?  Well, this is why.  I'm pretty
;;;             : sure this is all the right trig, but there could be some
;;;             : missed math in here.

(defmethod approach-width ((feat icon-feature) (theta number))
   (let* ((x (width feat))
          (y (height feat))
          (critical-theta (atan y x))
          (theta (abs theta))
          (ret-width nil))
     (when (> theta (/ pi 2))
       (setf theta (- pi theta)))
     (setf ret-width
           (cond ((= theta 0) x)
                 ((= theta (/ pi 2)) y)
                 ((= theta critical-theta) (sqrt (+ (* y y) (* x x))))
                 ((< theta critical-theta) (/ x (cos theta)))
                 (t (/ y (cos (- (/ pi 2) theta))))))
     (pm-pixels-to-angle ret-width)))


(defgeneric simple-size (feat)
   (:documentation  "If there are values for the height and width, 
convert to visual angle and multiply."))

(defmethod simple-size ((feat icon-feature))
   (when (and (width feat) (height feat))
     (* (pm-pixels-to-angle (width feat))
        (pm-pixels-to-angle (height feat)))))


;;; CONSTRUCT-LOCATION      [Method]
;;; Date        : 98.08.11, last delta 99.06.18
;;; Description : Building a location is pretty easy--if one exists already,
;;;             : use that.  If not, make one.  Note the commented out part
;;;             : may get used later--the idea is to store the feature and
;;;             : the spec used to find a given location, so that if attention
;;;             : is moved to that location and the feature moves a little
;;;             : bit, that same feature can be found.  And if that feature is
;;;             : gone, we can look for a new match to the spec.

(defgeneric construct-location (vis-mod feat spec)
   (:documentation  "Find or build a DMO based on a feature and the 
spec used to generate that feature."))

(defmethod construct-location ((vis-mod vision-module) (feat icon-feature)
                                   (spec icon-feature))
   (let ((loc-dmo (find-loc-dmo (xy-loc feat))))
     (if loc-dmo
       (coordinate-feat-loc feat loc-dmo)
       (setf loc-dmo (xy-to-dmo (xy-loc feat) nil)))
     ;; added set-attributes to synch this up right 99.06.18
     (set-attributes loc-dmo `(color ,(color feat) kind ,(kind feat)
                                     value ,(val feat)))
     (when *debug*
       (format t "~%Constructing location ~S" (id loc-dmo)))
     (setf (gethash (id loc-dmo) (found-locs vis-mod))
           (make-instance 'found-spec :feat feat :spec spec))
     (dmo-to-psdme loc-dmo)))


;;; CHECK-FEAT      [Method]
;;; Date        : 97.06.18
;;; Description : When features persist across calls to PROC-SCREEN, sometimes
;;;             : features that had been attended get wiped.  Use of this
;;;             : function can check for that.
;;;             : Setting DMO-ID added 98.07.17
;;;             : Wiping old feature (needed with optimizing off) added
;;;             : on 98.07.29.
;;;             : [mdb 00.06.12] Set the timestamp rather than the
;;;             : attended slot.

(defgeneric check-feat (feat vis-mod)
   (:documentation  "Checks a feature against the old icon, possibly 
setting the ATTENDED slot."))

(defmethod check-feat ((feat icon-feature) (vis-mod vision-module))
   (declare (optimize speed))
   (awhen (member feat (old-visicon vis-mod) :test #'feat=)
     (setf (tstamp feat) (tstamp (first it)))
     (unintern (dmo-id feat))
     (setf (dmo-id feat) (dmo-id (first it)))
     (setf (old-visicon vis-mod)
           (delete (first it) (old-visicon vis-mod)
                   :test (lambda (x y) (eq (dmo-id x) (dmo-id y))))))
   (checknew feat vis-mod))


;;; FEAT=      [Method]
;;; Description : Two features are equal if their non-ID attributes are
;;;             : all equal.

(defgeneric feat= (feat1 feat2)
   (:documentation  "Compares two icon features to determine if 
they're functionally equal."))

(defmethod feat= ((feat1 icon-feature) (feat2 icon-feature))
   (declare (optimize (speed 3)))
   (cond ((neq (type-of feat1) (type-of feat2)) nil)
         ((not (= (screen-x feat1) (screen-x feat2))) nil)
         ((not (= (screen-y feat1) (screen-y feat2))) nil)
         ((not (equal (width feat1) (width feat2))) nil)
         ((not (equal (height feat1) (height feat2))) nil)
         ((neq (kind feat1) (kind feat2)) nil)
         ((not (equal (val feat1) (val feat2))) nil)
         ((neq (color feat1) (color feat2)) nil)
         (t (typed-feat= feat1 feat2))))

(defgeneric typed-feat= (feat1 feat2)
   (:documentation  "Very specific comparison of special properties of 
icon features.  T is returned if equal."))

;; need one for line features
(defmethod typed-feat= ((feat1 line-feature) (feat2 line-feature))
   (declare (optimize (speed 3)))
   (cond ((not (= (end1-x feat1) (end1-x feat2))) nil)
         ((not (= (end1-y feat1) (end1-y feat2))) nil)
         ((not (= (end2-y feat1) (end2-y feat2))) nil)
         ((not (= (end2-x feat1) (end2-x feat2))) nil)
         (t t)))

;; with no other info, assume they're equal
(defmethod typed-feat= ((feat1 icon-feature) (feat2 icon-feature))
   t)


(defun feature-locs (feat-lst)
   "Given a list of features, return a list of unique feature locations."
   (declare (list feat-lst))
   (remove-duplicates (mapcar #'xy-loc feat-lst) :test #'equal))


(defun feat-max-x (feat-lst)
   "Returns list of features with maximum x value"
   (declare (list feat-lst))
   (objs-max-slotval feat-lst 'screen-x))


(defun feat-min-x (feat-lst)
   "Returns list of features with minimum x value"
   (declare (list feat-lst))
   (objs-min-slotval feat-lst 'screen-x))


(defun feat-max-y (feat-lst)
   "Returns list of features with maximum y value"
   (declare (list feat-lst))
   (objs-max-slotval feat-lst 'screen-y))


(defun feat-min-y (feat-lst)
   "Returns list of features with minimum y value"
   (declare (list feat-lst))
   (objs-min-slotval feat-lst 'screen-y))


(defun feat-match-x (feat-lst x)
   "Returns features that match a given x value"
   (declare (list feat-lst) (fixnum x))
   (objs-match-slotval feat-lst 'screen-x x))


(defun feat-match-y (feat-lst y)
   "Returns features that match a given y value"
   (declare (list feat-lst) (fixnum y))
   (objs-match-slotval feat-lst 'screen-y y))


(defgeneric feat-match-xy (feat-lst loc)
   (:documentation  "Returns the the subset of the list that match the 
XY location."))

(defmethod feat-match-xy ((feat-lst list) (loc vector))
   (let ((outlis nil))
     (dolist (feat feat-lst outlis)
       (if (and (= (screen-x feat) (px loc))
                (= (screen-y feat) (py loc)))
         (push feat outlis)))))


(defun nearest-feat (feat-list loc)
   "Returns list of features nearest to a given location"
   (declare (list feat-lis))
   (unless (vectorp loc)
     (setf loc (dmo-to-xy loc)))
   (when feat-list
     (let ((best (dist (xy-loc (first feat-list)) loc))
           (outlis (list (first feat-list)))
           (the-dist nil))
       (dolist (feat (rest feat-list) outlis)
         (setf the-dist (dist (xy-loc feat) loc))
         (cond ((= the-dist best) (push feat outlis))
               ((< the-dist best) (setf best the-dist)
                (setf outlis (list feat))))))))



;;; DELETE-FEATURES      [Method]
;;; Date        : 97.02.27
;;; Description : Removes features from the icon.  If the scale is SCREEN,
;;;             : then remove all features.  If the scale is WORD, then
;;;             : find the contiguous locations and remove all features at
;;;             : those locations.  Otherwise just remove all features at
;;;             : the specified location.

(defgeneric delete-features (vis-mod loc scale)
   (:documentation  "Removes features at a specified location"))

(defmethod delete-features ((vis-mod vision-module) loc scale)
   (declare (symbol loc))
   (case scale
     (screen (setf (visicon vis-mod) nil))
     (word
      (let ((feat-lis (visicon vis-mod))
            (loc-lis (contiguous-locs loc (feat-match-y (visicon vis-mod)
                                                          (py loc)))))
        (dolist (the-loc loc-lis)
          (setf feat-lis
                (remove-if #'(lambda (feat)
                               (equal the-loc (xy-loc feat)))
                           feat-lis)))
        (setf (visicon vis-mod) feat-lis)))
     (otherwise
      (setf (visicon vis-mod)
            (remove-if #'(lambda (feat) (equal loc (xy-loc feat)))
                       (visicon vis-mod))))))



;;; BUILD-STRING-FEATS      [Method]
;;; Date        : 99.03.30
;;; Description : In order to build all the features for a string, there is a
;;;             : great deal of stuff that is needed from the interface beyond
;;;             : just the string itself.  Need to know the y coordinate, the
;;;             : starting x coordinate, the line height, the associated
;;;             : screen object, and some way of determining the width (in
;;;             : pixels) of a string.
;;;             :
;;;             : There are two ways to do it, with and without optimizing.
;;;             : With optimizing it's easy, just accumulate words.  When
;;;             : optimzing is off, though, have to walk the string
;;;             : character-by-character and build features for each one.

(defgeneric build-string-feats (vis-mod &key text start-x y-pos
                                       width-fct height obj)
   (:documentation  "Build a list of ICON-FEATURES representing a 
string with the given geometry."))

(defmethod build-string-feats ((vis-mod vision-module) &key text start-x
                               y-pos width-fct height obj)
   (declare (fixnum start-x y-pos)  (function width-fct) (string text)
            (number height))
   (when (not (and text start-x y-pos width-fct height))
     (error "NIL passed to BUILD-STRING-FEATS."))
   (unless (equal text "")
     (let ((curr-x start-x)
           (f-accum nil)
           (spc-wdth (funcall width-fct " "))
           (curr-width nil))
       (if (optimize-p vis-mod)
         ;; if optimizing is on, then carve the string into words (strings)
         ;; and space runs (numbers)
         (dolist (word (chop-string text) (nreverse f-accum))
           (when (stringp word)
             (setf curr-width (funcall width-fct word))
             (push (make-instance 'text-feature
                     :y y-pos :screen-obj obj :height height
                     :value (string-downcase word)
                     :width curr-width
                     :x (+ curr-x (round curr-width 2))) f-accum))
           (incf curr-x (if (stringp word) curr-width (* word spc-wdth))))
         ;; if not optimizing, then blast it character-by-character
         (let ((char nil))
           (dotimes (idx (length text) (nreverse (flatten f-accum)))
             (setf char (char text idx))
             (setf curr-width (funcall width-fct (subseq text idx (1+ idx))))
             (cond ((alphanumericp char)
                    (push (char-to-features vis-mod (char-upcase char)
                                            curr-x
                                            (- (+ curr-x curr-width) 1)
                                            y-pos
                                            height obj) f-accum))
                   ((and (graphic-char-p char)
                         (not (char-equal char #\space)))
                    (push (make-instance 'text-feature
                            :y y-pos :screen-obj obj :height height
                            :value (mkstr char)
                            :width curr-width
                            :x (+ curr-x (round curr-width 2))) f-accum))
                   (t nil))
             (incf curr-x curr-width)))))))


;;;; 
---------------------------------------------------------------------- 
;;;;
;;;;  Those wacky LED features for letters.
;;;; 
---------------------------------------------------------------------- 
;;;;

;;; CHAR-TO-FEATURES      [Method]
;;; Date        : 99.03.30
;;; Description : For each character, there will usually be many of those
;;;             : CHAR-PRIMITIVE features.  Grab the list of features
;;;             : associated with a character, and build 'em.

(defgeneric char-to-features (vis-mod char left right y height obj)
   (:documentation  "Returns a list of basic icon-feature objects for 
a characer"))

(defmethod char-to-features ((vis-mod vision-module) (char character)
                                 (left number) (right number) (y number)
                                 (height number) obj)
   (let ((xpos (+ left (round (- right left) 2)))
         (width (1+ (- right left)))
         (features (pairlis
                      (getfeats (active-cfs vis-mod) char)
                      (get-icon-feats (active-cfs vis-mod) char)))
         (accum nil))
     (dolist (feats features accum)
       (push (make-instance 'char-primitive-feature
               :x xpos :y y :width width :height height
               :left left :right right :screen-obj obj
               :true-feat (first feats) :value (rest feats))
             accum))))


;;; ADJOINING-LED-LOCS      [Method]
;;; Date        : 99.04.02
;;; Description : To synthesize a word, we need to know which locations have
;;;             : LED-LINE features at adjoining locations.  However,
;;;             : because letter width is variable, the icon has to be
;;;             : searched for LED-LINE locations that have features that
;;;             : are near the boundaries.  Also, because we need to know the
;;;             : width of the word, return the min and max x values, too.

(defgeneric adjoining-led-locs (vis-mod loc)
   (:documentation  "Return a list of locations adjoining <loc>, as 
well as the max and min x locs."))

(defmethod adjoining-led-locs ((vis-mod vision-module) (loc vector))
   (let ((feat-ls (feat-match-xy (visicon vis-mod) loc))
         (feat nil))
     (while (and (null feat) feat-ls)
       (setf feat (pop feat-ls))
       (unless (typep feat 'char-primitive-feature)
         (setf feat nil)))
     (when feat
       (setf feat-ls (feat-match-y (visicon vis-mod) (screen-y feat)))
       (multiple-value-bind
         (lowlocs xmin) (left-adjoining-led-locs feat-ls (left-edge feat) nil)
         (multiple-value-bind
           (hilocs xmax) (right-adjoining-led-locs feat-ls (right-edge 
feat) nil)
           (values
            (append lowlocs (list loc) hilocs)
            xmin xmax))))))


;;; RIGHT-ADJOINING-LED-LOCS      [Method]
;;; Date        : 99.04.02
;;; Description : Recursively go right and accumulate locations that share
;;;             : the boundary.

(defgeneric right-adjoining-led-locs (feat-ls x accum)
   (:documentation  "Return a list of all the right-adjoining locs 
with led features and the min x."))

(defmethod right-adjoining-led-locs ((feat-ls list) x accum)
   (dolist (feat feat-ls)
     (when (typep feat 'char-primitive-feature)
       (when (> 1.5 (abs (- (left-edge feat) x)))
         (return-from right-adjoining-led-locs
           (right-adjoining-led-locs feat-ls (right-edge feat)
                                     (append accum (list (xy-loc feat))))))))
   (values accum x))


;;; LEFT-ADJOINING-LED-LOCS      [Method]
;;; Date        : 99.04.02
;;; Description : Recursively go left and accumulate locations that share
;;;             : the boundary.

(defgeneric left-adjoining-led-locs (feat-ls x accum)
   (:documentation  "Return a list of all the left-adjoining locs with 
led features and the max x."))

(defmethod left-adjoining-led-locs ((feat-ls list) x accum)
   (dolist (feat feat-ls)
     (when (typep feat 'char-primitive-feature)
       (when (> 1.5 (abs (- (right-edge feat) x)))
         (return-from left-adjoining-led-locs
           (left-adjoining-led-locs feat-ls (left-edge feat)
                                    (append (list (xy-loc feat)) accum))))))
   (values accum x))


;;;; 
---------------------------------------------------------------------- 
;;;;
;;;; Misc utils
;;;;

(defgeneric set-clof (vis-mod new-lof)
   (:documentation "Updates vision module's current location of focus."))

(defmethod set-clof ((vis-mod vision-module) (new-lof vector))
   (setf (current-lof vis-mod) new-lof)
   (when (trace-attn-p vis-mod)
     (push (cons (pm-time) new-lof) (attn-trace vis-mod))))




;;; non-MCL lisps don't define COPY-INSTANCE, so we need one just for
;;; feature-spec types.

#-mcl
(defmethod copy-instance ((spec feature-spec))
   (make-instance 'feature-spec
     :x (screen-x spec) :y (screen-y spec) :nearest (nearest spec)
     :attended-p (attended-p spec) :value (val spec) :color (color spec)
     :kind (kind spec) :size (size spec)))


;;; CHOP-STRING      [Function]
;;; Date        : 97.07.02
;;; Description : Chops up a string according to what's in the string.
;;;             : The idea is to keep words intact, blocks of nonword 
characters
;;;             : intact, and know the spacing between words.  Given a string,
;;;             : this will return a list with that kind of info in it.
;;;             : Example:  (chop-string "==foo==   bar") will return:
;;;             : ("==" "foo" "==" 3 "foo").  The 3 in the list represents
;;;             : blanks, and notice how the "==foo==" was carved into three
;;;             : elements.

(defun chop-string (str)
   (declare (string str))
   (let* ((oldstate (char->state (char str 0)))
          (state nil)
          (chr nil)
          (wrd "")
          (cnt 0)
          (accum nil))
     (dotimes (i (length str))
       (setf chr (char str i))
       (setf state (char->state chr))
       (cond
        ;; if we're accumulating chars and the new char matches our state,
        ;; just concat the char
        ((or (and (eq state :WORD) (eq oldstate :WORD))
             (and (eq state :MISC) (eq oldstate :MISC)))
         (setf wrd (mkstr wrd chr))
         (setf cnt 0))
        ;; If we get a state change that finishes a word, then grab the
        ;; word.
        ((and (or (eq oldstate :WORD) (eq oldstate :MISC))
              (not (eq oldstate state)))
         (push wrd accum)
         (if (not (eq state :SPACE))
           (setf wrd (mkstr chr))
           (setf wrd "")))
        ;; when switching from spaces to words, push the counter and start
        ;; the word
        ((and (eq oldstate :SPACE) (not (eq state oldstate)))
         (push (1+ cnt) accum)
         (setf wrd (mkstr wrd chr)))
        ;; from whitespace to whitespace, inc the counter
        (t (incf cnt)))
       (setf oldstate state))
     (when (not (string= wrd ""))
       (push wrd accum))
     (setf accum (nreverse accum))
     (when (numberp (first accum))
       (decf (first accum)))
     accum))


(defun char->state (char)
   "Given a character, return :WORD, :SPACE, or :MISC"
   (declare (character char))
   (cond ((alphanumericp char) :WORD)
         ((whitespace-p char) :SPACE)
         (t :MISC)))


(defun whitespace-p (char)
   "Returns T if <char> is a whitespace character (non-printing or space)"
   (declare (character char))
   (or (not (graphic-char-p char))
       (eq char #\Space)))


(defun break-by-space (str)
   "Return <str> broken into a list of strings. Space is the separator."
   (declare (string str))
   (let ((ans nil)
         (pos nil)
         (start 0))
     (loop
       (setf pos (position #\space str :start start))
       (cond (pos
              (push (subseq str start pos) ans)
              (setf start (1+ pos)))
             (t
              (push (subseq str start (length str)) ans)
              (return))))
     (setf ans (remove "" ans :test #'string=))
     (reverse ans)))




;;; CONTIGUOUS-LOCS      [Function]
;;; Date        : 97.02.07
;;; Description : Given a location and a feature list, return a list of all the
;;;             : contiguous locations.  "Contiguous" only in the X direction,
;;;             : in this case.

(defun contiguous-locs (loc feat-lis)
   "Given a location and a feature list, return a list of all the 
contiguous locations"
   (declare (vector loc) (list feat-lis))
   (let ((workloc (copy-list loc))
         (work-lis nil))
     (while (feat-match-xy feat-lis workloc)
       (push (copy-seq workloc) work-lis)
       (incf (px workloc)))
     (setf workloc (copy-seq loc))
     (decf (px workloc))
     (while (feat-match-xy feat-lis workloc)
       (push (copy-seq workloc) work-lis)
       (decf (px workloc)))
     (sort work-lis #'< :key #'first)))



(defun phrase-accum (lis)
   "Accumulate a list of words into a phrase."
   (let ((accum (first lis)))
     (dolist (item (rest lis) accum)
       (setf accum (mkstr accum " " item)))))


(defun word-accum (lis)
   "Accumulate a list of letters into a word, and downcase it."
   (let ((accum (first lis)))
     (dolist (item (rest lis) (string-downcase accum))
       (setf accum (mkstr accum item)))))


;;;  -*- mode: LISP; Package: CL-USER; Syntax: COMMON-LISP;  Base: 10 -*-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Author      : Mike Byrne
;;; 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    : vision-module.lisp
;;; Version     : 2.1b4
;;;
;;; Description : Source code for the ACT-R/PM Vision Module.
;;;
;;; Bugs        : [] Need to split object identification and chunk
;;;             :    construction in GET-OBJECT-AT because of EMMA.
;;;
;;; Todo        : [] Ordering of screen-x and screen-y tests.
;;;             : [] General feature synthesis.
;;;
;;;
;;; ----- History ----- [look also at function comments]
;;;
;;; 01.07.27 mdb
;;;             : Started the 2.1/ACT5 recoding.
;;;             : [x] Split up FL into pieces to be callable.
;;;             : [x] Remove OBJECTS slot from visual-locations.
;;;             : [x] VALUE slot should not be available for text features.
;;; 01.09.17 mdb
;;;             : Fixed bug in REMAP-SPEC-TO-CURRENT.
;;; 01.09.21 mdb [b2]
;;;             : * Made a bunch of changes to reduce the number of gentemps
;;;             : created by the system.  It probably rebuilds the icon
;;;             : faster, also.
;;;             : * Corrected another stupidity in UPDATE-ATTENDED-LOC.
;;; 01.10.31 mdb [b3]
;;;             : Added COPY-INSTANCE method for non-MCL Lisps.
;;; 01.11.05 mdb
;;;             : Added CURRENT-LOF slot to ease certain problems related to
;;;             : where attention is focussed vs. the chunk describing where
;;;             : its focussed.
;;; 01.11.11 mdb
;;;             : Added ATTN-TRACE and TRACE-ATTN-P slots to support replay as
;;;             : well as SET-CLOF function.  This changed the tracking code
;;;             : a teensy bit as well.
;;; 02.01.17 mdb [b4]
;;;             : Adopted Dan's fix on ENTER-INTO-VISICON.
;;; 02.01.21 mdb
;;;             : Fixed GREATER-THAN-CURRENT and LESS-THAN-CURRENT.
;;;             : Fixed NEAREST broken, only relative to current.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


(proclaim '(optimize (speed 3) (space 0)))

;;;; 
---------------------------------------------------------------------- 
;;;;
;;;; Class declarations
;;;; 
---------------------------------------------------------------------- 
;;;;

(defclass vision-module (attn-module)
   ((visicon :accessor visicon :initarg :visicon :initform nil)
    ; (old-visicon :accessor old-visicon :initarg :old-visicon :initform nil)
    (optimize-visual :accessor optimize-p :initarg :optimize-p :initform t)
    (print-viewed :accessor print-view-p :initarg :print-view-p :initform nil)
    (conservative-update :accessor conservative-p :initarg 
:conservative-p :initform nil)
    (move-attention-latency :accessor move-attn-latency
                            :initarg :move-attn-latency :initform 0.085)
    (tracked-object :accessor tracked-obj :initarg :tracked-obj :initform nil)
    (tracked-object-last-location :accessor tracked-obj-lastloc
                                  :initarg :tracked-obj-lastloc :initform nil)
    (last-scale :accessor last-scale :initarg :last-scale :initform nil)
    (moving-attention :accessor moving-attention :initarg :moving-attention
                      :initform nil)
    (move-allowance :accessor move-allowance :initarg :move-allowance
                    :initform 0)
    (synthd-objs :accessor synthd-objs :initarg :synthd-objs
                 :initform (make-hash-table))
    (found-locs :accessor found-locs :initarg :found-locs
                :initform (make-hash-table))
    (feature-sets :accessor feature-sets :initarg :feature-sets
                  :initform (all-feature-sets))
    (active-cfs :accessor active-cfs :initarg :active-cfs
                :initform nil)
    (num-finst :accessor num-finst :initarg :num-finst :initform 4)
    (finst-lst :accessor finst-lst :initarg :finst-lst :initform nil)
    (finst-span :accessor finst-span :initarg :finst-span :initform 3.0)
    (new-span :accessor new-span :initarg :new-span :initform 0.5)
    (default-spec :accessor default-spec :initarg :default-spec
      :initform nil)
    (current-lof :accessor current-lof :initarg :current-lof :initform #(0 0))
    (trace-attn-p :accessor trace-attn-p :initarg :trace-attn-p :initform nil)
    (attn-trace :accessor attn-trace :initarg :attn-trace :initform nil)
    )
   (:default-initargs
     :name :VISION))

(defclass found-spec ()
   ((spec :accessor spec :initarg :spec :initform nil)
    (feat :accessor feat :initarg :feat :initform nil)))


(defclass finst ()
   ((id :accessor id :initarg :id :initform nil)
    (tstamp :accessor tstamp :initarg :tstamp :initform 0.0)
    (synthed-from :accessor synthed-from :initarg :synthed-from :initform nil)))


;;; ICON-FEATURE      [Class]
;;; Description : Coordinates (x, y, width, height) should be in pixels to
;;;             : relate directly to the screen.  However, the SIZE attribute
;;;             : should be in degrees of visual angle (squared, of course)
;;;             : for FIND-LOCATION calls.
;;;             : Beta6 added WIDTH, HEIGHT, and SIZE attributes.

(defclass icon-feature ()
   ((screen-x :accessor screen-x :initarg :x :initform nil)
    (screen-y :accessor screen-y :initarg :y :initform nil)
    (attended-p :accessor attended-p :initarg :attended-p :initform 'NEW)
    (kind :accessor kind :initarg :kind :initform 'visual-object)
    (val :accessor val :initarg :value :initform nil)
    (color :accessor color :initarg :color :initform 'black)
    (dmo-id :accessor dmo-id :initarg :dmo-id :initform nil)     	; new
    (screen-obj :accessor screen-obj :initarg :screen-obj :initform nil)
    (height :accessor height :initarg :height :initform nil)
    (width :accessor width :initarg :width :initform nil)
    (size :accessor size :initarg :size :initform nil)
    (tstamp :accessor tstamp :initarg :tstamp :initform nil)     	; new
    (obj-freq :accessor obj-freq :initarg :obj-freq :initform 0.01)
    ))


(defclass oval-feature (icon-feature)
   ()
   (:default-initargs
     :kind 'oval
     :value 'oval
     ))


(defclass led-line-feature (icon-feature)
   ((line-pos :accessor line-pos :initarg :line-pos :initform nil)
    (left-edge :accessor left-edge :initarg :left :initform nil)
    (right-edge :accessor right-edge :initarg :right :initform nil))
   (:default-initargs
     :kind 'text))


(defclass cursor-feature (icon-feature)
   ()
   (:default-initargs
     :kind 'cursor
     :value 'pointer))


(defclass rect-feature (icon-feature)
   ()
   (:default-initargs
     :kind 'visual-object
     :value 'box))


(defclass line-feature (icon-feature)
   ((end1-x :accessor end1-x :initarg :end1-x :initform nil)
    (end1-y :accessor end1-y :initarg :end1-y :initform nil)
    (end2-x :accessor end2-x :initarg :end2-x :initform nil)
    (end2-y :accessor end2-y :initarg :end2-y :initform nil)
    )
   (:default-initargs
     :kind 'line
     :value 'line))


(defclass text-feature (icon-feature)
   ()
   (:default-initargs
     :kind 'text))


(defclass empty-feature (icon-feature)
   ()
   (:default-initargs
     :kind 'EMPTY-SPACE
     :value nil
     :color nil))


(defclass feature-spec (icon-feature spec)
   ((nearest :accessor nearest :initarg :nearest :initform nil))
   (:default-initargs
     :check-slots #(attended-p screen-x screen-y kind val color size)
     :x :IGNORE
     :y :IGNORE
     :attended-p :IGNORE
     :value :IGNORE
     :color :IGNORE
     :kind :IGNORE
     :size :IGNORE
     ))

(defmethod initialize-instance :after ((feat feature-spec) &key)
   (setf (dmo-id feat) (gensym "SPEC")))


(defclass char-primitive-feature (icon-feature)
   ((true-feat :accessor true-feat :initarg :true-feat :initform nil)
    (left-edge :accessor left-edge :initarg :left :initform nil)
    (right-edge :accessor right-edge :initarg :right :initform nil))
   (:default-initargs
     :kind 'text))



;;; SYNTHD-FEAT      [Class]
;;; Date        : 99.04.02
;;; Description : When an object (word or phrase) is synthesized out of
;;;             : primitive features, some record of that has to be kept
;;;             : around for things like mouse targeting.  Synthetic
;;;             : features are hashed by ID, and store the IDs of the
;;;             : features from which they were constructed.

(defclass synthd-feat (icon-feature)
   ((built-from :accessor built-from :initform nil :initarg :built-from)))


(defclass dummy-feature ()
   ((xy-loc :accessor xy-loc :initarg :xy-loc :initarg nil)))


(defgeneric approach-width (feat theta)
   (:documentation "Returns the width of a feature in degrees given an 
approach angle."))

(defmethod approach-width ((feat dummy-feature) (theta float))
   (default-target-width (motor-m *mp*)))


;;;; 
---------------------------------------------------------------------- 
;;;;
;;;; Module-level stuff stuff

(defmethod initialize-instance :after ((vis-mod vision-module) &key)
   "Initializes a vision module"
   (setf (state-dmo vis-mod)
         (make-dme 'vision-state 'module-state
                   '(module :vision modality free processor free 
preparation free
                     execution free)
                   :where :external))
   (setf (default-spec vis-mod)
         (make-instance 'feature-spec :attended-p 'NEW :x 'LOWEST :tstamp 0))
   (set-cfs-mth vis-mod :RM-ORIG))


;;; RESET-MODULE      [Method]
;;; Date        : 97.03.31
;;; Description : Besides the basics, clear the icon and reset the
;;;             : current location to be nil.

(defmethod reset-module :after ((vis-mod vision-module))
   "Resets the state of a Vision Module"
   (setf (visicon vis-mod) nil)
   (remove-tracking vis-mod)
   (setf (last-scale vis-mod) nil)
   (set-cfs-mth vis-mod :RM-ORIG)
   (setf (synthd-objs vis-mod) (clrhash (synthd-objs vis-mod)))
   (setf (found-locs vis-mod) (clrhash (found-locs vis-mod)))
   (setf (finst-lst vis-mod) nil)
   (setf (default-spec vis-mod)
         (make-instance 'feature-spec :attended-p 'NEW :x 'LOWEST :tstamp 0))
   (setf (attn-trace vis-mod) nil)
   (set-clof vis-mod #(0 0))
   )


(defmethod clear :after ((vis-mod vision-module))
   (remove-tracking vis-mod))


(defmethod update-module :after ((vis-mod vision-module))
   (when (tracked-obj vis-mod)
     (update-tracking-mth vis-mod))
   (check-finsts vis-mod)
   (mapc #'(lambda (f) (checknew f vis-mod)) (visicon vis-mod)))


(defmethod silent-events ((vis-mod vision-module))
   (tracked-obj vis-mod))


(defgeneric set-cfs-mth (vis-mod kwrd)
   (:documentation "Set the current character feature set."))

(defmethod set-cfs-mth ((vis-mod vision-module) kwrd)
   (setf (active-cfs vis-mod) (get-cfs-mth vis-mod kwrd)))


(defgeneric get-cfs-mth (vis-mod kwrd)
   (:documentation "Given a keyword, find a character feature set."))

(defmethod get-cfs-mth ((vis-mod vision-module) kwrd)
   (aif (member kwrd (feature-sets vis-mod) :key #'name)
     (first it)
     (pm-warning "Feature set ~S is unknown" kwrd)))


;;;; 
---------------------------------------------------------------------- 
;;;;
;;;; Moving attention and its immediate support functions, such
;;;;     as FOCUS-ON and the various GET- functions.
;;;; 
---------------------------------------------------------------------- 
;;;;

;;; MOVE-ATTENTION      [Method]
;;; Date        : 97.02.09
;;; Description : This is a toplevel command for the Vision Module, causing
;;;             : attention to move.  Latencey is 185 ms, so nothing actually
;;;             : happens right away other than setting state variables.
;;;             : A method is dispatched based on the scale that's passed.

(defgeneric move-attention (vis-mod &key location scale)
   (:documentation "Shift attention to a particular location at a 
particular scale."))

(defmethod move-attention ((vis-mod vision-module) &key location scale)
   (declare (symbol scale))
   (if (eq (exec-s vis-mod) 'BUSY)
     (pm-warning "Attention shift requested at ~S while one was 
already in progress."
                 (mp-time *mp*))
     (progn
       (when (tracked-obj vis-mod) (remove-tracking vis-mod))
       (setf (input-q vis-mod) nil)
       (setf (moving-attention vis-mod) t)
       (clear-attended vis-mod)
       (setf (last-scale vis-mod) scale)
       (setf location (psdme-to-dmo location))
       (queue-command
        :time (move-attn-latency vis-mod) :where :VISION :command 'focus-on
        :randomize t :params `(,location ,scale))
       (setf (current-marker vis-mod) location)
       (set-clof vis-mod (dmo-to-xy location))
       (change-state vis-mod :exec 'busy))))



;;; FOCUS-ON      [Method]
;;; Date        : 97.06.01
;;; Description : Several things to do when focusing attention on a location.
;;;             : [1] Make the location attended, set state to FREE.
;;;             : [2] Make it an external source (and null the old source).
;;;             : [3] If there was nothing there, or we were non-conserving
;;;             :     get the thing at that location.
;;;             : [4] If there is something, synch it up with the location
;;;             :     chunk.
;;;             : [5] If requested, print it.


(defgeneric focus-on (vis-mod loc-dmo scale)
   (:documentation "When MOVE-ATTENTION completes, focus on a place 
with this."))

(defmethod focus-on ((vis-mod vision-module) (loc-dmo dmo) scale)
   (declare (symbol scale))
   (set-attributes loc-dmo '(attended t))
   (setf (moving-attention vis-mod) nil)
   (change-state vis-mod :exec 'free)
   ;(setf (current-marker vis-mod) loc-dmo)
   (let ((return-obj (get-obj-at-location vis-mod loc-dmo scale)))
     (unless return-obj
       ;(clear-loc loc-dmo)
       (clear-attended vis-mod)
       (return-from focus-on nil))
     (set-attended vis-mod return-obj)
     (when (print-view-p vis-mod)
       (format t "~% <> MOVE-ATTENTION generated DMO ~S~%" (id return-obj)))
     return-obj))


(defgeneric get-obj-at-location (vis-mod loc-dmo scale)
   (:documentation  "Given a location and a scale, return a DMO 
representing what's there."))

(defmethod get-obj-at-location ((vis-mod vision-module) (loc-dmo dmo)
                                scale)
   (declare (symbol scale))
   (let ((return-obj nil)
         (xy-loc (dmo-to-xy loc-dmo)))
     (if (conservative-p vis-mod)
       (setf return-obj (conservative-get-object vis-mod loc-dmo))
       (progn
         (setf return-obj
               (cond ((eq scale 'PHRASE)
                      (get-phrase-at vis-mod xy-loc))
                     ((and (eq scale 'WORD) (not (optimize-p vis-mod)))
                      (get-word-at-noopt vis-mod loc-dmo))
                     (t
                      (let ((feat-lis (within-move vis-mod xy-loc)))
                        (when (eq scale 'WORD)
                          (setf feat-lis (text-feats feat-lis)))
                        (when feat-lis
                          (featlis-to-focus vis-mod loc-dmo feat-lis))))))))
     return-obj))



;;; CONSERVATIVE-GET-OBJECT      [Method]
;;; Date        : 99.03.29
;;; Description : When CONSERVATIVE is on, try to grab an object that's
;;;             : present in the current location chunk.

(defgeneric conservative-get-object (vis-mod loc-dmo)
   (:documentation "Create a DMO for the object at the given location, 
when :CONSERVATIVE-UPDATE-VISUAL is true."))

(defmethod conservative-get-object ((vis-mod vision-module)
                                         (loc-dmo dmo))
   (let ((present-objects
          (remove-if-not #'(lambda (o) (object-present-p vis-mod o))
                         (get-attribute loc-dmo 'objects)))
         (best-object nil)
         (base-feat (feat (gethash (id loc-dmo) (found-locs vis-mod)))))
     (when present-objects
       (if (null base-feat)
         (setf best-object (random-item present-objects))
         (progn
           (setf best-object
                 (determine-focus-dmo vis-mod present-objects base-feat))
           (setf (attended-p base-feat) t)))
       (setf (currently-attended vis-mod) best-object)
       best-object)))


;;; SYNCH-LOCS      [Method]
;;; Date        : 98.07.26, last delta 99.06.24
;;; Description : When an object is focused on, some objects might need to
;;;             : be updated.  This should keep the location chunk in
;;;             : synch with the world and with the object chunk.

(defgeneric synch-locs (vis-mod object location)
   (:documentation "Given an object and location DM rep, synchronizes 
the appropriate slots."))

(defmethod synch-locs ((vis-mod vision-module) (object dmo) (location dmo))
   (let ((still-around nil))
     (dolist (obj (mklist (get-attribute location 'objects)))
       (when (object-present-p vis-mod obj)
         (push obj still-around)))
     (set-attributes object `(screen-pos ,(id location)))
     (if (null still-around)
       (setf still-around (id object))
       (push (id object) still-around))
     (set-attributes location `(objects ,still-around))))


;;; WITHIN-MOVE      [Method]
;;; Date        : 99.03.29
;;; Description : Simply walk the icon and accumulate features that are within
;;;             : the movement tolerance.

(defgeneric within-move (vis-mod loc)
   (:documentation "Return a list of icon feature within the move 
allowance of loc."))

(defmethod within-move ((vis-mod vision-module) (loc vector))
   (if (= (move-allowance vis-mod) 0)
     (feat-match-xy (visicon vis-mod) loc)
     (let ((max (pm-angle-to-pixels (move-allowance vis-mod)))
           (accum nil))
       (dolist (feat (visicon vis-mod) accum)
         (when (>= max (dist (xy-loc feat) loc))
           (push feat accum))))))


;;; FEATLIS-TO-FOCUS      [Method]
;;; Date        : 99.03.29
;;; Description : First, determine which feature in the icon is the "best"
;;;             : feature, given the location that is the focus.  That
;;;             : location will have associate with it the feature and the
;;;             : spec used to generate it (in FIND-LOCATION).  Find the best
;;;             : feature, generate the list of DMOs at that location,
;;;             : determinine the focus, and make sure the location chunks and
;;;             : visual object chunks are synched up.

(defgeneric featlis-to-focus (vis-mod loc-dmo feat-lst)
   (:documentation  "Given the source location and a list of features, 
return the DMO that should be the focus."))

(defmethod featlis-to-focus ((vis-mod vision-module) (loc-dmo dmo) 
(feat-lis list))
   (let* ((best-feature
           (find-best-feature feat-lis
                              (gethash (id loc-dmo) (found-locs vis-mod))))
          (dmo-lis (featlis-to-dmos vis-mod (xy-loc best-feature)
                                      (feat-match-xy feat-lis
                                                     (xy-loc best-feature))))
          (return-dmo (determine-focus-dmo vis-mod dmo-lis best-feature)))
     (dolist (obj dmo-lis)
       (set-attributes obj `(screen-pos ,(id loc-dmo))))
     return-dmo))


;;; FEATLIS-TO-DMOS      [Method]
;;; Date        : 99.03.29
;;; Description : Actually, some of the features could be CHAR-PRIMITIVE
;;;             : features, in which case they're part of characters.  Save
;;;             : those out and make a character out of 'em.

(defgeneric featlis-to-dmos (vis-mod loc feat-lis)
   (:documentation  "Given a list of features, make a DMO for each."))

(defmethod featlis-to-dmos ((vis-mod vision-module) (loc vector) 
(feat-lis list))
   (let ((primitive-feats nil)
         (dmo-lis nil))
     (dolist (feat (feat-match-xy feat-lis loc))
       (setf (attended-p feat) t)
       ;; If it's a char primitive, push the feature, else push the 
feature chunk.
       (if (typep feat 'char-primitive-feature)
         (push  feat primitive-feats)
         (push (feat-to-dmo feat) dmo-lis)))
     (when primitive-feats
       (push (synthesize-letter vis-mod primitive-feats) dmo-lis))
     dmo-lis))


;;; DETERMINE-FOCUS-DMO      [Method]
;;; Date        : 99.03.29
;;; Description : Basically, look for a DMO with the same ID as the feature.
;;;             : If none, see if the DMO was synthesized from that feature.
;;;             : If none of those, return a random one.

(defgeneric determine-focus-dmo (vis-mod dmo-lst feat)
   (:documentation  "Determine which DMO corresponds to <feat>, which 
should be the 'best' feature."))

(defmethod determine-focus-dmo ((vis-mod vision-module) (dmo-lis 
list) (feat icon-feature))
   (when (= 1 (length dmo-lis))
     (return-from determine-focus-dmo (first dmo-lis)))
   (aif (member (dmo-id feat) dmo-lis :key #'id)
     (first it)
     (dolist (dmo dmo-lis (random-item dmo-lis))
       (when (member (dmo-id feat)
                     (synthed-to-features vis-mod (id dmo) nil))
         (return-from determine-focus-dmo dmo)))))


;;; GET-WORD-AT-NOOPT      [Method]
;;; Date        : 99.04.02
;;; Description : Getting a word when optimizing is off involves calling
;;;             : SYNTHESIZE-WORD method, but we need to collect the
;;;             : locations first, and also check the return if what was
;;;             : sent in was a DMO.

(defgeneric get-word-at-noopt (vis-mod loc-dmo)
   (:documentation  "Synthesize a word at the given location and synch 
it with the location."))

(defmethod get-word-at-noopt ((vis-mod vision-module) (loc-dmo dmo))
   (multiple-value-bind (locs xmin xmax)
                        (adjoining-led-locs vis-mod (dmo-to-xy loc-dmo))
     (when locs
       (let ((rtn-dmo (synthesize-word vis-mod locs
                                         (- xmax xmin) (dmo-to-xy loc-dmo))))
         (when rtn-dmo
           (set-attributes rtn-dmo `(screen-pos ,(id loc-dmo)))
           (values rtn-dmo xmin xmax))))))


(defgeneric get-word-at-noopt (vis-mod loc)
   (:documentation  "Synthesize a word at the given location."))

(defmethod get-word-at-noopt ((vis-mod vision-module) (loc vector))
   (multiple-value-bind (locs xmin xmax)  (adjoining-led-locs vis-mod loc)
     (when locs
       (let ((rtn-dmo (synthesize-word vis-mod locs
                                         (- xmax xmin) loc)))
         (when rtn-dmo
           (values rtn-dmo xmin xmax))))))


;;; GET-WORD-DMOS-NOOPT      [Method]
;;; Date        : 99.04.02
;;; Description : OK, when optimizing is off and a phrase needs to be built,
;;;             : the tricky bit is figuring out which locations you need
;;;             : to grab words from, since if you hit every x location,
;;;             : you'll generate multiple copies of each word.

(defgeneric get-word-dmos-noopt (vis-mod x-lst y)
   (:documentation  "Return a list of DMOs representing words at the 
given xlocs, with optimizing off."))

(defmethod get-word-dmos-noopt ((vis-mod vision-module) (x-ls list) y)
   (let ((rtn-dmos nil)
         (curr-x -1))
     (dolist (x x-ls (remove nil (nreverse rtn-dmos)))
       (when (> x curr-x)
         (multiple-value-bind (word min max)
                              (get-word-at-noopt vis-mod (vector x y))
           (declare (ignore min))
           (push word rtn-dmos)
           (setf curr-x max))))))


;;; GET-WORD-DMOS-OPT      [Method]
;;; Date        : 99.04.02
;;; Description : This is simpler when optimizing--just walk the xlist
;;;             : and accumulate words.
;;;             : Might be vestigial as of beta 6.

(defgeneric get-word-dmos-opt (vis-mod x-lst y)
   (:documentation  "Return a list of DMOs representing words at the 
given xlocs, with optimizing on."))

(defmethod get-word-dmos-opt ((vis-mod vision-module) (x-ls list) y)
   (let (accum)
     (dolist (x x-ls (nreverse accum))
       (dolist (feat (text-feats (feat-match-xy (visicon vis-mod) 
(vector x y))))
         (push (feat-to-dmo feat) accum)))))


;;; GET-ICON-OBJECT-AT      [Method]
;;; Date        : 97.06.01
;;; Description : Returns the DMO representing the feature(s) at a
;;;             : location.  If there are a whole bunch of the little line
;;;             : features that comprise letters, then do the categorization
;;;             : bit on the letters.

(defgeneric get-icon-object-at (vis-mod loc)
   (:documentation  "Return the chunk representing the icon feature(s) 
at the given <loc>"))

(defmethod get-icon-object-at ((vis-mod vision-module) (loc vector))
   (let ((led-feats nil)
         (dmo-lis nil)
         (return-dmo nil))
     (dolist (feat (within-move vis-mod loc))
       (setf (attended-p feat) t)
       ;; If it's an LED line, push the feature, else push the feature chunk.
       (if (eq (kind feat) 'led-line)
         (push  feat led-feats)
         (push (feat-to-dmo feat) dmo-lis)))
     (when led-feats
       (push (synthesize-letter vis-mod led-feats) dmo-lis))
     (setf return-dmo (random-item dmo-lis))
     return-dmo))


#|
;;; GET-WORD-AT      [Method]
;;; Date        : 97.06.01
;;; Description : Getting a word can be either hard or easy, depending on
;;;             : whether we're optimizing.  If we're optimizing, then the
;;;             : features are already words, so life is easy--just return
;;;             : the chunk for one of the features. If optimizing
;;;             : is off, then we have to synthesize a word from the letters.
;;;             : Vestigial in beta 6?  Not sure.

(defmethod get-word-at ((vis-mod vision-module) (loc list))
   "Return a chunk for the word at the given <loc>"
   (let ((dmo-lis nil))
     (if (optimize-p vis-mod)
       (let ((loc-feats (text-feats (within-move vis-mod loc)))
             (new-dmo nil))
         (unless (null loc-feats)
           (dolist (feat loc-feats (random-item dmo-lis))
             (setf new-dmo (feat-to-dmo feat))
             (push new-dmo dmo-lis))))
       ;; not optimizing
       (awhen (contiguous-locs loc (feat-match-y (visicon vis-mod) 
(second loc)))
         (synthesize-word vis-mod it)))))
|#


(defun text-feats (feat-lst)
   "Given a list, return only those features which are TEXT features."
   (remove-if #'(lambda (f) (not (eq (kind f) 'text))) feat-lst))


;;;; 
---------------------------------------------------------------------- 
;;;;
;;;; Finst support


(defmethod print-object ((fnst finst) strm)
   (print-unreadable-object (fnst strm :type t)
     (format strm "~S ~4,2F" (id fnst) (tstamp fnst))))


(defgeneric elapsed (object)
   (:documentation  "Return the time since this object was time-stamped."))

(defmethod elapsed ((fnst finst))
   (- (mp-time *mp*) (tstamp fnst)))


(defmethod in-finst ((name symbol) (fnst finst))
   (or (eq name (id fnst))
       (member name (synthed-from fnst))))


(defgeneric feat-attended (feat vis-mod)
   (:documentation  "Return the attended status of a visicon feature object."))

(defmethod feat-attended ((feat icon-feature) (vis-mod vision-module))
   (if (eq (attended-p feat) 'NEW)
     'NEW
     (consp (member (dmo-id feat) (finst-lst vis-mod)
                    :test #'in-finst))))


(defgeneric test-attended (spec feat)
   (:documentation  "Test a visicon feature against a spec, return T 
if they match on ATTENDED."))

(defmethod test-attended ((spec icon-feature) (feat icon-feature))
   (cond ((eq (attended-p spec) :IGNORE) t)
         ((and (null (attended-p spec)) (eq (attended-p feat) 'NEW)) t)
         (t (eq (attended-p spec)
                (feat-attended feat (vis-m *mp*))))))


(defmethod set-attended :after ((vis-mod vision-module) obj)
   (aif (member (id obj) (finst-lst vis-mod) :key #'id)
     (setf (tstamp (first it)) (mp-time *mp*))
     (push
      (make-instance 'finst :id (id obj) :tstamp (mp-time *mp*)
                     :synthed-from (synthed-to-features vis-mod (id obj) nil))
      (finst-lst vis-mod)))
   (sort-finsts vis-mod)
   (when (> (length (finst-lst vis-mod)) (num-finst vis-mod))
     (pop (finst-lst vis-mod))))


(defgeneric sort-finsts (vis-mod)
   (:documentation  "Sort finsts according to time stamp."))

(defmethod sort-finsts ((vis-mod vision-module))
   (setf (finst-lst vis-mod) (sort (finst-lst vis-mod) #'< :key #'tstamp)))


(defgeneric check-finsts (vis-mod)
   (:documentation  "Update finsts against what's on the display and sort."))

(defmethod check-finsts ((vis-mod vision-module))
   (setf (finst-lst vis-mod)
         (delete-if #'(lambda (f)
                        (or (not (object-present-p vis-mod (id f)))
                            (> (elapsed f)
                               (finst-span vis-mod))))
                    (finst-lst vis-mod)))
   (sort-finsts vis-mod))


;;;; 
---------------------------------------------------------------------- 
;;;;
;;;;  Supporting NEW tags


(defmethod elapsed ((feat icon-feature))
   (- (mp-time *mp*) (tstamp feat)))


(defgeneric checknew (feat vis-mod)
   (:documentation  "Check to see if a visicon feature is still NEW."))

(defmethod checknew ((feat icon-feature) (vis-mod vision-module))
   (when (and (eq (attended-p feat) 'NEW)
              (> (elapsed feat) (new-span vis-mod)))
     (setf (attended-p feat) nil))
   feat)





;;;; 
---------------------------------------------------------------------- 
;;;;
;;;; Synthetic features (letters, words, and phrases).
;;;; 
---------------------------------------------------------------------- 
;;;;

(defgeneric record-synth (vis-mod the-dmo &key x y width height built-from)
   (:documentation  "Record the id of a synthesized object and its 
properties."))

(defmethod record-synth ((vis-mod vision-module) (the-dmo dmo)
                            &key x y width height built-from)
   (declare (fixnum x y width height))
   (when (not (and x y width height built-from))
     (error "NIL passed to RECORD-SYNTH."))
   (setf (gethash (id the-dmo) (synthd-objs vis-mod))
         (make-instance 'synthd-feat :dmo-id (id the-dmo)
                        :built-from (mklist built-from)
                        :width width :height height
                        :x x :y y)))


;;; SYNTHED-TO-FEATURES      [Method]
;;; Description : If the ID is in the hash table of synthed IDs, then
;;;             : recurse on those.

(defgeneric synthed-to-features (vis-mod objid accum)
   (:documentation  "Given a synthetic object, return a list of icon 
features comprising it."))

(defmethod synthed-to-features ((vis-mod vision-module) objid accum)
   (aif (gethash objid (synthd-objs vis-mod))
     (flatten (mapcar #'(lambda (f) (synthed-to-features vis-mod f nil))
                      (built-from it)))
     (cons objid accum)))


;;; FEAT-OR-SYNTH      [Method]
;;; Date        : 99.04.02
;;; Description : VISUAL-OBJECTs should correspond to either real features
;;;             : or synthetic ones.  Look in both places.

(defgeneric feat-or-synth (vis-mod id)
   (:documentation  "Return the icon feature or synthetic object 
associated with <id>."))

(defmethod feat-or-synth ((vis-mod vision-module) id)
   (aif (member id (visicon vis-mod) :key #'dmo-id)
     (first it)
     (awhen (gethash id (synthd-objs vis-mod))
       it)))


;;; GET-PHRASE-AT      [Method]
;;; Date        : 98.07.27
;;; Description : The only way to get a phrase is to synthesize one, there is
;;;             : no "phrase" primitive in RPM.

(defgeneric get-phrase-at (vis-mod loc)
   (:documentation  "Mostly a stub for SYNTHESIZE-PHRASE."))

(defmethod get-phrase-at ((vis-mod vision-module) (loc vector))
   (awhen (feat-match-y (visicon vis-mod) (py loc))
     (synthesize-phrase vis-mod it (py loc))))


;;; SYNTHESIZE-LETTER      [Method]
;;; Date        : 98.07.27
;;; Description : From a list of LED-style icon features, synthesize a letter
;;;             : feature and note the synthesis.  The real worker here is
;;;             : Mike Matessa's FIND-BEST-OBJECT function, which is based on
;;;             : "rational categorization" of the features into a letter.

(defgeneric synthesize-letter (vis-mod feats)
   (:documentation  "Build a DMO representing a letter from a list of 
LED features."))

(defmethod synthesize-letter ((vis-mod vision-module) (feats list))
   (let ((base-feat (first feats))
         (letter (prob-best-character (active-cfs vis-mod)
                                       (mapcar #'true-feat feats)))
         (return-dmo nil)
         )
     (dolist (feat feats)
       (setf (attended-p feat) t))
     (setf return-dmo
           (make-dme (new-name-fct "LETTER") 'visual-object
                     `(screen-pos ,(id (current-marker vis-mod))
                                  value ,letter
                                  color black)
                     :obj (screen-obj base-feat)
                     ))
     (record-synth vis-mod return-dmo :x (screen-x base-feat)
                   :y (screen-y base-feat) :width (width base-feat)
                   :height (height base-feat)
                   :built-from (mapcar #'dmo-id feats))
     return-dmo))


;;; SYNTHESIZE-WORD      [Method]
;;; Date        : 98.07.27
;;; Description : Given the list of contiguous locations, get the letter
;;;             : at each location, and then build the word from the list
;;;             : of letters.

(defgeneric synthesize-word (vis-mod loc-lis width center)
   (:documentation  "Build a DMO representing a word from a location."))

(defmethod synthesize-word ((vis-mod vision-module) (loc-lis list)
                                (width number) (center vector))
   (let ((return-dmo nil)
         (letter-dmos nil))
     (dolist (xloc loc-lis)
       (push (synthesize-letter vis-mod (feat-match-xy (visicon vis-mod) xloc))
             letter-dmos)
       (when (not (stringp (get-attribute (first letter-dmos) 'value)))
         (pop letter-dmos)))
     (when letter-dmos
       (setf letter-dmos (nreverse letter-dmos))
       (setf return-dmo
             (make-dme (new-name-fct "WORD") 'TEXT
                       `(screen-pos ,(id (current-marker vis-mod))
                                    value ,(word-accum
                                            (mapcar #'(lambda (x) 
(get-attribute x 'value))
                                                    letter-dmos)))))
       (record-synth vis-mod return-dmo :x (px center) :y (py center)
                     :width width
                     :height
                     (height (feat-or-synth vis-mod (id (first letter-dmos))))
                     :built-from (mapcar #'id letter-dmos))
       return-dmo)))


;;; GET-PHRASE-AT      [Method]
;;; Date        : 98.07.27
;;; Description : The only way to get a phrase is to synthesize one, there is
;;;             : no "phrase" primitive in RPM.

(defgeneric get-phrase-at (vis-mod loc)
   (:documentation  "Mostly a stub for SYNTHESIZE-PHRASE."))

(defmethod get-phrase-at ((vis-mod vision-module) (loc vector))
   (awhen (feat-match-y (visicon vis-mod) (py loc))
     (synthesize-phrase vis-mod it loc)))


(defgeneric synthesize-phrase (vis-mod feature-locs loc)
   (:documentation  "Build a DMO representing a phrase."))

(defmethod synthesize-phrase ((vis-mod vision-module) (feature-locs list)
                                  (loc vector))
   (let ((x-locs (mapcar #'screen-x feature-locs))
         (word-dmos nil)
         (words nil)
         (return-dmo nil))
     (setf x-locs (sort (remove-duplicates x-locs) #'<))
     (if (optimize-p vis-mod)
       (setf word-dmos (get-word-dmos-opt vis-mod x-locs (py loc)))
       (setf word-dmos (get-word-dmos-noopt vis-mod x-locs (py loc))))
     ;(setf word-lis (nreverse word-lis))
     (when word-dmos
       (setf words (mapcar #'(lambda (x)
                               (get-attribute x 'value)) word-dmos))
       (setf word-dmos (mapcar #'id word-dmos))
       (setf return-dmo
             (make-dme (new-name-fct "PHRASE") 'phrase!
                       `(screen-pos
                         ,(id (current-marker vis-mod))
                         objects ,word-dmos
                         words ,words
                         color black
                         value ,(phrase-accum words))))
       (record-synth vis-mod return-dmo :x (px loc) :y (py loc)
                     :width
                     (reduce #'+
                             (mapcar #'(lambda (s)
                                         (width (feat-or-synth vis-mod s)))
                                     word-dmos))
                     :height
                     (height (feat-or-synth vis-mod (first word-dmos)))
                     :built-from word-dmos)
       return-dmo)))



;;;; 
---------------------------------------------------------------------- 
;;;;
;;;; Stuff for supporting other modules (mostly motor).
;;;; 
---------------------------------------------------------------------- 
;;;;

;;; UPDATE-ATTEDED-LOC      [Method]
;;; Date        : 97.06.01
;;; Description : What is at the focus of visual attention can change.
;;;             : If this might be happening, call this after PM-PROC-SCREEN
;;;             : to make sure the attended location is updated.
;;;             : UNLESS clause added 98.07.17

(defgeneric update-attended-loc (vis-mod)
   (:documentation  "Update whatever is at the attended location"))

(defmethod update-attended-loc ((vis-mod vision-module))
   (when (and (current-marker vis-mod)
              (currently-attended vis-mod)
              (null (tracked-obj vis-mod))
              (not (moving-attention vis-mod))
              (eq 'FREE (exec-s vis-mod))
              )
     (unless (and (currently-attended vis-mod)
                  (object-present-p vis-mod (id (currently-attended vis-mod))))
       (queue-command
        :time (move-attn-latency vis-mod)
        :where :VISION
        :command 'focus-on
        :randomize t
        :params `(,(current-marker vis-mod) ,(last-scale vis-mod)))
       (change-state vis-mod :exec 'busy))))



;;; OBJECT-PRESENT-P      [Method]
;;; Description : A visual object is present if its ID is still in the icon
;;;             : or if all the features from which it was synthesized are
;;;             : still in the icon.

(defgeneric object-present-p (vis-mod obj-id)
   (:documentation  "Returns NIL if the object ID passed to it is no 
longer in the icon."))

(defmethod object-present-p ((vis-mod vision-module) obj-id)
   (if (member obj-id (visicon vis-mod) :key #'dmo-id)
     t
     (let ((synthed (gethash obj-id (synthd-objs vis-mod))))
       (when synthed
         (dolist (obj (built-from synthed) t)
           (unless (object-present-p vis-mod obj)
             (return-from object-present-p nil)))))))


;;; LOC-TO-FEAT      [Method]
;;; Date        : 99.04.02
;;; Description : Since each location has associated with it the feature
;;;             : and the spec used to generate that location, it's possible
;;;             : to do a "best match" here vs. the current icon.  If there
;;;             : isn't a best match, then return a dummy feature which will
;;;             : generate the default width.

(defgeneric loc-to-feat (vis-mod loc)
   (:documentation  "Given a location DMO, return the corresponding 
icon feature."))

(defmethod loc-to-feat ((vis-mod vision-module) (loc dmo))
   (aif (find-best-feature (visicon vis-mod)
                           (gethash (id loc) (found-locs vis-mod)))
     it
     (make-instance 'dummy-feature :xy-loc (dmo-to-xy loc))))


;;; OBJ-TO-FEAT      [Method]
;;; Date        : 99.04.02
;;; Description : Visual objects should be associated with either real or
;;;             : synthetic features.  If neither of those can be found, at
;;;             : least the location of the object is known, so we can try
;;;             : to find something based on that.

(defgeneric obj-to-feat (vis-mod obj)
   (:documentation  "Given a visual object DMO, return the 
corresponding icon feature."))

(defmethod obj-to-feat ((vis-mod vision-module) (obj dmo))
   (aif (feat-or-synth vis-mod (id obj))
     it
     (loc-to-feat vis-mod (psdme-to-dmo (get-attribute obj 'screen-pos)))))



;;;; 
---------------------------------------------------------------------- 
;;;;
;;;; Finding locations.
;;;; 
---------------------------------------------------------------------- 
;;;;



;;; FIND-BEST-FEATURE      [Method]
;;; Date        : 99.03.29
;;; Description : The "best" feature is the one with the same ID as the spec.
;;;             : The next best feature is one that matches the spec and is
;;;             : nearest to that location.  Failing any matches to the spec,
;;;             : then return the nearest feature.

(defgeneric find-best-feature (feat-lst fs)
   (:documentation  "Given a list of features and a spec, return the 
'best' feature."))

(defmethod find-best-feature ((feat-lis list) (fs found-spec))
   (awhen (member (dmo-id (feat fs)) feat-lis :key #'dmo-id)
     (return-from find-best-feature (first it)))
   (let ((matches (matching-feats (spec fs) feat-lis)))
     (if matches
       (random-item (nearest-feat matches (xy-loc (feat fs))))
       (random-item (nearest-feat feat-lis (xy-loc (feat fs)))))))


;;; FIND-BEST-FEATURE      [Method]
;;; Date        : 99.03.29
;;; Description : When the spec is null, return a random feature.

(defgeneric find-best-feature (feat-lst fs)
   (:documentation  "Given a list of features and a spec, return the 
'best' feature."))

(defmethod find-best-feature ((feat-lis list) (fs null))
   (declare (ignore fs))
   (random-item feat-lis))


;;; FIND-LOCATION      [Method]
;;; Date        : 98.08.11R (rewrite), delta 99.06.24
;;; Description : To find a location, we need to search the icon.  To do this,
;;;             : construct a feature spec based on the parameters passed,
;;;             : and filter the list to those that match the spec.  This
;;;             : should be faster for large icons because it makes only
;;;             : one pass over the icon.  Regardless, some
;;;             : post-processing of that list might be necessary if LOWEST
;;;             : or HIGHEST was passed as a coordinate or if NEAREST is
;;;             : true.
;;;             : Once we have a list, randomly pick one (that may change in
;;;             : the future) feature and build a location out of it.

(defgeneric find-location (vis-mod &key kind attended value color
                                        size screen-x screen-y nearest)
   (:documentation  "Given a set of constraints, build a DMO for that 
screen location if one matches."))


(defmethod find-location ((vis-mod vision-module)
                              &key (kind :IGNORE) (attended :IGNORE)
                              (value :IGNORE) (color :IGNORE) (size :IGNORE)
                              screen-x screen-y nearest)

   (let ((spec (construct-findloc-spec :kind kind :attended attended 
:value value
                                  :color color :size size :screen-x screen-x
                                  :screen-y screen-y :nearest nearest)))
   (awhen (find-current-locs-with-spec vis-mod spec)
     (construct-location vis-mod
                         (random-item (objs-max-slotval it 'tstamp))
                         spec))))


(defun construct-findloc-spec (&key (kind :IGNORE) (attended :IGNORE)
                                         (value :IGNORE) (color :IGNORE)
                                         (size :IGNORE)
                                         screen-x screen-y nearest)
   (make-instance 'feature-spec
     :attended-p attended  :value value  :kind kind  :size size
     :color color :nearest nearest
     :x (if (null screen-x) :IGNORE screen-x)
     :y (if (null screen-y) :IGNORE screen-y)))


(defmethod find-current-locs-with-spec ((vis-mod vision-module)
                                              (base-spec feature-spec))
   (let ((feat-lst nil)
         (temp-spec (copy-instance base-spec)))
     (when (or (member (screen-x temp-spec)
                       '(greater-than-current less-than-current 
current lowest highest))
               (member (screen-y temp-spec)
                       '(greater-than-current less-than-current 
current lowest highest)))
       (setf temp-spec (remap-spec-to-current vis-mod temp-spec)))
     (setf (nearest temp-spec) :IGNORE)
     ;; do the actual search
     (setf feat-lst (objs-match-spec (visicon vis-mod) temp-spec))
     ;; some filtering--there's an ordering issue here!
     (case (screen-x base-spec)
       (lowest (setf feat-lst (objs-min-slotval feat-lst 'screen-x)))
       (highest (setf feat-lst (objs-max-slotval feat-lst 'screen-x))))
     (case (screen-y base-spec)
       (lowest (setf feat-lst (objs-min-slotval feat-lst 'screen-y)))
       (highest (setf feat-lst (objs-max-slotval feat-lst 'screen-y))))
     ;; handle the NEAREST flag
     (when (and (nearest base-spec) feat-lst)
       (if (eq (nearest base-spec) 'CURRENT)
         (setf feat-lst (nearest-feat feat-lst (current-lof vis-mod)))
         (setf feat-lst (nearest-feat feat-lst
                                      (dmo-to-xy
                                       (psdme-to-dmo
                                        (get-safe-wme (nearest base-spec))))))))
     feat-lst)
   )


(defmethod remap-spec-to-current ((vis-mod vision-module)
                                       (spec feature-spec))
   (let ((current-loc (current-lof vis-mod)))
     (setf (screen-x spec)
           (case (screen-x spec)
             (greater-than-current (greater-than (px current-loc)))
             (less-than-current (less-than (px current-loc)))
             (current (px current-loc))
             (lowest :IGNORE)
             (highest :IGNORE)
             (otherwise (screen-x spec))))
     (setf (screen-y spec)
           (case (screen-y spec)
             (greater-than-current (greater-than (py current-loc)))
             (less-than-current (less-than (py current-loc)))
             (current (py current-loc))
             (lowest :IGNORE)
             (highest :IGNORE)
             (otherwise (screen-y spec))))
     spec))






;;;; 
---------------------------------------------------------------------- 
;;;;
;;;;  Tracking stuff
;;;; 
---------------------------------------------------------------------- 
;;;;

;;; START-TRACKING      [Method]
;;; Date        : 97.05.15
;;; Description : Starting tracking is pretty easy, actually.  The target
;;;             : object needs to be found and installed in the relevant
;;;             : slots, and the ACT hook functions need to be set.

(defgeneric start-tracking (vis-mod obj-psdme)
   (:documentation  "Begin tracking an object"))

(defmethod start-tracking ((vis-mod vision-module) obj-psdme)
   (when (not (eql obj-psdme (id (currently-attended vis-mod))))
     (error "Request to track object ~S that is not currently being 
attended (~S)."
            obj-psdme (id (currently-attended vis-mod))))
   (change-state vis-mod :exec 'BUSY)
   (setf (input-q vis-mod) nil)
   (let ((target (pm-obj (currently-attended vis-mod))))
     (setf (tracked-obj vis-mod) target)
     (setf (tracked-obj-lastloc vis-mod) (view-loc target))
     (set-clof vis-mod (view-loc target))
     target))


;;; UPDATE-TRACKING-MTH      [Method]
;;; Date        : 97.05.15
;;; Description : Updating is kind of a pain.  First, if the tracked object
;;;             : hasn't moved, then do nothing.  If it has moved, however,
;;;             : there's a lot of bookkeeping to be done:
;;;             : [1] The old location need to have its object stripped and
;;;             : removed as an activation source.
;;;             : [2] The new location needs to be created, added to the
;;;             : attention focus, and have its OBJECTS slot set.
;;;             : [3] The object chunk needs to have its location changed.

(defgeneric update-tracking-mth (vis-mod)
   (:documentation  "Update the state of a tracked object"))

(defmethod update-tracking-mth ((vis-mod vision-module))
   (let ((oldloc-xy (tracked-obj-lastloc vis-mod))
         (newloc-xy (view-loc (tracked-obj vis-mod))))
     (when (not (equal newloc-xy oldloc-xy))
       (setf (tracked-obj-lastloc vis-mod) newloc-xy)
       (let (;(old-loc-dmo (current-marker vis-mod))
             (new-loc-dmo (xy-to-dmo newloc-xy t))
             (obj-dmo (currently-attended vis-mod)))
         ;(clear-loc old-loc-dmo)
         (set-attributes obj-dmo `(screen-pos ,(id new-loc-dmo)))
         (setf (current-marker vis-mod) new-loc-dmo)))))



;;; REMOVE-TRACKING      [Method]
;;; Date        : 97.05.15
;;; Description : When tracking stops, the slots for tracked objects need to
;;;             : to be cleared, and the ACT hook functions need to be cleared.

(defgeneric remove-tracking (vis-mod)
   (:documentation  "Clears out all the tracking stuff"))

(defmethod remove-tracking ((vis-mod vision-module))
   (setf (tracked-obj vis-mod) nil)
   (awhen (tracked-obj-lastloc vis-mod)
     (set-clof vis-mod it))
   (setf (tracked-obj-lastloc vis-mod) nil))


;;; PM-UPDATE-TRACKING      [Function]
;;; Date        : 97.05.15
;;; Description : To be called by the hook functions.

(defun pm-update-tracking (x)
   "Call the Vision Module's tracking update method."
   (declare (ignore x))
   (update-tracking-mth (vis-m *mp*)))



(defgeneric view-loc (view)
   (:documentation  "Return the location of the center of <view> as #(x y)."))

(defmethod view-loc (x)
   (declare (ignore x))
   (error "No method defined for VIEW-LOC."))


;;;; 
---------------------------------------------------------------------- 
;;;;
;;;; Icon Feature class and its children
;;;; 
---------------------------------------------------------------------- 
;;;;



(defgeneric print-icon-feature (feat)
   (:documentation  "Print out an ASCII representation of the icon."))

(defmethod print-icon-feature ((feat icon-feature))
   (format t "~%(~3D ~3D)  kind: ~A~Catt: ~3A~Cvalue: ~A~Cname: ~A"
           (screen-x feat) (screen-y feat) (kind feat) #\Tab
           (feat-attended feat (vis-m *mp*)) #\Tab (val feat)
           #\Tab (dmo-id feat)))


(defmethod print-object ((feat icon-feature) stream)
   (print-unreadable-object (feat stream :type t)
     (princ (dmo-id feat) stream)))



(defgeneric enter-into-visicon (feat time)
   (:documentation  "Enter at icon feature into the visicon at the 
time specified."))

(defmethod enter-into-visicon ((feat icon-feature) (time number))
   (unless (dmo-id feat)
     (setf (dmo-id feat) (new-name-fct (kind feat))))
   (setf (tstamp feat) time)
   feat)



;;; XY-LOC      [Method]
;;; Date        : 97.02.09
;;; Description : Return the location of a feature as a list.

(defgeneric xy-loc (feat)
   (:documentation  "Return the XY location of a feature as a vector."))

(defmethod xy-loc ((feat icon-feature))
   (vector (screen-x feat) (screen-y feat)))


;;; FEAT-TO-DMO      [Method]
;;; Date        : 98.05.28
;;; Description : From an icon feature, create a chunk.

(defgeneric feat-to-dmo (feat)
   (:documentation  "Build a chunk for an icon feature"))

(defmethod feat-to-dmo ((feat icon-feature))
   (setf (attended-p feat) t)
   (make-dme (dmo-id feat) (kind feat)
             `(screen-pos ,(id (xy-to-dmo (xy-loc feat) t))
                          value ,(val feat)
                          color ,(color feat))
             :obj (screen-obj feat)
             :where :external))

(defmethod feat-to-dmo :around ((feat cursor-feature))
   (let ((the-dmo (call-next-method)))
     (setf (pm-obj the-dmo) :cursor)
     the-dmo))


;;; COORDINATE-FEAT-LOC      [Method]
;;; Date        : 97.03.03
;;; Description : When a location is to correspond to a feature, make sure
;;;             : the ATTENDED slot matches.

(defgeneric coordinate-feat-loc (found-feat found-loc)
   (:documentation  "Matches up a feature and a location"))

(defmethod coordinate-feat-loc ((found-feat icon-feature) (found-loc dmo))
   (set-attributes found-loc `(attended ,(attended-p found-feat)
                                        kind ,(kind found-feat))))


(defgeneric feat-named (vis-mod id)
   (:documentation  "Returns the icon feature with the given <id>, if any."))

(defmethod feat-named ((vis-mod vision-module) id)
   (first (member id (visicon vis-mod) :key #'dmo-id)))



;;;; 
---------------------------------------------------------------------- 
;;;;
;;;;  Feature specifications, used to find features in the icon
;;;; 
---------------------------------------------------------------------- 
;;;;



;;; MATCH-SPEC-P      [Method]
;;; Date        : 98.08.11
;;; Description : Determining a match is based on testing for attribute
;;;             : matches or, in the case of coordinates, acceptable
;;;             : values.  So, check everything and return NIL on the
;;;             : first failure.  If nothing fails to match, return T.

(defgeneric match-spec-p (spec feat)
   (:documentation  "Returns T when <spec> and <feat> match."))

(defmethod match-spec-p ((spec icon-feature) (feat icon-feature))
   (cond ((not (test-attended spec feat)) nil)
         ;((not (attr-exact-match-p spec feat 'attended-p)) nil)
         ((not (attr-exact-match-p spec feat 'kind)) nil)
         ((not (attr-exact-match-p spec feat 'val)) nil)
         ((not (attr-exact-match-p spec feat 'color)) nil)
         ((and (numberp (size spec))
               (not (attr-exact-match-p spec feat 'size))) nil)
         ((and (numberp (screen-x spec))
               (not (attr-exact-match-p spec feat 'screen-x))) nil)
         ((and (numberp (screen-y spec))
               (not (attr-exact-match-p spec feat 'screen-y))) nil)
         ((and (functionp (size spec))
               (not (funcall (size spec) (size feat)))) nil)
         ((and (functionp (screen-x spec))
               (not (funcall (screen-x spec) (screen-x feat)))) nil)
         ((and (functionp (screen-y spec))
               (not (funcall (screen-y spec) (screen-y feat)))) nil)
         (t t)))


(defgeneric matching-feats (spec feat-lst)
   (:documentation  "Return a list of features matching a given feature spec."))

(defmethod matching-feats ((spec feature-spec) (feat-lis list))
   (remove-if-not #'(lambda (f) (match-spec-p spec f)) feat-lis))


;;; ATTR-EXACT-MATCH-P      [Method]
;;; Date        : 98.08.11
;;; Description : If the spec says to ignore that attribute, then return T
;;;             : becuase everything matches a don't care.  Otherwise, the
;;;             : spec and the feature values must be equal.

(defgeneric attr-exact-match-p (spec feat slotname)
   (:documentation  "Returns T when <spec> and <feat> match on 
attribute <slotname> (or if <spec> says :IGNORE)."))

(defmethod attr-exact-match-p ((spec icon-feature) (feat 
icon-feature) slotname)
   (cond ((eq (slot-value spec slotname) :IGNORE) T)
         ((equal (slot-value spec slotname) (slot-value feat slotname)))))


;;; SLOT-MATCH-P      [Method]
;;; Date        : 01.07.27
;;; Description : One should not be able to test TEXT features for their
;;;             : value, so this specializer should short-circuit that.

(defmethod slot-match-p ((ts spec) (obj text-feature)
                            (slotname (eql 'value)))
   t)


;;;; 
---------------------------------------------------------------------- 
;;;;
;;;;  Messing with features:  Doing icon checking, finding, and listing.
;;;; 
---------------------------------------------------------------------- 
;;;;

;;; APPROACH-WIDTH      [Method]
;;; Date        : 99.03.30
;;; Description : Remember in high school when someone asked in trig why we
;;;             : needed to know this crap?  Well, this is why.  I'm pretty
;;;             : sure this is all the right trig, but there could be some
;;;             : missed math in here.

(defmethod approach-width ((feat icon-feature) (theta number))
   (let* ((x (width feat))
          (y (height feat))
          (critical-theta (atan y x))
          (theta (abs theta))
          (ret-width nil))
     (when (> theta (/ pi 2))
       (setf theta (- pi theta)))
     (setf ret-width
           (cond ((= theta 0) x)
                 ((= theta (/ pi 2)) y)
                 ((= theta critical-theta) (sqrt (+ (* y y) (* x x))))
                 ((< theta critical-theta) (/ x (cos theta)))
                 (t (/ y (cos (- (/ pi 2) theta))))))
     (pm-pixels-to-angle ret-width)))


(defgeneric simple-size (feat)
   (:documentation  "If there are values for the height and width, 
convert to visual angle and multiply."))

(defmethod simple-size ((feat icon-feature))
   (when (and (width feat) (height feat))
     (* (pm-pixels-to-angle (width feat))
        (pm-pixels-to-angle (height feat)))))


;;; CONSTRUCT-LOCATION      [Method]
;;; Date        : 98.08.11, last delta 99.06.18
;;; Description : Building a location is pretty easy--if one exists already,
;;;             : use that.  If not, make one.  Note the commented out part
;;;             : may get used later--the idea is to store the feature and
;;;             : the spec used to find a given location, so that if attention
;;;             : is moved to that location and the feature moves a little
;;;             : bit, that same feature can be found.  And if that feature is
;;;             : gone, we can look for a new match to the spec.

(defgeneric construct-location (vis-mod feat spec)
   (:documentation  "Find or build a DMO based on a feature and the 
spec used to generate that feature."))

(defmethod construct-location ((vis-mod vision-module) (feat icon-feature)
                                   (spec icon-feature))
   (let ((loc-dmo (find-loc-dmo (xy-loc feat))))
     (if loc-dmo
       (coordinate-feat-loc feat loc-dmo)
       (setf loc-dmo (xy-to-dmo (xy-loc feat) nil)))
     ;; added set-attributes to synch this up right 99.06.18
     (set-attributes loc-dmo `(color ,(color feat) kind ,(kind feat)
                                     value ,(val feat)))
     (when *debug*
       (format t "~%Constructing location ~S" (id loc-dmo)))
     (setf (gethash (id loc-dmo) (found-locs vis-mod))
           (make-instance 'found-spec :feat feat :spec spec))
     (dmo-to-psdme loc-dmo)))


;;; CHECK-FEAT      [Method]
;;; Date        : 97.06.18
;;; Description : When features persist across calls to PROC-SCREEN, sometimes
;;;             : features that had been attended get wiped.  Use of this
;;;             : function can check for that.
;;;             : Setting DMO-ID added 98.07.17
;;;             : Wiping old feature (needed with optimizing off) added
;;;             : on 98.07.29.
;;;             : [mdb 00.06.12] Set the timestamp rather than the
;;;             : attended slot.

(defgeneric check-feat (feat vis-mod)
   (:documentation  "Checks a feature against the old icon, possibly 
setting the ATTENDED slot."))

(defmethod check-feat ((feat icon-feature) (vis-mod vision-module))
   (declare (optimize speed))
   (awhen (member feat (old-visicon vis-mod) :test #'feat=)
     (setf (tstamp feat) (tstamp (first it)))
     (unintern (dmo-id feat))
     (setf (dmo-id feat) (dmo-id (first it)))
     (setf (old-visicon vis-mod)
           (delete (first it) (old-visicon vis-mod)
                   :test (lambda (x y) (eq (dmo-id x) (dmo-id y))))))
   (checknew feat vis-mod))


;;; FEAT=      [Method]
;;; Description : Two features are equal if their non-ID attributes are
;;;             : all equal.

(defgeneric feat= (feat1 feat2)
   (:documentation  "Compares two icon features to determine if 
they're functionally equal."))

(defmethod feat= ((feat1 icon-feature) (feat2 icon-feature))
   (declare (optimize (speed 3)))
   (cond ((neq (type-of feat1) (type-of feat2)) nil)
         ((not (= (screen-x feat1) (screen-x feat2))) nil)
         ((not (= (screen-y feat1) (screen-y feat2))) nil)
         ((not (equal (width feat1) (width feat2))) nil)
         ((not (equal (height feat1) (height feat2))) nil)
         ((neq (kind feat1) (kind feat2)) nil)
         ((not (equal (val feat1) (val feat2))) nil)
         ((neq (color feat1) (color feat2)) nil)
         (t (typed-feat= feat1 feat2))))

(defgeneric typed-feat= (feat1 feat2)
   (:documentation  "Very specific comparison of special properties of 
icon features.  T is returned if equal."))

;; need one for line features
(defmethod typed-feat= ((feat1 line-feature) (feat2 line-feature))
   (declare (optimize (speed 3)))
   (cond ((not (= (end1-x feat1) (end1-x feat2))) nil)
         ((not (= (end1-y feat1) (end1-y feat2))) nil)
         ((not (= (end2-y feat1) (end2-y feat2))) nil)
         ((not (= (end2-x feat1) (end2-x feat2))) nil)
         (t t)))

;; with no other info, assume they're equal
(defmethod typed-feat= ((feat1 icon-feature) (feat2 icon-feature))
   t)


(defun feature-locs (feat-lst)
   "Given a list of features, return a list of unique feature locations."
   (declare (list feat-lst))
   (remove-duplicates (mapcar #'xy-loc feat-lst) :test #'equal))


(defun feat-max-x (feat-lst)
   "Returns list of features with maximum x value"
   (declare (list feat-lst))
   (objs-max-slotval feat-lst 'screen-x))


(defun feat-min-x (feat-lst)
   "Returns list of features with minimum x value"
   (declare (list feat-lst))
   (objs-min-slotval feat-lst 'screen-x))


(defun feat-max-y (feat-lst)
   "Returns list of features with maximum y value"
   (declare (list feat-lst))
   (objs-max-slotval feat-lst 'screen-y))


(defun feat-min-y (feat-lst)
   "Returns list of features with minimum y value"
   (declare (list feat-lst))
   (objs-min-slotval feat-lst 'screen-y))


(defun feat-match-x (feat-lst x)
   "Returns features that match a given x value"
   (declare (list feat-lst) (fixnum x))
   (objs-match-slotval feat-lst 'screen-x x))


(defun feat-match-y (feat-lst y)
   "Returns features that match a given y value"
   (declare (list feat-lst) (fixnum y))
   (objs-match-slotval feat-lst 'screen-y y))


(defgeneric feat-match-xy (feat-lst loc)
   (:documentation  "Returns the the subset of the list that match the 
XY location."))

(defmethod feat-match-xy ((feat-lst list) (loc vector))
   (let ((outlis nil))
     (dolist (feat feat-lst outlis)
       (if (and (= (screen-x feat) (px loc))
                (= (screen-y feat) (py loc)))
         (push feat outlis)))))


(defun nearest-feat (feat-list loc)
   "Returns list of features nearest to a given location"
   (declare (list feat-lis))
   (unless (vectorp loc)
     (setf loc (dmo-to-xy loc)))
   (when feat-list
     (let ((best (dist (xy-loc (first feat-list)) loc))
           (outlis (list (first feat-list)))
           (the-dist nil))
       (dolist (feat (rest feat-list) outlis)
         (setf the-dist (dist (xy-loc feat) loc))
         (cond ((= the-dist best) (push feat outlis))
               ((< the-dist best) (setf best the-dist)
                (setf outlis (list feat))))))))



;;; DELETE-FEATURES      [Method]
;;; Date        : 97.02.27
;;; Description : Removes features from the icon.  If the scale is SCREEN,
;;;             : then remove all features.  If the scale is WORD, then
;;;             : find the contiguous locations and remove all features at
;;;             : those locations.  Otherwise just remove all features at
;;;             : the specified location.

(defgeneric delete-features (vis-mod loc scale)
   (:documentation  "Removes features at a specified location"))

(defmethod delete-features ((vis-mod vision-module) loc scale)
   (declare (symbol loc))
   (case scale
     (screen (setf (visicon vis-mod) nil))
     (word
      (let ((feat-lis (visicon vis-mod))
            (loc-lis (contiguous-locs loc (feat-match-y (visicon vis-mod)
                                                          (py loc)))))
        (dolist (the-loc loc-lis)
          (setf feat-lis
                (remove-if #'(lambda (feat)
                               (equal the-loc (xy-loc feat)))
                           feat-lis)))
        (setf (visicon vis-mod) feat-lis)))
     (otherwise
      (setf (visicon vis-mod)
            (remove-if #'(lambda (feat) (equal loc (xy-loc feat)))
                       (visicon vis-mod))))))



;;; BUILD-STRING-FEATS      [Method]
;;; Date        : 99.03.30
;;; Description : In order to build all the features for a string, there is a
;;;             : great deal of stuff that is needed from the interface beyond
;;;             : just the string itself.  Need to know the y coordinate, the
;;;             : starting x coordinate, the line height, the associated
;;;             : screen object, and some way of determining the width (in
;;;             : pixels) of a string.
;;;             :
;;;             : There are two ways to do it, with and without optimizing.
;;;             : With optimizing it's easy, just accumulate words.  When
;;;             : optimzing is off, though, have to walk the string
;;;             : character-by-character and build features for each one.

(defgeneric build-string-feats (vis-mod &key text start-x y-pos
                                       width-fct height obj)
   (:documentation  "Build a list of ICON-FEATURES representing a 
string with the given geometry."))

(defmethod build-string-feats ((vis-mod vision-module) &key text start-x
                               y-pos width-fct height obj)
   (declare (fixnum start-x y-pos)  (function width-fct) (string text)
            (number height))
   (when (not (and text start-x y-pos width-fct height))
     (error "NIL passed to BUILD-STRING-FEATS."))
   (unless (equal text "")
     (let ((curr-x start-x)
           (f-accum nil)
           (spc-wdth (funcall width-fct " "))
           (curr-width nil))
       (if (optimize-p vis-mod)
         ;; if optimizing is on, then carve the string into words (strings)
         ;; and space runs (numbers)
         (dolist (word (chop-string text) (nreverse f-accum))
           (when (stringp word)
             (setf curr-width (funcall width-fct word))
             (push (make-instance 'text-feature
                     :y y-pos :screen-obj obj :height height
                     :value (string-downcase word)
                     :width curr-width
                     :x (+ curr-x (round curr-width 2))) f-accum))
           (incf curr-x (if (stringp word) curr-width (* word spc-wdth))))
         ;; if not optimizing, then blast it character-by-character
         (let ((char nil))
           (dotimes (idx (length text) (nreverse (flatten f-accum)))
             (setf char (char text idx))
             (setf curr-width (funcall width-fct (subseq text idx (1+ idx))))
             (cond ((alphanumericp char)
                    (push (char-to-features vis-mod (char-upcase char)
                                            curr-x
                                            (- (+ curr-x curr-width) 1)
                                            y-pos
                                            height obj) f-accum))
                   ((and (graphic-char-p char)
                         (not (char-equal char #\space)))
                    (push (make-instance 'text-feature
                            :y y-pos :screen-obj obj :height height
                            :value (mkstr char)
                            :width curr-width
                            :x (+ curr-x (round curr-width 2))) f-accum))
                   (t nil))
             (incf curr-x curr-width)))))))


;;;; 
---------------------------------------------------------------------- 
;;;;
;;;;  Those wacky LED features for letters.
;;;; 
---------------------------------------------------------------------- 
;;;;

;;; CHAR-TO-FEATURES      [Method]
;;; Date        : 99.03.30
;;; Description : For each character, there will usually be many of those
;;;             : CHAR-PRIMITIVE features.  Grab the list of features
;;;             : associated with a character, and build 'em.

(defgeneric char-to-features (vis-mod char left right y height obj)
   (:documentation  "Returns a list of basic icon-feature objects for 
a characer"))

(defmethod char-to-features ((vis-mod vision-module) (char character)
                                 (left number) (right number) (y number)
                                 (height number) obj)
   (let ((xpos (+ left (round (- right left) 2)))
         (width (1+ (- right left)))
         (features (pairlis
                      (getfeats (active-cfs vis-mod) char)
                      (get-icon-feats (active-cfs vis-mod) char)))
         (accum nil))
     (dolist (feats features accum)
       (push (make-instance 'char-primitive-feature
               :x xpos :y y :width width :height height
               :left left :right right :screen-obj obj
               :true-feat (first feats) :value (rest feats))
             accum))))


;;; ADJOINING-LED-LOCS      [Method]
;;; Date        : 99.04.02
;;; Description : To synthesize a word, we need to know which locations have
;;;             : LED-LINE features at adjoining locations.  However,
;;;             : because letter width is variable, the icon has to be
;;;             : searched for LED-LINE locations that have features that
;;;             : are near the boundaries.  Also, because we need to know the
;;;             : width of the word, return the min and max x values, too.

(defgeneric adjoining-led-locs (vis-mod loc)
   (:documentation  "Return a list of locations adjoining <loc>, as 
well as the max and min x locs."))

(defmethod adjoining-led-locs ((vis-mod vision-module) (loc vector))
   (let ((feat-ls (feat-match-xy (visicon vis-mod) loc))
         (feat nil))
     (while (and (null feat) feat-ls)
       (setf feat (pop feat-ls))
       (unless (typep feat 'char-primitive-feature)
         (setf feat nil)))
     (when feat
       (setf feat-ls (feat-match-y (visicon vis-mod) (screen-y feat)))
       (multiple-value-bind
         (lowlocs xmin) (left-adjoining-led-locs feat-ls (left-edge feat) nil)
         (multiple-value-bind
           (hilocs xmax) (right-adjoining-led-locs feat-ls (right-edge 
feat) nil)
           (values
            (append lowlocs (list loc) hilocs)
            xmin xmax))))))


;;; RIGHT-ADJOINING-LED-LOCS      [Method]
;;; Date        : 99.04.02
;;; Description : Recursively go right and accumulate locations that share
;;;             : the boundary.

(defgeneric right-adjoining-led-locs (feat-ls x accum)
   (:documentation  "Return a list of all the right-adjoining locs 
with led features and the min x."))

(defmethod right-adjoining-led-locs ((feat-ls list) x accum)
   (dolist (feat feat-ls)
     (when (typep feat 'char-primitive-feature)
       (when (> 1.5 (abs (- (left-edge feat) x)))
         (return-from right-adjoining-led-locs
           (right-adjoining-led-locs feat-ls (right-edge feat)
                                     (append accum (list (xy-loc feat))))))))
   (values accum x))


;;; LEFT-ADJOINING-LED-LOCS      [Method]
;;; Date        : 99.04.02
;;; Description : Recursively go left and accumulate locations that share
;;;             : the boundary.

(defgeneric left-adjoining-led-locs (feat-ls x accum)
   (:documentation  "Return a list of all the left-adjoining locs with 
led features and the max x."))

(defmethod left-adjoining-led-locs ((feat-ls list) x accum)
   (dolist (feat feat-ls)
     (when (typep feat 'char-primitive-feature)
       (when (> 1.5 (abs (- (right-edge feat) x)))
         (return-from left-adjoining-led-locs
           (left-adjoining-led-locs feat-ls (left-edge feat)
                                    (append (list (xy-loc feat)) accum))))))
   (values accum x))


;;;; 
---------------------------------------------------------------------- 
;;;;
;;;; Misc utils
;;;;

(defgeneric set-clof (vis-mod new-lof)
   (:documentation "Updates vision module's current location of focus."))

(defmethod set-clof ((vis-mod vision-module) (new-lof vector))
   (setf (current-lof vis-mod) new-lof)
   (when (trace-attn-p vis-mod)
     (push (cons (pm-time) new-lof) (attn-trace vis-mod))))




;;; non-MCL lisps don't define COPY-INSTANCE, so we need one just for
;;; feature-spec types.

#-mcl
(defmethod copy-instance ((spec feature-spec))
   (make-instance 'feature-spec
     :x (screen-x spec) :y (screen-y spec) :nearest (nearest spec)
     :attended-p (attended-p spec) :value (val spec) :color (color spec)
     :kind (kind spec) :size (size spec)))


;;; CHOP-STRING      [Function]
;;; Date        : 97.07.02
;;; Description : Chops up a string according to what's in the string.
;;;             : The idea is to keep words intact, blocks of nonword 
characters
;;;             : intact, and know the spacing between words.  Given a string,
;;;             : this will return a list with that kind of info in it.
;;;             : Example:  (chop-string "==foo==   bar") will return:
;;;             : ("==" "foo" "==" 3 "foo").  The 3 in the list represents
;;;             : blanks, and notice how the "==foo==" was carved into three
;;;             : elements.

(defun chop-string (str)
   (declare (string str))
   (let* ((oldstate (char->state (char str 0)))
          (state nil)
          (chr nil)
          (wrd "")
          (cnt 0)
          (accum nil))
     (dotimes (i (length str))
       (setf chr (char str i))
       (setf state (char->state chr))
       (cond
        ;; if we're accumulating chars and the new char matches our state,
        ;; just concat the char
        ((or (and (eq state :WORD) (eq oldstate :WORD))
             (and (eq state :MISC) (eq oldstate :MISC)))
         (setf wrd (mkstr wrd chr))
         (setf cnt 0))
        ;; If we get a state change that finishes a word, then grab the
        ;; word.
        ((and (or (eq oldstate :WORD) (eq oldstate :MISC))
              (not (eq oldstate state)))
         (push wrd accum)
         (if (not (eq state :SPACE))
           (setf wrd (mkstr chr))
           (setf wrd "")))
        ;; when switching from spaces to words, push the counter and start
        ;; the word
        ((and (eq oldstate :SPACE) (not (eq state oldstate)))
         (push (1+ cnt) accum)
         (setf wrd (mkstr wrd chr)))
        ;; from whitespace to whitespace, inc the counter
        (t (incf cnt)))
       (setf oldstate state))
     (when (not (string= wrd ""))
       (push wrd accum))
     (setf accum (nreverse accum))
     (when (numberp (first accum))
       (decf (first accum)))
     accum))


(defun char->state (char)
   "Given a character, return :WORD, :SPACE, or :MISC"
   (declare (character char))
   (cond ((alphanumericp char) :WORD)
         ((whitespace-p char) :SPACE)
         (t :MISC)))


(defun whitespace-p (char)
   "Returns T if <char> is a whitespace character (non-printing or space)"
   (declare (character char))
   (or (not (graphic-char-p char))
       (eq char #\Space)))


(defun break-by-space (str)
   "Return <str> broken into a list of strings. Space is the separator."
   (declare (string str))
   (let ((ans nil)
         (pos nil)
         (start 0))
     (loop
       (setf pos (position #\space str :start start))
       (cond (pos
              (push (subseq str start pos) ans)
              (setf start (1+ pos)))
             (t
              (push (subseq str start (length str)) ans)
              (return))))
     (setf ans (remove "" ans :test #'string=))
     (reverse ans)))




;;; CONTIGUOUS-LOCS      [Function]
;;; Date        : 97.02.07
;;; Description : Given a location and a feature list, return a list of all the
;;;             : contiguous locations.  "Contiguous" only in the X direction,
;;;             : in this case.

(defun contiguous-locs (loc feat-lis)
   "Given a location and a feature list, return a list of all the 
contiguous locations"
   (declare (vector loc) (list feat-lis))
   (let ((workloc (copy-list loc))
         (work-lis nil))
     (while (feat-match-xy feat-lis workloc)
       (push (copy-seq workloc) work-lis)
       (incf (px workloc)))
     (setf workloc (copy-seq loc))
     (decf (px workloc))
     (while (feat-match-xy feat-lis workloc)
       (push (copy-seq workloc) work-lis)
       (decf (px workloc)))
     (sort work-lis #'< :key #'first)))



(defun phrase-accum (lis)
   "Accumulate a list of words into a phrase."
   (let ((accum (first lis)))
     (dolist (item (rest lis) accum)
       (setf accum (mkstr accum " " item)))))


(defun word-accum (lis)
   "Accumulate a list of letters into a word, and downcase it."
   (let ((accum (first lis)))
     (dolist (item (rest lis) (string-downcase accum))
       (setf accum (mkstr accum item)))))