;; this is a file that loads ACT-R 6 as a single file. ;; it was built on 11-12 April 2007 based on the ac-r6 tar file (actr6.zip) of 15 jan 07 from act.psy.cmu.edu ;; Frank.ritter@psu.edu ;; ;; What I did: ;; I loaded the act-r loader, and took note of the order of file loads into cmucl (19c). ;; I put the files in a single file in load order using a keyboard macro to grab a file based on the load line ;; I moved a few files around where I could see that files required files or files loaded files, for example, ;; moved dmi and general-pm before vision ;; uni-foes before env-loader ;; I did not include files that were system files, e.g., socket utilities ;; I moved mpprint to the end of the file ;; I tested it by loading our serial subtraction file. ;; I found a few files were missing, but put them back in. ;; some of the loads put ;; in front and some put ;;; in front, my macro was simple, and lost some ;; I cross compared it to the other all-act-r done alphabetically by Jong Kim when I needed to. ;; It currently loads and appears to work well in CMUCL 19c ;; /Users/ritter/ritter/proposals/onr-emotions4/iccm07/actr6-15jan07/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 in directory 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) ;; -fer ;; (smart-load (translate-logical-pathname "ACT-R6:framework;") "framework-loader.lisp") ;; -fer ;;(dolist (the-file *file-list) ;; (smart-load (translate-logical-pathname "ACT-R6:framework;") the-file t)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Load the core modules ;; -fer ;; (smart-load (translate-logical-pathname "ACT-R6:core-modules;") "core-loader.lisp") ;; -fer ;; (dolist (the-file *file-list) ;; (smart-load (translate-logical-pathname "ACT-R6:core-modules;") the-file)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; First, load any additional extensions. ;;-fer ;; (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 ;; -fer ;; (compile-and-load (logical-pathname "ACT-R6:devices;virtual;device.lisp")) ;; -fer ;; (compile-and-load (logical-pathname "ACT-R6:devices;virtual;uwi.lisp")) ;;; Load any Lisp specific device that's defined ;; -fer #| (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. ;; -fer #| (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 "~%##################################~%") ;; -fer (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 |# ;; /Users/ritter/ritter/proposals/onr-emotions4/iccm07/actr6-15jan07/load-act-r-6.lisp ;; ;; **************************************************************** ;; **************************************************************** ;; /Users/ritter/ritter/proposals/onr-emotions4/iccm07/actr6-15jan07/framework/framework-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 : framework-loader.lisp ;;; Version : 1.0 ;;; ;;; Description : Compiles (if necessary) and loads the files that implement ;;; the framework core. ;;; ;;; Bugs : ;;; ;;; To do : Possibly need special cases for "standalones" as was done ;;; with the ACT-R 5 loader. ;;; : Get rid of smart-load and use the main loader's ;;; compile and load instead. ;;; ;;; ----- History ----- ;;; ;;; 2004.09.27 Dan ;;; : Creation ;;; 2005.01.29 Dan ;;; : * Removed the setting of *.lisp-pathname* and *.bin-pathname* ;;; : since that happens in the top loader (load-act-r-6.lisp). ;;; : * Changed smart-load to use compile-and-load instead of doing ;;; : the same checks. ;;; 2005.08.11 Dan ;;; : * Took act-gui-interface off of the list because it has been ;;; : moved to tools. ;;; : * Changed version to 1.0. ;;; : * Removed everything but the file list... ;;; 2007.01.15 Dan ;;; : * Added version-string as the first file in the list now. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; General Docs: ;;; ;;; Compiles and loads only the framework pieces but not the general modules ;;; or the specific device interfaces. ;;; Called 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: ;;; ;;; Based on the loader from ACT-R/PM and ACT-R 5. Supports the same Lisps ;;; as was done there. ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; 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. ;;; this is always the generic list (defparameter *file-list '("version-string" "internal-structures" "internal-macros" "misc-utils" "meta-process" "chunk-types" "chunks" "modules" "parameters" "buffers" "model" "events" "scheduling" "chunk-spec" "top-level" "device-interface" "generic-interface" "vision-categorization" "random" "printing" "naming-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 |# ;; /Users/ritter/ritter/proposals/onr-emotions4/iccm07/actr6-15jan07/framework/framework-loader.lisp ;; **************************************************************** ;; **************************************************************** ;; /Users/ritter/ritter/proposals/onr-emotions4/iccm07/actr6-15jan07/framework/version-string.lisp ;; ;;; -*- mode: LISP; Syntax: COMMON-LISP; Base: 10 -*- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Author : Dan Bothell ;;; Copyright : (c) 2007 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 : version-string.lisp ;;; Version : 1.0 ;;; ;;; Description : Sets a global variable with the current version of the ACT-R ;;; : sources so that this is all I need to touch to update that. ;;; ;;; Bugs : ;;; ;;; To do : ;;; ;;; ----- History ----- ;;; 2007.01.15 Dan ;;; : * Initial creation. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; General Docs: ;;; ;;; Just sets a string which will be used as the framework version number. ;;; ;;; Will not be indicating changes in the history section when they are made. ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; 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) (defvar *actr-version-string* "1.2 [r370]") #| 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 |# ;; /Users/ritter/ritter/proposals/onr-emotions4/iccm07/actr6-15jan07/framework/version-string.lisp ;; **************************************************************** ;; **************************************************************** ;; /Users/ritter/ritter/proposals/onr-emotions4/iccm07/actr6-15jan07/framework/internal-structures.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 : internal-structures.lisp ;;; Version : 1.1 ;;; ;;; Description : All of the defstructs for the internal code. ;;; ;;; Bugs : ;;; ;;; To do : ;;; ;;; ----- History ----- ;;; ;;; 2004.10.07 Dan ;;; : Created. ;;; 2005.01.05 Dan ;;; : Changed the version on the meta-process so that it indicates ;;; : the svn revision because it's going to be used to create a ;;; : snapshot for the website. ;;; 2005.01.10 Dan ;;; : Same as above - added r20 and this time it's actually going ;;; : out to the site! ;;; 2005.01.12 Dan ;;; : Because device is becoming a module it doesn't need to be ;;; : a slot in the model. ;;; 2005.01.15 Dan ;;; : * Taking the r20 out of the meta-process version and uping ;;; : it to 1.0a2. ;;; : * Moving to 80 charater width. ;;; : * Adding the copied-from slot to chunks. ;;; 2005.01.16 Dan ;;; : * Removed the print-functions for chunks and chunk-types ;;; : because users shouldn't be seeing those and there's no ;;; : need to hide the details. ;;; 2005.01.21 Dan ;;; : * Added the merge-list slot to chunks to help speed up the ;;; : merging action. ;;; 2005.01.27 Dan ;;; : * Added the filter slot to the printing module structure. ;;; 2005.01.29 Dan ;;; : * Added r33 to the meta-process version for distribution ;;; : on the ACT-R website. ;;; 2005.01.31 Dan ;;; : * Removed the r33 from the version and updated it to 1.0a3. ;;; 2005.02.02 Dan ;;; : * Added the detail slot to the printing module. ;;; : * Changed the default output for break events to be low ;;; : for use wth the detail level. ;;; 2005.02.11 Dan ;;; : * Changed the make-hash-tables in the chunk structure to ;;; : limit the size to just a little bigger than needed and ;;; : in the meta-process to 5 for models. ;;; 2005.03.23 Dan ;;; : * Added the secondary-reset slot to the module structure. ;;; 2005.04.08 Dan ;;; : * Added r67 to meta-process version for distribution on ;;; : the website. ;;; 2005.04.14 Dan ;;; : * Added the suppress-cmds slot to the printing module to get ;;; : around a problem with no-output and trying to read the :cmdt ;;; : parameter... ;;; 2005.04.20 Dan ;;; : * Took the r67 off of the meta-process version. ;;; 2005.05.11 Dan ;;; : * Changed the version to 1.0b1 [r79]. ;;; 2005.05.12 Dan ;;; : * Removed the [r79] from the version. ;;; 2005.06.10 Dan ;;; : * Changed the version to 1.0b2 [r120]. ;;; 2005.06.11 Dan ;;; : * Changed version to 1.0b2 ;;; 2005.07.12 Dan ;;; : * Changed the framework version to 1.0 [r130]. ;;; 2005.07.13 Dan ;;; : * Removed the r130 from the version number. ;;; 2005.08.30 Dan ;;; : * Changed the framework version to 1.0 [r144]. ;;; 2005.08.30 Dan ;;; : * Oops, mis-encoded the file with mac line endings, so ;;; : now changing to [r145]. ;;; 2005.09.01 Dan ;;; : * Taking the [r145] off. ;;; 2005.09.08 Dan ;;; : * Added the model-warnings slot to the printing module ;;; : struct to support suppression of all model warnings. ;;; 2005.11.16 Dan ;;; : * Changing framework version to 1.0 [r168]. ;;; 2005.11.17 Dan ;;; : * Changing framework version to back to 1.0. ;;; 2006.01.16 Dan ;;; : * Changed the version to [r187] for release. ;;; 2006.01.17 Dan ;;; : * Changing framework version to 1.1. ;;; 2006.01.18 Dan ;;; : * Added the extended-slots slot to the chunk-type structure ;;; : so that one can differentiate between the original slots ;;; : and any that are added on the fly. ;;; : * Added the show-all-slots slot to the printing module to hold ;;; : the new parameter. ;;; 2006.01.30 Dan ;;; : * Adding the maintenance event type for use in things like ;;; : terminating events and periodic events. The schedule-event- ;;; : after functions will have a keyword that specifies whether ;;; : or not to consider maintenance events that defaults to nil. ;;; 2006.02.27 Dan ;;; : * Added slots to the meta-process to handle the configuration ;;; : of the real time management. ;;; 2006.03.03 Dan ;;; : * Added the max-time-delta slot to the meta-process. ;;; 2006.03.06 Dan ;;; : * Changed the version to [r204] for release. ;;; 2006.03.06 Dan ;;; : * Removed the [r204] from the version. ;;; 2006.03.14 Dan ;;; : * Changed version to [r212] for web release. ;;; 2006.03.14 Dan ;;; : * Removed the [r212]. ;;; 2006.03.15 Dan ;;; : * Changed version to [r216] for web release. ;;; 2006.03.15 Dan ;;; : * Removed the [r216]. ;;; 2006.03.21 Dan ;;; : * Changed version to [r219] for web release. ;;; 2006.03.21 Dan ;;; : * Changed version to [r220] for web release. ;;; 2006.03.28 Dan ;;; : * Changed version to [r222] for web release. ;;; 2006.03.28 Dan ;;; : * Removed the [r222]. ;;; 2006.07.10 Dan ;;; : * Changed version to [r248] for web release. ;;; 2006.07.10 Dan ;;; : * Removed the [r248]. ;;; 2006.11.20 Dan ;;; : * Added the warn slot to the act-r-module structure. ;;; 2007.01.15 Dan ;;; : * Changed the version setting in the meta-process structure ;;; : to be the value of *actr-version-string* so that I don't ;;; : have to touch this file to mark the version changes. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; General Docs: ;;; ;;; These are not for general use! ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Public API: ;;; ;;; NONE! ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Design Choices: ;;; ;;; I had some odd compiling order issues with the defstructs and defmacros ;;; so for now the easy fix was to make sure that they are all ;;; available from 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) (defstruct act-r-buffer "The internal structure for a buffer" name chunk ;; holds the chunk name not struct - copy issues and such... module spread queries requests parameter-name requested status-printing ) (defstruct act-r-chunk-spec "The internal structure of a chunk-spec" type slots) (defstruct act-r-slot-spec "The internal structure of a chunk-spec's slot specification" (modifier '=) name value) (defstruct act-r-chunk-type ; (:print-function print-chunk-type)) "The internal structure of a chunk-type" name documentation supertypes subtypes slots extended-slots) (defstruct act-r-chunk ; (:print-function print-chunk)) "The internal structure of a chunk" name documentation chunk-type slot-value-lists copied-from merge-list (parameter-values (make-hash-table :size 17))) (defstruct act-r-chunk-parameter "The internal structure of a chunk parameter" name default-value default-function merge copy accessor) (defstruct (act-r-event (:conc-name evt-)) "Internal ACT-R event" time priority action model mp module destination params details (output t) wait-condition) (defstruct (act-r-maintenance-event (:include act-r-event (output 'low))) "Events for system maintenance") (defstruct (act-r-break-event (:include act-r-maintenance-event (action #'act-r-event-break-action))) "The ACT-R break events" ) (defstruct (act-r-periodic-event (:include act-r-maintenance-event)) "special event that repeatedly schedules a user's event" id) (defstruct (meta-processes (:conc-name mps-)) "The internal structure that holds meta-processes" (table (make-hash-table)) (count 0) current) (defstruct (meta-process (:conc-name meta-p-)) "The internal representation of the meta-process" name (time 0.0) start-time start-real-time (models (make-hash-table :size 5)) current-model (model-count 0) (model-name-len 0) events delayed break pre-events post-events (time-function 'get-internal-real-time) (units-per-second internal-time-units-per-second) (slack-function 'real-time-slack) max-time-delta (next-hook-id 0) (hook-table (make-hash-table)) (version *actr-version-string*) (documentation "")) (defstruct act-r-model "The internal structure of a model" (modules-table (make-hash-table)) (buffers (make-hash-table)) (chunks-table (make-hash-table)) (chunk-types-table (make-hash-table)) name code ;device ) (defstruct act-r-modules "The internal structure that holds the modules" (table (make-hash-table)) (count 0) (name-len 0) notify update) (defstruct act-r-module "The internal structure of a module" name buffers version documentation creation reset query request buffer-mod params delete notify-on-clear update secondary-reset warn) (defstruct act-r-parameter "The internal structure of a parameter" param-name default test warning details owner users) (defstruct printing-module "The internal structure for an instance of the printing module" (v (make-act-r-output :stream t)) (c (make-act-r-output :stream t)) (suppress-cmds nil) (filter nil) (detail 'high) (model-warnings t) (show-all-slots nil)) (defstruct act-r-output "The internal structure of an output stream for the printing module" stream file) #| 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 |# ;; /Users/ritter/ritter/proposals/onr-emotions4/iccm07/actr6-15jan07/framework/internal-structures.lisp ;; **************************************************************** ;; **************************************************************** ;; /Users/ritter/ritter/proposals/onr-emotions4/iccm07/actr6-15jan07/framework/internal-macros.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 : internal-macros.lisp ;;; Version : 1.0a1 ;;; ;;; Description : All of the defmacros for the internal code. ;;; ;;; Bugs : ;;; ;;; To do : ;;; ;;; ----- History ----- ;;; ;;; 2004.10.07 Dan ;;; : Created. ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; General Docs: ;;; ;;; These are not for general use! ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Public API: ;;; ;;; NONE! ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Design Choices: ;;; ;;; I had some odd compiling order issues with the defstructs and defmacros ;;; so for now the easy (only?) fix was to make sure that they are all ;;; available from 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) (defmacro current-model-struct () `(when (current-mp) (meta-p-current-model (current-mp)))) (defmacro verify-current-model (warning &body body) `(if (null (meta-p-current-model (current-mp))) (print-warning ,warning) (progn ,@body))) #| 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 |# ;; /Users/ritter/ritter/proposals/onr-emotions4/iccm07/actr6-15jan07/framework/internal-macros.lisp ;; **************************************************************** ;; **************************************************************** ;; /Users/ritter/ritter/proposals/onr-emotions4/iccm07/actr6-15jan07/framework/misc-utils.lisp ;; ;;; -*- mode: LISP; Syntax: COMMON-LISP; Base: 10 -*- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Author : Dan Bothell & Mike Byrne ;;; Copyright : (c) 2004-5 Dan Bothell/Mike Byrne ;;; 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 : misc-utils.lisp ;;; Version : 1.0 ;;; ;;; Description : Various useful functions that don't seem to belong anywhere ;;; else (many of which come directly from the old RPM code). ;;; ;;; Bugs : * The "-output" commands break if passed strings with format ;;; : control sequences in them. ;;; ;;; To do : * Add most if not all of these to the official API. ;;; : * Add all the ones copied from rpm to the public API section. ;;; : * Handle different warning levels. ;;; : * Fix an issue with MCL double printing model warnings because ;;; : *error-output* isn't the same as *standard-output* even ;;; : though both print to the listener - grrr. ;;; : * Possibly split the "-output" commands into macros and functions ;;; : like everything else because right now they're funny in that ;;; : they're macros but they do result in evaluating the parameters. ;;; ;;; ----- History ----- ;;; ;;; 2004.08.12 Dan ;;; : Creation ;;; 2005.01.17 Dan ;;; : * Updated model-output and added command-output. I don't think ;;; : it needs the no-output command, but maybe it will. ;;; 2005.02.10 Dan ;;; : * Added the expt-coerced, log-coerced, and sqrt-coerced ;;; : for performance improvements in Lisps that use doubles when ;;; : the default read format is singles. ;;; 2005.02.21 Dan ;;; : * Added some to do stuff. ;;; 2005.02.28 Dan ;;; : * Note that the -coerced macros don't really do anything ;;; : in MCL 5 or ACL, so probalby not necessary anymore... ;;; : * Made a bunch of the output macros hygienic. ;;; : * Added back meta-p-output to print to all models' :v stream ;;; : but only once per stream. ;;; 2005.04.14 Dan ;;; : * Made use of printing-module-suppress-cmds in no-output and ;;; : command-output to fix an issue with reading :cmdt in the ;;; : context of a no-output. ;;; 2005.05.11 Dan ;;; : * Added *one-stream-hack* to be used in model-warning to ;;; : get around an issue in MCL with it doubling warnings due ;;; : to *error-output* not equaling *standard-output* even ;;; : though they're the same place. ;;; : NOT a good solution, but makes things look nicer for now... ;;; 2005.07.22 mdb ;;; : * Changed WITHIN, GREATER-THAN, and LESS-THAN to return NIL ;;; : if compared against non-numbers. ;;; : * Added NOT-EQUAL function to support negations. ;;; 2005.08.10 Dan ;;; : * Changed no-output because it didn't need return0val and it ;;; : generated a warning. ;;; : * Updated version to 1.0. ;;; 2005.09.08 Dan ;;; : * Added support for a new paramter called :model-warnings ;;; : in the printing module. When it is nil all the calls to ;;; : model-warning result in no output. ;;; 2005.10.19 Dan ;;; : * Changed dovector slightly to assign an initial value of ;;; : nil to the variable in the let explicitily to get around ;;; : an issue with that in CMUCL. ;;; 2005.10.21 Dan ;;; : * Doh! Realized the problem isn't the let issue but that ;;; : CMUCL already defines dovector and doesn't like overwritting ;;; : it. Fixed that now. ;;; 2006.03.13 Dan ;;; : * Fixed no-outupt because it could fail when there were ;;; : nested calls. ;;; 2006.05.22 Dan ;;; : * Noticed that Mike isn't listed as an author even though ;;; : many of these come from his older files. ;;; 2006.06.29 Dan ;;; : * Added components provided by Don Morrison to allow it to be ;;; : loaded into CLisp v2.38 - just added clisp to the switch to ;;; : not define this method (defmethod random-item ((seq vector)). ;;; 2006.07.12 Dan ;;; : * Modified meta-p-output so that it always returns nil. ;;; 2006.09.08 Dan ;;; : * Cleaned up the definition of posnum and added a corresponding ;;; : nonneg because zero isn't positive and there are situations ;;; : where that distinction matters (and those modules are now ;;; : also being updated to use nonneg). ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; General Docs: ;;; ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Public API: ;;; ;;; While ;;; (defmacro while (test &body body) ;;; ;;; test a form to evaluate ;;; body any number of forms ;;; ;;; while the test evaluates to a non-nil value continue to evaluate the forms ;;; of the body. ;;; ;;; returns nil. ;;; ;;; Push-last ;;; (defmacro push-last (item place) ;;; ;;; item anything ;;; place a Lisp place ;;; ;;; push-last postpends item to the list that is stored in place and stores the ;;; resulting list in place. ;;; ;;; returns place. ;;; ;;; Print-warning ;;; (defmacro print-warning (control-string &rest args)) ;;; ;;; control-string is a control-string as would be passed to the format function ;;; args are the arguments to use in that control string ;;; ;;; control-string and args are passed to format on the stream *error-output* ;;; with the text "#|Warning: " proceeding it and "|#" after it so that it would ;;; appear as a comment if the stream were to be read. ;;; ;;; nil is returned. ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; 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) ;;; WHILE [Macro] ;;; From _On Lisp_. ;;; Already defined in ACL with the IDE or all versions 6.0 or newer. ;;; (defmacro while (test &body body) ;;; ;;; test a form to evaluate ;;; body any number of forms ;;; ;;; while the test evaluates to a non-nil value continue to evaluate the forms ;;; of the body. ;;; ;;; returns nil. #-(or :allegro-ide (and :allegro-version>= (version>= 6))) (defmacro while (test &body body) `(do () ((not ,test)) ,@body)) ;;; AIF [Macro] ;;; Date : 97.02.09 ;;; Description : From _On Lisp_, anaphoric if. That is, can use variable ;;; : "it" to refer to result of the test-form. (defmacro aif (test-form then-form &optional else-form) `(let ((it ,test-form)) (if it ,then-form ,else-form))) (defmacro awhen (test-form &body body) `(aif ,test-form (progn ,@body))) ;;; push-last ;;; ;;; (defmacro push-last (item place) ;;; ;;; item anything ;;; place a Lisp place ;;; ;;; push-last postpends item to the list that is stored in place and stores the ;;; resulting list in place. ;;; ;;; returns place. ;;; (defmacro push-last (item place) `(setf ,place (nconc ,place (list ,item)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; expt-coerced, exp-coerced, log-coerced, and sqrt-coerced ;;; ;;; These are for improved speed in Lisps that use doubles for math so that ;;; it can coerce them to single when that's the setting of ;;; *read-default-float-format*. Really makes a difference in MCL... ;;; Actually, in MCL 5 it makes no difference, and may want to just ;;; eliminate this... (defmacro expt-coerced (base power) "Computes expt and coerce to *read-default-float-format* if needed" (if (typep (expt 1.0 1.0) *read-default-float-format*) `(expt ,base ,power) `(coerce (expt ,base ,power) ,*read-default-float-format*))) (defmacro exp-coerced (arg) "Computes expt and coerce to *read-default-float-format* if needed" (if (typep (expt 1.0 1.0) *read-default-float-format*) `(exp ,arg) `(coerce (exp ,arg) ,*read-default-float-format*))) (defmacro log-coerced (arg &optional (base nil basep)) "Computes log and coerce to *read-default-float-format* if needed doesn't accept a base however" (if (typep (log 1.0) *read-default-float-format*) (if basep `(log ,arg ,base) `(log ,arg)) (if basep `(coerce (log ,arg ,base) ,*read-default-float-format*) `(coerce (log ,arg) ,*read-default-float-format*)))) (defmacro sqrt-coerced (arg) "Computes sqrt and coerce to *read-default-float-format* if needed" (if (typep (sqrt 2.0) *read-default-float-format*) `(sqrt ,arg) `(coerce (sqrt ,arg) ,*read-default-float-format*))) ;;; print-warning ;;; ;;; (defmacro print-warning (control-string &rest args)) ;;; ;;; control-string is a control-string as would be passed to the format function ;;; args are the arguments to use in that control string ;;; ;;; control-string and args are passed to format on the stream *error-output* ;;; with the text "#|Warning: " proceeding it and "|#" after it so that it would ;;; appear as a comment if the stream were to be read. ;;; ;;; nil is returned. (defmacro print-warning (message &rest arguments) "Outputs a warning of message and arguments." `(format *error-output* "~&#|Warning: ~@? |#~%" ,message ,@arguments)) (defun hash-table-keys (ht) "Return the list of current keys in a hash-table" (let ((keys nil)) (maphash #'(lambda (key val) (declare (ignore val)) (push key keys)) ht) keys)) (defun ms-round (x) "Rounds a time to the nearest millisecond" (declare (number x)) (/ (round (* x 1000)) 1000.0)) (defun fctornil (x) "Checks if a symbol is a function, function name, or nil" (or (null x) (functionp x) (fboundp x))) (defun tornil (x) "Checks if a symbol is T or NIL" (or (eq x t) (eq x nil))) (defun posnum (x) "Returns T only if is a positive number" (and (numberp x) (plusp x))) (defun nonneg (x) "Returns T only if is a non-negative number" (and (numberp x) (>= x 0.))) (defun numornil (x) "Returns T only if is a number or nil" (or (null x) (numberp x))) (defun posnumornil (x) "Returns T only if is a positive number or nil" (or (null x) (posnum x))) (defun nonnegornil (x) "Returns T only if is a non-negative number or nil" (or (null x) (nonneg x))) (defun numorbool (x) "Returns t only if is a number, T or nil" (or (tornil x) (numberp x))) (defun safe> (val1 val2) "Return t if val1 and val2 are numbers and val1 > val2" (and (numberp val1) (numberp val2) (> val1 val2))) (defun safe>= (val1 val2) "Return t if val1 and val2 are numbers and val1 >= val2" (and (numberp val1) (numberp val2) (>= val1 val2))) (defun safe< (val1 val2) "Return t if val1 and val2 are numbers and val1 < val2" (and (numberp val1) (numberp val2) (< val1 val2))) (defun safe<= (val1 val2) "Return t if val1 and val2 are numbers and val1 <= val2" (and (numberp val1) (numberp val2) (<= val1 val2))) ;;; SPLICE-INTO-LIST [Function] ;;; Date : 97.01.15 ;;; Description : (defun splice-into-list (lis position item) (let ((temp (copy-list lis))) (splice-into-list-des temp position item))) ;;; SPLICE-INTO-LIST-DES [Function] ;;; Date : 97.01.15 ;;; Description : (defun splice-into-list-des (lis position item) (if (= position 0) (push item lis) (if (listp item) (append (subseq lis 0 position) item (nthcdr position lis)) (append (subseq lis 0 position) (list item) (nthcdr position lis))))) ;;; MKLIST [Function] ;;; Description : From Graham's _On Lisp_, make sure we have a list. (defun mklist (obj) "If the object is not a list, return a list containing the object" (if (listp obj) obj (list obj))) ;;; Theoretically, these are part of the printing module, but ;;; since they are macros that are used by lots of the internal ;;; functions they need to be defined early in the loading. (defmacro model-output (control-string &rest args) (let ((module (gensym)) (present (gensym))) `(multiple-value-bind (,module ,present) (get-module-fct 'printing-module) (when (and ,present (act-r-output-stream (printing-module-v ,module))) (format (act-r-output-stream (printing-module-v ,module)) "~&~@?~%" ,control-string ,@args))))) (defmacro command-output (control-string &rest args) (let ((module (gensym)) (present (gensym))) `(multiple-value-bind (,module ,present) (get-module-fct 'printing-module) (when (and ,present (not (printing-module-suppress-cmds ,module)) (act-r-output-stream (printing-module-c ,module))) (format (act-r-output-stream (printing-module-c ,module)) "~&~@?~%" ,control-string ,@args))))) (defmacro no-output (&rest commands) "Suppress command output while evaluating ACT-R commands" (let ((module (gensym)) (present (gensym)) (current (gensym))) `(multiple-value-bind (,module ,present) (get-module-fct 'printing-module) (when ,present (let ((,current (printing-module-suppress-cmds ,module))) (setf (printing-module-suppress-cmds ,module) t) (unwind-protect (progn ,@commands) (setf (printing-module-suppress-cmds ,module) ,current))))))) ;;; Put this in for now because while the output goes to the ;;; same place, the streams aren't equal between *error-output* ;;; and *standard-output* so it ends up doubling the model warnings. ;;; I do NOT like this solution, but for now it's the easiest/only ;;; way I can come up with. (defparameter *one-stream-hack* #+:digitool t #-:digitool nil) (defmacro model-warning (control-string &rest args) (let ((module (gensym)) (present (gensym)) (stream (gensym))) `(multiple-value-bind (,module ,present) (get-module-fct 'printing-module) (when (and ,present (act-r-output-stream (printing-module-v ,module))) (let ((,stream (act-r-output-stream (printing-module-v ,module)))) (cond ((null (printing-module-model-warnings ,module)) ;; just suppress the warnings nil) ((or (null ,stream) (eq ,stream *error-output*) *one-stream-hack* (and (eq ,stream t) (eql *error-output* *standard-output*))) (format *error-output* "~&#|Warning: ~@? |#~%" ,control-string ,@args)) (t (format *error-output* "~&#|Warning: ~@? |#~%" ,control-string ,@args) (format ,stream "~&#|Warning: ~@? |#~%" ,control-string ,@args) nil))))))) (defmacro meta-p-output (control-string &rest args) (let ((module (gensym)) (present (gensym)) (stream (gensym)) (model (gensym)) (used-streams (gensym)) (key (gensym)) (previous-model (gensym))) `(if (current-mp) (progn (let ((,used-streams nil) (,previous-model (current-model-struct))) (maphash (lambda (,key ,model) (declare (ignore ,key)) (setf (meta-p-current-model (current-mp)) ,model) (multiple-value-bind (,module ,present) (get-module-fct 'printing-module) (when (and ,present (act-r-output-stream (printing-module-v ,module))) (let ((,stream (act-r-output-stream (printing-module-v ,module)))) (unless (member ,stream ,used-streams) (push ,stream ,used-streams) (format ,stream "~&~@?~%" ,control-string ,@args)))))) (meta-p-models (current-mp))) (setf (meta-p-current-model (current-mp)) ,previous-model)) nil) (print-warning "No current meta-process in call to meta-p-output")))) (defun rad->deg (r) "Converts radians into degrees." (declare (number r)) (* r (/ 180 pi))) (defun deg->rad (d) "Converts degrees into radians." (declare (number d)) (* (/ pi 180) d)) (defmacro px (vpt) "X coordinate of an XY vector." `(svref ,vpt 0)) (defmacro py (vpt) "Y coordinate of an XY vector." `(svref ,vpt 1)) (defmacro vr (vrt) "R component of an r-theta vector." `(svref ,vrt 0)) (defmacro vtheta (vrt) "Theta component of an r-theta vector." `(svref ,vrt 1)) (defun vpt= (vpt1 vpt2) (and (= (px vpt1) (px vpt2)) (= (py vpt1) (py vpt2)))) (defun round-xy (loc) (map 'vector #'round loc)) (defgeneric polar-move-xy (loc move) (:documentation "Given an xy location and a polar displacement, return new xy")) (defmethod polar-move-xy ((loc vector) (move vector)) (round-xy (list (+ (px loc) (* (px move) (cos (py move)))) (+ (py loc) (* (px move) (sin (py move))))))) (defmethod polar-move-xy ((loc list) (move list)) (polar-move-xy (coerce loc 'vector) (coerce move 'vector))) ;;; DIST [Function] ;;; Description : Computes the distance between two locations (xy pairs, not ;;; : chunks) using the 'real' hypoteneuse distance. (defgeneric dist (loc1 loc2) (:documentation "Computes the distance in pixels between two XY locations")) (defmethod dist ((loc1 vector) (loc2 vector)) (sqrt-coerced (+ (expt-coerced (- (px loc1) (px loc2)) 2) (expt-coerced (- (py loc1) (py loc2)) 2)))) (defmethod dist ((loc1 list) (loc2 list)) (dist (coerce loc1 'vector) (coerce loc2 'vector))) (defgeneric objs-match-slotval (lst slot-name value) (:documentation "Takes a list of CLOS objects and returns a list containing those items which have the slot equal to .")) (defmethod objs-match-slotval ((ls list) (slot-name symbol) value) (when ls (let (accum) (dolist (obj ls (nreverse accum)) (when (equal value (slot-value obj slot-name)) (push obj accum)))))) (defmethod objs-match-slotval ((ls list) (slot-name symbol) (value number)) (when ls (let (accum) (dolist (obj ls (nreverse accum)) (when (= value (slot-value obj slot-name)) (push obj accum)))))) (defmethod objs-match-slotval ((ls list) (slot-name symbol) (value symbol)) (when ls (let (accum) (dolist (obj ls (nreverse accum)) (when (eq value (slot-value obj slot-name)) (push obj accum)))))) (defgeneric objs-min-slotval (lst slot-name) (:documentation "Given a list of CLOS objects and a slot name, return a list containing the object(s) with the lowest value for that slot.")) (defmethod objs-min-slotval ((ls list) (slot-name symbol)) (when ls (let ((best (slot-value (first ls) slot-name)) (current nil) (out-ls (list (first ls)))) (dolist (obj (rest ls) (nreverse out-ls)) (setf current (slot-value obj slot-name)) (cond ((= current best) (push obj out-ls)) ((< current best) (setf best current) (setf out-ls (list obj)))))))) (defgeneric objs-max-slotval (lst slot-name) (:documentation "Given a list of CLOS objects and a slot name, return a list containing the object(s) with the highest value for that slot.")) (defmethod objs-max-slotval ((ls list) (slot-name symbol)) (when ls (let ((best (slot-value (first ls) slot-name)) (current nil) (out-ls (list (first ls)))) (dolist (obj (rest ls) (nreverse out-ls)) (setf current (slot-value obj slot-name)) (cond ((= current best) (push obj out-ls)) ((> current best) (setf best current) (setf out-ls (list obj)))))))) (defgeneric objs-nearest-slotval (lst slot-name val) (:documentation "Given a list of CLOS objects and a slot name, return a list containing the objects with the slot value closest to the supplied value.")) (defmethod objs-nearest-slotval ((lst list) (slot-name symbol) (val number)) (let ((best (abs (- val (slot-value (first lst) slot-name)))) (current nil) (out-lst (list (first lst)))) (dolist (obj (rest lst) (nreverse out-lst)) (setf current (abs (- val (slot-value obj slot-name)))) (cond ((= current best) (push obj out-lst)) ((< current best) (setf best current) (setf out-lst (list obj))))))) ;;; MKSTR [Function] ;;; Date : 97.07.02 ;;; Description : From Graham's _On Lisp_, makes sure we have a string. (defun mkstr (&rest args) "Return a concatenated string representation of the arguments" (with-output-to-string (s) (dolist (a args) (princ a s)))) (defgeneric random-item (seq) (:documentation "Returns a random item from a sequence using act-r-random.")) (defmethod random-item ((seq list)) (nth (act-r-random (length seq)) seq)) #+:mcl (defmethod random-item ((seq simple-vector)) (svref seq (act-r-random (length seq)))) #-(or :mcl :clisp) (defmethod random-item ((seq vector)) (svref seq (act-r-random (length seq)))) (defmethod random-item ((seq sequence)) (elt seq (act-r-random (length seq)))) (defmethod random-item ((seq null)) (declare (ignore seq)) nil) (defun sym->key (symbol) "Given a symbol, return the corresponding keyword." (read-from-string (mkstr ":" symbol))) ;;; FLATTEN [Function] ;;; Description : From Graham's _On Lisp_, takes a nested list and turns it ;;; : into a flat one. "Fast" version. (defun flatten (lis) "Takes a nested list and makes in into a single-level list" (declare (list lis)) (labels ((rec (lis acc) (cond ((null lis) acc) ((atom lis) (cons lis acc)) (t (rec (car lis) (rec (cdr lis) acc)))))) (rec lis nil))) #-(or :mcl :cmu) (defmacro dovector ((varsym vec &optional ret) &body body) (let ((idx (gensym))) `(let ((,varsym nil)) (dotimes (,idx (length ,vec) ,ret) (setq ,varsym (aref ,vec ,idx)) ,@body )))) (defgeneric within (min max) (:documentation "Returns a closure that will test whether the argument is betwen and , inclusive.")) (defmethod within ((min number) (max number)) (lambda (val) (and (numberp val) (<= val max) (>= val min)))) ;;(defmethod within ((min list) (max list)) ;; (within (check-fct min) (check-fct max))) ;;(defmethod within ((min number) (max list)) ;; (within min (check-fct max))) ;;(defmethod within ((min list) (max number)) ;; (within (check-fct min) max)) (defgeneric greater-than (criterion) (:documentation "Returns a closure that will return whether or not the argument is greater than .")) (defmethod greater-than ((criterion number)) (lambda (val) (and (numberp val) (> val criterion)))) ;;(defmethod greater-than ((criterion list)) ;; (greater-than (check-fct criterion))) (defgeneric less-than (criterion) (:documentation "Returns a closure that will return whether or not the argument is less than .")) (defmethod less-than ((criterion number)) (lambda (val) (and (numberp val) (< val criterion)))) ;;(defmethod less-than ((criterion list)) ;; (less-than (check-fct criterion))) (defun not-equal (x) (declare (inline not-equal)) (lambda (val) (not (equal x val)))) #-:mcl (defun neq (x y) "The NOT of EQ." (declare (inline neq)) (not (eq x y))) (defmethod string-to-lines ((s string)) (aif (position #\Newline s) (append (mklist (subseq s 0 it)) (string-to-lines (subseq s (1+ it) (length s)))) (list s))) ;;; A specific value of nil may be important to some things, so that's why it ;;; returns a second value of t on success. (defun verify-single-explicit-value (slot-specs module cmd slot) (cond ((zerop (length slot-specs)) (print-warning "~a command to ~s module requires a value for the ~a slot." cmd module slot)) ((> (length slot-specs) 1) (print-warning "~a slot may only be specified once in a ~a command to the ~s module." slot cmd module)) ((not (eql '= (caar slot-specs))) (print-warning "~a slot may only have the = modifier in a ~a command to the ~s module." slot cmd module)) ((chunk-spec-variable-p (third (car slot-specs))) (print-warning "~a slot must be explict - not a variable in a ~a command to the ~s module." slot cmd module)) (t (values (third (car slot-specs)) t)))) #| 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 |# ;; /Users/ritter/ritter/proposals/onr-emotions4/iccm07/actr6-15jan07/framework/misc-utils.lisp ;; **************************************************************** ;; **************************************************************** ;; /Users/ritter/ritter/proposals/onr-emotions4/iccm07/actr6-15jan07/framework/meta-process.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 : meta-process.lisp ;;; Version : 1.0a1 ;;; ;;; Description : The meta-process handling functions as defined in the ;;; ACT-R 6 software framework API. ;;; ;;; ;;; Bugs : ;;; ;;; To do : [ ] Improve on the max-time-delta situation for multiple models. ;;; ;;; ----- History ----- ;;; ;;; 2004.08.11 Dan ;;; : Creation. ;;; 2005.02.28 Dan ;;; : * Made the with-meta-process macro hygienic. ;;; 2006.02.27 Dan ;;; : * Added the mp-real-time-management function to allow one to ;;; : configure external time sources. ;;; 2006.03.03 Dan ;;; : * Updated mp-real-time-management to add the max-time-delta ;;; : parameter. This provides a solution for a problem that can ;;; : occur when hooking a model up to an asynchronous system. ;;; : The problem is that if there aren't any model events to ;;; : process at some point the model just jumps right to its end ;;; : time and waits for real time to catch up and asynchronous ;;; : events that come in effectively get pushed off until then. ;;; : This effectively provides the maximum amount of time that ;;; : the model will "skip ahead" without some event occuring. ;;; : This still isn't perfect for a multi-model situation because ;;; : it only works at the meta-process level and thus one model ;;; : could still end up skipping way ahead if other models were ;;; : still doing things, but it's better than nothing right now. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; General Docs: ;;; ;;; The global *meta-processes* and the corresponding struct are not part of ;;; the API, so should not be touched by module writers or modelers. ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Public API: ;;; ;;; ;;; mp-time ;;; mp-time returns the current time of the current meta-process in seconds. ;;; ;;; mp-models ;;; mp-models returns a list of the names of all the models defined in the current meta-process. ;;; ;;; meta-process-names ;;; meta-process-names returns a list of the names of all the existing meta-processes. ;;; ;;; mp-show-queue ;;; mp-show-queue prints the events that are on the event queue of the current meta-process ;;; to *standard-output* in the order that they would be executed. ;;; ;;; mp-show-waiting ;;; mp-show-waiting prints the events that are in the waiting queue of the current meta-process ;;; along with a description of the condition for which each needs to be added to the event queue to *standard-output*. ;;; ;;; mp-print-versions ;;; mp-print-versions prints the version number of the framework and the name, ;;; version number, and documentation of each module which is currently defined to *standard-output*. ;;; ;;; define-meta-process (mp-name) ;;; If there is no meta-process with the name mp-name already defined then one is created. ;;; ;;; delete-meta-process (mp-name) ;;; If there is a meta-process with the name mp-name, then all of the models in that meta-process ;;; are deleted and then the meta-process itself is removed. ;;; ;;; with-meta-process (mp-name &body body)) ;;; If mp-name is the name of a meta-process then the forms of the body are evaluated in order with the ;;; current meta-process set to the one named by mp-name. ;;; ;;; current-meta-process ;;; current-meta-process returns the name of the current meta-process or nil ;;; if there is no current meta-process. ;;; ;;; mp-real-time-management (&key (time-function 'get-internal-real-time) ;;; (units-per-second internal-time-units-per-second) ;;; (slack-function 'real-time-slack) ;;; (max-time-delta nil)) ;;; mp-real-time-management sets the function and divisor used to determine the ;;; current time in seconds when then real-time flag is specified to run the ;;; meta-process. The slack function is called continuously while the model ;;; is waiting for the time to advance when there is a discrepancy. It must take ;;; one parameter which will be the current delta between the model time and ;;; the currently reported "real time". The max-time-delta specifies how far ;;; the model will "skip ahead" - the maximum time between any two model events ;;; in simulation time. When it is nil the delta is unbounded. ;;; The default behavior is tied to the real clock, it calls the sleep function ;;; if the model has to spin for greater than 150ms, and there is no limit on ;;; how far ahead it can advance in one step. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Design Choices: ;;; ;;; Using structs for now because I don't need the flexibility of CLOS classes. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; 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 top level tabel that holds all the meta-processes. (defmacro current-mp () `(mps-current *meta-processes*)) (defun current-mp-fct () (mps-current *meta-processes*)) ;;; Holds all the meta-processes that have been defined and indicates ;;; which is the current one. (defvar *meta-processes* (make-meta-processes) "The table of all defined meta-processes") (defun get-mp (mp-name) (gethash mp-name (mps-table *meta-processes*))) (defun reset-mp (meta-process) "Set a meta-process to time 0 and clear the events" (setf (meta-p-time meta-process) 0.0) (setf (meta-p-start-time meta-process) nil) (setf (meta-p-start-real-time meta-process) nil) (setf (meta-p-events meta-process) nil) (setf (meta-p-delayed meta-process) nil) (mp-real-time-management :mp meta-process)) (defmacro verify-current-mp (warning &body body) `(if (null (mps-current *meta-processes*)) (print-warning ,warning) (progn ,@body))) (defun mp-time () "returns the current time of the current meta-process in seconds" (verify-current-mp "mp-time called with no current meta-process." (meta-p-time (current-mp)))) (defun mp-real-time-management (&key (mp (current-mp-fct)) (time-function 'get-internal-real-time) (units-per-second internal-time-units-per-second) (slack-function 'real-time-slack) (max-time-delta nil)) (when mp (setf (meta-p-time-function mp) time-function) (setf (meta-p-units-per-second mp) units-per-second) (setf (meta-p-slack-function mp) slack-function) (setf (meta-p-max-time-delta mp) max-time-delta))) (defun mp-models () "returns a list of the names of all the models in the current meta-process" (verify-current-mp "mp-models called with no current meta-process." (hash-table-keys (meta-p-models (current-mp))))) (defun meta-process-names () (hash-table-keys (mps-table *meta-processes*))) (defun mp-show-queue () (verify-current-mp "mp-show-queue called with no current meta-process." (let ((events (meta-p-events (current-mp)))) (format t "Events in the queue:~%") (dolist (evt events (length events)) (format t "~A~%" (format-event evt)))))) (defun mp-show-waiting () (verify-current-mp "mp-show-waiting called with no current meta-process." (let ((events (meta-p-delayed (current-mp)))) (format t "Events waiting to be scheduled:~%") (dolist (evt events (length events)) (format t "~A~%" (format-event evt)))))) (defun mp-print-versions () (format t "ACT-R Version Information:~%~va: ~10a ~a~%" (max (max-module-name-length) 10) "Framework" (meta-p-version (gethash 'default (mps-table *meta-processes*))) (meta-p-documentation (gethash 'default (mps-table *meta-processes*)))) (maphash #'(lambda (key value) (declare (ignore key)) (format t "~va: ~10a ~a~%" (max (max-module-name-length) 10) (act-r-module-name value) (act-r-module-version value) (act-r-module-documentation value))) (global-modules-table))) (defmacro define-meta-process (mp-name) `(define-meta-process-fct ',mp-name)) (defun define-meta-process-fct (mp-name) (if (not (symbolp mp-name)) (print-warning "~S is not a symbol and thus not valid as a meta-process name.") (if (gethash mp-name (mps-table *meta-processes*)) (print-warning "There is already a meta-process named ~S." mp-name) (let ((mp (make-meta-process :name mp-name))) (setf (gethash mp-name (mps-table *meta-processes*)) mp) (incf (mps-count *meta-processes*)) (setf (mps-current *meta-processes*) nil) mp-name)))) (defmacro delete-meta-process (mp-name) `(delete-meta-process-fct ',mp-name)) (defun delete-meta-process-fct (mp-name) (if (eql mp-name 'default) (print-warning "Cannot delete the default meta-process.") (if (gethash mp-name (mps-table *meta-processes*)) (let ((previous-mp (current-mp))) (setf (mps-current *meta-processes*) (gethash mp-name (mps-table *meta-processes*))) (maphash #'(lambda (key model) (declare (ignore model)) (delete-model-fct key)) (meta-p-models (gethash mp-name (mps-table *meta-processes*)))) (remhash mp-name (mps-table *meta-processes*)) (decf (mps-count *meta-processes*)) (if (= 1 (mps-count *meta-processes*)) (setf (mps-current *meta-processes*) (gethash 'default (mps-table *meta-processes*))) (setf (mps-current *meta-processes*) previous-mp)) t ) (print-warning "~S does not name a meta-process.")))) (defmacro with-meta-process (mp-name &body body) (let ((mp (gensym)) (old-mp (gensym))) `(let ((,mp (gethash ',mp-name (mps-table *meta-processes*)))) (if ,mp (let ((,old-mp (current-mp))) (setf (mps-current *meta-processes*) ,mp) (unwind-protect (progn ,@body) (setf (mps-current *meta-processes*) ,old-mp))) (print-warning "No actions taken in with-meta-process because ~S does not name a meta-process" ',mp-name))))) (defun with-meta-process-fct (mp-name forms-list) (let ((with-mp (gethash mp-name (mps-table *meta-processes*)))) (if with-mp (let ((previous-mp (current-mp)) (val nil)) (setf (mps-current *meta-processes*) with-mp) (unwind-protect (dolist (x forms-list val) (setf val (eval x))) (setf (mps-current *meta-processes*) previous-mp))) (print-warning "No actions taken in with-meta-process-fct because ~S does not name a meta-process" mp-name)))) (defun current-meta-process () (when (current-mp) (meta-p-name (current-mp)))) (define-meta-process default) (setf (mps-current *meta-processes*) (gethash 'default (mps-table *meta-processes*))) #| 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 |# ;; /Users/ritter/ritter/proposals/onr-emotions4/iccm07/actr6-15jan07/framework/meta-process.lisp ;; **************************************************************** ;; **************************************************************** ;; /Users/ritter/ritter/proposals/onr-emotions4/iccm07/actr6-15jan07/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 |# ;; /Users/ritter/ritter/proposals/onr-emotions4/iccm07/actr6-15jan07/framework/chunk-types.lisp ;; **************************************************************** ;; **************************************************************** ;; /Users/ritter/ritter/proposals/onr-emotions4/iccm07/actr6-15jan07/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-nam