;; 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-name ',value)) (defun set-chunk-slot-value-fct (chunk-name slot-name value) "Set the value of a chunk's slot" (let ((c (get-chunk-warn chunk-name))) (when c (if (valid-slot-name slot-name (act-r-chunk-chunk-type c)) (progn (when (and value (symbolp value) (not (chunk-p-fct value)) (not (numberp value)) (not (eq t value))) (create-undefined-chunk value)) (setf (act-r-chunk-copied-from c) nil) ;(setf (cdr (find slot-name (act-r-chunk-slot-value-lists c) ; :key #'car)) ; (list value)) ; again with the hash-table (setf (gethash slot-name (act-r-chunk-slot-value-lists c)) value) ) (print-warning "chunk ~S does not have a slot called ~S." chunk-name slot-name))))) (defmacro mod-chunk (chunk-name &rest modifications) "Modify the slot values of a chunk" `(mod-chunk-fct ',chunk-name ',modifications)) (defun mod-chunk-fct (chunk-name modifications-list) "Modify the slot values of a chunk" (let ((c (get-chunk-warn chunk-name))) (when c (if (oddp (length modifications-list)) (print-warning "Odd length modifications list in call to mod-chunk.") (let ((slots nil) (slots-and-values nil)) (do ((s modifications-list (cddr s))) ((null s)) (push (car s) slots) (push (list (car s) (second s)) slots-and-values)) (cond ((not (every #'(lambda (slot) (valid-slot-name slot (act-r-chunk-chunk-type c))) slots)) (print-warning "Invalid slot name in modifications list.")) ((not (= (length slots) (length (remove-duplicates slots)))) (print-warning "Slot name used more than once in modifications list.")) (t (dolist (slot-value slots-and-values chunk-name) (set-chunk-slot-value-fct chunk-name (first slot-value) (second slot-value)))))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; to potentially speed things way up provide un-checked but fast accessors ;;; to the chunk info... (defun fast-chunk-slot-value-fct (chunk-name slot-name) "Return the value of a slot for the named chunk without testing validity" (let ((c (get-chunk chunk-name))) (when c (chk-slot-value c slot-name)))) (defun fast-set-chunk-slot-value-fct (chunk-name slot-name value) "Set the value of a chunk's slot without testing validity" (let ((c (get-chunk chunk-name))) (when c (when (and value (symbolp value) (not (chunk-p-fct value)) (not (numberp value)) (not (eq t value))) (create-undefined-chunk value)) (setf (act-r-chunk-copied-from c) nil) ;(setf (cdr (find slot-name (act-r-chunk-slot-value-lists c) ; :key #'car)) ; (list value)) ; again with the hash-table (setf (gethash slot-name (act-r-chunk-slot-value-lists c)) value) ))) (defun fast-mod-chunk-fct (chunk-name modifications-list) "Modify the slot values of a chunk without testing validity" (let ((c (get-chunk chunk-name))) (when c (unless (oddp (length modifications-list)) (loop (when (null modifications-list) (return)) (fast-set-chunk-slot-value-fct chunk-name (pop modifications-list) (pop modifications-list))) chunk-name)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defmacro delete-chunk (chunk-name) "Delete a chunk from a model" `(delete-chunk-fct ',chunk-name)) (defun delete-chunk-fct (chunk-name) "Delete a chunk from a model" (let ((c (get-chunk-warn chunk-name))) (when c (maphash #'(lambda (key value) (when (eq value c) (remhash key (act-r-model-chunks-table (current-model-struct))))) (act-r-model-chunks-table (current-model-struct))) chunk-name))) (defmacro merge-chunks (chunk-name1 chunk-name2) "Merge two chunks into a single representation" `(merge-chunks-fct ',chunk-name1 ',chunk-name2)) (defun merge-chunks-fct (chunk-name1 chunk-name2) "Merge two chunks into a single representation" (let ((c1 (get-chunk-warn chunk-name1)) (c2 (get-chunk-warn chunk-name2))) (when (and c1 c2) (unless (chunk-equal-test c1 c2) (return-from merge-chunks-fct nil)) (unless (eq c1 c2) (dolist (param *chunk-parameters-list*) (when (act-r-chunk-parameter-merge param) (setf (gethash (act-r-chunk-parameter-name param) (act-r-chunk-parameter-values c1)) (funcall (act-r-chunk-parameter-merge param) chunk-name1 chunk-name2)))) #| (maphash #'(lambda (key value) (when (eq value c2) (setf (gethash key (act-r-model-chunks-table (current-model-struct))) c1))) (act-r-model-chunks-table (current-model-struct))) |# ;; merge the specific chunk (setf (gethash chunk-name2 (act-r-model-chunks-table (current-model-struct))) c1) ;; merge any that it had been merged with previously (dolist (merge-chunk (act-r-chunk-merge-list c2)) (setf (gethash merge-chunk (act-r-model-chunks-table (current-model-struct))) c1)) ;; save the new on as merged with the old (push chunk-name2 (act-r-chunk-merge-list c1)) ;; save any the new had been merged with with the old (setf (act-r-chunk-merge-list c1) (append (act-r-chunk-merge-list c1) (act-r-chunk-merge-list c2))) ;; clear the list for the new chunk (setf (act-r-chunk-merge-list c2) nil)) chunk-name1))) (defmacro eq-chunks (chunk-name1 chunk-name2) "Return t if two chunks have the same underlying representation" `(eq-chunks-fct ',chunk-name1 ',chunk-name2)) (defun eq-chunks-fct (chunk-name1 chunk-name2) "Return t if two chunks have the same underlying representation" (let ((c1 (get-chunk-warn chunk-name1)) (c2 (get-chunk-warn chunk-name2))) (and c1 c2 (eq c1 c2)))) (defmacro true-chunk-name (chunk-name) "Return the prototypical name of a chunk in the event of merging" `(true-chunk-name-fct ',chunk-name)) (defun true-chunk-name-fct (chunk-name) "Return the prototypical name of a chunk in the event of merging" (let ((c (get-chunk chunk-name))) (if c (act-r-chunk-name c) chunk-name))) (defmacro equal-chunks (chunk-name1 chunk-name2) "Return t if two chunks are of the same chunk-type and have equal slot values" `(equal-chunks-fct ',chunk-name1 ',chunk-name2)) (defun equal-chunks-fct (chunk-name1 chunk-name2) "Return t if two chunks are of the same chunk-type and have equal slot values" (let ((c1 (get-chunk-warn chunk-name1)) (c2 (get-chunk-warn chunk-name2))) (chunk-equal-test c1 c2))) (defun chunk-equal-test (c1 c2) "Internal function for comparing the equality of two chunks" (and c1 c2 (or (eq c1 c2) (and (eq (act-r-chunk-chunk-type c1) (act-r-chunk-chunk-type c2)) (every #'(lambda (slot-name) (equal-compare-slot-values (chk-slot-value c1 slot-name) (chk-slot-value c2 slot-name))) (ct-slot-names (act-r-chunk-chunk-type c1))))))) (defun equal-compare-slot-values (val1 val2) "Internal function for comparing equality of chunk slot values" (cond ((stringp val1) (and (stringp val2) (string-equal val1 val2))) ((and val1 val2 (symbolp val1) (symbolp val2) (get-chunk val1) (get-chunk val2)) (eq-chunks-fct val1 val2)) (t (equal val1 val2)))) #| What was this supposed to be for? (defun slot-value-pairs-from-spec (spec) (apply #'append (mapcar #'(lambda (x) (list (act-r-slot-spec-name x) (cdr (act-r-slot-spec-value x)))) (act-r-chunk-spec-slots spec)))) |# (defmacro extend-chunks (parameter-name &key (default-value nil) (default-function nil) (merge-function nil) (copy-function nil)) "Add new parameters to all chunks" (let ((accessor-name (intern (concatenate 'string "CHUNK-" (string-upcase parameter-name)))) (setf-name (intern (concatenate 'string "CHUNK-" (string-upcase parameter-name) "-SETF")))) (if (find parameter-name *chunk-parameters-list* :key #'act-r-chunk-parameter-name) (progn (print-warning "Parameter ~s already defined for chunks." parameter-name) :duplicate-parameter) `(eval-when (:compile-toplevel :load-toplevel :execute) (when (or (fboundp ',setf-name) (fboundp ',accessor-name)) (print-warning "The following ~:[~;2 ~]warning~:[~;s~] can be ignored for the main ACT-R modules provided, but may be a serious problem if seen otherwise." (and (fboundp ',setf-name) (fboundp ',accessor-name)) (and (fboundp ',setf-name) (fboundp ',accessor-name)))) (when (fboundp ',accessor-name) (print-warning "Function ~s already exists and is being redefined." ',accessor-name)) (when (fboundp ',setf-name) (print-warning "Function ~s already exists and is being redefined." ',setf-name)) (when (find ',parameter-name *chunk-parameters-list* :key #'act-r-chunk-parameter-name) (setf *chunk-parameters-list* (remove ',parameter-name *chunk-parameters-list* :key #'act-r-chunk-parameter-name))) (push (make-act-r-chunk-parameter :name ',parameter-name :default-value ',default-value :default-function ',default-function :merge ',merge-function :copy ',copy-function :accessor ',accessor-name) *chunk-parameters-list*) (defun ,accessor-name (chunk-name) (let ((c (get-chunk chunk-name))) (if c (multiple-value-bind (value exists) (gethash ',parameter-name (act-r-chunk-parameter-values c)) (if exists value (setf (gethash ',parameter-name (act-r-chunk-parameter-values c)) (chunk-parameter-default (find ',parameter-name *chunk-parameters-list* :key #'act-r-chunk-parameter-name) (act-r-chunk-name c))))) (print-warning "Chunk ~s does not exist." chunk-name)))) (defun ,setf-name (chunk-name new-value) (let ((c (get-chunk chunk-name))) (if c (setf (gethash ',parameter-name (act-r-chunk-parameter-values c)) new-value) (print-warning "Chunk ~s does not exist." chunk-name)))) (defsetf ,accessor-name ,setf-name) ',accessor-name)))) (defun normalize-chunk-names (&optional (unintern? nil)) (if (current-model-struct) (let ((possible-removals (mapcan #'(lambda (x) (when (not (eq x (true-chunk-name-fct x))) (list x))) (chunks)))) ;; clean up the chunk references ;; this could take a while (dolist (chunk (chunks)) (dolist (slot (chunk-type-slot-names-fct (chunk-chunk-type-fct chunk))) (when (member (chunk-slot-value-fct chunk slot) possible-removals) (set-chunk-slot-value-fct chunk slot (true-chunk-name-fct (chunk-slot-value-fct chunk slot)))))) (when unintern? (dolist (x possible-removals) (setf (act-r-chunk-merge-list (get-chunk (true-chunk-name-fct x))) (remove x (act-r-chunk-merge-list (get-chunk (true-chunk-name-fct x))))) (remhash x (act-r-model-chunks-table (current-model-struct))) (release-name-fct x)))) (print-warning "No current model in which to normalize chunk names."))) #| This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by the Free Software Foundation; either version 2.1 of the License, or (at your option) any later version. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA |# ;; /Users/ritter/ritter/proposals/onr-emotions4/iccm07/actr6-15jan07/framework/chunks.lisp ;; **************************************************************** ;; **************************************************************** ;; /Users/ritter/ritter/proposals/onr-emotions4/iccm07/actr6-15jan07/framework/modules.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 : modules.lisp ;;; Version : 1.0 ;;; ;;; Description : Code for defining and using the modules. ;;; ;;; Bugs : ;;; ;;; To do : * Finish the documentation. ;;; : X Write an undefine function. ;;; : X Test better so that a module can't be created with models ;;; : already defined otherwise bad things happen. ;;; ;;; ----- History ----- ;;; ;;; 2004.08.13 Dan ;;; : Creation. ;;; ;;; 2004.12.23 Dan ;;; : Modified get-module and get-module-fct so that :device ;;; : returns the current device interface. ;;; 2005.01.12 Dan ;;; : * Since the device is now a true module don't need to ;;; : do the hack listed above - the :device module is the current ;;; : device-interface. ;;; : * Changed the update function so that it gets the old and ;;; : new times as well as the module instance. ;;; 2005.02.22 Dan ;;; : * Updated the to do list with a new issue. ;;; 2005.02.25 Dan ;;; : * Removed the ~\newline usages because that causes problems ;;; : when a Lisp only wants to see native new lines there. ;;; 2005.03.23 Dan ;;; : * Changed how the reset parameter to define-module is ;;; : interpreted to allow for different reset possibilities. ;;; : There are two possible reset functions now - one before ;;; : and one after the parameters take the default values. ;;; : * Added the secondary-reset-module function to support ;;; : the additional reset function. ;;; 2005.03.24 Dan ;;; : * Patched define-module relative to the reset change so ;;; : that it doesn't break on fboundp in Lispworks. ;;; 2005.04.19 Dan ;;; : * Added all-module-names function to make some things easy. ;;; 2005.05.03 Dan ;;; : * Added some more warnings to define-module-fct. ;;; 2005.08.09 Dan ;;; : * Modified define-module so that you can't add a module while ;;; : there are any models defined or any meta-processes other ;;; : than the default. ;;; : * Made undefine-module work now so that one can remove a ;;; : module to redefine it - don't want to make that automatic ;;; : to prevent any module collision issues. ;;; : * Update the version to 1.0. ;;; 2005.08.16 Dan ;;; : * Update query-module so that one can now query "error t" ;;; : or "error nil" but the module writer doesn't have to do ;;; : anything else - just reporting "state error" queries is ;;; : sufficient because the mapping occurs automatically i.e. ;;; : if "state error" returns t then "error t" is t and "error ;;; : nil" is nil or if "state error" is returns nil then "error ;;; : t" is nil and "error nil" is t. ;;; 2006.11.15 Dan ;;; : * Changed the warnings in the buffer-mod-module function to ;;; : be a little clearer. ;;; 2006.11.20 Dan ;;; : * Added the warn-module and warn-module? commands so that ;;; : a module can receive an advance warning of an approaching ;;; : action if it needs to do something. That warning gets ;;; : called when a production which will make a request to the ;;; : module is selected (during the conflict resolution process). ;;; : Right now it's only needed by vision to lock-out the proc- ;;; : display, but other modules may need such functionality too. ;;; : * The warning keywrord parameter has been added to define-module ;;; : for setting the warning function. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; General Docs: ;;; ;;; The globals and structures are not for general use. ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Public API: ;;; ;;; ;;; define-module ;;; ;;; (defmacro define-module (module-name buffer-list ;;; &key (version "Unspecified") (documentation "") ;;; (creation nil) (reset nil) (query nil) ;;; (request nil) (buffer-mod nil) (params nil) ;;; (init-params nil) (delete nil) ;;; (notify-on-clear nil))) ;;; ;;; module-name a symbol that will name the module ;;; buffer-list a list of the buffer name specifications that this module will use ;;; version a string that can be used for version control and bug tracking ;;; documentation a string that describes the module ;;; creation a function, function name or nil ;;; reset a function, function name or nil ;;; query a function, function name or nil ;;; request a function, function name or nil ;;; buffer-mod a function, function name or nil ;;; init-params a function, function name or nil ;;; params a function, function name or nil ;;; delete a function, function name or nil ;;; notify-on-clear a function, function name or nil ;;; ;;; define-module creates a new module for the system which will be referenced by module-name and provides the buffers named in buffer-list as an interface. The operation of the module is controlled by the remaining parameters which are described in detail below. If a module is successfully defined, then module-name is returned. ;;; ;;; If there is already a module named module-name or buffers with any of the names in buffer-list then a warning is displayed, no module is created and nil is returned. ;;; ;;; An element of the buffer-list can be a symbol that names the buffer or a list with additional details about the buffer. If it is a list, then the first element must be a symbol that names the buffer, the second element describes the spreading activation parameter for the buffer, the third specifies any request parameters and the fourth any query parameters. ;;; ;;; The spreading activation description can be a keyword that specifies the parameter to use in setting the activation spreading from the buffer (the default parameter name will be :buffer-activation where buffer is the name of the buffer) or a list of the keyword that specifies the parameter and a default value for the activation parameter (the default default value is 0 and should be left there) or nil if the default values should be used for both (necessary if the third or fourth elements for the buffer details are needed). ;;; ;;; The request parameters specification is a list of the keywords that can be used in any request for this buffer regardless of the chunk-type used in the request. ;;; ;;; The query parameters specification is a list of symbols (not keywords) which can be used as the slot names for a query request. ;;; ;;; ;;; version should be set to a string that indicates in some fashion a version for this module. Every module should have a version and every update to the module should change that version. This will be displayed when the mp-print-versions command is called. ;;; ;;; documentation should be a string that contains some brief documentation about the purpose of the module. This will also be displayed when the mp-print-versions command is called. ;;; ;;; The remainder of the parameters (creation, reset, state, request, buffer-mod, params, delete, and notify-on-clear) are for specifying the functions that interface the module to the framework. Those functions will be called by the framework as necessary. The situations in which they will be called and the parameters that will be passed to them are described below. All of the functions are optional, and by leaving the corresponding parameter as nil, the module will not be called for that particular situation. ;;; ;;; creation ;;; ;;; The creation function will be called only once per instantiation of the module, when a model is first created. The creation function will be passed one parameter which will be the name of the model in which the module is currently being instantiated. ;;; ;;; It should return something that identifies this instance of the module for use by the other functions of the module as described below. The return value of the creation function is the "instance" of this module. If there is no create function for a module the instance will be nil for all instantiations of that module. ;;; ;;; reset ;;; ;;; The reset function will be called after the creation function is called and every time a model containing an instance of the module is reset. The reset function will be passed one parameter which will be the instance of the module for that model. ;;; ;;; The reset function should be used to reinitialize the module and typical tasks would be to define chunk-types and chunks that are used by the module. ;;; ;;; The return value from the reset function is ignored. ;;; ;;; query ;;; ;;; The query function is used to report on the state of the module and its buffer or any other "instant" tests the module provides. It will be called in response to any query request being made to any of the buffers of the module. The query function will be passed four parameters. The first will be the instance of the module for the model in which the buffer request was made. The second will be the name of the buffer to which the request was made, the third will be the name of a slot specification and the fourth will be a value for that slot. ;;; ;;; If the return value from the query function is nil then that indicates that the requested test has failed. Any other value is considered a successful response to the query. ;;; ;;; If a module provides a query function it must be able to respond to the slot state with possible values: busy, free, or error and the slot buffer with possible values: empty, full, or stuffed(?). ;;; ;;; Stylistically, this function should not have any persistent or time delayed effects nor should it schedule any actions because that is what the "true" requests are for and the distinction should be maintained for consistency. ;;; ;;; request ;;; ;;; The request function is used to respond to requests made to the buffers of the module. It will be called in response to requests being made to any of the buffers of the module. The request function will be passed three parameters. The first will be the instance of the module for the model in which the buffer request was made. The second will be the name of the buffer to which the request was made, and the third will be the chunk specification that was sent to the buffer. ;;; ;;; The return value from the request function is ignored. ;;; ;;; Stylistically, this function should schedule events for buffer changes or other actions that it does as a response to the request, particularly if those events are to occur at a future time. ;;; ;;; buffer-mod ;;; ;;; The buffer-mod function is used to respond to requests made to the module to modify the chunk in any of the module's buffers. The buffer-mod function will be passed three parameters. The first will be the instance of the module for the model in which the buffer-mod request was made. The second will be the name of the buffer to which the request was made, and the third will be a list of chunk modifications indicating how to modify the chunk in the buffer. ;;; ;;; The return value from the buffer-mod function is ignored. ;;; ;;; Stylistically, this function should schedule the buffer modification or any other actions that it does as a response to the request, particularly if those events are to occur at a future time. ;;; ;;; init-params ;;; ;;; The init-params function is used to specify the parameter values that are maintained and used by the module. It will be called after the reset function of the module is called. It should take one parameter, which will be the instance of the module in the model in which the request is being made. ;;; ;;; The init-params function should return a list of parameters which have been generated by calling define-parameter. The parameters of that list do not need to be unique i.e. every instance of the module could return the same list of parameters that was built once when the module code was loaded. ;;; ;;; The parameters specified will then be made available to the user through the sgp command and the params function of the module (described next) will be used to control them. ;;; ;;; params ;;; ;;; The params function is used to control the parameters of a module. The params function is called in two situations both in response to the sgp command. It will be either a request for the current value of a parameter of the module or to set a new value for a parameter of the module. ;;; ;;; The params function will be called with two parameters. The first will be the instance of the module in the model in which the request is being made. The second parameter will be either the name of a parameter for the module or a cons. If it is the name of a parameter, then it is a request for the current value of that parameter, and the params function should return that value. ;;; ;;; In the case where the second parameter is a cons, the car is a parameter name and the cdr is a value. This is either a request to set the value of the named parameter if it is owned by the module, or a notification that a non-owned parameter has been changed. If it is a parameter that the module owns then the value is what was passed to sgp and it has already passed the valid test if one was provided when creating the parameter. The function should handle the request to change the parameter however the module needs that to be done, and then return the current value of that parameter. Note that how a module "sets" parameters is entirely up to the module implementer, and there is nothing that requires it to return the same value as the one requested for the setting. ;;; ;;; If the parameter is one which the module does not own, then the value is the one that was returned from the owning module which may or may not be the same as the value which was passed to sgp. For a non-owned parameter the return value of the params function is ignored. ;;; ;;; delete ;;; ;;; The delete function will be called once when a model with an instance of the module is deleted. The delete function will be passed one parameter which will be the instance of the module in the model which is being deleted. ;;; ;;; The return value from the delete function is ignored. ;;; ;;; notify-on-clear ;;; ;;; The notify-on-clear function will be called when any buffer in the model is cleared, regardless of which module defined that buffer. The notify-on-clear function will be passed three parameters. The first will be the instance of the module in that model. The second will be the name of the buffer which is being cleared and the third will be the name of the chunk that is being cleared from that buffer. ;;; ;;; The return value of this function is ignored. ;;; ;;; The reason for such a test is to enable the functioning of the declarative memory module to have chunks enter declarative memory from the buffers without having to "build that in" and could allow for the creation of alternate declarative memory systems that would not require modifying the internals of the framework. I don't foresee any module other than declarative memory using it at this point, but perhaps once it is there maybe other uses will be found. ;;; ;;; ;;; get-module ;;; ;;; (defmacro get-module (module-name)) ;;; (defun get-module-fct (module-name)) ;;; ;;; module-name a symbol which is the name of a module ;;; ;;; If module-name is the name of a module in the current model then the instantiation of that module in the current model is returned. ;;; ;;; If module-name does not name a module in the current model or there is no current model then a warning is printed and nil is returned. ;;; ;;; This exists so that if a module provides functions that are called other than through the buffer it can get the correct instantiation of itself to use. It is not really for general purpose use because the instantiations of a module are really only meaningful within the code of the module. ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Design Choices: ;;; ;;; Redefinition requires explicit removal of the existing module first. ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; 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 modules and details. ;;; Holds all the modules that have been defined. (defvar *modules-lookup* (make-act-r-modules) "The table of all defined modules") ;;; Some macros to hide the global from direct use in other files (defun max-module-name-length () "Length of the longest module's name" (act-r-modules-name-len *modules-lookup*)) (defun global-modules-table () (act-r-modules-table *modules-lookup*)) (defun all-module-names () (hash-table-keys (global-modules-table))) (defun notified-modules () (act-r-modules-notify *modules-lookup*)) (defun updating-modules () (act-r-modules-update *modules-lookup*)) (defmacro define-module (module-name buffer-list params-list &key (version "Unspecified") (documentation "") (creation nil) (reset nil) (query nil) (request nil) (buffer-mod nil) (params nil) (delete nil) (notify-on-clear nil) (update nil) (warning nil)) `(define-module-fct ',module-name ',buffer-list ',params-list :version ',version :documentation ',documentation :creation ',creation :reset ',reset :query ',query :request ',request :buffer-mod ',buffer-mod :params ',params :delete ',delete :notify-on-clear ',notify-on-clear :update ',update :warning ',warning)) (defun define-module-fct (module-name buffer-list params-list &key (version "" version?) (documentation "" docs?) creation reset query request buffer-mod params delete notify-on-clear update warning) (unless (and version? docs?) (print-warning "Modules should always provide a version and documentation string.")) (cond ((or (> 1 (length (meta-process-names))) (not (eq (car (meta-process-names)) 'default))) (print-warning "Cannont create a new module when there is a meta-process other than the default defined.")) ((mp-models) (print-warning "Cannot create a new module when there are models defined.")) ((null module-name) (print-warning "Nil is not a valid module-name. No module defined.")) ((not (symbolp module-name)) (print-warning "~s is not a symbol and thus not a valid module name.~%No module defined." module-name)) ((valid-module-name module-name) (print-warning "Module ~S already exists and cannot be redefined. Delete it with undefine-module first if you want to redefine it." module-name)) ((and buffer-list (null query)) (print-warning "A module with a buffer must support queries.~%Module ~s not defined." module-name)) ((and buffer-list (some #'(lambda (x) (buffer-exists (cond ((listp x) (car x)) (t x)))) buffer-list)) (print-warning "A buffer name requested when defining module ~s is already used by another module." module-name) (print-warning "Existing buffer names are: ~s" (buffers)) (print-warning "Module attempted to create buffers: ~s" buffer-list) (print-warning "Module ~s not defined" module-name)) ((not (or (and (not (listp reset)) (fctornil reset)) ;; for Lispworks (and (listp reset) (<= (length reset) 2) (every #'fctornil reset)))) (print-warning "Reset parameter is not a function, functon name, nil or a list of two such items.")) ((not (and (fctornil creation) (fctornil query) (fctornil request) (fctornil buffer-mod) (fctornil params) (fctornil delete) (fctornil notify-on-clear) (fctornil update))) (print-warning "Invalid parameter for a module call-back function") (do ((items (list creation query request buffer-mod params delete notify-on-clear update warning) (cdr items)) (names '(creation query request buffer-mod params delete notify-on-clear update warning) (cdr names))) ((null items)) (unless (fctornil (car items)) (print-warning "Parameter: ~s is not a function, function name, or nil" (car names)))) (print-warning "Module ~s not defined" module-name)) ((notevery #'act-r-parameter-p params-list) (print-warning "Invalid params-list ~s.~%Module ~s not defined." params-list module-name)) ((and params-list (null params)) (print-warning "Must specify a param function because parameters are used.~%Module ~s not defined." module-name)) (t (let ((buffers (parse-buffers buffer-list)) (parameters (parse-parameters params-list))) (cond ((eq :error buffers) (print-warning "Error in module buffer definitions.~%Module ~s not defined." module-name)) ((eq :error parameters) (print-warning "Error in module parameter definitions.~%Module ~s not defined." module-name)) (t (let ((new-mod (make-act-r-module :name module-name :buffers buffers :version version :documentation documentation :creation creation :reset (if (listp reset) (first reset) reset) :secondary-reset (if (listp reset) (second reset) nil) :query query :request request :buffer-mod buffer-mod :params params :delete delete :notify-on-clear notify-on-clear :update update :warn warning))) (setf (gethash module-name (act-r-modules-table *modules-lookup*)) new-mod) (incf (act-r-modules-count *modules-lookup*)) (when (> (length (format nil "~S" module-name)) (act-r-modules-name-len *modules-lookup*)) (setf (act-r-modules-name-len *modules-lookup*) (length (format nil "~S" module-name)))) (install-buffers module-name buffers) (install-parameters module-name parameters) (when notify-on-clear (push module-name (act-r-modules-notify *modules-lookup*))) (when update (push module-name (act-r-modules-update *modules-lookup*))) module-name))))))) ;;; Since a module can't be redefined interactive creation of new ;;; modules requires a way to get rid of one on the fly (defmacro undefine-module (module-name) `(undefine-module-fct ',module-name)) (defun undefine-module-fct (module-name) (cond ((or (> 1 (length (meta-process-names))) (not (eq (car (meta-process-names)) 'default))) (print-warning "Cannont delete a module when there is a meta-process other than the default defined.")) ((mp-models) (print-warning "Cannot delete a module when there are models defined.")) ((not (valid-module-name module-name)) (print-warning "~S is not the name of a currently defined module." module-name)) (t (uninstall-buffers (act-r-module-buffers (gethash module-name (act-r-modules-table *modules-lookup*)))) (remove-modules-parameters module-name) ;; take it out of the table (remhash module-name (act-r-modules-table *modules-lookup*)) (decf (act-r-modules-count *modules-lookup*)) ;;; if it was the longest name remeasure the rest (when (= (length (format nil "~S" module-name)) (act-r-modules-name-len *modules-lookup*)) (setf (act-r-modules-name-len *modules-lookup*) (apply #'max (mapcar #'(lambda (x) (length (format nil "~S" x))) (all-module-names))))) (setf (act-r-modules-notify *modules-lookup*) (remove module-name (act-r-modules-notify *modules-lookup*))) (setf (act-r-modules-update *modules-lookup*) (remove module-name (act-r-modules-update *modules-lookup*))) t))) (defmacro get-module (module-name) `(get-module-fct ',module-name)) (defun get-module-fct (module-name) (verify-current-mp "get-module called with no current meta-process." (verify-current-model "get-module called with no current model." (multiple-value-bind (mod present) (gethash module-name (act-r-model-modules-table (current-model-struct))) (if present (values mod t) (values (print-warning "~s is not the name of a module in the current model." module-name) nil)))))) (defun get-abstract-module (module-name) (gethash module-name (act-r-modules-table *modules-lookup*))) (defun valid-module-name (name) (if (gethash name (act-r-modules-table *modules-lookup*)) t nil)) (defun process-parameters (module-name param) (let ((instance (get-module-fct module-name)) (module (get-abstract-module module-name))) (if module (when (act-r-module-params module) ;; should be guranteed (funcall (act-r-module-params module) instance param)) (print-warning "There is no module named ~S. Cannot process parameters for it." module-name)))) (defun instantiate-module (module-name model-name) (let ((module (get-abstract-module module-name))) (if module (when (act-r-module-creation module) (funcall (act-r-module-creation module) model-name)) (print-warning "There is no module named ~S. Cannot instantiate it." module-name)))) (defun reset-module (module-name) (let ((module (get-abstract-module module-name))) (if module (multiple-value-bind (instance exists) (get-module-fct module-name) (if exists (when (act-r-module-reset module) (funcall (act-r-module-reset module) instance)) (print-warning "There is no module named ~S in the current model. Cannot reset it." module-name))) (print-warning "There is no module named ~S defined. Cannot reset it." module-name)))) (defun secondary-reset-module (module-name) (let ((module (get-abstract-module module-name))) (if module (multiple-value-bind (instance exists) (get-module-fct module-name) (if exists (when (act-r-module-secondary-reset module) (funcall (act-r-module-secondary-reset module) instance)) (print-warning "There is no module named ~S in the current model. Cannot reset it." module-name))) (print-warning "There is no module named ~S defined. Cannot reset it." module-name)))) (defun query-module (module-name buffer-name query value) (let ((module (get-abstract-module module-name))) (if module (multiple-value-bind (instance exists) (get-module-fct module-name) (if exists (if (act-r-module-query module) (cond ((eq query 'error) (if value (funcall (act-r-module-query module) instance buffer-name 'state 'error) (not (funcall (act-r-module-query module) instance buffer-name 'state 'error)))) (t (funcall (act-r-module-query module) instance buffer-name query value))) (print-warning "Module ~s does not support queries." module-name)) (print-warning "There is no module named ~S in the current model. Cannot query it." module-name))) (print-warning "There is no module named ~S. Cannot query it." module-name)))) (defun warn-module (module-name buffer-name chunk-type) (let ((module (get-abstract-module module-name))) (if module (multiple-value-bind (instance exists) (get-module-fct module-name) (if exists (if (act-r-module-warn module) (funcall (act-r-module-warn module) instance buffer-name chunk-type) (print-warning "Module ~s does not require warnings." module-name)) (print-warning "There is no module named ~S in the current model. Cannot warn it." module-name))) (print-warning "There is no module named ~S. Cannot warn it." module-name)))) (defun warn-module? (module-name) (let ((module (get-abstract-module module-name))) (if module (if (act-r-module-warn module) t nil) (print-warning "There is no module named ~S. Cannot determine if it needs warnings." module-name)))) (defun warn-module (module-name buffer-name chunk-type) (let ((module (get-abstract-module module-name))) (if module (multiple-value-bind (instance exists) (get-module-fct module-name) (if exists (if (act-r-module-warn module) (funcall (act-r-module-warn module) instance buffer-name chunk-type) (print-warning "Module ~s does not require warnings." module-name)) (print-warning "There is no module named ~S in the current model. Cannot warn it." module-name))) (print-warning "There is no module named ~S. Cannot warn it." module-name)))) (defun request-module (module-name buffer-name chunk-spec) (let ((module (get-abstract-module module-name))) (if module (multiple-value-bind (instance exists) (get-module-fct module-name) (if exists (if (act-r-module-request module) (progn (funcall (act-r-module-request module) instance buffer-name chunk-spec) t) (print-warning "Module ~s does not handle requests." module-name)) (print-warning "There is no module named ~S in the current model. Cannot make a request of it." module-name))) (print-warning "There is no module named ~S. Cannot make a request of it." module-name)))) (defun buffer-mod-module (module-name buffer-name chunk-mods) (let ((module (get-abstract-module module-name))) (if module (multiple-value-bind (instance exists) (get-module-fct module-name) (if exists (if (act-r-module-buffer-mod module) (progn (funcall (act-r-module-buffer-mod module) instance buffer-name chunk-mods) t) (print-warning "Module ~s does not support buffer modification requests." module-name)) (print-warning "There is no module named ~S in the current model. Cannot make a buffer modification request using it." module-name))) (print-warning "There is no module named ~S. Cannot make a buffer modification using it." module-name)))) (defun delete-module (module-name) (let ((module (get-abstract-module module-name))) (if module (multiple-value-bind (instance exists) (get-module-fct module-name) (if exists (when (act-r-module-delete module) (funcall (act-r-module-delete module) instance)) (print-warning "There is no module named ~S in the current model. Cannot delete an instance of it." module-name))) (print-warning "There is no module named ~S. Cannot delete an instance of it." module-name)))) (defun notify-module (module-name buffer-name chunk-name) (let ((module (get-abstract-module module-name))) (if module (multiple-value-bind (instance exists) (get-module-fct module-name) (if exists ;; this only gets called if there is such a function ;; so no need to double check it (funcall (act-r-module-notify-on-clear module) instance buffer-name chunk-name) (print-warning "There is no module named ~S in the current model. Cannot notify it of a buffer's clearing." module-name))) (print-warning "There is no module named ~S. Cannot notify it of a buffer's clearing." module-name)))) (defun update-the-module (module-name old-time new-time) (let ((module (get-abstract-module module-name))) (if module (multiple-value-bind (instance exists) (get-module-fct module-name) (if exists ;; this only gets called if there is such a function ;; so no need to double check it (funcall (act-r-module-update module) instance old-time new-time) (print-warning "There is no module named ~S in the current model. Cannot update it." module-name))) (print-warning "There is no module named ~S. Cannot update it." module-name)))) #| This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by the Free Software Foundation; either version 2.1 of the License, or (at your option) any later version. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA |# ;; /Users/ritter/ritter/proposals/onr-emotions4/iccm07/actr6-15jan07/framework/modules.lisp ;; **************************************************************** ;; **************************************************************** ;; /Users/ritter/ritter/proposals/onr-emotions4/iccm07/actr6-15jan07/framework/parameters.lisp ;; ;;; -*- mode: LISP; Syntax: COMMON-LISP; Base: 10 -*- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Author : Dan Bothell ;;; Copyright : (c) 2004 Dan Bothell ;;; Availability: Covered by the GNU LGPL, see LGPL.txt ;;; Address : Department of Psychology ;;; : Carnegie Mellon University ;;; : Pittsburgh, PA 15213-3890 ;;; : db30@andrew.cmu.edu ;;; ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Filename : parameters.lisp ;;; Version : 1.0 ;;; ;;; Description : Functions for defining and accessing parameters. ;;; ;;; Bugs : ;;; ;;; To do : Finish the documentation. ;;; ;;; ----- History ----- ;;; ;;; 2004.08.18 Dan ;;; : Creation. ;;; ;;; 2005.01.04 Dan ;;; : Took some of the newlines out of show-all-parameters. ;;; : Shrunk down to max width of 80 chars. ;;; 2005.01.17 Dan ;;; : * Changed model-output to command-output so that one can ;;; : see sgp printing when :v is nil. ;;; : * Changed the order of sgp's printing so that it's easier ;;; : to see the parameter values. ;;; 2005.02.11 Dan ;;; : * Replaced a reverse with push-last in set-parameters. ;;; 2005.08.10 Dan ;;; : * Added the remove-modules-parameters and remove-parameter ;;; : to support the undefine-module function. ;;; : * Updated the version to 1.0. ;;; 2006.07.12 Dan ;;; : * Modified TEST-AND-SET-PARAMETER-VALUE so that when a value ;;; : failed the validity test :invalid-value is returned for the ;;; : list of parameter values (could return the current setting ;;; : instead, but I think an error marker works better). ;;; : * Also did some reformatting because I find it difficult to ;;; : read some of the code if I keep it to only 80 columns. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; General Docs: ;;; ;;; Internal structures not for external use. ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Public API: ;;; ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Design Choices: ;;; ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; The code ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; #+:packaged-actr (in-package :act-r) #+(and :clean-actr (not :packaged-actr) :ALLEGRO-IDE) (in-package :cg-user) #-(or (not :clean-actr) :packaged-actr :ALLEGRO-IDE) (in-package :cl-user) ;;; Holds all the parameters that have been "registered" with a module. (defvar *act-r-parameters-table* (make-hash-table :test #'eq) "The table of all used parameters") (defun define-parameter (param-name &key (owner t) (valid-test nil) (default-value nil) (warning "") (documentation "")) (cond ((not (keywordp param-name)) (print-warning "Parameter name must be a keyword.")) ((keywordp default-value) (print-warning "default-value cannot be a keyword.")) ((not (stringp documentation)) (print-warning "documentation must be a string.")) ((not (stringp warning)) (print-warning "warning must be a string.")) (t (make-act-r-parameter :owner owner :param-name param-name :default default-value :test valid-test :warning warning :details documentation)))) (defun parse-parameters (parameters-list) "Make sure that they are parameters and not already owned if ownership requested or that it exists if not owned" (if (every #'(lambda (x) (and (act-r-parameter-p x) (or (and (act-r-parameter-owner x) (not (valid-parameter-name (act-r-parameter-param-name x)))) (and (not (act-r-parameter-owner x)) (valid-parameter-name (act-r-parameter-param-name x)))))) parameters-list) parameters-list :error)) (defun install-parameters (module-name parameters) (dolist (x parameters) (if (act-r-parameter-owner x) (let ((param-copy (copy-act-r-parameter x))) (setf (act-r-parameter-owner param-copy) module-name) (setf (gethash (act-r-parameter-param-name param-copy) *act-r-parameters-table*) param-copy)) (push module-name (act-r-parameter-users (get-parameter-struct (act-r-parameter-param-name x))))))) (defun remove-modules-parameters (module-name) "Remove all parameters of the module both owned and watched" (maphash #'(lambda (name param) (when (eq module-name (act-r-parameter-owner param)) (remhash name *act-r-parameters-table*)) (setf (act-r-parameter-users param) (remove module-name (act-r-parameter-users param)))) *act-r-parameters-table*)) (defun remove-parameter (param-name) "Remove a specific parameter from the table" (remhash param-name *act-r-parameters-table*)) (defmacro sgp (&rest parameters) `(sgp-fct ',parameters)) (defun sgp-fct (&optional (parameters-list nil)) (verify-current-mp "sgp called with no current meta-process." (verify-current-model "sgp called with no current model." (set-or-get-parameters parameters-list)))) (defun set-or-get-parameters (params) (if (null params) (show-all-parameters) (if (every #'keywordp params) (get-parameters params) (set-parameters params)))) (defun get-parameters (params &optional (output t)) (let ((res nil)) (dolist (p-name params (reverse res)) (if (valid-parameter-name p-name) (let* ((param (get-parameter-struct p-name)) (owner (act-r-parameter-owner param)) (val (process-parameters owner p-name))) (push val res) (when output (command-output "~S ~S (default ~S) : ~A" p-name val (act-r-parameter-default param) (act-r-parameter-details param)))) (push :bad-parameter-name res))))) (defun get-parameter-struct (p-name) (gethash p-name *act-r-parameters-table*)) (defun valid-parameter-name (p-name) (gethash p-name *act-r-parameters-table*)) (defun set-parameters (params) (if (evenp (length params)) (let ((res nil)) (while params (let ((p-name (pop params)) (p-val (pop params))) (push-last (test-and-set-parameter-value p-name p-val) res))) res) (print-warning "Odd number of parameters and values passed to sgp."))) (defun test-and-set-parameter-value (p-name value) (let ((param (gethash p-name *act-r-parameters-table*))) (if param (if (or (null (act-r-parameter-test param)) (funcall (act-r-parameter-test param) value)) (set-parameter-value param value) (progn (print-warning "Parameter ~S cannot take value ~A because it must be ~A." p-name value (act-r-parameter-warning param)) :invalid-value)) (progn (print-warning "Parameter ~s is not the name of an available parameter" p-name) :bad-parameter-name)))) (defun set-parameter-value (param value) (let* ((current-value (process-parameters (act-r-parameter-owner param) (cons (act-r-parameter-param-name param) value)))) (dolist (s (act-r-parameter-users param) current-value) (process-parameters s (cons (act-r-parameter-param-name param) current-value))))) (defun show-all-parameters () (let ((current-val-table (make-hash-table))) (maphash #'(lambda (p-name param) (push (cons param (process-parameters (act-r-parameter-owner param) p-name)) (gethash (act-r-parameter-owner param) current-val-table))) *act-r-parameters-table*) (let ((name-len (1+ (apply #'max (mapcar #'(lambda (x) (length (string x))) (hash-table-keys *act-r-parameters-table*))))) (default-len (apply #'max (with-hash-table-iterator (generator-fn *act-r-parameters-table*) (let ((items nil)) (loop (multiple-value-bind (more? key value) (generator-fn) (declare (ignore key)) (unless more? (return items)) (push (length (format nil "~s" (act-r-parameter-default value))) items))))))) (value-len (apply #'max (with-hash-table-iterator (generator-fn current-val-table) (let ((items nil)) (loop (multiple-value-bind (more? key value) (generator-fn) (declare (ignore key)) (unless more? (return items)) (dolist (param value) (push (length (format nil "~S" (cdr param))) items))))))))) (maphash #'(lambda (module-name parameters) (command-output "--------------------------------~%~S module" module-name) (command-output "--------------------------------") (dolist (param parameters) (command-output "~vS ~vS default: ~vS : ~A" name-len (act-r-parameter-param-name (car param)) value-len (cdr param) default-len (act-r-parameter-default (car param)) (act-r-parameter-details (car param))))) current-val-table)))) #| 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/parameters.lisp ;; **************************************************************** ;; **************************************************************** ;; /Users/ritter/ritter/proposals/onr-emotions4/iccm07/actr6-15jan07/framework/buffers.lisp ;; ;;; -*- mode: LISP; Syntax: COMMON-LISP; Base: 10 -*- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Author : Dan Bothell ;;; Copyright : (c) 2004 Dan Bothell ;;; Availability: Covered by the GNU LGPL, see LGPL.txt ;;; Address : Department of Psychology ;;; : Carnegie Mellon University ;;; : Pittsburgh, PA 15213-3890 ;;; : db30@andrew.cmu.edu ;;; ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Filename : buffers.lisp ;;; Version : 1.0 ;;; ;;; Description : Functions that define the operation of buffers. ;;; ;;; Bugs : ;;; ;;; To do : [] Finish documentation. ;;; [] Investigate the copy sematics and probably optimize things. ;;; [] Crazy idea - why not treat buffer parameters the same as ;;; chunk parameters and allow them to be user defined? ;;; [] Have all the schedule-* functions allow a details keyword. ;;; ;;; ----- History ----- ;;; ;;; 2004.08.20 Dan ;;; : Creation ;;; ;;; 2004.12.13 Dan ;;; : Added :details to the scheduled buffer events to clean up the ;;; : traces. ;;; : Reduced lines down to max of 80 chars. ;;; 2005.01.17 Dan ;;; : * Removed calls to format in the scheduling. ;;; 2005.01.18 Dan ;;; : * Removed call to get-parameters. ;;; 2005.02.01 Dan ;;; : * Modified buffer-chunk so it prints the chunks as well when ;;; : specific buffers requested. ;;; 2005.02.03 Dan ;;; : * Changed the default output for some functions to 'medium ;;; : or 'low to play friendly with the new detail level. ;;; 2005.02.04 Dan ;;; : * Taking advantage of the fast-* chunk accessors. ;;; 2005.04.19 Dan ;;; : * Added buffers-module-name to add to the API. ;;; 2005.04.23 Dan ;;; : * Added the buffer-status command to print out the queries ;;; : for buffers. Works basically like buffer-chunk. ;;; : * Added the status-printing option to buffer definition ;;; : list (the fifth item) so a module can print extra status ;;; : info with buffer-status. ;;; : * Added the requested keyword to the set-buffer-chunk ;;; : command because the requested (formerly stuffed) status ;;; : of the buffer is being maintained internally now. ;;; : * Updated the query-buffer command to handle buffer ;;; : requested/unrequested instead of passing it to the module. ;;; : * For now, an overwrite always sets the requested to nil, ;;; : but maybe that needs to be user defineable too. ;;; 2005.05.11 Dan ;;; : * Adjusted the params in the schedule-set-buffer-chunk ;;; : call so that requested chunks don't have to show that ;;; : in the trace - only unrequested chunks are marked. ;;; 2005.08.10 Dan ;;; : * Added the uninstall-buffers function to support the ;;; : undefine-modules function. This is not designed to be used ;;; : any other way - buffer removal is a dangerous thing. ;;; : * Updated the version to 1.0. ;;; 2005.08.16 Dan ;;; : * Changes necessary to allow query of error t/nil without ;;; : any change to the module code - a module just has to ;;; : respond to the "state error" query and the query-module ;;; : function handles the mapping now. The change here is ;;; : to add error to the *required-buffer-queries* list ;;; : and to now test that on doesn't try to override a required ;;; : query. ;;; 2006.01.17 Dan ;;; : * Updated the module version to 1.0 since there haven't been ;;; : any problems it's time to drop the "a". ;;; 2006.01.25 Dan ;;; : * Added an option to allow details in schedule-module-request ;;; : to overwrite the default. Should make that change for all ;;; : of the schedule- functions at some point, but for now I ;;; : only need it for the request one... ;;; 2006.07.16 Dan ;;; : * Fixed an issue with buffer-chunk-fct because now that ;;; : more chunk accessors print a warning for nil it has to ;;; : be more careful to avoid lots of warnings. ;;; 2006.11.20 Dan ;;; : * Added require-module-warning? and module-warning to support ;;; : the warning mechanism added to the modules. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; General Docs: ;;; ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Public API: ;;; ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Design Choices: ;;; ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; The code ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; #+:packaged-actr (in-package :act-r) #+(and :clean-actr (not :packaged-actr) :ALLEGRO-IDE) (in-package :cg-user) #-(or (not :clean-actr) :packaged-actr :ALLEGRO-IDE) (in-package :cl-user) (defconstant *required-buffer-queries* '(state buffer error)) (defvar *buffers-table* (make-hash-table)) (defun buffers () (hash-table-keys *buffers-table*)) (defun buffer-exists (name) (multiple-value-bind (buffer present) (gethash name *buffers-table*) (declare (ignore buffer)) present)) (defun parse-buffers (buffer-list) (let ((res nil)) (dolist (buffer-def buffer-list res) (cond ((or (atom buffer-def) (and (listp buffer-def) (= (length buffer-def) 1))) (when (listp buffer-def) (setf buffer-def (car buffer-def))) (cond ((buffer-exists buffer-def) (print-warning "Buffer name ~S already used, cannot reuse it.") (return-from parse-buffers :error)) (t (push (make-act-r-buffer :name buffer-def :queries *required-buffer-queries* :parameter-name (read-from-string (format nil ":~S-activation" buffer-def))) res)))) ((and (listp buffer-def) (buffer-exists (car buffer-def))) (print-warning "Buffer name ~S already used, cannot reuse it.") (return-from parse-buffers :error)) ((not (listp buffer-def)) (print-warning "Invalid buffer specification: ~S" buffer-def) (return-from parse-buffers :error)) ((<= (length buffer-def) 5) (let (param-name param-default requests queries print-status) (if (and (second buffer-def) (listp (second buffer-def))) (cond ((or (> (length (second buffer-def)) 2) (not (keywordp (first (second buffer-def)))) (not (numberp (second (second buffer-def))))) (print-warning "Invalid buffer specification: ~S" buffer-def) (return-from parse-buffers :error)) (t (setf param-name (first (second buffer-def))) (setf param-default (second (second buffer-def))))) (cond ((keywordp (second buffer-def)) (setf param-name (second buffer-def))) ((null (second buffer-def)) (setf param-name (read-from-string (format nil ":~S-activation" (first buffer-def))))) (t (print-warning "Invalid buffer specification: ~S" buffer-def) (return-from parse-buffers :error)))) (when (third buffer-def) (cond ((and (listp (third buffer-def)) (every #'keywordp (third buffer-def))) (setf requests (third buffer-def))) (t (print-warning "Invalid buffer specification: ~S" buffer-def) (return-from parse-buffers :error)))) (when (fourth buffer-def) (cond ((and (listp (fourth buffer-def)) (every #'(lambda (x) (and (symbolp x) (not (keywordp x)) (not (find x *required-buffer-queries*)))) (fourth buffer-def))) (setf queries (fourth buffer-def))) (t (print-warning "Invalid buffer specification: ~S" buffer-def) (return-from parse-buffers :error)))) (when (fifth buffer-def) (cond ((fctornil (fifth buffer-def)) (setf print-status (fifth buffer-def))) (t (print-warning "Invalid buffer specification: ~S" buffer-def) (print-warning "status function not valid") (return-from parse-buffers :error)))) (push (make-act-r-buffer :name (first buffer-def) :queries (append queries *required-buffer-queries*) :requests requests :parameter-name param-name :spread param-default :status-printing print-status :requested nil) res))) (t (print-warning "Invalid buffer specification: ~S" buffer-def) (return-from parse-buffers :error)))))) (defun install-buffers (module-name buffers) (dolist (buffer buffers) (setf (gethash (act-r-buffer-name buffer) *buffers-table*) buffer) (setf (act-r-buffer-module buffer) module-name) (install-parameters 'buffer-params (list (define-parameter (act-r-buffer-parameter-name buffer) :owner t :valid-test #'numberp :default-value (if (null (act-r-buffer-spread buffer)) 0 (act-r-buffer-spread buffer)) :warning "a number" :documentation (format nil "source spread for the ~S buffer" (act-r-buffer-name buffer))))))) (defun uninstall-buffers (buffers) "Necessary for undefining a module" (dolist (buffer buffers) (remhash (act-r-buffer-name buffer) *buffers-table*) (remove-parameter (act-r-buffer-parameter-name buffer)))) (defun create-buffer-param-module (model-name) (declare (ignore model-name)) (make-hash-table)) (defun buffer-params-handler (instance param) (if (consp param) (setf (gethash (car param) instance) (cdr param)) (gethash param instance))) (define-module buffer-params nil nil :version "1.0" :documentation "Module to hold and control the buffer parameters" :creation create-buffer-param-module :params buffer-params-handler) (defun buffer-instance (buffer-name) (verify-current-mp "buffer-instance called with no current meta-process." (verify-current-model "buffer-instance called with no current model." (gethash buffer-name (act-r-model-buffers (current-model-struct)))))) (defmacro buffer-chunk (&rest buffer-names) `(buffer-chunk-fct ',buffer-names)) (defun buffer-chunk-fct (buffer-names-list) (verify-current-mp "buffer-chunk called with no current meta-process." (verify-current-model "buffer-chunk called with no current model." (let ((res nil)) (dolist (buffer-name (if buffer-names-list buffer-names-list (buffers)) res) (let* ((buffer (buffer-instance buffer-name))) (if buffer (let ((chunk (act-r-buffer-chunk buffer))) (command-output "~S: ~S ~@[[~s]~]" buffer-name chunk (when chunk (chunk-copied-from-fct chunk))) (when buffer-names-list (pprint-chunks-fct (list chunk))) (push-last (if buffer-names-list chunk (cons buffer-name chunk)) res)) (push-last (if buffer-names-list :error (cons :error nil)) res)))))))) (defmacro buffer-status (&rest buffer-names) `(buffer-status-fct ',buffer-names)) (defun buffer-status-fct (buffer-names-list) (verify-current-mp "buffer-status called with no current meta-process." (verify-current-model "buffer-status called with no current model." (let ((res nil)) (dolist (buffer-name (if buffer-names-list buffer-names-list (buffers)) res) (let ((buffer (buffer-instance buffer-name))) (if buffer (progn (command-output "~S:" buffer-name) (command-output " buffer empty : ~S" (query-buffer buffer-name '((buffer . empty)))) (command-output " buffer full : ~S" (query-buffer buffer-name '((buffer . full)))) (command-output " buffer requested : ~S" (query-buffer buffer-name '((buffer . requested)))) (command-output " buffer unrequested : ~S" (query-buffer buffer-name '((buffer . unrequested)))) (command-output " state free : ~S" (query-buffer buffer-name '((state . free)))) (command-output " state busy : ~S" (query-buffer buffer-name '((state . busy)))) (command-output " state error : ~S" (query-buffer buffer-name '((state . error)))) (awhen (act-r-buffer-status-printing buffer) (funcall it)) (push-last buffer-name res)) (push-last :error res)))))))) (defun buffer-read (buffer-name) (verify-current-mp "buffer-read called with no current meta-process." (verify-current-model "buffer-read called with no current model." (let ((buffer (buffer-instance buffer-name))) (if buffer (act-r-buffer-chunk buffer) (print-warning "Buffer-read called with an invalid buffer name ~S" buffer-name)))))) (defun schedule-buffer-read (buffer-name time-delta &key (module :none) (priority 0) (output t)) (verify-current-mp "schedule-buffer-read called with no current meta-process." (verify-current-model "schedule-buffer-read called with no current model." (let ((buffer (buffer-instance buffer-name))) (cond ((null buffer) (print-warning "schedule-buffer-read called with an invalid buffer name ~S" buffer-name)) ((not (numberp time-delta)) (print-warning "schedule-buffer-read called with a non-number time-delta: ~S" time-delta)) ((and (not (numberp priority)) (not (eq priority :max)) (not (eq priority :min))) (print-warning "schedule-buffer-read called with an invalid priority ~S" priority)) (t (schedule-event-relative time-delta 'buffer-read-action :module module :priority priority :params (list buffer-name) :output output))))))) (defun buffer-read-report (buffer-name &key (module :none)) (verify-current-mp "buffer-read-report called with no current meta-process." (verify-current-model "buffer-read-report called with no current model." (let ((buffer (buffer-instance buffer-name))) (cond ((null buffer) (print-warning "buffer-read-report called with an invalid buffer name ~S" buffer-name)) (t (schedule-event-relative 0 'buffer-read-action :module module :priority :max :params (list buffer-name) :output t) (act-r-buffer-chunk buffer))))))) (defun buffer-read-action (buffer-name) (declare (ignore buffer-name)) ) (defun query-buffer (buffer-name queries-list) (verify-current-mp "query-buffer called with no current meta-process." (verify-current-model "query-buffer called with no current model." (let ((buffer (buffer-instance buffer-name))) (cond ((null buffer) (print-warning "query-buffer called with an invalid buffer name ~S" buffer-name)) ((not (every #'(lambda (x) (member (car x) (act-r-buffer-queries buffer))) queries-list)) (print-warning "Invalid query-buffer ~S. Available queries to buffer ~S are ~S." queries-list buffer-name (act-r-buffer-queries buffer))) (t (do ((module (act-r-buffer-module buffer)) (queries queries-list (cdr queries))) ((null queries) t) (cond ((eq (caar queries) 'buffer) (case (cdar queries) (full (when (null (act-r-buffer-chunk buffer)) (return-from query-buffer nil))) (empty (unless (null (act-r-buffer-chunk buffer)) (return-from query-buffer nil))) (requested (when (or (null (act-r-buffer-chunk buffer)) (null (act-r-buffer-requested buffer))) (return-from query-buffer nil))) (unrequested (unless (and (act-r-buffer-chunk buffer) (null (act-r-buffer-requested buffer))) (return-from query-buffer nil))) (t (model-warning "Unknown buffer query ~S" (cdar queries)) (return-from query-buffer nil)))) (t (unless (query-module module buffer-name (caar queries) (cdar queries)) (return-from query-buffer nil))))))))))) (defun schedule-query-buffer (buffer-name queries-list time-delta &key (module :none) (priority 0) (output t)) (verify-current-mp "schedule-query-buffer called with no current meta-process." (verify-current-model "schedule-query-buffer called with no current model." (let ((buffer (buffer-instance buffer-name))) (cond ((null buffer) (print-warning "schedule-query-buffer called with an invalid buffer name ~S" buffer-name)) ((not (numberp time-delta)) (print-warning "schedule-query-buffer called with non-nimber time-delta: ~S" time-delta)) ((and (not (numberp priority)) (not (eq priority :max)) (not (eq priority :min))) (print-warning "schedule-query-buffer called with an invalid priority ~S" priority)) (t (schedule-event-relative time-delta 'query-buffer-action :module module :priority priority :params (list buffer-name queries-list) :details (concatenate 'string (symbol-name 'query-buffer-action) " " (symbol-name buffer-name)) :output output))))))) (defun query-buffer-report (buffer-name queries-list &key (module :none)) (verify-current-mp "query-buffer-report called with no current meta-process." (verify-current-model "query-buffer-report called with no current model." (let ((buffer (buffer-instance buffer-name))) (cond ((null buffer) (print-warning "query-buffer-report called with an invalid buffer name ~S" buffer-name)) ((not (every #'(lambda (x) (member (car x) (act-r-buffer-queries buffer))) queries-list)) (print-warning "Invalid query-buffer ~S. Available queries to buffer ~S are ~S." queries-list buffer-name (act-r-buffer-queries buffer))) (t (schedule-event-relative 0 'query-buffer-action :module module :priority :max :params (list buffer-name queries-list) :details (concatenate 'string (symbol-name 'query-buffer-action) " " (symbol-name buffer-name)) :output t) (query-buffer buffer-name queries-list))))))) (defun query-buffer-action (buffer-name queries) (declare (ignore buffer-name queries))) (defun clear-buffer (buffer-name) (verify-current-mp "clear-buffer called with no current meta-process." (verify-current-model "clear-buffer called with no current model." (let ((buffer (buffer-instance buffer-name))) (cond ((null buffer) (print-warning "clear-buffer called with an invalid buffer name ~S" buffer-name)) (t (let ((chunk (act-r-buffer-chunk buffer))) (when chunk (setf (act-r-buffer-chunk buffer) nil) (dolist (module (notified-modules)) (notify-module module buffer-name chunk))) chunk))))))) (defun schedule-clear-buffer (buffer-name time-delta &key (module :none) (priority 0) (output 'low)) (verify-current-mp "schedule-clear-buffer called with no current meta-process." (verify-current-model "schedule-clear-buffer called with no current model." (let ((buffer (buffer-instance buffer-name))) (cond ((null buffer) (print-warning "schedule-clear-buffer called with an invalid buffer name ~S" buffer-name)) ((not (numberp time-delta)) (print-warning "buffer-read-report called with a non-number time-delta: ~S" time-delta)) ((and (not (numberp priority)) (not (eq priority :max)) (not (eq priority :min))) (print-warning "buffer-read-report called with an invalid priority ~S" priority)) (t (schedule-event-relative time-delta 'clear-buffer :module module :priority priority :params (list buffer-name) :output output))))))) (defun set-buffer-chunk (buffer-name chunk-name &key (requested t)) "Forces a copy...." (verify-current-mp "set-buffer-chunk called with no current meta-process." (verify-current-model "set-buffer-chunk called with no current model." (let ((buffer (buffer-instance buffer-name))) (cond ((null buffer) (print-warning "set-buffer-chunk called with an invalid buffer name ~S" buffer-name)) ((null (get-chunk chunk-name)) (print-warning "set-buffer-chunk called with an invalid chunk name ~S" chunk-name)) (t (when (act-r-buffer-chunk buffer) (clear-buffer buffer-name)) (setf (act-r-buffer-chunk buffer) (copy-chunk-fct chunk-name)) (setf (act-r-buffer-requested buffer) requested))))))) (defun schedule-set-buffer-chunk (buffer-name chunk-name time-delta &key (module :none) (priority 0) (output 'low) (requested t)) (verify-current-mp "set-buffer-chunk called with no current meta-process." (verify-current-model "set-buffer-chunk called with no current model." (let ((buffer (buffer-instance buffer-name))) (cond ((null buffer) (print-warning "set-buffer-chunk called with an invalid buffer name ~S" buffer-name)) ((null (get-chunk chunk-name)) (print-warning "set-buffer-chunk called with an invalid chunk name ~S" chunk-name)) ((not (numberp time-delta)) (print-warning "set-buffer-chunk called with time-delta that is not a number: ~S" time-delta)) ((and (not (numberp priority)) (not (eq priority :max)) (not (eq priority :min))) (print-warning "set-buffer-chunk called with an invalid priority ~S" priority)) (t (schedule-event-relative time-delta 'set-buffer-chunk :module module :priority priority :params (if requested (list buffer-name chunk-name) (list buffer-name chunk-name :requested requested)) :output output))))))) (defun overwrite-buffer-chunk (buffer-name chunk-name) "Also forces a copy of the chunk..." (verify-current-mp "overwrite-buffer-chunk called with no current meta-process." (verify-current-model "overwrite-buffer-chunk called with no current model." (let ((buffer (buffer-instance buffer-name))) (cond ((null buffer) (print-warning "overwrite-buffer-chunk called with an invalid buffer name ~S" buffer-name)) ((null (get-chunk chunk-name)) (print-warning "overwrite-buffer-chunk called with an invalid chunk name ~S" chunk-name)) (t (setf (act-r-buffer-chunk buffer) (copy-chunk-fct chunk-name)) (setf (act-r-buffer-requested buffer) nil))))))) (defun schedule-overwrite-buffer-chunk (buffer-name chunk-name time-delta &key (module :none) (priority 0) (output 'low)) (verify-current-mp "overwrite-buffer-chunk called with no current meta-process." (verify-current-model "overwrite-buffer-chunk called with no current model." (let ((buffer (buffer-instance buffer-name))) (cond ((null buffer) (print-warning "overwrite-buffer-chunk called with an invalid buffer name ~S" buffer-name)) ((null (get-chunk chunk-name)) (print-warning "overwrite-buffer-chunk called with an invalid chunk name ~S" chunk-name)) ((not (numberp time-delta)) (print-warning "overwrite-buffer-chunk called with a non-number time-delta: ~S" time-delta)) ((and (not (numberp priority)) (not (eq priority :max)) (not (eq priority :min))) (print-warning "overwrite-buffer-chunk called with an invalid priority ~S" priority)) (t (schedule-event-relative time-delta 'overwrite-buffer-chunk :module module :priority priority :params (list buffer-name chunk-name) :output output))))))) (defun module-warning (buffer-name chunk-type) (verify-current-mp "module-warning called with no current meta-process." (verify-current-model "module-warning called with no current model." (let ((buffer (buffer-instance buffer-name))) (cond ((null buffer) (print-warning "module-warning called with an invalid buffer name ~S" buffer-name)) ((null (chunk-type-p-fct chunk-type)) (print-warning "module-warning called with an invalid chunk-type ~S" chunk-type)) (t (warn-module (act-r-buffer-module buffer) buffer-name chunk-type))))))) (defun require-module-warning? (buffer-name) (verify-current-mp "require-module-warning? called with no current meta-process." (verify-current-model "require-module-warning? called with no current model." (let ((buffer (buffer-instance buffer-name))) (cond ((null buffer) (print-warning "require-module-warning? called with an invalid buffer name ~S" buffer-name)) (t (warn-module? (act-r-buffer-module buffer)))))))) (defun module-request (buffer-name chunk-spec) (verify-current-mp "module-request called with no current meta-process." (verify-current-model "module-request called with no current model." (let ((buffer (buffer-instance buffer-name))) (cond ((null buffer) (print-warning "module-request called with an invalid buffer name ~S" buffer-name)) ((null (act-r-chunk-spec-p chunk-spec)) (print-warning "module-request called with an invalid chunk-spec ~S" chunk-spec)) (t (request-module (act-r-buffer-module buffer) buffer-name chunk-spec))))))) (defun schedule-module-request (buffer-name chunk-spec time-delta &key (module :none) (priority 0) (output 'medium) (details nil)) (verify-current-mp "schedule-module-request called with no current meta-process." (verify-current-model "schedule-module-request called with no current model." (let ((buffer (buffer-instance buffer-name))) (cond ((null buffer) (print-warning "schedule-module-request called with an invalid buffer name ~S" buffer-name)) ((null (act-r-chunk-spec-p chunk-spec)) (print-warning "schedule-module-request called with an invalid chunk-spec ~S" chunk-spec)) ((not (numberp time-delta)) (print-warning "schedule-module-request called with a non-number time-delta: ~S" time-delta)) ((and (not (numberp priority)) (not (eq priority :max)) (not (eq priority :min))) (print-warning "schedule-module-request called with an invalid priority ~S" priority)) (t (schedule-event-relative time-delta 'module-request :module module :priority priority :params (list buffer-name chunk-spec) :details (if (stringp details) details (concatenate 'string (symbol-name 'module-request) " " (symbol-name buffer-name))) :output output))))))) (defun module-mod-request (buffer-name modification) (verify-current-mp "module-mod-request called with no current meta-process." (verify-current-model "module-mod-request called with no current model." (let ((buffer (buffer-instance buffer-name))) (cond ((null buffer) (print-warning "module-mod-request called with an invalid buffer name ~S" buffer-name)) ((null (act-r-buffer-chunk buffer)) (print-warning "module-mod-request called with no chunk in buffer ~s" buffer-name)) ((null (valid-chunk-modification (act-r-buffer-chunk buffer) modification)) (print-warning "module-mod-request called with an invalid modification ~S" modification)) (t (buffer-mod-module (act-r-buffer-module buffer) buffer-name modification))))))) (defun schedule-module-mod-request (buffer-name modification time-delta &key (module :none) (priority 0) (output 'medium)) (verify-current-mp "schedule-module-mod-request called with no current meta-process." (verify-current-model "schedule-module-mod-request called with no current model." (let ((buffer (buffer-instance buffer-name))) (cond ((null buffer) (print-warning "schedule-module-mod-request called with invalid buffer name ~S" buffer-name)) ((null (act-r-buffer-chunk buffer)) (print-warning "schedule-module-mod-request called with no chunk in buffer ~s" buffer-name)) ((null (valid-chunk-modification (act-r-buffer-chunk buffer) modification)) (print-warning "module-mod-request called with an invalid modification ~S" modification)) ((not (numberp time-delta)) (print-warning "~s called with a non-number time-delta: ~S" 'schedule-module-mod-request time-delta)) ((and (not (numberp priority)) (not (eq priority :max)) (not (eq priority :min))) (print-warning "schedule-module-mod-request called with an invalid priority ~S" priority)) (t (schedule-event-relative time-delta 'module-mod-request :module module :priority priority :params (list buffer-name modification) :details (concatenate 'string (symbol-name 'module-mod-request) " " (symbol-name buffer-name)) :output output))))))) (defun mod-buffer-chunk (buffer-name modifications) (verify-current-mp "mod-buffer-chunk called with no current meta-process." (verify-current-model "mod-buffer-chunk called with no current model." (let ((buffer (buffer-instance buffer-name))) (cond ((null buffer) (print-warning "mod-buffer-chunk called with an invalid buffer name ~S" buffer-name)) ((null (act-r-buffer-chunk buffer)) (print-warning "mod-buffer-chunk called with no chunk in buffer ~s" buffer-name)) ((null (valid-chunk-modification (act-r-buffer-chunk buffer) modifications)) (print-warning "mod-buffer-chunk called with an invalid modification ~S" modifications)) (t (fast-mod-chunk-fct (act-r-buffer-chunk buffer) modifications))))))) (defun schedule-mod-buffer-chunk (buffer-name modifications time-delta &key (module :none) (priority 0) (output 'low)) (verify-current-mp "schedule-mod-buffer-chunk called with no current meta-process." (verify-current-model "schedule-mod-buffer-chunk called with no current model." (let ((buffer (buffer-instance buffer-name))) (cond ((null buffer) (print-warning "schedule-mod-buffer-chunk called with an invalid buffer name ~S" buffer-name)) ((null (act-r-buffer-chunk buffer)) (print-warning "mod-buffer-chunk called with no chunk in buffer ~s" buffer-name)) ((null (valid-chunk-modification (act-r-buffer-chunk buffer) modifications)) (print-warning "schedule-mod-buffer-chunk called with an invalid modification ~S" modifications)) ((not (numberp time-delta)) (print-warning "schedule-mod-buffer-chunk called with non-number time-delta: ~S" time-delta)) ((and (not (numberp priority)) (not (eq priority :max)) (not (eq priority :min))) (print-warning "schedule-mod-buffer-chunk called with an invalid priority ~S" priority)) (t (schedule-event-relative time-delta 'mod-buffer-chunk :module module :priority priority :params (list buffer-name modifications) :details (concatenate 'string (symbol-name 'mod-buffer-chunk) " " (symbol-name buffer-name)) :output output))))))) (defun valid-chunk-modification (chunk-name modifications) (let ((c (get-chunk chunk-name))) (when c (if (oddp (length modifications)) nil (let ((slots nil) (slots-and-values nil)) (do ((s modifications (cddr s))) ((null s)) (push (car s) slots) (push (list (car s) (second s)) slots-and-values)) (and (every #'(lambda (slot) (valid-slot-name slot (act-r-chunk-chunk-type c))) slots) (= (length slots) (length (remove-duplicates slots))))))))) (defun buffer-spread (buffer-name) (verify-current-mp "buffer-spread called with no current meta-process." (verify-current-model "buffer-spread called with no current model." (let ((buffer (buffer-instance buffer-name))) (cond ((null buffer) (print-warning "buffer-spread called with an invalid buffer name ~S" buffer-name)) (t (car (no-output (sgp-fct (list (act-r-buffer-parameter-name buffer))))))))))) (defun buffers-module-name (buffer-name) (let ((buffer (buffer-instance buffer-name))) (cond ((null buffer) (print-warning "invalid buffer name ~S" buffer-name)) (t (let ((module (act-r-buffer-module buffer))) (if module module (print-warning "Could not find a module for buffer ~S" buffer-name))))))) #| This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by the Free Software Foundation; either version 2.1 of the License, or (at your option) any later version. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA |# ;; /Users/ritter/ritter/proposals/onr-emotions4/iccm07/actr6-15jan07/framework/buffers.lisp ;; **************************************************************** ;; **************************************************************** ;; /Users/ritter/ritter/proposals/onr-emotions4/iccm07/actr6-15jan07/framework/model.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 : model.lisp ;;; Version : 1.0a1 ;;; ;;; Description : Functions that support the abstraction of a model ;;; ;;; Bugs : ;;; ;;; To do : Finish the documentation. ;;; ;;; ----- History ----- ;;; ;;; 2004.20.08 Dan ;;; : Creation ;;; 2005.01.12 Dan ;;; : Don't need to special case the device because it's now an ;;; : actual module. ;;; 2005.02.11 Dan ;;; : * Changed some reset-model to use clrhash instead of ;;; : creating new tables. ;;; 2005.02.28 Dan ;;; : * Made the with-model macro hygienic. ;;; 2005.03.23 Dan ;;; : * Update the model reset and creation to use the two reset ;;; : functions that are now part of the module definition - one ;;; : before the parameter are reset and one after. ;;; 2006.07.05 Dan ;;; : * Fixed a bug in the delete-model-fct function in the format ;;; : command for printing that there was no model. ;;; 2006.11.07 Dan ;;; : * Fixed a bug in delete-model which could result in the deleted ;;; : model being left as the current model after deletion. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; General Docs: ;;; ;;; Model structure is not for use outside of the framework. ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Public API: ;;; ;;; ;;; define-model ;;; ;;; (defmacro define-model (name &body model-code)) ;;; (defun define-model-fct (name model-code-list)) ;;; ;;; name a symbol that will be the name for the new model ;;; model-code any number of forms that will be evaluated for the model ;;; model-code-list a list of forms to evaluate for the model ;;; ;;; define-model is used to create a new model in the current meta-process. ;;; ;;; The name must not already be used for a model in the current meta-process. If the name is not a symbol or is already used to name a model in the current meta-process a warning will be displayed and the model will not be defined (the old model with that name will remain unchanged if one existed). ;;; ;;; When a model is first defined the following sequence of events will occur: ;;; ;;; - Create a new model with that name ;;; - with that new model as the current model ;;; - create the default chunk-types ;;; - create the default chunks ;;; - create a new instance of each module ;;; - call its create function if it exists ;;; - call its reset function if it exists ;;; - evaluate the forms of the model in the order provided ;;; ;;; If a model is successfully created then its name is returned otherwise define-model returns nil. ;;; ;;; Every model will need to have a call to define-model before issuing any of the model commands because there is no default model in a meta-process. However, if one is working with only a single model then all that is necessary is to provide a name - it is not necessary to enclose all of the model code. ;;; ;;; current-model ;;; ;;; (defun current-model ()) ;;; ;;; current-model returns the name of the current model in the current meta-process or nil if there is no current model or no current meta-process. ;;; ;;; delete-model ;;; ;;; (defmacro delete-model (&optional model-name)) ;;; (defun delete-model-fct (&optional model-name)) ;;; ;;; model-name a symbol that names a model ;;; ;;; If model-name is not provided the name of the current-model is used. ;;; ;;; If model-name is the name of a model in the current meta-process then the following sequence of events will occur: ;;; ;;; - the model with that name is set to the current model ;;; - all events generated by that model are removed from the event queue ;;; - each module of the model is deleted ;;; - the model is removed from the set of models in the current meta-process ;;; ;;; If model-name is valid then t is returned. ;;; ;;; If model-name is not valid or there is no current meta-process then a warning is printed, nothing is done and nil is returned. ;;; ;;; with-model ;;; ;;; (defmacro with-model (model-name &body body)) ;;; (defun with-model-fct (model-name forms-list)) ;;; ;;; model-name a symbol that names a model in the current meta-process ;;; body any number of forms to execute ;;; forms-list a list of forms to execute ;;; ;;; If model-name is the name of a model in the current meta-process then the forms are evaluated in order with the current model set to the one named by model-name. The value of the last form evaluated is returned. ;;; ;;; If model-name does not name a model in the current meta-process, or there is no current meta-process then none of the forms are evaluated, a warning is printed and 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) (defun current-model () (when (current-model-struct) (act-r-model-name (current-model-struct)))) (defmacro define-model (name &body model-code) `(define-model-fct ',name ',model-code)) (defun define-model-fct (name model-code-list) (verify-current-mp "define-model called with no current meta-process." (cond ((not (symbolp name)) (print-warning "Model name must be a symbol, ~S is not valid. No model defined." name)) ((null name) (print-warning "Nil is not a valid name for a model. No model defined.")) ((valid-model-name name) (print-warning "~S is already the name of a model in the current meta-process. Cannot be redefined." name)) (t (let ((new-model (make-act-r-model :name name)) (mp (current-mp))) (setf (gethash name (meta-p-models mp)) new-model) (setf (meta-p-current-model mp) new-model) (incf (meta-p-model-count mp)) ;(setf (act-r-model-device new-model) ; (make-instance 'device-interface)) (when (> (length (format nil "~S" name)) (meta-p-model-name-len mp)) (setf (meta-p-model-name-len mp) (length (format nil "~S" name)))) (create-model-default-chunk-types-and-chunks) (maphash #'(lambda (module-name val) (declare (ignore val)) (setf (gethash module-name (act-r-model-modules-table new-model)) (instantiate-module module-name name))) (global-modules-table)) ;; instantiate the buffers (maphash #'(lambda (buffer-name buffer-struct) (setf (gethash buffer-name (act-r-model-buffers new-model)) (copy-act-r-buffer buffer-struct))) *buffers-table*) (maphash #'(lambda (module-name val) (declare (ignore val)) (reset-module module-name)) (global-modules-table)) (maphash #'(lambda (parameter-name parameter) (sgp-fct (list parameter-name (act-r-parameter-default parameter)))) *act-r-parameters-table*) (maphash #'(lambda (module-name val) (declare (ignore val)) (secondary-reset-module module-name)) (global-modules-table)) (let ((errored nil)) (dolist (form model-code-list) (unwind-protect (handler-case (eval form) (error (condition) (setf errored t) (print-warning "Error encountered in model form:~%~S~%Invoking the debugger." form) (print-warning "You must exit the error state to continue.") (invoke-debugger condition))) (when errored (remhash name (meta-p-models mp)) (print-warning "Model ~s not defined." name) (decf (meta-p-model-count mp)) (return-from define-model-fct nil))))) (setf (act-r-model-code new-model) model-code-list) (unless (= 1 (meta-p-model-count mp)) (setf (meta-p-current-model mp) nil)) name))))) (defun create-model-default-chunk-types-and-chunks () (chunk-type-fct (list 'chunk)) (define-chunks-fct (list '(free isa chunk) '(busy isa chunk) '(error isa chunk) '(empty isa chunk) '(full isa chunk) '(requested isa chunk) '(unrequested isa chunk)))) (defmacro delete-model (&optional (model-name nil provided)) `(if ,provided (delete-model-fct ',model-name) (delete-model-fct (current-model)))) (defun delete-model-fct (model-name) (verify-current-mp "delete-model called with no current meta-process.~%No model deleted." (let ((mp (current-mp))) (if model-name (if (gethash model-name (meta-p-models mp)) (let ((model (gethash model-name (meta-p-models mp))) (saved-current (meta-p-current-model mp))) (setf (meta-p-current-model mp) model) (setf (meta-p-events mp) (remove model-name (meta-p-events mp) :key #'evt-model)) (setf (meta-p-delayed mp) (remove model-name (meta-p-delayed mp) :key #'evt-model)) (maphash #'(lambda (module-name instance) (declare (ignore instance)) (delete-module module-name)) (global-modules-table)) (decf (meta-p-model-count mp)) (remhash model-name (meta-p-models mp)) (if (= 1 (meta-p-model-count mp)) (setf (meta-p-current-model mp) (gethash (car (hash-table-keys (meta-p-models mp))) (meta-p-models mp))) (setf (meta-p-current-model mp) saved-current)) t) (print-warning "No model named ~S in current meta-process." model-name)) (print-warning "No current model to delete."))))) (defmacro with-model (model-name &body body) (let ((mp (gensym)) (previous-model (gensym))) `(let ((,mp (current-mp))) (if ,mp (if (valid-model-name ',model-name) (let ((,previous-model (current-model-struct))) (setf (meta-p-current-model (current-mp)) (gethash ',model-name (meta-p-models ,mp))) (unwind-protect (progn ,@body) (setf (meta-p-current-model (current-mp)) ,previous-model))) (print-warning "~S does not name a model in the current meta-process" ',model-name)) (print-warning "No actions taken in with-model because there is no current meta-process"))))) (defun with-model-fct (model-name forms-list) (let ((mp (current-mp))) (if mp (if (valid-model-name model-name) (let ((previous-model (current-model-struct)) (val nil)) (setf (meta-p-current-model (current-mp)) (gethash model-name (meta-p-models mp))) (unwind-protect (dolist (x forms-list val) (setf val (eval x))) (setf (meta-p-current-model (current-mp)) previous-model) )) (print-warning "~S does not name a model in the current meta-process" model-name)) (print-warning "No actions taken in with-model because there is no current meta-process")))) (defun valid-model-name (name) "Returns t if name is the name of a model in the current meta-process - there must be a current mp" (if (gethash name (meta-p-models (current-mp))) t nil)) (defun reset-model (mp model) (let ((previous-model (meta-p-current-model mp))) (setf (meta-p-current-model mp) model) (clrhash (act-r-model-chunk-types-table model)) (clrhash (act-r-model-chunks-table model)) (maphash #'(lambda (buffer-name buffer) (declare (ignore buffer-name)) (setf (act-r-buffer-chunk buffer) nil)) (act-r-model-buffers model)) (create-model-default-chunk-types-and-chunks) (maphash #'(lambda (module-name instance) (declare (ignore instance)) (reset-module module-name)) (global-modules-table)) (maphash #'(lambda (parameter-name parameter) (sgp-fct (list parameter-name (act-r-parameter-default parameter)))) *act-r-parameters-table*) (maphash #'(lambda (module-name val) (declare (ignore val)) (secondary-reset-module module-name)) (global-modules-table)) (dolist (form (act-r-model-code model)) (eval form)) (setf (meta-p-current-model mp) previous-model))) #| 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/model.lisp ;; **************************************************************** ;; **************************************************************** ;; /Users/ritter/ritter/proposals/onr-emotions4/iccm07/actr6-15jan07/framework/events.lisp ;; ;;; -*- mode: LISP; Syntax: COMMON-LISP; Base: 10 -*- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Author : Dan Bothell ;;; Copyright : (c) 2004 Dan Bothell ;;; Availability: Covered by the GNU LGPL, see LGPL.txt ;;; Address : Department of Psychology ;;; : Carnegie Mellon University ;;; : Pittsburgh, PA 15213-3890 ;;; : db30@andrew.cmu.edu ;;; ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Filename : events.lisp ;;; Version : 1.0a1 ;;; ;;; Description : The definition of events for the scheduler as described in ;;; the ACT-R 6 software framework API. ;;; ;;; Bugs : ;;; ;;; To do : ;;; ;;; ----- History ----- ;;; ;;; 2004.08.11 Dan ;;; : Creation. ;;; 2005.01.09 Dan ;;; : Changing the event trace a little. I don't think it's ;;; : necessary to print the destination in the trace since ;;; : it's either the same as the module (and already there) ;;; : or the module that was the destination will show an ;;; : event later in response... ;;; 2006.07.16 Dan ;;; : Changed the API section to note the correct accessor is ;;; : evt-output. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; General Docs: ;;; ;;; Despite the fact that events are simply structs one should not create ;;; them explicitly and only the scheduling fuctions provided in schedule.lisp ;;; should be used to generate them. ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Public API: ;;; ;;; ;;; evt-time (event) ;;; returns the time in seconds at which the event is scheduled to occur. ;;; ;;; evt-priority (event) ;;; returns the priority of the event. ;;; ;;; evt-action (event) ;;; returns the action function that will be executed for the event. ;;; ;;; evt-model (event) ;;; returns the name of the model in which this event was created. ;;; ;;; evt-module (event) ;;; returns the name of the module which created this event. ;;; ;;; evt-destination (event) ;;; returns the destination which was specified for the event. ;;; ;;; evt-params (event) ;;; returns the list of parameters which will be passed to the event's ;;; action function when the event is executed. ;;; ;;; evt-details (event) ;;; returns the details string that will be displayed in the trace for ;;; this event if it has one, or nil if it does not. ;;; ;;; evt-output (event) ;;; returns the output value of this event, which indicates whether to ;;; print this event in the trace. ;;; ;;; format-event (event) ;;; returns a string that contains the text that will be displayed in the ;;; trace for event if it is executed and has its output set to t. ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Design Choices: ;;; ;;; Because a function with the name 'event-'something is likely to conflict ;;; with existing functions in some Lisp and the default operation of the ;;; system is to not separately package the components, the names of the ;;; accessors begin with evt- instead of event-. ;;; ;;; Using a struct because I don't need anything fancy at this point. ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; The code ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; #+:packaged-actr (in-package :act-r) #+(and :clean-actr (not :packaged-actr) :ALLEGRO-IDE) (in-package :cg-user) #-(or (not :clean-actr) :packaged-actr :ALLEGRO-IDE) (in-package :cl-user) (defun act-r-event-break-action (mp) (setf (meta-p-break mp) t)) (defmethod format-event (event) (declare (ignore event)) nil) (defconstant +format-event-event-string+ (formatter "~10,3f ~:[~*~;~a ~] ~:[~2*~;~va ~] ~va ~:[~*~a~@[ ~a~]~{ ~a~}~;~a~*~*~*~] ~@[Waiting for: ~A~]")) (defmethod format-event ((event act-r-event)) (let ((*print-pretty* nil) (mp (get-mp (evt-mp event)))) (format nil +format-event-event-string+ (evt-time event) (< 1 (mps-count *meta-processes*)) (evt-mp event) (< 1 (meta-p-model-count mp)) (meta-p-model-name-len mp) (evt-model event) (max-module-name-length) (evt-module event) (evt-details event) (evt-details event) (evt-action event) ; this is easier than fixing the string for now ; (evt-destination event) nil (evt-params event) (evt-wait-condition event)))) (defconstant +format-event-break-event-string+ (formatter "~10,3f ~:[~*~;~a ~] ~:[~2*~;~va ~] ~va BREAK-EVENT ~@[~a ~]~@[Waiting for: ~A~]")) (defmethod format-event ((event act-r-break-event)) (let ((*print-pretty* nil) (mp (get-mp (evt-mp event)))) (format nil +format-event-break-event-string+ (evt-time event) (< 1 (mps-count *meta-processes*)) (evt-mp event) (< 1 (meta-p-model-count mp)) (meta-p-model-name-len mp) "------" (max-module-name-length) "------" (evt-details event) (evt-wait-condition event)))) #| This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by the Free Software Foundation; either version 2.1 of the License, or (at your option) any later version. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA |# ;; /Users/ritter/ritter/proposals/onr-emotions4/iccm07/actr6-15jan07/framework/events.lisp ;; **************************************************************** ;; **************************************************************** ;; /Users/ritter/ritter/proposals/onr-emotions4/iccm07/actr6-15jan07/framework/scheduling.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 : scheduling.lisp ;;; Version : 1.2 ;;; ;;; Description : Event creation and scheduling and schedule running functions. ;;; ;;; Bugs : [ ] Need to fix/remove the update functions from the modules ;;; : because how they get called prevents one from scheduleing ;;; : events correctly during one (in particular the device ;;; : device-update-attended-loc doesn't accept the time parameters ;;; : but just adding that is really just a hack). ;;; ;;; To do : [ ] Finish documentation. ;;; : [x] Add an equivalent to the real-time-slack-hook-fn in rpm. ;;; : [ ] Consider a global randomize time flag and/or parameter to the ;;; : scheduling functions. ;;; : [x] The break events and "stopping reason" trace don't go to ;;; : the output of all models but probably should so that if ;;; : the traces are split at the model level they all show it. ;;; ;;; ;;; ----- History ----- ;;; ;;; 2004.08.16 Dan ;;; : Creation ;;; 2004.12.06 Dan ;;; : Updated a warning message because I found it uninformative. ;;; : Tried to fit things to 80 char line width. ;;; 2005.01.12 Dan ;;; : Because the device is now a module it doesn't need to ;;; : be handled specially in set-mp-clock. ;;; 2005.01.27 Dan ;;; : * Modified run-one-event to use filter-output-events which ;;; : is now part of the printing module to determine if the ;;; : trace should be displayed. ;;; 2005.02.03 Dan ;;; : * Removed the format call from the periodic action's details. ;;; 2005.02.14 Dan ;;; : * Added the run-until-condition function. ;;; 2005.02.16 Dan ;;; : * Some general cleanup and added the "stopping reason" output ;;; : to the run functions. ;;; 2005.02.22 Dan ;;; : * Cleaned up the stopping reason output. ;;; : * Fixed a bug in run-full-time by just making it use ;;; : run-until-time. ;;; 2005.02.25 Dan ;;; : * Made run work more like pm-run in that if there are future ;;; : events it will work like run-full-time instead of just ;;; : stopping. ;;; 2005.02.28 Dan ;;; : * Switched the stopping reason output from model-output to ;;; : meta-p-output (which I've put back into things) because ;;; : model-output doesn't work in a multi-model situation. ;;; 2005.04.20 Dan ;;; : * Changed add-pre/post-event-hook so that fboundp doesn't ;;; : cause problems for Lispworks with lambdas. ;;; 2005.05.20 Dan ;;; : * Fixed a bug in run-until-time (caused primarily when ;;; : run-full-time used) where a non-rounded time could cause ;;; : the system to get stuck. ;;; 2005.12.08 Dan ;;; : * Fixed a bug in the output of the events generated by ;;; : schedule-periodic-event and periodic-action. ;;; 2006.01.25 Dan ;;; : * Modifying all the "run" functions so that when they end ;;; : a "run-terminated" event is passed to all the models if ;;; : it terminates other than due to a break. This way, the ;;; : event hooks can detect when a run ends (either a break ;;; : event or an event with the run-terminated action) which ;;; : makes adding additional tracing and other tools easier. ;;; 2006.01.26 Dan ;;; : * Added an optional parameter to the add-pre/post-event-hook ;;; : functions to suppress the warning if one adds a hook that's ;;; : already on the list. It just returns nil in that case now. ;;; : This helps because the hook is at the meta-process level, ;;; : but one may have a module (at the model level) that needs ;;; : to add such a hook and not want to see the warning if there ;;; : are multiple models loaded and using it. ;;; 2006.01.30 Dan ;;; : * Changed the run-terminated event to a maintenance event. ;;; : * Added the keyword param :include-maintenance to the schedule- ;;; : after-* functions which indicates whether or not to include ;;; : maintenance events in those that can trigger it (it defaults ;;; : to nil). This keeps things from getting scheduled after ;;; : events that don't do anything for the model. ;;; : * Added the schedule-maintenance-event-relative function to ;;; : be able to schedule maintenance events. Could make it a ;;; : switch on the existing functions, but for now at least ;;; : I've decided to use a different function. ;;; 2006.02.24 Dan ;;; : * Fixed a bug in run-until-time that caused it to not work ;;; : if there was more than one model defined. ;;; 2006.02.27 Dan [1.2] ;;; : * Modified run-schd-queue and set-mp-clock so that they ;;; : now use the "real time" control functions that can be set ;;; : for the meta-process using mp-real-time-management. ;;; 2006.02.28 Dan ;;; : * Added a schedule-maintenance-event function and changed ;;; : run-until-time to actually use it. ;;; 2006.03.03 Dan ;;; : * Modified run-sched-queue to use the max-delta-time ;;; : property set with mp-real-time-management. ;;; : New (non-maintenance) "dummy" events will be automatically ;;; : generated to occur in any time slice that needs them. ;;; 2006.03.08 Dan ;;; : * Fixed a bug with schedule-break-after-module because it ;;; : didn't set the model for the event, so never matched up ;;; : with a new event to get scheduled. ;;; ;;; 2006.05.02 Dan ;;; : * Noted an issue with the update function of modules and put ;;; : it under bugs above. ;;; 2006.07.13 Dan ;;; : * Fixed a bug with run-until-time that caused it to jump ;;; : back in time if the end-time had already passed. ;;; 2006.07.14 Dan ;;; : * Added another output to run-n-events to make it clearer ;;; : in the trace why it stopped - differentiate hitting the ;;; : event-count from just running out of events. ;;; 2006.07.18 Dan ;;; : * Removed the schedule-maintenance-* functions and ;;; : replaced them with a keyword :maintenance t/nil ;;; : in the regular schedule-* functions. ;;; : * Updated all references to schedule-maintenance-* with ;;; : the correct schedule-* function. ;;; : * As a saftey check those maintenance functions now just ;;; : print a warning to let people know there was a change. ;;; 2006.07.20 Dan ;;; : * Fixed a bug in schedule-periodic-event because it tried ;;; : to take the symbol-name of an interpreted function if that ;;; : was passed as the action. ;;; : * Updated conditions-met because a break event doesn't have ;;; : a model so if it's waiting it'll never match to any specific ;;; : model so should instead match to any model. ;;; : * Fixed update waiting-events because it didn't distinguish ;;; : between break events and normal events which caused a ;;; : problem for schedule-break-after-module. ;;; 2006.07.28 Dan ;;; : * Fixed the warning in delete-event-hook. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; General Docs: ;;; ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Public API: ;;; ;;; ;;; run ;;; ;;; (defun run (run-time &key (real-time nil))) ;;; ;;; run-time is a time in seconds ;;; real-time is either t or nil ;;; ;;; If there is a current meta-process this will run the scheduler for that ;;; meta-process with a stopping condition that the clock will be advanced by ;;; no more than run-time seconds. If real-time is t, then the clock will be ;;; advanced in step with actual time instead of simulating time as fast as ;;; possible. ;;; ;;; After running the scheduler a line will be output in the trace indicating ;;; why the run stopped, which will be one of the following conditions: the ;;; requested amount of time has passed, there are no events left to process, or ;;; a break event occurred. ;;; ;;; run returns three values. ;;; ;;; If there is no current meta-process all three are nil. ;;; ;;; If there is a current meta-process, then the first value is the amount ;;; of simulated time that passed during the call to run. The second is the ;;; number of events that were processed from the event queue, and the third ;;; will be t if the run terminated due to a break event or nil if it terminated ;;; for any other reason. ;;; ;;; run-full-time ;;; ;;; (defun run-full-time (run-time &key (real-time nil))) ;;; ;;; run-time is a time in seconds ;;; real-time is either t or nil ;;; ;;; If there is a current meta-process this will run the scheduler for that ;;; meta-process with a stopping condition that the clock will be advanced by ;;; exactly run-time seconds unless a break event occurs. If real-time is t, ;;; then the clock will be advanced in step with actual time instead of ;;; simulating time as fast as possible. ;;; ;;; After running the scheduler a line will be output in the trace indicating ;;; why the run stopped, which will be one of the following conditions: the ;;; requested amount of time has passed or a break event occurred. ;;; ;;; run-full-time returns three values. ;;; ;;; If there is no current meta-process all three are nil. ;;; ;;; If there is a current meta-process, then the first value is the amount ;;; of simulated time that passed during the call to run-full-time. The second ;;; is the number of events that were processed from the event queue, and the ;;; third will be t if the run terminated due to a break event or nil if it ;;; terminated for any other reason. ;;; ;;; run-until-time ;;; ;;; (defun run-until-time (end-time &key (real-time nil))) ;;; ;;; end-time is a time in seconds ;;; real-time is either t or nil ;;; ;;; If there is a current meta-process this will run the scheduler for that ;;; meta-process with a stopping condition that the clock will be advanced to ;;; the explicit end-time if the current time is not already greater than ;;; end-time and no break event occurs. If real-time is t, then the clock will ;;; be advanced in step with actual time instead of simulating time as fast as ;;; possible. ;;; ;;; After running the scheduler a line will be output in the trace indicating ;;; why the run stopped, which will be one of the following conditions: the ;;; requested end-time has already been passed, the requested end-time has ;;; been reached, or a break event occurred. ;;; ;;; run-until-time returns three values. ;;; ;;; If there is no current meta-process all three are nil. ;;; ;;; If there is a current meta-process, then the first value is the amount ;;; of simulated time that passed during the call to run-until-time. The second ;;; is the number of events that were processed from the event queue, and the ;;; third will be t if the run terminated due to a break event or nil if it ;;; terminated for any other reason. ;;; ;;; run-until-condition ;;; ;;; (defun run-until-condition (condition &key (real-time nil))) ;;; ;;; condition is a function or function name that takes no arguments ;;; real-time is either t or nil ;;; ;;; If there is a current meta-process this will run the scheduler for that ;;; meta-process with the stopping condition being until the codition ;;; function returns t or a break event occurs. If real-time is t, then the ;;; clock will be advanced in step with actual time instead of simulating time ;;; as fast as possible. ;;; ;;; After running the scheduler a line will be output in the trace indicating ;;; why the run stopped, which will be one of the following conditions: the ;;; requested condition was t or a break event occurred. ;;; ;;; run-until-time returns three values. ;;; ;;; If there is no current meta-process all three are nil. ;;; ;;; If there is a current meta-process, then the first value is the amount ;;; of simulated time that passed during the call to run-until-time. The second ;;; is the number of events that were processed from the event queue, and the ;;; third will be t if the run terminated due to a break event or nil if it ;;; terminated for any other reason. ;;; run-n-events ;;; ;;; (defun run-n-events (event-count &key (real-time nil))) ;;; ;;; event-count is a positive integer ;;; real-time is either t or nil ;;; ;;; If there is a current meta-process this will run the scheduler for ;;; that meta-process with a stopping condition that at most event-count events ;;; are executed. If real-time is t, then the clock will be advanced in step ;;; with actual time instead of simulating time as fast as possible. ;;; ;;; After running the scheduler a line will be output in the trace indicating ;;; why the run stopped, which will be one of the following conditions: there ;;; were no more events to execute, event-count events were processed, or a ;;; break event occurred. ;;; ;;; run-n-events returns three values. ;;; ;;; If there is no current meta-process all three are nil. ;;; ;;; If there is a current meta-process, then the first value is the amount ;;; of simulated time that passed during the call to run-n-events. The second ;;; is the number of events that were processed from the event queue, and the ;;; third will be t if the run terminated due to a break event or nil if it ;;; terminated for any other reason. ;;; ;;; run-step ;;; ;;; (defun run-step ()) ;;; ;;; If there is a current meta-process run-step will execute events from ;;; the event queue one at a time displaying each before execution on ;;; *standard-output* and prompting the user to decide whether to process the ;;; event, delete it, or end the stepping (other features may be added over ;;; time). It will continue until the queue is empty, a break event is ;;; executed, or the user requests it to quit. ;;; ;;; run-step returns three values. ;;; ;;; If there is no current meta-process all three are nil. ;;; ;;; If there is a current meta-process, then the first value is the amount ;;; of simulated time that passed during the call to run-step. The second is ;;; the number of events that were processed from the event queue (not counting ;;; those that were deleted), and the third will be t if the run terminated ;;; due to a break event or nil if it terminated for any other reason. ;;; ;;; ;;; schedule-event ;;; ;;; (defun schedule-event (time action ;;; &key (module :none) (destination nil) ;;; (priority 0)(params nil) (details nil) ;;; (output t))) ;;; ;;; time a time in seconds which should be a non-negative number ;;; action a function or function-name ;;; module a symbol that names the module which is scheduling the event ;;; destination a symbol that names a module or the keyword :device. The ;;; current instance of that module ;;; or the current model's device will be passed as the first parameter to ;;; the action. ;;; priority a number or the keywords :max or :min ;;; params a list of parameters for the action function ;;; details a string describing the event for the trace or nil ;;; output either t or nil ;;; ;;; schedule-event creates a new event using the supplied parameters for its ;;; corresponding attributes and the current model will be used for its model. ;;; It will then be added to the event queue of the current meta-process. ;;; ;;; If there are any events waiting to be scheduled they are checked to see ;;; if this new event allows them to be scheduled. ;;; ;;; If any of the parameters are invalid or there is no current model or ;;; current meta-process then a warning is printed, no event is scheduled, ;;; and nil is returned. ;;; ;;; The scheduled event is returned when successfully created and scheduled. ;;; ;;; schedule-event-relative ;;; ;;; (defun schedule-event-relative (time-delay action ;;; &key (module :none) (destination nil) ;;; (priority 0)(params nil) (details nil) ;;; (output t))) ;;; ;;; time-delay a time in seconds which should be a non-negative number ;;; action a function or function-name ;;; module a symbol that names the module which is scheduling the event ;;; destination a symbol that names a module or the keyword :device. The ;;; current instance of that module ;;; or the current model's device will be passed as the first parameter to ;;; the action. ;;; priority a number or the keywords :max or :min ;;; params a list of parameters for the action function ;;; details a string describing the event for the trace or nil ;;; output either t or nil ;;; ;;; schedule-event-relative creates a new event with a time that is equal ;;; to the current time plus time-delay and using the other supplied ;;; parameters for its corresponding attributes and the current model for ;;; its model which is then added to the event queue of the current ;;; meta-process. ;;; ;;; If there are any events waiting to be scheduled they are checked to see ;;; if this new event allows them to be scheduled. ;;; ;;; If any of the parameters are invalid or there is no current model or ;;; current meta-process then a warning is printed, no event is scheduled, ;;; and nil is returned. ;;; ;;; The scheduled event is returned when successfully created and scheduled. ;;; ;;; schedule-event-after-module ;;; ;;; (defun schedule-event-after-module (after-module action ;;; &key (module :none) (destination nil) ;;; (priority 0) (params nil) ;;; (details nil) (output t) ;;; (delay t))) ;;; ;;; after-module a symbol that names a module ;;; action a function or function-name ;;; module a symbol that names the module which is scheduling the event ;;; destination a symbol that names a module or the keyword :device. The ;;; current instance of that module ;;; or the current model's device will be passed as the first parameter to ;;; the action. ;;; params a list of parameters for the action function ;;; details a string describing the event for the trace or nil ;;; output either t or nil ;;; delay one of t, nil, or :abort. ;;; ;;; schedule-event-after-module creates a new event using the supplied ;;; parameters for its corresponding attributes and the current model for ;;; its model. ;;; ;;; If there is an event currently in the event queue with the module name ;;; of after-module and the same model as the current model then this new ;;; event is placed into the event queue at the time of the next such event ;;; (lowest time) with a priority of :min. If there are any events waiting ;;; to be scheduled they are checked to see if this new event allows them to ;;; be scheduled. ;;; ;;; If there is no event in the event queue that matches on both model and ;;; module then the value of delay determines what happens to the new event. ;;; ;;; If delay is t then the new event is placed into the set of waiting ;;; events to be scheduled after an event which matches after-module and ;;; the current model. ;;; ;;; If delay is nil then the new event is added to the event queue for ;;; immediate execution. Its time will be set to the current time and its ;;; priority will be :max. ;;; ;;; If delay is :abort then the new event is discarded without being ;;; scheduled or placed onto the waiting queue. ;;; ;;; schedule-event-after-module returns 2 values. ;;; ;;; If there is no current model or current meta-process or any of the ;;; parameters are invalid, then no event is scheduled and both values ;;; are nil. ;;; ;;; If an event is scheduled then the first value will be the event and ;;; the second value will be t if the event is in the waiting queue or nil ;;; if it is in the event queue. ;;; ;;; If the event is aborted the first value will be nil and the second ;;; value will be :abort. ;;; ;;; schedule-event-after-change ;;; ;;; (defun schedule-event-after-change (action ;;; &key (module :none) (destination nil) ;;; (params nil) (details nil) ;;; (output t) (delay t))) ;;; ;;; ;;; action a function or function-name ;;; module a symbol that names the module which is scheduling the event ;;; destination a symbol that names a module or the keyword :device. The ;;; current instance of that module ;;; or the current model's device will be passed as the first parameter to ;;; the action. ;;; params a list of parameters for the action function ;;; details a string describing the event for the trace or nil ;;; output either t or nil ;;; delay one of t, nil, or :abort. ;;; ;;; schedule-event-after-change creates a new event using the supplied ;;; parameters for its corresponding attributes and the current model for ;;; its model. ;;; ;;; If there is any event currently in the event queue with the same model ;;; as the current model then this new event is placed into the event queue ;;; at the time of the next such event (lowest time) with a priority of :min. ;;; If there are any events waiting to be scheduled they are checked to see ;;; if this new event allows them to be scheduled. ;;; ;;; If there is no event in the event queue that matches the current model ;;; then the value of delay determines what happens to the new event. ;;; ;;; If delay is t then the new event is placed into the set of waiting events ;;; to be scheduled after an event which matches the current model. ;;; ;;; If delay is nil then the new event is added to the event queue for ;;; immediate execution. Its time will be set to the current time and ;;; its priority will be :max. ;;; ;;; If delay is :abort then the new event is discarded without being scheduled. ;;; ;;; schedule-event-after-change returns 2 values. ;;; ;;; If there is no current model or current meta-process or any of the ;;; parameters are invalid, then no event is scheduled and both values are nil. ;;; ;;; If an event is scheduled then the first value will be the event and ;;; the second value will be t if the event is in the waiting queue or ;;; nil if it is in the event queue. ;;; ;;; If the event is aborted the first value will be nil and the second ;;; value will be :abort. ;;; ;;; schedule-periodic-event ;;; ;;; (defun schedule-periodic-event (period action ;;; &key (module :none) (destination nil) ;;; (priority 0) (params nil) ;;; (details nil) (output t) ;;; (initial-delay 0))) ;;; ;;; ;;; period a time in seconds which should be a non-negative number ;;; action a function or function-name ;;; module a symbol that names the module which is scheduling the event ;;; destination a symbol that names a module or the keyword :device. The ;;; current instance of that module ;;; or the current model's device will be passed as the first parameter to ;;; the action. ;;; priority a number or the keywords :max or :min ;;; params a list of parameters for the action function ;;; details a string describing the event for the trace or nil ;;; output either t or nil ;;; initial-delay a time in seconds which should be a non-negative number ;;; ;;; schedule-periodic-event creates a new event with a time that is equal ;;; to the current time plus initial-delay and using the other supplied ;;; parameters for its corresponding attributes and the current model for ;;; its model which is then added to the event queue of the current ;;; meta-process. After that event occurs a new event will automatically be ;;; scheduled to occur period seconds after that time with the same parameters ;;; as the initial one. That rescheduling will continue every period seconds ;;; until the event is deleted. ;;; ;;; If there are any events waiting to be scheduled they are checked to see ;;; if this new event allows them to be scheduled, and every time that it is ;;; rescheduled there will be a check of the waiting events. ;;; ;;; If any of the parameters are invalid or there is no current model or ;;; current meta-process then a warning is printed, no event is scheduled, ;;; and nil is returned. ;;; ;;; The scheduled event is returned when successfully created and scheduled. ;;; ;;; schedule-break ;;; ;;; (defun schedule-break (time &key (priority :max) (details nil))) ;;; ;;; time a time in seconds which should be a non-negative number ;;; priority a number or the keywords :max or :min ;;; details a string describing the event for the trace or nil ;;; ;;; schedule-break creates a new break event at the specified time with ;;; the priority and details provided. The model of the event will be the ;;; current model and the module is set to :none. A break event does not ;;; have an action and is only used to stop the scheduler. That new event ;;; is then added to the event queue of the current meta-process. ;;; ;;; If any of the parameters are invalid or there is no current model or ;;; current meta-process then a warning is printed, no event is scheduled, ;;; and nil is returned. ;;; ;;; The scheduled event is returned when successfully created and scheduled. ;;; ;;; schedule-break-relative ;;; ;;; (defun schedule-break-relative (time-delay ;;; &key (priority :max) (details nil))) ;;; ;;; time-delay a time in seconds which should be a non-negative number ;;; priority a number or the keywords :max or :min ;;; details a string describing the event for the trace or nil ;;; ;;; schedule-break-relative creates a new break event with a time set to the ;;; current time plus the specified time-delay with the priority and details ;;; provided. The model of the event will be the current model and the ;;; module is set to :none. A break event does not have an action and is ;;; only used to stop the scheduler. That new event is then added to the ;;; event queue of the current meta-process. ;;; ;;; If any of the parameters are invalid or there is no current model or ;;; current meta-process then a warning is printed, no event is scheduled, ;;; and nil is returned. ;;; ;;; The scheduled event is returned when successfully created and scheduled. ;;; ;;; schedule-break-after-module ;;; ;;; (defun schedule-break-after-module (after-module ;;; &key (details nil) (delay t))) ;;; ;;; ;;; after-module a symbol that names a module ;;; details a string describing the event for the trace or nil ;;; delay one of t, nil, or :abort. ;;; ;;; schedule-break-after-module creates a break event with the supplied ;;; details and the current model for its model. ;;; ;;; If there is an event currently in the event queue with the module name ;;; of after-module and the same model as the current model then this new ;;; event is placed into the event queue at the time of the next such event ;;; (lowest time) with a priority of :min. ;;; ;;; If there is no event in the event queue that matches on both model and ;;; module then the value of delay determines what happens to the new event. ;;; ;;; If delay is t then the new event is placed into the set of waiting events ;;; to be scheduled after an event which matches after-module and the ;;; current model. ;;; ;;; If delay is nil then the new event is added to the event queue for ;;; immediate execution. Its time will be set to the current time and its ;;; priority will be :max. ;;; ;;; If delay is :abort then the new event is discarded without being ;;; scheduled. ;;; ;;; schedule-break-after-module returns 2 values. ;;; ;;; If there is no current model or current meta-process or any of the ;;; parameters are invalid, then no event is scheduled and both values are ;;; nil. ;;; ;;; If an event is scheduled then the first value will be the event and the ;;; second value will be t if the event is in the waiting queue or nil if ;;; it is in the event queue. ;;; ;;; If the event is aborted the first value will be nil and the second value ;;; will be :abort. ;;; ;;; schedule-break-after-all ;;; ;;; (defun schedule-break-after-all (&key (details nil))) ;;; ;;; details a string describing the event for the trace or nil ;;; ;;; schedule-break-after-all creates a new break event with the provided ;;; details. The event's model is set to the current model and the module ;;; is set to :none. A break event does not have an action and is only ;;; used to stop the scheduler. The time for this new event is the greatest ;;; time of any event currently in the event queue of the current meta-process ;;; and its priority is :min. It will be inserted into the event queue such ;;; that it will occur after all of the events currently scheduled. ;;; ;;; If details is invalid or there is no current model or current meta-process ;;; then a warning is printed, no event is scheduled, and nil is returned. ;;; ;;; The scheduled event is returned when successfully created and scheduled. ;;; ;;; delete-event ;;; ;;; (defun delete-event (event)) ;;; ;;; event is an event that was returned by one of the scheduling functions ;;; ;;; If event is in either the event queue or the waiting queue of the ;;; current meta-process it is removed. ;;; ;;; If there is no current meta-process a warning is displayed. ;;; ;;; If the event is removed from either queue t is returned, otherwise it ;;; returns nil. ;;; ;;; ;;; add-pre-event-hook ;;; ;;; (defun add-pre-event-hook (hook-fn)) ;;; ;;; hook-fn a function which accepts one parameter or the name of such a ;;; function ;;; ;;; hook-fn function is added to the set of functions to be called before ;;; each event is processed in the current meta-process. An event that is ;;; about to be processed will be passed to the hook-fn function before it ;;; is executed by the scheduler. ;;; ;;; If there is no current meta-process a warning is displayed and nil is ;;; returned. ;;; If there is a current meta-process, then an id for hook-fn is returned. ;;; ;;; add-post-event-hook ;;; ;;; (defun add-post-event-hook (hook-fn)) ;;; ;;; hook-fn a function which accepts one parameter or the name of such a ;;; function ;;; ;;; hook-fn function is added to the set of functions to be called after ;;; each event is processed in the current meta-process. After an event ;;; is executed it will be passed to the hook-fn function. ;;; ;;; If there is no current meta-process a warning is displayed and nil is ;;; returned. ;;; If there is a current meta-process, then an id for hook-fn is returned. ;;; ;;; delete-event-hook ;;; ;;; (defun delete-event-hook (hook-fn-id)) ;;; ;;; hook-fn-id a hook function id that was returned from either ;;; add-pre-event-hook or add-post-event-hook ;;; ;;; If the hook function with hook-fn-id is still a member of either set of ;;; hook functions in the current meta-process then it is removed from the ;;; set of hook functions. ;;; ;;; If there is no current meta-process a warning is displayed and nil is ;;; returned. ;;; ;;; If the hook function with hook-fn-id has already been removed or ;;; hook-fn-id is otherwise invalid nil is returned. ;;; ;;; It a function is successfully removed then that function (or function name) ;;; is returned. ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Design Choices: ;;; ;;; Keep the system as simple as I can. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; 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 *periodic-event-id-counter* 0) (defun run-sched-queue (mp stop-condition &key (real-time nil)) "The internal function that steps through events sending them to be executed until a condtion is met" (let ((event-count 0) (toggle nil)) ; can get stuck due to floating point math... (setf (meta-p-start-time mp) (meta-p-time mp)) (setf (meta-p-start-real-time mp) (funcall (meta-p-time-function mp))) (setf (meta-p-break mp) nil) (while (and (not (meta-p-break mp)) (meta-p-events mp) (not (funcall stop-condition mp (evt-time (first (meta-p-events mp))) event-count))) (if (and (null toggle) (meta-p-max-time-delta mp) (numberp (meta-p-max-time-delta mp)) (> (- (evt-time (first (meta-p-events mp))) (meta-p-time mp)) (meta-p-max-time-delta mp))) (progn (setf toggle t) (dolist (model (mp-models)) (with-model-fct model `((schedule-event-relative ,(meta-p-max-time-delta mp) 'dummy-event-function :priority :max :details "A dummy event to prevent model skip ahead" :output nil))))) (progn (setf toggle nil) (run-one-event mp real-time) (incf event-count)))) (setf (meta-p-events mp) (remove 'dummy-event-function (meta-p-events mp) :key #'evt-action)) (values (- (meta-p-time mp) (meta-p-start-time mp)) event-count (meta-p-break mp)))) ;;; run-one-event ;;; ;;; This function takes one required parameter which is a meta-process (not ;;; a name of a meta-process). ;;; ;;; The first event on the meta-process's scheduled events queue is removed, ;;; the clock is updated, a line is printed to the trace to indicate the event, ;;; and that event's action is executed with *current-model* set to the model ;;; specified in that event (even if it doesn't name a model). If there are ;;; any event hook functions, they are called with the event as a parameter ;;; as appropriate (a pre-hook is called before the action and a post-hook is ;;; called after the action). (defun run-one-event (mp &optional (real-time nil)) "Dispatch the next event on the meta-process's schedule" (let ((next-event (pop (meta-p-events mp))) (current-model (meta-p-current-model (current-mp)))) (unwind-protect (progn (set-mp-clock mp (evt-time next-event) real-time) (when (evt-model next-event) (setf (meta-p-current-model (current-mp)) (gethash (evt-model next-event) (meta-p-models (current-mp))))) (dolist (hook (meta-p-pre-events mp)) (funcall hook next-event)) (when (and (evt-output next-event) (filter-output-events next-event)) (model-output (format-event next-event))) (if (evt-destination next-event) (apply (evt-action next-event) (append (list (get-module-fct (evt-destination next-event))) (evt-params next-event))) (apply (evt-action next-event) (evt-params next-event))) (dolist (hook (meta-p-post-events mp)) (funcall hook next-event)) ) (setf (meta-p-current-model (current-mp)) current-model)))) ;;; set-mp-clock ;;; ;;; This function takes two parameters which are a meta-process, and a time. ;;; ;;; The meta-process's time is updated to the specified time and then if the ;;; meta-process's mp-real-time-p slot is non-nil it spins until the appropriate ;;; amount of time has passed. ;;; ;;; The spin should probably call sleep, or perhaps a machine specific ;;; event handler so that it could be swapped out and doesn't swamp the ;;; processor because that could be an issue for multiple models in a real time ;;; environment. (defun set-mp-clock (mp time real-time) "Update the time of a meta-process and maybe spin for the necessary real time" (unless (= time (meta-p-time mp)) (let ((current-model (meta-p-current-model mp))) (unwind-protect (progn (maphash #'(lambda (model-name model) (declare (ignore model-name)) (setf (meta-p-current-model mp) model) (dolist (module (updating-modules)) (update-the-module module (meta-p-time mp) time))) (meta-p-models mp))) (setf (meta-p-current-model mp) current-model)))) (setf (meta-p-time mp) time) (when real-time (do ((delta-model (- time (meta-p-start-time mp))) (delta-real (/ (- (funcall (meta-p-time-function mp)) (meta-p-start-real-time mp)) (meta-p-units-per-second mp)) (/ (- (funcall (meta-p-time-function mp)) (meta-p-start-real-time mp)) (meta-p-units-per-second mp)))) ((>= delta-real delta-model)) (funcall (meta-p-slack-function mp) (- delta-model delta-real))))) (defun real-time-slack (delta) (when (> delta .150) (sleep delta))) ;;; This function lets all the models know that a run has terminated. (defun send-run-terminated-events (mp) (let ((current-model (meta-p-current-model mp))) (unwind-protect (dolist (model-name (hash-table-keys (meta-p-models mp))) (push (make-act-r-maintenance-event :time (mp-time) :priority :max :action 'run-terminated :params nil :model model-name :mp (current-meta-process) :output nil ) (meta-p-events mp)) (run-one-event mp)) (setf (meta-p-current-model mp) current-model)))) (defun run-terminated () "Dummy function to signal end of a call to run for a model" ) (defun run (run-time &key (real-time nil)) (verify-current-mp "run called with no current meta-process." (if (not (and (numberp run-time) (> run-time 0))) (print-warning "run-time must be a number greater than zero.") (flet ((test (mp next-time count) (declare (ignore count)) (> (- next-time (meta-p-start-time mp)) run-time))) (multiple-value-bind (time events break) (run-sched-queue (current-mp) #'test :real-time real-time) (unless break (send-run-terminated-events (current-mp)) (if (< time run-time) (if (null (meta-p-events (current-mp))) (meta-p-output (format-event (make-act-r-event :time (mp-time) :module "------" :model '-- :details "Stopped because no events left to process" :output t :mp (current-meta-process)))) (progn (run-full-time (- run-time time) :real-time nil) (setf time run-time))) (meta-p-output (format-event (make-act-r-event :time (mp-time) :module "------" :model '-- :details "Stopped because time limit reached" :output t :mp (current-meta-process)))) )) (values time events break)))))) (defun run-until-condition (condition &key (real-time nil)) (verify-current-mp "run-until-condition called with no current meta-process." (if (not (or (functionp condition) (fboundp condition))) (print-warning "condition must be a function.") (multiple-value-bind (time events break) (run-sched-queue (current-mp) #'(lambda (mp next-time count) (declare (ignore mp next-time count)) (funcall condition)) :real-time real-time) (unless break (send-run-terminated-events (current-mp)) (if (null (meta-p-events (current-mp))) (meta-p-output (format-event (make-act-r-event :time (mp-time) :module "------" :model '-- :details "Stopped because no events to process" :output t :mp (current-meta-process)))) (meta-p-output (format-event (make-act-r-event :time (mp-time) :module "------" :model '-- :details "Stopped because condition is true" :output t :mp (current-meta-process)))) )) (values time events break))))) (defun run-full-time (run-time &key (real-time nil)) (verify-current-mp "run-full-time called with no current meta-process." (if (not (and (numberp run-time) (> run-time 0))) (print-warning "run-time must be a number greater than zero.") (run-until-time (+ run-time (mp-time)) :real-time real-time)))) (defun dummy-event-function () ) (defun run-until-time (end-time &key (real-time nil)) (verify-current-mp "run-until-time called with no current meta-process." (if (not (and (numberp end-time) (> end-time 0))) (print-warning "end-time must be a number greater than zero.") (progn (setf end-time (ms-round end-time)) (if (<= end-time (mp-time)) (progn (meta-p-output (format-event (make-act-r-event :time (mp-time) :module "------" :model '-- :details "Stopped because end time already passed" :output t :mp (current-meta-process)))) (values 0 0 nil)) (flet ((test (mp next-time count) (declare (ignore count) (ignore mp)) (> next-time end-time))) (if (current-model) (schedule-event end-time 'dummy-event-function :maintenance t :priority :min :details "A dummy event to guarantee a run until time" :output nil) (with-model-fct (first (mp-models)) ;; just pick the first one `((schedule-event ,end-time 'dummy-event-function :maintenance t :priority :min :details "A dummy event to guarantee a run until time" :output nil)))) (multiple-value-bind (time events break) (run-sched-queue (current-mp) #'test :real-time real-time) (unless break (send-run-terminated-events (current-mp)) (meta-p-output (format-event (make-act-r-event :time (mp-time) :module "------" :model '-- :details "Stopped because time limit reached" :output t :mp (current-meta-process))))) (values time events break)))))))) (defun run-n-events (event-count &key (real-time nil)) (verify-current-mp "run-n-events called with no current meta-process." (if (not (and (numberp event-count) (> event-count 0))) (print-warning "event-count must be a number greater than zero.") (flet ((test (mp next-time count) (declare (ignore next-time) (ignore mp)) (= count event-count))) (multiple-value-bind (time events break) (run-sched-queue (current-mp) #'test :real-time real-time) (unless break (send-run-terminated-events (current-mp)) (if (< events event-count) (meta-p-output (format-event (make-act-r-event :time (mp-time) :module "------" :model '-- :details "Stopped because no events to process" :output t :mp (current-meta-process)))) (meta-p-output (format-event (make-act-r-event :time (mp-time) :module "------" :model '-- :details "Stopped because event limit reached" :output t :mp (current-meta-process)))))) (values time events break)))))) (defun run-step () (verify-current-mp "run-step called with no current meta-process." (flet ((test (mp next-time count) (declare (ignore next-time count)) (loop (when (null (meta-p-events mp)) (format t "No more events to process") (return t) ) (format t "Next Event: ~A~%" (format-event (car (meta-p-events mp)))) (format t "[A]bort (or [q]uit)~%") (format t "[D]elete~%") (format t "[E]xecute~%") (let ((response (read ))) (case response ((a q) (return t)) (e (return nil)) (d (pop (meta-p-events mp))) ))))) (multiple-value-bind (time events break) (run-sched-queue (current-mp) #'test :real-time nil) (unless break (send-run-terminated-events (current-mp)) (meta-p-output (format-event (make-act-r-event :time (mp-time) :module "------" :model '-- :details "Stepping stopped" :output t :mp (current-meta-process))))) (values time events break))))) (defun schedule-event (time action &key (maintenance nil) (module :none) (destination nil) (priority 0) (params nil) (details nil) (output t)) (verify-current-mp "schedule-event called with no current meta-process." (verify-current-model "schedule-event called with no current model." (let ((mp (current-mp))) (cond ((not (and (numberp time) (>= time 0))) (print-warning "Time must be non-negative number.")) ((not (or (functionp action) (fboundp action))) (print-warning "Can't schedule ~S not a function or function name." action)) ((not (or (numberp priority) (eq priority :min) (eq priority :max))) (print-warning "Priority must be a number or :min or :max.")) ((not (listp params)) (print-warning "params must be a list.")) (t (let ((new-event (funcall (if maintenance #'make-act-r-maintenance-event #'make-act-r-event) :mp (meta-p-name mp) :model (current-model) :module module :time (ms-round time) :priority priority :action action :params params :details details :output output :destination destination))) (insert-queue-event mp new-event) (when (meta-p-delayed mp) (update-waiting-events mp new-event)) new-event))))))) (defun schedule-maintenance-event (time action &key (module :none) (destination nil) (priority 0) (params nil) (details nil) (output t)) (print-warning "The schedule-maintenance functions no longer exist.") (print-warning "Instead there is now a maintenance keyword accepted by the regular schedule-* functions.")) ;;; insert-queue-event ;;; ;;; This function takes two parameter which are a meta-process and an ;;; event. The event is added to the list of scheduled events for the ;;; meta-process in order based on its time and priority. ;;; ;;; Items are ordered by time first, lower times occuring before higher ;;; times. If two events have the same time then: ;;; ;;; An event with priority :max occurs before any event in the queue with ;;; the same time except existing events of :max ;;; priority ;;; An event with a numeric priority occurs before an event with a lesser ;;; numbered priority or a priority of :min ;;; An event with priority :min occurs after any events at that time ;;; (defun insert-queue-event (mp event) "Place an event into the scheduled-events list maintaing the ordering" (if (null (meta-p-events mp)) (push event (meta-p-events mp)) (setf (meta-p-events mp) (do* ((pos 0 (1+ pos)) (queue (meta-p-events mp) (cdr queue))) ((or (null queue) (eq :left (compare-events event (car queue)))) (splice-into-list-des (meta-p-events mp) pos event)))))) (defun compare-events (new-event old-event) (if (or (> (evt-time new-event) (evt-time old-event)) (and (= (evt-time new-event) (evt-time old-event)) (or (eq (evt-priority new-event) :min) (eq (evt-priority old-event) :max) (and (numberp (evt-priority new-event)) (numberp (evt-priority old-event)) (<= (evt-priority new-event) (evt-priority old-event)))))) :right :left)) ;;; update-waiting-events ;;; ;;; This function takes two parameters, a meta-process and an event. The ;;; list of waiting events for the meta-process is checked to see if the ;;; event specified allows any of them to be added to the scheduled events. ;;; If an event can be moved to the scheduled events list it is removed ;;; from the waiting events list and it is added to the scheduled events ;;; list (which will call update-waiting-events to test whether that event ;;; frees others from the waiting list). (defun update-waiting-events (mp new-event) "Check the list of waiting events to see if a new event allows any to run" (let ((moved-events nil)) (dolist (event (meta-p-delayed mp)) (when (conditions-met event new-event) (setf (meta-p-delayed mp) (remove event (meta-p-delayed mp))) (setf (evt-wait-condition event) nil) (push event moved-events))) (dolist (event moved-events) (if (act-r-break-event-p event) (schedule-break (evt-time new-event) :priority :min :details (evt-details event)) (schedule-event (evt-time new-event) (evt-action event) :module (evt-module event) :details (evt-details event) :params (evt-params event) :priority :min :output (evt-output event) :destination (evt-destination event) :maintenance (act-r-maintenance-event-p event)))))) ;;; conditions-met ;;; ;;; This function takes two parameters which are a waiting-event and a ;;; new-event. (defun conditions-met (w-event new-event) "Test whether a waiting event's wait-for reason is met by a new event" (case (car (evt-wait-condition w-event)) (:any (and (eq (evt-model w-event) (evt-model new-event)) (or (second (evt-wait-condition w-event)) (not (act-r-maintenance-event-p new-event))))) (:module (and (or (eq (evt-model w-event) (evt-model new-event)) (null (evt-model w-event))) (eq (second (evt-wait-condition w-event)) (evt-module new-event)) (or (third (evt-wait-condition w-event)) (not (act-r-maintenance-event-p new-event))))) (t nil))) (defun schedule-event-relative (time-delay action &key (maintenance nil) (module :none) (destination nil) (priority 0) (params nil) (details nil) (output t)) (verify-current-mp "schedule-event-relative called with no current meta-process." (verify-current-model "schedule-event-relative called with no current model." (let ((mp (current-mp))) (cond ((not (and (numberp time-delay) (>= time-delay 0))) (print-warning "Time-delay must be non-negative number.")) ((not (or (functionp action) (fboundp action))) (print-warning "Can't schedule ~S not a function or function name." action)) ((not (or (numberp priority) (eq priority :min) (eq priority :max))) (print-warning "Priority must be a number or :min or :max.")) ((not (listp params)) (print-warning "params must be a list.")) (t (let ((new-event (funcall (if maintenance #'make-act-r-maintenance-event #'make-act-r-event) :mp (meta-p-name mp) :model (current-model) :module module :time (ms-round (+ (meta-p-time mp) time-delay)) :priority priority :action action :params params :details details :output output :destination destination))) (insert-queue-event mp new-event) (when (meta-p-delayed mp) (update-waiting-events mp new-event)) new-event))))))) (defun schedule-maintenance-event-relative (time-delay action &key (module :none) (destination nil) (priority 0) (params nil) (details nil) (output t)) (print-warning "The schedule-maintenance functions no longer exist.") (print-warning "Instead there is now a maintenance keyword accepted by the regular schedule-* functions.")) (defun schedule-event-after-module (after-module action &key (maintenance nil) (module :none) (destination nil) (params nil) (details nil) (output t) (delay t) (include-maintenance nil)) (let ((first-val (verify-current-mp "schedule-event-after-module called with no current meta-process." (verify-current-model "schedule-event-after-module called with no current model." (let ((mp (current-mp))) (cond ((not (valid-module-name after-module)) (print-warning "after-module must name a module.")) ((not (or (functionp action) (fboundp action))) (print-warning "Can't schedule ~S not a function or function name." action)) ((not (listp params)) (print-warning "params must be a list.")) (t (let* ((new-event (funcall (if maintenance #'make-act-r-maintenance-event #'make-act-r-event) :mp (meta-p-name mp) :model (current-model) :module module :priority :min :action action :params params :details details :output output :destination destination :wait-condition (list :module after-module include-maintenance))) (matching-event (find-if #'(lambda (x) (conditions-met new-event x)) (meta-p-events mp)))) (cond (matching-event (setf (evt-time new-event) (evt-time matching-event)) (setf (evt-wait-condition new-event) nil) (insert-queue-event mp new-event) (when (meta-p-delayed mp) (update-waiting-events mp new-event)) new-event) ((null delay) (setf (evt-time new-event) (meta-p-time mp)) (setf (evt-priority new-event) :max) (setf (evt-wait-condition new-event) nil) (insert-queue-event mp new-event) (when (meta-p-delayed mp) (update-waiting-events mp new-event)) new-event) ((eq delay :abort) :abort) (t (push new-event (meta-p-delayed mp)) new-event)))))))))) (if first-val (if (act-r-event-p first-val) (values first-val (if (evt-wait-condition first-val) t nil)) (values nil :abort)) (values nil nil)))) (defun schedule-event-after-change (action &key (maintenance nil) (module :none) (destination nil) (params nil) (details nil) (output t) (delay t) (include-maintenance nil)) (let ((first-val (verify-current-mp "schedule-event-after-change called with no current meta-process." (verify-current-model "schedule-event-after-change called with no current model." (let ((mp (current-mp))) (cond ((not (or (functionp action) (fboundp action))) (print-warning "Can't schedule ~S not a function or function name." action)) ((not (listp params)) (print-warning "params must be a list.")) (t (let* ((new-event (funcall (if maintenance #'make-act-r-maintenance-event #'make-act-r-event) :mp (meta-p-name mp) :model (current-model) :module module :priority :min :action action :params params :details details :output output :destination destination :wait-condition (list :any include-maintenance))) (matching-event (find-if #'(lambda (x) (conditions-met new-event x)) (meta-p-events mp)))) (cond (matching-event (setf (evt-time new-event) (evt-time matching-event)) (setf (evt-wait-condition new-event) nil) (insert-queue-event mp new-event) (when (meta-p-delayed mp) (update-waiting-events mp new-event)) new-event) ((null delay) (setf (evt-time new-event) (meta-p-time mp)) (setf (evt-priority new-event) :max) (setf (evt-wait-condition new-event) nil) (insert-queue-event mp new-event) (when (meta-p-delayed mp) (update-waiting-events mp new-event)) new-event) ((eq delay :abort) :abort) (t (push new-event (meta-p-delayed mp)) new-event)))))))))) (if first-val (if (act-r-event-p first-val) (values first-val (if (evt-wait-condition first-val) t nil)) (values nil :abort)) (values nil nil)))) (defun schedule-periodic-event (period action &key (maintenance nil) (module :none) (destination nil) (priority 0) (params nil) (details nil) (output t) (initial-delay 0)) (verify-current-mp "schedule-periodic-event called with no current meta-process." (verify-current-model "schedule-event called with no current model." (let ((mp (current-mp))) (cond ((not (and (numberp period) (> period 0))) (print-warning "period must be greater than 0.")) ((not (and (numberp initial-delay) (>= initial-delay 0))) (print-warning "initial-dealy must be a non-negative number.")) ((not (or (functionp action) (fboundp action))) (print-warning "Can't schedule ~S not a function or function name." action)) ((not (or (numberp priority) (eq priority :min) (eq priority :max))) (print-warning "Priority must be a number or :min or :max.")) ((not (listp params)) (print-warning "params must be a list.")) (t (let* ((real-event (funcall (if maintenance #'make-act-r-maintenance-event #'make-act-r-event) :mp (meta-p-name mp) :model (current-model) :module module :priority :max :action action :params params :details details :output output :destination destination)) (id (incf *periodic-event-id-counter*)) (periodic-event (make-act-r-periodic-event :id id :mp (meta-p-name mp) :module :none :model (current-model) :time (ms-round (+ (meta-p-time mp) initial-delay)) :priority priority :action 'periodic-action :params (list id real-event period priority) :output nil :details ;(format nil ; "Periodic Action: ~A Period: ~A" action period) (concatenate 'string "Periodic-Action " (if (fboundp action) (symbol-name action) "Unnamed function") " " (princ-to-string period)) ))) (insert-queue-event mp periodic-event) (when (meta-p-delayed mp) (update-waiting-events mp periodic-event)) periodic-event))))))) (defun periodic-action (id event period priority) (let* ((mp (current-mp)) (periodic-event (make-act-r-periodic-event :id id :mp (evt-mp event) :model (evt-model event) :module :none :time (ms-round (+ (meta-p-time mp) period)) :priority priority :action 'periodic-action :params (list id event period priority) :output nil :details ;(format nil ; "Periodic Action: ~A Period: ~A" (evt-action event) period) (concatenate 'string "Periodic-Action " (symbol-name (evt-action event)) " " (princ-to-string period))))) (setf (evt-time event) (meta-p-time mp)) (insert-queue-event mp event) (when (meta-p-delayed mp) (update-waiting-events mp event)) (insert-queue-event mp periodic-event) (when (meta-p-delayed mp) (update-waiting-events mp periodic-event)))) (defun schedule-break (time &key (priority :max) (details nil)) (verify-current-mp "schedule-break called with no current meta-process." (let ((mp (current-mp))) (cond ((not (and (numberp time) (>= time 0))) (print-warning "Time must be non-negative number.")) ((not (or (numberp priority) (eq priority :min) (eq priority :max))) (print-warning "Priority must be a number or :min or :max.")) (t (let ((new-event (make-act-r-break-event :mp (meta-p-name mp) :time (ms-round time) :params (list mp) :priority priority :details details))) (insert-queue-event mp new-event) (when (meta-p-delayed mp) (update-waiting-events mp new-event)) new-event)))))) (defun schedule-break-relative (time-delay &key (priority :max) (details nil)) (verify-current-mp "schedule-break-relative called with no current meta-process." (let ((mp (current-mp))) (cond ((not (and (numberp time-delay) (>= time-delay 0))) (print-warning "Time-delay must be non-negative number.")) ((not (or (numberp priority) (eq priority :min) (eq priority :max))) (print-warning "Priority must be a number or :min or :max.")) (t (let ((new-event (make-act-r-break-event :mp (meta-p-name mp) :time (ms-round (+ (meta-p-time mp) time-delay)) :params (list mp) :priority priority :details details))) (insert-queue-event mp new-event) (when (meta-p-delayed mp) (update-waiting-events mp new-event)) new-event)))))) (defun schedule-break-after-module (after-module &key (details nil) (delay t)) (let ((first-val (verify-current-mp "schedule-break-after-module called with no current meta-process." (verify-current-model "schedule-break-after-module called with no current model." (let ((mp (current-mp))) (cond ((not (valid-module-name after-module)) (print-warning "after-module must name a module.")) (t (let* ((new-event (make-act-r-break-event :mp (meta-p-name mp) :model (current-model) :priority :min :params (list mp) :details details :wait-condition (list :module after-module t))) (matching-event (find-if #'(lambda (x) (conditions-met new-event x)) (meta-p-events mp)))) (cond (matching-event (setf (evt-time new-event) (evt-time matching-event)) (setf (evt-wait-condition new-event) nil) (insert-queue-event mp new-event) (when (meta-p-delayed mp) (update-waiting-events mp new-event)) new-event) ((null delay) (setf (evt-time new-event) (meta-p-time mp)) (setf (evt-priority new-event) :max) (setf (evt-wait-condition new-event) nil) (insert-queue-event mp new-event) (when (meta-p-delayed mp) (update-waiting-events mp new-event)) new-event) ((eq delay :abort) :abort) (t (push new-event (meta-p-delayed mp)) new-event)))))))))) (if first-val (if (act-r-event-p first-val) (values first-val (if (evt-wait-condition first-val) t nil)) (values nil :abort)) (values nil nil)))) (defun schedule-break-after-all (&key (details nil)) (verify-current-mp "schedule-break called with no current meta-process." (let* ((mp (current-mp)) (new-event (make-act-r-break-event :mp (meta-p-name mp) :params (list mp) :priority :min :details details))) (setf (evt-time new-event) (if (meta-p-events mp) (evt-time (car (last (meta-p-events mp)))) (meta-p-time mp))) (insert-queue-event mp new-event) (when (meta-p-delayed mp) (update-waiting-events mp new-event)) new-event))) (defmethod delete-event ((event act-r-event)) (verify-current-mp "delete-event called with no current meta-process." (let* ((mp (current-mp)) (events (find event (meta-p-events mp))) (waiting (find event (meta-p-delayed mp)))) (cond (events (setf (meta-p-events mp) (remove event (meta-p-events mp))) t) (waiting (setf (meta-p-delayed mp) (remove event (meta-p-delayed mp))) t) (t nil))))) (defmethod delete-event ((event act-r-periodic-event)) (verify-current-mp "delete-event called with no current meta-process." (let* ((mp (current-mp)) (events (find (act-r-periodic-event-id event) (meta-p-events mp) :key #'(lambda (x) (and (eq (type-of x) 'act-r-periodic-event) (act-r-periodic-event-id x))))) (waiting (find (act-r-periodic-event-id event) (meta-p-delayed mp) :key #'(lambda (x) (and (eq (type-of x) 'act-r-periodic-event) (act-r-periodic-event-id x)))))) (cond (events (setf (meta-p-events mp) (remove (act-r-periodic-event-id event) (meta-p-events mp) :key #'(lambda (x) (and (eq (type-of x) 'act-r-periodic-event) (act-r-periodic-event-id x))))) t) (waiting (setf (meta-p-delayed mp) (remove (act-r-periodic-event-id event) (meta-p-delayed mp) :key #'(lambda (x) (and (eq (type-of x) 'act-r-periodic-event) (act-r-periodic-event-id x))))) t) (t nil))))) (defun add-pre-event-hook (hook-fn &optional (warn t)) (verify-current-mp "add-pre-event-hook called with no current meta-process" (let ((mp (current-mp))) (cond ((not (or (functionp hook-fn) (fboundp hook-fn))) (print-warning "parameter ~s to add-pre-event-hook is not a function" hook-fn)) ((member hook-fn (meta-p-pre-events mp)) (when warn (print-warning "~s is already on the pre-event-hook list not added again" hook-fn))) (t (push hook-fn (meta-p-pre-events mp)) (setf (gethash (meta-p-next-hook-id mp) (meta-p-hook-table mp)) (cons :pre hook-fn)) (1- (incf (meta-p-next-hook-id mp)))))))) (defun add-post-event-hook (hook-fn &optional (warn t)) (verify-current-mp "add-post-event-hook called with no current meta-process" (let ((mp (current-mp))) (cond ((not (or (functionp hook-fn) (fboundp hook-fn))) (print-warning "parameter ~s to add-post-event-hook is not a function" hook-fn)) ((member hook-fn (meta-p-post-events mp)) (when warn (print-warning "~s is already on the post-event-hook list not added again" hook-fn))) (t (push hook-fn (meta-p-post-events mp)) (setf (gethash (meta-p-next-hook-id mp) (meta-p-hook-table mp)) (cons :post hook-fn)) (1- (incf (meta-p-next-hook-id mp)))))))) (defun delete-event-hook (hook-fn-id) (verify-current-mp "delete-event-hook called with no current meta-process" (let* ((mp (current-mp)) (event (gethash hook-fn-id (meta-p-hook-table mp)))) (when event (remhash hook-fn-id (meta-p-hook-table mp)) (if (eq :pre (car event)) (setf (meta-p-pre-events mp) (remove (cdr event) (meta-p-pre-events mp))) (setf (meta-p-post-events mp) (remove (cdr event) (meta-p-post-events mp)))) (cdr event))))) #| This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by the Free Software Foundation; either version 2.1 of the License, or (at your option) any later version. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA |# ;; /Users/ritter/ritter/proposals/onr-emotions4/iccm07/actr6-15jan07/framework/scheduling.lisp ;; **************************************************************** ;; **************************************************************** ;; /Users/ritter/ritter/proposals/onr-emotions4/iccm07/actr6-15jan07/framework/chunk-spec.lisp ;; ;;; -*- mode: LISP; Syntax: COMMON-LISP; Base: 10 -*- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Author : Dan Bothell ;;; Copyright : (c) 2004 Dan Bothell ;;; Availability: Covered by the GNU LGPL, see LGPL.txt ;;; Address : Department of Psychology ;;; : Carnegie Mellon University ;;; : Pittsburgh, PA 15213-3890 ;;; : db30@andrew.cmu.edu ;;; ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Filename : chunk-spec.lisp ;;; Version : 1.0a1 ;;; ;;; Description : Definition of chunk specifications and corresponding functions ;;; ;;; Bugs : ;;; ;;; To do : * Finish the documentation. ;;; : * Investigate optimizations after there's some use. ;;; : * Add a function to check chunk-specs to make module writing ;;; : easier. ;;; ----- History ----- ;;; ;;; 2004.09.02 Dan ;;; : Creation. ;;; 2004.12.29 Dan ;;; : Realized that the comparitors are backwards with respect ;;; : to productions in test-chunk-slots. ;;; 2005.02.03 Dan ;;; : * Changing the internal slot-value-lists of a chunk to be a ;;; : hash-table instead of an alist... ;;; 2005.02.09 Dan ;;; : * Some minor cleanup - changing member to find where possible. ;;; 2005.04.19 Dan ;;; : * Added pprint-chunk-spec. ;;; 2005.05.16 Dan ;;; : * Modified chunk-spec-variable-p to test that the name has ;;; : a length > 1 to reject the symbol itself as a variable. ;;; : That fixes a minor problem in production parsing and I ;;; : don't think it breaks anything else. ;;; 2005.09.09 Dan ;;; : * Renamed chunk-to-chunk-spec chunk-name-to-chunk-spec to ;;; : clarify its use because I introduced a bug somewhere ;;; : along the line with its usage that didn't actually affect ;;; : any existing modules, but may cause problems for other ;;; : module writers. ;;; : * Also fixed chunk-name-to-chunk-spec because it didn't ;;; : include nil slots in the spec, but it probably should (it ;;; : did prior to my "fixing" it when I changed over to hash ;;; : tables). ;;; 2005.11.17 Dan ;;; : * Fixed chunk-name-to-chunk-spec because it incorrectly ;;; : referenced the internal chunk-type slot list instead of ;;; : using ct-slot-names. ;;; 2006.09.11 Dan ;;; : * Changed chunk-slot-equal so that it uses equalp instead of ;;; : equal when the string and chunk checks fall through because ;;; : numbers (which is the typical value that'd fall through) ;;; : don't test well with equal... ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; General Docs: ;;; ;;; The structures are not for external use. ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Public API: ;;; ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Design Choices: ;;; ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; The code ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; #+:packaged-actr (in-package :act-r) #+(and :clean-actr (not :packaged-actr) :ALLEGRO-IDE) (in-package :cg-user) #-(or (not :clean-actr) :packaged-actr :ALLEGRO-IDE) (in-package :cl-user) (defmacro define-chunk-spec (&rest specifications) `(define-chunk-spec-fct ',specifications)) (defun define-chunk-spec-fct (specifications-list) (verify-current-mp "define-chunk-spec-fct called with no current meta-process." (verify-current-model "define-chunk-spec-fct called with no current model." (cond ((null specifications-list) (print-warning "No specification in call to define-chunk-spec.")) ((= (length specifications-list) 1) (if (get-chunk (car specifications-list)) (chunk-name-to-chunk-spec (car specifications-list)) (print-warning "define-chunk-spec's 1 parameter doesn't name a chunk: ~S" specifications-list))) ((not (eq (car specifications-list) 'isa)) (print-warning "First element to define-chunk-spec isn't the symbol ISA. ~s" specifications-list)) ((not (get-chunk-type (second specifications-list))) (print-warning "Second element in define-chunk-spec isn't a chunk-type. ~S" specifications-list)) (t (let* ((ct (get-chunk-type (second specifications-list))) (new-spec (make-act-r-chunk-spec :type ct)) (slots (process-slots-specs ct (cddr specifications-list)))) (unless (eq slots :error) (setf (act-r-chunk-spec-slots new-spec) slots) new-spec))))))) (defun chunk-name-to-chunk-spec (chunk-name) (awhen (get-chunk chunk-name) (let* ((ct (act-r-chunk-chunk-type it)) (spec (make-act-r-chunk-spec :type ct))) (dolist (slot (ct-slot-names ct) spec) (push (make-act-r-slot-spec :name slot :value (chk-slot-value it slot)) (act-r-chunk-spec-slots spec)))))) (defun chunk-spec-chunk-type (chunk-spec) (cond ((not (act-r-chunk-spec-p chunk-spec)) (print-warning "chunk-spec-chunk-type called with a non-chunk-spec")) (t (act-r-chunk-type-name (act-r-chunk-spec-type chunk-spec))))) (defun chunk-spec-slots (chunk-spec) (cond ((not (act-r-chunk-spec-p chunk-spec)) (print-warning "chunk-spec-slots called with something other than a chunk-spec")) (t (remove-duplicates (mapcar #'act-r-slot-spec-name (act-r-chunk-spec-slots chunk-spec)))))) (defun chunk-spec-slot-spec (chunk-spec &optional slot) (cond ((not (act-r-chunk-spec-p chunk-spec)) (print-warning "chunk-spec-slots called with something other than a chunk-spec")) (t (cond ((and slot (find slot (act-r-chunk-spec-slots chunk-spec) :key #'act-r-slot-spec-name)) (mapcar #'slot-spec-to-list (remove-if-not #'(lambda (x) (eq x slot)) (act-r-chunk-spec-slots chunk-spec) :key #'act-r-slot-spec-name))) (slot (print-warning "Slot ~S is not specified in the chunk-spec." slot)) (t (mapcar #'slot-spec-to-list (act-r-chunk-spec-slots chunk-spec))))))) (defun slot-in-chunk-spec-p (chunk-spec slot) (cond ((not (act-r-chunk-spec-p chunk-spec)) (print-warning "slot-in-chunk-spec-p called with something other than a chunk-spec")) (t (find slot (mapcar #'act-r-slot-spec-name (act-r-chunk-spec-slots chunk-spec)))))) (defun slot-spec-to-list (slot-spec) (list (act-r-slot-spec-modifier slot-spec) (act-r-slot-spec-name slot-spec) (act-r-slot-spec-value slot-spec))) (defun process-slots-specs (chunk-type specs) (let ((slots nil)) (loop (when (null specs) (return slots)) (let ((spec (make-act-r-slot-spec))) (when (find (car specs) '(= - > < >= <=)) (setf (act-r-slot-spec-modifier spec) (pop specs))) (when (null specs) (print-warning "Invalid specs in call to define-chunk-spec - not enough arguments") (return :error)) (unless (or (valid-slot-name (car specs) chunk-type) (keywordp (car specs))) (print-warning "Invalid slot-name ~S in call to define-chunk-spec." (car specs)) (return :error)) (setf (act-r-slot-spec-name spec) (pop specs)) (when (null specs) (print-warning "Invalid specs in call to define-chunk-spec - not enough arguments") (return :error)) (setf (act-r-slot-spec-value spec) (pop specs)) (push spec slots))))) (defun chunk-spec-variable-p (chunk-spec-slot-value &optional (char #\=)) (and (symbolp chunk-spec-slot-value) (eql (aref (string chunk-spec-slot-value) 0) char) (> (length (string chunk-spec-slot-value)) 1))) (defun match-chunk-spec-p (chunk-name chunk-spec &key (=test #'chunk-slot-equal) (-test #'chunk-slot-not-equal) (>test #'safe>) (>=test #'safe>=) (test >=test test >=test >test) (>= >=test) (< test #'safe>) (>=test #'safe>=) (test >test :>=test >=test :test >test :>=test >=test :> printing from the vw-output command used by the ;;; : virtual window device. ;;; 2005.08.10 Dan ;;; : * Removed a duplicate definition of prod-display. ;;; 2005.11.02 Dan ;;; : * Updated unlock-device so that tracking updates can be ;;; : recognized and handled as well as full proc-displays. ;;; 2006.03.07 Dan ;;; : * Fixed an old bug which I don't know how it got back in... ;;; : the theta for hyphen in the key mapping should be -1.11. ;;; 2006.03.08 Dan ;;; : * Made the key-to-loc and key-to-command tables consistent ;;; : with respect to - and hyphen. Both tables now have entries ;;; : for both symbols mapped to the same things. ;;; 2006.09.11 Dan ;;; : * Changed valid test for :mouse-fitts-coeff from posnum to nonneg. ;;; 2006.12.14 Dan ;;; : * Changed current-device-interface so that it only returns ;;; : one value. ;;; : * Reset all the versions to 1.1... ;;; 2006.12.18 Dan ;;; : * Removed the :speech-hook parameter since it was depricated ;;; : long ago. ;;; : * Also removed the :output-speech parameter because it doesn't ;;; : really have a purpose now - the default devices all have a ;;; : device-speak-string method even if it doesn't do anything. ;;; 2006.12.28 Dan ;;; : * Made proc-display better check for current mp/model/device. ;;; 2007.01.09 Dan ;;; : * Make output-key check the keyboard array boundaries to avoid ;;; : errors when bad key-locations come in. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; #+:packaged-actr (in-package :act-r) #+(and :clean-actr (not :packaged-actr) :ALLEGRO-IDE) (in-package :cg-user) #-(or (not :clean-actr) :packaged-actr :ALLEGRO-IDE) (in-package :cl-user) ;;; unless it's MCL define the pixels-per-inch #+(or (not :mcl) :openmcl) (progn (defvar *pixels-per-inch-x* 72) (defvar *pixels-per-inch-y* 72)) ;;; if it's ACL with the IDE (Windows) then find the true units-per-inch #+(and :ALLEGRO-IDE (not :ACTR-ENV-ALONE)) (multiple-value-bind (x y) (cg:stream-units-per-inch (cg:screen cg:*system*)) (setf *pixels-per-inch-x* x) (setf *pixels-per-inch-y* y)) ;;;; ---------------------------------------------------------------------- ;;;; ;;; The functions for ACT-R 6 (defun current-device-interface () "Return the device-interface for current model in the current meta-process" (values (get-module :device))) (defun install-device (device) "Set the device with which a model will interact" (verify-current-mp "install-device called with no current meta-process." (verify-current-model "install-device called with no current model." (setf (device (current-device-interface)) device)))) (defun current-device () "Return the device for the current model in the current meta-process" (verify-current-mp "current-device called with no current meta-process." (verify-current-model "current-device called with no current model." (device (current-device-interface))))) (defun proc-display (&key clear) "Processes the current display." (verify-current-mp "proc-display called with no current meta-process." (verify-current-model "proc-display called with no current model." (if (current-device-interface) (process-display (current-device-interface) (get-module :vision) clear) (print-warning "No device interface available to process"))))) ;;;; ---------------------------------------------------------------------- ;;;; ;;; roll in everything that was in "environment-interface" (defvar *actr-enabled-p* t) ;;;; ---------------------------------------------------------------------- ;;;; ;;;; Move these here (defun pm-pixels-to-angle (pixels) "Convert to degress of visual angle." (pixels->angle-mth (current-device-interface) pixels)) (defun pm-angle-to-pixels (angle) "Convert visual in degress to pixels." (angle->pixels-mth (current-device-interface) angle)) ;;;; ---------------------------------------------------------------------- ;;;; ;;;; Base DEVICE-INTERFACE class and some quicky methods. (defclass device-interface () ((pixels-per-inch :accessor ppi :initarg :ppi :initform (/ (+ *pixels-per-inch-x* *pixels-per-inch-y*) 2.0)) (viewing-distance :accessor viewing-distance :initform 15.0) (device :accessor device :initform nil) (key-closure-time :accessor key-closure-time :initform 0.010) (microphone-delay :accessor microphone-delay :initform 0.100) (keyboard :accessor keyboard :initform (make-instance 'virtual-keyboard)) (with-cursor-p :accessor with-cursor-p :initform nil) (input-q :accessor input-q :initform nil) (device-hook :accessor device-hook :initform nil) (mouse-fitts-coeff :accessor mouse-fitts-coeff :initform 0.1) (show-focus-p :accessor show-focus-p :initarg :show-focus-p :initform nil) (trace-mouse-p :accessor trace-mouse-p :initarg :trace-mouse-p :initform nil) (mouse-trace :accessor mouse-trace :initarg :mouse-trace :initform nil) (needs-mouse-p :accessor needs-mouse-p :initarg :needs-mouse-p :initform t) (true-cursor-loc :accessor true-cursor-loc :initarg :true-cursor-loc :initform #(0 0)) (locks :accessor locks :initform 0) (pending-procs :accessor pending-procs :initform nil) (virtual-trace :accessor virtual-trace :initform nil) (version-string :accessor version-string :initarg :version-string :initform "1.1") )) (defmethod my-name ((mod device-interface)) :DEVICE) (defgeneric angle->pixels-mth (devin angle) (:documentation "Determine the number of pixels subtending a visual angle.")) (defmethod angle->pixels-mth ((devin device-interface) (angle number)) (round (* (* (viewing-distance devin) (tan (deg->rad angle))) (ppi devin)))) (defgeneric pixels->angle-mth (devin pixels) (:documentation "Determine the amount of visual angle subtended by .")) (defmethod pixels->angle-mth ((devin device-interface) (pixels number)) (rad->deg (atan (/ (/ pixels (ppi devin)) (viewing-distance devin))))) (defgeneric find-viewing-dist-mth (devin angle pixels) (:documentation "Given the number of pixels an angle subtends, what's the viewing distance?")) (defmethod find-viewing-dist-mth ((devin device-interface) angle pixels) (floor (/ pixels (* (tan (deg->rad angle)) (ppi devin))))) ;;;; ---------------------------------------------------------------------- ;;;; ;;;; Interacting with the Master Process (defmethod reset-device ((devin device-interface)) (setf (input-q devin) nil) (setf (mouse-trace devin) nil) (setf (locks devin) 0) (setf (pending-procs devin) nil)) (defgeneric update-device (devin time) (:documentation "Update the device at