;;; file: actr6/tools/act-gui-interface.lisp

;;;  -*- mode: LISP; Package: CL-USER; Syntax: COMMON-LISP;  Base: 10 -*-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 
;;; Author      : Dan Bothell 
;;; Address     : Carnegie Mellon University
;;;             : Psychology Department
;;;             : Pittsburgh,PA 15213-3890
;;;             : db30+@andrew.cmu.edu
;;; 
;;; Copyright   : (c)2002-2004 Dan Bothell
;;; Availability: Covered by the GNU LGPL, see LGPL.txt
;;;  
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 
;;; Filename    : act-gui-interface.lisp
;;; Version     : 1.0a1
;;; 
;;; Description : Contains the functions that implement the abstract GUI
;;;             : interface used by the tutorial units and the misc functions
;;;             : that go with them (permute-list, correlation and 
;;;             : mean-deviation).  I'm calling it the ACT-R GUI interface
;;;             : (AGI) as suggested by Mike.
;;;             : It relies on the UWI (at least for now).
;;; Bugs        : 
;;; To Do       : Consider making it support multiple interfaces to go with
;;;             : multiple models.
;;; --- History ---
;;; 2002.06.30 Dan
;;;             : Added this header.
;;;             : Renamed this file from uniform-interface-exp to 
;;;             : act-gui-interface.
;;;             : Added comments.
;;; 2002.12.17 Dan
;;;             : Modified correlation and mean-deviation so that
;;;             : the output keyword parameter is "more useful" -
;;;             : specifying a stream works right now (it doesn't try to
;;;             : open a file for it) and specifying nil suppress
;;;             : all output.
;;; 2002.12.19 Dan
;;;             : Updated add-text-to-exp-window so that it now includes
;;;             : a color option.
;;; 04.04.13 Dan [2.2]  (previous two changes also "new" as of 2.2)
;;;             : Changed the copyright notice and added the LGPL stuff.
;;;
;;; 04.10.19 Dan [Moved into ACT-R 6]
;;;             : reset version to 1.0a1
;;;             : added the packaging switches
;;;             : changed permute-list to use act-r-random
;;;
;;; 04.12.17 Dan
;;;             : Added get-time as a replacement for pm-get-time.
;;;   
;;; 2005.02.25 Dan
;;;             : * Removed the ~\newline usages because that causes problems
;;;             :   when a Lisp only wants to see native new lines there.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

#+:packaged-actr (in-package :act-r)
#+(and :clean-actr (not :packaged-actr) :ALLEGRO-IDE) (in-package :cg-user)
#-(or (not :clean-actr) :packaged-actr :ALLEGRO-IDE) (in-package :cl-user)

;;; *LIBRARY-EXPERIMENT-WINDOW*  [Global Variable]
;;; Description : This variable is used to hold the window that's opened with
;;;             : the AGI function open-exp-window.

(defvar *library-experiment-window* nil "Global AGI window")


;;; GET-TIME
;;; Return time in milliseconds
;;; If the model is enabled use model time, otherwise use 
;;; get-internal-real-time (which means it's only meaningful as a relative
;;; time outside of the model).

(defun get-time ()
  (if *actr-enabled-p*
      (round (* 1000 (mp-time)))
    ;; just to be safe use internal-time-units-per-second
    (round (* 1000 (/ (get-internal-real-time) 
                      internal-time-units-per-second)))))
    
;;; OPEN-EXP-WINDOW  [Function]
;;; Description : This function opens a window, either real, virtual, or
;;;             : visible-virtual as requested.  If there's already a window
;;;             : with those specs open it's cleared and used.

(defun open-exp-window (title &key (width 300) (height 300) (visible t) 
                                  (x 300) (y 300))
  "Open an experiment window"
  (if (open-rpm-window? *library-experiment-window*)
      (if (and (string-equal title (rpm-window-title 
                                    *library-experiment-window*))
               (eql visible (rpm-window-visible-status 
                             *library-experiment-window*))) 
          (progn
            (remove-all-items-from-rpm-window *library-experiment-window*)
            *library-experiment-window*)
        (progn
          (close-exp-window)
          
          (setf *library-experiment-window* (make-rpm-window 
                                             :visible visible 
                                             :title title
                                             :width width 
                                             :height height
                                             :x x
                                             :y y))))
    (setf *library-experiment-window* (make-rpm-window 
                                       :visible visible 
                                       :title title
                                       :width width 
                                       :height height
                                       :x x
                                       :y y)))
  (select-rpm-window *library-experiment-window*)
  *library-experiment-window*)

;;; SELECT-EXP-WINDOW  [Function]
;;; Description : Brings the *library-experiment-window* to the front.

(defun select-exp-window ()
  "select the experiment window"
  (select-rpm-window *library-experiment-window*))

;;; CLOSE-EXP-WINDOW  [Function]
;;; Description : Closes the *library-experiment-window*.

(defun close-exp-window ()
  "Close the experiment window"
  (close-rpm-window *library-experiment-window*)
  (setf *library-experiment-window* nil))

;;; CLEAR-EXP-WINDOW  [Function]
;;; Description : Removes all items from *library-experiment-window*.

(defun clear-exp-window ()
  "Erases everything in the experiment window"
  (remove-all-items-from-rpm-window *library-experiment-window*))

;;; REMOVE-ITEMS-FROM-EXP-WINDOW  [Function]
;;; Description : Removes the requested items from *library-experiment-window*.

(defun remove-items-from-exp-window (&rest items)
  "Remove the specified items from the experiment window"
  (apply #'remove-visual-items-from-rpm-window 
         (cons *library-experiment-window* items)))

;;; ADD-TEXT-TO-EXP-WINDOW  [Function]
;;; Description : Build a text item based on the parameters supplied and
;;;             : add it to *library-experiment-window*.

(defun add-text-to-exp-window (&key (x 0) (y 0) (text "") (height 20) 
                                    (width 75) (color 'black))
  "Create and display a text item in the experiment window"
 (let ((item (make-static-text-for-rpm-window 
                                   *library-experiment-window* 
                                   :text text 
                                   :x x
                                   :y y
                                   :width width
             	                   :height height
                                   :color color)))
   (add-visual-items-to-rpm-window *library-experiment-window* item)
   item))

;;; ADD-BUTTON-TO-EXP-WINDOW  [Function]
;;; Description : Build a button item based on the parameters supplied and
;;;             : add it to *library-experiment-window*.

(defun add-button-to-exp-window (&key (x 0) (y 0) (text "Ok") 
                                          (action nil) (height 18) 
                                          (width 60))
  "Create and display a button item in the experiment window"
  (let ((item (make-button-for-rpm-window *library-experiment-window*
                                                              :x x
                                                              :y y
                                                              :text text
                                                              :action action
                                                              :height height
                                          :width width)))
    (add-visual-items-to-rpm-window *library-experiment-window* item)
    item))

;;; ADD-LINE-TO-EXP-WINDOW  [Function]
;;; Description : Build a line item based on the parameters supplied and
;;;             : add it to *library-experiment-window*.

(defun add-line-to-exp-window (start-pt end-pt &optional (color 'black))
  "Create and display a line item in the experiment window"
  (let ((item (make-line-for-rpm-window *library-experiment-window*
                                        start-pt end-pt color)))
    (add-visual-items-to-rpm-window *library-experiment-window* item)
    item))

;;;; ---------------------------------------------------------------------- ;;;;
;;;; The miscelaneous functions used in the tutorial.
;;;; ---------------------------------------------------------------------- ;;;;

;;; PERMUTE-LIST  [Function]
;;; Description : This function returns a randomly ordered copy of the passed
;;;             : in list.

(defun permute-list (lis)
  "Return a random permutation of the list"
  (do* ((item (nth (act-r-random (length lis)) lis) (nth (act-r-random (length temp)) temp))
        (temp (remove item lis :count 1) (remove item temp :count 1))
        (result (list item) (cons item result)))
       ((null temp) result)))

;;; This is the correlation and deviation functions from the scripting
;;; extensions file and the necessary support.  I figured since they are
;;; still used they should be put here because the scripting extensions 
;;; aren't part of ACT-R 5, but making people load the scripting file
;;; separately is a pain...  I also changed mean-deviation so that it
;;; actually returned the deviation.

(defstruct data labels array)

(defmacro /-safe (number &rest dividers)
  `(/ ,number ,@(let ((max nil))
                  (dolist (divider dividers max)
                    (push-last `(if (zerop ,divider) 1 ,divider) max)))))

(defun numbers-list (structure)
  (let ((list nil))
    (when (data-p structure) (setf structure (data-array structure)))
    (cond ((arrayp structure)
           (dotimes (i (array-total-size structure))
             (let ((data (row-major-aref structure i)))
               (when (numberp data) (push data list)))))
          ((listp structure)
           (dolist (data structure)
             (cond ((listp data)
                    (setf list (append (nreverse (numbers-list data)) list)))
                   ((numberp data)
                    (push data list)))))
          ((numberp structure)
           (push structure list))
          (t (format t "~&UNKNOWN DATA FORMAT ~S NOT COMPATIBLE WITH NUMBERS LIST.~%"
                     structure)))
    (nreverse list)))

(defun square-data (x)
  (* x x))

(defun sum-list (list)
  (let ((sum 0.0))
    (dolist (data list sum)
      (incf sum data))))

(defun square-list (list)
  (let ((sum 0.0))
    (dolist (data list sum)
      (incf sum (square-data data)))))

(defun product-list (list1 list2)
  (let ((sum 0.0))
    (loop
      (when (or (null list1) (null list2)) (return sum))
      (incf sum (* (pop list1) (pop list2))))))

(defun mean-deviation (results data &key (output t))
  (let* ((results-list (numbers-list results))
         (data-list (numbers-list data))
         (n (min (length results-list) (length data-list)))
         (opened nil))
    (cond ((or (stringp output) (pathnamep output))
           (setf output (open output :direction :output :if-exists :append
                              :if-does-not-exist :create))
           (setf opened t))
          ((not (or (streamp output) (null output) (eq output t)))
           (format t "~&OUTPUT ARGUMENT ~S TO MEAN-DEVIATION IS NOT VALID.~%"
             output)
           (format t "IT MUST BE A STRING, PATHNAME, STREAM, T OR NIL.~%")
           (setf output t)))
    
    (unless (= (length results-list) (length data-list))
      (format t "~&ERROR: ~S AND ~S DO NOT HAVE THE SAME NUMBER OF NUMBERS.~%"
              results data))
    (let ((result (sqrt (/ (+ (square-list results-list) (square-list data-list)
                              (* -2.0 (product-list results-list data-list)))
                           n))))
      (format output "~&MEAN DEVIATION: ~6,3F~%" result)
      (when opened (close output))
      
      result)))

(defun correlation (results data &key (output t))
  (let* ((results-list (numbers-list results))
         (data-list (numbers-list data))
         (n (min (length results-list) (length data-list)))
         (average-results (/-safe (sum-list results-list) n))
         (average-data (/-safe (sum-list data-list) n))
         (opened nil))
    (cond ((or (stringp output) (pathnamep output))
           (setf output (open output :direction :output :if-exists :append
                              :if-does-not-exist :create))
           (setf opened t))
          ((not (or (streamp output) (null output) (eq output t)))
           (format t "~&OUTPUT ARGUMENT ~S TO CORRELATION IS NOT VALID.~%"
             output)
           (format t "IT MUST BE A STRING, PATHNAME, STREAM, T OR NIL.~%")
           (setf output t)))
    (unless (= (length results-list) (length data-list))
      (format t "~&ERROR: ~S AND ~S DO NOT HAVE THE SAME NUMBER OF NUMBERS.~%"
              results data))
    (let ((result (/-safe (- (/-safe (product-list results-list data-list) n)
                       (* average-results average-data))
                    (* (sqrt (- (/-safe (square-list results-list) n)
                                (square-data average-results)))
                       (sqrt (- (/-safe (square-list data-list) n)
                                (square-data average-data)))))))
      (format output "~&CORRELATION: ~6,3F~%"
            result)
    (when opened (close output))
      result)))


#|
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 2.1 of the License, or (at your option) any later version.

This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
Lesser General Public License for more details.

You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
|#

;;; file: actr6/core-modules/audio.lisp

;;;  -*- mode: LISP; Package: CL-USER; Syntax: COMMON-LISP;  Base: 10 -*-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 
;;; Author      : Mike Byrne & Dan Bothell
;;; Address     : Rice University, MS-25
;;;             : Psychology Department
;;;             : Houston,TX 77251-1892
;;;             : byrne@acm.org
;;; 
;;; Copyright   : (c)1998-2005 Mike Byrne/Dan Bothell
;;; Availability: Covered by the GNU LGPL, see LGPL.txt
;;; 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 
;;; Filename    : audio.lisp
;;; Version     : 2.2a1
;;; 
;;; Description : Source for RPM's Audition Module
;;; 
;;; Bugs        : 
;;; 
;;; Todo        : * Should there be audio buffer stuffing as well?
;;; 
;;; ----- History -----
;;; 
;;; 2005.01.07 mdb [act6a1]
;;;             : Transition to ACT6 stuff.
;;; 2005.01.08 Dan
;;;             : More updates to move to 6
;;;             :
;;;             : Changed aural-location to audio-event in request-audio-module
;;;             : (alternatively audio-event could be changed to aural-location
;;;             : in reset-audio-module but this way is backward compatible 
;;;             : to ACT-R 5)
;;;             :
;;;             : Removed the :offset parameter in the scheduling of find-sound
;;;             : in request-audio-module because it isn't defined in find-sound
;;;             :
;;;             : Changed find-sound to put the chunk into the buffer
;;;             :
;;;             : Changed find-sound because the chunk that comes in doesn't
;;;             : have the same name as the one in the audicon because it will
;;;             : be a copy from the buffer.  
;;;             :
;;;             : To get around that (for now at least) I've added an id slot
;;;             : to the audio-event chunk-type which will always have the
;;;             : original value.
;;;             :
;;;             : The event->dmo method was modified to set that value.
;;;             : 
;;;             : Changed audio-encoding-complete so that it sets the chunk
;;;             : in the aural buffer.  
;;;             :
;;;             : Related to the issue above with sound event names - the 
;;;             : sound put into the buffer has its event set to the "original" 
;;;             : event name (the id slot of the audio-event) which doesn't 
;;;             : correspond to the name of a chunk in DM, but it will match
;;;             : an audio-event with that value in its id slot (assuming the
;;;             : aural-location buffer has cleared so that the chunk goes to
;;;             : DM).
;;;             : 
;;;             : That seems reasonable for now at least.  
;;;             :
;;;             : Put the aural-location stuffing in:
;;;             ; Added the :around method for new-sound-event
;;;             : Added the stuff-sound-buffer function.
;;;             :
;;; 2005.01.09 Dan
;;;             : Added the clearing of the audicon to the reset-audio-module
;;;             : function.
;;;             : Added the word chunk to the audicon.
;;; 2005.01.10 Dan
;;;             : Maintain the stuffed slot of the audio module now since
;;;             : I added the buffer stuffing back in.
;;; 2005.01.11 mdb
;;;             : Put in parameter doc strings.
;;; 2005.01.21 Dan
;;;             : * Removed use of buffer-chunk and replaced with buffer-read.
;;; 2005.01.21 Dan
;;;             : * Wrapped the proclaim in an eval-when because otherwise
;;;             :   it may not actually affect the compilation.
;;; 2005.02.03 Dan
;;;             : * Added ":output 'medium" to some of the events that are
;;;             :   scheduled to play friendly with the new detail level.
;;; 2005.04.23 Dan
;;;             : * Updated find-sound so that it indicates whether the chunk
;;;             :   being put into the buffer was stuffed or not.
;;;             : * Changed stuff-sound-buffer to indicate that.
;;;             : * Removed the check of stuffed from query-audio-module.
;;;             : * Added attended as a possible query but I'm unsure if I've
;;;             :   got the testing quite right...
;;; 2005.04.29 Dan
;;;             : * Added a print-audicon command that works basically like
;;;             :   print-visicon for visual - it prints a table of info for
;;;             :   the sound-events currently in the audicon.
;;; 2005.07.22 Dan
;;;             : * Updated the module definition to use the pm-module-request
;;;             :   method and renamed the audio-module-request function 
;;;             :   accordingly.
;;; 2005.08.03 Dan
;;;             : * Added a find-sound-failure event to the trace when find-
;;;             :   sound fails.  Also adjusted the find-sound event scheduling
;;;             :   so that it gets output in the medium level trace detail.
;;; 2005.08.10 Dan
;;;             : * Commented out the offset value in the audio-event request
;;;             :   because it wasn't used.
;;; 2005.12.14 Dan
;;;             : * Added :sound-decay-time parameter which seems to have been
;;;             :   lost in the move to 6.
;;; 2006.01.04 Dan
;;;             : * Removed a duplicate instance of :tone-recode-delay in the
;;;             :   case of the parameter handling in params-audio-module and 
;;;             :   replaced it with :tone-detect-delay (which is what it 
;;;             :   should have been). 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

#+:packaged-actr (in-package :act-r)
#+(and :clean-actr (not :packaged-actr) :ALLEGRO-IDE) (in-package :cg-user)
#-(or (not :clean-actr) :packaged-actr :ALLEGRO-IDE) (in-package :cl-user)

(require-compiled "DMI" "ACT-R6:support;dmi")
(require-compiled "GENERAL-PM" "ACT-R6:support;general-pm")

#+:allegro (eval-when (:compile-toplevel :Load-toplevel :execute)
             (setf *enable-package-locked-errors* nil))

(eval-when (:compile-toplevel :Load-toplevel :execute)
  (proclaim '(optimize (speed 3) (space 0))))


(defclass audio-module (attn-module)
  ((audicon :accessor audicon :initarg :audicon :initform nil)
   (digit-detect-delay :accessor digit-detect-delay :initarg :digit-dtct-dly
                       :initform 0.300)
   (digit-recode-delay :accessor digit-recode-delay :initarg :digit-rec-dly
                       :initform 0.500)
   (digit-duration :accessor digit-duration :initarg :digit-duration 
                   :initform 0.600)
   (tone-detect-delay :accessor tone-detect-delay :initarg :tone-dtct-dly
                      :initform 0.050)
   (tone-recode-delay :accessor tone-recode-delay :initarg :tone-rec-dly 
                      :initform 0.285)
   (sound-decay-time :accessor decay-time :initarg :decay-time
                     :initform 3.000)
   )
  (:default-initargs
    :version-string "2.2a1"
    :name :AUDIO))


#|
(defmethod reset-module :after ((aud-mod audio-module))
  (setf (audicon aud-mod) nil))
|#

(defmethod initialize-instance :after ((aud-mod audio-module) &key)
#|
  (setf (state-dmo aud-mod)
        (make-dme 'audio-state 'module-state
                  '(module :audio modality free processor free preparation free
                    execution free)
                  :where :external))

|#  )


(defmethod silent-events ((aud-mod audio-module))
  (awhen (next-detectable-sound aud-mod (mp-time))
    (schedule-event-relative it 'detectable-audicon
                             :destination :audio  :module :audio )))


;;;; ---------------------------------------------------------------------- ;;;;
;;;; Sound events.
;;;; ---------------------------------------------------------------------- ;;;;

(defclass sound-event ()
  ((onset :accessor onset :initarg :onset 
          :initform (mp-time))
   (offset :accessor offset :initarg :offset :initform nil)
   (string :accessor snd-string :initarg :string :initform nil)
   (duration :accessor duration :initarg :duration :initform 0)
   (content :accessor content :initarg :content :initform nil)
   (content-delay :accessor delay :initarg :delay :initform nil)
   (kind :accessor kind :initarg :kind :initform 'SPEECH)
   (attended-p :accessor attended-p :initform nil :initarg :attended-p)
   (location :accessor location :initarg :location :initform 'EXTERNAL)
   (sname :accessor sname :initform (new-name-fct "SOUND") :initarg :sname)
   (ename :accessor ename :initform (new-name-fct "AUDIO-EVENT"))
   (recode :accessor recode :initarg :recode :initform nil)
   (pitch :accessor pitch :initform 'middle :initarg :pitch)
   (snd-dmo :accessor snd-dmo :initform nil)
   (evt-dmo :accessor evt-dmo :initform nil)
   ))


(defmethod initialize-instance :after ((self sound-event) &key)
  (unless (offset self)
    (when (and (numberp (onset self)) (numberp (duration self)))
      (setf (offset self) (+ (onset self) (duration self))))))

(defgeneric detect-at-time (evt)
  (:documentation "Returns the time at which an event becomes detectable."))

(defmethod detect-at-time ((evt sound-event))
  (ms-round (+ (onset evt) (delay evt))))


(defgeneric detectable-p (evt)
  (:documentation  "Returns T if the given sound event is detectable."))

(defmethod detectable-p ((evt sound-event))
  (>= (mp-time) (detect-at-time evt)))


(defgeneric finished-p (evt)
  (:documentation  "Returns T if the given sound-event is finished."))

(defmethod finished-p ((evt sound-event))
  (>= (mp-time) (offset evt)))


(defgeneric detectable-time (evt)
  (:documentation  "Returns the time at which the given sound event will become detectable."))

(defmethod detectable-time ((evt sound-event))
  (+ (onset evt) (delay evt)))


(defclass digit-sound-evt (sound-event)
  ()
  (:default-initargs
    :kind 'DIGIT
    :duration  (rand-time (digit-duration (get-module :audio)))
    :delay (rand-time (digit-detect-delay (get-module :audio)))
    :recode (digit-recode-delay (get-module :audio))
    :sname (new-name-fct "DIGIT")))


(defmethod initialize-instance :after ((self digit-sound-evt) &key)
  (setf (content self) (snd-string self)))


;;; TONE-SOUND-EVENT      [Class]
;;; Date        : 97.04.03
;;; Description : Class for tone events.
;;;             : The CONTENT slot should be the tone frequency.

(defclass tone-sound-evt (sound-event)
  ()
  (:default-initargs
    :string ""
    :kind 'TONE
    :content 1000
    :delay (rand-time (tone-detect-delay (get-module :audio)))
    :recode (tone-recode-delay (get-module :audio))
    :sname (new-name-fct "TONE")))


(defmethod initialize-instance :after ((self tone-sound-evt) &key)
  (cond ((> (content self) 1500) (setf (pitch self) 'high))
        ((< (content self) 900) (setf (pitch self) 'low))))


(defclass word-sound-evt (sound-event)
  ()
  (:default-initargs
    :kind 'WORD
    :delay (rand-time (digit-detect-delay (get-module :audio)))
    :sname (new-name-fct "WORD")
    :duration 0
    :recode nil
    ))

(defmethod initialize-instance :after ((self word-sound-evt) &key)
  (when (or (null (duration self)) (zerop (duration self)))
    (setf (duration self)
          (get-articulation-time (get-module :speech) (snd-string self))))
          ;;; that's defined in SPEECH.  hmmm
  (unless (recode self)
    (setf (recode self)
          ;; change the value below to make "hearing" faster
          (ms-round (max
                     (/ (duration self) 2)
                     (- (duration self) 0.150)))))
  (setf (content self) (snd-string self))
  (setf (offset self) (+ (onset self) (duration self)))
  )

(defclass sound-event-spec (sound-event spec)
  ()
  (:default-initargs
    :check-slots #(onset kind attended-p pitch location)
    :onset :IGNORE
    :kind :IGNORE
    :attended-p :IGNORE
    :pitch :IGNORE
    :offset :IGNORE
    :location :IGNORE
    ))


;;;; ---------------------------------------------------------------------- ;;;;
;;;; Toplevel commands.
;;;; ---------------------------------------------------------------------- ;;;;

;;; DAN
;;; Need to have the buffer stuffing still happen for aural-location because
;;; unit 3's sperling model depends on it.

(defmethod new-sound-event :around ((evt sound-event))
  (let ((evt (call-next-method)))
    (schedule-event (detect-at-time evt) 'stuff-sound-buffer
                    :module :audio
                    :destination :audio)))


(defun stuff-sound-buffer  (audio-mod) 
  (unless (buffer-read 'aural-location)
    (find-sound audio-mod :attended nil :stuffed t)))

(defgeneric new-sound-event (evt)
  (:documentation "Handles the bookkeeping when a new sound event is created."))

(defmethod new-sound-event ((evt sound-event))
  (push evt (audicon (get-module :audio)))
  evt)

(defgeneric new-digit-sound (digit &optional onset)
  (:documentation "Creates and adds a digit sound <digit>, a string, starting optionally at <onset>."))


(defmethod new-digit-sound ((digit number) 
                               &optional (onset (mp-time)))
  (new-sound-event (make-instance 'digit-sound-evt :onset (ms-round onset) 
                                  :string digit)))


(defgeneric new-tone-sound (freq duration &optional onset)
  (:documentation "Creates and adds a tone sound of <freq>, starting optionally at <onset>."))

(defmethod new-tone-sound ((freq number) (duration number)
                              &optional (onset (mp-time)))
  (new-sound-event (make-instance 'tone-sound-evt :onset (ms-round onset) 
                                  :duration duration :content freq)))

(defgeneric new-other-sound (content duration delay recode 
                                         &optional instr onset)
  (:documentation "Creates and adds a sound <content>, lasting <duration>, with content delay <delay>, with recode time <recode>, starting optionally at <onset>."))


(defmethod new-other-sound (content 
                               (duration number) (delay number)
                               (recode number) &optional (instr "")
                               (onset (mp-time)))
  (new-sound-event (make-instance 'sound-event :onset (ms-round onset) 
                                  :duration duration :content content 
                                  :delay delay :recode recode :string instr)))



(defgeneric new-word-sound (word &optional onset location)
  (:documentation "Creates and adds a word with optional onset time."))


(defmethod new-word-sound ((word string) 
                              &optional (onset (mp-time))
                              (location 'external))
  (new-sound-event (make-instance 'word-sound-evt :onset (ms-round onset) 
                                  :string word :location location)))



;;; FIND-SOUND      [Method]
;;; Date        : 97.08.18, delta 99.08.30
;;; Description : Parallels the Vision Module's FIND-LOCATION, this one finds
;;;             : audio events (not sounds) and returns a PS-specific DME.

(defgeneric find-sound (aud-mod &key attended kind onset pitch)
  (:documentation  "Given a set of specifications, return a sound event which matches."))

(defmethod find-sound ((aud-mod audio-module) &key (attended :IGNORE) 
                       (kind :IGNORE) onset pitch (location :ignore)
                       (stuffed nil))
  (let ((event-ls nil)
        (found-evt nil)
        (spec (make-instance 'sound-event-spec
                 :attended-p attended  :kind kind :location location
                 :onset (if (or (null onset) (symbolp onset)) 
                          :IGNORE onset)
                 :pitch (if (or (null pitch) (symbolp pitch)) 
                          :IGNORE pitch))))
    ;; find features matching the spec
    (setf event-ls (objs-match-spec (detectable-audicon aud-mod) spec))
    ;; some filtering
    (case onset
      (lowest (setf event-ls (objs-min-slotval event-ls 'onset)))
      (highest (setf event-ls (objs-max-slotval event-ls 'onset))))
    (case pitch
      (lowest (setf event-ls (objs-min-slotval event-ls 'pitch)))
      (highest (setf event-ls (objs-min-slotval event-ls 'pitch))))
    (if event-ls
        (progn
          (setf found-evt (random-item event-ls))
          (when found-evt
            (unless (evt-dmo found-evt)
              (event->dmo found-evt))
            
            ;;DAN
            ;; instead of returning it set it into the aural-location buffer
            ;; (dmo-to-psdme (evt-dmo found-evt))
            
            (schedule-set-buffer-chunk 'aural-location 
                                       (dmo-to-psdme (evt-dmo found-evt))
                                       0 :module :audio 
                                       :requested (not stuffed)
                                       
                                       ; Need this so that stuffing 
                                       ; can get things in before procedural
                                       ; can run conflict-resolution
                                       :priority 10)
            
            
            ))
      (schedule-event-relative 0 'find-sound-failure :module :audio :output 'medium))))

(defun find-sound-failure ()
  "dummy function to indicate a failure in the trace"
  nil)


;;; ATTEND-SOUND      [Method]
;;; Date        : 97.08.18
;;; Description : Parallels the Vision Module's MOVE-ATTENTION, this one
;;;             : attends an audio event, ultimately building a chunk based
;;;             : on the content of the sound.

(defgeneric attend-sound (aud-mod &key event)
  (:documentation  "Shift auditory attention to the given sound event."))

(defmethod attend-sound ((aud-mod audio-module) &key event)
  (unless (check-jam aud-mod)
    ;; does EVENT come in as a symbol or a chunk?  I'm assuming symbol...
    
    ;DAN 
    ; This won't work because the event that comes in is going to
    ; have a different name than the one that went into the audicon
    ; because it will be the name of the copy from the buffer.
    ; 
    ;(let ((s-event (find event (audicon aud-mod)
    ;                       :test #'(lambda (x y) (eq x (ename y))))))
    
    ; For now, using an id slot in the audio-event to keep the connection
    
    (let ((s-event (find (chunk-slot-value-fct event 'id) (audicon aud-mod)
                         :test #'(lambda (x y) (eq x (ename y))))))
      
      (setf (attend-failure aud-mod) nil)
      (setf (attended-p s-event) t)
      (setf (current-marker aud-mod) s-event)
      (change-state aud-mod :exec 'busy)
      (queue-command
       :time (recode s-event) :where :AUDIO :command 'audio-encoding-complete
       :randomize t :params s-event 
       ))))


#|
;;; LISTEN-FOR      [Method]
;;; Date        : 97.08.18, delta 99.08.30
;;; Description : Combination of FIND and ATTEND.  Does a FIND, and it if
;;;             : finds anything, immediately attends it.

(defgeneric listen-for (aud-mod &key onset kind attended pitch)
  (:documentation  "Checks the audicon for appropriate sounds.  If one is found, attend to it."))

(defmethod listen-for ((aud-mod audio-module) &key onset (kind :ignore) 
                         (attended :ignore) pitch)
  (multiple-value-bind (psdme found-evt)
                       (find-sound aud-mod :attended attended :kind kind
                                   :onset onset :pitch pitch)
    (declare (ignore psdme))
    (when found-evt
      (attend-event aud-mod found-evt))))
|#

;;;; ---------------------------------------------------------------------- ;;;;
;;;; support for toplevel commands
;;;; ---------------------------------------------------------------------- ;;;;


;;; ATTEND-EVENT      [Method]
;;; Date        : 97.04.11
;;; Description : When a sound is found by LISTEN-FOR, this may get called on
;;;             : the event.  This method handles state-setting and queueing
;;;             : of the appropriate actions.  Two situations are possible
;;;             : with the sound event:  the content is not yet available 
;;;             : [that is, the content-delay for the event has not passed]
;;;             : or it is.  If not, set preparation to busy until content
;;;             : becomes available.  Then, after recode time, actually add
;;;             : the item to declarative memory.

(defgeneric attend-event (aud-mod sevt)
  (:documentation  "When LISTEN-FOR picks up an event, this handles it."))

(defmethod attend-event ((aud-mod audio-module) (sevt sound-event))
  (let ((curr-time (mp-time))
        (detect-time (+ (onset sevt) (delay sevt))))
    (setf (current-marker aud-mod) sevt)
    (cond ((< curr-time detect-time)  		; sound not yet 'bufferized'
           (change-state aud-mod :prep 'busy)
           (queue-command
            :time (- detect-time curr-time) :where :AUDIO 
            :command 'change-state :params '(:exec busy :prep free))
           (queue-command
            :time (- (+ detect-time (rand-time (recode sevt))) curr-time)
            :where :AUDIO :command 'audio-encoding-complete
            :params sevt))
          (t
           (change-state aud-mod :exec 'busy)
           (queue-command
            :time (recode sevt) :where :AUDIO :command 'audio-encoding-complete
            :randomize t :params sevt)))))



(defgeneric audio-encoding-complete (aud-mod sevt)
  ;DAN
  ;(:documentation  "Actually add a sound to declarative memory."))
  (:documentation  "Put the sound into the aural buffer."))


(defmethod audio-encoding-complete ((aud-mod audio-module) 
                                         (sevt sound-event))
  (change-state aud-mod :exec 'free)
  (setf (attended-p sevt) t)
  (unless (snd-dmo sevt)
    
    ;; DAN
    ;; Similar to the issue in find-sound, the name of the
    ;; audio event doesn't match the actual chunk name that
    ;; was in the aural-location buffer so setting event
    ;; to the ename of svet is going to cause problems
    ;; since that slot value isn't going to match a chunk in DM.
    ;; For now, the solution is that the id slot of the event
    ;; is what's constant.
    
    (let ((the-dmo
           (make-dme (sname sevt) 'sound 
                     `(kind ,(kind sevt) content ,(content sevt)
                            event ,(chunk-slot-value-fct (ename sevt) 'id))
                     :where :external)))
      (setf (snd-dmo sevt) the-dmo)))
  
  ;; DAN 
  ;; set the aural buffer
  
  (schedule-set-buffer-chunk 'aural (sname sevt) 0 :module :audio)
  
  
  (set-attended aud-mod (snd-dmo sevt)))



;;;; ---------------------------------------------------------------------- ;;;;
;;;; Audio utilities
;;;; ---------------------------------------------------------------------- ;;;;


(defgeneric purge-old-sounds (aud-mod)
  (:documentation  "Removes sounds that have decayed from the audicon"))

(defmethod purge-old-sounds ((aud-mod audio-module))
  (setf (audicon aud-mod)
        (remove-if #'(lambda (e) (< (+ (offset e) (decay-time aud-mod))
                                     (mp-time)))
                   (audicon aud-mod))))


(defun earliest-onset (evt-lis)
  "Returns the sound event in the list with earliest onset."
  (let ((best (onset (first evt-lis)))
        (outlis (list (first evt-lis))))
    (dolist (evt (rest evt-lis) outlis)
      (cond ((= (onset evt) best) (push evt outlis))
            ((< (onset evt) best) (setf best (onset evt))
             (setf outlis (list evt)))))))


(defun latest-onset (evt-lis)
  "Returns the sound event in the list with latest onset."
  (let ((best (onset (first evt-lis)))
        (outlis (list (first evt-lis))))
    (dolist (evt (rest evt-lis) outlis)
      (cond ((= (onset evt) best) (push evt outlis))
            ((> (onset evt) best) (setf best (onset evt))
             (setf outlis (list evt)))))))


(defgeneric current-audicon (aud-mod)
  (:documentation  "Returns the audicon, assuming all events that currently exist are in there."))

(defmethod current-audicon ((aud-mod audio-module))
  (purge-old-sounds aud-mod)
  (remove-if #'(lambda (x) (> (onset x) (mp-time))) (audicon aud-mod)))


(defgeneric detectable-audicon (aud-mod)
  (:documentation  "Returns the audicon, but only those events that are currently detectable."))

(defmethod detectable-audicon ((aud-mod audio-module))
  (purge-old-sounds aud-mod)
  (remove-if #'(lambda (x) (not (detectable-p x))) (audicon aud-mod)))



(defgeneric event->dmo (evt)
  (:documentation  "Translate a sound event to the corresponding DMO."))

(defmethod event->dmo ((evt sound-event))
  (let ((dmo
         (make-dme (ename evt) 'audio-event 
                   `(attended ,(attended-p evt) onset ,(onset evt)
                              location ,(location evt) kind ,(kind evt)
                              ;;DAN 
                              ; adding this at least for now to deal with the
                              ; fact that chunk names change in the buffers
                              id ,(ename evt)
                              )
                   :where :external)))
    (when (finished-p evt)
      (set-attributes dmo `(offset ,(offset evt))))
    (setf (evt-dmo evt) dmo)))


(defgeneric next-detectable-sound (aud-mod current-time)
  (:documentation  "Return the time when the next sound in the audicon is detectable."))

(defmethod next-detectable-sound ((aud-mod audio-module) current-time)
  (let ((onsets (mapcar #'detectable-time (audicon aud-mod))))
    (setf onsets (sort onsets #'<))
    (dolist (event-time onsets nil)
      (when (> event-time current-time)
        (return-from next-detectable-sound event-time)))))



;;;; ---------------------------------------------------------------------- ;;;;
;;;; ACT6 integration stuff
;;;; ---------------------------------------------------------------------- ;;;;

(defun reset-audio-module (instance)
  (reset-pm-module instance)

  (chunk-type audio-event attended onset offset pitch kind location id)
  (chunk-type sound kind content event)
  (chunk-type audio-command)
  
  ;;DAN
  ; I think this needs to happen here
  
  (setf (audicon instance) nil)
  ;(setf (stuffed instance) nil)
  
  (define-chunks
    (digit isa chunk)
    (speech isa chunk)
    (tone isa chunk)
    (word isa chunk)))



(defun query-audio-module (aud-mod buffer slot value)
  (case buffer
    (aural
     (if (member slot '(preparation execution processor modality))
       (generic-state-query aud-mod buffer slot value)
       (case slot
         (state
          (case value
            (busy
             (eq (mode-s aud-mod) 'busy))
            (free
             (eq (mode-s aud-mod) 'free))
            (error
             (attend-failure aud-mod))
            (t (print-warning 
                "Invalid query made of the ~S buffer with slot ~S and value ~S" 
                buffer slot value))))
         (t (print-warning 
                "Invalid query made of the ~S buffer with slot ~S and value ~S" 
                buffer slot value)))))
    (aural-location
     (case slot
       (state
        (case value
          (busy nil) ;; aural-location requests are always free
          (free t)
          (error (loc-failure aud-mod))
          (t (pm-warning 
              "Invalid query made of the ~S buffer with slot ~S and value ~S" 
              buffer slot value))))
       (attended
        (awhen (buffer-read 'aural-location)
               (let ((s-event (find (chunk-slot-value-fct (buffer-read 'aural-location) 'id) 
                                    (audicon aud-mod)
                                    :test #'(lambda (x y) (eq x (ename y))))))
                 (when s-event
                   (eq value (attended-p s-event))))))))))
                 
         


(defmethod pm-module-request ((aud-mod audio-module) buffer-name chunk-spec)
  ;(declare (ignore aud-mod))
  (case buffer-name
    (aural
     (case (chunk-spec-chunk-type chunk-spec)
       (clear
        (schedule-event-relative 0 'clear :module :audio :destination :audio
                                 :output 'medium))
       (sound
        (let ((event (when (slot-in-chunk-spec-p chunk-spec 'event) 
                        (verify-single-explicit-value 
                         (chunk-spec-slot-spec chunk-spec 'event) 
                         :audio 'sound 'event))))
          (when event
            (schedule-event-relative 0 'attend-sound
                                     :params (list :event event)
                                     :module :audio  :destination :audio
                                     :details (mkstr 'attend-sound " " event)
                                     :output 'medium))))
       ;; should we support LISTEN-FOR anymore?  Hmm...
       (t
        (print-warning "Invalid command ~a sent to the aural buffer" 
                       (chunk-spec-chunk-type chunk-spec)))))
    (aural-location
     (case (chunk-spec-chunk-type chunk-spec)
       (;; DAN 
        ;;aural-location
        audio-event
        (let ((attended (if (slot-in-chunk-spec-p chunk-spec 'attended) 
                            (verify-single-explicit-value 
                             (chunk-spec-slot-spec chunk-spec 'attended) 
                             :audio 'aural-location 'nearest)
                            :IGNORE))
              (kind (if (slot-in-chunk-spec-p chunk-spec 'kind) 
                       (verify-single-explicit-value 
                        (chunk-spec-slot-spec chunk-spec 'kind) 
                        :audio 'aural-location 'kind)
                       :IGNORE))
              (location (if (slot-in-chunk-spec-p chunk-spec 'onset) 
                            (verify-single-explicit-value 
                             (chunk-spec-slot-spec chunk-spec 'location) 
                             :audio 'aural-location 'location)
                            :IGNORE))
              (onset (when (slot-in-chunk-spec-p chunk-spec 'onset) 
                        (verify-single-explicit-value 
                         (chunk-spec-slot-spec chunk-spec 'onset) 
                         :audio 'aural-location 'onset)))
              
              ;;; DAN commented out since it isn't used
              ;;; (offset (when (slot-in-chunk-spec-p chunk-spec 'offset) 
              ;;;            (verify-single-explicit-value 
              ;;;             (chunk-spec-slot-spec chunk-spec 'offset) 
              ;;;             :audio 'aural-location 'offset)))
              
              )
          ;(setf (stuffed aud-mod) nil)
          (schedule-event-relative 0 'find-sound :module :audio 
                                   :output 'medium
                                   :destination :audio 
                                   :details ;(format nil "~s" 'find-sound)
                                   (mkstr 'find-sound)
                                   :params (list :kind kind :attended attended 
                                                 :location location
                                                 :onset onset
                                                 ;; Dan 
                                                 ;; this isn't a valid
                                                 ;; keyword for find-sound
                                                 ;:offset offset
                                                 ))))
       (t
        (print-warning "Invalid command ~a sent to the aural-location buffer" 
                       (chunk-spec-chunk-type chunk-spec)))))))
 


(defun params-audio-module (aud-mod param)
  (if (consp param)
    (case (first param)
      (:digit-detect-delay
       (setf (digit-detect-delay aud-mod) (rest param)))
      (:digit-duration
       (setf (digit-duration aud-mod) (rest param)))
      (:digit-recode-delay
       (setf (digit-recode-delay aud-mod) (rest param)))
      (:sound-decay-time 
       (setf (decay-time aud-mod) (rest param)))
      (:tone-detect-delay
       (setf (tone-detect-delay aud-mod) (rest param)))
      (:tone-recode-delay
       (setf (tone-recode-delay aud-mod) (rest param))))
    (case param
      (:digit-detect-delay
        (digit-detect-delay aud-mod))
      (:digit-duration
        (digit-duration aud-mod))
      (:digit-recode-delay
        (digit-recode-delay aud-mod))
      (:sound-decay-time 
       (decay-time aud-mod))
      (:tone-detect-delay
        (tone-detect-delay aud-mod))
      (:tone-recode-delay
        (tone-recode-delay aud-mod)))))
      

(define-module-fct :audio 
    (list (list 'aural-location nil '(:attended) ;;note that the attended request parameter is not used anywere yet
                           '(attended)
                           #'(lambda ()
                               (command-output "  attended nil          : ~S"
                                               (query-buffer 'aural-location
                                                             '((attended . nil))))
                               (command-output "  attended t            : ~S"
                                               (query-buffer 'aural-location
                                                             '((attended . t)))))) 
          (list 'aural nil nil '(modality preparation execution processor) 
                  #'(lambda () (print-module-status (get-module :audio)))))
  (list 
   (define-parameter :digit-detect-delay
     :valid-test #'posnum
     :default-value 0.3
     :warning "a non-negative number"
     :documentation "Lag between onset and detectability for digits")
   (define-parameter :digit-duration
     :valid-test #'posnum
     :default-value 0.6
     :warning "a non-negative number"
     :documentation "Default duration for digit sounds.")
   (define-parameter :digit-recode-delay
     :valid-test #'posnum
     :default-value 0.5
     :warning "a non-negative number"
     :documentation "Recoding delay for digit sound content.")
   (define-parameter :sound-decay-time
     :valid-test #'posnum
     :default-value 3.0
     :warning "a non-negative number"
     :documentation "The amount of time after a sound has finished it takes for the sound to be deleted from the audicon")
   (define-parameter :tone-detect-delay
     :valid-test #'posnum
     :default-value 0.05
     :warning "a non-negative number"
     :documentation "Lag between sound onset and detectability for tones")
   (define-parameter :tone-recode-delay
     :valid-test #'posnum
     :default-value 0.285
     :warning "a non-negative number"
     :documentation "Recoding delay for tone sound content."))
  :version "2.2a1"
  :documentation "First pass at moving the audio module to ACT-R 6"
  :creation #'(lambda (x) (declare (ignore x))
               (make-instance 'audio-module))
  :reset #'reset-audio-module
  :query #'query-audio-module
  :request #'pm-module-request
  :buffer-mod nil  ;;; Don't accpet +aural or +aural-location chunk modifications
  :params #'params-audio-module
  :delete nil   ;;; I don't think there's any clean up necessary of the vision if a model and its vision module are deleted
  :notify-on-clear nil ;;; don't need to record the chunks that leave buffers
  :update #'update-module)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; User Commands
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun print-audicon ()
  (let ((module (get-module :audio)))
    (if module
        (progn
          (format t "~%Sound event  Att  Kind           Content           location     onset     offset  string     Sound ID")
          (format t "~%-----------  ---  -------------  ----------------  --------     -----     ------  -------    --------")
          
          (dolist (x (current-audicon module))
            (print-audio-feature x))) 
      (print-warning "No audio module found"))))



(defgeneric print-audio-feature (feat)
  (:documentation  "Print out an ASCII representation of the audicon."))


(defmethod print-audio-feature ((feat sound-event))
  (format t "~%~13a~5A~15A~18a~10a~8,3f   ~8,3f  ~11a~a"
    (ename feat)
    (attended-p feat)
    (kind feat)
    (content feat)
    (location feat)
    (onset feat)
    (offset feat)
    (snd-string feat)
    (sname feat)))


#|
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 2.1 of the License, or (at your option) any later version.

This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
Lesser General Public License for more details.

You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
|#

;;; file: actr6/support/backward.lisp

;;;  -*- mode: LISP; Syntax: COMMON-LISP;  Base: 10 -*-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 
;;; Author      : Dan Bothell
;;; Copyright   : (c) 2004 Dan Bothell
;;; Availability: Covered by the GNU LGPL, see LGPL.txt
;;; Address     : Department of Psychology 
;;;             : Carnegie Mellon University
;;;             : Pittsburgh, PA 15213-3890
;;;             : db30@andrew.cmu.edu
;;; 
;;; 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 
;;; Filename    : backward.lisp
;;; Version     : 1.0
;;; 
;;; Description : Maps ACT-R 5 functions to the ACT-R 6 counterpart.
;;; 
;;; Bugs        : 
;;;
;;; To do       : 
;;; 
;;; ----- History -----
;;; 2005.01.12 Dan
;;;             : File creation.
;;; 2005.01.26 Dan
;;;             : * Added commands from ACT-R 4/5 related to declarative
;;;             :   memory that have either been renamed or just depricated.
;;; 2005.05.02 Dan
;;;             : * Moved some commands from motor to here.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; General Docs:
;;; 
;;; If one wants or needs the old names for commands then just call this:
;;; (require-compiled "BACKWARD" "ACT-R6:support;backward")
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Public API:
;;;
;;; All of them...
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Design Choices:
;;; 
;;; 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 
;;; The code
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

#+:packaged-actr (in-package :act-r)
#+(and :clean-actr (not :packaged-actr) :ALLEGRO-IDE) (in-package :cg-user)
#-(or (not :clean-actr) :packaged-actr :ALLEGRO-IDE) (in-package :cl-user)



;;; Commands for the device interface

(defun pm-install-window (window)
  "Installs <window> as the action window for the PM layer.  Included purely fo backward compatibility only. Use INSTALL-DEVICE instead."
  (install-device window))

(defun pm-install-device (device)
  "Installs <device> as the active device for the perceptual-motor layer."
  (install-device device))

(defun pm-proc-display (&key clear)
  "Processes the current display."
  (process-display (current-device-interface) (get-module :vision) clear))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Commands from declarative memory

(defmacro add-ia (&rest settings)
  `(add-sji-fct ',settings))

(defun add-ia-fct (settings)
  (add-sji-fct settings))


(defmacro ia (chunkj chunki)
  "ACT-R 5 function to get IA value"
  `(sji-fct ',chunkj ',chunki))

(defun ia-fct (chunkj chunki)
  "ACT-R 5 function to get IA value"
  (sji-fct chunkj chunki))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Motor module commands

(defun pm-start-hand-at-mouse ()
  "Starts the right hand on the mouse instead of the 'home row' location"
  (start-hand-at-mouse))

(defmacro pm-set-cursor-position (x y)
  "Sets the position of the cursor."
  `(set-cursor-position-fct ,(vector x y)))

(defmacro pm-prepare-motor (&rest lis)
  "Tells the Motor Module to prepare the supplied movement. [left in for backward compatibility]"
  `(pm-prepare-mvmt-mth (get-module :motor) ',lis))

(defun pm-set-cursor-position-fct (xyloc)
  (set-cursor-location-fct xyloc))

(defmacro pm-set-hand-location (hand &rest loc)
  "Sets the location of the given hand to LOC"
  `(set-hand-location-fct ',hand ',loc))

(provide "BACKWARD")

#|
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 2.1 of the License, or (at your option) any later version.

This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
Lesser General Public License for more details.

You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
|#

;;; file: actr6/tools/buffer-trace.lisp

;;;  -*- mode: LISP; Syntax: COMMON-LISP;  Base: 10 -*-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 
;;; Author      : Dan Bothell
;;; Copyright   : (c) 2006 Dan Bothell
;;; Availability: Covered by the GNU LGPL, see LGPL.txt
;;; Address     : Department of Psychology 
;;;             : Carnegie Mellon University
;;;             : Pittsburgh, PA 15213-3890
;;;             : db30@andrew.cmu.edu
;;; 
;;; 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 
;;; Filename    : buffer-trace.lisp
;;; Version     : 1.0a1
;;; 
;;; Description : Provide a tool that shows what activities are occuring in
;;;             : the buffers instead of the current "event" based trace and
;;;             : make that information available to the modeler as well if
;;;             : desired.
;;; 
;;; Bugs        : 
;;;
;;; To do       : [] Watch the :trace-filter parameter and warn if it gets set
;;;             :    to a function other than disable-event-trace when the buffer
;;;             :    trace is enabled.
;;;             : [] Better monitor the setting/removing of the post-event hook.
;;; 
;;; ----- History -----
;;; 2006.01.26 Dan
;;;             : * Initial creation.
;;; 2006.02.07 Dan
;;;             : * Fixed an issue with subseq going past the end of the event-details.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; General Docs:
;;; 
;;; This module collects information about the buffers in the system as a model
;;; runs (when enabled).  That information can be displayed as a trace while the
;;; model runs, or saved for later use by the modeler.
;;; 
;;;
;;; The module has 5 parameters that control the tracing:
;;;
;;; :BUFFER-TRACE   default: NIL 
;;;   If this parameter is set to t, then the normal event trace is disabled and
;;;   the buffer trace is printed instead.
;;;
;;; :TRACED-BUFFERS default: T  
;;;   The list of buffers to be traced (all buffers if set to t).  Only those
;;;   buffers specified on this list will have their data recorded.  The order
;;;   of the buffers in the list is the order they will be printed, and if it
;;;   is set to t all buffers will be displayed in alphabetical order.
;;;
;;; :BUFFER-TRACE-STEP  default: NIL 
;;;   When this is set to a number it specifies the maximum amount of time 
;;;   that is allowed to elapse before creating a new buffer summary (there
;;;   may be smaller time steps that correspond to model actions).
;;;
;;; :SAVE-BUFFER-TRACE default: NIL
;;;   When set to t the module will record the summary data so that the modeler
;;;   can use it later (does not alter the trace i.e. if :buffer-trace is nil
;;;   and :save-buffer-trace is t one will still get the event based trace).
;;;
;;; :BUFFER-TRACE-HOOK default: NIL
;;;   Can be set to a function which takes one parameter.  It will be called
;;;   with every buffer-record structure at the time they are available (when
;;;   the clock changes or the run terminates).
;;; 
;;; The following information is recorded at each event of the model and aggregated
;;; over all events at a given time:
;;; 
;;; Whether the module is busy
;;; Whether the module is in an error
;;; Whether the buffer is full
;;; Whether the buffer is cleared
;;; Whether the chunk in the buffer is modified
;;;
;;; Whether a request is sent to the module
;;; Whether a new chunk is set in the buffer
;;;
;;;
;;; For the first 5, if the stated condition is true during any event at the
;;; current time the buffer record will indicate t.
;;; For the requests, each request overwrites any prior request recorded
;;; at that time.  The value recorded is a string of the chunk-type of the
;;; chunk-spec or the details string provided for the event if there was one.
;;; If a chunk is set into the buffer, then the name of that chunk is recorded,
;;; and only the last setting at a specific time is recorded.
;;;
;;; The trace attempts to show all of that information in a textual format.  At each
;;; time step of the model (including extra time steps if needed for the trace-step)
;;; there will be a line of trace printed.  At the start of the line will be the
;;; time of the summary and for each buffer traced there will be a column of 
;;; information in the trace. In the column the first character will be "E" if 
;;; the module is in an error state or a space otherwise.  The second character
;;; will be a "." if there is currently a chunk in the buffer or a space if it
;;; is empty.  The rest of the column will show one of the following things
;;; in their order of priority (truncated to maintain the column width):
;;;   If there is a chunk set in the buffer the name of that chunk
;;;   If there is a request the request is shown between two "+" characters
;;;   If the buffer is modified it will show a series of "=" characters
;;;   If the buffer is cleared it will show a series of "-" characters
;;;   If the module is busy it will show a series of "*" characters
;;;   otherwise it will be filled with spaces.
;;;
;;; Here is an example of a trace when the following sgp is added to the demo2
;;; model (and the run time is reduced from 10 seconds to 1 second):  
;;; (sgp :buffer-trace t :buffer-trace-step .025 :traced-buffers (production goal visual-location visual manual))
;;;
;;;
#|
CG-USER(86): (do-experiment)
           |    PRODUCTION   |       GOAL      | VISUAL-LOCATION |      VISUAL     |      MANUAL     |
     0.000 |  +FIND-UNATTEN+ | .     GOAL      | .     LOC0      |                 |                 |
     0.025 |  ************** | .               | .               |                 |                 |
     0.050 |  +ATTEND-LETTE+ | .    =======    | .     LOC1      |                 |                 |
     0.075 |  ************** | .               | .               |                 |                 |
     0.100 |  ************** | .    =======    | .    -------    |  +MOVE-ATTENTI+ |                 |
     0.125 |                 | .               |                 |  ************** |                 |
     0.150 |                 | .               |                 |  ************** |                 |
     0.175 |                 | .               |                 |  ************** |                 |
     0.185 |  +ENCODE-LETTE+ | .               |                 | .     TEXT0     |                 |
     0.210 |  ************** | .               |                 | .               |                 |
     0.235 |  +   RESPOND  + | .    =======    |                 | .    -------    |                 |
     0.260 |  ************** | .               |                 |                 |                 |
     0.285 |  ************** | .    =======    |                 |                 |  +  PRESS-KEY + |
     0.310 |                 | .               |                 |                 |  ************** |
     0.335 |                 | .               |                 |                 |  ************** |
     0.360 |                 | .               |                 |                 |  ************** |
     0.385 |                 | .               |                 |                 |  ************** |
     0.410 |                 | .               |                 |                 |  ************** |
     0.435 |                 | .               |                 |                 |  ************** |
     0.460 |                 | .               |                 |                 |  ************** |
     0.485 |                 | .               |                 |                 |  ************** |
     0.510 |                 | .               |                 |                 |  ************** |
     0.535 |                 | .               |                 |                 |  ************** |
     0.560 |                 | .               |                 |                 |  ************** |
     0.585 |                 | .               |                 |                 |  ************** |
     0.610 |                 | .               |                 |                 |  ************** |
     0.635 |                 | .               |                 |                 |  ************** |
     0.660 |                 | .               |                 |                 |  ************** |
     0.685 |                 | .               |                 |                 |  ************** |
     0.710 |                 | .               |                 |  ************** |  ************** |
     0.735 |                 | .               |                 |  ************** |  ************** |
     0.760 |                 | .               |                 |  ************** |  ************** |
     0.770 |                 | .               |                 |E                |  ************** |
     0.795 |                 | .               |                 |E                |  ************** |
     0.820 |                 | .               |                 |E                |  ************** |
     0.835 |                 | .               |                 |E                |                 |
     0.860 |                 | .               |                 |E                |                 |
     0.885 |                 | .               |                 |E                |                 |
     0.910 |                 | .               |                 |E                |                 |
     0.935 |                 | .               |                 |E                |                 |
     0.960 |                 | .               |                 |E                |                 |
     0.985 |                 | .               |                 |E                |                 |
     0.985   ------                 Stopped because no events left to process 
"V"
|#
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Public API:
;;;
;;; get-current-buffer-trace
;;;
;;;    takes no parameters and returns a list of the buffer-record structures
;;;    collected since the save-buffer-trace parameter was set or nil if the
;;;    module isn't found.
;;;
;;;    The buffer-record structures are pretty raw - there're no special accessors
;;;    defined for picking them apart nor are the buffer-summary structures that
;;;    it contains made more user friendly at this point.
;;;
;;;    This can be used if one wants to use other display mechanisms to present
;;;    the data collected.
;;; 
;;; Because the data is presented raw in a saved summary and to the hook function, 
;;; these structures are also part of the API:
;;;
;;;  (defstruct buffer-record time-stamp buffers)
;;;  (defstruct buffer-summary name cleared busy error full modified request chunk-name)
;;;
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Design Choices:
;;; 
;;; Grown out of Scott's graphic module tracer and the old environment's PERT
;;; style trace.  The idea being that instead of looking at the specific actions
;;; of a module one can "watch" the buffers since they're the interface to
;;; the module.  As long as a module takes requests through the buffers and 
;;; responds to the state queries appropriately it can be monitored.
;;;
;;; The addition of the production buffer was necessary so that the procedural
;;; module could be queried and report "requests" (production firings) like
;;; any other module.  It is a bit strange, and not really a buffer of the
;;; theory (note it doesn't end in 'al') but may end up being so as work on
;;; meta-cognitive processing continues - being able to monitor the state 
;;; of the prodceural system may be an important thing to do.
;;;
;;; If there are multiple models running with the buffer trace turned on one
;;; will probably want to direct those models' outputs to different streams
;;; because the trace doesn't make any effort to differentiate which model a
;;; summary line corresponds to (unlike the event trace which prints the model
;;; name at the start).
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 
;;; The code
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

#+:packaged-actr (in-package :act-r)
#+(and :clean-actr (not :packaged-actr) :ALLEGRO-IDE) (in-package :cg-user)
#-(or (not :clean-actr) :packaged-actr :ALLEGRO-IDE) (in-package :cl-user)


;;; Because the event hooks are applied at the meta-process level instead of
;;; at the model level there needs to be something outside of the module instance
;;; to track setting/removing the hooks for efficiency.  However, at this
;;; time, a quick and dirty approach is being used which essentially just
;;; ignores the need for such a thing, but it's here so that it's ready when/if
;;; I decide to come back and clean it up.

(defvar *buffer-trace-module-mp-table* (make-hash-table ))


(defstruct (buffer-trace-module (:conc-name btm-))
  trace 
  buffers 
  save 
  hooks
  time-step
  column-width
  
  traced-buffers
  enabled
  current-summary 
  saved-records
  next-step-time)

(defstruct buffer-record
  time-stamp
  buffers)


(defstruct buffer-summary
  name
  cleared
  busy
  error
  full
  modified
  request
  chunk-name)


(defun buffer-trace-time-step-event ()
  )

(defun disable-event-trace (evt)
  (declare (ignore evt))
  nil)



(defun format-buffer-record (br w)
  (with-output-to-string (s)
    (format s "~10,3f " (buffer-record-time-stamp br))
    
    (dolist (x (buffer-record-buffers br))
      
      (format s "|~:[ ~;E~]~:[ ~;.~]~v:@<~a~> " 
        (buffer-summary-error x) 
        (buffer-summary-full x)
        (1- w)
        
        (cond ((buffer-summary-chunk-name x)
               (if (>= (length (buffer-summary-chunk-name x)) w)
                   (subseq (buffer-summary-chunk-name x) 0 (1- w))
                 (buffer-summary-chunk-name x)))
              
              ((buffer-summary-request x)
               (if (> (length (buffer-summary-request x)) (- w 3))
                   (format nil "+~v:@<~a~>+" (- w 3) (subseq (buffer-summary-request x) 0 (- w 3)))
                 (format nil "+~v:@<~a~>+" (- w 3) (buffer-summary-request x))))
              ((buffer-summary-modified x)
               (format nil "~v:@<~v,1,0,'=a~>" (1- w) (floor w 2) ""))
              ((buffer-summary-cleared x)
               (format nil "~v:@<~v,1,0,'-a~>" (1- w) (floor w 2) ""))
              ((buffer-summary-busy x)
               (format nil "~v,1,0,'*a" (1- w) ""))
              (t
               (format nil "~va" (1- w) "")))))
    (format s "|")
    (model-output (get-output-stream-string s))))

(defun buffer-trace-event-recorder (evt)
  (let ((btm (get-module buffer-trace))
        (new nil))
    
 
    (when (and btm (btm-enabled btm))
      
      (if  (eq (evt-action evt) 'buffer-trace-time-step-event)
          (setf (btm-next-step-time btm) nil)
        (when (and (numberp (btm-time-step btm))
                   (btm-next-step-time btm)
                   (< (ms-round (- (evt-time (btm-next-step-time btm)) (evt-time evt))) (btm-time-step btm)))
          
          (setf new t) ;; need to generate a new one...
          (delete-event (btm-next-step-time btm))
          (setf (btm-next-step-time btm) nil)))
      
      
      
      (when (null (btm-current-summary btm))
        (when (btm-trace btm)
          (with-output-to-string (s)
            (format s "           ")
            (dolist (x (btm-traced-buffers btm))
              (format s "| ~v:@<~a~> " (btm-column-width btm) x))
            (format s "|")
            
            (model-output (get-output-stream-string s))
            ))
        
        ;; create a new one and set as current
        (setf (btm-current-summary btm)
          (make-buffer-record :time-stamp (evt-time evt)))
        (setf (buffer-record-buffers (btm-current-summary btm))
          (mapcar (lambda (x) (make-buffer-summary :name x))
            (btm-traced-buffers btm)))
        
        (setf new t))
      
      (unless (= (buffer-record-time-stamp (btm-current-summary btm)) (evt-time evt))
        
        (dolist (hook (btm-hooks btm))
          (funcall hook (btm-current-summary btm)))
        
        (when (btm-trace btm)
          (format-buffer-record (btm-current-summary btm) (btm-column-width btm)))
        
        (when (btm-save btm)
          (push-last (btm-current-summary btm) (btm-saved-records btm)))
        
        
        (setf (btm-current-summary btm)
          (make-buffer-record :time-stamp (evt-time evt)))
        
        (setf (buffer-record-buffers (btm-current-summary btm))
          (mapcar (lambda (x) (make-buffer-summary :name x))
            (btm-traced-buffers btm)))
        
        )
      
      ;; Update the records
      
      ;; First pull any meaningful info out of the evt itself
      
      (case (evt-action evt)
        ((set-buffer-chunk overwrite-buffer-chunk)
         (let ((bn (car (evt-params evt))))
           (awhen (find bn (buffer-record-buffers (btm-current-summary btm)) :key #'buffer-summary-name)
                  (setf (buffer-summary-chunk-name it) (string (second (evt-params evt))))))
           
           
           )
        (mod-buffer-chunk
         
         (let ((bn (car (evt-params evt))))
           (awhen (find bn (buffer-record-buffers (btm-current-summary btm)) :key #'buffer-summary-name)
                  (setf (buffer-summary-modified it) t)))         
         )
        (clear-buffer
         
         (let ((bn (car (evt-params evt))))
           (awhen (find bn (buffer-record-buffers (btm-current-summary btm)) :key #'buffer-summary-name)
                  (setf (buffer-summary-cleared it) t)))
         
         )
        (module-request
         (let ((bn (car (evt-params evt))))
           (awhen (find bn (buffer-record-buffers (btm-current-summary btm)) :key #'buffer-summary-name)
                  (setf (buffer-summary-request it)
                    (if (and (>= (length (evt-details evt)) 15)
                             (string-equal "module-request " (subseq (evt-details evt) 0 15)))
                        (string (chunk-spec-chunk-type (second (evt-params evt))))
                      (evt-details evt)))))
         
         )
        (module-mod-request
         (let ((bn (car (evt-params evt))))
           (awhen (find bn (buffer-record-buffers (btm-current-summary btm)) :key #'buffer-summary-name)
                  (setf (buffer-summary-request it)
                    (if (and (>= (length (evt-details evt)) 19)
                             (string-equal "module-mod-request " (subseq (evt-details evt) 0 19)))
                        "buffer modify"
                      (evt-details evt)))))

         ))
      
      ;; Now for each one set busy, error, and full
      
      (dolist (x (buffer-record-buffers (btm-current-summary btm)))
        (when (query-buffer (buffer-summary-name x) '((state . busy)))
          (setf (buffer-summary-busy x) t))
        (when (query-buffer (buffer-summary-name x) '((state . error)))
          (setf (buffer-summary-error x) t))
        (when (query-buffer (buffer-summary-name x) '((buffer . full)))
          (setf (buffer-summary-full x) t)))
      
      ;; Now, just check to see if it should stop or add a time-step check event
      
      (if (or (act-r-break-event-p evt)
              (eq 'run-terminated (evt-action evt)))
          ;; This is a terminating event
          
          (progn
            (dolist (hook (btm-hooks btm))
              (funcall hook (btm-current-summary btm)))
            
            (when (btm-trace btm)
              (format-buffer-record (btm-current-summary btm) (btm-column-width btm)))
            
            (when (btm-save btm)
              (push-last (btm-current-summary btm) (btm-saved-records btm)))
            
            
            (setf (btm-current-summary btm) nil)
            
            ;; kill any pending time-step-events...
            (when (btm-next-step-time btm)
              (delete-event (btm-next-step-time btm)))
            )
        
        ;; not a terminator, so check to see if a time-step event is necessary
        (when (and (or new 
                       (eq (evt-action evt) 'buffer-trace-time-step-event))
                   (numberp (btm-time-step btm))
                   (null (btm-next-step-time btm)))
          (setf (btm-next-step-time btm)
            (schedule-maintenance-event-relative (btm-time-step btm)
                                                 'buffer-trace-time-step-event
                                                 :output nil
                                                 :details nil
                                                 :priority :max
                                                 )))))))


(defun get-current-buffer-trace ()
  (let ((btm (get-module buffer-trace)))
    (when btm
      (btm-saved-records btm))))


(defun reset-buffer-trace-module (btm)
  (setf (btm-enabled btm) nil)
  (setf (btm-current-summary btm) nil)
  (setf (btm-saved-records btm) nil)
  (setf (btm-traced-buffers btm) nil)
  (setf (btm-next-step-time btm) nil))

(defun buffer-trace-params (btm param)
  (cond ((consp param)
         
         (case (car param)
           (:traced-buffers 
            (if (eq t (cdr param))
                (progn
                  (setf (btm-traced-buffers btm) (sort (buffers) #'string< :key #'symbol-name))
                  (setf (btm-buffers btm) t))
              (progn
                (setf (btm-buffers btm) (cdr param))
                (setf (btm-traced-buffers btm) (cdr param))))
            
            (setf (btm-column-width btm)
              (apply 'max (mapcar #'(lambda (x) (length (symbol-name x))) (btm-traced-buffers btm)))))
           
           (:buffer-trace-step 
            (setf (btm-time-step btm) (cdr param)))
           
           (:buffer-trace 
            (setf (btm-trace btm) (cdr param))
            (setf (btm-enabled btm)
              (or (btm-save btm) (btm-trace btm) (btm-hooks btm)))
            (when (btm-enabled btm)
              ;; eventually will need to record this for later removal
              (add-post-event-hook 'buffer-trace-event-recorder nil))
            
            ;; Should check to see if it's overwriting one but for now
            ;; just smash it.
            
            (if (cdr param)
                (no-output (sgp-fct (list :trace-filter 'disable-event-trace)))
              (no-output (sgp-fct (list :trace-filter nil)))))
           
           (:save-buffer-trace 
             (setf (btm-save btm) (cdr param))
            (setf (btm-enabled btm)
              (or (btm-save btm) (btm-trace btm) (btm-hooks btm)))
            (when (btm-enabled btm)
              ;; eventually will need to record this for later removal
              (add-post-event-hook 'buffer-trace-event-recorder nil)))
           
           (:buffer-trace-hook
            (if (cdr param)
                (if (member (cdr param) (btm-hooks btm))
                    (print-warning 
                      "Setting parameter ~s failed because ~s already on the hook."
                     :buffer-trace-hook
                      (cdr param))
                  (push (cdr param) (btm-hooks btm)))
              (setf (btm-hooks btm) nil))
            
            (setf (btm-enabled btm)
              (or (btm-save btm) (btm-trace btm) (btm-hooks btm)))
            (when (btm-enabled btm)
              ;; eventually will need to record this for later removal
              (add-post-event-hook 'buffer-trace-event-recorder nil)))))
        (t 
         (case param
           (:buffer-trace-hook (btm-hooks btm))
           (:save-buffer-trace (btm-save btm))
           (:buffer-trace-step (btm-time-step btm))
           (:traced-buffers (btm-buffers btm))
           (:buffer-trace (btm-trace btm))))))



(define-module-fct 'buffer-trace nil
  (list (define-parameter :buffer-trace
          :valid-test #'tornil 
          :warning "t or nil."
          :default-value nil
          :documentation "Display the trace as a buffer summary instead of as an event list.")
        (define-parameter :traced-buffers
          :valid-test #'(lambda (x) 
                          (or (eq t x) 
                              (and (listp x) 
                                   (every (lambda (y) (find y (buffers))) x))))
          :warning "t or a list of valid buffer names."
          :default-value t
          :documentation "The list of buffers to be traced (all buffers if set to t).")
        (define-parameter :buffer-trace-step
          :valid-test #'(lambda (x) (or (null x) (and (posnum x) (not (zerop x)))))
          :warning "a positive number or nil."
          :default-value nil
          :documentation "The maximum amount of time allowed to elapse before creating a buffer summary.")
        (define-parameter :save-buffer-trace
          :valid-test #'tornil 
          :warning "t or nil."
          :default-value nil
          :documentation "Whether to save the buffer summary for a run or not.")
        (define-parameter :buffer-trace-hook
          :valid-test #'fctornil
          :warning "a function or nil."
          :default-value nil
          :documentation "A function to call with each buffer summary."))
  :version "1.0a1"
  :documentation "A module that provides a buffer based tracing mechanism."
  :creation #'(lambda (x) (declare (ignore x)) (make-buffer-trace-module))
  :reset #'reset-buffer-trace-module
  :params #'buffer-trace-params
  ; :delete - eventually want to worry about coming off of the
  ; event-hook list, but not at this point.
   )
            

#|
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 2.1 of the License, or (at your option) any later version.

This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
Lesser General Public License for more details.

You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
|#

;;; file: actr6/framework/buffers.lisp

;;;  -*- mode: LISP; Syntax: COMMON-LISP;  Base: 10 -*-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 
;;; Author      : Dan Bothell
;;; Copyright   : (c) 2004 Dan Bothell
;;; Availability: Covered by the GNU LGPL, see LGPL.txt
;;; Address     : Department of Psychology 
;;;             : Carnegie Mellon University
;;;             : Pittsburgh, PA 15213-3890
;;;             : db30@andrew.cmu.edu
;;; 
;;; 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 
;;; Filename    : buffers.lisp
;;; Version     : 1.0
;;; 
;;; Description : Functions that define the operation of buffers.
;;; 
;;; Bugs        : 
;;;
;;; To do       : [] Finish documentation.
;;;               [] Investigate the copy sematics and probably optimize things.
;;;               [] Crazy idea - why not treat buffer parameters the same as
;;;                  chunk parameters and allow them to be user defined?
;;;               [] Have all the schedule-* functions allow a details keyword.
;;; 
;;; ----- History -----
;;;
;;; 2004.08.20 Dan
;;;             : Creation
;;;
;;; 2004.12.13 Dan
;;;             : Added :details to the scheduled buffer events to clean up the
;;;             : traces.
;;;             : Reduced lines down to max of 80 chars.
;;; 2005.01.17 Dan
;;;             : * Removed calls to format in the scheduling.
;;; 2005.01.18 Dan
;;;             : * Removed call to get-parameters.
;;; 2005.02.01 Dan
;;;             : * Modified buffer-chunk so it prints the chunks as well when
;;;             :   specific buffers requested.
;;; 2005.02.03 Dan
;;;             : * Changed the default output for some functions to 'medium
;;;             :   or 'low to play friendly with the new detail level.
;;; 2005.02.04 Dan
;;;             : * Taking advantage of the fast-* chunk accessors.
;;; 2005.04.19 Dan
;;;             : * Added buffers-module-name to add to the API.
;;; 2005.04.23 Dan
;;;             : * Added the buffer-status command to print out the queries
;;;             :   for buffers.  Works basically like buffer-chunk.
;;;             : * Added the status-printing option to buffer definition
;;;             :   list (the fifth item) so a module can print extra status
;;;             :   info with buffer-status.
;;;             : * Added the requested keyword to the set-buffer-chunk 
;;;             :   command because the requested (formerly stuffed) status
;;;             :   of the buffer is being maintained internally now.
;;;             : * Updated the query-buffer command to handle buffer
;;;             :   requested/unrequested instead of passing it to the module.
;;;             : * For now, an overwrite always sets the requested to nil,
;;;             :   but maybe that needs to be user defineable too.
;;; 2005.05.11 Dan
;;;             : * Adjusted the params in the schedule-set-buffer-chunk
;;;             :   call so that requested chunks don't have to show that
;;;             :   in the trace - only unrequested chunks are marked.
;;; 2005.08.10 Dan
;;;             : * Added the uninstall-buffers function to support the 
;;;             :   undefine-modules function.  This is not designed to be used
;;;             :   any other way - buffer removal is a dangerous thing.
;;;             : * Updated the version to 1.0.
;;; 2005.08.16 Dan
;;;             : * Changes necessary to allow query of error t/nil without
;;;             :   any change to the module code - a module just has to 
;;;             :   respond to the "state error" query and the query-module
;;;             :   function handles the mapping now.  The change here is
;;;             :   to add error to the *required-buffer-queries* list
;;;             :   and to now test that on doesn't try to override a required
;;;             :   query.
;;; 2006.01.17 Dan
;;;             : * Updated the module version to 1.0 since there haven't been 
;;;             :   any problems it's time to drop the "a".
;;; 2006.01.25 Dan
;;;             : * Added an option to allow details in schedule-module-request
;;;             :   to overwrite the default.   Should make that change for all
;;;             :   of the schedule- functions at some point, but for now I 
;;;             :   only need it for the request one...
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; General Docs:
;;; 
;;; 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Public API:
;;;
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Design Choices:
;;; 
;;; 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 
;;; The code
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

#+:packaged-actr (in-package :act-r)
#+(and :clean-actr (not :packaged-actr) :ALLEGRO-IDE) (in-package :cg-user)
#-(or (not :clean-actr) :packaged-actr :ALLEGRO-IDE) (in-package :cl-user)

(defconstant *required-buffer-queries* '(state buffer error))

(defvar *buffers-table* (make-hash-table))



(defun buffers ()
  (hash-table-keys *buffers-table*))


(defun buffer-exists (name)
  (multiple-value-bind (buffer present)
      (gethash name *buffers-table*)
    (declare (ignore buffer))
    present))

(defun parse-buffers (buffer-list)
  (let ((res nil))
    (dolist (buffer-def buffer-list res)
      (cond ((or (atom buffer-def)
                 (and (listp buffer-def) (= (length buffer-def) 1)))
             (when (listp buffer-def)
               (setf buffer-def (car buffer-def)))
             (cond ((buffer-exists buffer-def)
                    (print-warning 
                     "Buffer name ~S already used, cannot reuse it.")
                    (return-from parse-buffers :error))
                   (t
                    (push (make-act-r-buffer 
                           :name buffer-def
                           :queries *required-buffer-queries*
                           :parameter-name 
                           (read-from-string 
                            (format nil ":~S-activation" buffer-def)))
                          res))))
            ((and (listp buffer-def)
                  (buffer-exists (car buffer-def)))
             (print-warning "Buffer name ~S already used, cannot reuse it.")
             (return-from parse-buffers :error))
            
            ((not (listp buffer-def))
             (print-warning "Invalid buffer specification: ~S" buffer-def)
             (return-from parse-buffers :error))

            ((<= (length buffer-def) 5)
             (let (param-name param-default requests queries print-status)
               (if (and (second buffer-def) (listp (second buffer-def)))
                   (cond ((or 
                           (> (length (second buffer-def)) 2)
                           (not (keywordp (first (second buffer-def))))
                           (not (numberp (second (second buffer-def)))))
                          (print-warning 
                           "Invalid buffer specification: ~S" buffer-def)
                          (return-from parse-buffers :error))
                         (t
                          (setf param-name (first (second buffer-def)))
                          (setf param-default (second (second buffer-def)))))
                 (cond ((keywordp (second buffer-def))
                        (setf param-name (second buffer-def)))
                       ((null (second buffer-def))
                        (setf param-name
                          (read-from-string 
                           (format nil ":~S-activation" (first buffer-def)))))
                       (t
                        (print-warning 
                         "Invalid buffer specification: ~S" buffer-def)
                        (return-from parse-buffers :error))))
               (when (third buffer-def)
                 (cond ((and (listp (third buffer-def))
                             (every #'keywordp (third buffer-def)))
                        (setf requests (third buffer-def)))
                       (t
                        (print-warning 
                         "Invalid buffer specification: ~S" buffer-def)
                        (return-from parse-buffers :error))))
               (when (fourth buffer-def)
                 (cond ((and (listp (fourth buffer-def))
                             (every #'(lambda (x) 
                                        (and (symbolp x) (not (keywordp x))
                                             (not (find x *required-buffer-queries*))))
                                    (fourth buffer-def)))
                        (setf queries (fourth buffer-def)))
                       (t
                        (print-warning 
                         "Invalid buffer specification: ~S" buffer-def)
                        (return-from parse-buffers :error))))
               (when (fifth buffer-def)
                 (cond ((fctornil (fifth buffer-def))
                        (setf print-status (fifth buffer-def)))
                       (t
                        (print-warning 
                         "Invalid buffer specification: ~S" buffer-def)
                        (print-warning
                         "status function not valid")
                        (return-from parse-buffers :error))))
               
               (push (make-act-r-buffer 
                      :name (first buffer-def)
                      :queries (append queries *required-buffer-queries*)
                      :requests requests
                      :parameter-name param-name
                      :spread param-default
                      :status-printing print-status
                      :requested nil)
                     res)))
                       
             
            (t
             (print-warning "Invalid buffer specification: ~S" buffer-def)
             (return-from parse-buffers :error))))))


                   
(defun install-buffers (module-name buffers)
  (dolist (buffer buffers)
    (setf (gethash (act-r-buffer-name buffer) *buffers-table*) buffer)
    (setf (act-r-buffer-module buffer) module-name)
    (install-parameters 'buffer-params 
                        (list (define-parameter 
                                  (act-r-buffer-parameter-name buffer)
                                  :owner t
                                :valid-test #'numberp
                                :default-value 
                                (if (null (act-r-buffer-spread buffer))
                                    0
                                  (act-r-buffer-spread buffer))
                                :warning "a number"
                                :documentation 
                                (format nil 
                                    "source spread for the ~S buffer" 
                                  (act-r-buffer-name buffer)))))))



(defun uninstall-buffers (buffers)
  "Necessary for undefining a module"
  (dolist (buffer buffers)
    (remhash (act-r-buffer-name buffer) *buffers-table*)
    (remove-parameter (act-r-buffer-parameter-name buffer))))  


(defun create-buffer-param-module (model-name)
  (declare (ignore model-name))
  (make-hash-table))

(defun buffer-params-handler (instance param)
  (if (consp param)
      (setf (gethash (car param) instance) (cdr param))
    (gethash param instance)))




(define-module buffer-params nil nil :version "1.0"
  :documentation "Module to hold and control the buffer parameters"
  :creation create-buffer-param-module
  :params buffer-params-handler)



(defun buffer-instance (buffer-name)
  (verify-current-mp  
   "buffer-instance called with no current meta-process."
   (verify-current-model
    "buffer-instance called with no current model."
    (gethash buffer-name (act-r-model-buffers (current-model-struct))))))



(defmacro buffer-chunk (&rest buffer-names)
  `(buffer-chunk-fct ',buffer-names))

(defun buffer-chunk-fct (buffer-names-list)
  (verify-current-mp  
   "buffer-chunk called with no current meta-process."
   (verify-current-model
    "buffer-chunk called with no current model."
    (let ((res nil))
      (dolist (buffer-name (if buffer-names-list
                               buffer-names-list
                             (buffers))
                           res)
        (let* ((buffer (buffer-instance buffer-name)))
          (if buffer
              (let ((chunk (act-r-buffer-chunk buffer)))
                (command-output "~S: ~S ~@[[~s]~]" buffer-name chunk
                                (chunk-copied-from-fct chunk))
                (when buffer-names-list
                  (pprint-chunks-fct (list chunk)))
                (push-last (if buffer-names-list
                               chunk
                             (cons buffer-name chunk))
                           res))
            (push-last (if buffer-names-list
                           :error
                         (cons :error nil)) 
                       res))))))))
        

(defmacro buffer-status (&rest buffer-names)
  `(buffer-status-fct ',buffer-names))

(defun buffer-status-fct (buffer-names-list)
  (verify-current-mp  
   "buffer-status called with no current meta-process."
   (verify-current-model
    "buffer-status called with no current model."
    (let ((res nil))
      (dolist (buffer-name (if buffer-names-list
                               buffer-names-list
                             (buffers))
                           res)
        (let ((buffer (buffer-instance buffer-name)))
          (if buffer
              (progn
                (command-output "~S:" buffer-name)
                (command-output "  buffer empty          : ~S"
                                (query-buffer buffer-name
                                              '((buffer . empty))))
                (command-output "  buffer full           : ~S"
                                (query-buffer buffer-name
                                              '((buffer . full))))
                (command-output "  buffer requested      : ~S"
                                (query-buffer buffer-name
                                              '((buffer . requested))))
                (command-output "  buffer unrequested    : ~S"
                                (query-buffer buffer-name
                                              '((buffer . unrequested))))
                (command-output "  state free            : ~S"
                                (query-buffer buffer-name
                                              '((state . free))))
                (command-output "  state busy            : ~S"
                                (query-buffer buffer-name
                                              '((state . busy))))
                (command-output "  state error           : ~S"
                                (query-buffer buffer-name
                                              '((state . error))))
                
                (awhen (act-r-buffer-status-printing buffer)
                       (funcall it))
                
                (push-last buffer-name res))
            (push-last :error res))))))))

(defun buffer-read (buffer-name)  
  (verify-current-mp  
   "buffer-read called with no current meta-process."
   (verify-current-model
    "buffer-read called with no current model."
    (let ((buffer (buffer-instance buffer-name)))
      (if buffer 
          (act-r-buffer-chunk buffer) 
        (print-warning "Buffer-read called with an invalid buffer name ~S" 
                       buffer-name))))))


(defun schedule-buffer-read (buffer-name time-delta 
                             &key (module :none) (priority 0)
                             (output t))
  (verify-current-mp  
   "schedule-buffer-read called with no current meta-process."
   (verify-current-model
    "schedule-buffer-read called with no current model."
    (let ((buffer (buffer-instance buffer-name)))
      (cond ((null buffer)
             (print-warning 
              "schedule-buffer-read called with an invalid buffer name ~S"
              buffer-name))
            ((not (numberp time-delta))
             (print-warning 
              "schedule-buffer-read called with a non-number time-delta: ~S"
              time-delta))
            ((and (not (numberp priority)) (not (eq priority :max)) 
                  (not (eq priority :min)))
             (print-warning 
              "schedule-buffer-read called with an invalid priority ~S" 
              priority))
            (t
             (schedule-event-relative time-delta 'buffer-read-action 
                                      :module module
                                      :priority priority 
                                      :params (list buffer-name)
                                      :output output)))))))


(defun buffer-read-report (buffer-name &key (module :none))
  (verify-current-mp  
   "buffer-read-report called with no current meta-process."
   (verify-current-model
    "buffer-read-report called with no current model."
    (let ((buffer (buffer-instance buffer-name)))
      (cond ((null buffer)
             (print-warning 
              "buffer-read-report called with an invalid buffer name ~S" 
              buffer-name))
            (t
             (schedule-event-relative 0 'buffer-read-action 
                                      :module module
                                      :priority :max 
                                      :params (list buffer-name)
                                      :output t)
             (act-r-buffer-chunk buffer)))))))


(defun buffer-read-action (buffer-name)
  (declare (ignore buffer-name))
  )


(defun query-buffer (buffer-name queries-list)
  (verify-current-mp  
   "query-buffer called with no current meta-process."
   (verify-current-model
    "query-buffer called with no current model."
    (let ((buffer (buffer-instance buffer-name)))
      (cond ((null buffer)
             (print-warning 
              "query-buffer called with an invalid buffer name ~S" 
              buffer-name))
            ((not (every #'(lambda (x)
                             (member (car x) (act-r-buffer-queries buffer)))
                         queries-list))
             (print-warning 
              "Invalid query-buffer ~S.  Available queries to buffer ~S are ~S."
              queries-list buffer-name (act-r-buffer-queries buffer)))
            (t
             (do ((module (act-r-buffer-module buffer))
                  (queries queries-list (cdr queries)))
                 ((null queries) t)
               (cond ((eq (caar queries) 'buffer)
                      (case (cdar queries) 
                        (full 
                         (when (null (act-r-buffer-chunk buffer))
                           (return-from query-buffer nil)))
                        (empty
                         (unless (null (act-r-buffer-chunk buffer))
                           (return-from query-buffer nil)))
                        (requested
                         (when (or (null (act-r-buffer-chunk buffer))
                                   (null (act-r-buffer-requested buffer)))
                           (return-from query-buffer nil)))
                        (unrequested
                         (unless (and (act-r-buffer-chunk buffer)
                                      (null (act-r-buffer-requested buffer)))
                           (return-from query-buffer nil)))
                        (t
                         (model-warning "Unknown buffer query ~S"
                                        (cdar queries))
                         (return-from query-buffer nil))))
                     (t
                      (unless (query-module module buffer-name 
                                            (caar queries) (cdar queries))
                   (return-from query-buffer nil)))))))))))
                                              

(defun schedule-query-buffer (buffer-name queries-list time-delta 
                                   &key (module :none) (priority 0)
                                   (output t))
  (verify-current-mp  
   "schedule-query-buffer called with no current meta-process."
   (verify-current-model
    "schedule-query-buffer called with no current model."
    (let ((buffer (buffer-instance buffer-name)))
      (cond ((null buffer)
             (print-warning 
              "schedule-query-buffer called with an invalid buffer name ~S" 
              buffer-name))
            ((not (numberp time-delta))
             (print-warning 
              "schedule-query-buffer called with non-nimber time-delta: ~S" 
              time-delta))
            ((and (not (numberp priority)) (not (eq priority :max)) 
                  (not (eq priority :min)))
             (print-warning 
              "schedule-query-buffer called with an invalid priority ~S" 
              priority))
            (t
             (schedule-event-relative time-delta 'query-buffer-action 
                                      :module module
                                      :priority priority 
                                      :params (list buffer-name queries-list)
                                      :details
                                      (concatenate 'string
                                        (symbol-name 'query-buffer-action)
                                        " "
                                        (symbol-name buffer-name))
                                      
                                      
                                      :output output)))))))


(defun query-buffer-report (buffer-name queries-list &key (module :none))
  (verify-current-mp  
   "query-buffer-report called with no current meta-process."
   (verify-current-model
    "query-buffer-report called with no current model."
    (let ((buffer (buffer-instance buffer-name)))
      (cond ((null buffer)
             (print-warning 
              "query-buffer-report called with an invalid buffer name ~S" 
              buffer-name))
            ((not (every #'(lambda (x)
                             (member (car x) (act-r-buffer-queries buffer)))
                         queries-list))
             (print-warning 
              "Invalid query-buffer ~S.  Available queries to buffer ~S are ~S."
              queries-list buffer-name (act-r-buffer-queries buffer)))
            (t
             (schedule-event-relative 0 'query-buffer-action 
                                      :module module
                                      :priority :max 
                                      :params (list buffer-name queries-list)
                                      :details 
                                      (concatenate 'string
                                        (symbol-name 'query-buffer-action)
                                        " "
                                        (symbol-name buffer-name))
                                      :output t)
             (query-buffer buffer-name queries-list)))))))


(defun query-buffer-action (buffer-name queries)
  (declare (ignore buffer-name queries)))


(defun clear-buffer (buffer-name)
  (verify-current-mp  
   "clear-buffer called with no current meta-process."
   (verify-current-model
    "clear-buffer called with no current model."
    (let ((buffer (buffer-instance buffer-name)))
      (cond ((null buffer)
             (print-warning 
              "clear-buffer called with an invalid buffer name ~S" 
              buffer-name))
            (t
             (let ((chunk (act-r-buffer-chunk buffer)))
               (when chunk
                 (setf (act-r-buffer-chunk buffer) nil)
                 (dolist (module (notified-modules))
                   (notify-module module buffer-name chunk)))
               chunk)))))))


(defun schedule-clear-buffer (buffer-name time-delta 
                              &key (module :none) (priority 0)
                              (output 'low))
  (verify-current-mp  
   "schedule-clear-buffer called with no current meta-process."
   (verify-current-model
    "schedule-clear-buffer called with no current model."
    (let ((buffer (buffer-instance buffer-name)))
      (cond ((null buffer)
             (print-warning 
              "schedule-clear-buffer called with an invalid buffer name ~S" 
              buffer-name))
            ((not (numberp time-delta))
             (print-warning 
              "buffer-read-report called with a non-number time-delta: ~S"
              time-delta))
            ((and (not (numberp priority)) (not (eq priority :max)) 
                  (not (eq priority :min)))
             (print-warning 
              "buffer-read-report called with an invalid priority ~S" 
              priority))
            (t
             
             (schedule-event-relative time-delta 'clear-buffer 
                                      :module module
                                      :priority priority 
                                      :params (list buffer-name)
                                      :output output)))))))


(defun set-buffer-chunk (buffer-name chunk-name &key (requested t))
  "Forces a copy...."
  (verify-current-mp  
   "set-buffer-chunk called with no current meta-process."
   (verify-current-model
    "set-buffer-chunk called with no current model."
    (let ((buffer (buffer-instance buffer-name)))
      (cond ((null buffer)
             (print-warning 
              "set-buffer-chunk called with an invalid buffer name ~S" 
              buffer-name))
            ((null (get-chunk chunk-name))
             (print-warning 
              "set-buffer-chunk called with an invalid chunk name ~S"
              chunk-name))
            (t
             (when (act-r-buffer-chunk buffer)
               (clear-buffer buffer-name))
             (setf (act-r-buffer-chunk buffer) 
               (copy-chunk-fct chunk-name))
             (setf (act-r-buffer-requested buffer) 
               requested)))))))


(defun schedule-set-buffer-chunk (buffer-name chunk-name time-delta 
                                              &key (module :none) (priority 0)
                                              (output 'low)
                                              (requested t))
  (verify-current-mp  
   "set-buffer-chunk called with no current meta-process."
   (verify-current-model
    "set-buffer-chunk called with no current model."
    (let ((buffer (buffer-instance buffer-name)))
      (cond ((null buffer)
             (print-warning 
              "set-buffer-chunk called with an invalid buffer name ~S" 
              buffer-name))
            ((null (get-chunk chunk-name))
             (print-warning 
              "set-buffer-chunk called with an invalid chunk name ~S" 
              chunk-name))
            ((not (numberp time-delta))
             (print-warning 
              "set-buffer-chunk called with time-delta that is not a number: ~S"
              time-delta))
            ((and (not (numberp priority)) (not (eq priority :max)) 
                  (not (eq priority :min)))
             (print-warning 
              "set-buffer-chunk called with an invalid priority ~S" priority))
            (t
             (schedule-event-relative time-delta 'set-buffer-chunk 
                                      :module module
                                      :priority priority 
                                      :params (if requested
                                                  (list buffer-name chunk-name)
                                                (list buffer-name chunk-name
                                                      :requested requested))

                                      :output output)))))))



(defun overwrite-buffer-chunk (buffer-name chunk-name)
  "Also forces a copy of the chunk..."
  (verify-current-mp  
   "overwrite-buffer-chunk called with no current meta-process."
   (verify-current-model
    "overwrite-buffer-chunk called with no current model."
    (let ((buffer (buffer-instance buffer-name)))
      (cond ((null buffer)
             (print-warning 
              "overwrite-buffer-chunk called with an invalid buffer name ~S" 
              buffer-name))
            ((null (get-chunk chunk-name))
             (print-warning 
              "overwrite-buffer-chunk called with an invalid chunk name ~S"
              chunk-name))
            (t
             (setf (act-r-buffer-chunk buffer) 
               (copy-chunk-fct chunk-name))
             (setf (act-r-buffer-requested buffer) 
               nil)))))))


(defun schedule-overwrite-buffer-chunk (buffer-name chunk-name time-delta 
                                              &key (module :none) (priority 0)
                                              (output 'low))
  (verify-current-mp  
   "overwrite-buffer-chunk called with no current meta-process."
   (verify-current-model
    "overwrite-buffer-chunk called with no current model."
    (let ((buffer (buffer-instance buffer-name)))
      (cond ((null buffer)
             (print-warning 
              "overwrite-buffer-chunk called with an invalid buffer name ~S"
              buffer-name))
            ((null (get-chunk chunk-name))
             (print-warning 
              "overwrite-buffer-chunk called with an invalid chunk name ~S" 
              chunk-name))
            ((not (numberp time-delta))
             (print-warning 
              "overwrite-buffer-chunk called with a non-number time-delta: ~S"
              time-delta))
            ((and (not (numberp priority)) (not (eq priority :max)) 
                  (not (eq priority :min)))
             (print-warning 
              "overwrite-buffer-chunk called with an invalid priority ~S" 
              priority))
            (t
             (schedule-event-relative time-delta  'overwrite-buffer-chunk 
                                      :module module
                                      :priority priority 
                                      :params (list buffer-name chunk-name)
                                      :output output)))))))


(defun module-request (buffer-name chunk-spec)
  (verify-current-mp  
   "module-request called with no current meta-process."
   (verify-current-model
    "module-request called with no current model."
    (let ((buffer (buffer-instance buffer-name)))
      (cond ((null buffer)
             (print-warning 
              "module-request called with an invalid buffer name ~S" 
              buffer-name))
            ((null (act-r-chunk-spec-p chunk-spec))
             (print-warning 
              "module-request called with an invalid chunk-spec ~S"
              chunk-spec))
            (t
             (request-module (act-r-buffer-module buffer) buffer-name 
                             chunk-spec)))))))


(defun schedule-module-request (buffer-name chunk-spec time-delta 
                                &key (module :none) (priority 0)
                                (output 'medium) (details nil))

  (verify-current-mp  
   "schedule-module-request called with no current meta-process."
   (verify-current-model
    "schedule-module-request called with no current model."
    (let ((buffer (buffer-instance buffer-name)))
      (cond ((null buffer)
             (print-warning 
              "schedule-module-request called with an invalid buffer name ~S"
              buffer-name))
            ((null (act-r-chunk-spec-p chunk-spec))
             (print-warning 
              "schedule-module-request called with an invalid chunk-spec ~S" 
              chunk-spec))
            ((not (numberp time-delta))
             (print-warning 
              "schedule-module-request called with a non-number time-delta: ~S"
              time-delta))
            ((and (not (numberp priority)) (not (eq priority :max)) 
                  (not (eq priority :min)))
             (print-warning 
              "schedule-module-request called with an invalid priority ~S"
              priority))
            (t
             (schedule-event-relative time-delta  'module-request 
                                      :module module
                                      :priority priority 
                                      :params (list buffer-name chunk-spec)
                                      :details
                                      (if (stringp details)
                                          details
                                        (concatenate 'string
                                        (symbol-name 'module-request)
                                        " "
                                        (symbol-name buffer-name)))
                                      
                                      :output output)))))))

(defun module-mod-request (buffer-name modification)
  (verify-current-mp  
   "module-mod-request called with no current meta-process."
   (verify-current-model
    "module-mod-request called with no current model."
    (let ((buffer (buffer-instance buffer-name)))
      (cond ((null buffer)
             (print-warning 
              "module-mod-request called with an invalid buffer name ~S" 
              buffer-name))
            ((null (act-r-buffer-chunk buffer))
             (print-warning 
              "module-mod-request called with no chunk in buffer ~s"
              buffer-name))
            ((null (valid-chunk-modification 
                    (act-r-buffer-chunk buffer) modification))
             (print-warning 
              "module-mod-request called with an invalid modification ~S"
              modification))
            (t
             (buffer-mod-module 
              (act-r-buffer-module buffer) buffer-name modification)))))))


(defun schedule-module-mod-request (buffer-name modification time-delta 
                                &key (module :none) (priority 0)
                                                (output 'medium))
  (verify-current-mp  
   "schedule-module-mod-request called with no current meta-process."
   (verify-current-model
    "schedule-module-mod-request called with no current model."
    (let ((buffer (buffer-instance buffer-name)))
      (cond ((null buffer)
             (print-warning 
              "schedule-module-mod-request called with invalid buffer name ~S"
              buffer-name))
            ((null (act-r-buffer-chunk buffer))
             (print-warning 
              "schedule-module-mod-request called with no chunk in buffer ~s"
              buffer-name))
            ((null (valid-chunk-modification 
                    (act-r-buffer-chunk buffer) modification))
             (print-warning 
              "module-mod-request called with an invalid modification ~S"
              modification))
            ((not (numberp time-delta))
             (print-warning 
              "~s called with a non-number time-delta: ~S" 
              'schedule-module-mod-request time-delta))
            ((and (not (numberp priority)) (not (eq priority :max)) 
                  (not (eq priority :min)))
             (print-warning 
              "schedule-module-mod-request called with an invalid priority ~S"
              priority))
            (t
             (schedule-event-relative time-delta  'module-mod-request 
                                      :module module
                                      :priority priority 
                                      :params (list buffer-name modification)
                                      :details
                                      (concatenate 'string
                                        (symbol-name 'module-mod-request)
                                        " "
                                        (symbol-name buffer-name))
                                      
                                      :output output)))))))


(defun mod-buffer-chunk (buffer-name modifications)
  (verify-current-mp  
   "mod-buffer-chunk called with no current meta-process."
   (verify-current-model
    "mod-buffer-chunk called with no current model."
    (let ((buffer (buffer-instance buffer-name)))
      (cond ((null buffer)
             (print-warning 
              "mod-buffer-chunk called with an invalid buffer name ~S" 
              buffer-name))
            ((null (act-r-buffer-chunk buffer))
             (print-warning 
              "mod-buffer-chunk called with no chunk in buffer ~s" 
              buffer-name))
            ((null (valid-chunk-modification 
                    (act-r-buffer-chunk buffer) modifications))
             (print-warning 
              "mod-buffer-chunk called with an invalid modification ~S" 
              modifications))
            (t 
             (fast-mod-chunk-fct (act-r-buffer-chunk buffer) modifications)))))))
            

(defun schedule-mod-buffer-chunk (buffer-name modifications time-delta 
                                &key (module :none) (priority 0)
                                (output 'low))
  (verify-current-mp  
   "schedule-mod-buffer-chunk called with no current meta-process."
   (verify-current-model
    "schedule-mod-buffer-chunk called with no current model."
    (let ((buffer (buffer-instance buffer-name)))
      (cond ((null buffer)
             (print-warning 
              "schedule-mod-buffer-chunk called with an invalid buffer name ~S"
              buffer-name))
            ((null (act-r-buffer-chunk buffer))
             (print-warning 
              "mod-buffer-chunk called with no chunk in buffer ~s" 
              buffer-name))
            ((null (valid-chunk-modification 
                    (act-r-buffer-chunk buffer) modifications))
             (print-warning 
              "schedule-mod-buffer-chunk called with an invalid modification ~S"
              modifications))
            ((not (numberp time-delta))
             (print-warning 
              "schedule-mod-buffer-chunk called with non-number time-delta: ~S"
              time-delta))
            ((and (not (numberp priority)) (not (eq priority :max)) 
                  (not (eq priority :min)))
             (print-warning 
              "schedule-mod-buffer-chunk called with an invalid priority ~S"
              priority))
            (t
             (schedule-event-relative time-delta  'mod-buffer-chunk 
                                      :module module
                                      :priority priority 
                                      :params (list buffer-name modifications)
                                      :details 
                                      (concatenate 'string
                                        (symbol-name 'mod-buffer-chunk)
                                        " "
                                        (symbol-name buffer-name))
                                      :output output)))))))
 
  
(defun valid-chunk-modification (chunk-name modifications)
  
  
  (let ((c (get-chunk chunk-name)))
    (when c
      (if (oddp (length modifications))
          nil
        (let ((slots nil)
              (slots-and-values nil))
          (do ((s modifications (cddr s)))
              ((null s))
            (push (car s) slots)
            (push (list (car s) (second s)) slots-and-values))
          (and (every #'(lambda (slot)
                          (valid-slot-name slot 
                                           (act-r-chunk-chunk-type c)))
                             slots)
               (= (length slots) (length (remove-duplicates slots)))))))))

   
(defun buffer-spread (buffer-name)
  (verify-current-mp  
   "buffer-spread called with no current meta-process."
   (verify-current-model
    "buffer-spread called with no current model."
    (let ((buffer (buffer-instance buffer-name)))
      (cond ((null buffer)
             (print-warning 
              "buffer-spread called with an invalid buffer name ~S" 
              buffer-name))
            (t
             (car (no-output 
                   (sgp-fct 
                    (list (act-r-buffer-parameter-name buffer)))))))))))


(defun buffers-module-name (buffer-name)
  (let ((buffer (buffer-instance buffer-name)))
      (cond ((null buffer)
             (print-warning 
              "invalid buffer name ~S" buffer-name))
            (t
             (let ((module (act-r-buffer-module buffer)))
                   (if module
                       module
                     (print-warning 
                      "Could not find a module for buffer ~S"
                      buffer-name)))))))

#|
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 2.1 of the License, or (at your option) any later version.

This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
Lesser General Public License for more details.

You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
|#

;;; file: actr6/support/central-parameters.lisp

;;;  -*- mode: LISP; Syntax: COMMON-LISP;  Base: 10 -*-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 
;;; Author      : Dan Bothell
;;; Copyright   : (c) 2004 Dan Bothell
;;; Availability: Covered by the GNU LGPL, see LGPL.txt
;;; Address     : Department of Psychology 
;;;             : Carnegie Mellon University
;;;             : Pittsburgh, PA 15213-3890
;;;             : db30@andrew.cmu.edu
;;; 
;;; 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 
;;; Filename    : central-parameters.lisp
;;; Version     : 1.0
;;; 
;;; Description : A module to hold parameters that could be used by more than
;;;               one module.
;;; 
;;; Bugs        : 
;;;
;;; To do       : 
;;; 
;;; ----- History -----
;;;
;;; 2004.10.17 Dan
;;;             : Creation.
;;; 2005.01.09 Dan
;;;             : Moved the provide to the end.
;;; 2006.01.17 Dan
;;;             : * Updated the version to 1.0 and modified the description.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; General Docs:
;;; 
;;; Creates a module to hold some of the critical parameters that may
;;; be used by multiple modules:
;;;
;;; :esc Enable Subsymbolic Computation
;;; :ol  Optimized Learning
;;; :er  Enable Randomness
;;;
;;; 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Public API:
;;;
;;; The three parameters :esc :ol and :er.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Design Choices:
;;; 
;;; 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 
;;; The code
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

#+:packaged-actr (in-package :act-r)
#+(and :clean-actr (not :packaged-actr) :ALLEGRO-IDE) (in-package :cg-user)
#-(or (not :clean-actr) :packaged-actr :ALLEGRO-IDE) (in-package :cl-user)


(defstruct central-parameters
  esc ol er)


(defun create-central-params (model-name)
  (declare (ignore model-name))
  (make-central-parameters))

(defun central-parameters-params (instance param)
  (cond ((consp param)
         (case (car param)
           (:esc (setf (central-parameters-esc instance) (cdr param)))
           (:ol (setf (central-parameters-ol instance) (cdr param)))
           (:er (setf (central-parameters-er instance) (cdr param)))))
        (t
         (case param
           (:esc (central-parameters-esc instance))
           (:ol (central-parameters-ol instance))
           (:er (central-parameters-er instance))))))

(define-module-fct 'central-parameters nil
  (list
   (define-parameter :esc :owner t :valid-test #'tornil :default-value nil
     :warning "either t or nil" :documentation "Enable Subsymbolic Computations")
   (define-parameter :er :owner t :valid-test #'tornil :default-value nil
     :warning "either t or nil" :documentation "Enable Randomness")
   (define-parameter :ol :owner t :valid-test #'(lambda (x) (or (tornil x) (posnum x)))
     :default-value t :warning "either t, nil, or a positive number"
     :documentation "Optimized Learning"))
  :version "1.0"
  :documentation "a module that maintains parameters used by other modules"
  :creation #'create-central-params
  :params #'central-parameters-params)


(provide "CENTRAL-PARAMETERS")

#|
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 2.1 of the License, or (at your option) any later version.

This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
Lesser General Public License for more details.

You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
|#

;;; actr6/support/CFBundle.lisp

;;;-*- Mode: Lisp; Package: COMMON-LISP-USER -*-

(in-package "CL-USER")

;;; See the sample code at:
;;; http://developer.apple.com/samplecode/Sample_Code/Runtime_Architecture/CallMachOFramework.htm
;;; This is The Official Way to open and use Mach-O libraries from CFM
;;; Carbon applications.  -gb 2/21/02
;;; (Revised slightly, since MCL's interface files now define
;;; more constants and entrypoints than they once did) -gb 11/12/02


;;; Define some shared-library entrypoints for symbols that don't seem
;;; to be in the interface files.  There may be a better way to do this;
;;; if I ever knew it, I've forgotten.


(defvar *__cfstringmakeconstantstring-slep*
  (ccl::get-slep "__CFStringMakeConstantString"))

(defun cfstr (string)
  (with-cstrs ((cstr string))
    (ccl::ff-call-slep *__CFStringMakeConstantString-slep*
                       :address cstr 
                       :address)))

(defun create-frameworks-url ()
  (rlet ((fsref :fsref))
    (let* ((err (#_FSFindFolder #$kOnAppropriateDisk #$kFrameworksFolderType #$true fsref)))
      (declare (type (signed-byte 16) err))
      (if (eql #$noErr err)
        (let* ((url (#_CFURLCreateFromFSRef (%null-ptr) fsref)))
          (if (%null-ptr-p url)
            (error "Failed to create URL")
            url))
        (error "Couldn't find system Frameworks folder")))))

(ccl::defloadvar *frameworks-url* nil)

(defun frameworks-url ()
  (or *frameworks-url*
      (setq *frameworks-url* (create-frameworks-url))))

(defun load-framework-bundle (framework-name)
  (let* ((bundle-url 
          (#_CFURLCreateCopyAppendingPathComponent
           (%null-ptr)
           (frameworks-url)    ; file:///System/Library/Frameworks/
           (CFSTR framework-name)
           #$false)))
    (if (%null-ptr-p bundle-url)
      (error "Can't create URL for ~s in system frameworks folder" 
             framework-name)
      (let* ((bundle (#_CFBundleCreate (%null-ptr) bundle-url)))
        (if (%null-ptr-p bundle)
          (error "Can't create bundle for ~s" framework-name)
          (if (eql #$false (#_CFBundleLoadExecutable bundle))

            (error "Couldn't load bundle library for ~s" framework-name)
            bundle))))))
            

(ccl::defloadvar *system-framework-bundle* nil)

;;; Most BSD/Mach functions are in the System framework.
(defun system-framework-bundle ()
  (or *system-framework-bundle*
      (setq *system-framework-bundle*
            (load-framework-bundle "System.framework"))))


(defun lookup-function-in-framework (symbol-name &optional