;;;  -*- 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 or