;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;;  Here are all of the lisp files in actr 6
;;;
;;;  there is a main load file of ACT-R (load-act-r-6.lisp) at first.
;;;  then, all lisp files are listed alphabetically
;;;
;;; 
;;;
;;;  Date: 02-15-07
;;;  by JWK
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;;;===========================================================================
;;;    actr6/load-act-r-6.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    : load-act-r-6.lisp
;;; Version     : 1.0
;;; 
;;; Description : Top level loader for the whole ACT-R 6 system.
;;; 
;;; Bugs        : ???
;;;
;;; To do       : [-] Test in a variety of Lisps for issues with the
;;;             :     logical hostname stuff.
;;;             : [ ] Now, look into using the clisp version in other
;;;             :     lisps because it seems cleaner/more generic than
;;;             :     the ones I put toghether...
;;; 
;;; ----- History -----
;;;
;;; 2004.10.26 Dan
;;;             : Creation.
;;;             :
;;;             : Realized that require doesn't compile things automatically
;;;             : in all cases, so added my own require-compiled that does.
;;; 2004.12.10 Dan
;;;             : Fixed the make-package for the packaged version (for use
;;;             : with ACL at least).
;;;             : Reduced the lines to max of 80 chars.
;;; 2005.01.02 Dan
;;;             : Changed it so that it loads the "core modules" in a specific
;;;             : order and then all other modules.
;;; 2005.01.12 Dan
;;;             : * Added the tools directory to the set.
;;; 2005.01.23 Dan
;;;             : * Fixed the Lispworks binary extension check. Don't think it
;;;             :   still needs the old one...
;;; 2005.01.29 Dan
;;;             : * Added a feature check into compile-and-load to force it
;;;             :   to recompile if :actr-recompile is on the features list.
;;; 2005.02.01 Dan
;;;             : * This time, the Lispworks feature checks should be set
;;;             :   properly for OSX (thanks to Chris Sims).
;;; 2005.02.25 Dan
;;;             : * Removed the ~\newline usages because that causes problems
;;;             :   when a Lisp only wants to see native new lines there.
;;; 2005.04.14 Dan
;;;             : * Changed compile-and-load so that it throws an error if the
;;;             :   file it is passed has a non-"lisp" extension. - need to
;;;             :   verify that in other Lisps to make sure it works right.
;;; 2005.07.07 Dan
;;;             : * Fixed the packaged loading for Lispworks now too.
;;; 2005.08.10 Dan
;;;             : * Added a new directory to the set (commands) in place of
;;;             :   where modules was and then moved modules to after the
;;;             :   devices.
;;;             : * Now, there's basically a directory to auto-load in all
;;;             :   resonable locations, and I can better distribute files 
;;;             :   that were all jammed into tools.
;;;             : * Updated the version to 1.0.
;;; 2005.08.16 Dan
;;;             : * Added a flag to indicate whether things have been loaded
;;;             :   previously or not and actually throw an error if this
;;;             :   file is attempted to be loaded more than once.
;;; 2005.09.16 Dan
;;;             : * Added the appropriate feature checks to work "right" with
;;;             :   ACL 7's IDE i.e. load the devices and package things in
;;;             :   cg-user when necessary.
;;; 2005.10.18 Dan
;;;             : * Added the logical host setup for CMUCL.
;;;             : * Moved the smart-load function here and generalized it so
;;;             :   that framework and core-modules don't need to have 
;;;             :   their own special versions.
;;;             : * Also converted those specific loaders to essentially just
;;;             :   file lists now.
;;; 2005.11.01 Dan
;;;             : * Added a new compile-and-load so that things can be loaded
;;;             :   into MCL 5/5.1 (the versions that have the split open/load
;;;             :   Mac/Unix file menu options) without having to convert all
;;;             :   the files first.  This file needs to be loaded as a Unix
;;;             :   file and the rest should take care of itself.
;;; 2005.11.07 Dan
;;;             : * Realized that since the environment is loaded from tools
;;;             :   that there's no way to add patches to the environment
;;;             :   in an "auto load" directory because things in tools may
;;;             :   be loaded before the environment.  So, I've added yet
;;;             :   another directory from which files are loaded automatically.
;;;             :   The other-files directory is now scanned and .lisp files
;;;             :   are loaded as the last step of the load process.
;;; 2005.12.13 Dan
;;;             : * Changed the logical host setup for ACL because it turns
;;;             :   out that the host-namestring always ends up nil and doesn't
;;;             :   actually capture the drive info which causes problems if
;;;             :   the ACT-R sources are on a different drive than the ACL
;;;             :   assumed default.
;;; 2006.01.04 Dan
;;;             : * Added the switches so that it'll load under CMUCL in OS X
;;;             :   (with ppc).
;;; 2006.06.29 Dan
;;;             : * Added components provided by Don Morrison to allow it to be 
;;;             :   loaded into CLisp v2.38 - the CLisp logical host, tighter 
;;;             :   handling of the logical pathnames in general (other Lisps
;;;             :   didn't mind logical namestrings in places where a pathname
;;;             :   designator was required), and a shadowing of the CLisp
;;;             :   execute function.
;;; 2006.08.31 Dan
;;;             : * Replaced the *already-loaded-act-r-6-files* variable as
;;;             :   the reloading test with a feeature check for :act-r-6.0
;;;             :   which is now placed on the *features* list.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; General Docs:
;;; 
;;; Using logical pathnames a directory structure for ACT-R 6 can be created
;;; that allows users to add or remove files from a specific directory within
;;; the system, and through the use of require and provide also remove the
;;; need to edit a "load order" file.
;;;
;;; The organization has 5 directories in the act-r6 directory: 
;;;  - framework contains the core code of the system which has its own
;;;              load file and is not supposed to be modified by users
;;;  - devices contains folders to hold the specific device interface and uwi
;;;            files for a particular lisp
;;;            each supported lisp should have a directory in the device
;;;            directory that contains one or two files which should be 
;;;            named device.lisp and uwi.lisp.   The device.lisp file should
;;;            contain the appropriate device interface methods and the 
;;;            uwi.lisp
;;;            file should contain the specific GUI functions that support
;;;            the AGI (ACT-R GUI interface) calls.
;;;
;;;           NOTE: This is one thing that will require changing this
;;;                 load file to add the specific switch and directory name for
;;;                 a new device definition set.
;;;  - support this is where one should place files that may be needed by 
;;;            a particular module or for other special purposes.  These files
;;;            are only loaded when made explicit (or implicit with require).
;;;  - core-modules this is where the core modules of the system are located.
;;;            These modules are referenced explicitly in the loader and 
;;;            if they exist are loaded in a specified order.  They consist
;;;            of the modules that were part of ACT-R 5 (though not always
;;;            implemented that way): Declarative, Goal, Procedural, Vision,
;;;            Motor, Audio, and Speech.  They are loaded in that order if
;;;            they exist.
;;;  - modules this is where any other modules of the system are to be placed.
;;;            All files with a .lisp extension in this folder will be loaded
;;;            in no particular order.  Thus, there should be no dependencies
;;;            among these modules.  Any code that may be needed by more than
;;;            one module should go in the support directory where it can
;;;            be indicated with a require in the module file.
;;;          
;;;   See the declarative (in modules) and central-parameters (in support)
;;;   or vision (in modules) and dmi (in support) for examples of the require/
;;;   provide usage.  
;;;   
;;;   NOTE: require isn't necessairily going to compile the required file,
;;;   so using the require-compiled function below is recommended.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Public API:
;;;
;;; The logical hostname "ACT-R6" can be used as a relative reference for the
;;; directory where the ACT-R 6 folders are located.
;;;
;;;
;;; require-compiled (code-module pathname)
;;;
;;; code-module is a string that designates some code that needs to be loaded
;;;             which should have a corresponding (provide code-module)
;;; pathname is the pathname to where code-module can be found.
;;;
;;; Similar to the function require this will determine if the requested
;;; code-module has been loaded and if not will compile and load the file
;;; specified by pathname.  This differs from the normal require function
;;; in that the pathname is mandatory and it does not search through any
;;; implementation defaults to find the code-module.  However, it does still
;;; depend on a provide call existing in the code-module file so that
;;; it only loads the necessary file the first time it is required.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Design Choices:
;;; 
;;; The idea is for a system where people can just drop in new modules without
;;; having to edit or change any of the existing code.  In practice, that
;;; may not work all the time (with things like name conflicts) but should
;;; be useable.  Name conflicts could probably be eliminated through some
;;; sort of module packaging scheme, but that seems to complicate module
;;; creation and could lead to some potentially nasty debugging issues.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 
;;; The code
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

#+:packaged-actr (make-package :act-r 
                               :use '("COMMON-LISP-USER" 
                                      #+:lispworks "COMMON-LISP"
                                      #+:allegro "COMMON-LISP"
                                      #+:allegro "EXCL"
                                      #+:allegro-ide "COMMON-GRAPHICS-USER"
                                      #+:common-graphics "COMMON-GRAPHICS-USER"))


;;; Basically a hack for ACL 7 so that I don't have to touch every file!

(eval-when (:compile-toplevel :load-toplevel :execute)
  
  #+(and :allegro :ide (not :allegro-ide))
    (push :allegro-ide *features*))

#+: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)


#+:act-r-6.0 (error "The ACT-R 6 load file should only be loaded once.")
#-:act-r-6.0 (pushnew :act-r-6.0 *features*)


;; Clisp has an implementation-specific function execute that conflicts with
;; the generic function execute in ACT-R, so shadow it
#+:clisp (defpackage "COMMON-LISP-USER" (:shadow "EXECUTE"))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Create the logical host "ACT-R6" relative to the current location

#+:allegro (setf (logical-pathname-translations "ACT-R6")
             (list (list "**;*.*" (let ((name (namestring *load-truename*))
                                        (file (file-namestring *load-truename*)))
                                    (subseq name 0 (- (length name) (length file)))))))


#+:digitool (setf (logical-pathname-translations "ACT-R6")
  (list (list "**;*.*" (concatenate 'string
                         (host-namestring *load-truename*)
                         (directory-namestring *load-truename*) "**:"))))

#+:openmcl (setf (logical-pathname-translations "ACT-R6")
  (list (list "**;*.*" (concatenate 'string
                         (host-namestring *load-truename*)
                         (directory-namestring *load-truename*) "**/"))))

#+:lispworks (setf (logical-pathname-translations "ACT-R6")
               (list (list "**;*.*" 
                           (concatenate 'string
                             (format nil "~A" (make-pathname
                                               :host 
                                               (pathname-host *load-truename*)
                                               :directory 
                                               (pathname-directory 
                                                *load-truename*))) 
                             "**/*.*"))))

;; just copied the lispworks one for now...
#+:cmu (setf (logical-pathname-translations "ACT-R6")
               (list (list "**;*.*" 
                           (concatenate 'string
                             (format nil "~A" (make-pathname
                                               :host 
                                               (pathname-host *load-truename*)
                                               :directory 
                                               (pathname-directory 
                                                *load-truename*))) 
                             "**/*.*"))))

#+:clisp (setf (logical-pathname-translations "ACT-R6")
               `(("**;*.*" ,(namestring (merge-pathnames "**/*.*" *load-truename*)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; define the file extension (the pathname type) for compiled and source files
;;; in the currently supported systems

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

(unless (boundp '*.fasl-pathname*)
  (defvar *.fasl-pathname* 
    #+:allegro (make-pathname :type "fasl")
    #+:clisp (make-pathname  :type "fas")
    #+(and :linux :cmu) (make-pathname :type "x86f")
    #+(and :ppc :cmu) (make-pathname :type "ppcf")
    #+(and :lispworks :win32) (make-pathname :type "fsl")
    #+(and :lispworks :unix (not :macosx)) (make-pathname :type "ufsl")
    #+(and :lispworks :macosx) (make-pathname :type "nfasl")))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Define some functions for compiling and loading files

;;; compile-and-load (pathname)
;;;
;;; pathname a file pathname (or pathname string) if the file already
;;;          has a type specified, then it is ignored and the defaults
;;;          of lisp for source and system-dependent binary types are
;;;          used.
;;; 
;;; If a source file (.lisp) exists for the specified pathname then if there
;;; is no binary file (determined by *.fasl-pathname*), the binary is
;;; older than the source file, or the feature :act-r-recompile is set then 
;;; compile the source file into a binary and load it.  
;;;
;;; Based on the smart-load function from the ACT-R loader.


;;; Specific loader for the newer MCL 5/5.1

#+(and :ccl-4.3.5 :ccl-5.0) 
(defun compile-and-load (pathname)
  (when (pathname-type pathname) ;; throw away the type to allow for
                                 ;; the merging with a binary type
    (if (string-equal (pathname-type pathname) "lisp")
        (setf pathname (make-pathname :host (pathname-host pathname)
                                      :directory (pathname-directory pathname)
                                      :device (pathname-device pathname)
                                      :name (pathname-name pathname)))
      (error "To compile a file it must have a .lisp extension")))
  
  (let* ((srcpath (merge-pathnames pathname *.lisp-pathname*))
         (binpath (merge-pathnames pathname *.fasl-pathname*)))
    (unless (probe-file srcpath)
      (error "File ~S does not exist" srcpath))
    (when (or (member :actr-recompile *features*)
              (not (probe-file binpath))
              (> (file-write-date srcpath) (file-write-date binpath)))
      (compile-file srcpath :output-file binpath :external-format :unix))
    (load binpath)))
  
#-(and :ccl-4.3.5 :ccl-5.0) 
(defun compile-and-load (pathname)
  (when (pathname-type pathname) ;; throw away the type to allow for
                                 ;; the merging with a binary type
    (if (string-equal (pathname-type pathname) "lisp")
        (setf pathname (make-pathname :host (pathname-host pathname)
                                      :directory (pathname-directory pathname)
                                      :device (pathname-device pathname)
                                      :name (pathname-name pathname)))
      (error "To compile a file it must have a .lisp extension")))
  
  (let* ((srcpath (merge-pathnames pathname *.lisp-pathname*))
         (binpath (merge-pathnames pathname *.fasl-pathname*)))
    (unless (probe-file srcpath)
      (error "File ~S does not exist" srcpath))
    (when (or (member :actr-recompile *features*)
              (not (probe-file binpath))
              (> (file-write-date srcpath) (file-write-date binpath)))
      (compile-file srcpath :output-file binpath))
    (load binpath)))
  


;;; SMART-LOAD      [Function]
;;; Date        : 99.12.21
;;; Description : Loads binary version of a specified file.  Of course, the 
;;;             : said binary version might not exist or be older than the 
;;;             : source version, in which case the source file is compiled 
;;;             : before loading.
;;;             : Updated to add an option parameter to determine whether
;;;             : to just warn of a missing file or to throw an error.


(defun smart-load (this-files-dir file &optional (error? nil))
  "Loads binary <file> in directory <this-files-dir> or compiles and loads 
   source version"
  (let* ((srcpath (merge-pathnames  
                   (merge-pathnames file *.lisp-pathname*)
                   this-files-dir))
         )
    (if (not (probe-file srcpath))
        (if error? 
            (error "File ~S does not exist" srcpath)
          (format *error-output* "File ~S does not exist" srcpath)))
    (compile-and-load srcpath)))


;;; require-compiled (code-module pathname)
;;;
;;; code-module is a string that designates some code that needs to be loaded
;;;             which should have a corresponding (provide code-module) in it
;;; pathname is the pathname to where that code-module can be found (including
;;;          the file's name).
;;;
;;; Similar to the function require this will determine if the requested
;;; code-module has been loaded and if not will compile and load the file
;;; specified by pathname.  This differs from the normal require function
;;; in that the pathname is mandatory and it does not search through any
;;; implementation defaults to find the code-module.  However, it does still
;;; depend on a provide call existing in the code-module file so that
;;; it only loads the necessary file the first time it is required.

(defmacro require-compiled (code-module pathname)
  `(eval-when (:compile-toplevel :load-toplevel :execute)
     (unless (member ,code-module *modules* :test #'string=)
       (compile-and-load (translate-logical-pathname ,pathname)))))                       


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; load any special system support files here

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

#+:ccl-5.0
(when (osx-p)
  (load "ACT-R6:support;CFBundle.lisp"))

#+:allegro (when (or (eq :case-sensitive-lower *current-case-mode*)
                     (eq :case-sensitive-upper *current-case-mode*))
             (unless 
                 (yes-or-no-p 
                  "WARNING: you are using a case sensitive Lisp.  ACT-R may not load or run correctly.  Continue anyway?")
               (break)))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Load the framework's loader file (it is order dependent)

(smart-load (translate-logical-pathname "ACT-R6:framework;") "framework-loader.lisp")

(dolist (the-file *file-list)
  (smart-load (translate-logical-pathname "ACT-R6:framework;") the-file t))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Load the core modules 

(smart-load (translate-logical-pathname "ACT-R6:core-modules;") "core-loader.lisp")

(dolist (the-file *file-list)
  (smart-load (translate-logical-pathname "ACT-R6:core-modules;") the-file))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 
;;; First, load any additional extensions.

(dolist (file (directory (logical-pathname "ACT-R6:commands;*.lisp")))
  (compile-and-load file))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Indicate that there is a device available so that it can be loaded 
;;; When a new device is added it should be included with a switch below

(defvar *device-interface-pathname* nil)

;;; Here are the devices that are defined

#+:allegro-ide (setf *device-interface-pathname* "ACT-R6:devices;acl;")

#+:digitool (setf *device-interface-pathname* "ACT-R6:devices;mcl;")


;;; Load the virtual device

(compile-and-load (logical-pathname "ACT-R6:devices;virtual;device.lisp"))
(compile-and-load (logical-pathname "ACT-R6:devices;virtual;uwi.lisp"))

;;; Load any Lisp specific device that's defined

(when *device-interface-pathname*
  (if (probe-file (merge-pathnames *device-interface-pathname* "device.lisp"))
      (compile-and-load (merge-pathnames *device-interface-pathname* 
                                         "device.lisp"))
    (format t 
        "################~%#### No Device file found in ~S ####~%##############"
      *device-interface-pathname*))
  (if (probe-file (merge-pathnames *device-interface-pathname* "uwi.lisp"))
      (compile-and-load (merge-pathnames *device-interface-pathname* 
                                         "uwi.lisp"))
    (format t 
        "#################~%#### No uwi file found in ~S ####~%################"
      *device-interface-pathname*)))
  

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; After the modules and devices files are done load any files in the 
;;; modules, tools and then finally the other-files drectories.

(dolist (file (directory (logical-pathname "ACT-R6:modules;*.lisp")))
  (compile-and-load file))

(dolist (file (directory (logical-pathname "ACT-R6:tools;*.lisp")))
  (compile-and-load file))

(dolist (file (directory (logical-pathname "ACT-R6:other-files;*.lisp")))
  (compile-and-load file))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Print a conformation message to let the user know ACT-R has been loaded
;;; along with the version numbers of all the modules.

(format t "~%##################################~%")
(mp-print-versions )
(format t "~%######### Loading of ACT-R 6 is complete #########~%")



#|
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/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.
;;; 2006.09.07 Dan
;;;             : * Changed permute-list so that it's safe when passed nil or
;;;             :   a non-list.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

#+: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"
  (if (and (listp lis) lis)
      (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))
    nil))

;;; 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
|#

;;;============================================================================
;;; 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.2
;;; 
;;; Description : Source for RPM's Audition Module
;;; 
;;; Bugs        : * 
;;; 
;;; Todo        : * [x] Should there be audio buffer stuffing as well?
;;;             : * [ ] Add a set-audioloc-defaults command like the set-visloc-
;;;             :       default to give more control over stuffing so that
;;;             :       the :hear-newest-only parameter can go away.
;;;             : * [ ] Change the request function so that modifiers and ranges
;;;             :       are accepted and add pitch as an option (alternatively
;;;             :       convert the audicon over to holding chunks and use the
;;;             :       more general chunk matching tools...)
;;; 
;;; ----- 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). 
;;; 2006.03.24 Dan
;;;             : * Added a new parameter called :hear-newest-only and changed 
;;;             :   stuff-sound-buffer to include :onset :highest when that's
;;;             :   set because it seems like often one might want the newest 
;;;             :   sound to be the one that gets stuffed into the buffer. 
;;;             :   The default is nil to keep it compatible with the old
;;;             :   version for now, but should it default to t?
;;; 2006.05.03 Dan
;;;             : * Fixed a bug in pm-module-request for aural-location requests
;;;             :   in specifying the location (it was testing the onset slot.)
;;; 2006.05.03 Dan
;;;             : * Turns out that loc-failure and attend-failure weren't
;;;             :   really being set/cleared so add that in now.
;;; 2006.05.03 Dan
;;;             : * Fixed attend-sound so that it checks the current-audicon
;;;             :   so that old sounds get purged as needed.
;;; 2006.09.08 Dan
;;;             : * Changed several parameter tests from posnum to nonneg.
;;; 2006.11.20 Dan
;;;             : * Fixed the bug in stuff-sound-buffer because it should be
;;;             :   :onset 'highest not :highest...
;;;             : * Changed the version to 2.2 (dropped the a1) and updated the
;;;             :   doc string so that it doesn't say "first pass".
;;; 2006.12.20 Dan 
;;;             : * Changed the version in the class definition too...
;;; 2007.01.03 Dan
;;;             : * Changed the scheduling of the stuff-sound-buffer event
;;;             :   to :output nil and :maintenance t because the set-buffer-chunk 
;;;             :   ... requested nil shows that the stuffing occurs already - 
;;;             :   no point in two events showing for the same thing.
;;;             : * Also changed the test for the empty buffer slightly because
;;;             :   buffer-read is a bit of a hack for that purpose.
;;;             : * Took attended out of the audio-event chunk-type and made it
;;;             :   a request parameter instead (actually just started using the 
;;;             :   request parameter that was already there).
;;; 2007.01.04 Dan
;;;             : * Took the string column out of the audicon printing because
;;;             :   its going to be the same as content when it's provided.
;;;             : * Similarly, changed the content column to be printed with
;;;             :   ~s instead of ~a so that strings are differentiated from
;;;             :   symbols for content.
;;;             : * Added a column for detectable to the audicon printing.
;;;             : * Changed attend-sound to check exec-s instead of check-jam
;;;             :   because the attend-sound doesn't set the preparation state
;;;             :   to busy (which is what check-jam looks at).
;;;             : * Use randomize-time in scheduling the attend-sound-failure
;;;             :   event.
;;;             : * Removed the update function from the module definition
;;;             :   because it didn't do anything.
;;;             : * Fixed new-sound-event to better check for model/mp/module
;;;             :   and report a warning if not available - also switched the
;;;             :   return value to t/nil instead of returning the stuff-sound
;;;             :   scheduler event.
;;;             : * Converted the new-*-sound methods to functions so that
;;;             :   parameter validation is handled explicitly.  So that
;;;             :   ACT-R warnings can be printed instead of Lisp errors being
;;;             :   generated when invalid values are used (yes there are more
;;;             :   "CLOS-y" ways of doing it, but call me old fashioned...).
;;;             : * Took the optional instr parameter out of new-other-sound
;;;             :   because the string component of the sound-events doesn't
;;;             :   really have a purpose. [Or am I missing something?]
;;; 2007.01.10 Dan
;;;             : * Added location and kind optional parameters to new-other-sound.
;;;             : * Changed the call to get-articulation-time because the 
;;;             :   speech module is no longer needed as a parameter (though the
;;;             :   module itself still needs to exist).
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

#+: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)
   (stuff-newest :accessor stuff-newest-sound :initarg :stuff-newest
                 :initform nil))
  (:default-initargs
    :version-string "2.2"
    :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 (snd-string self))))
  (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)))
    (when evt
      (schedule-event (detect-at-time evt) 'stuff-sound-buffer
                      :module :audio
                      :destination :audio
                      :output nil
                      :maintenance t)
      t)))


(defun stuff-sound-buffer  (audio-mod) 
  (when (query-buffer 'aural-location '((buffer . empty)))
    (if (stuff-newest-sound audio-mod)
        (find-sound audio-mod :attended nil :stuffed t :onset 'highest)
      (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))
  (verify-current-mp 
   "No meta-process found.  Cannot create a new sound."
   (verify-current-model 
    "No current model found.  Cannot create a new sound."
    (aif (get-module :audio)
         (progn
           (push evt (audicon it))
           evt)
         (print-warning "No Audio module found.  Cannot create a new sound.")))))


(defun new-digit-sound (digit &optional (onset (mp-time)))
  "Creates and adds a digit sound <digit>, a number, starting optionally at <onset>."
  (verify-current-mp 
   "No meta-process found.  Cannot create a new sound."
   (verify-current-model 
    "No current model found.  Cannot create a new sound."
    (cond ((not (numberp digit))
           (print-warning "Digit must be a number.  No new digit sound created."))
          ((not (numberp onset))
           (print-warning "Onset must be a number.  No new digit sound created."))
          (t
           (new-sound-event (make-instance 'digit-sound-evt :onset (ms-round onset) :string digit)))))))


(defun new-tone-sound (freq duration &optional (onset (mp-time)))
  "Creates and adds a tone sound of <freq>, starting optionally at <onset>."
  (verify-current-mp 
   "No meta-process found.  Cannot create a new sound."
   (verify-current-model 
    "No current model found.  Cannot create a new sound."
    (cond ((not (numberp freq))
           (print-warning "Freq must be a number.  No new tone sound created."))
          ((not (numberp duration))
           (print-warning "Duration must be a number.  No new tone sound created."))
          ((not (numberp onset))
           (print-warning "Onset must be a number.  No new tone sound created."))
          (t
           (new-sound-event (make-instance 'tone-sound-evt :onset (ms-round onset) 
                              :duration duration :content freq)))))))

(defun new-other-sound (content duration delay recode 
                        &optional (onset (mp-time)) (location 'external) (kind 'speech))
  "Creates and adds a sound <content>, lasting <duration>, with content delay <delay>, with recode time <recode>, starting optionally at <onset>."
  (verify-current-mp 
   "No meta-process found.  Cannot create a new sound."
   (verify-current-model 
    "No current model found.  Cannot create a new sound."
    (cond ((not (numberp duration))
           (print-warning "Duration must be a number.  No new sound created."))
          ((not (numberp delay))
           (print-warning "Delay must be a number.  No new sound created."))
          ((not (numberp recode))
           (print-warning "Recode must be a number.  No new sound created."))
          ((not (numberp onset))
           (print-warning "Onset must be a number.  No new sound created."))
          (t
           (new-sound-event (make-instance 'sound-event :onset (ms-round onset) 
                              :duration duration :content content 
                              :delay delay :recode recode :location location
                              :kind kind)))))))

(defun new-word-sound (word &optional (onset (mp-time)) (location 'external))
  "Creates and adds a word with optional onset time."
  (verify-current-mp 
   "No meta-process found.  Cannot create a new sound."
   (verify-current-model 
    "No current model found.  Cannot create a new sound."
    (cond ((not (stringp word))
           (print-warning "Word must be a string.  No new word sound created."))
          ((not (numberp onset))
           (print-warning "Onset must be a number.  No new word sound created."))
          (t
           (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))))
    
    (setf (loc-failure aud-mod) nil)
    
    ;; 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 :destination :audio 
                               :output 'medium :details "find-sound-failure"))))

(defun find-sound-failure (audio)
  "function to indicate a failure in the trace and set the error flag"
  (setf (loc-failure audio) t)
  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)
  (if (eq (exec-s aud-mod) 'BUSY)
    (pm-warning "Auditory attention shift requested at ~S while one was already in progress."
                (mp-time))
    (progn
  
    ;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) (current-audicon aud-mod)
                         :test #'(lambda (x y) (eq x (ename y))))))
      
      (setf (attend-failure aud-mod) nil)
      (change-state aud-mod :exec 'busy)
      
      (if s-event ;; add in a test to make sure - could have a failure
          (progn
            (setf (attended-p s-event) t)
            (setf (current-marker aud-mod) s-event)
            (queue-command
             :time (recode s-event) :where :AUDIO :command 'audio-encoding-complete
             :randomize t :params s-event))
        (progn
          ;; assume digit delay for a failure
          (schedule-event-relative (randomize-time (digit-recode-delay aud-mod))
                                   #'attend-sound-failure
                                   :module :audio
                                   :destination :audio
                                   :output 'medium
                                   :details "attend-sound-failure")))))))


(defun attend-sound-failure (audio)
  "Flag that an error occured"
  (setf (attend-failure audio) t)
  (change-state audio :exec 'free))

#|
;;; 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 
                   `(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 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)
  
  ;; handle the failure flags
  
  (setf (loc-failure instance) nil)
  (setf (attend-failure 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 :attended)
                            :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 'location) 
                            (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))))
          ;(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)))
      (:hear-newest-only
       (setf (stuff-newest-sound 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))
      (:hear-newest-only
       (stuff-newest-sound aud-mod)))))
      

(define-module-fct :audio 
    (list (list 'aural-location nil '(:attended) 
                '(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 #'nonneg
     :default-value 0.3
     :warning "a non-negative number"
     :documentation "Lag between onset and detectability for digits")
   (define-parameter :digit-duration
     :valid-test #'nonneg
     :default-value 0.6
     :warning "a non-negative number"
     :documentation "Default duration for digit sounds.")
   (define-parameter :digit-recode-delay
     :valid-test #'nonneg
     :default-value 0.5
     :warning "a non-negative number"
     :documentation "Recoding delay for digit sound content.")
   (define-parameter :sound-decay-time
     :valid-test #'nonneg
     :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 #'nonneg
     :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 #'nonneg
     :default-value 0.285
     :warning "a non-negative number"
     :documentation "Recoding delay for tone sound content.")
   (define-parameter :hear-newest-only
     :valid-test #'tornil
     :default-value nil
     :warning "T or nil"
     :documentation "Whether to stuff only the newest unattended audio-event from the audicon into the aural-location buffer."))
  :version "2.2"
  :documentation "A module which gives the model an auditory attentional system"
  :creation #'(lambda (x) (declare (ignore x))
               (make-instance 'audio-module))
  :reset #'reset-audio-module
  :query #'query-audio-module
  :request #'pm-module-request
  :params #'params-audio-module
  ;:update #'update-module
  )

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

(defun print-audicon ()
  (let ((module (get-module :audio)))
    (if module
        (progn
          (format t "~%Sound event    Att  Detectable  Kind           Content           location     onset     offset  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 "~%~15a~5A~12A~15A~18s~10a~8,3f   ~8,3f  ~a"
    (ename feat)
    (attended-p feat)
    (detectable-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
|#

;;;============================================================================
;;; 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
|#

;;;============================================================================
;;; 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...
;;; 2006.07.16 Dan
;;;             : * Fixed an issue with buffer-chunk-fct because now that
;;;             :   more chunk accessors print a warning for nil it has to
;;;             :   be more careful to avoid lots of warnings.
;;; 2006.11.20 Dan
;;;             : * Added require-module-warning? and module-warning to support
;;;             :   the warning mechanism added to the modules.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; 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
                                (when 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-warning (buffer-name chunk-type)
  (verify-current-mp  
   "module-warning called with no current meta-process."
   (verify-current-model
    "module-warning called with no current model."
    (let ((buffer (buffer-instance buffer-name)))
      (cond ((null buffer)
             (print-warning "module-warning called with an invalid buffer name ~S" buffer-name))
            ((null (chunk-type-p-fct chunk-type))
             (print-warning "module-warning called with an invalid chunk-type ~S" chunk-type))
            (t
             (warn-module (act-r-buffer-module buffer) buffer-name chunk-type)))))))


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


(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
|#

;;;============================================================================
;;; 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.
;;; 2006.07.18 Dan
;;;             : * Changed schedule-maintenance-event-relative to just
;;;             :   schedule-event-relative because maintenance is now just a 
;;;             :   keyword in all of the scheduling functions.
;;; 2006.09.11 Dan
;;;             : * Changed the parameter test for the trace step to just be posnumornil.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; 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-event-relative (btm-time-step btm)
                                     'buffer-trace-time-step-event
                                     :maintenance t
                                     :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 #'posnumornil
          :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
|#

;;;============================================================================
;;; actr6/framework/chunks.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    : chunks.lisp
;;; Version     : 1.0
;;; 
;;; Description : Definition of chunks and the function that manipulate them.
;;; 
;;; Bugs        : 
;;;
;;; To do       : * Finish the documentation.
;;;             : * This one is a big target for benchmarking and optimizing.
;;;             : * Should merge-chunks impact chunk-copied-from?
;;; ----- History -----
;;;
;;; 2004.09.02 Dan
;;;             : Creation
;;; 2005.01.16 Dan
;;;             : * Added chunk-copied-from.
;;;             : * Reduced most things to 80 columns (I don't want to split
;;;             :   the format string because I've had problems with the ~
;;;             :   new-line breaking with "non-native" line endings).
;;;             : * Added doc strings.
;;;             : * Modified pprint-a-chunk so it can print with or without
;;;             :   the parameters.
;;;             : * Removed the print-chunk-type function since I don't want to
;;;             :   hide the structure since users shouldn't see them anyway.
;;; 2005.01.17 Dan
;;;             : * Switched to using command-output for printing.
;;;             : * Renamed pprint-chunk pprint-chunkS and took away its
;;;             :   printing of chunk parameters and added pprint-chunks-plus 
;;;             :   to display chunks with chunk parameters. 
;;; 2005.01.21 Dan
;;;             : * Updated merge-chunks-fct to work more efficiently.
;;; 2005.01.24 Dan
;;;             : * Fixed some bugs I introduced with the changes to pprint-
;;;             :   chunks and pprint-chunks-plus - I changed their return 
;;;             :   value which broke other things...
;;; 2005.02.04 Dan
;;;             : * Added the fast-* chunk accessors to eliminate the 
;;;             :   excessive calling of valid-slot-name.
;;; 2005.02.09 Dan
;;;             : * Fixed a bug that the fast-* stuff introduced with respect
;;;             :   to printing chunks.
;;; 2005.02.11 Dan
;;;             : * Some general clean up in define-chunks-fct.
;;; 2005.03.24 Dan
;;;             : * Changed the pprint-a-chunk function because it turns out
;;;             :   that some Lisps don't like using the pre-formatted format
;;;             :   string with the ~? directive.
;;; 2005.03.25 Dan
;;;             : * Changed pprint-a-chunk so that the slots print in the
;;;             :   same order as the chunk-type.
;;; 2005.04.01 Dan
;;;             : * Added true-chunk-name to help with an issue in merging
;;;             :   and may want to use it in printing and elsewhere...
;;; 2005.04.07 Dan
;;;             : * Fixed a minor issue with define-chunks and how it creates
;;;             :   the name for a chunk without one specified.
;;; 2005.05.07 Dan
;;;             : * Changed copy-chunk-fct so that instead of naming the new
;;;             :   chunk based on the chunk-type it bases it on the actual
;;;             :   name of the chunk being copied.  I think this is easier
;;;             :   to follow in the traces, but maybe it's more confusing.
;;;             :   We'll find out from experience I guess and then determine
;;;             :   which is better...
;;; 2005.06.11 Dan
;;;             : * DOH!  I remember again why I used the chunktype for the
;;;             :   name of the copy - because vision for example uses things
;;;             :   like loc1 which now when copied ends up as loc10 which
;;;             :   of course looks like "loc"+"10" instead of "loc1"+"0".
;;;             :   So, I've changed it so that it adds a - between the
;;;             :   chunk's name and the number so that would be loc1-0.             
;;; 2005.08.10 Dan
;;;             : * Minor clean-up in define-chunks to remove unused variables
;;;             :   in the let.
;;;             : * Updated version to 1.0.
;;; 2005.09.14 Dan
;;;             : * Fixed a bug in the output of a warning in define-chunks-fct
;;;             :   because invalid slot names weren't printed.
;;; 2005.11.17 Dan
;;;             : * Fixed some bugs in define-chunks-fct and pprint-a-chunk
;;;             :   related to default slot values in the chunk-type.
;;; 2006.01.03 Dan
;;;             : * Modified extend-chunks to remove the explicit compile call
;;;             :   (but still result in a compiled function at all times) to
;;;             :   hopefully get around the CMUCL issue.
;;; 2006.01.18 Dan
;;;             : * Modified the chunk printing function so that it can suppress
;;;             :   the "unfilled" extended slots of a chunk if desired.
;;; 2006.02.20 Dan
;;;             : * Fixed a bug in extend-chunks that causes problems with chunk 
;;;             :   parameters when merged when the ACT-R is both compiled and
;;;             :   loaded in the same session i.e. if one loads a previously
;;;             :   compiled version there's no problem so it shouldn't have
;;;             :   caused too many problems.
;;; 2006.07.06 Dan
;;;             : * Fixed a bug in define-chunks-fct.  When a chunk-type 
;;;             :   specified a default value for a slot which was a symbol (thus
;;;             :   interepreted as a chunk name) nothing ever created such a
;;;             :   chunk if it wasn't defined.  It doesn't make sense to do it
;;;             :   at the time of the chunk-type definition (because you may not
;;;             :   be able to create the chunk you want first) so it now happens
;;;             :   when such a slot value gets set (just like it does for any
;;;             :   non-chunk name symbols in the specified chunk slots).
;;; 2006.07.10 Dan
;;;             : * Added get-chunk-warn for use in several of the "user" functions
;;;             :   because they don't provide a warning if the chunk-name is
;;;             :   invalid, but since get-chunk is used for other purposes, 
;;;             :   I don't want to change it directly.
;;;             : * Added changed true-chunk-name to true-chunk-name-fct and
;;;             :   added a macro for true-chunk-name to make it user accessible.
;;; 2006.07.11 Dan
;;;             : * Made merge-chunks "safe" because previously it would merge
;;;             :   un-equal chunks as long as both items were really chunks.
;;;             :   Didn't cause problems since DM did the check first anyway,
;;;             :   but may be an issue if other modules were to use it.
;;; 2006.08.08 Dan
;;;             : * Put a test into define-chunks-fct so that it doesn't result
;;;             :   in errors for malformed add-dm/define-chunks calls, but just
;;;             :   prints a warning.
;;; 2006.10.10 Dan
;;;             : * Added the normalize-chunk-names command which goes through
;;;             :   all of the model's chunks and replaces any refrence to a
;;;             :   chunk name in a slot with the chunk's "true" name and then
;;;             :   optionally releases any non-true name i.e. the name that
;;;             :   was "merged away".  Generally, this probably won't see 
;;;             :   much use, but cleaning up the references may be useful at
;;;             :   times, and if a model creates so many names that the symbol
;;;             :   table becomes a memory limiter clearing those out maybe
;;;             :   necessary.
;;; 2006.10.17 Dan
;;;             : * Minor bug fix in normalize-chunk-names for the unintern 
;;;             :   clause.
;;; 2006.10.20 Dan
;;;             : * More clean-up added to normalize-chunk-names - should free
;;;             :   up more memory in the unintern case now.
;;; 2007.01.04 Dan
;;;             : * Minor tweak to chunk-copied-from-fct to make sure that the
;;;             :   "copied-from" chunk still exists - which may not be the case
;;;             :   for something like a goal or imaginal requests which delete 
;;;             :   the original.
;;; 2007.01.15 Dan
;;;             : * Bug from that last update fixed - use chunk-p-fct instead
;;;             :   of chunk-p...
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; General Docs:
;;; 
;;; Globals and underlying chunk structures are not for general use.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; 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)


#| Don't want to hide this anymore
(defun print-chunk (chunk stream depth)
  "Print a chunk as just its name."
  (declare (ignore depth))
  (format stream "~A" (act-r-chunk-name chunk)))
|#

(defvar *chunk-parameters-list* nil 
  "Internal list of parameters that have been added to chunks")

(defun chunk-parameter-default (param chunk-name)
  "Return a default value for a parameter in a chunk"
  (if (act-r-chunk-parameter-default-function param)
      (funcall (act-r-chunk-parameter-default-function param) chunk-name)
    (act-r-chunk-parameter-default-value param)))


(defconstant *pprint-chunk-string*
    (formatter 
     "~S~:[ (~s)~;~*~]~%~@[~S~%~]  ISA ~S~%~:{   ~s  ~s~%~}")
  "compiled format string for printing chunks")

(defconstant *pprint-chunk-parameters-string*
    (formatter "~@[  --chunk parameters--~%~:{   ~s  ~s~%~}~]~%")
  "compiled format string for printing chunk parameters")

(defun pprint-a-chunk (chunk-name &optional (w-params t))
  "Internal function for printing a chunk"
  (let ((chunk (get-chunk chunk-name)))
    (if chunk
        (progn
          (command-output
           (format nil
               *pprint-chunk-string*
             chunk-name
             (eql chunk-name (act-r-chunk-name chunk))
             (act-r-chunk-name chunk)
             (act-r-chunk-documentation chunk)
             (act-r-chunk-type-name (act-r-chunk-chunk-type chunk))  
             (mapcan #'(lambda (slot-name) 
                         (multiple-value-bind (value exists) (gethash slot-name (act-r-chunk-slot-value-lists chunk))
                             (when (or exists
                                       (car (no-output (sgp-fct (list :show-all-slots))))
                                       (not (extended-slot-name-p slot-name
                                                                  (act-r-chunk-type-name (act-r-chunk-chunk-type chunk)))))
                               (list (list slot-name value)))))
               (ct-slot-names (act-r-chunk-chunk-type chunk)))
             ))
          (when w-params
            (command-output
             (format nil *pprint-chunk-parameters-string*
               (mapcar #'(lambda (param)
                           (list (act-r-chunk-parameter-name param)
                                 (funcall (act-r-chunk-parameter-accessor param) 
                                          chunk-name)))
                 *chunk-parameters-list*)))
            
            )
          chunk-name)
      
      :error)))

(defmacro pprint-chunks (&rest chunk-names)
  "Print the chunks"
  `(pprint-chunks-fct ',chunk-names))

(defun pprint-chunks-fct (&optional chunk-names-list)
  "Print the chunks"
  (verify-current-mp  
   "pprint-chunks called with no current meta-process."
   (verify-current-model
    "pprint-chunks called with no current model."
    (let ((res nil))
      (dolist (chunk (if (null chunk-names-list) (chunks) chunk-names-list) res)
        (push-last (pprint-a-chunk chunk nil) res))))))

  
(defmacro pprint-chunks-plus (&rest chunk-names)
  "Print the chunks and their chunk parameters"
  `(pprint-chunks-plus-fct ',chunk-names))

(defun pprint-chunks-plus-fct (&optional chunk-names-list)
  "Print the chunks and their parameters"
  (verify-current-mp  
   "pprint-chunks-plus called with no current meta-process."
   (verify-current-model
    "pprint-chunks-plus called with no current model."
    (let ((res nil))
      (dolist (chunk (if (null chunk-names-list) (chunks) chunk-names-list) res)
        (push-last (pprint-a-chunk chunk t) res))))))


(defun chunks ()
  "Returns a list of the names of all currently defined chunks"
  (verify-current-mp  
   "chunks called with no current meta-process."
   (verify-current-model
    "chunks called with no current model."
    (hash-table-keys (act-r-model-chunks-table (current-model-struct))))))

(defun get-chunk (name)
  "Internal function for getting the chunk structure from its name"
  (verify-current-mp  
   "get-chunk called with no current meta-process."
   (verify-current-model
    "get-chunk called with no current model."
    (gethash name (act-r-model-chunks-table (current-model-struct))))))


(defun get-chunk-warn (name)
  "Internal function for getting the chunk structure from its name"
  (verify-current-mp  
   "get-chunk called with no current meta-process."
   (verify-current-model
    "get-chunk called with no current model."
    (let ((c (gethash name (act-r-model-chunks-table (current-model-struct)))))
      (if c c
        (print-warning "~s does not name a chunk in the current model." name))))))

(defmacro chunk-p (chunk-name?)
  "Check a name to see if it names a chunk"
  `(chunk-p-fct ',chunk-name?))

(defun chunk-p-fct (chunk-name?)
  "Check a name to see if it names a chunk"
  (if (get-chunk chunk-name?)
      t nil))


(defmacro chunk-chunk-type (chunk-name)
  "Return the name of the chunk-type for a chunk"
  `(chunk-chunk-type-fct ',chunk-name))

(defun chunk-chunk-type-fct (chunk-name)
  "Return the name of the chunk-type for a chunk"
    (let ((c (get-chunk-warn chunk-name)))
    (when c
      (act-r-chunk-type-name (act-r-chunk-chunk-type c)))))


(defmacro chunk-documentation (chunk-name)
  "Return the documentation string for a chunk"
  `(chunk-documentation-fct ',chunk-name))

(defun chunk-documentation-fct (chunk-name)
  "Return the documentation string for a chunk"
    (let ((c (get-chunk-warn chunk-name)))
    (when c
      (act-r-chunk-documentation c))))

  
(defun create-undefined-chunk (name)
  "Create a new chunk with the given name of chunk-type chunk with a warning"
  (model-warning "Creating chunk ~S of default type chunk" name)
  (define-chunks-fct (list (list name 'isa 'chunk))))


(defmacro copy-chunk (chunk-name)
  "Create a new chunk which is a copy of the given chunk"
  `(copy-chunk-fct ',chunk-name))

(defun copy-chunk-fct (chunk-name)
  "Create a new chunk which is a copy of the given chunk"
    (let ((chunk (get-chunk-warn chunk-name)))
    (when chunk
      (let ((new-chunk (make-act-r-chunk 
                        :name 
                        (new-name-fct 
                         
                         (concatenate 'string (symbol-name chunk-name) "-"))
                         ;;(act-r-chunk-type-name (act-r-chunk-chunk-type chunk)))
                        
                        :chunk-type (act-r-chunk-chunk-type chunk)
                        :slot-value-lists 
                        ; works with hash-tables, right?
                        ; NO! (copy-tree (act-r-chunk-slot-value-lists chunk))
                        (make-hash-table :size (hash-table-size (act-r-chunk-slot-value-lists chunk)))
                        )))
        
        ;; Copy the hash table 
        (maphash #'(lambda (key value)
                     (setf (gethash key (act-r-chunk-slot-value-lists new-chunk))
                       value))
                 (act-r-chunk-slot-value-lists chunk))
        
        
        (dolist (param *chunk-parameters-list*)
          (setf (gethash (act-r-chunk-parameter-name param) 
                         (act-r-chunk-parameter-values new-chunk))
            (if (act-r-chunk-parameter-copy param)
                (funcall (act-r-chunk-parameter-copy param) 
                         (funcall (act-r-chunk-parameter-accessor param) 
                                  chunk-name))
              (chunk-parameter-default param (act-r-chunk-name new-chunk)))))
        (setf (gethash (act-r-chunk-name new-chunk) 
                       (act-r-model-chunks-table (current-model-struct)))
          new-chunk)
        
        (setf (act-r-chunk-copied-from new-chunk) chunk-name)
        
        (act-r-chunk-name new-chunk)))))

(defmacro chunk-copied-from (chunk-name)
  "Return the name of the chunk from which the provided chunk was copied"
  `(chunk-copied-from-fct ',chunk-name))

(defun chunk-copied-from-fct (chunk-name)
  "Return the name of the chunk from which the provided chunk was copied"
  (let ((chunk (get-chunk-warn chunk-name)))
    (when chunk
      (let ((copied-from (act-r-chunk-copied-from chunk)))
        (when (and copied-from (chunk-p-fct copied-from) (equal-chunks-fct chunk-name copied-from))
          copied-from)))))


(defmacro define-chunks (&rest chunk-defs)
  "Create chunks in the current model"
  `(define-chunks-fct ',chunk-defs))

(defun define-chunks-fct (chunk-def-list)
  "Create chunks in the current model"
  
  ;; Do it in 2 passes like the old add-dm because there could be 
  ;; circular references which should be allowed
  
  (verify-current-mp  
   "define-chunks called with no current meta-process."
   (verify-current-model
    "define-chunks called with no current model."
    (let ((chunk-list nil))
        ;; first pass just create the chunks
        (dolist (chunk-def chunk-def-list)
          (if (listp chunk-def)
              (let (name doc type slots slots-and-values
                         (pos (position 'isa chunk-def)))
                (cond ((not (find 'isa chunk-def))
                       (print-warning 
                        "Invalid chunk definition: ~S has no ISA specified."
                        chunk-def))
                      ((> (count 'isa chunk-def) 1)
                       (print-warning 
                        "Invalid chunk definition: ~S has more than one ISA."
                        chunk-def))
                      ((= (1+ pos) (length chunk-def))
                       (print-warning 
                        "Invalid chunk definition: ~S no chunk-type specified after ISA." 
                        chunk-def))
                      ((not (get-chunk-type 
                             (nth (1+ pos) chunk-def)))
                       (print-warning 
                        "Invalid chunk definition: ~S chunk-type specified does not exist."
                        chunk-def))
                      (t
                       (setf type 
                         (get-chunk-type 
                          (nth (1+ pos) chunk-def)))
                       (setf slots-and-values 
                         (subseq chunk-def (+ 2 pos)))
                       (cond ((> pos 2)
                              (print-warning 
                               "Invalid chunk definition: ~S too many specifiers before ISA." 
                               chunk-def))
                             (t
                              (cond ((= pos 0)
                                     (setf name (new-name-fct (symbol-name (act-r-chunk-type-name type)))))
                                    ((= pos 1)
                                     (setf name (first chunk-def)))
                                    ((= pos 2)
                                     (setf name (first chunk-def))
                                     (setf doc (second chunk-def))))
                              
                              (cond ((or (null name) (not (symbolp name)))
                                     (print-warning 
                                      "Invalid chunk definition: ~S chunk name is not a valid symbol." 
                                      chunk-def))
                                    ((and doc (not (stringp doc)))
                                     (print-warning 
                                      "Invalid chunk definition: ~S documentation is not a string."
                                      chunk-def))
                                    ((oddp (length slots-and-values))
                                     (print-warning 
                                      "Invalid chunk definition: ~S slot and values list is an odd length."
                                      chunk-def))
                                    ((chunk-p-fct name)
                                     (print-warning 
                                      "Invalid chunk definition: ~S names a chunk which already exists."
                                      chunk-def))
                                    (t
                                     (do ((s slots-and-values (cddr s)))
                                         ((null s))
                                       (if (valid-slot-name (car s) type)
                                           (push (car s) slots)
                                         (progn
                                           (print-warning 
                                            "Invalid chunk definition: ~S invalid slot name ~s."
                                            chunk-def (car s))
                                           (setf s nil)
                                           (setf slots :error))))
                                     (cond ((eq slots :error))
                                           ; Don't worry about this...
                                           ;((not 
                                           ;  (= (length slots) 
                                           ;     (length (remove-duplicates slots))))
                                           ; (print-warning 
                                           ;  "Invalid chunk definition: ~S slot name used more than once."
                                           ;  chunk-def))
                                           (t 
                                            (let ((c (make-act-r-chunk 
                                                      :name name
                                                      :documentation doc
                                                      :chunk-type type
                                                      :slot-value-lists 
                                                      slots-and-values)))
                                              (push-last c chunk-list)
                                              (setf (gethash 
                                                     name 
                                                     (act-r-model-chunks-table 
                                                      (current-model-struct)))
                                                c)))))))))))
            (model-warning "~S is not a list in call to define-chunks-fct" chunk-def)))
      
      ;; second pass create slot-value list and define parameters
      
      (dolist (chunk chunk-list)
        
        (let ((slots-table 
               (make-hash-table :size (length (ct-slot-names (act-r-chunk-chunk-type chunk)))))
              (ct (act-r-chunk-chunk-type chunk)))
          
          (do* ((all-slots (ct-slot-names ct))
                (s (act-r-chunk-slot-value-lists chunk) (cddr s))
                (slot-name (car s) (car s))
                (slot-value (cadr s) (cadr s)))
               ((null s)
                (dolist (sn all-slots)
                  (awhen (ct-slot-default ct sn)
                         (when (and (symbolp it)
                                    (not (chunk-p-fct it))
                                    (not (numberp it))
                                    (not (eq t it)))
                           (create-undefined-chunk it))
                         
                         (setf (gethash sn slots-table) it))))
            
            ;(push (list (car s) (second s)) slots))
            
            (setf all-slots (remove slot-name all-slots))
            
            (when (and slot-value (symbolp slot-value) 
                       (not (chunk-p-fct slot-value))
                       (not (numberp slot-value))
                       (not (eq t slot-value)))
              (create-undefined-chunk slot-value))
            
            (setf (gethash slot-name slots-table) slot-value))
          
          (setf (act-r-chunk-slot-value-lists chunk) 
            slots-table)
          
          )
        
        
        ;;; Don't want to do this 
        ;(dolist (param *chunk-parameters-list*)
        ;  (setf (gethash (act-r-chunk-parameter-name param)
        ;                 (act-r-chunk-parameter-values chunk))
        ;    (chunk-parameter-default param (act-r-chunk-name chunk))))
        
        )
      
      (mapcar #'act-r-chunk-name chunk-list)))))
        

(defun chk-slot-value (chunk slot-name)
  "Internal function for getting the value of a slot in a chunk structure"
  ;(second (find slot-name (act-r-chunk-slot-value-lists chunk) :key #'car))
  (gethash slot-name (act-r-chunk-slot-value-lists chunk))
  )

(defmacro chunk-slot-value (chunk-name slot-name)
  "Return the value of a slot for the named chunk"
  `(chunk-slot-value-fct ',chunk-name ',slot-name))

(defun chunk-slot-value-fct (chunk-name slot-name)
  "Return the value of a slot for the named chunk"
  (let ((c (get-chunk-warn chunk-name)))
    (when c
      (if (valid-slot-name slot-name (act-r-chunk-chunk-type c))
          (chk-slot-value c slot-name)
        (print-warning 
         "chunk ~S does not have a slot called ~S." chunk-name slot-name)))))


(defmacro set-chunk-slot-value (chunk-name slot-name value)
  "Set the value of a chunk's slot"
  `(set-chunk-slot-value-fct ',chunk-name ',slot-name ',value))

(defun set-chunk-slot-value-fct (chunk-name slot-name value)
  "Set the value of a chunk's slot"
  (let ((c (get-chunk-warn chunk-name)))
    (when c
      (if (valid-slot-name slot-name (act-r-chunk-chunk-type c))
          (progn
            (when (and value (symbolp value) 
                       (not (chunk-p-fct value))
                       (not (numberp value))
                       (not (eq t value)))
              (create-undefined-chunk value))
            
            (setf (act-r-chunk-copied-from c) nil)
            
            ;(setf (cdr (find slot-name (act-r-chunk-slot-value-lists c) 
            ;                 :key #'car)) 
            ;  (list value))
            
            ; again with the hash-table
            
            (setf (gethash slot-name (act-r-chunk-slot-value-lists c))
              value)
            
            )
        (print-warning 
         "chunk ~S does not have a slot called ~S." chunk-name slot-name)))))


(defmacro mod-chunk (chunk-name &rest modifications)
  "Modify the slot values of a chunk"
  `(mod-chunk-fct ',chunk-name ',modifications))

(defun mod-chunk-fct (chunk-name modifications-list)
  "Modify the slot values of a chunk"
  (let ((c (get-chunk-warn chunk-name)))
    (when c
      (if (oddp (length modifications-list))
          (print-warning "Odd length modifications list in call to mod-chunk.")
        (let ((slots nil)
              (slots-and-values nil))
          (do ((s modifications-list (cddr s)))
              ((null s))
            (push (car s) slots)
            (push (list (car s) (second s)) slots-and-values))
          (cond ((not (every #'(lambda (slot)
                                 (valid-slot-name 
                                  slot (act-r-chunk-chunk-type c)))
                             slots))
                 (print-warning "Invalid slot name in modifications list."))
                ((not (= (length slots) (length (remove-duplicates slots))))
                 (print-warning 
                  "Slot name used more than once in modifications list."))
                (t
                 (dolist (slot-value slots-and-values chunk-name)
                   (set-chunk-slot-value-fct 
                    chunk-name (first slot-value) (second slot-value))))))))))



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; to potentially speed things way up provide un-checked but fast accessors
;;; to the chunk info...



(defun fast-chunk-slot-value-fct (chunk-name slot-name)
  "Return the value of a slot for the named chunk without testing validity"
  (let ((c (get-chunk chunk-name)))
    (when c
      (chk-slot-value c slot-name))))
      
(defun fast-set-chunk-slot-value-fct (chunk-name slot-name value)
  "Set the value of a chunk's slot without testing validity"
  (let ((c (get-chunk chunk-name)))
    (when c
      (when (and value (symbolp value) 
                 (not (chunk-p-fct value))
                 (not (numberp value))
                 (not (eq t value)))
        (create-undefined-chunk value))
      
      (setf (act-r-chunk-copied-from c) nil)
      
      ;(setf (cdr (find slot-name (act-r-chunk-slot-value-lists c) 
      ;                 :key #'car)) 
      ;  (list value))
      
      ; again with the hash-table
      
      (setf (gethash slot-name (act-r-chunk-slot-value-lists c))
        value)
      
      )))

(defun fast-mod-chunk-fct (chunk-name modifications-list)
  "Modify the slot values of a chunk without testing validity"
  (let ((c (get-chunk chunk-name)))
    (when c
      (unless (oddp (length modifications-list))
        (loop 
          (when (null modifications-list) (return))
          (fast-set-chunk-slot-value-fct 
           chunk-name
           (pop modifications-list)
           (pop modifications-list)))
        chunk-name))))

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





(defmacro delete-chunk (chunk-name)
  "Delete a chunk from a model"
  `(delete-chunk-fct ',chunk-name))

(defun delete-chunk-fct (chunk-name)
  "Delete a chunk from a model"
  (let ((c (get-chunk-warn chunk-name)))
    (when c
      (maphash #'(lambda (key value)
                    (when (eq value c)
                      (remhash 
                       key (act-r-model-chunks-table (current-model-struct)))))
               (act-r-model-chunks-table (current-model-struct)))
      chunk-name)))


(defmacro merge-chunks (chunk-name1 chunk-name2)
  "Merge two chunks into a single representation"
  `(merge-chunks-fct ',chunk-name1 ',chunk-name2))

(defun merge-chunks-fct (chunk-name1 chunk-name2)
  "Merge two chunks into a single representation"
  (let ((c1 (get-chunk-warn chunk-name1))
        (c2 (get-chunk-warn chunk-name2)))
    (when (and c1 c2)
      (unless (chunk-equal-test c1 c2)
        (return-from merge-chunks-fct nil))
      (unless (eq c1 c2)
        (dolist (param *chunk-parameters-list*)
          (when (act-r-chunk-parameter-merge param)
            (setf (gethash (act-r-chunk-parameter-name param)
                           (act-r-chunk-parameter-values c1))
              (funcall (act-r-chunk-parameter-merge param) 
                       chunk-name1 chunk-name2))))
        
        #|
         (maphash #'(lambda (key value)
                     (when (eq value c2)
                       (setf (gethash key (act-r-model-chunks-table 
                                           (current-model-struct))) c1)))
                 (act-r-model-chunks-table (current-model-struct)))
        |#
        
        ;; merge the specific chunk
        (setf (gethash chunk-name2 (act-r-model-chunks-table 
                                    (current-model-struct))) 
          c1)
        
        ;; merge any that it had been merged with previously
        (dolist (merge-chunk (act-r-chunk-merge-list c2))
          (setf (gethash merge-chunk (act-r-model-chunks-table 
                                      (current-model-struct))) 
            c1))
        
        ;; save the new on as merged with the old
        (push chunk-name2 (act-r-chunk-merge-list c1))
        
        ;; save any the new had been merged with with the old
        (setf (act-r-chunk-merge-list c1)
          (append (act-r-chunk-merge-list c1)
                  (act-r-chunk-merge-list c2)))
        
        ;; clear the list for the new chunk
        (setf (act-r-chunk-merge-list c2) nil))
      
      chunk-name1)))

(defmacro eq-chunks (chunk-name1 chunk-name2)
  "Return t if two chunks have the same underlying representation"
  `(eq-chunks-fct ',chunk-name1 ',chunk-name2))

(defun eq-chunks-fct (chunk-name1 chunk-name2)
  "Return t if two chunks have the same underlying representation"
  (let ((c1 (get-chunk-warn chunk-name1))
        (c2 (get-chunk-warn chunk-name2)))
    (and c1 c2 (eq c1 c2))))

(defmacro true-chunk-name (chunk-name)
  "Return the prototypical name of a chunk in the event of merging"
  `(true-chunk-name-fct ',chunk-name))

(defun true-chunk-name-fct (chunk-name)
  "Return the prototypical name of a chunk in the event of merging"
  (let ((c (get-chunk chunk-name)))
    (if c
        (act-r-chunk-name c)
      chunk-name)))

(defmacro equal-chunks (chunk-name1 chunk-name2)
  "Return t if two chunks are of the same chunk-type and have equal slot values"
  `(equal-chunks-fct ',chunk-name1 ',chunk-name2))

(defun equal-chunks-fct (chunk-name1 chunk-name2)
  "Return t if two chunks are of the same chunk-type and have equal slot values"
  (let ((c1 (get-chunk-warn chunk-name1))
        (c2 (get-chunk-warn chunk-name2)))
    (chunk-equal-test c1 c2)))


(defun chunk-equal-test (c1 c2)
  "Internal function for comparing the equality of two chunks"
  (and c1 c2 (or (eq c1 c2)
                   (and (eq (act-r-chunk-chunk-type c1)
                            (act-r-chunk-chunk-type c2))
                        (every #'(lambda (slot-name) 
                                   (equal-compare-slot-values
                                    (chk-slot-value c1 slot-name)
                                    (chk-slot-value c2 slot-name)))
                               (ct-slot-names (act-r-chunk-chunk-type c1)))))))

(defun equal-compare-slot-values (val1 val2)
  "Internal function for comparing equality of chunk slot values"
  (cond ((stringp val1) (and (stringp val2) (string-equal val1 val2)))
        ((and val1 val2 (symbolp val1) (symbolp val2)
              (get-chunk val1) (get-chunk val2))
         (eq-chunks-fct val1 val2))
        (t (equal val1 val2))))
  

#| What was this supposed to be for?

(defun slot-value-pairs-from-spec (spec)
  (apply #'append (mapcar #'(lambda (x)
                              (list (act-r-slot-spec-name x) 
                                    (cdr (act-r-slot-spec-value x))))
                    (act-r-chunk-spec-slots spec))))

|#

(defmacro extend-chunks (parameter-name &key (default-value nil)
                                        (default-function nil)
                                        (merge-function nil)
                                        (copy-function nil))
  "Add new parameters to all chunks"
  (let ((accessor-name (intern (concatenate 'string "CHUNK-"  (string-upcase parameter-name))))
        (setf-name (intern (concatenate 'string "CHUNK-" (string-upcase parameter-name) "-SETF"))))
    (if (find parameter-name *chunk-parameters-list* :key #'act-r-chunk-parameter-name)
         (progn
           (print-warning "Parameter ~s already defined for chunks." parameter-name)
           :duplicate-parameter)
      `(eval-when (:compile-toplevel :load-toplevel :execute)
         (when (or (fboundp ',setf-name) (fboundp ',accessor-name))
           (print-warning "The following ~:[~;2 ~]warning~:[~;s~] can be ignored for the main ACT-R modules provided, but may be a serious problem if seen otherwise." 
                          (and (fboundp ',setf-name) (fboundp ',accessor-name))
                          (and (fboundp ',setf-name) (fboundp ',accessor-name))))
         (when (fboundp ',accessor-name)
           (print-warning "Function ~s already exists and is being redefined." ',accessor-name))
         (when (fboundp ',setf-name)
           (print-warning "Function ~s already exists and is being redefined." ',setf-name))
         (when (find ',parameter-name *chunk-parameters-list* :key #'act-r-chunk-parameter-name)
           (setf *chunk-parameters-list* (remove ',parameter-name *chunk-parameters-list* :key #'act-r-chunk-parameter-name)))
         
         (push (make-act-r-chunk-parameter :name ',parameter-name
                                           :default-value ',default-value
                                           :default-function ',default-function
                                           :merge ',merge-function
                                           :copy ',copy-function
                                           :accessor ',accessor-name)
               *chunk-parameters-list*)
         (defun ,accessor-name (chunk-name)
           (let ((c (get-chunk chunk-name)))
             (if c
                 (multiple-value-bind (value exists)
                     (gethash ',parameter-name (act-r-chunk-parameter-values c))
                   (if exists
                       value
                     (setf (gethash ',parameter-name (act-r-chunk-parameter-values c)) 
                       (chunk-parameter-default 
                        (find ',parameter-name *chunk-parameters-list* 
                              :key #'act-r-chunk-parameter-name)
                        (act-r-chunk-name c)))))
               (print-warning "Chunk ~s does not exist." chunk-name))))
         (defun ,setf-name (chunk-name new-value)
           (let ((c (get-chunk chunk-name)))
             (if c
                 (setf (gethash ',parameter-name (act-r-chunk-parameter-values c)) new-value)
               (print-warning "Chunk ~s does not exist." chunk-name))))
         (defsetf ,accessor-name ,setf-name)
         ',accessor-name))))



(defun normalize-chunk-names (&optional (unintern? nil))
  (if (current-model-struct)
      (let ((possible-removals
             (mapcan #'(lambda (x)
                         (when (not (eq x (true-chunk-name-fct x))) 
                           (list x)))
               (chunks))))
         
        ;; clean up the chunk references
        ;; this could take a while
        
        (dolist (chunk (chunks))
          (dolist (slot (chunk-type-slot-names-fct (chunk-chunk-type-fct chunk)))
            (when (member (chunk-slot-value-fct chunk slot) possible-removals)
              (set-chunk-slot-value-fct chunk slot (true-chunk-name-fct (chunk-slot-value-fct chunk slot))))))
        
        (when unintern?
          (dolist (x possible-removals)
            (setf (act-r-chunk-merge-list (get-chunk (true-chunk-name-fct x)))
              (remove x (act-r-chunk-merge-list (get-chunk (true-chunk-name-fct x)))))
            (remhash x (act-r-model-chunks-table (current-model-struct)))
            (release-name-fct x))))            
    (print-warning "No current model in which to normalize chunk names.")))


#|
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/framework/chunk-spec.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    : chunk-spec.lisp
;;; Version     : 1.0a1
;;; 
;;; Description : Definition of chunk specifications and corresponding functions
;;; 
;;; Bugs        : 
;;;
;;; To do       : * Finish the documentation.
;;;             : * Investigate optimizations after there's some use.
;;;             : * Add a function to check chunk-specs to make module writing
;;;             :   easier.
;;; ----- History -----
;;;
;;; 2004.09.02 Dan
;;;             : Creation.
;;; 2004.12.29 Dan
;;;             : Realized that the comparitors are backwards with respect
;;;             : to productions in test-chunk-slots.
;;; 2005.02.03 Dan
;;;             : * Changing the internal slot-value-lists of a chunk to be a
;;;             :   hash-table instead of an alist...
;;; 2005.02.09 Dan
;;;             : * Some minor cleanup - changing member to find where possible.
;;; 2005.04.19 Dan
;;;             : * Added pprint-chunk-spec.
;;; 2005.05.16 Dan
;;;             : * Modified chunk-spec-variable-p to test that the name has
;;;             :   a length > 1 to reject the symbol itself as a variable.
;;;             :   That fixes a minor problem in production parsing and I
;;;             :   don't think it breaks anything else.
;;; 2005.09.09 Dan
;;;             : * Renamed chunk-to-chunk-spec chunk-name-to-chunk-spec to
;;;             :   clarify its use because I introduced a bug somewhere
;;;             :   along the line with its usage that didn't actually affect
;;;             :   any existing modules, but may cause problems for other
;;;             :   module writers.
;;;             : * Also fixed chunk-name-to-chunk-spec because it didn't 
;;;             :   include nil slots in the spec, but it probably should (it
;;;             :   did prior to my "fixing" it when I changed over to hash
;;;             :   tables).
;;; 2005.11.17 Dan
;;;             : * Fixed chunk-name-to-chunk-spec because it incorrectly
;;;             :   referenced the internal chunk-type slot list instead of
;;;             :   using ct-slot-names.
;;; 2006.09.11 Dan
;;;             : * Changed chunk-slot-equal so that it uses equalp instead of
;;;             :   equal when the string and chunk checks fall through because
;;;             :   numbers (which is the typical value that'd fall through)
;;;             :   don't test well with equal...
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; General Docs:
;;; 
;;; The structures are not for external use.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; 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)



(defmacro define-chunk-spec (&rest specifications)
  `(define-chunk-spec-fct ',specifications))

(defun define-chunk-spec-fct (specifications-list)
  (verify-current-mp  
   "define-chunk-spec-fct called with no current meta-process."
   (verify-current-model
    "define-chunk-spec-fct called with no current model."
    (cond ((null specifications-list)
           (print-warning "No specification in call to define-chunk-spec."))
          ((= (length specifications-list) 1)
           (if (get-chunk (car specifications-list))
               (chunk-name-to-chunk-spec (car specifications-list))
             (print-warning 
              "define-chunk-spec's 1 parameter doesn't name a chunk: ~S" 
              specifications-list)))
          
          ((not (eq (car specifications-list) 'isa))
           (print-warning 
            "First element to define-chunk-spec isn't the symbol ISA. ~s" 
            specifications-list))
          ((not (get-chunk-type (second specifications-list)))
           (print-warning 
            "Second element in define-chunk-spec isn't a chunk-type. ~S" 
            specifications-list))
          (t
           (let* ((ct (get-chunk-type (second specifications-list)))
                  (new-spec (make-act-r-chunk-spec :type ct))
                  (slots (process-slots-specs ct (cddr specifications-list))))
             (unless (eq slots :error)
               (setf (act-r-chunk-spec-slots new-spec) slots)
               new-spec)))))))

(defun chunk-name-to-chunk-spec (chunk-name)
  
  (awhen (get-chunk chunk-name)
         (let* ((ct  (act-r-chunk-chunk-type it))
                (spec (make-act-r-chunk-spec :type ct)))
           (dolist (slot (ct-slot-names ct) spec)
             (push (make-act-r-slot-spec :name slot 
                                         :value (chk-slot-value it slot))
                   (act-r-chunk-spec-slots spec))))))
  

(defun chunk-spec-chunk-type (chunk-spec)
  (cond ((not (act-r-chunk-spec-p chunk-spec))
         (print-warning 
          "chunk-spec-chunk-type called with a non-chunk-spec"))
        (t
         (act-r-chunk-type-name (act-r-chunk-spec-type chunk-spec)))))

(defun chunk-spec-slots (chunk-spec)
  (cond ((not (act-r-chunk-spec-p chunk-spec))
         (print-warning 
          "chunk-spec-slots called with something other than a chunk-spec"))
        (t
         (remove-duplicates (mapcar #'act-r-slot-spec-name
                              (act-r-chunk-spec-slots chunk-spec))))))
  
(defun chunk-spec-slot-spec (chunk-spec &optional slot)
  (cond ((not (act-r-chunk-spec-p chunk-spec))
         (print-warning 
          "chunk-spec-slots called with something other than a chunk-spec"))
        (t
         (cond ((and slot (find slot (act-r-chunk-spec-slots chunk-spec) 
                                :key #'act-r-slot-spec-name))
                (mapcar #'slot-spec-to-list 
                  (remove-if-not #'(lambda (x)
                                     (eq x slot))
                                 (act-r-chunk-spec-slots chunk-spec)
                                 :key #'act-r-slot-spec-name)))
               (slot
                (print-warning 
                 "Slot ~S is not specified in the chunk-spec." slot))
               (t
                (mapcar #'slot-spec-to-list 
                  (act-r-chunk-spec-slots chunk-spec)))))))

(defun slot-in-chunk-spec-p (chunk-spec slot)
  (cond ((not (act-r-chunk-spec-p chunk-spec))
         (print-warning 
          "slot-in-chunk-spec-p called with something other than a chunk-spec"))
        (t
         (find slot (mapcar #'act-r-slot-spec-name
                              (act-r-chunk-spec-slots chunk-spec))))))

(defun slot-spec-to-list (slot-spec)
  (list (act-r-slot-spec-modifier slot-spec)
        (act-r-slot-spec-name slot-spec)
        (act-r-slot-spec-value slot-spec)))
         
(defun process-slots-specs (chunk-type specs)
  (let ((slots nil))
    (loop 
      (when (null specs)
        (return slots))
      (let ((spec (make-act-r-slot-spec)))
        (when (find (car specs) '(= - > < >= <=))
          (setf (act-r-slot-spec-modifier spec) (pop specs)))
        (when (null specs)
          (print-warning 
           "Invalid specs in call to define-chunk-spec - not enough arguments")
          (return :error))
        (unless (or (valid-slot-name (car specs) chunk-type) 
                    (keywordp (car specs)))
          (print-warning "Invalid slot-name ~S in call to define-chunk-spec." 
                         (car specs))
          (return :error))
        (setf (act-r-slot-spec-name spec) (pop specs))
        (when (null specs)
          (print-warning 
           "Invalid specs in call to define-chunk-spec - not enough arguments")
          (return :error))
        (setf (act-r-slot-spec-value spec) (pop specs))
        (push spec slots)))))

(defun chunk-spec-variable-p (chunk-spec-slot-value &optional (char #\=))
  (and (symbolp chunk-spec-slot-value) 
       (eql (aref (string chunk-spec-slot-value) 0) char)
       (> (length (string chunk-spec-slot-value)) 1)))


(defun match-chunk-spec-p (chunk-name chunk-spec 
                                      &key (=test #'chunk-slot-equal) 
                                      (-test #'chunk-slot-not-equal)
                                      (>test #'safe>) (>=test #'safe>=) 
                                      (<test #'safe<) (<=test #'safe<=)
                                      (variable-char #\=))
  (let ((chunk (get-chunk chunk-name)))
    (cond ((null chunk)
           (print-warning 
            "~s does not name a chunk in call to match-chunk-spec-p." 
            chunk-name))
          ((not (act-r-chunk-spec-p chunk-spec))
           (print-warning 
            "~s is not a valid chunk-spec in call to match-chunk-spec-p."
            chunk-spec))
          ((find (act-r-chunk-type-name (act-r-chunk-spec-type chunk-spec))
                   (act-r-chunk-type-supertypes (act-r-chunk-chunk-type chunk)))
           
           (handler-case (test-chunk-slots (act-r-chunk-slot-value-lists chunk)
                                           (act-r-chunk-spec-slots chunk-spec)
                                           =test
                                           -test
                                           >test
                                           >=test
                                           <test
                                           <=test
                                           variable-char)
                      (error (condition) 
                        (print-warning 
                         "Error ~S encountered in matching chunk ~s." 
                         condition chunk-name))))
          (t
           nil))))

(defun chunk-slot-equal (val1 val2)
  (cond ((stringp val1) 
         (and (stringp val2) (string-equal val1 val2)))
        ((and val1 val2 
              (symbolp val1) (symbolp val2)
              (get-chunk val1) (get-chunk val2))
         (eq-chunks-fct val1 val2))
        (t (equalp val1 val2))))

(defun chunk-slot-not-equal (arg1 arg2)
 (not (chunk-slot-equal arg1 arg2)))

(defun test-chunk-slots (slots specs =test -test >test >=test <test <=test 
                               variable-char)
  (let ((variables nil)
        (bindings nil)
        (rest nil))
    
    ;; pull out the variables
    
    (dolist (x specs)
      (if (and (chunk-spec-variable-p (act-r-slot-spec-value x) variable-char)
               (eql '= (act-r-slot-spec-modifier x)))
          (progn
            (push x variables)
            (unless (assoc (act-r-slot-spec-value x) bindings)
              (push (cons (act-r-slot-spec-value x) nil) bindings))) 
        (push x rest)))
    
      
    ;; bind the ='s to the variable
    ;; and verify that they don't conflict
    
    (dolist (x variables)
      (let* ((var (act-r-slot-spec-value x))
             (slot (act-r-slot-spec-name x))
             (slot-val (gethash slot slots)) ;(cadr (assoc slot slots)))
             (current (cdr (assoc var bindings))))
        
        (cond ((null slot-val)
               (return-from test-chunk-slots nil))
              ((null current)
               (setf (cdr (assoc var bindings)) slot-val))
              ((not (funcall =test slot-val current))
               (return-from test-chunk-slots nil)))))
               
    ;; make sure there are bindings 
    ;; and if so try the rest of the slots
    
    (unless (some #'(lambda (x) (null (cdr x))) bindings)
    
    (do ((matches t)
         (tests rest (cdr tests)))
        ((or (null tests) (null matches)) matches)
      
      (let ((modifier (act-r-slot-spec-modifier (car tests)))
            (slot (act-r-slot-spec-name (car tests)))
            (value (act-r-slot-spec-value (car tests))))
        
        
        (when (chunk-spec-variable-p value variable-char)
          (setf value (cdr (assoc value bindings))))
        
          (setf matches
            (funcall (case modifier
                       (= =test)
                       (- -test)
                       (> >test)
                       (>= >=test)
                       (< <test)
                       (<= <=test))
                     ;(second (assoc slot slots)) 
                     (gethash slot slots)
                     value)))))))
  
(defun find-matching-chunks (chunk-spec 
                             &key 
                             (chunks :all) (=test #'chunk-slot-equal) 
                             (-test #'chunk-slot-not-equal)
                             (>test #'safe>) (>=test #'safe>=) 
                             (<test #'safe<) (<=test #'safe<=)
                             (variable-char #\=))
  
  (verify-current-mp  
   "Find-matching-chunks called with no current meta-process."
   (verify-current-model
    "Find-matching-chunks called with no current model."
    
    (let ((found nil))
      (cond ((not (act-r-chunk-spec-p chunk-spec))
             (print-warning 
              "~s is not a valid chunk-spec in call to find-matching-chunks." 
              chunk-spec))
            ((eq :all chunks)
             (maphash #'(lambda (name chunk)
                          (declare (ignore chunk))
                          (when (match-chunk-spec-p name chunk-spec 
                                                    :=test =test :-test -test
                                                    :>test >test :>=test >=test 
                                                    :<test <test :<=test <=test
                                                    :variable-char variable-char
                                                    )
                            (push name found)))
                      (act-r-model-chunks-table (current-model-struct)))
             found)
            (t
             (dolist (name chunks found)
               (when (match-chunk-spec-p name chunk-spec 
                                         :=test =test :-test -test
                                         :>test >test :>=test >=test 
                                         :<test <test :<=test <=test
                                         :variable-char variable-char)
                 (push name found)))))))))
                       


(defun strip-request-parameters-from-chunk-spec (chunk-spec)
  "Return a chunk-spec that doesn't have any request parameters in it"
  (let ((slots (chunk-spec-slots chunk-spec)))
    (if (some #'keywordp slots)
        (let ((new-chunk-spec-list 
               (list 'isa (chunk-spec-chunk-type chunk-spec))))
          (dolist (slot (remove-if #'keywordp slots))
            (setf new-chunk-spec-list 
              (append new-chunk-spec-list 
                      (mapcan #'(lambda (x) x) 
                        (chunk-spec-slot-spec chunk-spec slot)))))
          (define-chunk-spec-fct new-chunk-spec-list))
      chunk-spec)))

(defun pprint-chunk-spec (chunk-spec)
  "Print a chunk specification in a 'production like' way to the
   command output"
  (when (act-r-chunk-spec-p chunk-spec)
    (command-output "    ISA ~A" (chunk-spec-chunk-type chunk-spec))
    (dolist (slot (act-r-chunk-spec-slots chunk-spec))
      (if (eql '= (act-r-slot-spec-modifier slot))
          (command-output "    ~A ~S"
                          (act-r-slot-spec-name slot)
                          (act-r-slot-spec-value slot))
          (command-output " ~2a ~A ~S"
                          (act-r-slot-spec-modifier slot)
                          (act-r-slot-spec-name slot)
                          (act-r-slot-spec-value slot))))))
    
#|
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/framework/chunk-types.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    : chunk-types.lisp
;;; Version     : 1.0
;;; 
;;; Description : Definition of chunk-types and function that manipulate them.
;;; 
;;; Bugs        : 
;;;
;;; To do       : Finish up the documentation.
;;; 
;;; ----- History -----
;;;
;;; 2004.09.02 Dan
;;;             : Creation
;;; 2005.01.16 Dan
;;;             : * Removed the print-chunk-type function since I don't want to
;;;             :   hide the structure since users shouldn't see them anyway.
;;; 2005.01.17 Dan
;;;             : * Changed pprint-chunk-type to use command-output and a
;;;             :   compiled format string.
;;; 2005.01.18 Dan
;;;             : * Made it so chunk-type returns the name and not the struct.
;;; 2005.01.21 Dan
;;;             : * Fixed a bug with maintaining the subtypes information.
;;; 2005.02.04 Dan
;;;             : * Changed member to find for speed. (?)
;;; 2005.02.24 Dan
;;;             : * Changed pprint-chunk-type becasue some Lisps don't take a
;;;             :   preformatted format string with the ~? directive.
;;; 2005.03.25 Dan
;;;             : * Changed chunk-type-fct so that when it builds a chunk-type
;;;             :   as a subtype the slot ordering is maintained. 
;;; 2005.09.01 Dan
;;;             : * Added extend-chunk-type-slots to support the experimental
;;;             :   change to p* that will allow a RHS modification to add
;;;             :   new slots to a chunk.  This should NOT be used in general
;;;             :   or by any other system/module/model at this time.
;;;             : * Had to patch chunk-type-fct to copy the slots list because
;;;             :   otherwise the macro calls inside of the existing code
;;;             :   get thumped by extend-... making the change persistent.
;;; 2006.01.18 Dan
;;;             : * Modified extend-chunk-type-slots to also record the new
;;;             :   slot names in a separate list.
;;;             : * Added the extended-slot-name-p function to allow one to see
;;;             :   whether or not a given slot name was one of the originals.
;;; 2006.03.02 Dan [1.0]
;;;             : * Fixed an issue with recording the subtype info that caused
;;;             :   problems with retrievals when there were more than 2 levels
;;;             :   of inheritance.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; General Docs:
;;; 
;;; chunk-type structure for internal use only.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Public API:
;;;
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Design Choices:
;;; 
;;; Saving both the super and sub type information in the chunk type structure
;;; for potential use in the matching or elsewhere, but may not need both when
;;; all is done.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 
;;; 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)

#| Don't want to hide the details since users shouldn't see these

(defun print-chunk-type (chunk-type stream depth)
  "Print a chunk-type as just its name."
  (declare (ignore depth))
  (format stream "~A" (act-r-chunk-type-name chunk-type)))
|#

(defun get-chunk-type (name)
  "Internal command to get a chunk-type structure from its name"
  (verify-current-mp  
   "get-chunk-type called with no current meta-process."
   (verify-current-model
    "get-chunk-type called with no current model."
    (gethash name (act-r-model-chunk-types-table (current-model-struct))))))            

(defmacro chunk-type (&rest name-and-slots)
  "The user macro to define a new chunk-type."
  `(chunk-type-fct ',name-and-slots))
     
(defun chunk-type-fct (name-and-slots)
  "The user function to define a new chunk-type"
  (verify-current-mp  
   "chunk-type called with no current meta-process."
   (verify-current-model
    "chunk-type called with no current model."
    (cond ((null name-and-slots)
           (print-all-chunk-types))
          ((not (listp name-and-slots))
           (print-warning 
            "chunk-type-fct must be passed a list which defines a chunk-type."))
          (t
           (let* ((name-description (car name-and-slots))
                  (name (if (consp name-description)
                            (car name-description) name-description))
                  (super-type (if (consp name-description)
                                  (cdr name-description) nil))
                  (documentation (when (stringp (second name-and-slots))
                                   (second name-and-slots)))
                  (slots (if documentation (cddr name-and-slots) 
                           (cdr name-and-slots))))
             
             (when (get-chunk-type name)
               (print-warning 
                "Chunk-type ~S is already defined and redefinintion is not allowed."
                name)
               (return-from chunk-type-fct nil))
             
             ; check type hierarchy
             (when super-type
               (unless (null (cdr super-type))
                 (print-warning 
                  "Too many options specified for chunk-type ~S. NO chunk-type created." 
                  name)
                 (return-from chunk-type-fct nil))
               
               (if (and (eq (caar super-type) :include) 
                        (null (cddar super-type)))
                   (if (get-chunk-type (cadar super-type))
                       (setf super-type (get-chunk-type (cadar super-type)))
                     (progn
                       (print-warning 
                        "Unknown supertype ~S specified for type ~S." 
                        (cadar super-type) name)
                       (return-from chunk-type-fct nil)))
                 (progn
                   (print-warning "Unknown option ~S specified for type ~S." 
                                  (car super-type) name)
                   (return-from chunk-type-fct nil))))
             
             (dolist (slot slots)
               (unless (or (atom slot)
                           (and (listp slot)
                                (= (length slot) 2)))
                 (print-warning 
                  "Unacceptable slot specification ~S for chunk-type ~S.  Chunk-type not created." 
                  slot name)
                 (return-from chunk-type-fct nil)))
             
             (unless (= (length slots) (length (remove-duplicates slots)))
               (print-warning 
                "Duplicate slot specifications in ~S for chunk-type ~S.  Chunk-type not created."
                slots name)
               (return-from chunk-type-fct nil))
             
             (when super-type
               (dolist (parent-slot (reverse (act-r-chunk-type-slots super-type)))
                 (unless (find (chunk-type-slot-name parent-slot) slots 
                                 :key #'chunk-type-slot-name)
                   (push parent-slot slots))))
             
             (let ((ct (make-act-r-chunk-type 
                        :name name 
                        :documentation documentation
                        :slots (copy-tree slots)
                        :subtypes (list name)
                        :supertypes 
                        (if super-type
                            (cons name 
                                  (act-r-chunk-type-supertypes super-type))
                          (list name)))))
               
               (when super-type
                 (dolist (parent (act-r-chunk-type-supertypes super-type))
                   (push name (act-r-chunk-type-subtypes 
                               (get-chunk-type parent)))))
               
               (setf (gethash name 
                              (act-r-model-chunk-types-table 
                               (current-model-struct))) ct)
               name)))))))
  

(defun chunk-type-slot-name (slot)
  "Internal function for parsing chunk-types"
  (if (atom slot)
      slot
    (car slot)))

(defun print-all-chunk-types ()
  "Internal function for printing all chunk-types" 
  (let ((res nil))
    (maphash #'(lambda (name chunk-type)
                 (declare (ignore name))
                 (push (pprint-chunk-type chunk-type) res))
             (act-r-model-chunk-types-table (current-model-struct)))
    (reverse res)))

(defconstant *pprint-chunk-type-string*
     (formatter "~S~@[ <- ~s~]~@[ ~S~]~%~{~{   ~s~@[ (~s)~]~%~}~}~%")
  "Internal compiled format string used to print out chunk-types")

(defun pprint-chunk-type (chunk-type)
  "Pretty prints a chunk-type."
  (command-output  
   (format nil *pprint-chunk-type-string*
                  (act-r-chunk-type-name chunk-type)
                  (second (act-r-chunk-type-supertypes chunk-type))
                  (act-r-chunk-type-documentation chunk-type)
                  (mapcar #'(lambda (slot)
                              (if (listp slot)
                                  slot
                                (list slot nil)))
                    (act-r-chunk-type-slots chunk-type))))
  (act-r-chunk-type-name chunk-type))


(defmacro chunk-type-p (chunk-type-name?)
  "Predicate macro for verifying that a chunk-type of a given name exists"
  `(chunk-type-p-fct ',chunk-type-name?))

(defun chunk-type-p-fct (chunk-type-name?)
  "Predicate function for verifying that a chunk-type of a given name exists"
  (if (get-chunk-type chunk-type-name?)
      t nil))

(defmacro chunk-type-subtype-p (chunk-subtype? chunk-supertype)
  "Predicate macro for testing that one chunk-type isa a subtype of another"
  `(chunk-type-subtype-p-fct ',chunk-subtype? ',chunk-supertype))

(defun chunk-type-subtype-p-fct (chunk-subtype? chunk-supertype)
  "Predicate function for testing that one chunk-type isa a subtype of another"
  (let ((ct (get-chunk-type chunk-subtype?)))
    (when ct 
      (find chunk-supertype (act-r-chunk-type-supertypes ct)))))


(defmacro chunk-type-supertypes (chunk-type-name)
  "Macro to return the list of supertypes for a given chunk-type"
  `(chunk-type-supertypes-fct ',chunk-type-name))

(defun chunk-type-supertypes-fct (chunk-type-name)
  "Function to return the list of supertypes for a given chunk-type"
  (let ((ct (get-chunk-type chunk-type-name)))
    (when ct 
      (act-r-chunk-type-supertypes ct))))


(defmacro chunk-type-subtypes (chunk-type-name)
  "Macro to return the list of subtypes for a given chunk-type"
  `(chunk-type-subtypes-fct ',chunk-type-name))

(defun chunk-type-subtypes-fct (chunk-type-name)
  "Function to return the list of subtypes for a given chunk-type"
  (let ((ct (get-chunk-type chunk-type-name)))
    (when ct 
      (act-r-chunk-type-subtypes ct))))


(defmacro chunk-type-slot-names (chunk-type-name)
  "Macro to return the list of valid slot names for a given chunk-type"
  `(chunk-type-slot-names-fct ',chunk-type-name))

(defun chunk-type-slot-names-fct (chunk-type-name)
  "Function to return the list of valid slot names for a given chunk-type"
  (let ((ct (get-chunk-type chunk-type-name)))
    (when ct 
      (mapcar #'chunk-type-slot-name (act-r-chunk-type-slots ct)))))

(defun ct-slot-names (chunk-type)
  "Internal function for parsing chunk-type structures"
  (mapcar #'chunk-type-slot-name (act-r-chunk-type-slots chunk-type)))


(defmacro chunk-type-slot-default (chunk-type-name slot-name)
  "Macro to return the default value for a slot in a chunk-type"
  `(chunk-type-slot-default-fct ',chunk-type-name ',slot-name))

(defun chunk-type-slot-default-fct (chunk-type-name slot-name)
  "Function to return the default value for a slot in a chunk-type"
    (let ((ct (get-chunk-type chunk-type-name)))
    (when ct 
      (let ((slot (find slot-name (act-r-chunk-type-slots ct) 
                        :key #'chunk-type-slot-name)))
        (when (listp slot)
          (second slot))))))


(defun ct-slot-default (chunk-type slot-name)
  "Internal function for parsing chunk-type structures"
  (let ((slot (find slot-name (act-r-chunk-type-slots chunk-type) 
                    :key #'chunk-type-slot-name)))
    (when (listp slot)
      (second slot))))


(defmacro chunk-type-documentation (chunk-type-name)
  "Macro to return the documentation string for a chunk-type"
  `(chunk-type-documentation-fct ',chunk-type-name))

(defun chunk-type-documentation-fct (chunk-type-name)
  "Function to return the documentation string for a chunk-type"
  (let ((ct (get-chunk-type chunk-type-name)))
    (when ct 
      (act-r-chunk-type-documentation ct))))

(defun valid-slot-name (slot chunk-type)
  "Internal function for testing chunk-type structures"
  (find slot (act-r-chunk-type-slots chunk-type) :key #'chunk-type-slot-name))

(defun valid-chunk-type-slot (chunk-type-name slot)
  (let ((ct (get-chunk-type chunk-type-name)))
    (when ct
      (valid-slot-name slot ct))))

(defun extend-chunk-type-slots (chunk-type slot-name)
  (let ((ct (get-chunk-type chunk-type)))
    (when ct
      (unless (valid-slot-name slot-name ct)
        (push-last slot-name (act-r-chunk-type-slots ct))
        (push-last slot-name (act-r-chunk-type-extended-slots ct))
        
        (dolist (sub-type (act-r-chunk-type-subtypes ct))
          (extend-chunk-type-slots sub-type slot-name))))))

(defun extended-slot-name-p (slot-name chunk-type-name)
  (let ((ct (get-chunk-type chunk-type-name)))
    (when ct
      (find slot-name (act-r-chunk-type-extended-slots ct)))))

#|
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
                                                 (bundle (system-framework-bundle)))
  (let* ((addr (#_CFBundleGetFunctionPointerForName bundle (CFSTR symbol-name))))
    (if (%null-ptr-p addr)
      (error "Couldn't resolve address of foreign function ~s" symbol-name)
      ;; This may be a little confusing: MCL uses fixnums (whose low 2 bits are
      ;; zero) to represent function addresses (whose low 2 bits are zero ...)
      ;; Shove the pointer in a buffer; fetch a signed 32-bit integer, shift it
      ;; right 2 bits ... voila.
      (rlet ((buf :long))
        (setf (%get-ptr buf) addr)
        (ash (%get-signed-long buf) -2)))))


#|
;;; Lookup the foreign function "gethostname" and call it.
;;; Note that (a) we have to use CCL::PPC-FF-CALL to call the address
;;; (b) that address may become invalid when a saved application is
;;; resumed.
;;; One would want to cache these addresses (and invalidate the cache on
;;; application startup); that's left as an exercise.
;;; The Darwin implementation of gethostname doesn't seem to want to tell
;;; you how big the buffer needs to be.

(defun gethostname ()
  (let* ((gethostname-function-ptr (lookup-function-in-framework
                                    "gethostname" (system-framework-bundle))))
    (%stack-block ((buf 512))
      (if (eql 0 (ccl::ppc-ff-call
                  gethostname-function-ptr
                  :address buf
                  :unsigned-fullword 512
                  :signed-fullword))
        (%get-cstring buf)))))
|#

;;;============================================================================
;;; actr6/core-modules/core-loader.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    : core-loader.lisp
;;; Version     : 1.0a1
;;; 
;;; Description : Compiles (if necessary) and loads the files that implement
;;;               the core modules.
;;; 
;;; Bugs        : 
;;;
;;; To do       : Possibly need special cases for "standalones" as was done
;;;               with the ACT-R 5 loader.
;;; 
;;; ----- History -----
;;;
;;; 2005.01.02 Dan
;;;             : Creation
;;; 2005.01.29 Dan
;;;             : * Changed core-load to use compile-and-load instead of doing
;;;             :   the the same things here.
;;; 2005.09.29 Dan
;;;             : * Added imaginal to the list - I forgot that core-modules
;;;             :   wasn't searched, but loaded in a specific order.
;;; 2005.10.18 Dan
;;;             : * Stripped this down to just the file list.  It makes more
;;;             :   sense to have all the loading in the top-level load file.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; General Docs:
;;; 
;;; loaded by the top level loader so it's not really for general use, but 
;;; may be needed when testing updates.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Public API:
;;;
;;; Nothing for use here.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Design Choices:
;;; 
;;; Just a list of files to be loaded in order from the core-modules directory.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 
;;; 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)

;;; Define the files to be loaded.

(defparameter *file-list '("declarative-memory"
                           "goal"
                           "procedural"
                           "vision"
                           "motor"
                           "audio"
                           "speech"
                           "imaginal"))


#|
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/core-modules/declarative-memory.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    : declarative-memory.lisp
;;; Version     : 1.1
;;; 
;;; Description : Implements the declarative memory module.
;;; 
;;; Bugs        : 
;;;
;;; To do       : [x] Better storage of activation quantities (computed act.,
;;;             :     base-level, and Sji's) for reference since right now
;;;             :     it's all "on the fly" and only available in the trace.
;;;             : [ ] Consider a hook before the module merges cleared buffer
;;;             :     chunks into DM so that someone could have a chance to
;;;             :     touch them first, or maybe prioritize the notify fn's
;;;             :     so that people could hook into things better there.
;;; 
;;; ----- History -----
;;;
;;; 2004.10.15 Dan
;;;             : Creation.
;;; 2004.12.06 Dan
;;;             : Fixed some issues with the hook fns when reset.
;;;             : Brought the line length down to 80.
;;; 2004.12.18 Dan
;;;             : Added the tracing info.
;;; 2005.01.09 Dan
;;;             : Playing around with some optimization ideas for merging
;;;             : since that really kills models with lots of buffer action...
;;;             :
;;;             : The first thought is to hash the chunk contents - the down
;;;             : side is that any mod-chunk to a chunk already in DM is going
;;;             : to cause problems with that.
;;;             : 
;;;             : Add the chunk-hash-table to dm structure.
;;;             : Modify the add-chunk-into-dm and merge-chunk-into-dm
;;;             : to take advantage of that.
;;;             :
;;;             : Seems to work and cuts zbrodoff time almost in half.
;;;             :
;;;             : So, adding it as an option with a new parameter for those
;;;             : that still want to mod-chunk DM.
;;; 2005.01.12 Dan
;;;             : * Updated version to 1.0a2
;;;             : * Shifted the commands to a dm-commands file in tools leaving
;;;             :   this file as solely responsible for the module interface.
;;; 2005.01.17 Dan
;;;             : * Removed calls to format in the scheduling functions.
;;; 2005.01.18 Dan
;;;             : * Added the ability to reset the dm finsts by passing reset
;;;             :   as the value of the :recently-retrieved request parameter.
;;; 2005.01.21 Dan
;;;             : * Did some minor optimizing by having DM organize its chunks
;;;             :   by chunk-type.  That seemed to be the bottle neck in most
;;;             :   of the tutorial models, so trying to speed that up some. 
;;;             : * Don't worry about setting fan unless spreading activation
;;;             :   is enabled.
;;; 2005.01.26 Dan
;;;             : * Changed chunk-base-level usage so that it gets set every
;;;             :   time a base-level is computed regardless of circumstances.
;;;             : * Added the spource-spread parameter to chunks to hold the
;;;             :   activation spread component of the computation.
;;; 2005.02.03 Dan
;;;             : * Added ":output 'medium" and ":output 'low" to some of the 
;;;             :   events that are scheduled to play friendly with the 
;;;             :   new detail level.
;;; 2005.02.04 Dan
;;;             : * Taking advantage of the fast-* chunk accessors.
;;; 2005.02.10 Dan
;;;             : * Switched to the use of expt-coerced, exp-coerced, and 
;;;             :   log-coerced.
;;; 2005.04.01 Dan
;;;             : * Changed the fast-mergeing mechanism to work over chunks
;;;             :   that have merged (but unchanged) chunks in their slots
;;;             :   by using true-chunk-name hash-chunk-contents.
;;; 2005.04.14 Dan
;;;             : * Fixed the parameter setting for the hook functions so that
;;;             :   a value of nil clears it completely.
;;; 2005.04.23 Dan
;;;             : * Added recently-retrieved as a possible query and added
;;;             :   a buffer-status function to show it.
;;;             : * However, the query may not be what people want - the
;;;             :   query returns whether the chunk in the buffer has a
;;;             :   declarative-finst on it at the time of the query which 
;;;             :   may not be the same as when the request was made, but
;;;             :   this seems like the "right" thing to return.
;;; 2005.06.10 Dan
;;;             : * Fixed a bug - terminating an ongoing retrieval didn't
;;;             :   properly clear the events if they had already been 
;;;             :   scheduled to occur.
;;; 2005.06.14 Dan
;;;             : * Fixed an issue with start-retrieval related to :recently-
;;;             :   retrieved reset because what happened is that it cleared
;;;             :   the finsts, but then wanted to find one that had a finst
;;;             :   that matched "reset" which always resulted in failure.
;;; 2005.06.16 Dan
;;;             : * Changed the reference count to only store as many as
;;;             :   are needed...
;;; 2005.06.28 Dan
;;;             : * Removed the :sa parameter and instead changed :mas to
;;;             :   act as both the switch and the value.
;;; 2005.07.29 Dan
;;;             : * Fixed base-level-activation so that if it tries to compute
;;;             :   the activation for a chunk with no references (not yet in
;;;             :   DM) for some reason it prints a warning and returns a very
;;;             :   large negative value.
;;; 2005.08.01 Dan
;;;             : * Fixed a bug that resulted in BLC being added repeatedly
;;;             :   to the activation value.
;;;             :   Side effect is that right now sdp doesn't show the base-
;;;             :   level value (other than the blc) when bll is on.
;;;             :   See the Todo above...
;;;             : * Updated the version to 1.0.
;;; 2005.08.02 Dan
;;;             : * Modified the priority of start-retrieval so that it doesn't
;;;             :   start until the goal buffer has been set.
;;; 2006.06.01 Dan
;;;             : * Added a note to the to do list as a reminder of some thoughts
;;;             :   on an issue that someone might want/need in the future 
;;;             :   (dealing with chunks before they merge into DM) based on 
;;;             :   Mike's intrest in it now.
;;; 2006.07.10 Dan
;;;             : * Changed a call to true-chunk-name to true-chunk-name-fct in
;;;             :   hash-chunk-contents because true-chunk-name is now the macro.
;;; 2006.07.12 Dan
;;;             : * Actually removed the :sa parameter to get rid of the warning.
;;; 2006.08.08 Dan
;;;             : * Fixed spreading-activation so that it doesn't print a warning
;;;             :   when a buffer that should spread activation is empty.
;;; 2006.08.30 Dan
;;;             : * Fixed a bug when partial matching is on - it wasn't taking
;;;             :   the comparison tests (>, <, >=, and <=) into account for a
;;;             :   retrieval request!
;;;             : * Also removed some of the comments that were no longer valid
;;;             :   which were there from the "sample" module details in the
;;;             :   old framework spec.
;;;             : * Reordered how the activation trace prints for partial
;;;             :   matching so things are a bit cleaner when there's a hook.
;;; 2006.09.08 Dan
;;;             : * Changed some parameter checks from posnum to nonneg and
;;;             :   updated the warnings appropriately.
;;; 2006.11.28 Dan
;;;             : * Took an unnecessary get-module out of the query function.
;;; 2006.11.29 Dan
;;;             : * The :pm parameter is now depricated - use :mp as both the
;;;             :   flag and value like :bll and :mas.
;;; 2006.11.30 Dan
;;;             : * Removed the fan parameter from chunks since it wasn't used
;;;             :   for anything now (the fan-list is what's important).
;;;             : * Updated chunks-similarity to use chunk-slot-equal instead
;;;             :   of equal for comparing non-chunk values.
;;; 2006.12.01 Dan
;;;             : * Cleaned up some comments in/around the base-level calculation.
;;; 2006.12.04 Dan
;;;             : * Added the last-base-level chunk parameter and changed the default
;;;             :   for the base-level chunk parameter to nil.
;;;             : * Modified the base-level calculation to set last-base-level and
;;;             :   so that the user setting overrides the :blc when :bll is nil
;;;             :   instead of being addative (makes it like ACT-R 4/5 now).
;;; 2006.12.05 Dan
;;;             : * Minor formatting changes - no real change.
;;; 2006.12.06 Dan
;;;             : * Added the retrieval-activation and retrieval-time 
;;;             :   parameters to the chunk to record the activation value
;;;             :   that it had during a retrieval request and the time at which
;;;             :   that request occured.
;;;             : * Updated the version to 1.1.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; General Docs:
;;; 
;;; The declarative memory module has one buffer called retrieval.
;;;
;;; The declarative memory module collects the chunks that have been cleared
;;; from all buffers.  It merges newly cleared chunks with those that have been
;;; previously cleared.  This set of chunks is refered to as the declarative
;;; memory (DM for short).  Requests to the declarative module are attempts to
;;; find a chunk in DM which matches the request.  If such a chunk is found
;;; it is placed into the retrieval buffer.  If no such chunk is found, then
;;; it reports an error state.  It can only process one request at a time.  If
;;; a new request comes in prior to the completion of a previous request the
;;; older request is terminated immediately. The timing of a request's
;;; completion along with how the matching chunk is found are controled by
;;; several parameters and the following equations:
;;;
;;;
;;; In addition, to that, there is one request parameter which may be used -
;;; :recently-retrieved.  It may be passed a value of t or nil.  The declarative
;;; memory module records which chunks it has returned as the result of a
;;; request and the recently-retrieved request parameter may be used to exclude
;;; chunks based on that information.  There are two parameters that control
;;; how the recently-retrieved designation occurs.  The :dm-finsts parameter
;;; indicates how many chunks will be marked as recently-retrieved and the
;;; :dm-finsts-decay parameter indicates for how many seconds each of those
;;; designations will persist.
;;;
;;; The declarative memory module does not support buffer modification requests.
;;;
;;; The declarative memory module responds to the required queries as follows:
;;;
;;; State free will respond t if there is no request pending or nil if there is
;;;       i.e. the module is not free between the time of a request and when
;;;       the chunk from that request is placed into the buffer.
;;; State busy will respond t if there is a pending request and nil if not.
;;; State error will respond with t if no chunk matching the most recent request 
;;;       could be found or nil otherwise.  The error t will not be indicated 
;;;       until after the time for failure has passed.
;;; Buffer stuffed will respond nil i.e. the declarative module never stuffs
;;;       the buffer.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Public API:
;;;
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Design Choices:
;;; 
;;; One thing that is going in from the beginning is lots of hooks into the
;;; equations.  Every component of the activation equation will have an
;;; "over-ride" function basically like the similarity-hook-fn of the 
;;; older system.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 
;;; 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)

;;; Relies on :esc, :ol, and :er so make sure they exist first

(require-compiled "CENTRAL-PARAMETERS" "ACT-R6:support;central-parameters")

;;; Start by defining a structure to hold the instance of the module

(defstruct dm "an instance of the declarative memory module"
  (chunks (make-hash-table))  ; the set of chunks that are in declarative memory
  (busy nil)    ; record whether the module is busy
  (failed nil)  ; record whether the last request failed
  
  ;;; keep track of the central parameters internally for ease of access
  
  esc er ol
  
  ;;; slots for the various parameters from previous versions
  ;;; that control the subsymbolc
  
  blc ans pas lf le mp ms md rt bll mas 
  
  ;;; add a new parameter to act as a switch for spreading
  ;;; since relying on ga to be zero won't work
  
  sa
    
  ;;; only one of the old traces still really matters
  ;;; or in some cases is even possible - basically show all
  ;;; components that are enabled with this switch
  
  act
  
  ;;; parameters for the declarative finsts count and duration 
  
  num-finsts finst-span
  
  ;;; a list to hold the finsts
  
  finsts
  
  ;;; replace the global hook functions with parameters
  ;;; 
  ;;; Start with the "low-level" hooks that over-ride
  ;;; internal values
  
  sim-hook ;; the old similarity hook 
           ;; called with the two values and returns similarity or nil
  sji-hook ;; same thing now for Sji values - passed the two chunk names 
  
  ;;; Higher level hooks over-ride the entire internal
  ;;; computiation for each component 
  ;;; the chunk name is what gets passed to all
  
  bl-hook         ;; let the user redefine the base-level computation
  spreading-hook  ;; let the user redefine the spreading component
  partial-matching-hook ;; redefinition of the partial matching component
  noise-hook      ;; redefine the transient noise computation
  
  
  ;;; some retrieval hooks like the conflict resolution
  ;;; system has.  Could get some of this from the main
  ;;; event hooks, but seems cleaner to just hook where
  ;;; one wants when possible.  All of these parameters
  ;;; have a list of functions internally which get called.
  ;;; Each setting is pushed onto that list.  No way to remove
  ;;; one other than through a reset.  This is so something
  ;;; like the environment can add such a hook without the
  ;;; user being able to "break" things.
  
  retrieval-request-hook ;; called at the initation of the request with the spec
  
  retrieval-set-hook     ;; called with the chunks that matched the spec. The
                         ;; activations have already been computed but a non-nil
                         ;; return overrides that - like the conflict-set hook.
                         ;; If the return value is a cons of chunk-name and time
                         ;; that is used instead of the computation and if it is
                         ;; just a number, then a failure is scheduled with that
                         ;; latency.
                         ;; If more than one returns a non-nil a warning is
                         ;; signaled and none of those effects occur.
  
  retrieved-chunk-hook   ;; called with the retrieved chunk or nil on failure.
                         ;; The call occurs at the time of the actual retrieval
                         ;; but before the buffer setting - the general event 
                         ;; hook should be used to detect that.
  
  
  ;;; a couple of hooks to support user extensions
  
  chunk-merge-hook  ;; called after a chunk has been merged into dm
  chunk-add-hook    ;; called after a chunk has been newly added to dm
  
  
  ;;; A hash-table of chunks in DM referenced by contents
  ;;; to speed the merging calculation
  
  chunk-hash-table
  
  ;;; A parameter to control whether the hash-table based merging is used
  
  fast-merge
  )


;;; Add the necessary parameters to the chunk definitions

;;; Set to the computed value when necessary

(extend-chunks activation :default-value 0)



;;; Record the chunks in which a chunk occurs

;;; merging is a funny thing here because it could be possible for
;;; the "newer" chunk to have fan to items the "old" one doesn't
;;; but for now that seems unusual and I'm gong to ignore that
;;; at the time of a merge and it can be corrected with a 
;;; call to reset-sjis (replacement for reset-ia) when it 
;;; becomes available.
;;;
;;; The chunk itself should be on the list from the start, but 
;;; when it goes into DM that may need to change because if it
;;; is copied that name will be invalid.

(defun default-fan-list (chunk-name)
  (list chunk-name))

(extend-chunks fan-list :default-function default-fan-list
               :copy-function copy-list)


;;; Not really going to be "creation" time but entry to DM time
;;; which is what will be used in the computations.

(extend-chunks creation-time :default-value 0)


;;; This holds the user set base-level which is only meaningful when
;;; :bll is nil.

(extend-chunks base-level :default-value nil
               :copy-function identity)

;;; This holds the last computed base-level value

(extend-chunks last-base-level :default-value 0
               :copy-function identity)


;;; holds the computed spreading activation component of the chunk

(extend-chunks source-spread :default-value 0
               :copy-function identity)


;;; Merging results in one new reference for the "existing" chunk

(defun merge-reference-list (chunk1 chunk2)
  (declare (ignore chunk2))
  (let* ((dm (get-module declarative))
         (ol (dm-ol dm)))
    (cond ((null ol)
           (cons (mp-time) (chunk-reference-list chunk1)))
          ((eq ol t)
           nil)
          (t ;; ol is a number
           (subseq (cons (mp-time) (chunk-reference-list chunk1))
                   0 (min ol (1+ (length (chunk-reference-list chunk1)))))))))

(defun merge-reference-count (chunk1 chunk2)
  (declare (ignore chunk2))
  (+ 1 (chunk-reference-count chunk1)))


(extend-chunks reference-list :default-value nil
               :copy-function copy-list
               :merge-function merge-reference-list)

(extend-chunks reference-count :default-value 0
               :copy-function identity
               :merge-function merge-reference-count)

;;; Keep the similarities with the chunks
;;; at least for now.

(extend-chunks similarities :default-value nil
               :copy-function copy-tree)

;;; compute the permanent noise as needed

(defun default-permanent-noise (chunk)
  (declare (ignore chunk))
  
  (let ((dm (get-module declarative)))
    (if (and dm (dm-pas dm))
        (act-r-noise (dm-pas dm))
      0.0)))

(extend-chunks permanent-noise :default-function
               default-permanent-noise
               :copy-function identity)


;;; store user define Sji values with the chunk

(extend-chunks sjis :default-value nil
               :copy-function copy-tree)


;;; store the last activation used in a retrieval request and
;;; the time that request occured

(extend-chunks retrieval-activation :default-value nil)
(extend-chunks retrieval-time :default-value nil)



;;; A function for converting a chunk to a list of it's info

(defun hash-chunk-contents (chunk)
  (let* ((ct (chunk-chunk-type-fct chunk))
         (res (list ct)))
    (dolist (slot (chunk-type-slot-names-fct ct) res)
      (push (true-chunk-name-fct (fast-chunk-slot-value-fct chunk slot)) res))))



(defun reset-dm-module (dm)
  
  ;; Set all of the slots of this instance to their initial values.
  
  (clrhash (dm-chunks dm))
  (setf (dm-busy dm) nil)
  (setf (dm-failed dm) nil)
  
  (setf (dm-finsts dm) nil)
  
  ;; parameters will be handled on thier own
  
  
  ;;;
  (setf (dm-chunk-hash-table dm) 
    (make-hash-table :test #'equal))
  
  )



(defun dm-query-request (dm buffer slot value)
  (case slot
    (state
     (case value
       (busy
        (dm-busy dm))
       (free
        (not (dm-busy dm)))
       (error
        (dm-failed dm))
       (t (print-warning  
           "Invalid query made of the ~S buffer with slot ~S and value ~S" 
           buffer slot value))))
    (recently-retrieved
       (setf (dm-finsts dm)
         (remove-if #'(lambda (time)
                        (> (- (mp-time) time)
                           (dm-finst-span dm)))
                    (dm-finsts dm) :key #'cdr))
       
       (and (buffer-read buffer)
            (chunk-copied-from-fct (buffer-read buffer))
            (if value 
                (find (chunk-copied-from-fct (buffer-read buffer))
                      (dm-finsts dm)
                      :key #'car)
              (not (find (chunk-copied-from-fct (buffer-read buffer))
                         (dm-finsts dm)
                         :key #'car)))))))
    
    


(defun dm-request (dm buffer request)
  (declare (ignore buffer)) ;; It is always going to be retrieval
  
  ;; If the module has not completed the last request
 
  (when (dm-busy dm)
    
    ;; Report a warning about that and remove the unexecuted event 
    ;; from the queue.
    
    (model-warning "A retrieval event has been aborted by a new request")
    (delete-event (dm-busy dm)))
  
  ;; Clear the failed attempt flag of the module
  
  (setf (dm-failed dm) nil)
  
  ;; Schedule an event to start the retrieval at the current time
  ;; but with a priority of -2000 and save that as the busy flag
  ;; instead of immediately attempting the retrieval.
  
  ;; Not important for this demonstration, but in the context of 
  ;; a request being made from the RHS of a production this would be
  ;; important to ensure that any buffer modifications have had a chance
  ;; to occur so that the "correct" sources are used for activation spreading.
  
  (setf (dm-busy dm)
    (schedule-event-relative 0 'start-retrieval
                             :module 'declarative
                             :destination 'declarative
                             :details (symbol-name 'start-retrieval)
                             :priority -2000
                             :params (list request)
                             :output 'medium)))


;;; Start-retrieval
;;;
;;; This function is called to actually attempt a retrieval.
;;;
;;; The parameters it receives are an instance of the module and the 
;;; chunk-spec of the request.
;;;
;;; It either schedules the setting of the retrieval buffer or indication of
;;; an error depending on whether or not it finds a chunk that matches the
;;; request.
;;;
;;; There are several parameters that determine how the "best" matching chunk
;;; is selected and how long that action will take.


(defun start-retrieval (dm request)
  
  (dolist (x (dm-retrieval-request-hook dm))
    (funcall x request))
  
  (let* ((ct (chunk-spec-chunk-type request))
         (chunk-list (apply #'append 
                            (mapcar #'(lambda (x) 
                                        (gethash x (dm-chunks dm)))
                              (chunk-type-subtypes-fct ct)))))
        
    (when (member :recently-retrieved (chunk-spec-slots request))
      (let ((recent (chunk-spec-slot-spec request :recently-retrieved)))
        (cond ((> (length recent) 1)
               (print-warning "Invalid retrieval request.")
               (print-warning 
                ":recently-retrieved parameter used more than once.")
               (return-from start-retrieval))
              ((not (or (eq '- (caar recent)) (eq '= (caar recent))))
               (print-warning "Invalid retrieval request.")
               (print-warning 
                ":recently-retrieved parameter's modifier can only be = or -.")
               (return-from start-retrieval))
              ((not (or (eq t (third (car recent)))
                        (eq nil (third (car recent)))
                        (and (eq 'reset (third (car recent)))
                             (eq '= (caar recent)))))
               (print-warning "Invalid retrieval request.")
               (print-warning 
                ":recently-retrieved parameter's value can only be t, nil or reset.")
               (return-from start-retrieval))
              
              (t ;; it's a valid request
               
               ;; remove any old finsts 
               
               (setf (dm-finsts dm)
                 (remove-if #'(lambda (time)
                                (> (- (mp-time) time)
                                   (dm-finst-span dm)))
                            (dm-finsts dm) :key #'cdr))
               
               (if (eq 'reset (third (car recent)))
                 (setf (dm-finsts dm) nil)
               
                 (cond ((or (and (eq t (third (car recent)))   ;; = request t
                                 (eq (caar recent) '=)) 
                            (and (null (third (car recent)))   ;; - request nil
                                 (eq (caar recent) '-)))
                        
                        ;; only those chunks marked are available
                        (setf chunk-list (mapcar #'car (dm-finsts dm)))
                        (when (dm-act dm)
                          (model-output "Only recently retrieved chunks: ~s"
                                        chunk-list)))
                       (t
                        ;; simply remove the marked items
                        ;; may be "faster" to do this later
                        ;; once the set is trimed elsewise, but
                        ;; for now keep things simple
                        
                        (when (dm-act dm)
                          (model-output "Removing recently retrieved chunks:"))
                        
                        (setf chunk-list 
                          (remove-if #'(lambda (x)
                                         (when (member x (dm-finsts dm) 
                                                       :key #'car
                                                       :test #'eq-chunks-fct)
                                           (when (dm-act dm)
                                             (model-output "~s" x))
                                           t))
                                     chunk-list))))))))
      
      (setf request (strip-request-parameters-from-chunk-spec request)))
    
    (let ((best-val nil)
          (best nil)
          (return-val nil)
          (chunk-set 
           (cond ((or (null (dm-esc dm)) (null (dm-mp dm)))
                  ;; for tracing purposes should probably try them all
                  ;; individually instead of doing it in one call
                  ;(find-matching-chunks request :chunks chunk-list)
                  
                  (let ((found nil))
                    (dolist (name chunk-list found)
                      (if (match-chunk-spec-p name request)
                          (progn
                            (when (dm-act dm)
                              (model-output "Chunk ~s matches" name)) 
                            (push-last name found))
                        (when (dm-act dm)
                          (model-output "Chunk ~s does not match" name)))))
                  )
                 (t
                  ;; with esc and pm on then want to use
                  ;; everything that fits the general pattern:
                  ;; correct type
                  ;; slots with a binding not nil
                  ;; empty slots are empty
                  ;; >, <, >=, and <= tests met
                  
                  (find-matching-chunks 
                   (define-chunk-spec-fct 
                       (append (list 'isa (chunk-spec-chunk-type request))
                               (mapcan #'(lambda (x)
                                           (cond ((eq (car x) '=)
                                                  (if (third x)
                                                      (list '- (second x) nil)
                                                    (list '= (second x) nil)))
                                                 ((eq (car x) '-)
                                                  (unless (third x) x))
                                                 ;;; make sure the comparison tests match
                                                 (t x)))
                                 (chunk-spec-slot-spec request))))
                   :chunks chunk-list)))))
      
            
      (if (dm-esc dm)
          (dolist (x chunk-set)
            (compute-activation dm x request)
            
            (setf (chunk-retrieval-activation x) (chunk-activation x))
            (setf (chunk-retrieval-time x) (mp-time))
            
            (cond ((null best-val)
                   (setf best-val (chunk-activation x))
                   (push x best)
                   (when (dm-act dm)
                     (model-output "Chunk ~s has the current best activation ~f" 
                                   x best-val)))
                  ((= (chunk-activation x) best-val)
                   (push x best)
                   (when (dm-act dm)
                     (model-output 
                      "Chunk ~s matches the current best activation ~f" 
                      x best-val)))
                  ((> (chunk-activation x) best-val)
                   (setf best-val (chunk-activation x))
                   (setf best (list x))
                   (when (dm-act dm)
                     (model-output 
                      "Chunk ~s is now the current best with activation ~f" 
                      x best-val)))))
        (setf best chunk-set))
      
      (when (car (dm-retrieval-set-hook dm))
        (dolist (x (dm-retrieval-set-hook dm))
          (let ((val (funcall x chunk-set)))
            (when val
              (if return-val
                  (progn 
                    (print-warning 
                     "multiple set-hook functions returned a value - none used")
                    (setf return-val :error))
                (setf return-val val))))))
      
      (cond ((consp return-val)
             (setf (dm-busy dm) (schedule-event-relative (cdr return-val) 'retrieved-chunk
                                                         :module 'declarative 
                                                         :destination 'declarative 
                                                         :params (list (car return-val))
                                                         :details (concatenate 'string
                                                                    (symbol-name 'retrieved-chunk)
                                                                    " "
                                                                    (symbol-name (car return-val)))
                                                         :output 'medium))
             
             (when (dm-act dm)
                     (model-output 
                      "Retrieval-set-hook funciton forced retrieval of" 
                      (car return-val))))
            
            ((numberp return-val)
             (setf (dm-busy dm) (schedule-event-relative return-val 'retrieval-failure
                                                         :module 'declarative 
                                                         :destination 'declarative 
                                                         :output 'low))
             (when (dm-act dm)
                     (model-output 
                      "Retrieval-set-hook funciton forced retrieval failure")))
            
            ((or (null best) 
                 (and (dm-esc dm)
                      (< best-val (dm-rt dm))))
             (setf (dm-busy dm) (schedule-event-relative 
                                 (if (dm-esc dm)
                                     (compute-activation-latency dm (dm-rt dm))
                                   0)
                                 'retrieval-failure
                                 :module 'declarative 
                                 :destination 'declarative
                                 :output 'low))
               
             (when (and (dm-act dm) (null best))
               (model-output 
                "No matching chunk found retrieval failure"))
             
             (when (and (dm-act dm) best)
               (model-output 
                "No chunk above the retrieval threshold: ~f" (dm-rt dm)))
             )
            
            ((= (length best) 1)
             (setf (dm-busy dm) (schedule-event-relative 
                                 (if (dm-esc dm)
                                     (compute-activation-latency dm (chunk-activation (car best)))
                                   0)
                                 'retrieved-chunk
                                 :module 'declarative 
                                 :destination 'declarative 
                                 :params best
                                 :details 
                                 (concatenate 'string
                                   (symbol-name 'retrieved-chunk)
                                   " "
                                   (symbol-name (car best)))
                                 :output 'medium))
             (when (dm-act dm)
               (model-output 
                "Chunk ~s with activation ~f is the best"
                (car best) (chunk-activation (car best)))))
            (t
             (let ((best1 (if (dm-er dm)
                              (random-item best)
                            (car (sort best #'string<)))))
               
               (setf (dm-busy dm) (schedule-event-relative 
                                   (if (dm-esc dm)
                                       (compute-activation-latency dm (chunk-activation best1))
                                     0)
                                   'retrieved-chunk
                                   :module 'declarative 
                                   :destination 'declarative 
                                   :params (list best1)
                                   :details 
                                   (concatenate 'string
                                     (symbol-name 'retrieved-chunk)
                                     " "
                                     (symbol-name best1))
                                   :output 'medium))
               
               (when (dm-act dm)
                 (model-output 
                  "Chunk ~s chosen among the chunks with activation ~f"
                  best1 (chunk-activation best1)))))))))
  

;;; Retrieved-chunk
;;;
;;; Called as an event when a chunk has been retrieved and is ready to be placed
;;; into the buffer.
;;;
;;; The parameters are an instance of the module and the name of the chunk 
;;; to put in the buffer.

(defun retrieved-chunk (dm chunk)
  
  ;; Clear the busy flag
  
  (setf (dm-busy dm) nil)
  
  
  (when (car (dm-retrieved-chunk-hook dm))
    (dolist (x (dm-retrieved-chunk-hook dm))
      (funcall x chunk)))
  
  ;; Schedule an event to put the chunk into the buffer right now instead of
  ;; placing it there directly to comply with the guideline that buffer changes
  ;; should be scheduled.
  
  (schedule-set-buffer-chunk 'retrieval chunk 0 
                             :module 'declarative 
                             :priority :max)
  
  ;; update the marker for having retrieved this chunk
  
  (update-declarative-finsts dm chunk)
  )


(defun update-declarative-finsts (dm chunk)
  (setf (dm-finsts dm) (remove chunk (dm-finsts dm) :key #'car 
                               :test #'eq-chunks-fct))
  (push (cons chunk (mp-time)) (dm-finsts dm))
  (setf (dm-finsts dm) (subseq (dm-finsts dm) 0 (min (length (dm-finsts dm))
                                                     (dm-num-finsts dm)))))

;;; Retrieval-failure
;;;
;;; Called as an event when a chunk failed to be found in response to a request.
;;;
;;; The parameter is an instance of the module.

(defun retrieval-failure (dm)
  
  ;; Clear the busy flag and set the failure flag.
  
  (setf (dm-busy dm) nil)
  
  (when (car (dm-retrieved-chunk-hook dm))
    (dolist (x (dm-retrieved-chunk-hook dm))
      (funcall x nil)))
  
  (setf (dm-failed dm) t))


;;; Dm-params
;;;

(defun dm-params (dm param)
  (cond ((consp param)
         
         (when (hash-table-keys (dm-chunks dm))
           (print-warning 
            "Changing declarative parameters with chunks in dm not supported.")
           (print-warning 
            "Results may not be what one expects."))
         
         (case (car param)
           (:esc (setf (dm-esc dm) (cdr param)))
           (:er (setf (dm-er dm) (cdr param)))
           (:ol (setf (dm-ol dm) (cdr param)))
           
           (:blc (setf (dm-blc dm) (cdr param)))
           (:ans (setf (dm-ans dm) (cdr param)))
           (:pas (setf (dm-pas dm) (cdr param)))
           (:lf (setf (dm-lf dm) (cdr param)))
           (:le (setf (dm-le dm) (cdr param)))
           (:mp (setf (dm-mp dm) (cdr param)))
           (:ms (setf (dm-ms dm) (cdr param)))
           (:md (setf (dm-md dm) (cdr param)))
           (:rt (setf (dm-rt dm) (cdr param)))
           (:bll (setf (dm-bll dm) (cdr param)))
           (:mas (setf (dm-mas dm) (cdr param))
                 (setf (dm-sa dm) (cdr param)))
           (:pm (setf (dm-mp dm) 
                  (if (cdr param) 
                      (progn
                        (print-warning "The :pm parameter is now depricated.  Like :bll and :mas, the :mp parameter is now both a flag and a value.")
                        (print-warning "Setting :pm will change :mp to 1.0.")
                        1.0)
                    nil)))
           
           (:act (setf (dm-act dm) (cdr param)))
           
           (:declarative-num-finsts (setf (dm-num-finsts dm) (cdr param)))
           (:declarative-finst-span (setf (dm-finst-span dm) (cdr param)))
                   
           (:sim-hook (setf (dm-sim-hook dm) (cdr param)))
           (:sji-hook (setf (dm-sji-hook dm) (cdr param)))
                      
           (:bl-hook (setf (dm-bl-hook dm) (cdr param)))
           (:spreading-hook (setf (dm-spreading-hook dm) (cdr param)))
           (:partial-matching-hook (setf (dm-partial-matching-hook dm) 
                                     (cdr param)))
           (:noise-hook (setf (dm-noise-hook dm) (cdr param)))
           
           
           (:fast-merge (setf (dm-fast-merge dm) (cdr param)))

           
           (:retrieval-request-hook 
            (if (cdr param)
              (if (member (cdr param) (dm-retrieval-request-hook dm))
                (print-warning 
                 "Setting parameter ~s failed because ~s already on the hook."
                 :retrieval-request-hook
                 (cdr param))
                (push (cdr param) (dm-retrieval-request-hook dm)))
              (setf (dm-retrieval-request-hook dm) nil)))
           
           (:retrieval-set-hook 
            (if (cdr param)
                (if (member (cdr param) (dm-retrieval-set-hook dm))
                    (print-warning 
                     "Setting parameter ~s failed because ~s already on the hook."
                     :retrieval-set-hook
                     (cdr param))
                  (push (cdr param) (dm-retrieval-set-hook dm)))
              (setf (dm-retrieval-set-hook dm) nil)))
           
           (:retrieved-chunk-hook 
            (if (cdr param)
                (if (member (cdr param) (dm-retrieved-chunk-hook dm))
                    (print-warning 
                     "Setting parameter ~s failed because ~s already on the hook."
                     :retrieved-chunk-hook
                     (cdr param))
                  (push (cdr param) (dm-retrieved-chunk-hook dm)))
              (setf (dm-retrieved-chunk-hook dm) nil)))
           
           (:chunk-merge-hook 
            (if (cdr param)
                (if  (member (cdr param) (dm-chunk-merge-hook dm))
                    (print-warning 
                     "Setting parameter ~s failed because ~s already on the hook."
                     :chunk-merge-hook
                     (cdr param))
                  (push (cdr param) (dm-chunk-merge-hook dm)))
              (setf (dm-chunk-merge-hook dm) nil)))
           
           (:chunk-add-hook 
            (if (cdr param)
                (if (member (cdr param) (dm-chunk-add-hook dm))
                    (print-warning 
                     "Setting parameter ~s failed because ~s already on the hook."
                     :chunk-add-hook
                     (cdr param))
                  (push (cdr param) (dm-chunk-add-hook dm)))
              (setf (dm-chunk-add-hook dm) nil)))))
        (t 
         (case param
           
           (:blc (dm-blc dm))
           (:ans (dm-ans dm))
           (:pas (dm-pas dm))
           (:lf (dm-lf dm))
           (:le (dm-le dm))
           (:mp (dm-mp dm))
           (:ms (dm-ms dm))
           (:md (dm-md dm))
           (:rt (dm-rt dm))
           (:bll (dm-bll dm))
           (:mas (dm-mas dm))
           (:pm (if (dm-mp dm) t nil))
           (:sa (progn
                  (print-warning "The :SA parameter is no longer used") 
                  nil))
           (:act (dm-act dm))
           
           (:declarative-num-finsts (dm-num-finsts dm))
           (:declarative-finst-span (dm-finst-span dm))
        
           (:sim-hook (dm-sim-hook dm))
           (:sji-hook (dm-sji-hook dm))
                      
           (:bl-hook (dm-bl-hook dm))
           (:spreading-hook (dm-spreading-hook dm))
           (:partial-matching-hook (dm-partial-matching-hook dm))
           (:noise-hook (dm-noise-hook dm))           
           
           (:fast-merge (dm-fast-merge dm))
           
           (:retrieval-request-hook (dm-retrieval-request-hook dm))
           (:retrieval-set-hook (dm-retrieval-set-hook dm))
           (:retrieved-chunk-hook (dm-retrieved-chunk-hook dm))
           
           (:chunk-merge-hook (dm-chunk-merge-hook dm))
           (:chunk-add-hook (dm-chunk-add-hook dm))))))





;;; Merge-chunk-into-dm
;;;
;;; This function will be called automatically each time a buffer is cleared.
;;;
;;; The parameters are an instance of the module, the name of the buffer that 
;;; was cleared, and the name of the chunk that was in the buffer.
;;;
;;; This module adds that chunk to declarative memory and increments its 
;;; reference count.  If a matching chunk already exists in declarative memory,
;;; then those chunks are merged together.  If this is the first occurrence of 
;;; the chunk, then its initial parameters are set accordingly.

(defun merge-chunk-into-dm (dm buffer chunk)
  (declare (ignore buffer))  ;; don't care which buffer it came from
  
  ;; Find any existing matching chunk

  (let ((existing 
         (if (dm-fast-merge dm)
             (gethash (hash-chunk-contents chunk) (dm-chunk-hash-table dm))
           (find chunk (gethash (chunk-chunk-type-fct chunk) (dm-chunks dm))
                 :test #'equal-chunks-fct))))
        
    (if existing
        (progn
          
          (merge-chunks-fct existing chunk)  ;; merging functions handle params
          
          (when (car (dm-chunk-merge-hook dm))
            (dolist (x (dm-chunk-merge-hook dm))
              (funcall x chunk))))
      
      ;; otherwise add it to the list
      
      (add-chunk-into-dm dm chunk))))

;; add-chunk-into-dm
;;;
;;; works like merge-chunk-into-dm but without doing any merging i.e. it
;;; makes the chunk part of dm and sets it's initial parameters regardless
;;; of whether it is a perfect match to an existing member
;;;

(defun add-chunk-into-dm (dm chunk)
  
  (push chunk (gethash (chunk-chunk-type-fct chunk) (dm-chunks dm)))
  
  (when (dm-fast-merge dm)
    (setf (gethash (hash-chunk-contents chunk) (dm-chunk-hash-table dm))
      chunk))
  
  ;; set the parameters
  
  (setf (chunk-creation-time chunk) (mp-time))
  (setf (chunk-reference-list chunk) (list (mp-time)))
  (setf (chunk-reference-count chunk) 1)
  
  
  ;; make sure that it has its own name on the fan-list
  ;; because that may not be true after copying, but
  ;; until it enters DM it doesn't really matter
  
  (unless (eq (car (last (chunk-fan-list chunk))) chunk)
    (setf (chunk-fan-list chunk) 
      (append (butlast (chunk-fan-list chunk))
              (list chunk))))  
  
  ;; For the chunks in slots of this chunk increase their fan
  ;; But only do that when spreading activation is on, otherwise
  ;; it doesn't matter...
  (when (dm-sa dm)
    (let ((new-fans (mapcan #'(lambda (slot)
                                (when (chunk-p-fct 
                                       (fast-chunk-slot-value-fct chunk slot))
                                  (list (fast-chunk-slot-value-fct chunk slot))))
                      (chunk-type-slot-names-fct 
                       (chunk-chunk-type-fct chunk)))))
      (dolist (c new-fans)
        (push chunk (chunk-fan-list c)))))
  
  (when (car (dm-chunk-add-hook dm))
    (dolist (x (dm-chunk-add-hook dm))
      (funcall x chunk))))

 
;;; Add-dm
;;; Add-dm-fct
;;;
;;; User level function for creating chunks and placing them directly into the
;;; declarative memory list of the declarative memory module of the current 
;;; model.
;;;
;;; It takes a parameter which is a chunk definition list like define-chunk-fct
;;; takes.  Those chunks are created and then added to the declarative memory 
;;; list with the current creation time and 1 reference.

(defmacro add-dm (&rest chunk-list)
  `(add-dm-fct ',chunk-list))

(defun add-dm-fct (chunk-definitions)
  
  ;; Need to find the current instance of the declarative module
  
  (let ((dm (get-module declarative)))  

    ;; if there is one, create the chunks and set the parameters

    (if (dm-p dm)  

        ;; pass the list of chunk defs off to define-chunks 
        ;; to do the creation

        (let ((chunks (define-chunks-fct chunk-definitions)))

          ;; Then iterate over those chunks and add them to the module

          (dolist (chunk chunks chunks)
            (add-chunk-into-dm dm chunk)))
          
       ;; otherwise report a warning to the meta-process because there may not
       ;; be a current model 

      (print-warning 
       "Could not create chunks because no declarative module was found"))))       


;;; Call define-module to hook the module into the framework.

;;; Indicate that it is to be named declarative and that it
;;; has a buffer called retrieval.


(define-module-fct 'declarative 
    (list (list 'retrieval nil '(:recently-retrieved) '(recently-retrieved)
                 #'(lambda ()
                     (command-output "  recently-retrieved nil: ~S"
                                     (query-buffer 'retrieval 
                                                   '((recently-retrieved . nil))))
                     (command-output "  recently-retrieved t  : ~S"
                                     (query-buffer 'retrieval 
                                                   '((recently-retrieved . t))))
                               ))) 
  (list (define-parameter :esc :owner nil)
        (define-parameter :er :owner nil)
        (define-parameter :ol :owner nil)
        
        (define-parameter :blc :valid-test #'numberp :default-value 0.0
          :warning "a number" :documentation "Base Level Constant")
        (define-parameter :ans :valid-test #'posnumornil :default-value nil
          :warning "a positive number or nil" :documentation "Activation Noise S")
        (define-parameter :pas :valid-test #'posnumornil :default-value nil
          :warning "a positive number or nil" 
          :documentation "Permanent Activation noise S")
        (define-parameter :lf :valid-test #'nonneg :default-value 1.0
          :warning "a non-negative number" :documentation "Latency Factor")
        (define-parameter :le :valid-test #'nonneg :default-value 1.0
          :warning "a non-negative number" :documentation "Latency Exponent")
        (define-parameter :mp :valid-test #'numornil :default-value nil
          :warning "a number or nil" :documentation "Mismatch Penalty")
        (define-parameter :ms :valid-test #'numberp :default-value 0.0
          :warning "a number" :documentation "Maximum Similarity")
        (define-parameter :md :valid-test #'numberp :default-value -1.0
          :warning "a number" :documentation "Maximum Difference")
        (define-parameter :rt :valid-test #'numberp :default-value 0.0
          :warning "a number" :documentation "Retrieval Threshold")
        (define-parameter :bll :valid-test #'posnumornil :default-value nil
          :warning "a positive number or nil" :documentation "Base Level Learning")        
        (define-parameter :mas :valid-test #'numornil :default-value nil
          :warning "a number or nil" :documentation "Maximum Associative Strength")
        (define-parameter :pm :valid-test #'tornil :default-value nil
          :warning "T or nil" :documentation "Depricated - use :mp as both the flag and value instead (like :bll and :mas)")
        (define-parameter :act :valid-test #'tornil :default-value nil
          :warning "T or nil" :documentation "Activation Trace")
        
        (define-parameter :fast-merge :valid-test #'tornil :default-value t
          :warning "T or nil" 
          :documentation "Whether or not to use the fast merge mechanism")
        
        
        (define-parameter :declarative-num-finsts
            :valid-test #'posnum :default-value 4
          :warning "positive number" 
          :documentation "Number of declarative finst markers")
        
        
        (define-parameter :declarative-finst-span
            :valid-test #'posnum :default-value 3.0
          :warning "positive number" 
          :documentation "Duration of declarative finst markers in seconds")

        
        (define-parameter :sim-hook :valid-test #'fctornil :default-value nil
          :warning "a function or nil" :documentation "Similarity hook")
        (define-parameter :sji-hook :valid-test #'fctornil :default-value nil
          :warning "a function or nil" :documentation "Sji hook")
        
        
        (define-parameter :bl-hook :valid-test #'fctornil :default-value nil
          :warning "a function or nil" 
          :documentation "Baselevel component hook")
        (define-parameter :spreading-hook :valid-test #'fctornil 
          :default-value nil
          :warning "a function or nil" 
          :documentation "Spreading component hook")
        (define-parameter :partial-matching-hook :valid-test #'fctornil 
          :default-value nil
          :warning "a function or nil" 
          :documentation "Partial matching component hook")
        (define-parameter :noise-hook :valid-test #'fctornil 
          :default-value nil
          :warning "a function or nil" :documentation "Noise component hook")
        
        (define-parameter :retrieval-request-hook :valid-test #'fctornil 
          :default-value nil
          :warning "a function or nil" 
          :documentation "Retrieval notification hook")
        (define-parameter :retrieval-set-hook 
            :valid-test #'fctornil :default-value nil
          :warning "a function or nil" 
          :documentation "Prospective retrievals hook")
        (define-parameter :retrieved-chunk-hook :valid-test #'fctornil 
          :default-value nil
          :warning "a function or nil" 
          :documentation "Retrieval completion hook")
        
        (define-parameter :chunk-merge-hook :valid-test #'fctornil 
          :default-value nil
          :warning "a function or nil" 
          :documentation "Hook called when a chunk is merged into dm")
        (define-parameter :chunk-add-hook :valid-test #'fctornil 
          :default-value nil
          :warning "a function or nil" 
          :documentation "Hook called when a chunk is added to dm"))
  
  :version "1.1" 
  :documentation 
  "The declarative memory module stores chunks from the buffers for retrieval"
  
  ;; The creation function returns a new dm structure
  ;; that doesn't require knowing the current model's name
  
  :creation (lambda (x) (declare (ignore x)) (make-dm))
    
  :reset 'reset-dm-module
  :query 'dm-query-request
  :request 'dm-request
  :params 'dm-params
  :notify-on-clear 'merge-chunk-into-dm
  )

;;; Functions to compute activations and latency


(defun compute-activation (dm chunk request)
  
  (when (dm-act dm)
    (model-output "Computing activation for chunk ~s" chunk))
  
  (setf (chunk-activation chunk) 
    (+ (base-level-activation dm chunk)
       (spreading-activation dm chunk)
       (partial-matching dm chunk request)
       (activation-noise dm chunk)))
  
  (when (dm-act dm)
    (model-output "Chunk ~s has an activation of: ~f" chunk (chunk-activation chunk))))


(defun base-level-activation (dm chunk)
  
  (when (dm-act dm)
    (model-output "Computing base-level"))
  
  (let ((base-level nil))
    
    (when (dm-bl-hook dm)
      (setf base-level (funcall (dm-bl-hook dm) chunk)))
    
    (cond ((numberp base-level)
           (when (dm-act dm)
             (model-output "base-level hook returns: ~f" base-level)))
          (t
           (setf base-level 
             (cond ((dm-bll dm)
                    (+ (progn
                         (when (dm-act dm)
                           (model-output "Starting with blc: ~f" (dm-blc dm)))
                         (dm-blc dm))
                       (cond ((zerop (chunk-reference-count chunk))
                              (model-warning "Cannot compute base-level for a chunk with no references.")
                              -999999.0)
                             (t ;; just use the ACT-R 5 function basically as is for now
                              (compute-references dm (chunk-reference-count chunk)
                                                  (chunk-reference-list chunk) (chunk-creation-time chunk)
                                                  (- (dm-bll dm)))))))
                   (t ;; bll nil
                    (if (chunk-base-level chunk)
                        (progn
                          (when (dm-act dm)
                            (model-output "User provided chunk base-level: ~f" (chunk-base-level chunk)))
                          (chunk-base-level chunk))
                      (progn
                        (when (dm-act dm)
                          (model-output "Starting with blc: ~f" (dm-blc dm)))
                        (dm-blc dm)))))
             
             #|(+ (progn
                                 (when (dm-act dm)
                                   (model-output "Starting with blc: ~f" (dm-blc dm)))
                                 (dm-blc dm))
                               (cond ((null (dm-bll dm))
                                      (when (dm-act dm)
                                        (model-output "User provided chunk base-level: ~f" (chunk-base-level chunk)))
                                      (chunk-base-level chunk))
                                     ((zerop (chunk-reference-count chunk))
                                      (model-warning "Cannot compute base-level for a chunk with no references.")
                                      -999999.0)
                                     (t ;; just use the ACT-R 5 function basically as is for now
                                      (compute-references dm (chunk-reference-count chunk)
                                                          (chunk-reference-list chunk) (chunk-creation-time chunk)
                                                          (- (dm-bll dm))))))
             
             |#
             )
           (when (dm-act dm)
             (model-output "Total base-level: ~f" base-level))))
    (setf (chunk-last-base-level chunk) base-level)))


#|
Interesting note on spreading activation and the retrieval buffer.
Currently, the retrieval buffer will never be an active source of
activation because the buffer will clear before the request is made.
That is the desired current implementation - no buffers get treated
special and all production actions are allowed to occur before the
retrieval is attempted.

That may need to be revisited at some point, but for now parsimony
of operation is more important.

|#

(defun spreading-activation (dm chunk)
  (setf (chunk-source-spread chunk)
    (if (dm-sa dm)
        (let ((sa nil))
          (when (dm-act dm)
            (model-output "Computing activation spreading from buffers"))
          
          (when (dm-spreading-hook dm)
            (setf sa (funcall (dm-spreading-hook dm) chunk)))
          
          (cond ((numberp sa)
                 (when (dm-act dm)
                   (model-output "spreading activation hook returns: ~f" sa))
                 sa)
                (t
                 
                 (let ((total-spread 0.0))
                   (dolist (buffer (buffers))
                     (unless (or (zerop (buffer-spread buffer))
                                 (null (buffer-read buffer))) 
                       (let ((buffer-chunk (buffer-read buffer)))
                         
                         (when (dm-act dm)
                           (model-output "  Spreading ~f from buffer ~s chunk ~s" 
                                         (buffer-spread buffer) buffer buffer-chunk))
                         
                         (let ((js (mapcan #'(lambda (slot)
                                               (when (chunk-p-fct (fast-chunk-slot-value-fct buffer-chunk slot))
                                                 (list (fast-chunk-slot-value-fct buffer-chunk slot))))
                                     (chunk-type-slot-names-fct (chunk-chunk-type-fct (buffer-read buffer))))))
                           
                           (when (dm-act dm)
                             (model-output "    sources of activation are: ~s" js))
                           
                           (dolist (j js)
                             (let* ((sji (compute-sji dm j chunk))
                                    (level (/ (buffer-spread buffer) (length js)))
                                    (total (* level sji)))
                               
                               (when (dm-act dm)
                                 (model-output "    Spreading activation  ~f from source ~s level  ~f times Sji ~f"
                                               total j level sji))
                               
                               (incf total-spread total)))))))
                   (when (dm-act dm)
                     (model-output "Total spreading activation: ~f" total-spread)) 
                   total-spread))))
      0.0)))


(defun compute-sji (dm j i)
  (let ((sji (if (dm-sji-hook dm)
                 (funcall (dm-sji-hook dm) j i)
               nil)))
    
    (if (numberp sji)
        sji
      (if (assoc j (chunk-sjis i) :test #'eq-chunks-fct)
          (cdr (assoc j (chunk-sjis i) :test #'eq-chunks-fct))
        (if (member i (chunk-fan-list j) :test #'eq-chunks-fct)
            (- (dm-mas dm) (log-coerced (chunk-fan-j-to-i j i)))
          0.0)))))

(defun chunk-fan-j-to-i (j i)
  (/ (length (chunk-fan-list j))
     (count i (chunk-fan-list j) :test #'eq-chunks-fct)))


(defun partial-matching (dm chunk request)
  (if (dm-mp dm)
      (progn
        (when (dm-act dm)
          (model-output "Computing partial matching component"))
        (let ((pm (when (dm-partial-matching-hook dm)
                    (funcall (dm-partial-matching-hook dm) chunk request))))
          
          (cond ((numberp pm) 
                 (when (dm-act dm)
                   (model-output "partial matching hook returns: ~f" pm))
                 pm)
                (t
                 
                 (let ((total-sim 0.0))
                   (dolist (k (chunk-spec-slot-spec request))
                     (when (and (or (eq (car k) '=)
                                    (eq (car k) '-))
                                (not (chunk-spec-variable-p (third k))))
                       (when (dm-act dm)
                         (model-output "  comparing slot ~S"
                                       (second k))
                         (model-output "  Requested: ~s ~s  Chunk's slot value: ~s"
                                       (first k)
                                       (third k) 
                                       (fast-chunk-slot-value-fct 
                                        chunk
                                        (second k))))
                       
                       (let* ((sim (chunks-similarity dm (third k) 
                                                      (fast-chunk-slot-value-fct chunk
                                                                                 (second k))))
                              
                              
                              (sim-dif (case (car k) 
                                         (= (* (dm-mp dm) sim))
                                         
                                         (- (cond ((= sim (dm-ms dm))
                                                   (* (dm-mp dm) (dm-md dm)))
                                                  ; ACT-R 5 doesn't do this, but
                                                  ; it seems like maybe it should
                                                  ;((= sim (dm-md dm))
                                                  ; (* (dm-mp dm) (dm-ms dm)))
                                                  (t
                                                   (when (dm-act dm)
                                                     (model-output 
                                                      "  negation test with similarity not ms has no effect"))
                                                   0))))))
                         
                         (when (dm-act dm)
                           (model-output "  similarity increased by ~f"
                                         sim-dif))
                         
                         (incf total-sim sim-dif)
                         
                         )))
                   (when (dm-act dm)
                     (model-output "Total similarity ~f"
                                   total-sim))
                   
                   total-sim)))))
    0.0))


(defun chunks-similarity (dm chunk1 chunk2)
  (let ((sim (if (dm-sim-hook dm)
                 (funcall (dm-sim-hook dm) chunk1 chunk2)
               nil)))
    (cond ((numberp sim)
        (when (dm-act dm)
          (model-output "  similarity hook returns: ~f" sim))
           sim)
          (t (setf sim (cond ((not (and (chunk-p-fct chunk1)
                                        (chunk-p-fct chunk2)))
                              (if (chunk-slot-equal chunk1 chunk2)
                                  (dm-ms dm) (dm-md dm)))
                             ((assoc chunk1 (chunk-similarities chunk2) :test #'eq-chunks-fct)
                              (cdr (assoc chunk1 (chunk-similarities chunk2) :test #'eq-chunks-fct)))
                             ((eq-chunks-fct chunk1 chunk2)
                              (dm-ms dm))
                             (t (dm-md dm))))
             (when (dm-act dm)
               (model-output "  similarity: ~f" sim))
             sim))))


(defun activation-noise (dm chunk)
  (let ((noise (when (dm-noise-hook dm)
                   (funcall (dm-noise-hook dm) chunk))))
                 
    (cond ((numberp noise)
           (when (dm-act dm)
             (model-output "noise hook returns: ~f" noise))
           noise)
          (t
           (setf noise (if (dm-ans dm)
                           (act-r-noise (dm-ans dm))
                         0.0))
    
           (when (dm-act dm)
             (model-output "Adding transient noise ~f" noise)
             (model-output "Adding permanent noise ~f" 
                           (chunk-permanent-noise chunk)))
      
           (+ noise (chunk-permanent-noise chunk))))))
    

(defun compute-activation-latency (dm activation)
  (* (dm-lf dm)
     (exp-coerced (* -1 (dm-le dm) activation))))


;;; Christian's function from ACT-R 5

(defun compute-references (dm n references creation-time minus-decay)
  "Computes generalized decay formula from number and list of references,
   creation time and minus the decay rate."
  
  (when (dm-act dm)
    (model-output "Computing base-level from ~d references ~S" n references)
    (model-output "  creation time: ~f decay: ~f  Optimized-learning: ~s"
                  creation-time (- minus-decay) (dm-ol dm)))
  
  (let ((value 0.0)
        (last-reference 0.0))
    (when references
      (dolist (reference references)
        (incf value (expt-coerced (max .05 (- (mp-time) reference))
                             minus-decay))
        (setf last-reference reference)))
    
    (when (dm-ol dm)
      (let ((denominator (+ 1.0 minus-decay)))
        (if (numberp (dm-ol dm))
          (when (> n (dm-ol dm))
            (incf value (/ (* (- n (dm-ol dm))
                              (- (expt-coerced (- (mp-time) creation-time) denominator)
                                 (expt-coerced (- (mp-time) last-reference) denominator)))
                           (* (max .05 (- last-reference creation-time)) denominator))))
          
          (setf value (/ (* n (expt-coerced (max .05 (- (mp-time) creation-time)) minus-decay))
                         denominator)))))
    
    (when (dm-act dm)
      (model-output "base-level value: ~f" (log-coerced value)))
    (log-coerced value)))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Some postentially useful Declarative module accessing tools


(defun all-dm-chunks (dm)
  (apply #'append
         (mapcar #'(lambda (x)
                     (gethash x (dm-chunks dm)))
           (hash-table-keys (dm-chunks dm)))))

#|
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/devices/acl/device.lisp
;;;============================================================================

;;;  -*- mode: LISP; Package: CL-USER; Syntax: COMMON-LISP;  Base: 10 -*-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 
;;; Author      : Dan Bothell (plus code from Tech support at Franz Inc.)
;;; Address     : Carnegie Mellon University
;;;             : Psychology Department
;;;             : Pittsburgh,PA 15213-3890
;;;             : db30+@andrew.cmu.edu
;;; 
;;; Copyright   : (c)2000-2004 Dan Bothell
;;; Availability: Covered by the GNU LGPL, see LGPL.txt
;;; 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 
;;; Filename    : device.lisp
;;; Version     : 1.0a1
;;; 
;;; Description : ACL-specific functions for RPM.  This consists primarily
;;;             : of stuff for vision (parsing the screen), and output
;;;             : stuff for motor.
;;;             : I'm unsure if this file should stay in the main distribution -
;;;             : I think it should be dropped down to the extras.
;;; 
;;; Bugs        : 
;;;
;;; Todo        : Document this file better...
;;;             : There's an issue with human pressing of "punctuation" keys
;;;             : because ACL sends the vk- code instead of the ASCII for
;;;             : things like comma and semicolon so it differs from what the
;;;             : model does.  Don't know if it's worth fixing, but is somthing
;;;             : to be aware of if using real ACL windows and not visible-
;;;             : virtuals.
;;;             : * Make this work with a packaged ACT-R - the problem is 
;;;             :   that some of the cg functions are't exported from cg-user
;;;             :   so just having that on the uses of the :act-r package
;;;             :   isn't sufficient...
;;; 
;;; --- History ---
;;; 00.01.25 Dan Bothell
;;;             : First version.
;;;             : function comments copied from mcl-interface.
;;; 00.06.08 mdb
;;;             : Moved POPULATE-LOC-TO-KEY-ARRAY method here.
;;; 00.09.05 Dan
;;;             : Fixed all of the text feature building to correctly
;;;             : use ascent and descent parameters for the font instead of
;;;             : only using the font-height.
;;;             : Made the changes to bring it up to speed with 2.0b3
;;;             : Specifically:
;;;             :    Added a focus ring.
;;;             :    Changed from xy lists to vectors.
;;;             :    Fixed the build-features-for for buttons.
;;;             :    Added the approach-width method for text features
;;;             :    so that if it's on a button it's computed correctly.
;;; 01.04.12 Dan
;;;             : Added a hack to get around the keypad not returning
;;;             :    numbers.
;;;             : Changed the focus ring so that it didn't 'eat' the
;;;             :    the keypresses.
;;; 02.01.15 Dan
;;;             : Added some feature checks to better handle ACL versions
;;;             : other than 5.0.1.  It's still not perfect however because
;;;             : in ACL 6 or newer the focus ring doesn't erase 
;;;             : and I haven't figured out how to fix that yet.
;;; 02.06.07 Dan
;;;             : Finally got to the bottom of the focus ring stuff because
;;;             : I needed it to work in ACL 6.1 and it had a couple
;;;             : of issues - it stole mouse clicks and kept being recreated,
;;;             : but it's all better now.
;;; 02.06.21 Dan [b7]
;;;             : Changed rpm-window class to rpm-real-window class
;;;             : and updated all the methods accordingly.
;;; 02.06.30 Dan
;;;             : Removed the UWI code from this file.
;;;             : Moved the view-line and color mapping code into this file.
;;; 02.11.25 Dan
;;;             : Changed the model's pressing of the escape key from #\esc to
;;;             : vk-escape because that's what ACL uses for "real" escape 
;;;             : presses so this makes the model act the same i.e. the same
;;;             : key handling code works for both a model and human.
;;;             : Might impact some existing models.
;;; 02.12.23 Dan 
;;;             : Added the around method for the build-features-for of text
;;;             : items to handle color.
;;; 03.01.24 Dan
;;;             : Redefine the attr-exact-match-p method because of the issue
;;;             : raised by adding the colors - ACL defines red, blue, green,
;;;             : etc as special symbols that cause problems in RHS requests
;;;             : so those need to be caught and handled differently.  I don't 
;;;             : think there are any LHS issues to resolve, but we'll see...
;;;
;;; 04.04.13 Dan [2.2] (both previous changes are also "new" in 2.2)
;;;             : Changed the copyright notice and added the LGPL stuff.
;;;
;;; 04.10.19 Dan [Moved into ACT-R 6]
;;;             : Reset the version to 1.0a1
;;;             : added the packaging switches
;;;             : changed the name to device to be placed in a folder called acl
;;;             : following the MCL exaple, got rid of the do-update method
;;;             :   (which is necessary anyway) and replaced it with the 
;;;             :   device-update :after method to do basically the same thing
;;; 2005.02.17 Dan
;;;             : * Added the use-package to deal with the packaging stuff.
;;; 2005.08.10 Dan
;;;             : * Minor clean-up of compiler warnings.  Wrapped an eval-when
;;;             :   around the use-package and added some ignores.
;;;             : * Fixed build-features-for button items with multiple lines
;;;             :   of text (I think).
;;;             : * Noted that it doesn't work with the packaged ACT-R quite
;;;             :   right (virtuals do, but reals don't).
;;; 2005.09.16 Dan
;;;             : * Preliminary work for converting to ACL 7 - for now, just
;;;             :   check to see if the do-xxxxxxx (key, mouse) stuff is
;;;             :   needed.  The release notes don't show anything else that
;;;             :   should be a problem, but we'll find out...
;;;             : * Of course they fail to document that they've reoganized
;;;             :   the class hierarchy and there is no longer a class called
;;;             :   window.  Using the class basic-pane instead for ACL 7.
;;; 2006.09.07 Dan
;;;             : * Removed the fill-default-dimensions method because it's
;;;             :   now defined in the vision file.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

#+: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)


(eval-when (:compile-toplevel :load-toplevel :execute)
  (use-package :cg-user))

(defvar *simulated-key* nil)

(defvar *attn-tracker* nil "Holds the view for the focus ring.")

(defmethod window-select ((w #-(version>= 7) cg:window #+(version>= 7) cg:basic-pane))
  (select-window w))

(defmethod device-move-cursor-to ((device #-(version>= 7) cg:window #+(version>= 7) cg:basic-pane) (xyloc vector))
  (setf (cg:cursor-position device) (cg:make-position (px xyloc) (py xyloc))))

(defmethod device-speak-string ((device #-(version>= 7) cg:window #+(version>= 7) cg:basic-pane) string)
  (declare (ignore string)))

(defmethod get-mouse-coordinates ((device #-(version>= 7) cg:window #+(version>= 7) cg:basic-pane))
  (let ((cur-pos (cg:cursor-position device)))
    (vector (cg:position-x cur-pos) (cg:position-y cur-pos))))

(defmethod device-handle-click ((device #-(version>= 7) cg:window #+(version>= 7) cg:basic-pane))
  #+(version>= 6)
  (let (x y)
    (when (and (show-focus-p (current-device-interface))
               (equal (type-of *attn-tracker*) 'focal-view))
      (setf x (left *attn-tracker*))
      (setf y (top *attn-tracker*))
      
      (close *attn-tracker*)
      (cg:process-pending-events))
    (do-click nil :preview-seconds nil :down-seconds .0001)
    (cg:process-pending-events)
    (when (and (show-focus-p (current-device-interface))
               (equal (type-of *attn-tracker*) 'focal-view))
      (setf *attn-tracker* (cg:make-window :focus-ring :device 'focal-view :parent device
                                      :left x 
                                      :top y )))
      )
    
  #-(version>= 6)
  (do-click nil :preview-seconds nil :down-seconds .0001))


(defmethod device-handle-keypress ((device #-(version>= 7) cg:window #+(version>= 7) cg:basic-pane) key)
  (do-keypress device key :preview-seconds nil :down-seconds nil))


;;; Similar to what Mike did for the MCL version
;;; but since process-pending-events is faster than
;;; event-dispatch in MCL (basically negligible) I don't 
;;; need to do the testing and only fire it periodically.
;;; 

(defmethod device-update :after ((wind #-(version>= 7) cg:window #+(version>= 7) cg:basic-pane) time)
  (declare (ignore time))
  (cg:process-pending-events)
  )

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




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

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

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


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

(defmethod build-features-for ((self #-(version>= 7) cg:window #+(version>= 7) cg:basic-pane) (vis-mod vision-module))
  (let ((base-ls (flatten
                    (mapcar #'(lambda (obj) (build-features-for obj vis-mod))
                            (get-sub-objects self)))))
    (dolist (feat base-ls)
      (fill-default-dimensions feat))
    base-ls))


(defmethod get-sub-objects ((v #-(version>= 7) cg:window #+(version>= 7) cg:basic-pane))
  "Grabbing the sub-objects of a window by default returns the dialog-items."
  (cg:dialog-items v))


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

(defmethod build-features-for ((self cg:dialog-item) 
                                  (vis-mgr vision-module))
  "Build an icon feature for the dialog item"
  
  (make-instance 'icon-feature
    :x (px (view-loc self))
    :y (py (view-loc self))
    :isa 'visual-object
    :value 'unknown
    :screen-obj self))


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

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



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

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



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

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

(defmethod build-features-for :around ((self cg:static-text)
                                          (vis-mod vision-module))
  (let ((feats (call-next-method))
        (color (system-color->symbol (aif (cg:foreground-color self)
                                        it
                                        cg:black))))
    (mapcar #'(lambda (f)
                (setf (color f) color)
                f)
      feats)))


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

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

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

(defmethod cursor-to-feature ((the-window #-(version>= 7) cg:window #+(version>= 7) cg:basic-pane))
  "Returns a feature corresponding to the current cursor."
  (let ((pos (cg:cursor-position the-window))
        (shape (cursor the-window)))
    (when (cursor-in-window-p the-window)
      (make-instance 'cursor-feature
        :x (cg:position-x pos) :y (cg:position-y pos)
        :value (case (name shape)
                 (:line-cursor 'i-beam)
                 (:cross-cursor 'crosshair)
                 (:waiting-cursor 'watch)
                 (otherwise 'pointer))))))
               

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



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



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


#| Moved to vision for general usage


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

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



(defmethod populate-loc-to-key-array ((ar array))
  "Sets all the keys in the array that need to be set"
  ;; function key row
  (setf (aref ar 0 0) cg:vk-escape)
  (setf (aref ar 2 0) cg:vk-f1)
  (setf (aref ar 3 0) cg:vk-f2)
  (setf (aref ar 4 0) cg:vk-f3)
  (setf (aref ar 5 0) cg:vk-f4)
  (setf (aref ar 7 0) cg:vk-f5)
  (setf (aref ar 8 0) cg:vk-f6)
  (setf (aref ar 9 0) cg:vk-f7)
  (setf (aref ar 10 0) cg:vk-f8)
  (setf (aref ar 12 0) cg:vk-f9)
  (setf (aref ar 13 0) cg:vk-f10)
  (setf (aref ar 14 0) cg:vk-f11)
  (setf (aref ar 15 0) cg:vk-f12)
  (setf (aref ar 17 0) cg:vk-f13)
  (setf (aref ar 18 0) cg:vk-f14)
  (setf (aref ar 19 0) cg:vk-f15)
  ;; numeric key row
  (setf (aref ar 0 2) cg:vk-backquote)
  (setf (aref ar 1 2) #\1)
  (setf (aref ar 2 2) #\2)
  (setf (aref ar 3 2) #\3)
  (setf (aref ar 4 2) #\4)
  (setf (aref ar 5 2) #\5)
  (setf (aref ar 6 2) #\6)
  (setf (aref ar 7 2) #\7)
  (setf (aref ar 8 2) #\8)
  (setf (aref ar 9 2) #\9)
  (setf (aref ar 10 2) #\0)
  (setf (aref ar 11 2) #\-)
  (setf (aref ar 12 2) #\=)
  (setf (aref ar 13 2) cg:vk-backspace)
  (setf (aref ar 15 2) cg:vk-insert)
  (setf (aref ar 16 2) cg:vk-home)
  (setf (aref ar 17 2) cg:vk-pageup)
  (setf (aref ar 19 2) cg:vk-numlock)
  (setf (aref ar 20 2) #\=)
  (setf (aref ar 21 2) #\/)
  (setf (aref ar 22 2) #\*)
  ;; qwerty row
  (setf (aref ar 0 3) #\tab)
  (setf (aref ar 1 3) #\q)
  (setf (aref ar 2 3) #\w)
  (setf (aref ar 3 3) #\e)
  (setf (aref ar 4 3) #\r)
  (setf (aref ar 5 3) #\t)
  (setf (aref ar 6 3) #\y)
  (setf (aref ar 7 3) #\u)
  (setf (aref ar 8 3) #\i)
  (setf (aref ar 9 3) #\o)
  (setf (aref ar 10 3) #\p)
  (setf (aref ar 11 3) #\[)
  (setf (aref ar 12 3) #\])
  (setf (aref ar 13 3) #\\)
  (setf (aref ar 15 3) cg:vk-delete)
  (setf (aref ar 16 3) cg:vk-end)
  (setf (aref ar 17 3) cg:vk-pagedown)
  (setf (aref ar 19 3) #\7)
  (setf (aref ar 20 3) #\8)
  (setf (aref ar 21 3) #\9)
  (setf (aref ar 22 3) #\-)
  ;; ASDF row
  (setf (aref ar 0 4) cg:vk-capslock)
  (setf (aref ar 1 4) #\a)
  (setf (aref ar 2 4) #\s)
  (setf (aref ar 3 4) #\d)
  (setf (aref ar 4 4) #\f)
  (setf (aref ar 5 4) #\g)
  (setf (aref ar 6 4) #\h)
  (setf (aref ar 7 4) #\j)
  (setf (aref ar 8 4) #\k)
  (setf (aref ar 9 4) #\l)
  (setf (aref ar 10 4) #\;)
  (setf (aref ar 11 4) cg:vk-quote)
  (setf (aref ar 12 4) #\return)
  (setf (aref ar 13 4) #\return)
  (setf (aref ar 19 4) #\4)
  (setf (aref ar 20 4) #\5)
  (setf (aref ar 21 4) #\6)
  (setf (aref ar 22 4) #\+)
  ;; Z row
  (setf (aref ar 0 5) cg:vk-shift)
  (setf (aref ar 1 5) #\z)
  (setf (aref ar 2 5) #\x)
  (setf (aref ar 3 5) #\c)
  (setf (aref ar 4 5) #\v)
  (setf (aref ar 5 5) #\b)
  (setf (aref ar 6 5) #\n)
  (setf (aref ar 7 5) #\m)
  (setf (aref ar 8 5) #\,)
  (setf (aref ar 9 5) #\.)
  (setf (aref ar 10 5) #\/)
  (setf (aref ar 11 5) cg:vk-shift)
  (setf (aref ar 12 5) cg:vk-shift)
  (setf (aref ar 16 5) cg:vk-up)
  (setf (aref ar 19 5) #\1)
  (setf (aref ar 20 5) #\2)
  (setf (aref ar 21 5) #\3)
  (setf (aref ar 22 5) cg:vk-enter)
  ;; space bar row
  (setf (aref ar 0 6) cg:vk-control)
  (setf (aref ar 1 6) 'option)
  (setf (aref ar 2 6) cg:vk-alt)
  (setf (aref ar 3 6) #\space)
  (setf (aref ar 4 6) #\space)
  (setf (aref ar 5 6) #\space)
  (setf (aref ar 6 6) #\space)
  (setf (aref ar 7 6) #\space)
  (setf (aref ar 8 6) #\space)
  (setf (aref ar 9 6) #\space)
  (setf (aref ar 10 6) #\space)
  (setf (aref ar 11 6) cg:vk-alt)
  (setf (aref ar 12 6) 'option)
  (setf (aref ar 13 6) cg:vk-control)
  (setf (aref ar 15 6) cg:vk-left)
  (setf (aref ar 16 6) cg:vk-down)
  (setf (aref ar 17 6) cg:vk-right)
  (setf (aref ar 19 6) #\0)
  (setf (aref ar 20 6) #\0)
  (setf (aref ar 21 6) #\.)
  (setf (aref ar 22 6) cg:vk-enter)
  ar)



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

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

;;;; ---------------------------------------------------------------------- ;;;;;;;
;;;; The view based line drawing classes and methods
;;;; ---------------------------------------------------------------------- ;;;;;;;

;;; The base class for the dialog based lines.  All it adds is a color slot.

(defclass liner (drawable)
  ((color :accessor color :initarg :color :initform 'black)
   (start-pt :accessor start-pt :initarg :start-pt :initform (list 0 0))
   (end-pt :accessor end-pt :initarg :end-pt :initform (list 0 0)))
  (:default-initargs
    :width 1
    :height 1
    :left -2
    :top 0
    :on-redisplay 'draw-view-line))


(defun draw-view-line (di stream)
  (declare (ignore stream))
  (let* ((real-stream (cg:parent di)))
    (with-foreground-color (real-stream (color di))
      (draw-line real-stream (cg:make-position (first (start-pt di)) (second (start-pt di)))
                 (cg:make-position (first (end-pt di)) (second (end-pt di)))))))


(defmethod build-features-for ((lnr liner) (vis-mod vision-module))
  "Convert the view to a feature to be placed into the visual icon"
  (make-instance 'line-feature
    :color (system-color->symbol (color lnr))
    :end1-x (first (start-pt lnr)) 
    :end1-y (second (start-pt lnr))
    :end2-x (first (end-pt lnr)) 
    :end2-y (second (end-pt lnr))
    :x (loc-avg (first (start-pt lnr)) (first (end-pt lnr)))
    :y (loc-avg (second (start-pt lnr)) (second (end-pt lnr)))
    :width (abs (- (first (start-pt lnr)) (first (end-pt lnr))))
    :height (abs (- (second (start-pt lnr)) (second (end-pt lnr))))))





(defun rpm-view-line (wind start-pt end-pt &optional (color cg:black))
  "Adds a dialog-item representing the line to the specified window 
   which will draw a line from the start-pt to the end-pt on the window
   using the optional color specified (defaulting to black). "
  (let* ((dis (cg:dialog-items wind)))
    (setf (cg:dialog-items wind) (cons (make-instance 'liner
                                      :color color
                                      :start-pt start-pt 
                                      :end-pt end-pt) dis))))


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


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


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

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



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

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

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

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

(defmethod virtual-key-down :before ((focus-ring focal-view) buttons key-code)
  (virtual-key-down (cg:parent focus-ring) buttons key-code))

;;;; --------------------------------------------------------------------- ;;;;
;;;; The color mapping functions

;;; because of how ACL treats the color names as symbols I need to do some
;;; extra trickery so that one can use names like red in a production request

(defmethod attr-exact-match-p ((spec icon-feature) (feat icon-feature) slotname)
  (cond ((eq (slot-value spec slotname) :IGNORE) T)
        ((and (equal slotname 'color) (rgb-p (slot-value spec slotname))) 
         (equal (slot-value feat slotname) (color-name->color-symbol (slot-value spec slotname))))
        ((equal (slot-value spec slotname) (slot-value feat slotname)))))

;;; This function returns the symbol name of one of the ACL RGB special 
;;; symbols.  It's similar to system-color->symbol but doesn't do the funny
;;; mapping for things like magenta -> pink because that isn't the problem.
;;; It's an issue because a RHS request like this:
;;;
;;; +visual-location>
;;;    isa visual-location
;;;    color red
;;;
;;; ends up being parsed into passing the special RGB red to the find-location
;;; instead of the symbol red.
;;; I think this is enough to fix things, but maybe there are other issues
;;; I haven't seen yet where those special symbols cause problems (perhaps
;;; some LHS issues need to be resolved).

(defun color-name->color-symbol (color)
  (cond ((cg:rgb-equal color cg:red) 'red)
        ((cg:rgb-equal color cg:blue) 'blue)
        ((cg:rgb-equal color cg:green) 'green)
        ((cg:rgb-equal color cg:black) 'black)
        ((cg:rgb-equal color cg:white) 'white)
        ((cg:rgb-equal color cg:magenta) 'magenta)
        ((cg:rgb-equal color cg:yellow) 'yellow)
        ((cg:rgb-equal color cg:cyan) 'cyan)
        ((cg:rgb-equal color cg:dark-green) 'dark-green)
        ((cg:rgb-equal color cg:dark-red) 'dark-red)
        ((cg:rgb-equal color cg:dark-cyan) 'dark-cyan)
        ((cg:rgb-equal color cg:dark-blue) 'dark-blue)
        ((cg:rgb-equal color cg:dark-magenta) 'dark-magenta)
        ((cg:rgb-equal color cg:dark-yellow) 'dark-yellow)
        ((cg:rgb-equal color cg:light-gray) 'light-gray)
        ((cg:rgb-equal color cg:gray) 'gray)
        ((cg:rgb-equal color cg:dark-gray) 'dark-gray)))


(defun system-color->symbol (color)
  "Return a symbol that names the color for the 'recognized' colors.   
   Any other color gets mapped to a symbol color-RRRRR-GGGGG-BBBBB where the 
   R's, G's, and B's are the red, green, and blue components of the 
   color left padded with zeros to 5 digits."
  (if (null color)
    'black
    (cond ((cg:rgb-equal color cg:red) 'red)
          ((cg:rgb-equal color cg:blue) 'light-blue)
          ((cg:rgb-equal color cg:green) 'green)
          ((cg:rgb-equal color cg:black) 'black)
          ((cg:rgb-equal color cg:white) 'white)
          ((cg:rgb-equal color cg:magenta) 'pink)
          ((cg:rgb-equal color cg:yellow) 'yellow)
          ((cg:rgb-equal color cg:dark-green) 'dark-green)
          ((cg:rgb-equal color cg:dark-blue) 'blue)
          ((cg:rgb-equal color cg:dark-magenta) 'purple)
          ((cg:rgb-equal color cg:dark-yellow) 'brown)
          ((cg:rgb-equal color cg:light-gray) 'light-gray)
          ((cg:rgb-equal color cg:gray) 'gray)
          ((cg:rgb-equal color cg:dark-gray) 'dark-gray)
          (t (intern (format nil "COLOR-~5,'0d-~5,'0d-~5,'0d" 
                             (cg:rgb-red color) 
                             (cg:rgb-green color) 
                             (cg:rgb-blue color)))))))

(defun color-symbol->system-color (color)
  "this may look like it should do the inverse of the above, but right now
   it doesn't exactly.  If the color isn't one of the default ones then
   the black color is returned.  It's only being used by the UWI right now,
   so it's simplified for that purpose."
  (cond ((equal color 'red) cg:red)
        ((equal color 'blue) cg:dark-blue)
        ((equal color 'green) cg:green)
        ((equal color 'black) cg:black)
        ((equal color 'white) cg:white)
        ((equal color 'pink)  cg:magenta)
        ((equal color 'yellow) cg:yellow)
        ((equal color 'dark-green) cg:dark-green)
        ((equal color 'light-blue) cg:blue)
        ((equal color 'purple) cg:dark-magenta)
        ((equal color 'brown) cg:dark-yellow)
        ((equal color 'light-gray) cg:light-gray)
        ((equal color 'gray) cg:gray)
        ((equal color 'dark-gray) cg:dark-gray)
        (t cg:black)))


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



;;; As of ACL 7 these exact functions have been made part of the system!!!!
;;; So, I need to not load them when using ACL 7.

#-(version>= 7)
(progn 

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


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

You can try running the following examples using the widgets w3 and w4.
For example: 
 
       (do-click w3)
 
will  call the button to be pressed and the on-change function foo to run.
Foo simply prints "hello" to the debug window.
 



Examples (where "it" is either a window or widget):
 
;; Mouse clicks
 
;; Left-click in the center of its scrollable page.
(do-click it)
 
;; Left-click near the upper-right corner of its scrollable page.
(do-click it :position (cg:make-position (- (interior-width (window it))
                                         8)
                                      12))
 
;; Left-click it with no pause for people to watch the action.
(do-click it :preview-seconds nil :down-seconds nil)
 
;; Right-click in the center of its client area.
(do-click it :button :right)
 
;; Left-click wherever the mouse is now.
(do-click nil)
 
;; Left-click an arbitary position on the screen.
(do-click nil :position (cg:make-position 100 200))
 
 
;; Left-click the screen over the center of it, but without first
;; exposing it.  So if another window covers it, then the click
;; will go to that window instead of it.  Pre-expose defaults to
;; t to ensure that the click goes to the specified window, but
;; it may be useful to pass it as nil as in this example if you
;; are testing that that the window is exposed when it should be.
(do-click it :pre-expose nil)
 
;; Keypresses
 
;; Type a "j" into it.
(do-keypress it #\j)
 
;; Type a semicolon into whatever window has the focus already.
(do-keypress nil vk-semicolon)
 
;; Give it the focus and press down the shift key
;; without releasing it.  WARNING:  Doing this without
;; a subsequent up-click of the same key leaves the OS thinking
;; that the shift key is still down, and a further keystroke
;; will believe it is shifted.  This can be fixed interactively
;; by simply pressing and releasing the left shift key.
(do-keypress it vk-shift :up nil)
 
;; Type control-J into it.
(do-keypress it #\j :control t)
 
;; Type a whole string of characters into it.
(do-keypresses it "How about that.")
 
;; Print an arbitrary object into it.
(do-keypresses it (list :one "Foo"))
 
|#
 
;; ------------------------------------------------------------
;; mouse events
 
(defconstant win::mouseeventf_move        #x0001)
(defconstant win::mouseeventf_leftdown    #x0002)
(defconstant win::mouseeventf_leftup      #x0004)
(defconstant win::mouseeventf_rightdown   #x0008)
(defconstant win::mouseeventf_rightup     #x0010)
(defconstant win::mouseeventf_middledown  #x0020)
(defconstant win::mouseeventf_middleup    #x0040)
(defconstant win::mouseeventf_wheel       #x0800)
(defconstant win::mouseeventf_absolute    #x8000)
 
(ff:def-foreign-call (win::mouse_event "mouse_event")
    ((win::dwflags win::dword)
     (win::dx win::dword)
     (win::dy win::dword)
     (win::dwdata win::dword)
     (win::dwextrainfo win::dword))) ;; officially ulong_ptr
     
(defgeneric do-click (window-or-widget-or-nil
                        &key (position (and window-or-widget-or nil :center))
                        (button :left)(pre-expose t)
                        (preview-seconds 0.5)(down-seconds 0.5))
  (:documentation
   "Simulates clicking a mouse button at some position in a window."))
 
(defmethod do-click ((widget cg:dialog-item)
                       &key (position (and widget :center))
                       (button :left)(pre-expose t)
                       (preview-seconds 0.5)(down-seconds 0.5))
  (let* ((window (cg:window widget)))
    (when (cg:windowp window)
      (do-click window :position position
                :button button :pre-expose pre-expose
                :preview-seconds preview-seconds
                :down-seconds down-seconds))))
 
(defmethod do-click ((window t)
                     &key (position (and window :center))
                     (button :left)(pre-expose t)
                     (preview-seconds 0.5)(down-seconds 0.5)
                     (down t)(up t))
  (unless window
    (setq window (cg:screen cg:*system*)))
  (let* ((win window)
         (down-event (and down
                          (case button
                            (:left win::mouseeventf_leftdown)
                            (:middle win::mouseeventf_middledown)
                            (:right win::mouseeventf_rightdown))))
         (up-event (and up
                        (case button
                          (:left win::mouseeventf_leftup)
                          (:middle win::mouseeventf_middleup)
                          (:right win::mouseeventf_rightup))))
         (stream-pos (case position 
                       (:center (cg:box-center (visible-box window)))
                       (t position)))
         #+not-used
         (screen-pos (and stream-pos
                          (window-to-screen-units window
                            (stream-to-window-units window
                              (copy-position stream-pos))))))
    (when window
      (when pre-expose
        (loop (unless (cg:windowp win)(return))
              (unless (eq win (cg:selected-window (cg:parent win)))
                (select-window win))
              (setq win (cg:parent win))))
      
      ;; Move the mouse over the window.
      (when stream-pos
        (setf (cg:cursor-position window) stream-pos))
      
      #+no ;; These units apparently would need to be normalized
      ;; where 0 to 65k covers the screen, so use (setf cursor-position)
      ;; instead in order to use pixel units.
      (when screen-pos
        (win::mouse_event (logior win::mouseeventf_move
                                  win::mouseeventf_absolute)
                          (cg:position-x screen-pos)
                          (cg:position-y screen-pos)
                          0 0)))
    
    ;; Wait a bit for the user to see the window before the click is done.
    (when preview-seconds (sleep preview-seconds))
    
    ;; Send the click down and up messages, pausing a bit in between
    ;; so that a human can see that the button was clicked.
    (when down
      (win::mouse_event down-event 0 0 0 0)
      
      #+no ;; The coordinates don't matter when doing the click,
      ;; though the MSDN doesn't make this clear.
      (win::mouse_event (logior down-event
                                (if screen-pos
                                    win::mouseeventf_absolute
                                  0))
                        (if screen-pos (cg:position-x screen-pos) 0)
                        (if screen-pos (cg:position-y screen-pos) 0)
                        0 0))
    #+old ;; This works, but mouse_event may be more robust.
    (win:sendmessage (cg:handle window) win:wm_lbuttondown 
      win:mk_lbutton (win:makelong (cg:position-x window-pos)
                                   (cg:position-y window-pos)))
    (when down-seconds (sleep down-seconds))
    (when up
      (win::mouse_event up-event 0 40000 0 0))
    ))
 
;; ------------------------------------------------------------
;; key presses
 
(defconstant win::keyeventf_extendedkey 1)
(defconstant win::keyeventf_keyup       2)
 
(ff:def-foreign-call (win::keybd_event "keybd_event")
    ((win::bvk byte)
     (win::bscan byte)
     (win::dwflags win::dword)
     (win::dwextrainfo win::dword))
  :convention :stdcall
  :release-heap :when-ok
  :arg-checking nil
  :returning :void)
 
(defgeneric do-keypress (window-or-widget-or-nil
                         keynum-or-character
                         &key (preview-seconds 0.5)
                         shift control alt
                         (down-seconds 0.5)(down t)(up t))
  (:documentation
   #.(format nil "Simulates pressing and/or releasing a key ~
       on the keyboard while some window has the focus.")))
 
(defmethod do-keypress ((widget cg:dialog-item)(keynum-or-char t)
                        &key (preview-seconds 0.5)(down-seconds 0.5)
                        shift control alt
                        (down t)(up t))
  (let* ((window (cg:window widget)))
    (when (cg:windowp window)
      (do-keypress window keynum-or-char
        :down-seconds down-seconds
        :preview-seconds preview-seconds
        :shift shift :control control :alt alt
        :down down :up up))))
 
(defmethod do-keypress ((window t)(keynum integer)
                        &key (preview-seconds 0.5)(down-seconds 0.5)
                        shift control alt
                        (down t)(up t))
  (declare (ignore shift control alt))
  
  ;; Expose the window and its parents all the way up
  (when window
    (let* ((win window))
      (loop (unless (cg:windowp win)(return))
            (unless (eq win (cg:selected-window (cg:parent win)))
              (select-window win))
            (setq win (cg:parent win))))
      
    ;; Make sure the window has the keyboard focus.
    (unless (eq window (cg:get-focus (cg:screen cg:*system*)))
      (win:setfocus (cg:handle window))))
    
  ;; Wait a bit for the user to see the window before the click is done.
  (when preview-seconds (sleep preview-seconds))
  
  ;; Send the click down and up messages, pausing a bit in between
  ;; so that a human can see any effect of the key being down.
  (when down
    (win::keybd_event keynum 0 0 0)
    #+old ;; this doesn't seem to work
    (win:sendmessage (cg:handle window) win:wm_keydown keynum
      1)) ;; "repeat" the keypress one time
  (when down-seconds (sleep down-seconds))
  (when up
    (win::keybd_event keynum 0 win::keyeventf_keyup 0)
    #+old
    (win:sendmessage (cg:handle window) win:wm_keyup keynum
      (logior (expt 2 31) ;; transition flag
              (expt 2 30) ;; flag that key was down
              1)) ;; "repeat" the keypress one time
    ))
 
(defmethod do-keypress ((window t)(char character)
                        &key (preview-seconds 0.5)(down-seconds 0.5)
                        shift control alt
                        (down t)(up t))
  (let* ((vk (win:VkKeyScan (char-int char)))
         (key-number (cg::lobyte vk))
         (shift-keys (cg::hibyte vk))
         (upper-case? (logbitp 0 shift-keys)))
    (when preview-seconds
      (sleep preview-seconds))
    (when alt
      (do-keypress window cg:vk-alt :up nil
        :preview-seconds nil :down-seconds nil))
    (when control
      (do-keypress window cg:vk-control :up nil
        :preview-seconds nil :down-seconds nil))
    (when (or shift upper-case?)
      (do-keypress window cg:vk-shift :up nil
        :preview-seconds nil :down-seconds nil))
    (do-keypress window key-number
      :preview-seconds nil
      :down-seconds down-seconds
      :down down :up up)
    (when (or shift upper-case?)
      (do-keypress window cg:vk-shift :down nil
        :preview-seconds nil :down-seconds nil))
    (when control
      (do-keypress window cg:vk-control :down nil
        :preview-seconds nil :down-seconds nil))
    (when alt
      (do-keypress window cg:vk-alt :down nil
        :preview-seconds nil :down-seconds nil))
    ))
         
(defmethod do-keypresses ((window t)(object string)
                          &key (preview-seconds 0.5)(down-seconds 0.5))
  (let* ((length (length object)))
    (dotimes (j length)
      (do-keypress
        window (aref object j) 
        :preview-seconds (if (eq j 0) preview-seconds nil)
        :down-seconds (if (eq j (1- length)) down-seconds)))))
 
(defmethod do-keypresses ((window t)(object symbol)
                          &key (preview-seconds 0.5)(down-seconds 0.5))
  (do-keypresses window (symbol-name object)
    :preview-seconds preview-seconds
    :down-seconds down-seconds))
 
(defmethod do-keypresses ((window t)(object t)
                          &key (preview-seconds 0.5)(down-seconds 0.5))
  (do-keypresses window (princ-to-string object)
    :preview-seconds preview-seconds
    :down-seconds down-seconds))

)
#|
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/devices/mcl/device.lisp
;;;============================================================================

;;;  -*- mode: LISP; Package: CL-USER; Syntax: COMMON-LISP;  Base: 10 -*-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 
;;; Author      : Mike Byrne
;;; Address     : Rice University, MS-25
;;;             : Psychology Department
;;;             : Houston,TX 77251-1892
;;;             : byrne@acm.org
;;; 
;;; Copyright   : (c)1998-2004 Mike Byrne
;;; Availability: Covered by the GNU LGPL, see LGPL.txt
;;; 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 
;;; Filename    : device.lisp
;;; Version     : 1.0a1
;;; 
;;; Description : MCL-specific functions for RPM.  This consists primarily
;;;             : of stuff for vision (parsing the screen), and output
;;;             : stuff for motor.
;;; 
;;; Bugs        : 
;;; 
;;; --- History ---
;;; 01.09.21 mdb [b2]
;;;             : Fixed an infinte recursion bug in APPROACH-WIDTH.
;;; 2002.04.16 mdb [b6]
;;;             : * Rolled in color text stuff.
;;;             : * Added BUILD-FEATURES-FOR methods for radio buttons and
;;;             : check boxes.
;;; 2002.04.18  mdb
;;;             : Fixed minor glitch created by color text stuff--if the part
;;;             : color was not set, that passed NIL to the color parser.  No.
;;; 2002.05.17 mdb
;;;             : Moved COLOR-SYMBOL->MAC-COLOR here.
;;; 2002.06.05 mdb
;;;             : Grr, fixed what is hopefully the last vector bug issue.
;;; 
;;; 2002.06.21 Dan [b7]
;;;             : Changed the rpm-window class to rpm-real-window and
;;;             : updated the methods accordingly.
;;; 2002.06.30 Dan
;;;             : Changed the COLOR-SYMBOL->MAC-COLOR and MAC-COLOR->SYMBOL
;;;             : function names by replacing MAC with SYSTEM to be a little
;;;             : more consistent (that way there aren't as many 'different'
;;;             : function names floating around in these files).
;;;             : Moved the view-line stuff in here from the separate file and
;;;             : documented it better.
;;;             : Removed all of the UWI code from this file.
;;; 2002.07.03 mdb
;;;             : Makes sure that SPEECH-AVAILABLE-P is defined.
;;; 2002.11.25 mdb [2.1f1]
;;;             : Added DEVICE-MOVE-CURSOR-TO for MCL5.0 on OSX. 
;;; 2003.03.11 mdb [2.1.2]
;;;             : Per DB's suggestion, cut back on EVENT-DISPATCHing. 
;;; 2003.06.18 mdb
;;;             : Turns out static text dialog items support multiple kinds
;;;             : of justifications, though it's hard to get at it.  Now
;;;             : handled properly. 
;;; 2003.06.23 mdb [2.1.3]
;;;             : Under-the-hood addition of RPM-OVERLAY class. 
;;; 2004.03.11 mdb [2.2]
;;;             : Added a VIEW-KEY-EVENT-HANDLER method for editable text dialog
;;;             : items, which used to break.
;;;
;;; 04.10.19 Dan [Moved into ACT-R 6]
;;;             : Reset the version to 1.0a1
;;;             : added the packaging switches
;;;             : changed the name to device to be placed in a folder called mcl
;;;             : removed references to *mp* and other minor
;;;             : ACT-R 6 updates
;;; 2006.09.07 Dan
;;;             : * Removed the fill-default-dimensions method because it's
;;;             :   now defined in the vision file.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

#+: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)

(defparameter *crosshair-cursor* 
  (#_GetCursor #$crossCursor) "Crosshair cursor")

(defvar *attn-tracker* nil "Holds the view for the focus ring.")
(defparameter *last-update* (get-internal-real-time))

;;;; RPM-LINE-TO is meant to be called in the VIEW-DRAW-CONTENTS method for
;;;; window, which should be called after PM-PROC-DISPLAY.  I know this is
;;;; is stupid, but I'm having trouble getting this to work right with views.

;;; RPM-LINE-TO      [Function]
;;; Date        : 97.03.31
;;; Description : For use in building interfaces.  If there is to be a lot of
;;;             : drawing, then there will probably be a lot of LINE-TO 
;;;             : commands.  After making the window in question the current
;;;             : RPM window (via RPM-INSTALL-WINDOW), then call this function
;;;             : instead.  Note that the point should be in the coordinate
;;;             : system of the window.

(defun rpm-line-to (the-view h &optional v)
  "Adds a line to the icon and draws in in the default window. Designed to be called by the VIEW-DRAW-CONTENTS method for the window."
  (let* (;DAN (the-wind (device (device-interface *mp*)))
         (the-wind (current-device))
         (start-point (pen-position the-wind))
         (end-point (if v (make-point h v) h))
         (the-offset (view-position the-view)))
    (line-to the-view end-point)
    (rpm-build-line (p2vpt (add-points start-point the-offset))
                    (p2vpt (add-points the-offset end-point)))
    end-point))


;;; RPM-BUILD-LINE      [Function]
;;; Date        : 97.03.31
;;; Description : Called by RPM-LINE-TO, this creates an icon feature based 
;;;             : on the beginning and end points.

(defun rpm-build-line (start-pt end-pt)
  "Build a line feature in the visual interface"
  ;  (declare (point start-pt) (point end-pt))
  (push
   (make-instance 'line-feature
     :end1-x (px start-pt) :end1-y (py start-pt)
     :end2-x (px end-pt) :end2-y (py end-pt)
     :x (loc-avg (px start-pt) (py end-pt))
     :y (loc-avg (px start-pt) (py end-pt))
     :width (abs (- (px start-pt) (py end-pt)))
     :height (abs (- (px start-pt) (py end-pt))))
   ; DAN (visicon (vis-m *mp*))))
   (visicon (get-module :vision ))))

(defun loc-avg (x y)
  "Return the 'location' (integer) average of <x> and <y>."
  (declare (fixnum x) (fixnum y))
  (floor (/ (+ x y) 2)))


;;;; ---------------------------------------------------------------------- ;;;;;;;
;;;; MCL screen-to-icon interface
;;;; ---------------------------------------------------------------------- ;;;;;;;


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

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


(defgeneric get-sub-objects (view)
  (:documentation  "Grabbing the sub-objects of a view by default returns the subviews."))

(defmethod get-sub-objects ((v view))
  (subviews v))


;;; BUILD-FEATURES-FOR      [Method]
;;; Date        : 97.04.02
;;; Description : Builder of features for a generic view.  Doesn't do anything
;;;             : based on the view itself, but it will call the 
;;;             : feature-builder on all subviews.

(defmethod build-features-for ((self view) (vis-mod vision-module))
  (let ((subs (get-sub-objects self))
        (outlis nil))
    (dolist (sub subs outlis)
      (push (build-features-for sub vis-mod) outlis))))



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

(defmethod build-features-for ((self dialog-item) (vis-mod vision-module))
  (declare (ignore vis-mod))
  (make-instance 'icon-feature
    :x (px (view-loc self))
    :y (py (view-loc self))
    :kind 'visual-object
    :value 'unknown
    :screen-obj self))


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

(defmethod build-features-for ((self editable-text-dialog-item)
                                  (vis-mod vision-module))
  (let ((font-spec (view-font self))
        (text (dialog-item-text self)))
    (cons
     (make-instance 'rect-feature 
       :x (px (view-loc self))
       :y (py (view-loc self))
       :screen-obj self)
     (unless (equal text "")
       (multiple-value-bind (ascent descent)
                            (font-info font-spec)
         (build-string-feats vis-mod :text text
                             :start-x (1+ (point-h (view-position self)))
                             :y-pos (+ (point-v (view-position self))
                                       descent (round ascent 2))
                             :width-fct #'(lambda (str)
                                            (string-width str font-spec))
                             :height ascent :obj self))))))


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

(defmethod build-features-for ((self button-dialog-item)
                                  (vis-mod vision-module))
  (let ((btn-width (point-h (view-size self)))
        (btn-height (point-v (view-size self)))
        (text (dialog-item-text self)))
    (cons
     (make-instance 'oval-feature 
       :x (px (view-loc self)) :y (py (view-loc self))
       :width btn-width :height btn-height :color 'light-gray
       :screen-obj self) 
     (unless (equal text "")
       (let* ((font-spec (view-font self))
              (start-y nil)
              (accum nil)
              (textlines (string-to-lines text))
              (width-fct #'(lambda (str) (string-width str font-spec))))
         (multiple-value-bind (ascent descent) (font-info font-spec)
           (setf start-y (+ (point-v (view-position self))
                            (round (- btn-height (* (length textlines)
                                                    (+ ascent descent))) 2)))
           (dolist (item textlines (nreverse accum))
             (push
              (build-string-feats vis-mod :text item
                                  :start-x 
                                  (+ (point-h (view-position self))
                                     (round 
                                      (- btn-width (funcall width-fct item))
                                      2))
                                  :y-pos 
                                  (+ start-y (round (+ ascent descent) 2))
                                  :width-fct width-fct 
                                  :height (min ascent btn-height)
                                  :obj self)
              accum)
             (incf start-y (+ ascent descent)))))))))



;;; BUILD-FEATURES-FOR      [Method]
;;; Date        : 02.04.16
;;; Description : A radio button is like a regular button, except that the
;;;             : oval is small and might be gray [unselected] or gray
;;;             : [selected].  Text is also not horizontally centered.

(defmethod build-features-for ((self radio-button-dialog-item)
                                  (vis-mod vision-module))
  (let* ((btn-height (point-v (view-size self)))
         (text (dialog-item-text self)))
    (cons
     (make-instance 'oval-feature 
       :x (+ 7 (point-h (view-position self))) :y (py (view-loc self))
       :width 11 :height 11 :screen-obj self
       :color (if (radio-button-pushed-p self)
                'black
                'light-gray))
     (unless (equal text "")
       (let* ((font-spec (view-font self))
              (start-y nil)
              (accum nil)
              (textlines (string-to-lines text))
              (width-fct #'(lambda (str) (string-width str font-spec))))
         (multiple-value-bind (ascent descent) (font-info font-spec)
           (setf start-y (+ (point-v (view-position self))
                            (round (- btn-height (* (length textlines)
                                                    (+ ascent descent))) 2)))
           (dolist (item textlines (nreverse accum))
             (push
              (build-string-feats vis-mod :text item
                                  :start-x 
                                  (+ (point-h (view-position self))
                                     17)
                                  :y-pos 
                                  (+ start-y (round (+ ascent descent) 2))
                                  :width-fct width-fct 
                                  :height (min ascent btn-height)
                                  :obj self)
              accum)
             (incf start-y (+ ascent descent)))))))))


;;; BUILD-FEATURES-FOR      [Method]
;;; Date        : 02.04.16
;;; Description : Very much like radio buttons, but if checked add an 
;;;             : "X" to the output.

(defmethod build-features-for ((self check-box-dialog-item)
                                  (vis-mod vision-module))
  (let ((btn-height (point-v (view-size self)))
        (text (dialog-item-text self))
        (feats nil))
    (setf feats
          (cons
           (make-instance 'rect-feature 
             :x (+ 8 (point-h (view-position self))) :y (py (view-loc self))
             :width 11 :height 11 :color 'light-gray
             :screen-obj self)
           (unless (equal text "")
             (let* ((font-spec (view-font self))
                    (start-y nil)
                    (accum nil)
                    (textlines (string-to-lines text))
                    (width-fct #'(lambda (str) (string-width str font-spec))))
               (multiple-value-bind (ascent descent) (font-info font-spec)
                 (setf start-y (+ (point-v (view-position self))
                                  (round (- btn-height (* (length textlines)
                                                          (+ ascent descent))) 2)))
                 (dolist (item textlines (nreverse accum))
                   (push
                    (build-string-feats vis-mod :text item
                                        :start-x 
                                        (+ (point-h (view-position self))
                                           17)
                                        :y-pos 
                                        (+ start-y (round (+ ascent descent) 2))
                                        :width-fct width-fct 
                                        :height (min ascent btn-height)
                                        :obj self)
                    accum)
                   (incf start-y (+ ascent descent))))))))
    (when (check-box-checked-p self)
      (setf feats
            (cons
             (make-instance 'icon-feature
               :x (+ 8 (point-h (view-position self)))
               :y (py (view-loc self))
               :kind 'visual-object
               :value 'check
               :screen-obj self
               :height 11
               :width 11)               
             
             feats)))
    feats
    ))


(defmethod approach-width ((feat text-feature) (theta number))
  (let ((screen-obj (screen-obj feat)))
    (if (button-p screen-obj)
      (let ((new-feat 
             (find-if #'(lambda (f) (and (eq (screen-obj f) screen-obj)
                                          (eq (kind f) 'oval)))
                      ;DAN (visicon (vis-m *mp*)))))
                      (visicon (get-module :vision)))))
        (if new-feat
          (approach-width new-feat theta)
          (call-next-method)))
      (call-next-method))))


(defmethod button-p (obj)
  (declare (ignore obj))
  nil)

(defmethod button-p ((obj button-dialog-item))
  (declare (ignore obj))
  t)

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

(defmethod build-features-for ((self static-text-dialog-item)
                                  (vis-mod vision-module))
  (let ((font-spec (view-font self))
        (text (dialog-item-text self)))
    (unless (equal text "")
      (multiple-value-bind (ascent descent)
                           (font-info font-spec)
        (build-string-feats vis-mod :text text
                            :start-x (xstart self)
                            :y-pos (+ (point-v (view-position self))
                                      descent (round ascent 2))
                            :width-fct #'(lambda (str)
                                           (string-width str font-spec))
                            :height ascent :obj self)))))


(defmethod xstart ((self static-text-dialog-item))
  (let ((left-x (point-h (view-position self)))
        (text-width (string-width (dialog-item-text self)
                                  (view-font self)))
        (text-justification
         (or (cdr (assq (slot-value self 'ccl::text-justification)
                        '((:left . #.#$tejustleft)
                          (:center . #.#$tejustcenter)
                          (:right . #.#$tejustright))))
             (require-type (slot-value self 'ccl::text-justification) 'fixnum)))
        )
    (ecase text-justification
      (#.#$teJustLeft (1+ left-x))
      (#.#$teJustCenter (+ 1 left-x (round (/ (- (width self) text-width) 2))))
      (#.#$teJustRight (+ 1 left-x (- (width self) text-width))))))
 


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

(defmethod cursor-to-feature ((the-window window))
  (let ((pos (view-mouse-position the-window))
        (shape (window-cursor the-window)))
    (when (cursor-in-window-p the-window)
      (make-instance 'cursor-feature
        :x (point-h pos) :y (point-v pos)
        :value (case shape
                 (*i-beam-cursor* 'I-BEAM)
                 (*crosshair-cursor* 'CROSSHAIR)
                 (*watch-cursor* 'WATCH)
                 (otherwise 'POINTER))))))


(defgeneric cursor-in-window-p (wind)
  (:documentation  "Returns T if the cursor is over <wind>, NIL otherwise."))

(defmethod cursor-in-window-p ((tw window))
  (when (window-shown-p tw)
    (rlet ((the-rect rect))
      (points-to-rect (view-position tw)
                      (add-points (view-position tw) (view-size tw))
                      the-rect)
      (point-in-rect-p the-rect 
                       (local-to-global tw (view-mouse-position tw))))))



(defmethod view-loc ((self view))
  (let ((pos (view-position self))
        (size (view-size self)))
    (vector (round (+ (point-h pos) (/ (point-h size) 2)))
            (round (+ (point-v pos) (/ (point-v size) 2))))))


(defmethod view-loc ((self simple-view))
  (let ((pos (view-position self))
        (size (view-size self)))
    (vector (round (+ (point-h pos) (/ (point-h size) 2)))
            (round (+ (point-v pos) (/ (point-v size) 2))))))


(defmethod view-loc ((self symbol))
  (if (eq self :cursor)
    ;DAN (get-mouse-coordinates (device (device-interface *mp*)))
    (get-mouse-coordinates (current-device))
    (error "!! Can't find location of ~S" self)))


(defmethod width ((self simple-view))
  (point-h (view-size self)))


(defmethod height ((self simple-view))
  (point-v (view-size self)))

#| Moved to vision

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

(defgeneric fill-default-dimensions (feat)
  (:documentation  "Fill in the width, height, and size of an icon feature."))

(defmethod fill-default-dimensions ((feat icon-feature))
  (aif (simple-size feat)
    (setf (size feat) it)
    (if (null (screen-obj feat))
      (setf (size feat) 1.0)              ; should be default size, eh
      (progn
        (unless (width feat) (setf (width feat) (width (screen-obj feat))))
        (unless (height feat) (setf (height feat) (height (screen-obj feat))))
        (setf (size feat) (simple-size feat))))))

|#
;;;; ---------------------------------------------------------------------- ;;;;;;;
;;;; The view based line drawing classes and methods
;;;; ---------------------------------------------------------------------- ;;;;;;;

;;; LINER      [Class]
;;; Description : The base class for the view based lines.  
;;;             : All it adds to a simple-view is a color slot that defaults
;;;             : to black.

(defclass liner (simple-view)
  ((color :accessor color :initarg :color :initform *black-color*)))

;;; POINT-IN-CLICK-REGION-P      [Method]
;;; Description : Override this method so that lines don't handle mouse clicks.

(defmethod point-in-click-region-p ((self liner) where)
  (declare (ignore where))
  nil)


;;; TD-LINER      [Class]
;;; Description : A view that represents a line which is drawn top-down 
;;;             : i.e. from the view-position (upper-left) to the 
;;;             : [view-size - (1,1)] (lower-right) in the container window

(defclass td-liner (liner)
  ())

;;;  A view that represents a line which is drawn bottom-up i.e. from the
;;;  view's lower-left to the view's upper-right in the container window.

;;; BU-LINER      [Class]
;;; Description : A view that represents a line which is drawn bottom-up 
;;;             : i.e. from the view's lower-left to the view's upper-rignt
;;;             : in the container window

(defclass bu-liner (liner)
  ())

;;; VIEW-DRAW-CONTENTS [Method]
;;; Description : Draw a top-down line on it's container window.

(defmethod view-draw-contents ((lnr td-liner))
  "Draws the line on the view-container window using the color specified
   and restoring the previous draw color and pen position"
  (let* ((parent (view-container lnr))
         (old-point (pen-position parent))
         (old-color (get-fore-color parent))
         (other-end (add-points (view-size lnr) (view-position lnr))))
    (set-fore-color parent (color lnr))
    (move-to parent (view-position lnr))
    (line-to parent (make-point (1- (point-h other-end))
                                (1- (point-v other-end))))
    (set-fore-color parent old-color)
    (move-to parent old-point)))

;;; VIEW-DRAW-CONTENTS [Method]
;;; Description : Draw a bottom-up line on it's container window.

(defmethod view-draw-contents ((lnr bu-liner))
  "Draws the line on the view-container window using the color specified
   and restoring the previous draw color and pen position"
  (let* ((parent (view-container lnr))
         (old-point (pen-position parent))
         (old-color (get-fore-color parent)))
    (set-fore-color parent (color lnr))
    (move-to parent (make-point (point-h (view-position lnr))
                                (1- (point-v (add-points (view-position lnr) (view-size lnr))))))
    (line-to parent (make-point (1- (point-h (add-points (view-size lnr) (view-position lnr))))
                                (point-v (view-position lnr))))
    (set-fore-color parent old-color)
    (move-to parent old-point)))


;;; VIEW-DRAW-CONTENTS [Method]
;;; Description : A td-liner is just a line-feature located "at" it's mid-point.

(defmethod build-features-for ((lnr td-liner) (vis-mod vision-module))
  "Convert the view to a feature to be placed into the visual icon"
  (let ((start-pt (view-position lnr))
        (end-pt (subtract-points (add-points (view-position lnr) (view-size lnr)) 
                                  (make-point 1 1))))
    (make-instance 'line-feature
      :color (system-color->symbol (color lnr))
      :end1-x (point-h start-pt) 
      :end1-y (point-v start-pt)
      :end2-x (point-h end-pt) 
      :end2-y (point-v end-pt)
      :x (loc-avg (point-h start-pt) (point-h end-pt))
      :y (loc-avg (point-v start-pt) (point-v end-pt))
      :width (abs (- (point-h start-pt) (point-h end-pt)))
      :height (abs (- (point-v start-pt) (point-v end-pt))))))


;;; VIEW-DRAW-CONTENTS [Method]
;;; Description : A bu-liner is just a line-feature located "at" it's mid-point.

(defmethod build-features-for ((lnr bu-liner) (vis-mod vision-module))
  "Convert the view to a feature to be placed into the visual icon"
  (let ((start-pt (add-points (view-position lnr)
                                (make-point 0 (1- (point-v (view-size lnr))))))
        
        
        (end-pt (add-points (view-position lnr) 
                             (make-point (1- (point-h (view-size lnr))) 0))))
    (make-instance 'line-feature
      :color (system-color->symbol (color lnr))
      :end1-x (point-h start-pt) 
      :end1-y (point-v start-pt)
      :end2-x (point-h end-pt) 
      :end2-y (point-v end-pt)
      
      :x (loc-avg (point-h start-pt) (point-h end-pt))
      :y (loc-avg (point-v start-pt) (point-v end-pt))
      :width (abs (- (point-h start-pt) (point-h end-pt)))
      :height (abs (- (point-v start-pt) (point-v end-pt))))))

;;; RPM-VIEW-LINE [Function]
;;; Description : Add a view to the window that displays a line defined by
;;;             : the start and end points in the color supplied (an MCL
;;;             : system style color).

(defun rpm-view-line (wind start-pt end-pt &optional (color *black-color*))
  "Adds a view in the specified window which draws a line from the start-pt to the end-pt
   using the optional color specified (defaulting to black).  This view will add features 
   to the icon on PM-PROC-DISPLAY."
  (let* ((gx (> (point-h end-pt) (point-h start-pt)))
         (gy (> (point-v end-pt) (point-v start-pt)))
         (vs (subtract-points start-pt end-pt)))
    (setf vs (make-point (+ 1 (abs (point-h vs)))
                         (+ 1 (abs (point-v vs)))))
    (add-subviews wind (cond ((and gx gy)
                              (make-instance 'td-liner
                                :color color
                                :view-position start-pt 
                                :view-size vs))
                             ((and (not gx) (not gy))
                              (make-instance 'td-liner
                                :color color
                                :view-position end-pt 
                                :view-size vs))
                             ((and gx (not gy))
                              (make-instance 'bu-liner
                                :color color
                                :view-position (make-point (point-h start-pt) (point-v end-pt))
                                :view-size vs))
                             (t
                              (make-instance 'bu-liner
                                :color color
                                :view-position (make-point (point-h end-pt) (point-v start-pt))
                                :view-size vs))))))



;;;; ---------------------------------------------------------------------- ;;;;
;;;; Utilities
;;;; ---------------------------------------------------------------------- ;;;;

;;; XY->POINT      [Function]
;;; Description : Converts an (X Y) list into an MCL/Quickdraw point.

(defun xy->point (xy)
  "(x y) to point converstion function. Deprecated, use vpt2p instead."
  (declare (list xy))
  (make-point (first xy) (second xy)))


;;; P2XY      [Function]
;;; Description : Takes an MCL/Quickdraw point and returns an XY list

(defun p2xy (p)
  "Coverts an MCL/Quickdraw point to an XY list.  Deprecated, use p2vpt instead."
  ;  (declare (point p))
  (list (point-h p) (point-v p)))


(defun p2vpt (p)
  "Convert an MCL/Quickdraw point to #(x y) format."
  (declare (inline p2vpt))
  (vector (point-h p) (point-v p)))


(defun vpt2p (mpt)
  "Convert an #(x y) format point to MCL/Quickdraw format."
  (declare (vector mpt) (inline vpt2p))
  (make-point (px mpt) (py mpt)))


;;;; ---------------------------------------------------------------------- ;;;;
;;;; RPM device methods.
;;;; ---------------------------------------------------------------------- ;;;;

;;; DEVICE-HANDLE-KEYPRESS      [Method]
;;; Description : Just call VIEW-KEY-EVENT-HANDLER and make sure that the 
;;;             : event gets dealt with.

(defmethod device-handle-keypress ((device window) key)
  (view-key-event-handler device key)
  (event-dispatch)) 


;;; VIEW-KEY-EVENT-HANDLER      [Method]
;;; Description : ACT-R couldn't actually type into editiable text dialog
;;;             : items because the default method required that 
;;;             : *current-event* be bound, which of course it wouldn't be.
;;;             : So hack around it.

(defmethod view-key-event-handler ((view editable-text-dialog-item) 
                                       (char character))
  (if (not *actr-enabled-p*)
    (call-next-method)
    (progn
      (cond ((graphic-char-p char) (ed-insert-char view char))
            ((char= char #\backspace) (ed-rubout-char view))
            )
      (view-draw-contents view)))
  )


;;; DEVICE-HANDLE-CLICK      [Method]
;;; Description : Again, just call the base MCL method and dispatch.

(defmethod device-handle-click ((device window))
  (view-click-event-handler device (view-mouse-position device))
  (event-dispatch))


;;; DEVICE-MOVE-CURSOR-TO      [Method]
;;; Date        : 97.02.18 [revised 98.10.29]
;;; Description : Since moving the mouse is considered a Bad Thing by 
;;;             : Apple's HI police, you can't just make a simple call
;;;             : to do it.  First, there's moving the cursor, which
;;;             : involves blasting into low memory.  Then, if the cursor
;;;             : is being tracked by the system, we have to make sure that 
;;;             : the cursor move has really been registered (#$CrsrNew 
;;;             : changes from -1 to 255 when this happens) by the OS.  Then 
;;;             : make sure it's been registered by MCL with UPDATE-CURSOR.

#-ccl-4.3.1
(defmethod device-move-cursor-to ((device window) (xyloc vector))
  (let ((absloc (local-to-global device (px xyloc) (py xyloc))))
    (without-interrupts
     (ccl::%put-point (%int-to-ptr #$MTemp) absloc)
     (ccl::%put-point (%int-to-ptr #$RawMouse) absloc)
     (%put-word (%int-to-ptr #$CrsrNew) -1))
    (while (eql (%get-signed-word (%int-to-ptr #$CrsrNew)) -1))
    (update-cursor)
    (while (not (vpt= xyloc (p2vpt (view-mouse-position device))))
      (event-dispatch))))

#+ccl-4.3.1
(defmethod device-move-cursor-to ((device window) (xyloc vector))
  (let ((absloc (local-to-global device (px xyloc) (py xyloc))))
    (without-interrupts
     ;(ccl::%put-point (%int-to-ptr #$MTemp) absloc)
     (#_LMSetMouseTemp absloc)
     ;(ccl::%put-point (%int-to-ptr #$RawMouse) absloc)
     (#_LMSetRawMouseLocation absloc)
     ;(%put-word (%int-to-ptr #$CrsrNew) -1)
     (#_LMSetCursorNew -1)
     )
    ;(while (eql (%get-signed-word (%int-to-ptr #$CrsrNew)) -1))
    (while (eql (#_LMGetCursorNew) -1))
    (update-cursor)
    (while (not (vpt= xyloc (p2vpt (view-mouse-position device))))
      (event-dispatch))))


(unless (fboundp 'speech-available-p)
  (defun speech-available-p () nil))



;;; DEVICE-SPEAK-STRING      [Method]
;;; Description : If the Mac Speech Manager is installed, actually speak the
;;;             : string.

(defmethod device-speak-string ((device window) string)
  (when (speech-available-p)
    (speak-string string)
    ))


;;; GET-MOUSE-COORDINATES      [Method]
;;; Description : Return the current mouse loc in #(x y) format.

(defmethod get-mouse-coordinates ((device window))
  (p2vpt (view-mouse-position device)))


;;; DEVICE-UPDATE      [Method]
;;; Date        : 03.03.11
;;; Description : Rather than calling EVENT-DISPATCH on every cycle, call it
;;;             : only at about 10Hz.

(defmethod device-update :after ((wind window) time)
  (declare (ignore wind time))
  (when (< 100 (- (get-internal-real-time) *last-update*))
    (event-dispatch)
    (setf *last-update* (get-internal-real-time)))
  )


#|
(defmethod do-update :after ((mstr-proc master-process) current-time 
                               &key (real-wait nil))
  (declare (ignore current-time real-wait))
  (event-dispatch))
|#




(defmethod populate-loc-to-key-array ((ar array))
  "Sets all the keys in the array that need to be set"
  ;; function key row
  (setf (aref ar 0 0) #\ESC)
  (setf (aref ar 2 0) #\2061)
  (setf (aref ar 3 0) #\2062)
  (setf (aref ar 4 0) #\2063)
  (setf (aref ar 5 0) #\2064)
  (setf (aref ar 7 0) #\2065)
  (setf (aref ar 8 0) #\2066)
  (setf (aref ar 9 0) #\2067)
  (setf (aref ar 10 0) #\2070)
  (setf (aref ar 12 0) #\2071)
  (setf (aref ar 13 0) #\2101)
  (setf (aref ar 14 0) #\2102)
  (setf (aref ar 15 0) #\2103)
  (setf (aref ar 17 0) #\2014)
  (setf (aref ar 18 0) #\2015)
  (setf (aref ar 19 0) #\2016)
  ;; numeric key row
  (setf (aref ar 0 2) #\tab)
  (setf (aref ar 1 2) #\1)
  (setf (aref ar 2 2) #\2)
  (setf (aref ar 3 2) #\3)
  (setf (aref ar 4 2) #\4)
  (setf (aref ar 5 2) #\5)
  (setf (aref ar 6 2) #\6)
  (setf (aref ar 7 2) #\7)
  (setf (aref ar 8 2) #\8)
  (setf (aref ar 9 2) #\9)
  (setf (aref ar 10 2) #\0)
  (setf (aref ar 11 2) #\-)
  (setf (aref ar 12 2) #\=)
  (setf (aref ar 13 2) #\Delete)
  (setf (aref ar 15 2) #\help)
  (setf (aref ar 16 2) #\home)
  (setf (aref ar 17 2) #\pageup)
  (setf (aref ar 19 2) #\ESC)
  (setf (aref ar 20 2) #\=)
  (setf (aref ar 21 2) #\/)
  (setf (aref ar 22 2) #\*)
  ;; qwerty row
  (setf (aref ar 0 3) #\Tab)
  (setf (aref ar 1 3) #\q)
  (setf (aref ar 2 3) #\w)
  (setf (aref ar 3 3) #\e)
  (setf (aref ar 4 3) #\r)
  (setf (aref ar 5 3) #\t)
  (setf (aref ar 6 3) #\y)
  (setf (aref ar 7 3) #\u)
  (setf (aref ar 8 3) #\i)
  (setf (aref ar 9 3) #\o)
  (setf (aref ar 10 3) #\p)
  (setf (aref ar 11 3) #\[)
  (setf (aref ar 12 3) #\])
  (setf (aref ar 13 3) #\\)
  (setf (aref ar 15 3) #\DEL)
  (setf (aref ar 16 3) #\End)
  (setf (aref ar 17 3) #\Page)
  (setf (aref ar 19 3) #\7)
  (setf (aref ar 20 3) #\8)
  (setf (aref ar 21 3) #\9)
  (setf (aref ar 22 3) #\-)
  ;; ASDF row
  (setf (aref ar 0 4) 'caps-lock)
  (setf (aref ar 1 4) #\a)
  (setf (aref ar 2 4) #\s)
  (setf (aref ar 3 4) #\d)
  (setf (aref ar 4 4) #\f)
  (setf (aref ar 5 4) #\g)
  (setf (aref ar 6 4) #\h)
  (setf (aref ar 7 4) #\j)
  (setf (aref ar 8 4) #\k)
  (setf (aref ar 9 4) #\l)
  (setf (aref ar 10 4) #\;)
  (setf (aref ar 11 4) #\')
  (setf (aref ar 12 4) #\Newline)
  (setf (aref ar 13 4) #\Newline)
  (setf (aref ar 19 4) #\4)
  (setf (aref ar 20 4) #\5)
  (setf (aref ar 21 4) #\6)
  (setf (aref ar 22 4) #\+)
  ;; Z row
  (setf (aref ar 0 5) 'shift)
  (setf (aref ar 1 5) #\z)
  (setf (aref ar 2 5) #\x)
  (setf (aref ar 3 5) #\c)
  (setf (aref ar 4 5) #\v)
  (setf (aref ar 5 5) #\b)
  (setf (aref ar 6 5) #\n)
  (setf (aref ar 7 5) #\m)
  (setf (aref ar 8 5) #\,)
  (setf (aref ar 9 5) #\.)
  (setf (aref ar 10 5) #\/)
  (setf (aref ar 11 5) 'shift)
  (setf (aref ar 12 5) 'shift)
  (setf (aref ar 16 5) #\UpArrow)
  (setf (aref ar 19 5) #\1)
  (setf (aref ar 20 5) #\2)
  (setf (aref ar 21 5) #\3)
  (setf (aref ar 22 5) #\Enter)
  ;; space bar row
  (setf (aref ar 0 6) 'control)
  (setf (aref ar 1 6) 'option)
  (setf (aref ar 2 6) 'command)
  (setf (aref ar 3 6) #\Space)
  (setf (aref ar 4 6) #\Space)
  (setf (aref ar 5 6) #\Space)
  (setf (aref ar 6 6) #\Space)
  (setf (aref ar 7 6) #\Space)
  (setf (aref ar 8 6) #\Space)
  (setf (aref ar 9 6) #\Space)
  (setf (aref ar 10 6) #\Space)
  (setf (aref ar 11 6) 'command)
  (setf (aref ar 12 6) 'option)
  (setf (aref ar 13 6) 'control)
  (setf (aref ar 15 6) #\BackArrow)
  (setf (aref ar 16 6) #\DownArrow)
  (setf (aref ar 17 6) #\ForwardArrow)
  (setf (aref ar 19 6) #\0)
  (setf (aref ar 20 6) #\0)
  (setf (aref ar 21 6) #\.)
  (setf (aref ar 22 6) #\Enter)
  ar)


;;;; ---------------------------------------------------------------------- ;;;;
;;;; RPM overlay and Focus ring stuff


;;; RPM-OVERLAY      [Class]
;;; Description : If you want a view to be superimposed on a window, but not
;;;             : be visible to RPM, use this class.  The focus ring in RPM
;;;             : is a subclass.
;;;
;;;             : The OFFSET slot is for the difference between the center of
;;;             : the view and the upper-left corner, as a QuickDraw point.
;;;             : For example, for the focus ring its #@(-10 -10).

(defclass rpm-overlay (simple-view)
  ((offset :accessor offset :initarg :offset :initform nil)))


(defgeneric update-me (olay wind xyloc)
  (:documentation "Call this to move the overlay to a specific location within a window."))

(defmethod update-me ((olay rpm-overlay) (wind window) (xyloc vector))
  (set-view-position olay (add-points (offset olay) (vpt2p xyloc)))
  (unless (equal (view-window olay) wind) (add-subviews wind olay))
  (event-dispatch)
  (when (wptr (view-window olay)) (view-draw-contents olay)))


;;; BUILD-FEATURES-FOR      [Method]
;;; Description : We don't want icon features for the focus ring, and since 
;;;             : it'll be a subview a null BUILD-FEATURES-FOR method is 
;;;             : necessary.

(defmethod build-features-for ((olay rpm-overlay) (vm vision-module))
  (declare (ignore olay vm))
  nil)

;;; POINT-IN-CLICK-REGION-P      [Method]
;;; Description : The focus ring will generally be the "front" view, but 
;;;             : having it receive clicks is a Bad Thing (tm) so it's 
;;;             : necessary to override the POINT-IN-CLICK-REGION-P method
;;;             : for this view class.

(defmethod point-in-click-region-p ((olay rpm-overlay) where)
  (declare (ignore olay where))
  nil)


;;; here's the actual focus ring itself

(defclass focus-ring (rpm-overlay)
  ((color :accessor color :initarg :color :initform *red-color*))
  (:default-initargs 
    :view-size #@(19 19)
    :offset #@(-10 -10)))


(defmethod view-draw-contents ((self focus-ring))
  (let ((oldmode (pen-mode self))
        (oldpat (pen-pattern self))
        (oldsize (pen-size self)))
    (set-pen-mode self :pator)
    (set-pen-pattern self *light-gray-pattern*)
    (set-pen-size self 4 4)
    (with-focused-view self
      (with-fore-color (color self)
        (frame-oval self #@(0 0) (view-size self))))
    (set-pen-mode self oldmode)
    (set-pen-pattern self oldpat)
    (set-pen-size self (point-h oldsize) (point-v oldsize))
    ))


;;; DEVICE-UPDATE-ATTENDED-LOC      [Method]
;;; Date        : 00.07.11
;;; Description : When the attended location is updated, update the focus
;;;             : ring.

(defmethod device-update-attended-loc ((wind window) xyloc)
  (update-me *attn-tracker* wind xyloc))


;;; make the fous ring

(eval-when (load eval)
  (setf *attn-tracker* (make-instance 'focus-ring)))

;;;; ---------------------------------------------------------------------- ;;;;
;;;; color text stuff

(defmethod build-features-for :around ((self static-text-dialog-item)
                                          (vis-mod vision-module))
  (let ((feats (call-next-method))
        (color (system-color->symbol (aif (part-color self :text)
                                        it
                                        *black-color*))))
    (mapcar #'(lambda (f)
                (setf (color f) color)
                f)
            feats)))


(defun system-color->symbol (color)
  "Given an MCL color code, return a symbol representing that color.  Unknown colors get mapped to COLOR-RRRRR-GGGGG-BBBBB."
  (if (null color)
    'black
    (case color
      (#.*black-color* 'black)
      (#.*green-color* 'green)
      (#.*red-color* 'red)
      (#.*blue-color* 'blue)
      (#.*brown-color* 'brown)
      (#.*purple-color* 'purple)
      (#.*pink-color* 'pink)
      (#.*orange-color* 'orange)
      (#.*dark-gray-color* 'dark-gray)
      (#.*light-blue-color* 'light-blue)
      (#.*white-color* 'white)
      (#.*light-gray-color* 'light-gray)
      (#.*dark-green-color* 'dark-green)
      (#.*tan-color* 'tan)
      (#.*yellow-color* 'yellow)
      (otherwise (intern (format nil "COLOR-~5,'0d-~5,'0d-~5,'0d" 
                                 (color-red color) 
                                 (color-green color) 
                                 (color-blue color)))))))

(defun color-symbol->system-color (color)
  "this may look like it should do the inverse of the above, but right now
   it doesn't exactly.  If the color isn't one of the default ones then
   the black color is returned.  It's only being used by the UWI right now,
   so it's simplified for that purpose.  Only colors that the systems have
   in 'common' are used - with the Mac names being the default, in keeping
   with the usual bias :) "
  (cond ((equal color 'red) *red-color*)
        ((equal color 'blue) *blue-color*)
        ((equal color 'green) *green-color*)
        ((equal color 'black) *black-color*)
        ((equal color 'white) *white-color*)
        ((equal color 'pink)  *pink-color*)
        ((equal color 'yellow) *yellow-color*)
        ((equal color 'dark-green) *dark-green-color*)
        ((equal color 'light-blue) *light-blue-color*)
        ((equal color 'purple) *purple-color*)
        ((equal color 'brown) *brown-color*)
        ((equal color 'light-gray) *light-gray-color*)
        ((equal color 'gray) *gray-color*)
        ((equal color 'dark-gray) *dark-gray-color*)
        (t *black-color*)))



;;;; ---------------------------------------------------------------------- ;;;;
;;;; handling mouse movement under MCL 5.0 and OS X.

#+:ccl-5.0
(when (osx-p)
(progn

(defparameter *warp* (lookup-function-in-framework 
                       "CGWarpMouseCursorPosition"))

(defmethod device-move-cursor-to ((device window) (xyloc vector))
  (when (and device (wptr device)) (window-select device))
  (setf xyloc (local-to-global device (vpt2p xyloc)))
  (ccl::ppc-ff-call *warp* 
                    :single-float (coerce (point-h xyloc) 'short-float)
                    :single-float (coerce (point-v xyloc) 'short-float)
                    :unsigned-fullword)
  )))

#|
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/devices/virtual/device.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)2000-2004 Mike Byrne
;;; Availability: Covered by the GNU LGPL, see LGPL.txt
;;; 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 
;;; Filename    : virtual-view.lisp
;;; Version     : 1.0a1
;;; 
;;; Description : Instantiates "virtual views" so that RPM can act on things
;;;             : other than MCL windows.
;;; 
;;; Bugs        : 
;;; 
;;; Todo        : 
;;; 
;;; ----- History -----
;;; 00.06.08 Mike Byrne
;;;             :  Date for new header.
;;; 00.09.13 mdb
;;;             : Updated for vectors.
;;; 00.11.15 mdb
;;;             : Fixed minor compiler warnings, cleaned up some lingering
;;;             : vector bugs.
;;; 01.07.03 mdb
;;;             : Added defgenerics and doc strings.
;;; 02.01.15 Dan
;;;             : Changed the declaration of ignore to
;;;             : ignore-if-unused for the subviews method
;;;             : to eliminate an ugly warning in ACL.  
;;; 02.02.28 Dan
;;;             : changed vv-click-event-handler because
;;;             : functionp doesn't gurantee that the function is
;;;             : returned as the true value.
;;; 02.06.21 Dan [b7]
;;;             : Added the rpm-window class as part of the reorganization
;;;             : of internal window classes.
;;;             : Changed the #+:mcl to better work with openmcl.
;;; 02.06.30 Dan
;;;             : Moved the view based line support in to here.
;;;             : Moved the populate-loc-to-key-array from generic-interface
;;;             : to here.
;;;             : Took the UWI code out of here.
;;; 02.12.19 Dan 
;;;             : Added an around method for text items to handle color.
;;; 04.04.13 Dan [2.2]  (the previous update is "new" as of 2.2 as well)
;;;             : Changed the copyright notice and added the LGPL stuff.
;;;
;;; 04.10.19 Dan [Moved into ACT-R 6]
;;;             : Reset the version to 1.0a1
;;;             : added the packaging switches
;;;             : Changed vw-output to show in the trace and not in the
;;;             :  a window specific stream
;;;             :
;;;             : depends on the vision module and dmi, but that seems
;;;             : reasonable for now.
;;; 2005.05.11 Dan
;;;             : * Added a check of :vwt to vw-output so that it can be
;;;             :   easily shut off (which is actually the default for now).
;;; 2006.01.16 Dan
;;;             : * Discovered that the hash-table implementation of the
;;;             :   virtual-view subviews can lead to non-repeatable performance
;;;             :   of tutorial models (both between different Lisps or even
;;;             :   within a single Lisp!).  So, for now at least, the 
;;;             :   build-features-for method for a virtual-window will sort
;;;             :   the features based on xy coordinates.  That way the tutorial
;;;             :   model results will remain consistent for all systems that
;;;             :   use the virtuals (any hooked up to the environment).
;;; 2006.09.07 Dan
;;;             : * Modified the build-features-for method on the virtual-
;;;             :   windows so that it calls fill-default-dimensions.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

#+: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)

;;;; ---------------------------------------------------------------------- ;;;;
;;;; Base Virtual View class.

(defclass virtual-view ()
  ((view-subviews :accessor view-subviews :initarg :subviews
                  :initform (make-hash-table))
   (x-pos :accessor x-pos :initform nil :initarg :x-pos)
   (y-pos :accessor y-pos :initform nil :initarg :y-pos)
   (width :accessor width :initform nil :initarg :width)
   (height :accessor height :initform nil :initarg :height)
   (id :accessor id :initarg :id :initform (new-name-fct "VV"))
   (handles-click-p :accessor handles-click-p :initform t 
                    :initarg :handles-click-p)
   (view-container :accessor view-container :initform nil)
   (color :accessor color :initarg :color :initform 'black)
   ))

#+(or (not :mcl) :openmcl)
(defgeneric subviews (view &optional subview-type)
  (:documentation "Returns a list of subviews of <view>."))

(defmethod subviews ((vv virtual-view) &optional subview-type)
  (declare (ignore subview-type))
  (let (accum)
    (maphash #'(lambda (x y) (declare (ignore x)) 
                (push y accum)) 
             (view-subviews vv))
    accum))

#+(or (not :mcl) :openmcl)
(defgeneric set-view-position (view x &optional y)
  (:documentation  "Sets the position of <view> to the supplied location."))

(defmethod set-view-position ((vv virtual-view) x &optional y)
  (setf (x-pos vv) x)
  (when y
    (setf (y-pos vv) y)))


#+(or (not :mcl) :openmcl)
(defgeneric set-view-size (view x &optional y)
  (:documentation  "Set the size of <view> to the provided dimensions."))

(defmethod set-view-size ((vv virtual-view) x &optional y)
  (setf (width vv) x)
  (when y
    (setf (height vv) y)))


#+(or (not :mcl) :openmcl)
(defgeneric view-size (view)
  (:documentation  "Return the size of <view> as #(x y)."))

(defmethod view-size ((vv virtual-view))
  (vector (width vv) (height vv)))


#+(or (not :mcl) :openmcl)
(defgeneric view-position (view)
  (:documentation  "Return the top left position of <view> in its container as #(x y)."))

(defmethod view-position ((vv virtual-view))
  (vector (x-pos vv) (y-pos vv)))


(defmethod view-loc ((vv virtual-view))
  (vector (+ (x-pos vv) (/ (width vv) 2))
          (+ (y-pos vv) (/ (height vv) 2))))


#+(or (not :mcl) :openmcl)
(defgeneric add-subviews (view &rest subviews)
  (:documentation  "Add subviews to <view>."))

(defmethod add-subviews ((vv virtual-view) &rest subviews)
  (dolist (sub subviews)
    (setf (gethash (id sub) (view-subviews vv)) sub)
    (setf (view-container sub) vv)))


#+(or (not :mcl) :openmcl)
(defgeneric remove-subviews (view &rest subviews)
  (:documentation  "Remove subviews from <view>."))

(defmethod remove-subviews ((vv virtual-view) &rest subviews)
  (dolist (sub subviews)
    (remhash (id sub) (view-subviews vv))
    (setf (view-container sub) nil)))


(defgeneric point-in-vv-p (vview point)
  (:documentation  "Determine if the supplied point is inside the supplied view."))

(defmethod point-in-vv-p ((vv virtual-view) point)
  (let ((x (the fixnum (px point)))
        (y (the fixnum (py point))))
    (and (>= x (the fixnum (x-pos vv)))
         (>= y (the fixnum (y-pos vv)))
         (<= x (the fixnum (+ (x-pos vv) (width vv))))
         (<= y (the fixnum (+ (y-pos vv) (height vv)))))))


(defgeneric vv-click-event-handler (vview point)
  (:documentation  "Handle a click in <vview> at point <point>."))

(defmethod vv-click-event-handler ((vv virtual-view) point)
  (declare (ignore point))
  nil)


;;;; ---------------------------------------------------------------------- ;;;;
;;;; Virtual Window class and methods.

(defclass virtual-window (virtual-view)
  ((window-title :accessor window-title :initarg :window-title
                 :initform "Virtual Window")
   (outstrm :accessor outstrm :initarg :outstrm :initform t)
   (cursor-pos :accessor cursor-pos :initform #(0 0) :initarg :cursor-pos)
   (cursor-shape :accessor cursor-shape :initform 'POINTER 
                 :initarg :cursor-shape)
   )
  (:default-initargs
    :x-pos 0
    :y-pos 0
    :id (new-name-fct "VW")
    ))


(defmethod get-mouse-coordinates ((vw virtual-window))
  (cursor-pos vw))


(defmethod build-features-for ((vw virtual-window) (vis-mod vision-module))
  (let ((base-ls
         (sort (flatten 
                (mapcar #'(lambda (obj) (build-features-for obj vis-mod))
                  (subviews vw)))
               #'loc-sort)))
    (dolist (feat base-ls)
      (fill-default-dimensions feat))
    base-ls))


(defun loc-sort (i1 i2)
  (and (numberp (screen-x i1))
       (numberp (screen-x i2))
       (numberp (screen-y i1))
       (numberp (screen-y i2))
       (or
        (< (screen-x i1) (screen-x i2))
        (and (= (screen-x i1) (screen-x i2))
             (< (screen-y i1) (screen-y i2))))))
       
       


(defmethod cursor-to-feature ((vw virtual-window))
  (when (point-in-vv-p vw (cursor-pos vw))
    (make-instance 'cursor-feature
        :x (px (cursor-pos vw)) :y (py (cursor-pos vw))
        :value (cursor-shape vw))))


(defmethod device-move-cursor-to ((vw virtual-window) (xyloc list))
  (device-move-cursor-to vw (coerce xyloc 'vector))
  )


(defmethod device-move-cursor-to ((vw virtual-window) (loc vector))
  (setf (cursor-pos vw) loc)
  (when (with-cursor-p (current-device-interface))
      (proc-display)))


(defmethod device-handle-keypress ((vw virtual-window) key)
  ;(when (car (no-output (sgp :v)))
   (vw-output vw "got key ~S at time ~S" key (mp-time))
  )




(defmethod device-speak-string ((vw virtual-window) string)
  (vw-output vw "heard speech '~A' at time ~S" string (mp-time))
  )


(defmethod device-handle-click ((vw virtual-window))
  (dolist (sub (subviews vw))
    (when (and (handles-click-p sub)
               (point-in-vv-p sub (cursor-pos vw)))
      (vv-click-event-handler sub (cursor-pos vw))
      (return-from device-handle-click t)))
  ;(when (car (no-output (sgp :v)))
    (vw-output vw "was clicked at time ~S" (mp-time)))



(defgeneric vw-output (vwind base &rest args)
  (:documentation  "Print some output to a virtual window."))

(defmethod vw-output ((vw virtual-window) (base string) &rest args)
  ;; DAN
  ;; seems like this should be in the trace
  ;;(format (outstrm vw)
  
  (when (car (no-output (sgp :vwt)))
    (model-output "~&~%<< Window ~S ~? >>~%"
                  (window-title vw)
                  base args)))



#+(or (not :mcl) :openmcl)
(defgeneric view-window (view)
  (:documentation  "Returns the window associated with <view> (if any), or <view> if <view> is a window."))

(defmethod view-window ((vw virtual-window))
  vw)


#+(or (not :mcl) :openmcl)
(defgeneric window-close (wind)
  (:documentation  "Closes a window."))

;;; there isn't really anything to close in a virtual window, so do nothing
(defmethod window-close ((vw virtual-window))
  nil)

#+(or (not :mcl) :openmcl)
(defgeneric window-select (wind)
  (:documentation  "Brings <wind> to the front."))

;;; there's no "front" in virtual windows, so do nothing.
(defmethod window-select ((vw virtual-window))
  nil)


#+(or (not :mcl) :openmcl)
(defgeneric set-window-title (wind new-title)
  (:documentation  "Set the title of <wind> to <new-title>."))

(defmethod set-window-title ((window virtual-window) (new-title string))
  (setf (window-title window) new-title))


;;;; ---------------------------------------------------------------------- ;;;;
;;;; View classes:  static-text-vv, button-vv, 


(defclass virtual-dialog-item (virtual-view)
  ((text :accessor dialog-item-text :initform "Untitled" 
         :initarg :dialog-item-text)
   (action-function :accessor action-function :initarg :action :initform nil)
   (text-height :accessor text-height :initarg :text-height :initform 10)
   (str-width-fct :accessor str-width-fct :initarg :str-width-fct
                  :initform #'(lambda (str)
                                (* 7 (length str))))
   )
  (:default-initargs
       :height 18
       :width 60
       :subviews nil))


#+(or (not :mcl) :openmcl)
(defgeneric set-dialog-item-text (dialog-item text)
  (:documentation  "Set the text associated with <dialog-item> to <text>."))

(defmethod set-dialog-item-text ((vdi virtual-dialog-item) (text string))
  (setf (dialog-item-text vdi) text))


(defmethod subviews ((vdi virtual-dialog-item) &optional subview-type)
  (declare (ignore-if-unused vdi subview-type))
  nil)


(defmethod view-window ((vdi virtual-dialog-item))
  (let ((vc (view-container vdi)))
    (if (null vc)
      nil
      (if (typep vc 'virtual-window)
        vc
        (view-window vc)))))


(defclass static-text-vdi (virtual-dialog-item)
  ()
  (:default-initargs
       :id (new-name-fct "TEXT-VDI")
       :handles-click-p nil))


(defmethod build-features-for ((self static-text-vdi) 
                                  (vis-mod vision-module))
  (build-string-feats vis-mod :text (dialog-item-text self)
                      :start-x (1+ (x-pos self))
                      :y-pos (py (view-loc self))
                      :width-fct (str-width-fct self)
                      :height (text-height self)
                      :obj self))


(defmethod build-features-for :around ((self static-text-vdi)
                                          (vis-mod vision-module))
  (let ((feats (call-next-method)))
    (mapcar #'(lambda (f)
                (setf (color f) (color self))
                f)
            feats)))


(defclass button-vdi (virtual-dialog-item)
  ()
  (:default-initargs
       :id (new-name-fct "BUTTON-VDI")
       :action #'default-button-action
       ))


(defmethod vv-click-event-handler ((btn button-vdi) where)
  (declare (ignore where))
  (when (functionp (action-function btn))
    (funcall (action-function btn) btn)))


(defmethod default-button-action ((btn button-vdi))
  (format t "~%Button '~S' clicked at time ~S." 
          (dialog-item-text btn) (mp-time)))



(defmethod build-features-for ((self button-vdi) (vis-mod vision-module))
  (cons
   (make-instance 'oval-feature 
     :x (px (view-loc self))
     :y (py (view-loc self))
     :screen-obj self
     :width (width self)
     :height (height self))
   (build-string-feats vis-mod :text (dialog-item-text self)
                       :start-x 
                       (+ (x-pos self)
                          (round
                           (funcall (str-width-fct self) 
                                    (dialog-item-text self))
                           2))
                       :y-pos (y-pos self)
                       :width-fct (str-width-fct self)
                       :height (text-height self)
                       :obj self)))




;;; The base class for the view based lines. 

(defclass v-liner (virtual-view)
  ())


(defmethod point-in-click-region-p ((self v-liner) where)
  "Method needed by R/PM so that if the mouse is clicked on the view it
   doesn't get handled by this view, and is passed on to the next"
  (declare (ignore where))
  nil)


(defmethod build-features-for ((lnr v-liner) (vis-mod vision-module))
  "Convert the view to a feature to be placed into the visual icon"
  
  (make-instance 'line-feature
     :color  (color lnr)
     :end1-x (x-pos lnr) 
     :end1-y (y-pos lnr)
     :end2-x (width lnr) 
     :end2-y (height lnr)
     :x (floor (/ (+ (x-pos lnr) (width lnr)) 2))
     :y (floor (/ (+ (y-pos lnr) (height lnr)) 2))
     :width (abs (- (x-pos lnr) (width lnr)))
     :height (abs (- (y-pos lnr) (height lnr)))))


(defmethod feat-to-dmo ((feat line-feature))
  "Convert the line-feature from the visual icon to a DMO (chunk in ACT-R)
   when the feature is attended to"
  (setf (attended-p feat) t)
  (make-dme (dmo-id feat) (kind feat)
            `(screen-pos ,(id (xy-to-dmo (xy-loc feat) t))
              value ,(val feat)
              color ,(color feat)
              height ,(height feat)
              width ,(width feat)
              end1-x ,(end1-x feat)
              end1-y ,(end1-y feat)
              end2-x ,(end2-x feat)
              end2-y ,(end2-y feat))
            :obj (screen-obj feat)
            :where :external))


(defmethod populate-loc-to-key-array ((ar array))
  "Sets all the keys in the array that need to be set"
  ;; function key row
  (setf (aref ar 0 0) 'ESC)
  (setf (aref ar 2 0) 'f1)
  (setf (aref ar 3 0) 'f2)
  (setf (aref ar 4 0) 'f3)
  (setf (aref ar 5 0) 'f4)
  (setf (aref ar 7 0) 'f5)
  (setf (aref ar 8 0) 'f6)
  (setf (aref ar 9 0) 'f7)
  (setf (aref ar 10 0) 'f8)
  (setf (aref ar 12 0) 'f9)
  (setf (aref ar 13 0) 'f10)
  (setf (aref ar 14 0) 'f11)
  (setf (aref ar 15 0) 'f12)
  (setf (aref ar 17 0) 'print-screen)
  (setf (aref ar 18 0) 'scroll-lock)
  (setf (aref ar 19 0) 'pause)
  ;; numeric key row
  (setf (aref ar 0 2) #\tab)
  (setf (aref ar 1 2) #\1)
  (setf (aref ar 2 2) #\2)
  (setf (aref ar 3 2) #\3)
  (setf (aref ar 4 2) #\4)
  (setf (aref ar 5 2) #\5)
  (setf (aref ar 6 2) #\6)
  (setf (aref ar 7 2) #\7)
  (setf (aref ar 8 2) #\8)
  (setf (aref ar 9 2) #\9)
  (setf (aref ar 10 2) #\0)
  (setf (aref ar 11 2) #\-)
  (setf (aref ar 12 2) #\=)
  (setf (aref ar 13 2) 'Delete)
  (setf (aref ar 15 2) 'help)
  (setf (aref ar 16 2) 'home)
  (setf (aref ar 17 2) 'pageup)
  (setf (aref ar 19 2) 'ESC)
  (setf (aref ar 20 2) #\=)
  (setf (aref ar 21 2) #\/)
  (setf (aref ar 22 2) #\*)
  ;; qwerty row
  (setf (aref ar 0 3) #\Tab)
  (setf (aref ar 1 3) #\q)
  (setf (aref ar 2 3) #\w)
  (setf (aref ar 3 3) #\e)
  (setf (aref ar 4 3) #\r)
  (setf (aref ar 5 3) #\t)
  (setf (aref ar 6 3) #\y)
  (setf (aref ar 7 3) #\u)
  (setf (aref ar 8 3) #\i)
  (setf (aref ar 9 3) #\o)
  (setf (aref ar 10 3) #\p)
  (setf (aref ar 11 3) #\[)
  (setf (aref ar 12 3) #\])
  (setf (aref ar 13 3) #\\)
  (setf (aref ar 15 3) 'DEL)
  (setf (aref ar 16 3) 'End)
  (setf (aref ar 17 3) 'Page)
  (setf (aref ar 19 3) #\7)
  (setf (aref ar 20 3) #\8)
  (setf (aref ar 21 3) #\9)
  (setf (aref ar 22 3) #\-)
  ;; ASDF row
  (setf (aref ar 0 4) 'caps-lock)
  (setf (aref ar 1 4) #\a)
  (setf (aref ar 2 4) #\s)
  (setf (aref ar 3 4) #\d)
  (setf (aref ar 4 4) #\f)
  (setf (aref ar 5 4) #\g)
  (setf (aref ar 6 4) #\h)
  (setf (aref ar 7 4) #\j)
  (setf (aref ar 8 4) #\k)
  (setf (aref ar 9 4) #\l)
  (setf (aref ar 10 4) #\;)
  (setf (aref ar 11 4) #\')
  (setf (aref ar 12 4) #\Newline)
  (setf (aref ar 13 4) #\Newline)
  (setf (aref ar 19 4) #\4)
  (setf (aref ar 20 4) #\5)
  (setf (aref ar 21 4) #\6)
  (setf (aref ar 22 4) #\+)
  ;; Z row
  (setf (aref ar 0 5) 'shift)
  (setf (aref ar 1 5) #\z)
  (setf (aref ar 2 5) #\x)
  (setf (aref ar 3 5) #\c)
  (setf (aref ar 4 5) #\v)
  (setf (aref ar 5 5) #\b)
  (setf (aref ar 6 5) #\n)
  (setf (aref ar 7 5) #\m)
  (setf (aref ar 8 5) #\,)
  (setf (aref ar 9 5) #\.)
  (setf (aref ar 10 5) #\/)
  (setf (aref ar 11 5) 'shift)
  (setf (aref ar 12 5) 'shift)
  (setf (aref ar 16 5) 'UpArrow)
  (setf (aref ar 19 5) #\1)
  (setf (aref ar 20 5) #\2)
  (setf (aref ar 21 5) #\3)
  (setf (aref ar 22 5) 'enter)
  ;; space bar row
  (setf (aref ar 0 6) 'control)
  (setf (aref ar 1 6) 'option)
  (setf (aref ar 2 6) 'command)
  (setf (aref ar 3 6) #\Space)
  (setf (aref ar 4 6) #\Space)
  (setf (aref ar 5 6) #\Space)
  (setf (aref ar 6 6) #\Space)
  (setf (aref ar 7 6) #\Space)
  (setf (aref ar 8 6) #\Space)
  (setf (aref ar 9 6) #\Space)
  (setf (aref ar 10 6) #\Space)
  (setf (aref ar 11 6) 'command)
  (setf (aref ar 12 6) 'option)
  (setf (aref ar 13 6) 'control)
  (setf (aref ar 15 6) 'BackArrow)
  (setf (aref ar 16 6) 'DownArrow)
  (setf (aref ar 17 6) 'ForwardArrow)
  (setf (aref ar 19 6) #\0)
  (setf (aref ar 20 6) #\0)
  (setf (aref ar 21 6) #\.)
  (setf (aref ar 22 6) 'enter)
  ar)


#|
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/framework/device-interface.lisp
;;;============================================================================

;;;  -*- mode: LISP; Package: CL-USER; Syntax: COMMON-LISP;  Base: 10 -*-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 
;;; Authors     : 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 LICENSE.txt
;;; 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 
;;; Filename    : device-interface.lisp
;;; Version     : 1.1
;;; 
;;; Description : File for managing the device interface.
;;; 
;;; Bugs        : None known.
;;; 
;;; Todo        : Nothing pending.
;;; 
;;; ----- History -----
;;; 2004.10.19 Dan [Moved into ACT-R 6]
;;;             : Lots of changes - first being a reset of version to 1.0a1
;;;
;;;             : Added the package switches for the act-r package and
;;;             : the "clean" packaging
;;;
;;;             : Removed the following:
;;;                      pm-get-time, pm-timed-event, pm-delayed-event
;;;                         new functions replace these: mp-time and all of the
;;;                         new scheduling functions
;;;                         may want to put back as depricated to ease transition
;;;
;;;                      reset-module 
;;;                         because a model reset calls reset-device directly
;;;                      
;;;                      run-events, new-message 
;;;                         everything goes through the central scheduler
;;;                         instead of separate event queues
;;;
;;;                      pm-install-module, update-module, silent-events
;;;                         master-process functionality replaced
;;;
;;;                      process-display and update-cursor-feat
;;;                         moved specific methods to the vision module since 
;;;                         that's really more the critical class and the
;;;                         device preceeds the specific modules now
;;;
;;;             : Added:
;;;                      current-device-interface, install-device, 
;;;                      current-device, proc-display
;;;
;;;             : Moved these from elsewhere to here
;;;                      pm-angle-to-pixels, pm-pixels-to-angle  
;;; 2005.01.11 mdb
;;;             : Added a couple toplevel functions for backward compatibility.        
;;;
;;; 2005.01.12 Dan
;;;             : Made the device an actual module so that it can have its
;;;             : own parameters.
;;;             :
;;;             : Moved the newly added backward compatibility functions to the
;;;             : backward file in support.
;;; 2005.01.13 Dan
;;;             : * Added the the two new methods lock-device and unlock-device
;;;             :   along with the appropriate slots and changes to reset-device
;;;             :   to allow other modules to block and unblock proc-display 
;;;             :   from actually going.  [Right now, that's a problem with
;;;             :   productions potentially jamming vision if a proc-display
;;;             :   happens between the time of the query for free and the
;;;             :   time that the +visual command is actually sent.]
;;; 2005.02.17 Dan
;;;             : * Fixed the references in the *pixels-per-inch-* settings
;;;             :   so that ACL gets the packaging correct.
;;; 2005.05.11 Dan
;;;             : * Added the :vwt paramter and corresponding virtual-trace
;;;             :   slot to the device interface to control the output of the
;;;             :   << ... >> printing from the vw-output command used by the
;;;             :   virtual window device.
;;; 2005.08.10 Dan
;;;             : * Removed a duplicate definition of prod-display.
;;; 2005.11.02 Dan
;;;             : * Updated unlock-device so that tracking updates can be
;;;             :   recognized and handled as well as full proc-displays.
;;; 2006.03.07 Dan
;;;             : * Fixed an old bug which I don't know how it got back in...
;;;             :   the theta for hyphen in the key mapping should be -1.11.
;;; 2006.03.08 Dan
;;;             : * Made the key-to-loc and key-to-command tables consistent
;;;             :   with respect to - and hyphen.  Both tables now have entries
;;;             :   for both symbols mapped to the same things.
;;; 2006.09.11 Dan
;;;             : * Changed valid test for :mouse-fitts-coeff from posnum to nonneg.
;;; 2006.12.14 Dan
;;;             : * Changed current-device-interface so that it only returns
;;;             :   one value.
;;;             : * Reset all the versions to 1.1...
;;; 2006.12.18 Dan
;;;             : * Removed the :speech-hook parameter since it was depricated
;;;             :   long ago.
;;;             : * Also removed the :output-speech parameter because it doesn't
;;;             :   really have a purpose now - the default devices all have a
;;;             :   device-speak-string method even if it doesn't do anything.
;;; 2006.12.28 Dan
;;;             : * Made proc-display better check for current mp/model/device.
;;; 2007.01.09 Dan
;;;             : * Make output-key check the keyboard array boundaries to avoid
;;;             :   errors when bad key-locations come in.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

#+: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)


;;; unless it's MCL define the pixels-per-inch
#+(or (not :mcl) :openmcl)
(progn
  (defvar *pixels-per-inch-x* 72)
  (defvar *pixels-per-inch-y* 72))

;;; if it's ACL with the IDE (Windows) then find the true units-per-inch
#+(and :ALLEGRO-IDE (not :ACTR-ENV-ALONE))
(multiple-value-bind (x y) 
                     (cg:stream-units-per-inch  (cg:screen cg:*system*))
  (setf *pixels-per-inch-x* x)
  (setf *pixels-per-inch-y* y))


;;;; ---------------------------------------------------------------------- ;;;;
;;; The functions for ACT-R 6

(defun current-device-interface ()
  "Return the device-interface for current model in the current meta-process"
  (values (get-module :device)))

(defun install-device (device)
  "Set the device with which a model will interact"
  (verify-current-mp  
   "install-device called with no current meta-process."
   (verify-current-model
    "install-device called with no current model."
    (setf (device (current-device-interface)) device))))

(defun current-device ()
  "Return the device for the current model in the current meta-process"
  (verify-current-mp  
   "current-device called with no current meta-process."
   (verify-current-model
    "current-device called with no current model."
    (device (current-device-interface)))))

(defun proc-display (&key clear)
  "Processes the current display."
  (verify-current-mp  
   "proc-display called with no current meta-process."
   (verify-current-model
    "proc-display called with no current model."
    (if (current-device-interface)
        (process-display (current-device-interface) (get-module :vision) clear)
      (print-warning "No device interface available to process")))))


;;;; ---------------------------------------------------------------------- ;;;;
;;; roll in everything that was in "environment-interface"

(defvar *actr-enabled-p* t)


;;;; ---------------------------------------------------------------------- ;;;;
;;;; Move these here

(defun pm-pixels-to-angle (pixels)
  "Convert <pixels> to degress of visual angle."
  (pixels->angle-mth (current-device-interface) pixels))


(defun pm-angle-to-pixels (angle)
  "Convert visual <angle> in degress to pixels."
  (angle->pixels-mth (current-device-interface) angle))


;;;; ---------------------------------------------------------------------- ;;;;
;;;; Base DEVICE-INTERFACE class and some quicky methods.

(defclass device-interface ()
  ((pixels-per-inch :accessor ppi :initarg :ppi
                    :initform (/ (+ *pixels-per-inch-x* 
                                    *pixels-per-inch-y*) 2.0))
   (viewing-distance :accessor viewing-distance :initform 15.0)
   (device :accessor device :initform nil)
   (key-closure-time :accessor key-closure-time :initform 0.010)
   (microphone-delay :accessor microphone-delay :initform 0.100)
   (keyboard :accessor keyboard :initform (make-instance 'virtual-keyboard))
   (with-cursor-p :accessor with-cursor-p :initform nil)
   (input-q :accessor input-q :initform nil)
   (device-hook :accessor device-hook :initform nil)
   (mouse-fitts-coeff :accessor mouse-fitts-coeff :initform 0.1)
   (show-focus-p :accessor show-focus-p :initarg :show-focus-p :initform nil)
   (trace-mouse-p :accessor trace-mouse-p :initarg :trace-mouse-p :initform nil)
   (mouse-trace :accessor mouse-trace :initarg :mouse-trace :initform nil)
   (needs-mouse-p :accessor needs-mouse-p :initarg :needs-mouse-p :initform t)
   (true-cursor-loc :accessor true-cursor-loc :initarg :true-cursor-loc
                    :initform #(0 0))
   (locks :accessor locks :initform 0)
   (pending-procs :accessor pending-procs :initform nil)
   (virtual-trace :accessor virtual-trace :initform nil)
   (version-string :accessor version-string :initarg :version-string 
                   :initform "1.1")
   ))


(defmethod my-name ((mod device-interface))
  :DEVICE)

(defgeneric angle->pixels-mth (devin angle)
  (:documentation  "Determine the number of pixels subtending a visual angle."))

(defmethod angle->pixels-mth ((devin device-interface) (angle number))
  (round (* (* (viewing-distance devin) (tan (deg->rad angle))) 
            (ppi devin))))


(defgeneric pixels->angle-mth (devin pixels)
  (:documentation  "Determine the amount of visual angle subtended by <pixels>."))

(defmethod pixels->angle-mth ((devin device-interface) (pixels number))
  (rad->deg (atan (/ (/ pixels (ppi devin)) (viewing-distance devin)))))


(defgeneric find-viewing-dist-mth (devin angle pixels)
  (:documentation  "Given the number of pixels an angle subtends, what's the viewing distance?"))

(defmethod find-viewing-dist-mth ((devin device-interface) angle pixels)
  (floor 
   (/ pixels (* (tan (deg->rad angle)) (ppi devin)))))





;;;; ---------------------------------------------------------------------- ;;;;
;;;; Interacting with the Master Process


(defmethod reset-device ((devin device-interface))
  (setf (input-q devin) nil)
  (setf (mouse-trace devin) nil)
  (setf (locks devin) 0)
  (setf (pending-procs devin) nil))

(defgeneric update-device (devin time)
  (:documentation  "Update the device at <time>."))

;;; the default method has to do the following:
;;; [1] Update the attentional focus
;;; [2] Call the device hook
;;; [3] Make sure the cursor synch is maintained
;;; [4] Call the device update method

(defmethod update-device ((devin device-interface) time)
  (let ((vis-m (get-module :vision)))
    (when (and (show-focus-p devin)
               vis-m 
               (current-marker vis-m))
      (device-update-attended-loc (device devin) 
                                  (dmo-to-xy (current-marker vis-m )))))
  (awhen (device-hook devin)
         (funcall it time))
  (synch-mouse devin)
  (device-update (device devin) time))


(defgeneric device-update-attended-loc (device xyloc)
  (:documentation  "Tell the device to update the attended location, which is passed in."))

(defmethod device-update-attended-loc (device xyloc)
  (declare (ignore device xyloc))
  nil)


(defgeneric device-update (device time)
  (:documentation  "Update the device at <time>.  A method should be defined for this if the device is dynamic."))

(defmethod device-update (device time)
  (declare (ignore device time))
  nil)


;;;; ---------------------------------------------------------------------- ;;;;
;;;; Module interface functions


(defun update-device-module (device old-time new-time)
  "Call the device's update-device method with the new time"
  (declare (ignore old-time))
  (update-device device new-time))


(defun params-device-module (device param)
  (if (consp param)
    (case (car param)
     (:pixels-per-inch
       (setf (ppi device) (cdr param)))
      (:process-cursor
       (setf (with-cursor-p device) (cdr param)))
      (:show-focus
       (setf (show-focus-p device) (cdr param))) 
      (:viewing-distance
       (setf (viewing-distance device) (cdr param)))
      
      (:mouse-fitts-coeff
       (setf (mouse-fitts-coeff device) (cdr param)))
      
      (:needs-mouse
       (setf (needs-mouse-p device) (cdr param)))
      (:vwt
       (setf (virtual-trace device) (cdr param)))
      )
    (case param
     (:pixels-per-inch
      (ppi device))
      (:process-cursor
       (with-cursor-p device))
      (:show-focus
       (show-focus-p device)) 
      (:viewing-distance
       (viewing-distance device))
      (:mouse-fitts-coeff
       (mouse-fitts-coeff device))
      (:needs-mouse
       (needs-mouse-p device))
      (:vwt
       (virtual-trace device))
      )))

;;;; ---------------------------------------------------------------------- ;;;;
;;;; Module definition

(define-module-fct :device
    nil
  (list 
   ;; From vision
   (define-parameter :pixels-per-inch
     :valid-test #'posnum 
     :default-value 72.0
     :warning "a non-negative number"
     :documentation "Pixels per inch of display")
   (define-parameter :process-cursor
     :valid-test #'tornil 
     :default-value nil
     :warning "T or NIL"
     :documentation "Should there be a visicon feature for the cursor?")
   (define-parameter :show-focus
     :valid-test #'tornil 
     :default-value nil
     :warning "T or NIL"
     :documentation "Show the focus ring on the GUI?")
   (define-parameter :viewing-distance
     :valid-test #'posnum 
     :default-value 15.0
     :warning "a non-negative number"
     :documentation "Distance of the eyes from the display, in inches.")
   
   ;; From motor
   
   (define-parameter :mouse-fitts-coeff
     :valid-test #'nonneg 
     :default-value 0.1
     :warning "a non-negative number"
     :documentation "b coefficient in Fitts's equation for aimed movements.")
   (define-parameter :needs-mouse
     :valid-test #'tornil 
     :default-value t
     :warning "T or NIL"
     :documentation "Does ACT-R control the mouse?")
   
   ;; New general parameter
   
   (define-parameter :vwt
     :valid-test #'tornil 
     :default-value nil
     :warning "T or NIL"
     :documentation "Virtual Window trace controls the << ... >> outputs from virtual windows")
   
   
   )
  :version "1.1"
  :documentation "The device interface for a model"
  :creation #'(lambda (x)
                (declare (ignore x))
                (make-instance 'device-interface))
  :reset #'reset-device
  :params #'params-device-module
  :update #'update-device-module)



;;;; ---------------------------------------------------------------------- ;;;;
;;;; Proc screen stuff

;;; PROCESS-DISPLAY      [Method]
;;; Description : Replacement for old PROC-SCREEN functionality.  A few things
;;;             : have to be done to process the display.  First, make sure
;;;             : a display is attached.  Then, set up the previous icon.
;;;             : This is NIL if we're clearing the display.  Then, ask the
;;;             : device for a new icon.  Then check the new icon against the
;;;             : old one so we don't lose state information.  Update the
;;;             : attended location, make sure everyone is current on the
;;;             : mouse location.  Return the length of the icon, since ya
;;;             : gotta return something.

(defgeneric process-display (devin vis-mod &optional clear)
  (:documentation  "Rebuild the Vision Module's icon based on the current display."))

(defgeneric synch-mouse (devin)
  (:documentation  "Make sure everyone agress on the current cursor position."))

(defmethod synch-mouse ((devin device-interface))
  (when (and (device devin)
             (needs-mouse-p devin)
             (not (vpt= (true-cursor-loc devin)
                        (get-mouse-coordinates (device devin)))))
    (device-move-cursor-to (device devin) (true-cursor-loc devin)))
  (let ((vis-m (get-module :vision)))
    (when vis-m
      (update-cursor-feat devin vis-m))))


(defgeneric update-cursor-feat (devin vis-mod)
  (:documentation  "Updates the feature in the icon with the current cursor position."))

(defgeneric key->cmd (devin key)
  (:documentation  "Given a key, return the appropriate Motor Module command to type it."))

(defmethod key->cmd ((devin device-interface) key)
  (key-to-command (keyboard devin) key))


;;; Generic methods which will need to be overridden for specific devices.
;;; These are defined for MCL windows.

(defgeneric get-mouse-coordinates (device)
  (:documentation  "Return the mouse coordinates in #(x y) form."))

(defmethod get-mouse-coordinates (device)
  (error "No method defined for GET-MOUSE-COORDINATES on object ~S." device))

(defgeneric build-features-for (obj vis-mod)
  (:documentation  "Return a list of icon-features for an object."))

(defmethod build-features-for (obj vis-mod)
  (declare (ignore vis-mod))
  (error "No method defined for BUILD-FEATURES-FOR on object ~S." obj))

(defgeneric cursor-to-feature (device)
  (:documentation  "Reaturn an icon feature reprsenting the current cursor."))

(defmethod cursor-to-feature (device)
  (error "No method definded for CURSOR-TO-FEATURE on object ~S." device))  


;;;; ---------------------------------------------------------------------- ;;;;
;;;; Output functions:  mouse movements, keypress stuff.


(defgeneric output-key (devin keyloc)
  (:documentation  "Request that the device register a key output for the key at a given location."))

(defmethod output-key ((devin device-interface) (keyloc vector))
  (let* ((invalid (or (< (svref keyloc 1) 0)
                      (> (svref keyloc 1) 6)
                      (< (svref keyloc 0) 0)
                      (and (> (svref keyloc 0) 22)
                           (not (= (svref keyloc 0) 28)))))
         (the-key (if invalid nil (loc->key (keyboard devin) keyloc))))
    (if (eq the-key 'mouse)
        (device-handle-click (device devin))
      (progn 
        (when (null the-key)
          (print-warning "Invalid key location pressed ~s" keyloc))
        (device-handle-keypress (device devin) the-key)))))


(defgeneric output-speech (devin text)
  (:documentation  "Requests that the device output the provided text as speech."))

(defmethod output-speech ((devin device-interface) (text string))
  (device-speak-string (device devin) text))


(defgeneric move-cursor-absolute (devin xyloc)
  (:documentation  "Request that the device move the cursor to the absolute location <xyloc>."))

(defmethod move-cursor-absolute ((devin device-interface) xyloc)
  (when (trace-mouse-p devin)
    (push (cons (mp-time) xyloc) (mouse-trace devin)))
  (device-move-cursor-to (device devin) xyloc)
  (setf (true-cursor-loc devin) xyloc)
  (synch-mouse devin))


(defgeneric move-cursor-polar (devin rtheta)
  (:documentation  "Request that the device move the cursor by <r> in direction <theta>."))

(defmethod move-cursor-polar ((devin device-interface) rtheta)
  (let ((newloc (polar-move-xy (get-mouse-coordinates (device devin)) rtheta)))
    (device-move-cursor-to (device devin) newloc)
    (setf (true-cursor-loc devin) newloc))
  (synch-mouse devin))


(defgeneric output-click (devin)
  (:documentation  "Output a mouse click to the device."))

(defmethod output-click ((devin device-interface))
  (device-handle-click (device devin)))


;;; Generic methods which will need to be overridden for specific devices.
;;; These are defined for MCL windows.

(defgeneric device-handle-keypress (device key)
  (:documentation  "Handle the press of the given key."))

(defmethod device-handle-keypress (device key)
  (declare (ignore key))
  (error "No method defined for DEVICE-HANDLE-KEYPRESS for object ~S." device))

(defgeneric device-move-cursor-to (device xyloc)
  (:documentation  "Move the cursor to a specified location."))

(defmethod device-move-cursor-to (device xyloc)
  (declare (ignore xyloc))
  (error "No method defined for DEVICE-MOVE-CURSOR-TO for object ~S." device))

(defgeneric device-handle-click (device)
  (:documentation  "Handle a click request."))

(defmethod device-handle-click (device)
  (error "No method defined for DEVICE-HANDLE-CLICK for object ~S." device))

(defgeneric device-speak-string (device string)
  (:documentation  "Handle a speech request."))

(defmethod device-speak-string (device string)
  (declare (ignore string))
  (error "No method defined for DEVICE-SPEAK-STRING for object ~S.") device)


;;;; ---------------------------------------------------------------------- ;;;;
;;;; The virtual keyboard.  Override one or more of these methods to 
;;;; represent different keyboards.

(defclass virtual-keyboard ()
   ((key->cmd-ht :accessor key->cmd-ht 
                  :initform (make-hash-table :test #'equal))
    (key->loc-ht :accessor key->loc-ht
                  :initform (make-hash-table :test #'equal))
    (loc->key-array :accessor loc->key-arr 
                     :initform (make-array '(23 7) :initial-element nil))))


(defmethod initialize-instance :after ((vk virtual-keyboard) &key)
  (populate-key-to-command-ht (key->cmd-ht vk))
  (populate-key-to-loc-ht (key->loc-ht vk))
  (populate-loc-to-key-array (loc->key-arr vk)))


;;; LOC-TO-KEY      [Method]
;;; Description : Given a location, return the corresponding character.
;;;             : Accessed via the 'virtual keyboard' array.

(defgeneric loc->key (vk loc)
  (:documentation  "Given an location, return the corresponding key"))

(defmethod loc->key ((vk virtual-keyboard) (loc vector))
  (if (vpt= loc #(28 2))
    'mouse
    (aref (loc->key-arr vk) (px loc) (py loc))))


(defgeneric key-to-command (vk key)
  (:documentation  "Given a key, return the appropriate command."))

(defmethod key-to-command ((vk virtual-keyboard) key)
  (gethash key (key->cmd-ht vk)))


(defmethod key-to-loc ((vk virtual-keyboard) key)
  (gethash key (key->loc-ht vk)))


(defgeneric populate-key-to-command-ht (ht)
  (:documentation  "Populates the hash table that maps keys to motor commands"))

(defmethod populate-key-to-command-ht ((ht hash-table))
  (setf (gethash 'space ht) '(punch :hand left :finger thumb))
  (setf (gethash 'backquote ht) 
        '(peck-recoil :hand left :finger pinkie :r 2.24 :theta -2.03))
  (setf (gethash 'tab ht) 
        '(peck-recoil :hand left :finger pinkie :r 1.41 :theta -2.36))
  (setf (gethash '1 ht) 
        '(peck-recoil :hand left :finger pinkie :r 2 :theta -1.57))
  (setf (gethash 'Q ht) 
        '(peck-recoil :hand left :finger pinkie :r 1 :theta -1.57))
  (setf (gethash 'A ht) '(punch :hand left :finger pinkie))
  (setf (gethash 'Z ht) 
        '(peck-recoil :hand left :finger pinkie :r 1 :theta 1.57))
  (setf (gethash '2 ht) 
        '(peck-recoil :hand left :finger ring :r 2 :theta -1.57))
  (setf (gethash 'W ht) 
        '(peck-recoil :hand left :finger ring :r 1 :theta -1.57))
  (setf (gethash 'S ht) 
        '(punch :hand left :finger ring))
  (setf (gethash 'X ht) 
        '(peck-recoil :hand left :finger ring :r 1 :theta 1.57))
  (setf (gethash '3 ht) 
        '(peck-recoil :hand left :finger middle :r 2 :theta -1.57))
  (setf (gethash 'E ht) 
        '(peck-recoil :hand left :finger middle :r 1 :theta -1.57))
  (setf (gethash 'D ht) '(punch :hand left :finger middle))
  (setf (gethash 'C ht) 
        '(peck-recoil :hand left :finger middle :r 1 :theta 1.57))
  (setf (gethash '4 ht) 
        '(peck-recoil :hand left :finger index :r 2 :theta -1.57))
  (setf (gethash 'R ht) 
        '(peck-recoil :hand left :finger index :r 1 :theta -1.57))
  (setf (gethash 'F ht) '(punch :hand left :finger index))
  (setf (gethash 'V ht) 
        '(peck-recoil :hand left :finger index :r 1 :theta 1.57))
  (setf (gethash '5 ht) 
        '(peck-recoil :hand left :finger index :r 2.24 :theta -1.11))
  (setf (gethash 'T ht) 
        '(peck-recoil :hand left :finger index :r 1.41 :theta -0.79))
  (setf (gethash 'G ht) 
        '(peck-recoil :hand left :finger index :r 1 :theta 0))
  (setf (gethash 'B ht) 
        '(peck-recoil :hand left :finger index :r 1.41 :theta 0.79))
  (setf (gethash '6 ht) 
        '(peck-recoil :hand right :finger index :r 2.24 :theta -2.03))
  (setf (gethash 'Y ht) 
        '(peck-recoil :hand right :finger index :r 1.41 :theta -2.36))
  (setf (gethash 'H ht) 
        '(peck-recoil :hand right :finger index :r 1 :theta 3.14))
  (setf (gethash 'N ht) 
        '(peck-recoil :hand right :finger index :r 1.41 :theta 2.36))
  (setf (gethash '7 ht) 
        '(peck-recoil :hand right :finger index :r 2 :theta -1.57))
  (setf (gethash 'U ht) 
        '(peck-recoil :hand right :finger index :r 1 :theta -1.57))
  (setf (gethash 'J ht) 
        '(punch :hand right :finger index))
  (setf (gethash 'M ht) 
        '(peck-recoil :hand right :finger index :r 1 :theta 1.57))
  (setf (gethash '8 ht) 
        '(peck-recoil :hand right :finger middle :r 2 :theta -1.57))
  (setf (gethash 'I ht) 
        '(peck-recoil :hand right :finger middle :r 1 :theta -1.57))
  (setf (gethash 'K ht) '(punch :hand right :finger middle))
  (setf (gethash 'comma ht) 
        '(peck-recoil :hand right :finger middle :r 1 :theta 1.57))
  (setf (gethash '9 ht) 
        '(peck-recoil :hand right :finger ring :r 2 :theta -1.57))
  (setf (gethash 'O ht) 
        '(peck-recoil :hand right :finger ring :r 1 :theta -1.57))
  (setf (gethash 'L ht) 
        '(punch :hand right :finger ring))
  (setf (gethash 'period ht) 
        '(peck-recoil :hand right :finger index :r 1 :theta 1.57))
  (setf (gethash '0 ht) 
        '(peck-recoil :hand right :finger pinkie :r 2 :theta -1.57))
  (setf (gethash 'P ht) 
        '(peck-recoil :hand right :finger pinkie :r 1 :theta -1.57))
  (setf (gethash 'semicolon ht) '(punch :hand right :finger pinkie))
  (setf (gethash 'slash ht) 
        '(peck-recoil :hand right :finger pinkie :r 1 :theta 1.57))
  (setf (gethash 'hyphen ht) 
        '(peck-recoil :hand right :finger pinkie :r 2.24 :theta -1.11))
  
  (setf (gethash '- ht) 
        '(peck-recoil :hand right :finger pinkie :r 2.24 :theta -1.11))
  
  (setf (gethash '[ ht) 
        '(peck-recoil :hand right :finger pinkie :r 1.41 :theta -0.78))
  (setf (gethash 'quote ht) 
        '(peck-recoil :hand right :finger pinkie :r 1 :theta 0))
  (setf (gethash 'return ht) 
        '(peck-recoil :hand right :finger pinkie :r 2 :theta 0))
  ht
  )

(defgeneric populate-key-to-loc-ht (ht)
  (:documentation  "Build a hash table mapping keys to locations."))

(defmethod populate-key-to-loc-ht ((ht hash-table))
  ;; function key row
  (setf (gethash 'escape ht) #(0 0))
  (setf (gethash 'F1 ht) #(2 0))
  (setf (gethash 'F2 ht) #(3 0))
  (setf (gethash 'F3 ht) #(4 0))
  (setf (gethash 'F4 ht) #(5 0))
  (setf (gethash 'F5 ht) #(7 0))
  (setf (gethash 'F6 ht) #(8 0))
  (setf (gethash 'F7 ht) #(9 0))
  (setf (gethash 'F8 ht) #(10 0))
  (setf (gethash 'F9 ht) #(12 0))
  (setf (gethash 'F10 ht) #(13 0))
  (setf (gethash 'F11 ht) #(14 0))
  (setf (gethash 'F12 ht) #(15 0))
  (setf (gethash 'F13 ht) #(17 0))
  (setf (gethash 'F14 ht) #(18 0))
  (setf (gethash 'F15 ht) #(19 0))
  ;; numeric key row
  (setf (gethash 'backquote ht) #(0 2))
  (setf (gethash 1 ht) #(1 2))
  (setf (gethash 2 ht) #(2 2))
  (setf (gethash 3 ht) #(3 2))
  (setf (gethash 4 ht) #(4 2))
  (setf (gethash 5 ht) #(5 2))
  (setf (gethash 6 ht) #(6 2))
  (setf (gethash 7 ht) #(7 2))
  (setf (gethash 8 ht) #(8 2))
  (setf (gethash 9 ht) #(9 2))
  (setf (gethash 0 ht) #(10 2))
  (setf (gethash '- ht) #(11 2))
  (setf (gethash 'hyphen ht) #(11 2))
  (setf (gethash '= ht) #(12 2))
  (setf (gethash 'delete ht) #(13 2))
  (setf (gethash 'help ht) #(15 2))
  (setf (gethash 'home ht) #(16 2))
  (setf (gethash 'pageup ht) #(17 2))
  (setf (gethash 'clear ht) #(19 2))
  (setf (gethash '= ht) #(20 2))
  (setf (gethash '/ ht) #(21 2))
  (setf (gethash '* ht) #(22 2))
  ;; QWERTY row
  (setf (gethash 'tab ht) #(0 3))
  (setf (gethash 'Q ht) #(1 3))
  (setf (gethash 'W ht) #(2 3))
  (setf (gethash 'E ht) #(3 3))
  (setf (gethash 'R ht) #(4 3))
  (setf (gethash 'T ht) #(5 3))
  (setf (gethash 'Y ht) #(6 3))
  (setf (gethash 'U ht) #(7 3))
  (setf (gethash 'I ht) #(8 3))
  (setf (gethash 'O ht) #(9 3))
  (setf (gethash 'P ht) #(10 3))
  (setf (gethash '[ ht) #(11 3))
  (setf (gethash '] ht) #(12 3))
  (setf (gethash 'backslash  ht) #(13 3))
  (setf (gethash 'forward-delete ht) #(15 3))
  (setf (gethash 'end ht) #(16 3))
  (setf (gethash 'page-up ht) #(17 3))
  (setf (gethash 'keypad-7 ht) #(19 3))
  (setf (gethash 'keypad-8 ht) #(20 3))
  (setf (gethash 'keypad-9 ht) #(21 3))
  (setf (gethash 'keypad-hyphen ht) #(22 3))
  ;; "A" row
  (setf (gethash 'caps-lock ht) #(0 4))
  (setf (gethash 'A ht) #(1 4))
  (setf (gethash 'S ht) #(2 4))
  (setf (gethash 'D ht) #(3 4))
  (setf (gethash 'F ht) #(4 4))
  (setf (gethash 'G ht) #(5 4))
  (setf (gethash 'H ht) #(6 4))
  (setf (gethash 'J ht) #(7 4))
  (setf (gethash 'K ht) #(8 4))
  (setf (gethash 'L ht) #(9 4))
  (setf (gethash 'semicolon ht) #(10 4))
  (setf (gethash 'quote ht) #(11 4))
  (setf (gethash 'return ht) #(12 4))
  (setf (gethash 'keypad-4 ht) #(19 4))
  (setf (gethash 'keypad-5 ht) #(20 4))
  (setf (gethash 'keypad-6 ht) #(21 4))
  (setf (gethash 'keypad-plus ht) #(22 4))
  ;; "Z" row
  (setf (gethash 'shift ht) #(0 5))
  (setf (gethash 'Z ht) #(1 5))
  (setf (gethash 'X ht) #(2 5))
  (setf (gethash 'C ht) #(3 5))
  (setf (gethash 'V ht) #(4 5))
  (setf (gethash 'B ht) #(5 5))
  (setf (gethash 'N ht) #(6 5))
  (setf (gethash 'M ht) #(7 5))
  (setf (gethash 'comma ht) #(8 5))
  (setf (gethash 'period ht) #(9 5))
  (setf (gethash 'dot  ht) #(9 5))
  (setf (gethash '/ ht) #(10 5))
  (setf (gethash 'right-shift ht) #(11 5))
  (setf (gethash 'up-arrow ht) #(16 5))
  (setf (gethash 'keypad-1 ht) #(19 5))
  (setf (gethash 'keypad-2 ht) #(20 5))
  (setf (gethash 'keypad-3 ht) #(21 5))
  (setf (gethash 'keypad-enter ht) #(22 5))
  ;; space bar row
  (setf (gethash 'left-control ht) #(0 6))
  (setf (gethash 'left-option ht) #(1 6))
  (setf (gethash 'left-command ht) #(2 6))
  (setf (gethash 'spc ht) #(3 6))
  (setf (gethash 'spc ht) #(4 6))
  (setf (gethash 'spc ht) #(5 6))
  (setf (gethash 'spc ht) #(6 6))
  (setf (gethash 'spc ht) #(7 6))
  (setf (gethash 'spc ht) #(8 6))
  (setf (gethash 'spc ht) #(9 6))
  (setf (gethash 'spc ht) #(10 6))
  (setf (gethash 'right-command ht) #(11 6))
  (setf (gethash 'right-option ht) #(12 6))
  (setf (gethash 'right-control ht) #(13 6))
  (setf (gethash 'left-arrow ht) #(15 6))
  (setf (gethash 'down-arrow ht) #(16 6))
  (setf (gethash 'right-arrow ht) #(17 6))
  (setf (gethash 'keypad-0 ht) #(19 6))
  (setf (gethash 'keypad-period ht) #(21 6))
  (setf (gethash 'enter ht) #(22 6))
  ht)


;;;; ---------------------------------------------------------------------- ;;;;
;;;; various toplevel commands, mostly for backward compatibility

  

(defmethod lock-device ((devin device-interface))
  "Place a lock on proc-display to prevent it from actually occuring"
  (incf (locks devin)))

(defmethod unlock-device ((devin device-interface))
  "Remove one of the locks from proc-display and run it now if all locks are
   removed and there were any blocked calls"
  (unless (zerop (locks devin))
    (decf (locks devin)))
  
  ;; Check for tracking first
  
  (when (and (zerop (locks devin)) (find :tracking (pending-procs devin)))
    (update-tracking)
    (setf (pending-procs devin) (remove :tracking (pending-procs devin))))
  
  
  (when (and (zerop (locks devin)) (pending-procs devin))
    (proc-display  :clear (some #'identity (pending-procs devin)))
    (setf (pending-procs devin) nil)))


#|
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/commands/dm-commands.lisp
;;;============================================================================

;;;  -*- mode: LISP; Syntax: COMMON-LISP;  Base: 10 -*-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 
;;; Author      : Dan Bothell
;;; Copyright   : (c) 2005 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    : dm-commands.lisp
;;; Version     : 1.0a3
;;; 
;;; Description : ACT-R commands relavent to Declarative Memory
;;; 
;;; Bugs        : 
;;;
;;; To do       : Fix issues with merged-copies not showing up as being in DM.
;;; 
;;; ----- History -----
;;;
;;; 2005.01.11 Dan
;;;             : Created this file to hold stuff that was in declarative-
;;;             : memory in core-modules.
;;; 2005.01.17 Dan
;;;             : * Updated dm and sdm to use pprint-chunks-fct instead of
;;;             :   the now non-existent pprint-chunk-fct.
;;;             : * Fixed dm and sdm so that they don't print anything in the
;;;             :   case that there are no chunks to print instead of all 
;;;             :   existing chunks.
;;; 2005.01.18 Dan
;;;             : * Added more of the ACT-R 5 commands.
;;; 2005.01.21 Dan
;;;             : * Changed references to dm-chunks to reflect the change to
;;;             :   the new representation as a hash table by chunk-type.
;;; 2005.01.26 Dan
;;;             : * Added sdp functionality.
;;;             : * Removed calls with "old" names and moved them to
;;;             :   backward.lips in support.
;;; 2005.01.31 Dan
;;;             : * Fixed dm so that it only prints chunks from DM even when
;;;             :   names are provided.
;;; 2005.05.06 Dan
;;;             : * Fixed a bug in add-sji-fct where it called chunk-p instead
;;;             :   of chunk-p-fct.
;;; 2005.06.10 Dan
;;;             : * Changed chunk-parameters so that the references returned
;;;             :   is sensitive to the current setting of :ol i.e. it hides
;;;             :   the reference list when :ol is t and truncates it to the
;;;             :   appropriate size when :ol is a number.
;;; 2005.06.15 Dan
;;;             : * Updated the dm command so that chunks which have merged
;;;             :   into dm still print out if asked for, but it doesn't
;;;             :   show all merged names if called with no parameters.
;;; 2005.07.06 Dan
;;;             : * Changed sdm so that the isa isn't required.
;;; 2005.07.29 Dan
;;;             : * Fixed sdp so that it only works for chunks that are actually
;;;             :   in DM.
;;; 2005.08.01 Dan
;;;             : * Fixed an issue with BLC in the main module file that
;;;             :   reflects on the usage of sdp here.  Basically, BLC is added
;;;             :   to all base-level calculations, but no values are stored
;;;             :   in the chunk-base-level other than user settings.
;;; 2005.08.03 Dan
;;;             : * Added the print-dm-finsts command.
;;; 2005.09.15 Dan
;;;             : * Cleaned up sdm so that it checks the chunk-type and prints
;;;             :   a reasonable warning when an invalid chunk-type is given.
;;; 2006.06.20 Dan
;;;             : * Fixed a bug in set-base-level that lead to an error if 
;;;             :   :ol was nil and a creation time wasn't provided for a chunk.
;;; 2006.07.10 Dan
;;;             : * Changed call to true-chunk-name to true-chunk-name-fct since
;;;             :   that's being moved to a macro/-fct for user's access.
;;; 2006.11.29 Dan
;;;             : * Removed use of dm-pm and replaced it with dm-mp because the
;;;             :   :pm parameter is being depricated and :mp is both the flag
;;;             :   and value now like :bll and :mas.
;;;             : * Changed a warning in sdm to be a little clearer.
;;; 2006.11.30 Dan
;;;             : * Fixed add-sji-fct so that it removes an older setting
;;;             :   when adding a new one.
;;;             : * Changed clear-dm so that it returns t if the chunks were
;;;             :   cleared and nil if not.
;;;             : * Fixed clear-dm so that it also clears the merge table.
;;; 2006.12.01 Dan
;;;             : * Renamed the internal function set-base-level to set-bl
;;;             :   to avoid any issues with the user function set-base-levels.
;;;             : * Updates to sdp to better handle base-level reporting.
;;; 2006.12.05 Dan
;;;             : * Modified sdp to use the chunk-last-base-level parameter
;;;             :   setting instead of calling for a recomputation of the
;;;             :   base-level.
;;;             : * Modified the base-level setting code (set-base-levels and 
;;;             :   set-all-base-levels) so that when :ol is a number the
;;;             :   appropriate number of references are created.
;;;             : * Fixed set-base-levels and set-all-base-levels so that they
;;;             :   now return the base-level activations.
;;; 2006.12.06 Dan
;;;             : * Changed set-all-base-levels to return t/nil because if a
;;;             :   creation time isn't specified there's no particular base-level 
;;;             :   that's meaningful to return - they could all be different.
;;;             : * Added tests in set-base-levels-fct and set-all-base-levels
;;;             :   to make sure that the level and creation-time are numbers.
;;;             : * Turn off the activation trace when updating activations in sdp.
;;; 2006.12.07 Dan
;;;             : * Added the new sdp parameters :reference-list, :reference-count,
;;;             :   :retrieval-activation and :retrieval-time.  The first two of
;;;             :   those effectively make :references unnecessary and it will
;;;             :   no longer be shown (and shouldn't be used now either).
;;; 2006.12.08 Dan
;;;             : * Cleaned up the return values of sjis and similarities in sdp
;;;             :   so "default" values are returned in addition to user settings.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; 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)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 
;;; The user functions from previous versions


(defmacro add-sji (&rest settings)
  "Macro to add an sji value between chunks"
  `(add-sji-fct ',settings))

(defun add-sji-fct (settings)
  "Function to add an sji value between chunks"
  (let ((returns nil))
    (dolist (x settings (reverse returns))
      (if (and (listp x)
               (= (length x) 3)
               (chunk-p-fct (first x))
               (chunk-p-fct (second x))
               (numberp (third x)))
          (let ((sji (third x))
                (chunk-i (second x))
                (chunk-j (first x)))
            (push sji returns)
            (setf (chunk-sjis chunk-i) (remove chunk-j (chunk-sjis chunk-i) :key #'car))
            (push (cons chunk-j sji) (chunk-sjis chunk-i)))
        (progn
          (print-warning "Bad Sji setting in ~S" x)
          (push :error returns))))))


(defmacro sji (chunkj chunki)
  "Macro to return the current Sji value between chunkj and chunki"
  `(sji-fct ',chunkj ',chunki))

(defun sji-fct (chunkj chunki)
  "Function to return current Sji value between chunkj and chunki"
  (let ((dm (get-module declarative)))
    (if dm
        (compute-sji dm chunkj chunki)
      (print-warning "No declarative memory module found"))))


(defmacro similarity (chunkj chunki)
  "Macro to return the current similarity value between chunkj and chunki"
  `(similarity-fct ',chunkj ',chunki))

(defun similarity-fct (chunkj chunki)
  "Function to return current similarity value between chunkj and chunki"
  (let ((dm (get-module declarative)))
    (if dm
        (chunks-similarity dm chunkj chunki)
      (print-warning "No declarative memory module found"))))


(defun clear-dm ()
  "User function to clear declarative memory - not recommended"
  (let ((dm (get-module declarative)))
    (if dm
        (progn
          (clrhash (dm-chunks dm))
          (clrhash (dm-chunk-hash-table dm))
          (print-warning "All the chunks cleared from DM.")
          t)
      (print-warning "No declarative memory module found"))))


(defmacro dm (&rest chunks)
  "Macro to print and return chunks in declarative memory"
  `(dm-fct ',chunks))

(defun dm-fct (chunk-list)
  "Function to print and return chunks in declarative memory"
    (let ((dm (get-module declarative)))
    (if dm
        (if chunk-list
            (let ((c-l (remove-if-not 
                       #'(lambda (x)
                           (member (true-chunk-name-fct x)
                                   (all-dm-chunks dm)))
                       chunk-list)))
              (when c-l
                (pprint-chunks-fct c-l)))
          (when (hash-table-keys (dm-chunks dm))
            (pprint-chunks-fct (all-dm-chunks dm))))
      (print-warning "No declarative memory module found"))))
   
   
(defmacro get-base-level (&rest chunks)
  "Macro to return the base-level activation of a chunk in dm"
  `(get-base-level-fct ',chunks))

(defun get-base-level-fct (chunks)
  "Function to return the base-level activation of a chunk in dm"
  (let ((dm (get-module declarative))
        (returns nil))
    (if dm
        (let ((dm-chunks (all-dm-chunks dm)))
          (dolist (chunk chunks (reverse returns))
            (if (member chunk dm-chunks)
              (push (base-level-activation dm chunk) returns)
            (push :error returns))))
      (print-warning "No declarative memory module found"))))
      

(defmacro sdm (&rest spec)
  "Macro to search for and print chunks in declarative memory"
  `(sdm-fct ',spec))

(defun sdm-fct (spec)
  "Function to search for and print chunks in declarative memory"
  (let ((dm (get-module declarative)))
    (if dm
        (cond ((null spec) (dm))
              ((eq (car spec) 'isa)
               (if (chunk-type-p-fct (second spec))
                   (let* ((chunk-spec (define-chunk-spec-fct spec))
                          (chunks (find-matching-chunks 
                                   chunk-spec
                                   :chunks (apply #'append 
                                                  (mapcar #'(lambda (x)
                                                              (gethash 
                                                               x 
                                                               (dm-chunks dm)))
                                                    (chunk-type-subtypes-fct 
                                                     (chunk-spec-chunk-type 
                                                      chunk-spec)))))))
                     (when chunks
                       (pprint-chunks-fct chunks)))
                 (model-warning "Invalid chunk-type ~S passed to sdm" (second spec))))
               
              (t
               (if (evenp (length spec))
                   (let ((slot-names)
                         (valid-chunk-types))
                     (dotimes (i (/ (length spec) 2))
                       (push (nth (* i 2) spec) slot-names))
                     (dolist (ct (no-output (chunk-type)))
                       (when (every #'(lambda (x)
                                        (find x (chunk-type-slot-names-fct ct)))
                                    slot-names)
                         (push ct valid-chunk-types)))
                     (dolist (ct valid-chunk-types)
                       (let* ((chunk-spec (define-chunk-spec-fct (append (list 'isa ct) spec)))
                              (chunks (find-matching-chunks 
                                       chunk-spec
                                       :chunks (gethash ct (dm-chunks dm)))))
                         (when chunks
                           (pprint-chunks-fct chunks)))))
                 (model-warning "Specification list to sdm without an isa is not an even length"))))
              
      (print-warning "No declarative memory module found"))))

(defmacro set-similarities (&rest settings)
  "Macro to set the similarity value between chunks"
  `(set-similarities-fct ',settings))

(defun set-similarities-fct (settings)
  "Function to set the similarity value between chunks"
  (let ((returns nil))
    (dolist (x settings (reverse returns))
      (if (and (listp x)
               (= (length x) 3)
               (chunk-p-fct (first x))
               (chunk-p-fct (second x))
               (numberp (third x)))
          (let ((similarity (third x))
                (chunk-i (second x))
                (chunk-j (first x)))
            (push similarity returns)
            
            (awhen (assoc chunk-j (chunk-similarities chunk-i))
                   (setf (chunk-similarities chunk-i)
                     (remove it (chunk-similarities chunk-i))))
            
            (awhen (assoc chunk-i (chunk-similarities chunk-j))
                   (setf (chunk-similarities chunk-j)
                     (remove it (chunk-similarities chunk-j))))
            
            (push (cons chunk-j similarity) 
                  (chunk-similarities chunk-i))
            (push (cons chunk-i similarity) 
                  (chunk-similarities chunk-j))
            )
        (progn
          (print-warning "Bad similarity setting in ~S" x)
          (push :error returns))))))

(defmacro set-base-levels (&rest settings)
  "Macro to set the base-level activation of chunks"
  `(set-base-levels-fct ',settings))

(defun set-base-levels-fct (settings)
  "Function to set the base-level activation of chunks"
  (let ((base-levels nil)
        (dm (get-module declarative)))
    (if dm
        (dolist (setting settings (reverse base-levels))
          (if (and (chunk-p-fct (car setting)) (member (car setting) (all-dm-chunks dm))
                   (numberp (second setting)) (or (null (third setting)) (numberp (third setting))))
              (push (set-bl dm (car setting) (second setting) (third setting)) base-levels)
            (progn 
              (cond ((not (and (chunk-p-fct (car setting)) (member (car setting) (all-dm-chunks dm))))
                     (print-warning "~S does not name a chunk in DM." (car setting)))
                    ((not (numberp (second setting)))
                     (print-warning "Invalid level in setting ~S" setting))
                    (t    
                     (print-warning "Invalid creation-time in setting ~S" setting)))
              (push :error base-levels))))
      (print-warning "No declarative memory module found"))))
  

(defun set-all-base-levels (base-level &optional creation-time)
  "Function to set the base-level activation of all dm chunks"
  (let ((dm (get-module declarative)))
    (if dm
        (if (and (numberp base-level) (or (null creation-time) (numberp creation-time)))
            (dolist (chunk (all-dm-chunks dm) t)
              (set-bl dm chunk base-level creation-time))
          (if (numberp base-level)
              (print-warning "Invalid creation-time ~S" creation-time)
            (print-warning "Invalid level ~S" base-level)))
      (print-warning "No declarative memory module found"))))


(defun set-bl (dm chunk base-level creation-time)
  "Internal function to set the base level of a chunk"
  (when (numberp creation-time)
    (setf (chunk-creation-time chunk) creation-time))
  (cond ((dm-bll dm)
         (setf (chunk-reference-count chunk) base-level)
         (setf (chunk-reference-list chunk)
           (adapt-references dm base-level (chunk-creation-time chunk)))
         (base-level-activation dm chunk))
        (t
         (setf (chunk-base-level chunk) base-level))))

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

(defun adapt-references (dm references creation-time)
  (cond ((eq (dm-ol dm) t) nil)
        ((null (dm-ol dm))
         (even-references creation-time (mp-time) references))
        (t
         (even-references creation-time (mp-time) references (min (dm-ol dm) references)))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; SDP functionality based on ACT-R 4/5 code.
;;; May need some adjustment at some point...

(defmacro sdp (&rest settings)
  "Macro to inspect and set declarative memory's chunks' parameters."
  `(sdp-fct ',settings))


(defun sdp-fct (parameters)
  "Function to inspect and set declarative memory's chunks' parameters."
  (let ((results nil)
        (dm (get-module declarative)))
    (if dm
        (if (null parameters) ; print all parameters for all wmes
            (dolist (chunk (all-dm-chunks dm) results)
              (push-last (dm-chunk-parameters-fct dm chunk) results))
          
          (dolist (description (if (or (keywordp (first parameters))
                                       (keywordp (second parameters))
                                       (and (listp (first parameters))
                                            (null (second parameters))
                                            (not (keywordp 
                                                  (second 
                                                   (first parameters))))))
                                   (list parameters) parameters)
                               results)
            (when (atom description) (setf description (list description)))
            (if (keywordp (first description))
                (dolist (chunk (all-dm-chunks dm) results)
                  (push-last
                   (if (and (cdr description)
                            (not (keywordp (second description))))
                       (set-dm-chunk-parameters-fct dm chunk description)
                     (dm-chunk-parameters-fct dm chunk description))
                   results))
              (dolist (chunk (if (atom (first description))
                                 (list (first description))
                               (first description)))
                (if (find chunk (all-dm-chunks dm))
                    (push-last
                     (if (and (cddr description)
                              (not (keywordp (third description))))
                         (set-dm-chunk-parameters-fct dm chunk (rest description))
                       (dm-chunk-parameters-fct dm chunk (rest description)))
                     results)
                  (progn
                    ; Should it print a warning?
                    (print-warning "~S does not name a chunk in DM." chunk)
                    (push-last :error results)))))))
      
      (print-warning "No declarative memory module found"))))


(defun dm-chunk-parameters-fct (dm chunk &optional parameters)
  "Internal function to return the value of declarative chunk parameter(s), or  
   print them all if none specified."
  (let ((value nil)
        (values nil))
    (cond (chunk
           (command-output "Declarative parameters for chunk ~S:" chunk)
           
           ;;; Update activations ignoring partial matching
           ;;; by making the request spec only the chunk-type.
           ;;; also turn off the activation trace 
           
           (when (dm-esc dm)
             (let ((saved-trace (dm-act dm)))
               (setf (dm-act dm) nil)
               (compute-activation dm chunk (define-chunk-spec-fct (list 'isa (chunk-chunk-type-fct chunk))))
               (setf (dm-act dm) saved-trace)))
           
           (cond (parameters
                  (dolist (parameter parameters)
                    (setf value 
                          (case parameter
                            (:name chunk)
                            (:activation (chunk-activation chunk))
                            (:base-level (chunk-last-base-level chunk))
                            (:creation-time (chunk-creation-time chunk))
                            (:references 
                             (cond ((null (dm-ol dm))
                                    (cons (chunk-reference-count chunk)
                                          (chunk-reference-list chunk)))
                                   ((numberp (dm-ol dm))
                                    (cons (chunk-reference-count chunk)
                                          (subseq (chunk-reference-list chunk) 0 (dm-ol dm))))
                                   (t
                                    (list (chunk-reference-count chunk)))))
                                   
                            (:source-spread (chunk-source-spread chunk))
                            (:sjis (get-all-chunk-sjis dm chunk))
                            (:permanent-noise (chunk-permanent-noise chunk))
                            (:similarities (get-all-chunk-similarities dm chunk))
                            (:retrieval-activation (chunk-retrieval-activation chunk))
                            (:retrieval-time (chunk-retrieval-time chunk))
                            (:reference-count (chunk-reference-count chunk))
                            (:reference-list (chunk-reference-list chunk))
                            (t (print-warning 
                                "~A is not a declarative parameter for chunks."
                                parameter)
                               :error)))
                    (push-last value values)
                    ; ~f falls back to ~a when not a number...
                    (command-output " ~S ~6,3F" parameter value))
                  values)
                 
                 
                 (t
                  (when (dm-esc dm)
                    (command-output 
                     " :Retrieval-Activation ~6,3F~% :Retrieval-Time ~6,3F"
                     (chunk-retrieval-activation chunk) 
                     (chunk-retrieval-time chunk))
                    (command-output 
                     " :Activation ~6,3F~% :Permanent-Noise ~6,3F~% :Base-Level ~6,3F"
                     (chunk-activation chunk) 
                     (chunk-permanent-noise chunk)
                     (chunk-last-base-level chunk))
                    (when (dm-bll dm)
                      (command-output " :Creation-Time ~6,3F" (chunk-creation-time chunk))
                      (when (dm-ol dm)
                        (command-output " :Reference-Count ~6,3F" (chunk-reference-count chunk)))
                      (unless (eq t (dm-ol dm))
                        (command-output " :Reference-List ~S" (chunk-reference-list chunk))))
                    (when (dm-sa dm)
                      (command-output" :Source-Spread ~6,3F~% :Sjis ~6,3F" (chunk-source-spread chunk) (get-all-chunk-sjis dm chunk)))
                    
                    (when (dm-mp dm)
                      (command-output " :Similarities ~6,3F" (get-all-chunk-similarities dm chunk))))
                  chunk)))
          (t :error))))


(defun get-all-chunk-sjis (dm chunk)
  (let ((sjis nil)
        (js (mapcan #'(lambda (slot)
                        (when (chunk-p-fct (fast-chunk-slot-value-fct chunk slot))
                          (list (fast-chunk-slot-value-fct chunk slot))))
              (chunk-type-slot-names-fct (chunk-chunk-type-fct chunk)))))
    
    (setf sjis (mapcar #'(lambda (j) (cons j (compute-sji dm j chunk))) (remove-duplicates (cons chunk js))))
    (dolist (x (chunk-sjis chunk))
      (setf sjis (remove (car x) sjis :key #'car))
      (push x sjis))
    sjis))


(defun get-all-chunk-similarities (dm chunk)
  (let ((sims (chunk-similarities chunk)))
    (unless (find chunk sims :key #'car)
      (push (cons chunk (dm-ms dm)) sims))
    sims))

(defun set-dm-chunk-parameters-fct (dm chunk parameters)
  "Internal function to set the value of declarative chunk parameter(s)."
  (let ((values nil))
    (if chunk
      (loop
        (unless parameters 
          (return values))
        (let* ((parameter (pop parameters))
               (value (pop parameters)))
          ; not sure what this was for, but don't think it's still necessary
          ;(when (and (listp value) (eq (first value) 'quote))
          ;  (setf value (second value)))  
          
          (push-last
           (case parameter
             (:name
              (print-warning "CHUNK NAME CANNOT BE SET.")
              :error)
             (:activation
              (print-warning "CHUNK ACTIVATION CANNOT BE SET DIRECTLY.")
              :error)
             (:retrieval-activation
              (print-warning "CHUNK RETRIEVAL-ACTIVATION CANNOT BE SET DIRECTLY.")
              :error)
             (:retrieval-time
              (print-warning "CHUNK RETRIEVAL-TIME CANNOT BE SET DIRECTLY.")
              :error)
             
             (:base-level
              (cond ((dm-bll dm)
                     (print-warning 
                      "CHUNK BASE-LEVEL CANNOT BE SET DIRECTLY WHEN BASE LEVEL LEARNING IS ENABLED")
                     (print-warning "SET CREATION-TIME AND/OR REFERENCES INSTEAD.")
                     :error)
                    ((numberp value)
                     (setf (chunk-base-level chunk) value))
                    (t
                     (print-warning "CHUNK BASE-LEVEL MUST BE SET TO A NUMBER.")
                     :error)))
             (:creation-time
              (cond ((and (numberp value) (<= value (mp-time)))
                     (setf (chunk-creation-time chunk) value))
                    (t
                     (print-warning
                      "CHUNK CREATION-TIME MUST BE SET TO A NUMBER LESS THAN OR EQUAL TO THE CURRENT TIME.")
                     :error)))
             
             (:reference-count
              (cond ((null (dm-bll dm))
                     (print-warning "WHEN BLL DISABLED BASE-LEVEL SHOULD BE SET DIRECTLY")
                     :error)
                    ((null (dm-ol dm))
                     (print-warning "WHEN OL IS DISABLED BASE-LEVEL MUST BE SET THROUGH THE REFERENCE-LIST")
                     :error)
                    ((not (numberp value))
                     (print-warning "CHUNK REFERENCE-COUNT MUST BE SET TO A NUMBER")
                     :error) 
                    ((numberp (dm-ol dm)) 
                     (cond ((= (length (chunk-reference-list chunk)) value)
                            ;; do nothing
                            )
                           ((> (length (chunk-reference-list chunk)) value)
                            (setf (chunk-reference-list chunk) (subseq (chunk-reference-list chunk) 0 value)))
                           ((= (length (chunk-reference-list chunk)) (dm-ol dm))
                            ;; do nothing
                            )
                           (t 
                            (setf (chunk-reference-list chunk) (adapt-references dm value (chunk-creation-time chunk)))))
                     (setf (chunk-reference-count chunk) value))
                    (t ;; dm-ol = t so just set the number...
                     (setf (chunk-reference-count chunk) value))))
             
             (:reference-list
              (cond ((null (dm-bll dm))
                     (print-warning "WHEN BLL DISABLED BASE-LEVEL SHOULD BE SET DIRECTLY")
                     :error)
                    ((eq t (dm-ol dm))
                     (print-warning "WHEN OL IS T BASE-LEVEL MUST BE SET THROUGH THE REFERENCE-COUNT")
                     :error)
                    ((not (listp value))
                     (print-warning "CHUNK REFERENCE-LIST MUST BE SET TO A LIST OF NUMBERS")
                     :error)
                    ((not (every 'numberp value))
                     (print-warning "CHUNK REFERENCE-LIST MUST BE SET TO A LIST OF NUMBERS")
                     :error)
                    ((numberp (dm-ol dm))
                     (if (> (length value) (dm-ol dm))
                         (setf (chunk-reference-list chunk) (copy-list (subseq value 0 (dm-ol dm))))
                       (setf (chunk-reference-list chunk) (copy-list value)))
                     (when (< (chunk-reference-count chunk) (length (chunk-reference-list chunk)))
                       (setf (chunk-reference-count chunk) (length (chunk-reference-list chunk))))
                     (chunk-reference-list chunk))
                    (t ;; dm-ol = nil
                     (setf (chunk-reference-count chunk) (length value))
                     (setf (chunk-reference-list chunk) (copy-list value)))))
             
             (:references
              (cond ((listp value)
                     (setf (chunk-reference-count chunk) (length value))
                     
                     (setf (chunk-reference-list chunk)
                     
                       (cond ((null (dm-ol dm))
                              (copy-list value))
                             ((dm-ol dm) ;; it's a number so ignore the
                              ;; items in the list and even space them -
                              ;; that's what 4/5 does...
                              (adapt-references dm
                               (length value) 
                               (chunk-creation-time chunk)))
                             (t nil)))
                     
                     (cons (chunk-reference-count chunk)
                           (chunk-reference-list chunk)))
                    
                    ((numberp value)
                     (setf (chunk-reference-count chunk) value)
                     (setf (chunk-reference-list chunk)
                       (adapt-references dm
                        value 
                        (chunk-creation-time chunk)))
                       
                     (cons (chunk-reference-count chunk)
                           (chunk-reference-list chunk)))
                    (t
                     (print-warning 
                      "CHUNK REFERENCES MUST BE SET TO A NUMBER OR A LIST.")
                     :error)))
             
             (:source-spread
              (print-warning "CHUNK SOURCE-SPREAD CANNOT BE SET DIRECTLY: SET BUFFER CHUNKS AND/OR Sjis INSTEAD.")
              :error)
             
             (:sjis
              (cond ((listp value)
                     (dolist (sji-pair value)
                       (let ((chunkj (car sji-pair))
                             (sji (if (numberp (cdr sji-pair))
                                      (cdr sji-pair)
                                    (cadr sji-pair))))
                         (if (numberp sji)
                             (if (chunk-p-fct chunkj)
                                 (add-sji-fct (list (list chunkj chunk sji)))
                               (print-warning "~S is not a chunk"))
                           (print-warning "Sji VALUE ~S IS NOT A NUMBER." sji))))
                     (get-all-chunk-sjis dm chunk))
                    (t
                     (print-warning 
                      "CHUNK Sjis MUST BE SET USING A LIST OF CHUNK-NUMBER PAIRS.")
                     :error)))
             
             (:permanent-noise
              (cond ((numberp value)
                     (setf (chunk-permanent-noise chunk) value))
                    (t
                     (print-warning
                      "CHUNK PERMANENT-NOISE MUST BE SET TO A NUMBER.")
                     :error)))
             
             
             (:similarities
              (cond ((listp value)
                     
                     (dolist (similarity-pair value)
                       (let ((chunkj (car similarity-pair))
                             (similarity (if (numberp (cdr similarity-pair))
                                             (cdr similarity-pair)
                                           (cadr similarity-pair))))
                         (if (numberp similarity)
                             (if (chunk-p-fct chunkj)
                               (progn
                                 (awhen (assoc chunkj (chunk-similarities chunk))
                                        (setf (chunk-similarities chunk)
                                          (remove it (chunk-similarities chunk))))
                                 
                                 (push (cons chunkj similarity) 
                                       (chunk-similarities chunk)))
                               (print-warning "~S is not the name of a chunk." chunkj))
                           (print-warning "CHUNK SIMILARITY VALUE ~S IS NOT A NUMBER." similarity))))
                     
                     (get-all-chunk-similarities dm chunk))
                    (t
                     (print-warning 
                      "CHUNK SIMILARITIES MUST BE SET USING A LIST OF CHUNK-NUMBER PAIRS.")
                     :error)))
             
             
             (t (print-warning "NO PARAMETER ~s DEFINED FOR CHUNKS."
                             parameter)
                :error))
           values)))
      :error)))

;;; 
;;; New user level functions
;;;


(defun print-dm-finsts ()
  (let ((dm (get-module declarative)))
    (when dm
      ;; get-module will report a warning if it's not found
      
      (let ((max-name-len (max 11
                               (if (dm-finsts dm)
                                   (apply #'max 
                                          (mapcar #'(lambda (x)
                                                      (length (symbol-name (car x))))
                                            (dm-finsts dm)))
                                 0))))
        
        (command-output  "~%~va    Time Stamp~%~v,1,0,'-a"
          max-name-len "Chunk name" 
          (+ 14 max-name-len) "")
        
        (dolist (x (dm-finsts dm) (dm-finsts dm))
          (command-output  "~va    ~8,3f" max-name-len
            (car x) (cdr x)))))))

#|
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/dmi.lisp
;;;============================================================================

;;;  -*- mode: LISP; Package: CL-USER; Syntax: COMMON-LISP;  Base: 10 -*-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 
;;; Author      : Mike Byrne
;;; Address     : Rice University, MS-25
;;;             : Psychology Department
;;;             : Houston,TX 77251-1892
;;;             : byrne@acm.org
;;; 
;;; Copyright   : (c)1998-2003 Mike Byrne
;;; Availability: Covered by the GNU LGPL, see LICENSE.txt
;;; 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 
;;; Filename    : dmi.lisp
;;; Version     : 1.0a1
;;; 
;;; Description : The "Declarative Memory Interface"
;;;             : Defines a class ("declarative memory object," or DMO)
;;;             : and numerous methods to provide an interface layer
;;;             : between the PM stuff and the specific production
;;;             : system in terms of referring to declarative
;;;             : memory elements.  Cleans up a bunch of the PM code.
;;; 
;;; Bugs        : 
;;; 
;;; Todo        : 
;;; 
;;; ----- History -----
;;; 01.07.27 mdb
;;;             : Removed CLEAR-LOC for 2.1/ACT5
;;; 2003.01.21 mdb
;;;             : Removed PS-PTR slot and made it a method instead. 
;;; 
;;; 04.10.20 Dan [First past at moving things to ACT-R 6]
;;;            : Moved it in with the support code
;;;            :   modules that use it should have this call in them:
;;;            :   (require-compiled "DMI" "ACT-R6:support;dmi")
;;;            : Reset version number to 1.0a1
;;;            : Moved the methods from actr-interface to here, updated
;;;            :   them for ACT-R 6 and removed the methods that just printed
;;;            :   the "no method defined" message
;;;            : One thing though is that they aren't going directly to
;;;            :   declarative memory but just to chunks which will then
;;;            :   be deposited into buffers which will then end up in DM
;;;            : Modified the matching-dmos method because there will always be 
;;;            :   multiple copies as the chunks get moved into the buffers and 
;;;            :   modifying one of those chunks "behind the scenes" is not 
;;;            :   kosher.  For now I've just replaced it with essentially a
;;;            :   nop so that a new one is used everytime but a good solution
;;;            :   would probably be to keep an internal collection of the
;;;            :   chunks that the module explicitly creates and then search
;;;            :   over those.
;;;            :
;;; 04.12.17 Dan
;;;            : Changed make-dme so that it doesn't recreate an existing
;;;            :   chunk.  This is basically a hack around something that may
;;;            :   need to be fixed in vision.  Shouldn't affect DM since
;;;            :   the dme chunk isn't going to be a buffer's copy and thus
;;;            :   not one that ends up in DM.
;;; 2005.01.09 Dan
;;;            : Moved the provide to the end.
;;; 2005.03.25 Dan
;;;            : * Changed xy-to-dmo to remove the attended slot from the
;;;            :   chunk that gets made.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

#+: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)


(defclass dmo ()
  (;(ps-ptr :accessor ps-ptr :initform nil :initarg :ps-ptr)
   (id :accessor id :initform (new-name-fct "DMO") :initarg :id)
   (dmtype :accessor dmtype :initarg :dmtype :initform nil)
   (pm-obj :accessor pm-obj :initform nil :initarg :pm-obj)))


;;; generic methods 

(defmethod print-object ((self dmo) stream)
  (print-unreadable-object (self stream :type t)
    (princ (id self) stream)))

(defgeneric ps-ptr (self)
  (:documentation "Return the production system [hence PS] declarative memory."))



(defgeneric find-loc-dmo (loc)
  (:documentation "Given an XY location, return the DMO representing that location, if present."))

(defmethod find-loc-dmo ((loc vector))
  (random-item 
   (matching-dmos 'visual-location
                  `(screen-x ,(px loc) screen-y ,(py loc)))))

(defmethod find-loc-dmo ((loc list))
  (find-loc-dmo (coerce loc 'vector)))


(defgeneric xy-to-dmo (loc attended-p)
  (:documentation "Given an XY loc and an attended value, find the declarative memory representaion for that location, or build it.  Either way, set the attended flag of the DMO."))

(defmethod xy-to-dmo ((loc vector) (attended-p symbol))
  (let ((loc-dmo (find-loc-dmo loc))
        (name (new-name-fct "LOC")))
    (if loc-dmo
      (if attended-p 
        (set-attributes loc-dmo '(attended t))
        loc-dmo)
      (make-dme name 'visual-location  
                `(screen-x ,(px loc) screen-y ,(py loc)
                           ;attended ,attended-p 
                           objects nil)
                :where :external))))


(defmethod xy-to-dmo ((loc list) (attended-p symbol))
  (xy-to-dmo (coerce loc 'vector) attended-p))


#|
(defgeneric clear-loc (dmo)
  (:documentation "Clears the <objects> slot of a DMO."))

(defmethod clear-loc ((self dmo))
  (set-attributes self '(objects nil)))
|#

(defgeneric dmo-to-xy (dmo)
  (:documentation "Takes a location DMO and returns the XY location."))

(defmethod dmo-to-xy ((self dmo))
  (vector (get-attribute self 'screen-x) (get-attribute self 'screen-y)))



;;; Must be overridden with PS-specific methods.

(defgeneric make-dme (id dmtype attrs &key obj where)
  (:documentation "Creates both a PS-specific DM rep and an abstract DMO for a specification."))



(defgeneric get-attribute (dmo attrname)
  (:documentation "Retuns the value of a DMO's specified attribute."))


(defgeneric set-attributes (dmo attrs)
  (:documentation "Sets the value of one or more attributes of a DMO."))


(defgeneric psdme-to-dmo (psdme)
  (:documentation "Given a PS-specific DME, return the corresponding DMO."))

(defmethod psdme-to-dmo ((psdme null))
  nil)


(defgeneric dmo-to-psdme (dmo)
  (:documentation "Return the PS-specific DME form for a given DMO."))

(defmethod dmo-to-psdme ((self null))
  nil)


(defgeneric matching-dmos (dmtype attrs)
  (:documentation "Return a list of DMOs matching the given spec."))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; DAN
;;; Methods from actr-interface updated for ACT-R 6 
;;; note: they don't exactly go to DM now but are just chunks


(defmethod ps-ptr ((self dmo))
  ;;; The chunk name is the "pointer" for ACT-R 6
  ;;; because chunk structures are "off-limits"
  ;(get-safe-wme (id self))
  (id self))

(defmethod make-dme (id (dmtype symbol) (attrs list) &key (obj nil) 
                          (where nil))
  (declare (ignore where))
  
  ; (no-output (add-dm-fct `((,id isa ,dmtype ,@attrs)) :reset-ia nil))
  
  ;; The mod-chunk thing is a bad idea...
  ;; but necessary for now.
  
  (if (get-chunk id)
      (mod-chunk-fct id attrs)
    
    (define-chunks-fct `((,id isa ,dmtype ,@attrs))))
  
  (make-instance 'dmo :dmtype dmtype :id id :pm-obj obj))


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

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


(defmethod psdme-to-dmo (psdme)
  ;(setf psdme (get-safe-wme psdme))
  ;(make-instance 'dmo :dmtype (wme-type psdme) :id (wme-name psdme))
  (make-instance 'dmo :dmtype (chunk-chunk-type-fct psdme) :id psdme)
  )


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

(defmethod matching-dmos ((dmtype symbol) (attrs list))
  #|(let ((psdmes 
         (no-output (sdm-fct `(isa ,dmtype ,@attrs)))))
    (when psdmes
      (mapcar #'psdme-to-dmo psdmes)))
  
    ;;; The good solution would be something like
      
     (let ((psdmes (find-matching-chunks   
                       (define-chunk-spec-fct  
                         `(isa ,dmetype ,@attrs))
                      :chunks (internal-module-chunk-list))))
        (when psdmes
          (mapcar #'psdme-to-dmo psdmes)))
   |#
  nil)


(provide "DMI")

#|
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/environment/env-device.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-2005 Dan Bothell
;;; Availability: Covered by the GNU LGPL, see LGPL.txt
;;; 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 
;;; Filename    : env-device.lisp
;;; Version     : 2.0
;;; 
;;; Description : No system dependent code.
;;;             : This file contains the code that handles passing
;;;             : the virtual windows out through Tk - the visible
;;;             : virtuals, and the AGI support.
;;; Bugs        : 
;;; 
;;; Todo        :   
;;; ----- History -----
;;;
;;; 10/01/2002  Dan
;;;             : Added this header. 
;;; 10/01/2002  Dan
;;;             : Updated version to 1.1 and fixed the packaging
;;;             : for building a standalone in ACL.
;;; 12/04/2002  Dan
;;;             : Added the definition for *use-environment-window*
;;;             : even though it's still not used because it
;;;             : does get set by the environment and generates a
;;;             : warning.
;;; 01/06/2003  Dan
;;;             : Updated it so that the colors were sent out
;;;             : properly for all supported colors and so that
;;;             : text colors worked.
;;; 4/22/2004   Dan [1.5]
;;;             : Added the license info.
;;; -----------------------------------------------------------------------
;;; 2005.04.13  Dan [2.0]
;;;             : * Moved over to ACT-R 6.
;;; 2005.06.07 Dan
;;;             : * Replaced a call to device-interface with 
;;;             :   current-device-interface.
;;; 2005.06.28 Dan
;;;             : * Removed a pm-proc-display call that was still lingering
;;;             :   in the device-move-cursor-to method.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

#+: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)


;(in-package :cl-user)

;#+(and :allegro-ide (not :ACTR-ENV-ALONE)) (in-package :cg-user)


;;; This gets set to the user's option setting in the environment
;;; but for now is ignored.

(defvar *use-environment-window* nil)


;;; virtual windows for the environment that go out through
;;; Tcl/Tk to display i.e. a visible virtual
;;;
;;; Inherits much of the functionality from the rpm-virtual-window
;;; but needs to send the commands to Tcl/Tk as well

(defun visible-virtuals-available? () 
  "Return whether or not the visible-virtuals are available"
  (and *use-environment-window* *env-windows*)
  )

;;; First define all the stuff necessary for it and it's possible 
;;; 'subviews' as it relates to the device interface

(defclass visible-virtual-window (rpm-virtual-window)
  ())

(defmethod initialize-instance :after ((win visible-virtual-window) &key)
  (send-env-window-update (list 'open (window-title win) (x-pos win)
                                (y-pos win) (width win) (height win))))

(defclass env-text-vdi (static-text-vdi)
  ()
  (:default-initargs
      :id (new-name-fct "TEXT")))

(defclass env-button-vdi (button-vdi)
  ()
  (:default-initargs
      :id (new-name-fct "BUTTON")))

(defclass env-line-vdi (v-liner)
  ()
  (:default-initargs
      :id (new-name-fct "LINE")))


(defmethod vv-click-event-handler ((btn env-button-vdi) where)
  (declare (ignore where))
  (when (functionp (action-function btn))
    (funcall (action-function btn) btn))
  (when *actr-enabled-p* 
    (send-env-window-update (list 'click (id btn)))))


(defmethod device-move-cursor-to ((vw visible-virtual-window) (loc vector))
  (setf (cursor-pos vw) loc)
  (when (with-cursor-p (current-device-interface))
    (proc-display))
  (send-env-window-update (list 'cursor (px loc) (py loc))))

(defmethod device-update-attended-loc ((wind visible-virtual-window) xyloc)
  (send-env-window-update (list 'attention (px xyloc) (py xyloc))))


;;; Then define the UWI functions - which get called by the exp interface

(defmethod close-rpm-window ((win visible-virtual-window))
  (setf (window-open? win) nil)
  (send-env-window-update (list 'close)))


(defmethod select-rpm-window ((win visible-virtual-window))
  (send-env-window-update (list 'select)))

(defmethod add-visual-items-to-rpm-window ((win visible-virtual-window) 
                                           &rest items)
  (dolist (item items)
    (add-subviews win item)
    (send-env-window-update 
     (case (type-of item)
       (env-button-vdi
        (list 'button (id item) (x-pos item) (y-pos item) 
          (width item) (height item) (dialog-item-text item)))
       (env-text-vdi
        (list 'text 
          (id item) (x-pos item) (y-pos item) 
          (color-symbol->env-color (color item))  (dialog-item-text item)))
       (env-line-vdi
        (list 'line
              (id item) (x-pos item) (y-pos item) 
              (color-symbol->env-color (color item)) (width item) (height item)))))))



(defun color-symbol->env-color (color)
  (cond ((equal color 'red) "red")
        ((equal color 'blue) "blue")
        ((equal color 'green) "green")
        ((equal color 'black) "black")
        ((equal color 'white) "white")
        ((equal color 'pink)  "pink")
        ((equal color 'yellow) "yellow")
        ((equal color 'dark-green) "green4")
        ((equal color 'light-blue) "cyan")
        ((equal color 'purple) "purple")
        ((equal color 'brown) "brown")
        ((equal color 'light-gray) "gray90")
        ((equal color 'gray) "gray")
        ((equal color 'dark-gray) "gray40")
        (t "black")))



(defmethod remove-visual-items-from-rpm-window ((win visible-virtual-window) 
                                                &rest items)
  (dolist (item items)
    (remove-subviews win item)
    (send-env-window-update (list 'remove (id item)))))



(defmethod remove-all-items-from-rpm-window ((win visible-virtual-window))
  (apply #'remove-subviews win (subviews win))
  (send-env-window-update (list 'clear)))


(defmethod make-button-for-rpm-window ((win visible-virtual-window) 
                                       &key (x 0) (y 0) (text "Ok")  
                                       (action nil) (height 18) (width 60))
  (make-instance 'env-button-vdi
    :x-pos x 
    :y-pos y
    :dialog-item-text text
    :action action
    :height height
    :width width))


(defmethod make-static-text-for-rpm-window ((win visible-virtual-window) 
                                            &key (x 0) (y 0) (text "") 
                                            (height 20) (width 80) (color 'black))
  (make-instance 'env-text-vdi
    :x-pos x 
    :y-pos y
    :dialog-item-text text
    :height height
    :width width
    :color color
    ))

(defmethod rpm-window-visible-status ((win visible-virtual-window))
  t)

(defmethod make-line-for-rpm-window ((wind visible-virtual-window) 
                                     start-pt end-pt &optional (color 'black))
  (make-instance 'env-line-vdi
    :color color
    :x-pos (first start-pt)
    :y-pos (second start-pt)
    :width (first end-pt)
    :height (second end-pt)))

;;; This is a little tricky, because if it's a real window in an IDE'ed
;;; Lisp, it's still got to do the right thing to prevent hanging, 
;;; which is lisp specific...

(defmethod allow-event-manager ((win visible-virtual-window))
  (uni-process-system-events) 
  )


;;; This function relies on the handlers from the environment existing...

(defun send-env-window-update (cmd)
  (dolist (x *env-windows*)
    (setf (update-form x) #'(lambda (x) (declare (ignore x)) cmd))
    (update-handler x nil)))
#|
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/environment/env-module.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-2005 Dan Bothell
;;; Availability: Covered by the GNU LGPL, see LGPL.txt
;;; 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 
;;; Filename    : env-module.lisp (was hook-fns.lisp)
;;; Version     : 2.0
;;; 
;;; Description : NO system dependent code.
;;;             : This file contains the functions and variables 
;;;             : for managing the handlers connected to the hook functions 
;;;             : as well as the definition of the module which coordinates
;;;             : the operations now.
;;; Bugs        : 
;;; 
;;; Todo        :
;;; 
;;; ----- History -----
;;;
;;; 05/10/2002  Dan
;;;             : Added this header
;;; 09/25/2002  Dan
;;;             : Updated with the newest ACT-R code (v5.0.6)
;;; 10/01/2002  Dan
;;;             : Updated version to 1.1 and fixed the packaging
;;;             : for building a standalone in ACL.
;;; 04/22/2004  Dan
;;;             : Updated the master-process class to version 2.2
;;;             : and added the LGPL license stuff.
;;; 4/22/2004   Dan [1.5]
;;;             : Added the license info.
;;; ------------------------------------------------------------------------
;;; 2005.04.12  Dan [2.0]
;;;             : * Moving to ACT-R 6.
;;;             : * Get rid of all the ACT-R 5 function redefinitions.
;;;             : * Using a module to handle things.  That gives me some
;;;             :   encapsulation that it didn't have before (an actual
;;;             :   CLOS class with some class slots would be even better
;;;             :   but not for the first pass) and lends itself to the 
;;;             :   eventual support of multiple models.
;;; 2005.04.20  Dan
;;;             : * Changed create-environment-module to put #' before the
;;;             :   lambdas in the add-... for Lispworks.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


#+: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)

;(in-package :cl-user)

;#+(and :allegro-ide (not :ACTR-ENV-ALONE)) (in-package :cg-user)


(defvar *environment-exists* nil)

(defvar *creation-hook-list* nil)
(defvar *deletion-hook-list* nil)



(defstruct (environment-module (:conc-name env-mod-))
  model-name
  pre-hook-list
  post-hook-list
  conflict-hook-list
  pre-hook
  post-hook                             
  conflict-set
  last-dm-request
  last-dm-set
  )


(defun create-environment-module (model-name) 
  (when *environment-sockets* 
    (if *environment-exists*
        (print-warning "Cannot (yet) use the environment with multiple models!")
      (let ((module (make-environment-module :model-name model-name)))
        (setf *environment-exists* t)
        (setf (env-mod-pre-hook module)
          (add-pre-event-hook #'(lambda (event)
                                (dolist (x (env-mod-pre-hook-list module))
                                  (update-handler x event)))))
        (setf (env-mod-post-hook module)
          (add-post-event-hook #'(lambda (event)
                                 (dolist (x (env-mod-post-hook-list module))
                                   (update-handler x event)))))
        (dolist (x *creation-hook-list*)
          (update-handler x model-name))
        module))))


(defun reset-environment-module (env-mod)
  (when env-mod
    (setf (env-mod-conflict-set env-mod) nil)
    (setf (env-mod-last-dm-request env-mod) nil)
    (setf (env-mod-last-dm-set env-mod) nil)
    
    (if *environment-sockets*
    
    ;; Push the commands onto the appropriate hooks
        
        (sgp-fct (list :conflict-set-hook 
                       (lambda (cs)
                         (setf (env-mod-conflict-set env-mod)
                           (copy-list cs))
                         (let ((val nil))
                           (dolist (x (env-mod-conflict-hook-list env-mod) val)
                             (let ((r (update-handler x cs)))
                               (when r
                                 (setf val r))))))
                       
                       :retrieval-request-hook (lambda (request)
                                                 (setf (env-mod-last-dm-request env-mod)
                                                   request)
                                                 nil)
                       :retrieval-set-hook (lambda (ret-set)
                                             (setf (env-mod-last-dm-set env-mod)
                                               (copy-list ret-set))
                                             nil)))
    )))
    
                   
(defun delete-environment-module (env-mod)
  (when env-mod
    (setf *environment-exists* nil)
    (delete-event-hook (env-mod-pre-hook env-mod))
    (delete-event-hook (env-mod-post-hook env-mod))
    (dolist (x *deletion-hook-list*)
          (update-handler x nil))))


(define-module-fct :environment nil nil
  :creation 'create-environment-module
  :reset '(nil reset-environment-module)
  :version #+:ACTR-ENV-ALONE "2.0-s"
           #-:ACTR-ENV-ALONE "2.0"
  
  :documentation "A module to handle the environment connection if opened"
  :delete 'delete-environment-module)


#|
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/framework/events.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    : events.lisp
;;; Version     : 1.0a1
;;; 
;;; Description : The definition of events for the scheduler as described in
;;;               the ACT-R 6 software framework API.
;;; 
;;; Bugs        : 
;;;
;;; To do       : 
;;; 
;;; ----- History -----
;;;
;;; 2004.08.11 Dan
;;;             : Creation.
;;; 2005.01.09 Dan
;;;             : Changing the event trace a little. I don't think it's
;;;             : necessary to print the destination in the trace since
;;;             : it's either the same as the module (and already there)
;;;             : or the module that was the destination will show an
;;;             : event later in response...
;;; 2006.07.16 Dan
;;;             : Changed the API section to note the correct accessor is
;;;             : evt-output.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; General Docs:
;;; 
;;; Despite the fact that events are simply structs one should not create
;;; them explicitly and only the scheduling fuctions provided in schedule.lisp
;;; should be used to generate them.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Public API:
;;;
;;; 
;;; evt-time (event)
;;; returns the time in seconds at which the event is scheduled to occur.
;;;
;;; evt-priority (event)
;;; returns the priority of the event.  
;;;
;;; evt-action (event)
;;; returns the action function that will be executed for the event.  
;;;
;;; evt-model (event)
;;; returns the name of the model in which this event was created.
;;;
;;; evt-module (event)
;;; returns the name of the module which created this event.
;;;
;;; evt-destination (event)
;;; returns the destination which was specified for the event.
;;;
;;; evt-params (event)
;;; returns the list of parameters which will be passed to the event's 
;;; action function when the event is executed.
;;;
;;; evt-details (event)
;;; returns the details string that will be displayed in the trace for 
;;; this event if it has one, or nil if it does not.
;;;
;;; evt-output (event)
;;; returns the output value of this event, which indicates whether to 
;;; print this event in the trace.
;;;
;;; format-event (event)
;;; returns a string that contains the text that will be displayed in the 
;;; trace for event if it is executed and has its output set to t.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Design Choices:
;;; 
;;; Because a function with the name 'event-'something is likely to conflict 
;;; with existing functions in some Lisp and the default operation of the 
;;; system is to not separately package the components, the names of the 
;;; accessors begin with evt- instead of event-.
;;;
;;; Using a struct because I don't need anything fancy at this point.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 
;;; 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)



(defun act-r-event-break-action (mp)
  (setf (meta-p-break mp) t))

(defmethod format-event (event)
  (declare (ignore event))
  nil)

(defconstant +format-event-event-string+ 
    (formatter "~10,3f ~:[~*~;~a ~] ~:[~2*~;~va ~] ~va ~:[~*~a~@[ ~a~]~{ ~a~}~;~a~*~*~*~] ~@[Waiting for: ~A~]"))


(defmethod format-event ((event act-r-event))
  (let ((*print-pretty* nil)
        (mp (get-mp (evt-mp event))))
    (format nil +format-event-event-string+
      (evt-time event)
      (< 1 (mps-count *meta-processes*))
      (evt-mp event)
      (< 1 (meta-p-model-count mp))
      (meta-p-model-name-len mp)
      (evt-model event)
      (max-module-name-length)
      (evt-module event)
      (evt-details event)
      (evt-details event)
      (evt-action event)
      ; this is easier than fixing the string for now 
      ; (evt-destination event)
      nil
      (evt-params event)
      (evt-wait-condition event))))
  
(defconstant +format-event-break-event-string+ (formatter "~10,3f ~:[~*~;~a ~] ~:[~2*~;~va ~] ~va BREAK-EVENT ~@[~a ~]~@[Waiting for: ~A~]"))


(defmethod format-event ((event act-r-break-event))
  (let ((*print-pretty* nil)
        (mp (get-mp (evt-mp event))))
    (format nil +format-event-break-event-string+
      (evt-time event)
      (< 1 (mps-count *meta-processes*))
      (evt-mp event)
      (< 1 (meta-p-model-count mp))
      (meta-p-model-name-len mp)
      "------"
      (max-module-name-length)
      "------"
      (evt-details event)
      (evt-wait-condition event))))
  

#|
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/environment/environment-cmds.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    : environment-cmds.lisp
;;; Version     : 2.0
;;; 
;;; Description : No system dependent code.
;;;             : Defines stuff that is needed to handle "environment"
;;;             : things.
;;; Bugs        : 
;;; 
;;; Todo        : Clean up what goes here and what's passed literally
;;;             : from the Tcl side - it's an odd mix at this point
;;;             : and I should have some consistency.
;;; 
;;; ----- History -----
;;;
;;; 05/22/2002  Dan
;;;             : File creation
;;; 10/01/2002  Dan
;;;             : Updated version to 1.1 and fixed the packaging
;;;             : for building a standalone in ACL.
;;; 01/20/2003  Dan
;;;             : Added the show-module-state-chunk function and
;;;             : hacked buffer-contents so that the module-state
;;;             : chunks shown by the environment match internal
;;;             : module states even though the "real" chunks
;;;             : don't seem to be updated anymore. WHY and WHEN?!
;;; 4/22/2004   Dan [1.5]
;;;             : Added the license info.
;;; ----------------------------------------------------------------------
;;; 2005.04.13  Dan [2.0]
;;;             : * Moved to ACT-R 6.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

#+: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)

;(in-package :cl-user)

;#+(and :allegro-ide (not :ACTR-ENV-ALONE)) (in-package :cg-user)

;;; Here I define a variable that will be used by the environment
;;; as a simple flag to prevent run from being pressed more than
;;; once (and there may be other uses)

(defvar *running-actr* nil)

;;; Reset-model-env
;;; this is the function called when the reset button in the
;;; environment is pressed.  Basically, all it does print a message
;;; after it resets for reference.

(defun reset-model-env (x)
  (declare (ignore x))
  (if (or *stepper-open* *running-actr*)
      (model-warning "Cannot reset a running model or if the stepper is open.")
    (unwind-protect 
        (progn
          (setf *running-actr* t)
          (reset)
          (format t "~%#|## Model has been reset. ##|#~%"))
      (setf *running-actr* nil))))

;;; Reload-model
;;; this is the function called when the reload button in the
;;; environment is pressed.  It takes one parameter which specifies 
;;; whether or not to use the smart-loader instead of the simple reload
;;; function.

(defun reload-model (smart-load?)
  (let* ((save-stream (make-string-output-stream ))
         (display-stream (make-broadcast-stream *standard-output* save-stream))
         (error-stream (make-broadcast-stream *error-output* save-stream))
         (*standard-output* display-stream)
         (*error-output* error-stream))
    
    (if (or *running-actr* *stepper-open*)
        (list 0 "Cannot reload a model that is running or if the stepper is open.")
      (unwind-protect
          (progn
            (setf *running-actr* t)   
            (multiple-value-bind (s err) 
                (ignore-errors 
                 (if smart-load?
                     (reload t)
                   (reload)))
      
              (cond ((and (subtypep (type-of err) 'condition)
                          (not (equal (type-of err) 'unbound-variable)))
                     (uni-report-error err (format nil "Error reloading model"))
                     (list 0 (get-output-stream-string save-stream)))
                    ((eq s :none)
                     (model-warning "Error Reloading model")
                     (list 0 (get-output-stream-string save-stream)))
                    (t
                     (model-output "Model Reloaded")
                     (list 1 (get-output-stream-string save-stream))))))
        (setf *running-actr* nil)))))

(defun safe-load (file compile-it)
  
  (setf file (create-valid-pathname file))
  
  (let* ((save-stream (make-string-output-stream ))
         (display-stream (make-broadcast-stream *standard-output* save-stream))
         (error-stream (make-broadcast-stream *error-output* save-stream))
         (*standard-output* display-stream)
         (*error-output* error-stream))
    
    
    (multiple-value-bind (s err) 
        (ignore-errors 
         (if compile-it
             (compile-and-load file)
           (load file)))
      (declare (ignore s))
      
      (cond ((and (subtypep (type-of err) 'condition)
                  (not (equal (type-of err) 'unbound-variable)))
             (uni-report-error err (format nil "Error reloading model"))
             (list 0 (get-output-stream-string save-stream)))
            (t
             (model-output "Model Reloaded")
             (list 1 (get-output-stream-string save-stream)))))))
  

;;; buffer-list
;;; This function doesn't take any parameters, and 
;;; doesn't really do anything at this point other than
;;; return a constant list. 
;;; I'm hoping that with 6.0 there'll be a way to add and
;;; access buffers uniformly (unlike now) and there'll exist
;;; a function for getting the list, but for now just hack
;;; it out.

(defun buffer-list (x)
  (declare (ignore x))
  (buffers))

;;; buffer-contents
;;; This function takes one parameter which is a symbol that
;;; is the name of a buffer.  It prints out the chunk that is
;;; currently in that buffer, or "Buffer is Empty" if there isn't
;;; a chunk in that buffer to *standard-output*.
;;; This is another of those mechanisms that'd be nice to fix
;;; for ACT-R 6.0...

(defun buffer-contents (buffer)
  
  (if (buffer-read buffer)
         (buffer-chunk-fct (list buffer))
        
    (format *standard-output* "Buffer is Empty")
  ))


#|
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 Foundati