diff --git a/commands/conflict-tree.lisp b/commands/conflict-tree.lisp index 8a7464e..ce11187 100644 --- a/commands/conflict-tree.lisp +++ b/commands/conflict-tree.lisp @@ -13,19 +13,21 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Filename : conflict-tree.lisp -;;; Version : 2.1 +;;; Version : 3.0 ;;; ;;; Description : Code for creating and searching a simple decision tree of ;;; production conditions. ;;; ;;; Bugs : ;;; -;;; To do : [ ] Consider handling conditions other than constants. -;;; : [ ] See if it can infer other things about non-equal or -;;; : numeric values in creating the tree. -;;; : [ ] Consider extending the tree when adding new productions +;;; To do : [2.0] Consider handling conditions other than constants. +;;; : [2.0] See if it can infer other things about non-equal or +;;; : numeric values in creating the tree. +;;; : [-] Consider extending the tree when adding new productions ;;; : on the fly - track the used tests and call build-... -;;; : [ ] Make the negative limit a parameter somewhere. +;;; : Seems like a bad idea for performance which is the +;;; : objective of using the tree. +;;; : [3.0] Make the negative limit a parameter somewhere. ;;; ;;; ----- History ----- ;;; 2008.12.23 Dan [1.0] @@ -65,15 +67,51 @@ ;;; : branches. ;;; 2020.08.25 Dan ;;; : * Moved the defstructs to the procedural module file. +;;; 2021.03.31 Dan [3.0] +;;; : * Something broke this at some point. Instead of just fixing +;;; : it, doing some significant updating. Just remove all the isa +;;; : conditions beforehand instead of no-oping them everywhere. +;;; : Also switching to the info gain for deciding which to use +;;; : which eliminates the need for the repeated 0 tests, but +;;; : that requires the real calculations and to improve that it +;;; : groups the productions by the conditions they have so that +;;; : the calcualtions better measure how well a condition does at +;;; : splitting things (treating each production as its own class +;;; : as was done previously doesn't really produce a good metric +;;; : resulting in bigger trees than necessary and all the extra +;;; : checks to decide when to stop). The downside is the added +;;; : computation for this calcuation... +;;; : * Switched from the 'doesn't test' branch being marked with +;;; : :other to '=other since it's possible for someone to put the +;;; : keyword value into the productions but something which starts +;;; : with an = would never be a specific value since it's a +;;; : variable. +;;; : * Don't try to extend the tree when new productions are added +;;; : for now (previously it just picked some remaining condition +;;; : and used that to split things). May want to try using the +;;; : gain to decide to split a leaf, but would require keeping +;;; : some of the class grouping info to be efficient. +;;; 2021.04.15 Dan +;;; : * Changed print-conflict-tree to output to the command trace. +;;; 2021.04.21 Dan +;;; : * Fixed a place where :other hadn't been changed to '=other. +;;; 2021.05.10 Dan +;;; : * Allow use with ppm by just dropping the slot tests - it's +;;; : just the query and test-slot cases. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; General Docs: ;;; ;;; Builds a tree from production conditions. Initially uses all the productions -;;; in the model definition with the ID3 algorithm to try and grow a small tree. +;;; in the model definition using the info. gain calculation to try and create a +;;; small tree. Originally used the ID3 algorithm ofr that but switched to info. +;;; gain to alleviate some issues with detecting terminating conditions. Not +;;; using the normalized info. gain from the C4.5 algorithm (the updated version +;;; of ID3) since that biases away from creating many specific classes which is +;;; something we want here -- if a single test uniquely splits things that's what +;;; we want instead of something that generalizes to more cases. ;;; If productions get added after the model is defined (through compilation or -;;; otherwise) it will only augment the tree if needed (a new branch at a slot -;;; node) otherwise they just end up in an existing leaf. +;;; otherwise) currently they just end up in an existing leaf. ;;; ;;; One assumption in the matching is that chunk names used in constant slot ;;; tests (those hard coded into the productions) will always have thier true @@ -116,12 +154,9 @@ ;;; ;;; Design Choices: ;;; -;;; For info. gain calculation it considers each production to be a separate -;;; classification which makes entropy and gain simply based on production count. -;;; Additional assumption in building the tree is that it stops expanding if -;;; it finds that all possible splits are equal and no better than the current -;;; split (0 or less info. gain). It doesn't just stop if the gain is negative -;;; because a "bad" split can sometimes be benifical anyway. +;;; Using the info gain from C4.5 now because the simple entropy from ID3 and +;;; assuming each production was its own classification had some problems with +;;; building a "good" tree. ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -159,16 +194,6 @@ (declare (ignore prod)) (root-node-child node)) -(defmethod select-child ((node isa-node) prod) - (declare (ignorable node prod)) - #| - (let ((type (aif (cr-buffer-read prod (isa-node-buffer node) (isa-node-buffer-index node)) - (chunk-chunk-type-fct it) - nil))) - (if (and type (chunk-type-subtype-p-fct type (isa-node-value node))) - (isa-node-true node) - (isa-node-false node)))) -|#) (defmethod select-child ((node test-slot-node) prod) (let ((buffer-val (cr-buffer-slot-read prod (test-slot-node-buffer node) (test-slot-node-buffer-index node) (test-slot-node-slot-index node) (test-slot-node-slot node)))) @@ -187,7 +212,7 @@ (let ((buffer-val (cr-buffer-slot-read prod (slot-node-buffer node) (slot-node-buffer-index node) (slot-node-slot-index node) (slot-node-slot node)))) (aif (gethash buffer-val (slot-node-children node)) it - (gethash :other (slot-node-children node))))) + (gethash '=other (slot-node-children node))))) @@ -203,24 +228,28 @@ (defun print-tree (node branch depth) (cond ((root-node-p node) - (format t "---->[root ~s]~%" (conflict-node-valid node)) + (command-output "---->[root ~s]" (conflict-node-valid node)) (awhen (root-node-child node) (print-tree it t (+ depth 2)))) ((leaf-node-p node) - (format t "~vt-~d- ~s ->[leaf ~s]~%" depth (/ depth 2) branch (conflict-node-valid node)) + (command-output "~vt-~d- ~s ->[leaf ~s]" depth (/ depth 2) branch (conflict-node-valid node)) ) ((binary-test-node-p node) - (format t "~vt-~d- ~s ->[~s " depth (/ depth 2) branch (cr-condition-type (test-node-condition node))) - (case (cr-condition-type (test-node-condition node)) - (isa (format t " ~a ~s]~%" (test-node-buffer node) (test-node-value node))) - (query (format t " ~a ~s ~s]~%" (test-node-buffer node) (query-node-query node) (test-node-value node))) - (test-slot (format t " ~a ~s ~s ~s]~%" (test-node-buffer node) (test-slot-node-slot node) (test-slot-node-test node) (test-node-value node)))) + (command-output "~vt-~d- ~s ->[~s ~a ~s ~@[~s ~]~s]" depth (/ depth 2) branch (cr-condition-type (test-node-condition node)) + (test-node-buffer node) + (if (eq (cr-condition-type (test-node-condition node)) 'query) + (query-node-query node) + (test-slot-node-slot node)) + (if (eq (cr-condition-type (test-node-condition node)) 'query) + nil + (test-slot-node-test node)) + (test-node-value node)) (awhen (binary-test-node-true node) (print-tree it t (+ depth 2))) (awhen (binary-test-node-false node) (print-tree it nil (+ depth 2)))) ((wide-test-node-p node) - (format t "~vt-~d- ~s ->[~s ~a ~s]~%" depth (/ depth 2) branch (cr-condition-type (test-node-condition node)) (test-node-buffer node) (slot-node-slot node)) + (command-output "~vt-~d- ~s ->[~s ~a ~s]" depth (/ depth 2) branch (cr-condition-type (test-node-condition node)) (test-node-buffer node) (slot-node-slot node)) (maphash (lambda (branch node) (print-tree node branch (+ depth 2))) (wide-test-node-children node))))) @@ -317,15 +346,16 @@ |# -;;; Build the tree incrementally when a production is parsed +;;; Build the tree incrementally when a production is added. +;;; ;;; only happens after the initial tree creation - which should only be production compilation ;;; for most models. ;;; -;;; Don't add any more nodes than necessary i.e. if it gets to a root add the first condition and stop +;;; Don't add any more nodes than necessary i.e. if it gets to a leaf add the first condition and stop ;;; ;;; Input: - current-tree ;;; - list of cr-condition structs valid for constants -;;; so the type is one of: isa, query, slot, or test-slot +;;; so the type is one of: query, slot, or test-slot ;;; - production name @@ -333,9 +363,11 @@ (defmethod add-to-tree ((node leaf-node) conditions production) - (if conditions - (create-branch node (list (car conditions)) production) - (push-last production (leaf-node-valid node)))) + ; just storing in leaves for now + ;(if conditions + ;(create-branch node (list (car conditions)) production) + (declare (ignore conditions)) + (push-last production (leaf-node-valid node))) (defmethod add-to-tree ((node root-node) conditions production) @@ -344,36 +376,12 @@ (aif (root-node-child node) (add-to-tree it conditions production) - (let ((new-node (make-leaf-node :parent node :branch t :valid nil))) - (setf (root-node-child node) new-node) - (add-to-tree new-node conditions production)))) - - -(defmethod add-to-tree ((node isa-node) conditions production) - (declare (ignorable node conditions production)) - #|(aif (find (isa-node-condition node) conditions :test 'cr-condition-equal) - ;; then it's a true test - (add-to-tree (isa-node-true node) (remove it conditions) production) - ;; check if there's some other test of the type on this buffer - (let* ((current (isa-node-condition node)) - (other-types (mapcar #'cr-condition-value (remove-if-not (lambda (a) - (and (eq (cr-condition-type a) (cr-condition-type current)) - (eq (cr-condition-buffer a) (cr-condition-buffer current)))) - conditions)))) - - ; (format t "Other-types are: ~S~%" other-types) - - (if (and other-types (notany (lambda (x) (chunk-type-subtype-p-fct (cr-condition-value current) x)) other-types)) - ;; there is a mismatch so progress down the false branch - ;; requires that all possible tests fail to be safe - (add-to-tree (isa-node-false node) conditions production) - ;; otherwise add it to both branches - if there's any possibility it could match - (progn - (add-to-tree (isa-node-true node) conditions production) - (add-to-tree (isa-node-false node) conditions production))))) -|# - ) - + nil + ; Don't make a tree if there isn't one + ;(let ((new-node (make-leaf-node :parent node :branch t :valid nil))) + ; (setf (root-node-child node) new-node) + ; (add-to-tree new-node conditions production)))) + )) (defmethod add-to-tree ((node binary-test-node) conditions production) ;; query and test-slot @@ -396,30 +404,43 @@ (if (gethash (cr-condition-value it) (slot-node-children node)) ;; push it down the existing branch (add-to-tree (gethash (cr-condition-value it) (slot-node-children node)) (remove it conditions) production) - ;; doesn't have a branch so create one then add it - (let ((default (copy-conflict-tree (gethash :other (slot-node-children node)) node))) - (setf (gethash (cr-condition-value it) (slot-node-children node)) default) - (setf (conflict-node-branch default) (cr-condition-value it)) - (add-to-tree default (remove it conditions) production))) - ;; otherwise add it to every branch - (maphash (lambda (key value) - (declare (ignore key)) - (add-to-tree value conditions production)) - (slot-node-children node)))) + + ;; doesn't have a branch so create one then add it + ;; copy the default node if there is once since those may have + ;; a subtree already otherwise just create a leaf + + (let* ((default (gethash '=other (slot-node-children node))) + (new-node (if default + (copy-conflict-tree default node) + (make-leaf-node :parent node)))) + + (setf (gethash (cr-condition-value it) (slot-node-children node)) new-node) + (setf (conflict-node-branch new-node) (cr-condition-value it)) + (add-to-tree new-node (remove it conditions) production))) + + ;; need to add it to every branch and if there's not a default + ;; create one + + (let ((default nil)) + (maphash (lambda (key value) + (when (eq key '=other) (setf default t)) + (add-to-tree value conditions production)) + (slot-node-children node)) + (unless default + (setf (gethash '=other (slot-node-children node)) + (make-leaf-node :parent node :branch '=other :valid (list production))))))) +#| Not going to extend the tree for now -- but may come back to this, and if so + should use info gain to determine whether to branch or not but that may + require keeping some more info in the leaves (the production class info with + remaining conditions) to make it easy to do the calculations (defmethod create-branch ((node leaf-node) conditions production) ;(format t "create-branch ~20s from ~20s~%" branch (type-of node)) (let* ((condition (car conditions)) (new-node (case (cr-condition-type condition) - (isa - (make-isa-node :parent (conflict-node-parent node) - :branch (conflict-node-branch node) - :buffer (cr-condition-buffer condition) - :buffer-index (cr-condition-bi condition) - :value (cr-condition-value condition) - :condition condition)) + (query (make-query-node :parent (conflict-node-parent node) :branch (conflict-node-branch node) @@ -452,8 +473,8 @@ (setf (binary-test-node-false new-node) (make-leaf-node :parent new-node :branch nil )) ) (progn - (let ((other-tree (make-leaf-node :parent new-node :branch :other))) - (setf (gethash :other (wide-test-node-children new-node)) other-tree)))) + (let ((other-tree (make-leaf-node :parent new-node :branch '=other))) + (setf (gethash '=other (wide-test-node-children new-node)) other-tree)))) ;; splice this in as the child of the leaf's parent @@ -481,7 +502,7 @@ (find (car conditions) (production-implicit p) :test 'tree-condition-equal)))) (add-to-tree new-node (when c (list c)) p-name))))) - +|# ;;; Code to copy a tree making sure not to save things that shouldn't be saved @@ -527,7 +548,6 @@ (and (eq (cr-condition-type a) (cr-condition-type b)) (eq (cr-condition-buffer a) (cr-condition-buffer b)) (case (cr-condition-type a) - (isa t) (slot (= (cr-condition-si a) (cr-condition-si b))) (query (and (eq (cr-condition-slot a) (cr-condition-slot b)) (eql (cr-condition-value a) (cr-condition-value b)))) @@ -537,113 +557,211 @@ (t nil)))) - -(defun split-productions-with-condition (c conditions) - (let ((vals - (cond ((eq 'slot (cr-condition-type c)) - (let* ((r1 (mapcan (lambda (x) (copy-list (append (second x) (third x)))) conditions)) - (r2 (remove-if-not (lambda (x) (tree-condition-equal c x)) r1)) - (r3 (remove-duplicates (mapcar 'cr-condition-value r2) :test 'equalp)) - (r4 (cons :other r3)) - (results (mapcar (lambda (x) (list x nil)) r4))) - - ; (format t "Results are: r1:~S~%r2:~S~%r3:~S~%r4:~S~%r5:~S~%" r1 r2 r3 r4 results) - ; (break) - - (dolist (x conditions) - (aif (find c (append (second x) (third x)) :test 'cr-condition-equal) - (push-last (list (first x) (remove c (second x) :test 'cr-condition-equal) (remove c (third x) :test 'cr-condition-equal)) - (second (find (cr-condition-value it) results :key #'car :test #'equalp))) - (dolist (y results) - (push-last x (second y))))) - results)) - ((eq 'isa (cr-condition-type c)) - #|(let ((results (list (list t nil) (list nil nil)))) - (dolist (x conditions) - (aif (find c (append (second x) (third x)) :test 'cr-condition-equal) - ;; then it's a true test - (push-last (list (first x) (remove c (second x) :test 'cr-condition-equal) (remove c (third x) :test 'cr-condition-equal)) - (second (first results))) - ;; check if there's some other test of the type on this buffer - (let ((other-types (mapcar #'cr-condition-value (remove-if-not (lambda (y) (tree-condition-equal y c)) (append (second x) (third x)))))) - - (if (and other-types (notany (lambda (y) (chunk-type-subtype-p-fct (cr-condition-value c) y)) other-types)) - ;; there is a mismatch so progress down the false branch - ;; requires that all possible tests fail to be safe - (push-last x (second (second results))) - ;; otherwise add it to both branches - if there's any possibility it could match - (progn - (push-last x (second (first results))) - (push-last x (second (second results)))))))) - results)|#) +;;; Sort the root nodes based on the cannonical production order so that +;;; using the tree should result in identical choices for 'tie' situations +;;; and can't just build them that way now with the class based grouping + +(defun production-ordering (productions procedural) + (sort (copy-list productions) #'< :key (lambda (x) (position x (productions-list procedural) :key 'production-name)))) + +;;; Updated the scoring to use the info gain. Also, now group the productions +;;; by their sets of conditions instead of treating each as a separate class +;;; which should allow for a more efficient tree (at the cost of more initial +;;; calculations). + +(defun tree-entropy (classes) + ;; s is a list of lists where each list is a 'class' of items and the car of the + ;; list holds the items in that class. + + (let ((N (reduce '+ (mapcar (lambda (x) (length (car x))) classes) :initial-value 0))) + (if (zerop N) + 0 + (reduce '+ (mapcar (lambda (x) + (if (zerop (length (car x))) + 0 + (- (* (/ (length (car x)) N) (log (/ (length (car x)) N) 2))))) + classes))))) + + +(defun tree-gain (base-entropy sub-groupings) + ;; the sub-groupings are based on + ;; the repartitioning of the sets based on a condition. + ;; It's a list of lists of lists where the toplevel lists + ;; are the possible values for the condition, the lists + ;; within that are the classes, and the first list in those + ;; are the items. + (let ((N (reduce '+ (mapcar (lambda (x) (reduce '+ (mapcar (lambda (y) (length (car y))) x) :initial-value 0)) sub-groupings) :initial-value 0))) + (if (zerop N) + 0 + (- base-entropy + (reduce '+ (mapcar (lambda (x) + (* (/ (reduce '+ (mapcar (lambda (y) (length (car y))) x)) N) + (tree-entropy x))) + sub-groupings)))))) + +(defun split-productions-with-condition (condition n classes) + + ;; Need to compute the entropy for the condition + ;; which means ignore the items without the condition + + (let (haves have-nots entropy) + + (dolist (x classes) + (if (assoc n (second x)) + (push x haves) + (push x have-nots))) + + (setf entropy (tree-entropy haves)) + + ;(pprint classes) + + + (if (eq 'slot (cr-condition-type condition)) + + (let* ((vals (remove-duplicates (mapcar (lambda (x) (cdr (assoc n (second x)))) haves))) + (results (mapcar (lambda (x) + (cons x nil)) + vals))) - (t ; slot-test and queries are easier - - (let ((results (list (list t nil) (list nil nil)))) - (dolist (x conditions) - (aif (find c (append (second x) (third x)) :test 'cr-condition-equal) - (if (cr-condition-result it) - (push-last (list (first x) (remove c (second x) :test 'cr-condition-equal) (remove c (third x) :test 'cr-condition-equal)) - (second (first results))) - (push-last (list (first x) (remove c (second x) :test 'cr-condition-equal) (remove c (third x) :test 'cr-condition-equal)) - (second (second results)))) - (progn - (push-last x (second (first results))) - (push-last x (second (second results)))))) - results))))) + ;; split the items that have it to determine the gain + + (dolist (x haves) + (let ((val (cdr (assoc n (second x)))) + (without (list (first x) (remove n (second x) :key 'car)))) + (push without + (cdr (assoc val results))))) + + ;; update their classes + + (dolist (x results) + (setf (cdr x) + (group-by-condition-class (cdr x)))) + + (let* ((new-classes (mapcar 'cdr results)) + (gain (tree-gain entropy new-classes))) + + (when have-nots + + (dolist (y results) + (setf (cdr y) + (append have-nots (cdr y)))) + + (push (cons '=other have-nots) results) + + ;; update the classes again with the have-nots included + + (setf results (mapcar (lambda (x) + (cons (car x) + (group-by-condition-class (cdr x)))) + results))) + + ;(pprint results) + (values gain results))) + + ; test-slot and queries only have two options t or nil + + (let ((results (list (cons t nil) (cons nil nil)))) + + ;; split the items that have it to determine the gain + + (dolist (x haves) + (let ((val (cdr (assoc n (second x)))) + (without (list (first x) (remove n (second x) :key 'car)))) + (push without + (cdr (if val + (first results) + (second results)))))) + + ;; update their classes + + (dolist (x results) + (setf (cdr x) + (group-by-condition-class (cdr x)))) + + (let* ((new-classes (mapcar 'cdr results)) + (gain (tree-gain entropy new-classes))) + + (when have-nots + (dolist (y results) + (setf (cdr y) + (append have-nots (cdr y)))) + + ;; update the classes again with the have-nots included + + (setf results (mapcar (lambda (x) + (cons (car x) + (group-by-condition-class (cdr x)))) + results))) + + ;(pprint results) + (values gain results)))))) - (values (- (log (length conditions) 2) (score-tree-cases vals (length conditions))) vals))) -(defun score-tree-cases (vals s) - (reduce #'+ (mapcar (lambda (x) (if (null (second x)) 0 (* (/ (length (second x)) s) (log (length (second x)) 2)))) vals) :initial-value 0)) -(defun build-tree-from-productions (branch parent conditions negative) - (let* ((constants (mapcan (lambda (x) (copy-list (second x))) conditions)) - (valid-conditions (remove-duplicates constants :test #'tree-condition-equal))) + +(defun build-tree-from-productions (branch parent conditions classes procedural) + + (if (= (length classes) 1) ;; nothing to decide + (make-leaf-node :parent parent :branch branch :valid (production-ordering (first (first classes)) procedural)) + + ;; only consider the conditions that are actually used. + ;; I thought limiting that to only those where every class has it + ;; or there are classes with different values for the condition + ;; would be useful, but it can find shorter trees if all of the + ;; used conditions are tested though that's potentially a lot of + ;; extra computation... + + + (let ((used-conditions (remove-duplicates (mapcar 'car (reduce 'append (mapcar 'second classes)))))) + ;(used-conditions (reduce 'append (mapcar 'second classes))) + ;(all-contain nil) + ;(diff-vals nil) + ;(n (length conditions)) + ;(class-count (length classes))) - ; (format t "Branch: ~s (~S)~%Constants: ~S~%Valid-conditions are: ~S~%" branch (mapcar #'car conditions) constants valid-conditions) - ; (break) + ;; find the interesting cases + #|(dotimes (i n) + (let ((match (remove-if-not (lambda (x) (= x i)) used-conditions :key 'car))) + (when (= (length match) class-count) + (push i all-contain)) + (when (> (length (remove-duplicates match :test 'equalp)) 1) + (push i diff-vals)))) - (if (or (null valid-conditions) (= (length conditions) 1)) - (make-leaf-node :parent parent :branch branch :valid (mapcar #'first conditions)) - (let ((best nil) - (val nil) - (groups nil) - (all-same t) - (last nil)) - (dolist (x valid-conditions) - (unless (eq (cr-condition-type x) 'isa) - (multiple-value-bind (v g) (split-productions-with-condition x conditions) - - ;(format t "~S: ~S~%" v x) - - (unless (or (null last) (= last v)) - (setf all-same nil)) + (setf used-conditions (remove-duplicates (append diff-vals all-contain))) + |# + + (if (null used-conditions) ;; nothing useful to split with + (make-leaf-node :parent parent :branch branch :valid (production-ordering (apply 'append (mapcar 'first classes)) procedural)) + + ;; Find the condition with the best info gain ration + (let ((best nil) + (val nil) + (sub-nodes nil)) + + (dolist (x used-conditions) + (let ((condition (svref conditions x))) + + (multiple-value-bind (gain subs) (split-productions-with-condition condition x classes) - (setf last v) + ;(format t "splitting ~S~% with ~s~% scores ~S~%" classes condition gain) (when (or (null val) - (> v val)) - (setf val v) - (setf groups g) - (setf best x))))) - - ; (format t "Best(~3s): ~S ~S ~%~%" all-same val best) - + (> gain val)) + (setf val gain) + (setf sub-nodes subs) + (setf best condition))))) - (if (or (and negative (<= val 0.0) (> negative 3)) ;; Only make a few negative or zero splits - (and all-same (<= val 0.0))) ;; doesn't seem like any improvements left - - (make-leaf-node :parent parent :branch branch :valid (mapcar #'first conditions)) + ;(format t "Best: ~S ~S ~%~%" val sub-nodes) + + ;(break) + ;; No relevant conditions left to split them + + (if (or (null val) (<= val 0.0)) ;;; should it always stop if zero or negative now? + + (make-leaf-node :parent parent :branch branch :valid (production-ordering (flatten (mapcar 'first classes)) procedural)) - (let ((new-node (case (cr-condition-type best) - (isa - (make-isa-node :parent parent - :branch branch - :buffer (cr-condition-buffer best) - :buffer-index (cr-condition-bi best) - :value (cr-condition-value best) - :condition best)) + (let* ( + (new-node (case (cr-condition-type best) (query (make-query-node :parent parent :branch branch @@ -668,58 +786,93 @@ :buffer-index (cr-condition-bi best) :slot (cr-condition-slot best) :slot-index (cr-condition-si best) - :condition best))))) + :condition best)))) + ) (if (binary-test-node-p new-node) (progn (setf (binary-test-node-true new-node) - (build-tree-from-productions t new-node (second (first groups)) (if (<= val 0.0) - (if negative (1+ negative) 0) - 0))) - - - (setf (binary-test-node-false new-node) (build-tree-from-productions nil new-node (second (second groups)) (if (<= val 0.0) - (if negative (1+ negative) 0) - 0)))) + (build-tree-from-productions t new-node conditions (cdr (assoc t sub-nodes)) procedural)) + (setf (binary-test-node-false new-node) + (build-tree-from-productions nil new-node conditions (cdr (assoc nil sub-nodes)) procedural))) (progn - (dolist (x groups) - (setf (gethash (first x) (wide-test-node-children new-node)) - (build-tree-from-productions (first x) new-node (second x) (if (<= val 0.0) - (if negative (1+ negative) 0) - 0)))))) - new-node)))))) + (dolist (x sub-nodes) + (setf (gethash (car x) (wide-test-node-children new-node)) + (build-tree-from-productions (car x) new-node conditions (cdr x) procedural))))) + new-node))))))) + +(defun group-by-condition-class (productions) + (let ((classes nil)) + (dolist (p productions classes) + (aif (find (second p) classes :test 'equalp :key 'second) + (setf (first it) (append (first p) (first it))) + (push (list (first p) (second p)) classes))))) + ;;; Interface to the procedural module +(defun build-conflict-tree (procedural) + (let* ((productions-with-conditions (mapcar (lambda (x) + (list (list (production-name x)) + (append (remove-if (lambda (x) + (or (eq (cr-condition-type x) 'isa) + (and + (procedural-ppm procedural) ;; param lock held by calling fn + (eq (cr-condition-type x) 'slot)))) + (copy-list (production-constants x))) + (copy-list (production-implicit x))))) + (productions-list procedural))) + (conditions (remove-duplicates (mapcan (lambda (x) (copy-list (second x))) productions-with-conditions) :test 'tree-condition-equal))) + + (setf conditions (coerce conditions 'vector)) + + ;(pprint productions-with-conditions) + + (dolist (p productions-with-conditions) + (setf (second p) + (sort (mapcar (lambda (x) + (let ((n (position x conditions :test 'tree-condition-equal)) + (val (if (eq 'slot (cr-condition-type x)) + (cr-condition-value x) + (cr-condition-result x)))) + (cons n val))) + (second p)) + #'< :key 'car))) + + ;(pprint conditions)) + ;(pprint productions-with-conditions)) + + + (setf (root-node-conditions (procedural-conflict-tree procedural)) conditions) + (setf (root-node-valid (procedural-conflict-tree procedural)) (mapcar 'production-name (productions-list procedural))) + + + (setf (root-node-child (procedural-conflict-tree procedural)) + (build-tree-from-productions t + (procedural-conflict-tree procedural) + conditions + (group-by-condition-class productions-with-conditions) + procedural)))) + + + (defun add-production-to-tree (p procedural) (add-to-tree (procedural-conflict-tree procedural) (remove-if (lambda (x) - (eq (cr-condition-type x) 'isa)) + (or (eq (cr-condition-type x) 'isa) + (and + (procedural-ppm procedural) ;; param lock held by calling fn + (eq (cr-condition-type x) 'slot)))) (remove-duplicates (append (production-constants p) (production-implicit p)) :test 'cr-condition-equal)) (production-name p))) + + (defun remove-production-from-tree (p procedural) (declare (ignore p procedural)) - (model-warning "Remove productions not recommended when :conflict-tree is set to t - tree removal not implemented.")) + (model-warning "Removing productions not supported when :use-tree is set to t - tree removal not implemented.")) -(defun build-conflict-tree (procedural) - - #| simple - production at a time method - bad idea in general for multiple reasons - - (dolist (p (productions-list procedural)) - (add-production-to-tree p procedural) - (conflict-tree-stats )) - |# - - (setf (root-node-valid (procedural-conflict-tree procedural)) (mapcar #'production-name (productions-list procedural))) - (setf (root-node-child (procedural-conflict-tree procedural)) - (build-tree-from-productions t (procedural-conflict-tree procedural) - (mapcar (lambda (x) (list (production-name x) (append (copy-list (production-constants x)) (copy-list (production-implicit x))))) - (productions-list procedural)) - nil)) - ) (defun get-valid-productions (procedural) (get-valid (procedural-conflict-tree procedural) procedural)) diff --git a/commands/dm-commands.lisp b/commands/dm-commands.lisp index 3a558d3..6cedcdb 100644 --- a/commands/dm-commands.lisp +++ b/commands/dm-commands.lisp @@ -293,6 +293,9 @@ ;;; 2019.12.02 Dan ;;; : * Clear-dm should set the in-dm parameter to nil so that the ;;; : chunks can be added back if needed. +;;; 2021.04.19 Dan +;;; : * Fixed a bug with the external definition of set-base-levels +;;; : and set-base-levels-fct. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; General Docs: @@ -582,14 +585,14 @@ (defun set-base-levels-external (&rest settings) - (get-base-level-fct (string->name-recursive settings))) + (set-base-levels-fct (string->name-recursive settings))) (defun set-base-levels-fct-external (settings) - (get-base-level-fct (string->name-recursive settings))) + (set-base-levels-fct (string->name-recursive settings))) (add-act-r-command "set-base-levels" 'set-base-levels-external "Set the base-level activation of chunks in DM. Params: (chunk level {creation-time})*") -(add-act-r-command "set-base-levels-fct" 'set-base-levels-external-fct "Set the base-level activation of chunks in DM. Params: ((chunk level {creation-time})*)") +(add-act-r-command "set-base-levels-fct" 'set-base-levels-fct-external "Set the base-level activation of chunks in DM. Params: ((chunk level {creation-time})*)") (defun set-all-base-levels (base-level &optional creation-time) "Function to set the base-level activation of all dm chunks" diff --git a/commands/procedural-cmds.lisp b/commands/procedural-cmds.lisp index 3582bd7..f59fcb4 100644 --- a/commands/procedural-cmds.lisp +++ b/commands/procedural-cmds.lisp @@ -387,6 +387,15 @@ ;;; 2020.08.26 Dan ;;; : * Removed the path for require-compiled since it's not needed ;;; : and results in warnings in SBCL. +;;; 2021.07.08 Dan +;;; : * Fixed a typo in the warning for p-fct about no procedural +;;; : module being available. +;;; 2021.08.23 Dan +;;; : * Fixed a problem with production-failure-reason because it +;;; : didn't work when the buffer array mechanism was used since +;;; : productions not in the matching buffer set didn't have their +;;; : failure-condition cleared or set. Now, it sets the ones +;;; : that aren't in the buffer set to indicate that. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; General Docs: @@ -635,8 +644,26 @@ (defun production-failure-reason (p-name) - (let ((production (get-production p-name))) + ; only called with the procedural-cr-lock already held since it's + ; called during the conflict-set-hook by the procedural history recorder + + (let ((production (get-production p-name)) + (procedural (get-module procedural))) (bt:with-recursive-lock-held ((production-lock production)) + + (when (procedural-buffer-use-array procedural) + (let* ((buffer-state + (let ((m (current-model-struct))) + (bt:with-lock-held ((act-r-model-buffers-lock m)) + (act-r-model-buffer-state m)))) + + (tested-productions (aref (procedural-buffer-use-array procedural) + (aref (procedural-master-buffer-map procedural) buffer-state)))) + + (unless (find production tested-productions) + (setf (production-failure-condition production) (cons :buffer-state buffer-state))) + )) + (if (and production (production-failure-condition production)) (failure-reason-string (production-failure-condition production) production) "")))) @@ -743,7 +770,7 @@ (let ((prod (get-module procedural))) (if (procedural-p prod) (create-production prod definition) - (print-warning "No procedural modulue found cannot create production.")))) + (print-warning "No procedural module found cannot create production.")))) (defun delete-production (prod-name) diff --git a/core-modules/audio.lisp b/core-modules/audio.lisp index d8c3286..dc38add 100755 --- a/core-modules/audio.lisp +++ b/core-modules/audio.lisp @@ -13,7 +13,7 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Filename : audio.lisp -;;; Version : 6.0 +;;; Version : 6.1 ;;; ;;; Description : Source for RPM's Audition Module ;;; @@ -476,6 +476,9 @@ ;;; 2020.08.26 Dan ;;; : * Removed the path for require-compiled since it's not needed ;;; : and results in warnings in SBCL. +;;; 2021.06.09 Dan [6.1] +;;; : * Make sure the aural-location buffer always gets a new +;;; : chunk when it's set with buffer-requires-copies. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; #+:packaged-actr (in-package :act-r) @@ -504,7 +507,7 @@ (last-stuffed-event :accessor last-stuffed-event :initform nil)) (:default-initargs - :version-string "6.0" + :version-string "6.1" :name :AUDIO)) @@ -1160,7 +1163,7 @@ (setf (default-spec instance) (define-chunk-spec :attended nil))) - + (buffer-requires-copies 'aural-location) ) diff --git a/core-modules/declarative-memory.lisp b/core-modules/declarative-memory.lisp index 8b05033..7eee3cb 100644 --- a/core-modules/declarative-memory.lisp +++ b/core-modules/declarative-memory.lisp @@ -13,7 +13,7 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Filename : declarative-memory.lisp -;;; Version : 6.6 +;;; Version : 7.0 ;;; ;;; Description : Implements the declarative memory module. ;;; @@ -508,6 +508,11 @@ ;;; : * Added an :rt-value request parameter that can be used to set ;;; : a new :rt value to use during this retrieval, just like the ;;; : :mp-value changes the :mp parameter. +;;; 2021.03.10 Dan [6.8] +;;; : * Set the :do-not-query parameter for goal buffer now. +;;; 2021.06.04 Dan [7.0] +;;; : * When merging chunks from a buffer need to check if it's +;;; : storable or not if it's being added as a new chunk. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; General Docs: @@ -918,7 +923,7 @@ (defun secondary-reset-dm-module (dm) (declare (ignore dm)) - (sgp :dcsc-hook dm-fm-rh)) + (sgp :dcsc-hook dm-fm-rh :do-not-query retrieval)) (defun tertiary-reset-dm-module (dm) @@ -1805,7 +1810,9 @@ ;; otherwise add it to the list - (add-chunk-into-dm dm chunk key)))))) + (if (chunk-not-storable chunk) + (add-chunk-into-dm dm (copy-chunk-fct chunk) key) + (add-chunk-into-dm dm chunk key))))))) ;; add-chunk-into-dm ;;; @@ -2161,7 +2168,7 @@ (define-parameter :cache-sim-hook-results :valid-test 'tornil :default-value nil :warning "T or nil" :documentation "Whether the results of calling a sim-hook function should be cached to avoid future calls to the hook function")) - :version "6.7" + :version "7.0" :documentation "The declarative memory module stores chunks from the buffers for retrieval" ;; The creation function returns a new dm structure diff --git a/core-modules/goal.lisp b/core-modules/goal.lisp index b5ab0cd..85a7667 100644 --- a/core-modules/goal.lisp +++ b/core-modules/goal.lisp @@ -13,7 +13,7 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Filename : goal.lisp -;;; Version : 2.2 +;;; Version : 2.3 ;;; ;;; Description : Implementation of the goal module. ;;; @@ -131,6 +131,8 @@ ;;; 2020.08.26 Dan ;;; : * Removed the path for require-compiled since it's not needed ;;; : and results in warnings in SBCL. +;;; 2021.03.10 Dan [2.3] +;;; : * Set the :do-not-query parameter for goal buffer now. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; General Docs: @@ -209,7 +211,9 @@ (bt:with-lock-held ((goal-module-lock instance)) (setf (goal-module-delayed instance) nil)) ; Do NOT strict harvest the goal buffer by default - (sgp :do-not-harvest goal) + ; and don't add explicit queries when requests are made + (sgp :do-not-harvest goal :do-not-query goal) + ) (defun goal-query (instance buffer-name slot value) @@ -232,7 +236,7 @@ (define-module-fct 'goal '((goal (:ga 0.0))) nil - :version "2.2" + :version "2.3" :documentation "The goal module creates new goals for the goal buffer" :creation 'create-goal-module :query 'goal-query diff --git a/core-modules/imaginal.lisp b/core-modules/imaginal.lisp index 48b4829..b12c469 100644 --- a/core-modules/imaginal.lisp +++ b/core-modules/imaginal.lisp @@ -13,7 +13,7 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Filename : imaginal.lisp -;;; Version : 5.0 +;;; Version : 6.0 ;;; ;;; Description : An actual imaginal module. ;;; @@ -150,6 +150,10 @@ ;;; 2020.08.26 Dan ;;; : * Removed the path for require-compiled since it's not needed ;;; : and results in warnings in SBCL. +;;; 2021.06.14 Dan [6.0] +;;; : * Allow the simple imaginal-action request to accept a chunk +;;; : description list as the return value and then use that to +;;; : set the buffer instead of creating a temp chunk. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; General Docs: @@ -197,15 +201,18 @@ ;;; ;;; The function named in the action slot is called at the time of the request, ;;; the imaginal buffer is cleared, and the imaginal module is marked as busy. -;;; The action function should return either a chunk name or nil. If a chunk -;;; name is returned then that chunk will be put into the imaginal buffer after -;;; the current delay time for the imaginal module passes and the module will -;;; then be marked as free. If the function returns nil then after the current -;;; imaginal delay time passes the module will be marked as free and the error -;;; state will be set to t. If the slots slot -;;; is specified with a list of symbols which name valid slots for a chunk then -;;; those slot names will be passed to the action function in the order provided -;;; i.e. this is what will effectively happen: (apply ). +;;; The action function should return either a chunk name, a list of slots and +;;; values that describe a chunk, or nil. If a chunk name or list of slots and +;;; values is returned then the named chunk will be copied into the imaginal +;;; buffer after the current delay time for the imaginal module passes and the +;;; module will then be marked as free. If a slots and values list is returned +;;; then that will be used to create a new chunk in the imaginal buffer after the +;;; current delay time passes and then the module will be marked as free. If the +;;; function returns nil then after the current imaginal delay time passes the +;;; module will be marked as free and the error state will be set to t. If the +;;; slots slot is specified with a list of symbols which name valid slots for a +;;; chunk then those slot names will be passed to the action function in the order +;;; provided i.e. this is what will effectively happen: (apply ). ;;; If the slots list is provided but not valid then no action is taken and a warning ;;; is printed. @@ -380,6 +387,12 @@ ((chunk-p-fct (string->name c)) ;; set module free and buffer chunk (schedule-set-buffer-chunk 'imaginal (string->name c) delay :time-in-ms t :module 'imaginal :priority -1000) (schedule-event-relative delay 'set-imaginal-free :time-in-ms t :module 'imaginal :output nil :priority -1001 :maintenance t)) + ((listp c) + (aif (define-chunk-spec-fct (decode-string-names c)) + (schedule-set-buffer-chunk 'imaginal it delay :time-in-ms t :module 'imaginal :priority -1000) + (progn + (bt:acquire-lock (imaginal-module-lock instance)) ;; since the bad exit releases it + (bad-action-exit "Invalid result from the action of an imaginal-action simple-action function.")))) (t (bt:acquire-lock (imaginal-module-lock instance)) ;; since the bad exit releases it (bad-action-exit "Invalid result from the action of an imaginal-action simple-action function.")))))))) @@ -433,7 +446,7 @@ (define-parameter :vidt :valid-test 'tornil :default-value nil :warning "T or nil" :documentation "Variable Imaginal Delay Time")) - :version "5.0" + :version "6.0" :documentation "The imaginal module provides a goal style buffer with a delay and an action buffer for manipulating the imaginal chunk" :creation 'create-imaginal :query 'imaginal-query diff --git a/core-modules/procedural.lisp b/core-modules/procedural.lisp index cf9f0d7..8282d0d 100644 --- a/core-modules/procedural.lisp +++ b/core-modules/procedural.lisp @@ -13,7 +13,7 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Filename : procedural.lisp -;;; Version : 8.1 +;;; Version : 8.3 ;;; ;;; Description : Implements the procedural module (productions). ;;; @@ -879,6 +879,30 @@ ;;; : event in the queue. Not making it documented functionality ;;; : at this point, but if somebody else runs into similar issues ;;; : I'll need to reconsider that. +;;; 2021.03.10 Dan [8.2] +;;; : * Added a :do-not-query parameter which works like do-not- +;;; : harvest to exclude buffers from the new "safe qeuring" +;;; : mechanism that adds an explict "?buffer> state free" query +;;; : to the LHS of productions that make a request without a +;;; : corresponding query to the buffer. +;;; 2021.04.02 Dan +;;; : * When use-tree is true need to do some the array setup before +;;; : walking the tree in conflict-resolution. +;;; : * Removed the isa-node structure and added a slot to the root- +;;; : node to hold the condition numbering. +;;; 2021.04.21 Dan +;;; : * Added a declare ignorable to procedural-run-check to avoid +;;; : a warning when loading the single threaded version. +;;; 2021.05.10 Dan +;;; : * Allow use-tree to work with ppm (it won't use the slot test +;;; : conditions so may not be very useful). +;;; 2021.06.04 Dan +;;; : * Adjusted the style warning check for set-buffer-chunk to +;;; : deal with the case where set-buffer-chunk is passed a +;;; : chunk-spec instead of a chunk name. +;;; 2021.08.18 Dan [8.3] +;;; : * Don't reschedule conflict-resolution just because :v was +;;; : changed... ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; General Docs: @@ -988,6 +1012,8 @@ req-spec + do-not-query + current-p ppm md @@ -1039,7 +1065,7 @@ (defstruct conflict-node parent branch (valid nil) entropy) -(defstruct (root-node (:include conflict-node)) child) +(defstruct (root-node (:include conflict-node)) child conditions) (defstruct (leaf-node (:include conflict-node))) (defstruct (test-node (:include conflict-node)) @@ -1048,9 +1074,6 @@ (defstruct (binary-test-node (:include test-node)) true false) -(defstruct (isa-node (:include binary-test-node)) - buffer-index) - (defstruct (query-node (:include binary-test-node)) query) @@ -1155,9 +1178,9 @@ (cond ((consp param) ;; Changing procedural parameters reschedules conflict resolution - ;; if it's waiting to happen + ;; if it's waiting to happen unless it's :v - (un-delay-conflict-resolution) + (unless (eq (car param) :v) (un-delay-conflict-resolution)) (case (car param) (:use-tree (setf (procedural-use-tree procedural) (cdr param))) @@ -1190,8 +1213,12 @@ (:do-not-harvest - (setf (procedural-unharvested-buffers procedural) - (set-or-remove-hook-parameter :do-not-harvest (procedural-unharvested-buffers procedural) (cdr param)))) + (setf (procedural-unharvested-buffers procedural) + (set-or-remove-hook-parameter :do-not-harvest (procedural-unharvested-buffers procedural) (cdr param)))) + + (:do-not-query + (setf (procedural-do-not-query procedural) + (set-or-remove-hook-parameter :do-not-query (procedural-do-not-query procedural) (cdr param)))) (:cycle-hook (setf (procedural-cycle-hook procedural) @@ -1226,6 +1253,9 @@ (:do-not-harvest (procedural-unharvested-buffers procedural)) + (:do-not-query + (procedural-do-not-query procedural)) + (:cycle-hook (procedural-cycle-hook procedural)) (:conflict-set-hook (procedural-conflict-set-hook procedural)) (:add-production-hook (procedural-add-production-hook procedural))))))) @@ -1512,9 +1542,17 @@ (when (and (eq (evt-model event) (current-model)) (or (eq (evt-action event) 'set-buffer-chunk) (eq (evt-action event) #'set-buffer-chunk))) - (let ((params (evt-params event))) - (setf (gethash (first params) (procedural-init-chunk-slots procedural)) - (remove-duplicates (append (gethash (first params) (procedural-init-chunk-slots procedural)) (chunk-filled-slots-list-fct (second params)))))))) + (let* ((params (evt-params event)) + (value (second params))) + (if (symbolp value) + (setf (gethash (first params) (procedural-init-chunk-slots procedural)) + (remove-duplicates (append (gethash (first params) (procedural-init-chunk-slots procedural)) (chunk-filled-slots-list-fct value)))) + (let ((spec (or (and (act-r-chunk-spec-p value) value) + (id-to-chunk-spec value)))) + (when spec + (setf (gethash (first params) (procedural-init-chunk-slots procedural)) + (remove-duplicates (append (gethash (first params) (procedural-init-chunk-slots procedural)) + (slot-mask->names (chunk-spec-filled-slots spec))))))))))) ;; also look at the buffers themselves to see if there are any chunks there (dolist (buffer (buffers)) @@ -1532,8 +1570,9 @@ (progn (when (or (procedural-crt procedural) - (procedural-ppm procedural)) - (model-warning "Conflict resolution cannot use the decision tree when :crt or :ppm is enabled.")) + ; allow for now (procedural-ppm procedural) + ) + (model-warning "Conflict resolution cannot use the decision tree when :crt is enabled.")) (cond ((null (procedural-last-conflict-tree procedural)) (build-conflict-tree procedural) @@ -2043,7 +2082,7 @@ nil))) (defun conflict-resolution (procedural) - (let (crt ppm er conflict-set-hook cst v dat use-tree) + (let (crt er conflict-set-hook cst v dat use-tree) (bt:with-lock-held ((procedural-cr-lock procedural)) (setf (procedural-delayed-resolution procedural) nil) @@ -2051,7 +2090,7 @@ (bt:with-lock-held ((procedural-param-lock procedural)) (setf crt (procedural-crt procedural) - ppm (procedural-ppm procedural) + ; ppm (procedural-ppm procedural) er (procedural-er procedural) conflict-set-hook (procedural-conflict-set-hook procedural) cst (procedural-cst procedural) @@ -2080,9 +2119,21 @@ (setf (aref (procedural-master-buffer-map procedural) buffer-state) mapped-state) (aref (procedural-buffer-use-array procedural) mapped-state))) ) - (ppm - (productions-list procedural)) + ;(ppm + ; (productions-list procedural)) (use-tree + (if (null (procedural-buffer-lookup procedural)) + (setf (procedural-buffer-lookup procedural) (make-array (list (procedural-buffer-lookup-size procedural)) :initial-element :untested)) + (fill (procedural-buffer-lookup procedural) :untested :start 0 :end (procedural-buffer-lookup-size procedural))) + + (if (or (null (procedural-slot-lookup procedural)) + (not (= (largest-chunk-type-size) (procedural-largest-chunk-type procedural)))) + (progn + (setf (procedural-largest-chunk-type procedural) (largest-chunk-type-size)) + (setf (procedural-slot-lookup procedural) (make-array (list (procedural-buffer-lookup-size procedural) (largest-chunk-type-size)) :initial-element :untested))) + (dolist (x (procedural-slot-used procedural) (setf (procedural-slot-used procedural) nil)) + (setf (aref (procedural-slot-lookup procedural) (car x) (cdr x)) :untested))) + (mapcar (lambda (x) (get-production-internal x procedural)) (get-valid-productions procedural))) (t (productions-list procedural))))) @@ -2091,17 +2142,20 @@ (setf (procedural-last-cr-time procedural) (mp-time-ms)) (when test-set - (if (null (procedural-buffer-lookup procedural)) - (setf (procedural-buffer-lookup procedural) (make-array (list (procedural-buffer-lookup-size procedural)) :initial-element :untested)) - (fill (procedural-buffer-lookup procedural) :untested :start 0 :end (procedural-buffer-lookup-size procedural))) + - (if (or (null (procedural-slot-lookup procedural)) - (not (= (largest-chunk-type-size) (procedural-largest-chunk-type procedural)))) - (progn - (setf (procedural-largest-chunk-type procedural) (largest-chunk-type-size)) - (setf (procedural-slot-lookup procedural) (make-array (list (procedural-buffer-lookup-size procedural) (largest-chunk-type-size)) :initial-element :untested))) - (dolist (x (procedural-slot-used procedural) (setf (procedural-slot-used procedural) nil)) - (setf (aref (procedural-slot-lookup procedural) (car x) (cdr x)) :untested))) + (unless use-tree + (if (null (procedural-buffer-lookup procedural)) + (setf (procedural-buffer-lookup procedural) (make-array (list (procedural-buffer-lookup-size procedural)) :initial-element :untested)) + (fill (procedural-buffer-lookup procedural) :untested :start 0 :end (procedural-buffer-lookup-size procedural))) + + (if (or (null (procedural-slot-lookup procedural)) + (not (= (largest-chunk-type-size) (procedural-largest-chunk-type procedural)))) + (progn + (setf (procedural-largest-chunk-type procedural) (largest-chunk-type-size)) + (setf (procedural-slot-lookup procedural) (make-array (list (procedural-buffer-lookup-size procedural) (largest-chunk-type-size)) :initial-element :untested))) + (dolist (x (procedural-slot-used procedural) (setf (procedural-slot-used procedural) nil)) + (setf (aref (procedural-slot-lookup procedural) (car x) (cdr x)) :untested)))) (dolist (b (procedural-used-search-buffers procedural)) @@ -2556,7 +2610,7 @@ (declare (ignore instance buffer-name chunk-spec))) (defun procedural-run-check (instance) - + (declare (ignorable instance)) ;; if there aren't any procedural events put a new ;; conflict-resolution out there... (unless (mp-modules-events 'procedural) @@ -2617,12 +2671,16 @@ (define-parameter :do-not-harvest :valid-test 'do-not-harvest-value-test :default-value nil :warning "a string or symbol or a list starting with :remove" :documentation "Buffers that are not strict harvested") + (define-parameter :do-not-query :valid-test 'do-not-harvest-value-test :default-value nil + :warning "a string or symbol or a list starting with :remove" + :documentation "Buffers that are not automatically queried for state free") + (define-parameter :use-tree :valid-test 'tornil :default-value nil :warning "T or nil" :documentation "Use a decision tree in production matching") (define-parameter :style-warnings :valid-test 'tornil :default-value t :warning "T or nil" :documentation "Show model warnings for production issues that don't prevent production definition")) - :version "8.1" + :version "8.3" :documentation "The procedural module handles production definition and execution" diff --git a/core-modules/speech.lisp b/core-modules/speech.lisp index 8b42b6a..ca263a6 100644 --- a/core-modules/speech.lisp +++ b/core-modules/speech.lisp @@ -13,7 +13,7 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Filename : speech.lisp -;;; Version : 7.0 +;;; Version : 7.1 ;;; ;;; Description : Source code for the ACT-R/PM Speech Module. This Module ;;; : is pretty brain-damaged but should get the job done @@ -176,6 +176,11 @@ ;;; 2020.08.26 Dan ;;; : * Removed the path for require-compiled since it's not needed ;;; : and results in warnings in SBCL. +;;; 2021.03.18 Dan [7.1] +;;; : * The minimum articulation time is now the syllable-rate +;;; : not a fraction of that for shorter strings. For longer +;;; : strings it is still computed at the sub-syllable level i.e. +;;; : syllable-rate * (length/char-per-syllable). ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; #+:packaged-actr (in-package :act-r) @@ -193,7 +198,7 @@ (device :accessor device :initform nil) (notify-subvocalize :accessor notify-subvocalize :initform nil)) (:default-initargs - :version-string "7.0" + :version-string "7.1" :name :SPEECH)) @@ -206,7 +211,7 @@ (let ((time (aif (gethash text (art-time-ht spch-mod)) it - (round (* (s-rate spch-mod) (/ (length text) (char-per-syllable spch-mod))))))) + (round (max (s-rate spch-mod) (* (s-rate spch-mod) (/ (length text) (char-per-syllable spch-mod)))))))) (if time-in-ms time (ms->seconds time)))) diff --git a/core-modules/vision.lisp b/core-modules/vision.lisp index 462f986..158184b 100644 --- a/core-modules/vision.lisp +++ b/core-modules/vision.lisp @@ -13,7 +13,7 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Filename : vision.lisp -;;; Version : 9.1 +;;; Version : 10.0 ;;; ;;; Description : Source code for the ACT-R Vision Module. ;;; @@ -78,6 +78,8 @@ ;;; with respect to checking the real-visual-value i.e. does ;;; that always get set correctly elsewhere or can that break ;;; with a custom device? +;;; : [ ] Could convert-loc-to-object just return the spec/desc to +;;; avoid creating another chunk? ;;; ;;; ----- History ----- [look also at function comments] ;;; @@ -1179,6 +1181,17 @@ ;;; 2020.08.26 Dan ;;; : * Removed the path for require-compiled since it's not needed ;;; : and results in warnings in SBCL. +;;; 2021.03.10 Dan [9.2] +;;; : * Added a secondary reset function so that the visual-location +;;; : buffer can be on the do-not-query list automatically. +;;; 2021.06.08 Dan [10.0] +;;; : * Force the visual-location buffer to always copy the chunk +;;; : since the name is used in the screen-pos slot of the object +;;; : chunk. +;;; : * Updated update-tracking-mth so that it better handles things +;;; : with respect to the visual buffer not always having a new +;;; : chunk name -- compare the chunk-visicon-entry of the chunk +;;; : in the buffer to tracked-obj. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -1203,7 +1216,6 @@ (move-attention-latency :accessor move-attn-latency :initarg :move-attn-latency :initform 85) (tracked-object :accessor tracked-obj :initarg :tracked-obj :initform nil) (tracked-object-last-location :accessor tracked-obj-lastloc :initarg :tracked-obj-lastloc :initform nil) - (tracked-object-last-obj :accessor tracked-obj-last-obj :initarg :tracked-obj-last-obj :initform nil) (last-scale :accessor last-scale :initarg :last-scale :initform nil) (moving-attention :accessor moving-attention :initarg :moving-attention :initform nil) (move-allowance :accessor move-allowance :initarg :move-allowance :initform 0) @@ -1217,7 +1229,6 @@ (new-span :accessor new-span :initarg :new-span :initform 0.5) (default-spec :accessor default-spec :initarg :default-spec :initform nil) (visual-lock :accessor visual-lock :initform nil) - (last-obj :accessor last-obj :initform nil) ;; added for use in tracking (auto-attend :accessor auto-attend :initform nil) (purge-visicon :accessor purge-visicon :initform t) (scene-change :accessor scene-change :initform nil) @@ -1246,7 +1257,7 @@ ) (:default-initargs :name :VISION - :version-string "9.0")) + :version-string "10.0")) (defun visual-location-slots (chunk vis-m) @@ -2317,7 +2328,7 @@ (bt:with-lock-held ((marker-lock vis-mod)) (set-current-marker vis-mod loc position) (setf (currently-attended vis-mod) nil) - (setf (last-obj vis-mod) nil) + ;(setf (last-obj vis-mod) nil) (set-buffer-failure 'visual :ignore-if-full t :requested requested) (setf (attend-failure vis-mod) t) @@ -2336,8 +2347,8 @@ ;; record the object for tracking purposes - (bt:with-lock-held ((marker-lock vis-mod)) - (setf (last-obj vis-mod) obj)) + ;(bt:with-lock-held ((marker-lock vis-mod)) + ; (setf (last-obj vis-mod) obj)) ;; update the time-stamp on the finst if it's already attended or ;; add a new finst if it's not @@ -2565,11 +2576,7 @@ Whenever there's a change to the display the buffers will be updated as follows: (bt:with-lock-held ((marker-lock vis-mod)) (setf (tracked-obj vis-mod) current-visicon-entry) (setf (tracked-obj-lastloc vis-mod) nil) ;; don't assume anything about vis-loc buffer at this point - (let ((vis-obj (buffer-read 'visual))) ;; should always be empty since the request clears it but - ;; if not record it for later checking - (if (and vis-obj (eq (chunk-copied-from-fct vis-obj) (last-obj vis-mod))) - (setf (tracked-obj-last-obj vis-mod) vis-obj) - (setf (tracked-obj-last-obj vis-mod) nil)))) + ) (update-tracking-mth vis-mod) @@ -2595,13 +2602,6 @@ Whenever there's a change to the display the buffers will be updated as follows: (when modify (mod-buffer-chunk 'visual (list 'screen-pos vis-loc))))) -;;; Record the visual object chunk placed into the buffer -;;; for later comparisons when needed - -(defmethod update-tracking-obj-chunk ((vis-mod vision-module)) - (bt:with-lock-held ((marker-lock vis-mod)) - (setf (tracked-obj-last-obj vis-mod) (buffer-read 'visual)))) - (defgeneric update-tracking-mth (vis-mod &optional from-proc-display) (:documentation "Update the state of a tracked object")) @@ -2615,7 +2615,7 @@ Whenever there's a change to the display the buffers will be updated as follows: (setf (currently-attended vis-mod) nil) (setf (attend-failure vis-mod) t) (setf (tracked-obj vis-mod) nil) - (setf (last-obj vis-mod) nil) + ;(setf (last-obj vis-mod) nil) (when (tracking-clear vis-mod) (set-current-marker vis-mod nil))) @@ -2627,136 +2627,140 @@ Whenever there's a change to the display the buffers will be updated as follows: (let (tracked still-available old-loc - old-obj + ; old-obj tracked-loc) (bt:with-lock-held ((marker-lock vis-mod)) (setf tracked (tracked-obj vis-mod)) (setf still-available (find tracked (visicon vis-mod))) (setf old-loc (tracked-obj-lastloc vis-mod)) - (setf old-obj (tracked-obj-last-obj vis-mod))) + ;(setf old-obj (last-obj vis-mod)) + ) (unless still-available (tracking-failed)) (setf tracked-loc (chunk-visual-loc tracked)) - (let ((vis-loc-chunk (buffer-read 'visual-location)) - (vis-obj-chunk (buffer-read 'visual))) + (let* ((vis-loc-chunk (buffer-read 'visual-location)) + (vis-obj-chunk (buffer-read 'visual)) + (vis-obj-marker (when vis-obj-chunk + (chunk-visicon-entry vis-obj-chunk)))) - ;; we don't have an old-loc but the one currently in the - ;; visual-location buffer is the screen-pos of the old-obj - ;; should make that the old-loc. This is the 5.1 fix. + ;; we don't have an old-loc but there is one currently in the + ;; visual-location buffer which has the right visicon-entry + ;; so assume that's the "right" one -- not quite the same + ;; fix as was done with the issue in 5.1 but that situation + ;; shouldn't happen now with the way the chunks are created + ;; from the visicon - (when (and (null old-loc) old-obj vis-loc-chunk - (chunk-slot-equal vis-loc-chunk (fast-chunk-slot-value-fct old-obj 'screen-pos))) + (when (and (null old-loc) vis-loc-chunk + (eq tracked (chunk-visicon-entry vis-loc-chunk))) (setf old-loc vis-loc-chunk)) - - (let ((new-obj (convert-loc-to-object vis-mod tracked))) (unless new-obj ;; for some reason we have a location but no object (tracking-failed)) - (bt:with-lock-held ((marker-lock vis-mod)) - (set-current-marker vis-mod tracked) - (setf (last-obj vis-mod) new-obj)) - - ;; For the following events need to set priority of the buffer setting - ;; so that if there's a find-location scheduled but not completed this - ;; happens first, so that the find-loc overwrites. Thus the priorities > 10. + ;; For the following events need to set priority of the buffer setting + ;; so that if there's a find-location scheduled but not completed this + ;; happens first, so that the find-loc overwrites. Thus the priorities > 10. - (flet ((set-vis-loc () - (schedule-set-buffer-chunk 'visual-location tracked-loc 0 :time-in-ms t :module :vision - :output 'high :requested nil :priority 15) - ;; need to make sure the chunk being set in the buffer isn't deleted before it gets there - (when from-proc-display - (lock-vision vis-mod) - (schedule-event-now 'unlock-vision :module :vision - :destination :vision :priority 14 - :output nil :maintenance t))) - (mod-vis-loc () - (schedule-mod-buffer-chunk 'visual-location (chunk-difference-to-chunk-spec tracked-loc vis-loc-chunk) 0 - :time-in-ms t :module :vision :output 'high :priority 15)) - (set-vis-obj () - (schedule-set-buffer-chunk 'visual new-obj 0 :time-in-ms t :module :vision - :output 'high :requested nil :priority 14)) - (mod-vis-obj () - (schedule-mod-buffer-chunk 'visual (chunk-difference-to-chunk-spec new-obj vis-obj-chunk) 0 - :time-in-ms t :module :vision :output 'high :priority 14)) - (update-loc (mod) - (schedule-event-now 'update-tracking-loc-chunk :module :vision - :destination :vision :params (if mod (list t) nil) :priority 13 :output nil)) - (update-obj () - (schedule-event-now 'update-tracking-obj-chunk :module :vision - :destination :vision :params nil :priority 12 :output nil))) - - ;;; Make sure there's still a finst on the tracked item + (flet ((set-vis-loc () + (schedule-set-buffer-chunk 'visual-location tracked-loc 0 :time-in-ms t :module :vision + :output 'high :requested nil :priority 15) + ;; need to make sure the chunk being set in the buffer isn't deleted before it gets there + (when from-proc-display + (lock-vision vis-mod) + (schedule-event-now 'unlock-vision :module :vision + :destination :vision :priority 14 + :output nil :maintenance t))) + (mod-vis-loc () + (schedule-mod-buffer-chunk 'visual-location (chunk-difference-to-chunk-spec tracked-loc vis-loc-chunk) 0 + :time-in-ms t :module :vision :output 'high :priority 15)) + (set-vis-obj () + (schedule-set-buffer-chunk 'visual new-obj 0 :time-in-ms t :module :vision + :output 'high :requested nil :priority 14) + ) + (mod-vis-obj () + (schedule-mod-buffer-chunk 'visual (chunk-difference-to-chunk-spec new-obj vis-obj-chunk) 0 + :time-in-ms t :module :vision :output 'high :priority 14) + ) + (update-loc (mod) + (schedule-event-now 'update-tracking-loc-chunk :module :vision + :destination :vision :params (if mod (list t) nil) :priority 13 :output nil)) + ) - (aif (member tracked (finst-lst vis-mod) :key 'id :test 'equal) - (setf (tstamp (first it)) (mp-time-ms)) - (add-finst vis-mod tracked)) + ;;; Make sure there's still a finst on the tracked item + + (aif (member tracked (finst-lst vis-mod) :key 'id :test 'equal) + (setf (tstamp (first it)) (mp-time-ms)) + (add-finst vis-mod tracked)) - (cond ((and (null vis-loc-chunk) - (null vis-obj-chunk)) - ;; Stuff both buffers and then update the obj with the buffer-chunk's name - (set-vis-loc) - (set-vis-obj) - (update-loc t) - (update-obj)) - - ((and (null vis-loc-chunk) - (eq vis-obj-chunk old-obj)) - ;; stuff the new location and modify the visual buffer with the new info - (set-vis-loc) - (mod-vis-obj) - (update-loc t)) + (cond ((and (null vis-loc-chunk) + (null vis-obj-chunk)) + ;; Stuff both buffers + (set-vis-loc) + (set-vis-obj) + (update-loc t) + ) - ((null vis-loc-chunk) - ;; stuff a new location chunk and don't touch the chunk in the visual buffer - (set-vis-loc) - (update-loc nil)) + ((and (null vis-loc-chunk) + (eq vis-obj-marker tracked)) ;; still the right chunk + ;; stuff the new location and modify the visual buffer with the new info + (set-vis-loc) + (mod-vis-obj) + (update-loc t)) + + ((null vis-loc-chunk) + ;; stuff a new location chunk and don't touch the chunk in the visual buffer + (set-vis-loc) + (update-loc nil)) - ((and (eq vis-loc-chunk old-loc) - (null vis-obj-chunk)) - ;; Modify the chunk in the visual-location buffer put new obj into visual buffer - (mod-vis-loc) - (set-vis-obj) - (update-loc t) - (update-obj)) + ((and (eq vis-loc-chunk old-loc) + (null vis-obj-chunk)) + ;; Modify the chunk in the visual-location buffer put new obj into visual buffer + (mod-vis-loc) + (set-vis-obj) + (update-loc t) + ) - ((and (eq vis-loc-chunk old-loc) - (eq vis-obj-chunk old-obj)) - ;; Modify both chunks and make sure the obj points to the right loc just to be safe. - (mod-vis-loc) - (mod-vis-obj) - (update-loc t)) + ((and (eq vis-loc-chunk old-loc) + (eq vis-obj-marker tracked)) + ;; Modify both chunks and make sure the obj points to the right loc just to be safe. + (mod-vis-loc) + (mod-vis-obj) + (update-loc t)) - ((eq vis-loc-chunk old-loc) - ;; just modify the loc and don't know about the visual buffer - (mod-vis-loc)) + ((eq vis-loc-chunk old-loc) + ;; just modify the loc and don't know about the visual buffer + (mod-vis-loc)) - ((null vis-obj-chunk) - ;; Don't know about the vis-loc buffer just put the new object in place - ;; setting the screen-pos if it isn't - - (unless (chunk-slot-value-fct new-obj 'screen-pos) - (set-chunk-slot-value-fct new-obj 'screen-pos tracked-loc)) + ((null vis-obj-chunk) + ;; Don't know about the vis-loc buffer just put the new object in place + ;; setting the screen-pos if it isn't - (set-vis-obj) - (update-obj)) + (unless (chunk-slot-value-fct new-obj 'screen-pos) + (set-chunk-slot-value-fct new-obj 'screen-pos tracked-loc)) + + (set-vis-obj) + ) - ((eq vis-obj-chunk old-obj) - ;; Just modify the object chunk and set the screen-pos if necessary - - (unless (chunk-slot-value-fct new-obj 'screen-pos) - (set-chunk-slot-value-fct new-obj 'screen-pos tracked-loc)) - (mod-vis-obj)) + ((eq vis-obj-marker tracked) + ;; Just modify the object chunk and set the screen-pos if necessary + + (unless (chunk-slot-value-fct new-obj 'screen-pos) + (set-chunk-slot-value-fct new-obj 'screen-pos tracked-loc)) + (mod-vis-obj)) - (t ;; Don't do anything - )))))) - nil))) + (t ;; Don't do anything + )) + + (bt:with-lock-held ((marker-lock vis-mod)) + (set-current-marker vis-mod tracked) + )))) + nil)))) ;;; REMOVE-TRACKING [Method] @@ -2770,7 +2774,6 @@ Whenever there's a change to the display the buffers will be updated as follows: (defmethod remove-tracking ((vis-mod vision-module)) (bt:with-lock-held ((marker-lock vis-mod)) (setf (tracked-obj-lastloc vis-mod) nil) - (setf (tracked-obj-last-obj vis-mod) nil) (setf (tracked-obj vis-mod) nil)) (change-state vis-mod :exec 'FREE)) @@ -2787,7 +2790,7 @@ Whenever there's a change to the display the buffers will be updated as follows: ;; handles clof and current-marker (set-current-marker vis-mod nil) - (setf (last-obj vis-mod) nil) + ;(setf (last-obj vis-mod) nil) (setf (loc-failure vis-mod) nil) (setf (attend-failure vis-mod) nil) @@ -3018,6 +3021,12 @@ Whenever there's a change to the display the buffers will be updated as follows: (make-instance 'vision-module)) +(defun dont-query-vis-loc (vis-mod) + (declare (ignore vis-mod)) + (sgp :do-not-query visual-location) + (buffer-requires-copies 'visual-location)) + + (defun reset-vision-module (vis-mod) (reset-pm-module vis-mod) @@ -3027,7 +3036,7 @@ Whenever there's a change to the display the buffers will be updated as follows: (setf (current-marker vis-mod) nil) (setf (clof vis-mod) nil) - (setf (last-obj vis-mod) nil) + ;(setf (last-obj vis-mod) nil) (setf (loc-failure vis-mod) nil) (setf (attend-failure vis-mod) nil) @@ -3411,7 +3420,7 @@ Whenever there's a change to the display the buffers will be updated as follows: :version (version-string (make-instance 'vision-module)) :documentation "A module to provide a model with a visual attention system" :creation 'create-vision-module - :reset 'reset-vision-module + :reset '(reset-vision-module dont-query-vis-loc) :query 'query-vision-module :request 'pm-module-request :params 'params-vision-module diff --git a/docs/AGI.pdf b/docs/AGI.pdf index 2105725..cd4e4a3 100644 Binary files a/docs/AGI.pdf and b/docs/AGI.pdf differ diff --git a/docs/EnvironmentManual.pdf b/docs/EnvironmentManual.pdf index 2b86994..4efa2fd 100644 Binary files a/docs/EnvironmentManual.pdf and b/docs/EnvironmentManual.pdf differ diff --git a/docs/QuickStart.txt b/docs/QuickStart.txt index 7aeb280..1dd589e 100644 --- a/docs/QuickStart.txt +++ b/docs/QuickStart.txt @@ -26,11 +26,11 @@ ACT-R remote interface server. Once the ACT-R version information is printed it is ready to use. If you would like to use the ACT-R Environment GUI then you can run the -appropriate application for your OS in the environment directory of the sources -("Start Environment.exe", "start-environment-osx", or "start environment -Linux"). Once the buttons appear in the "Control Panel" window the ACT-R -Environment is ready to use. When you are done with the ACT-R Environment, -closing the "Control Panel" window will exit the application. +appropriate application for your OS in the environment directory: +"Start Environment.exe", "start-environment-osx", or "start-environment-Linux". +Once the buttons appear in the "Control Panel" window the ACT-R Environment +is ready to use. When you are done with the ACT-R Environment, closing the +"Control Panel" window will exit the application. If you are using LispWorks or Allegro Common Lisp with either macOS or Windows or using Clozure Common Lisp with Windows, macOS, or Linux, then you diff --git a/docs/Task_Interfacing.pdf b/docs/Task_Interfacing.pdf index d28510c..c350642 100644 Binary files a/docs/Task_Interfacing.pdf and b/docs/Task_Interfacing.pdf differ diff --git a/docs/compilation.xls b/docs/compilation.xls index 4e42f79..d4a1edd 100644 Binary files a/docs/compilation.xls and b/docs/compilation.xls differ diff --git a/docs/reference-manual.pdf b/docs/reference-manual.pdf index 2009ff7..1714506 100644 Binary files a/docs/reference-manual.pdf and b/docs/reference-manual.pdf differ diff --git a/docs/remote.pdf b/docs/remote.pdf index 840ea4b..8f55533 100644 Binary files a/docs/remote.pdf and b/docs/remote.pdf differ diff --git a/environment/GUI/dialogs/11-ctrl-panel-load-python-button.tcl b/environment/GUI/dialogs/11-ctrl-panel-load-python-button.tcl new file mode 100644 index 0000000..02a8445 --- /dev/null +++ b/environment/GUI/dialogs/11-ctrl-panel-load-python-button.tcl @@ -0,0 +1,110 @@ +# Assumes the normal load button has been loaded first. +# Works like the load ACT-R code button except that it +# passes the pathname off to the Python-import-from-file +# command if it exists which can import a python module +# + +set load_result "" + +proc record_load_traces {model s} { + global load_result + + set load_result "$load_result$s" + + return "" +} + +proc load_python_file {fname {wait ""}} { + + global load_result + global options_array + + set load_result "" + + set load_monitor [add_new_cmd load_monitor "record_load_traces" "Environment command for capturing output during Import Python module."] + + send_cmd "monitor" [list "model-trace" $load_monitor] + send_cmd "monitor" [list "command-trace" $load_monitor] + send_cmd "monitor" [list "warning-trace" $load_monitor] + send_cmd "monitor" [list "general-trace" $load_monitor] + + set result [call_act_r_command_with_error_messages "Python-import-from-file" nil [list {$fname}]] + + send_cmd "remove-monitor" [list "model-trace" $load_monitor] + send_cmd "remove-monitor" [list "command-trace" $load_monitor] + send_cmd "remove-monitor" [list "warning-trace" $load_monitor] + send_cmd "remove-monitor" [list "general-trace" $load_monitor] + + remove_cmd $load_monitor + + set win [toplevel [new_variable_name .import_response]] + + # hide the window for speed and aesthetic reasons + + wm withdraw $win + + wm geometry $win [get_configuration .import_response $win] + + set text_frame [frame $win.text_frame -borderwidth 0] + + set text_box [text $text_frame.text -yscrollcommand \ + "$text_frame.text_scrl set" -state normal \ + -font text_font] + + set text_scroll_bar [scrollbar $text_frame.text_scrl \ + -command "$text_box yview"] + + set the_button [button $win.but -text "Ok" -font button_font -command "destroy $win"] + + place $text_frame -x 0 -y 0 -relheight 1.0 -height -30 -relwidth 1.0 + place $the_button -relx .5 -x -30 -width 60 -rely 1.0 -y -30 -height 30 + + pack $text_scroll_bar -side right -fill y + pack $text_box -side left -expand 1 -fill both + + if {[lindex $result 1] != "true" } { + wm title $win "ERROR importing" + $text_box insert 1.0 "Failed to import $fname\n[lindex $result 1]" + } else { + wm title $win "SUCCESSFUL import" + $text_box insert 1.0 $load_result + } + + wm deiconify $win + focus $win + + if {$wait != ""} {tkwait window $win} + +} + +button [control_panel_name].load_py -text "Import Python module" -font button_font -command { + global local_connection + global top_dir + global current_file_window + global currently_open_files + + set fname "" + + if {$local_connection == 0} { + tk_messageBox -icon warning -type ok -title "Load warning" \ + -message "You cannot use the Load Python module button if the\ + environment is not running on the same machine\ + as ACT-R." + } elseif {[send_cmd "check" "Python-import-from-file"] == "null"} { + tk_messageBox -icon warning -type ok -title "No Python connection found" \ + -message "Did not find a Python with the actr.py module imported that would accept the import request." + + } else { + if {$current_file_window == ""} { + set fname [tk_getOpenFile -title "File to load" -initialdir $top_dir] + } else { + set fname [tk_getOpenFile -title "File to load" -initialdir [file dirname $currently_open_files($current_file_window)] -initialfile [file tail $currently_open_files($current_file_window)]] + } + + if {$fname != ""} { + load_python_file $fname + } + } +} + +pack [control_panel_name].load_py diff --git a/environment/GUI/dialogs/21-stepper.tcl b/environment/GUI/dialogs/21-stepper.tcl index 6046e9f..f497ccd 100644 --- a/environment/GUI/dialogs/21-stepper.tcl +++ b/environment/GUI/dialogs/21-stepper.tcl @@ -557,6 +557,11 @@ proc update_instantiation_viewers {list} { } } + if { $side == "rhs" && $is_buffer == 1 && [.stepper.prod_frame.f3.f.text search -exact ">" $word_end "$word_end +1 chars"] != ""} { + + #do nothing for the RHS buffer modification actions + + } else { set t_name [new_variable_name tag] .stepper.prod_frame.f3.f.text tag add $t_name $v_start $word_end @@ -598,7 +603,9 @@ proc update_instantiation_viewers {list} { -message "There was additional text selected when clicking on a variable. Please try again." -type ok } } + } set strt $word_end + } } update_text_pane .stepper.prod_frame.f2.f.text $b diff --git a/environment/GUI/dialogs/999-image-item.tcl b/environment/GUI/dialogs/999-image-item.tcl index b50d19d..298595b 100644 --- a/environment/GUI/dialogs/999-image-item.tcl +++ b/environment/GUI/dialogs/999-image-item.tcl @@ -4,7 +4,7 @@ # file. # # All of the .gif files to display must be available in the -# GUI/AGI-images directory. +# gui/AGI-images directory. # # Mouse clicks on the item will be handled in the virtual # view on the Lisp side just like they would if the window @@ -56,7 +56,7 @@ add_agi_handler remove agi_image_remove_handler # When an image cmd is sent read the file from the images -# directory in GUI and add it to the window's canvas. +# directory in gui and add it to the window's canvas. # The params sent are: item_name x y file_name width height proc agi_image_creation_handler {cmd win coords params} { diff --git a/environment/GUI/server.tcl b/environment/GUI/server.tcl index 74a7930..b1a7915 100644 --- a/environment/GUI/server.tcl +++ b/environment/GUI/server.tcl @@ -98,7 +98,7 @@ if {$standalone_mode == 2} {cd applications} if {$standalone_mode == 0} {cd "environment"} -if {$standalone_mode != 3} {cd "GUI"} +if {$standalone_mode != 3} {cd "gui"} diff --git a/environment/server.lisp b/environment/server.lisp index 495ea90..b2d2f85 100644 --- a/environment/server.lisp +++ b/environment/server.lisp @@ -282,6 +282,14 @@ ;;; 2019.11.01 Dan ;;; : * Change run-environment for the Macs to run the application ;;; : directly because it's not in an app bundle anymore. +;;; 2021.05.11 Dan +;;; : * Changed reference to GUI directory to gui to avoid issues +;;; : with logical pathnames (particularlly in SBCL). +;;; 2021.09.15 Dan +;;; : * The Linux environment application now has dashes instead +;;; : of spaces in its name. +;;; : * Also fixed the Linux and macOS versions of ACL to run +;;; : the correct program. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; #+:packaged-actr (in-package :act-r) @@ -310,7 +318,7 @@ (defun run-environment () (let ((c (ccl::cd "."))) (ccl::cd "ACT-R:environment") - (run-program "./start environment Linux" nil :wait nil) + (run-program "./start-environment-Linux" nil :wait nil) (ccl::cd c))) #+(and :ccl :darwin) @@ -342,15 +350,15 @@ (defun run-environment () (let ((c (current-directory))) (chdir "ACT-R:environment") - (run-shell-command "'Start Environment OSX.app/Contents/MacOS/start-environment-osx'" :wait nil) + (run-shell-command "./start-environment-osx" :wait nil) (chdir c))) #+(and :allegro :linux) (defun run-environment () (let ((c (current-directory))) - (chdir "ACT-R:environment;GUI") - (run-shell-command "./starter.tcl" :wait nil) + (chdir "ACT-R:environment") + (run-shell-command "./start-environment-Linux" :wait nil) (chdir c))) (unless (fboundp 'run-environment) diff --git a/environment/start environment Linux b/environment/start environment Linux deleted file mode 100755 index 7ae5b50..0000000 Binary files a/environment/start environment Linux and /dev/null differ diff --git a/environment/start-environment-Linux b/environment/start-environment-Linux new file mode 100755 index 0000000..405bad3 Binary files /dev/null and b/environment/start-environment-Linux differ diff --git a/environment/start-environment-osx b/environment/start-environment-osx index 72249c0..27f01cf 100755 Binary files a/environment/start-environment-osx and b/environment/start-environment-osx differ diff --git a/environment/stepper-control.lisp b/environment/stepper-control.lisp index 0c3d34e..f8cc2e9 100644 --- a/environment/stepper-control.lisp +++ b/environment/stepper-control.lisp @@ -18,7 +18,8 @@ ;;; Description : No system dependent code. ;;; : This file contains the Lisp to support the stepper window. ;;; : -;;; Bugs : +;;; Bugs : [ ] Display more info in the cases when data wasn't recorded +;;; : 2021.01.27 fix at least stopped the warning ;;; ;;; Todo : [ ] Extend the possible information which can be recorded ;;; : with some sort of action triggers and data hooks. @@ -171,6 +172,12 @@ ;;; : * Use suppress-undelay-cr and unsuppress-undelay-cr so that ;;; : opening and closing the stepper doesn't potentially lead to ;;; : scheduling a new conflict-resolution. +;;; 2021.01.27 Dan +;;; : * Added a safety check to displaying the production-fired +;;; : details since it's possible that the stepper wasn't open +;;; : when the production was selected and thus there's no info +;;; : recorded. In that case it will just print the name in the +;;; : list, but none of the details. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -675,7 +682,11 @@ (eq (evt-action event) 'production-fired)) (list (with-model-eval (evt-model event) (if (eq (evt-action event) 'production-fired) - (list (car (stepper-module-cs (get-module stepper)))) + ;; catch when no saved data + (if (car (stepper-module-cs (get-module stepper))) + (list (car (stepper-module-cs (get-module stepper)))) + ;; get production named in the event + (list (production-name (first (evt-params event))))) (stepper-module-cs (get-module stepper)))) (if (eq (evt-action event) 'production-selected) t nil) "Possible Productions" "Production Parameters" "Bindings" "Production")) @@ -688,10 +699,11 @@ (t (list nil nil "" "" "" "")))) (saved-details (cond ((or (eq (evt-action event) 'production-selected) - (eq (evt-action event) 'production-fired)) + (eq (evt-action event) 'production-fired)) (with-model-eval (evt-model event) (mapcar (lambda (p) - (let* ((prod (get-production p)) + (when p + (let* ((prod (get-production p)) (bindings (when prod (bt:with-recursive-lock-held ((production-lock prod)) (mapcar (lambda (x) @@ -714,7 +726,7 @@ (second x)) (third x))) bindings) - ))) + )))) (if (eq (evt-action event) 'production-fired) (list (car (stepper-module-cs (get-module stepper)))) diff --git a/examples/connections/nodejs/environment.html b/examples/connections/nodejs/environment.html index 214c1ab..4c98618 100644 --- a/examples/connections/nodejs/environment.html +++ b/examples/connections/nodejs/environment.html @@ -378,6 +378,33 @@ } } + function load_python_module() { + if (socket.io.opts.hostname == "127.0.0.1" || socket.io.opts.hostname == "localhost") { + + var input = document.createElement('input'); + input.type = 'file'; + + load_results = ""; + + monitor_cmd("model-trace","monitor_loading"); + monitor_cmd("command-trace","monitor_loading"); + monitor_cmd("warning-trace","monitor_loading"); + monitor_cmd("general-trace","monitor_loading"); + + + input.onchange = e => { + var file = e.target.files[0]; + evaluate_cmd("load-python-module-html",null,[file.name],report_load_results); + } + + + input.click(); + + } else { + alert("Only local connections may import modules."); + } + } + @@ -1600,6 +1627,11 @@ } else { details.in_buffer = last_buffer.slice(1); } + } else { + if (s[o+m.length] == ">") { + txt = m; + index--; + } } tutor_values.push([m,(o < separator)]); @@ -2398,6 +2430,7 @@
Unit
+
diff --git a/examples/connections/nodejs/html-environment-linux b/examples/connections/nodejs/html-environment-linux index 3e0f4f3..fe40fc4 100755 Binary files a/examples/connections/nodejs/html-environment-linux and b/examples/connections/nodejs/html-environment-linux differ diff --git a/examples/connections/nodejs/html-environment-macos b/examples/connections/nodejs/html-environment-macos index e4f4805..95954ce 100755 Binary files a/examples/connections/nodejs/html-environment-macos and b/examples/connections/nodejs/html-environment-macos differ diff --git a/examples/connections/nodejs/html-environment-win.exe b/examples/connections/nodejs/html-environment-win.exe index 8807609..97c9779 100644 Binary files a/examples/connections/nodejs/html-environment-win.exe and b/examples/connections/nodejs/html-environment-win.exe differ diff --git a/examples/creating-image-items/background-image.lisp b/examples/creating-image-items/background-image.lisp index 1622548..9d9a1ad 100644 --- a/examples/creating-image-items/background-image.lisp +++ b/examples/creating-image-items/background-image.lisp @@ -7,7 +7,7 @@ ;;; It is a demonstration of creating and using an ;;; image AGI item along with custom visicon features. ;;; It assumes that the ref-brain.gif file is in the -;;; GUI/AGI-images directory if you use a visible window +;;; gui/AGI-images directory if you use a visible window ;;; to see the images. ;;; ;;; To run the task call the run-test function. It has one diff --git a/examples/creating-image-items/background_image.py b/examples/creating-image-items/background_image.py index 26dcbb1..ca8ebf9 100644 --- a/examples/creating-image-items/background_image.py +++ b/examples/creating-image-items/background_image.py @@ -4,7 +4,7 @@ # It is a demonstration of creating and using an # image AGI item along with custom visicon features. # It assumes that the ref-brain.gif file is in the -# GUI/AGI-images directory if you use a visible window +# gui/AGI-images directory if you use a visible window # to see the images. # # To run the task call the run-test function. It has one diff --git a/examples/creating-image-items/creating-an-image.lisp b/examples/creating-image-items/creating-an-image.lisp index e3962cf..9adcae2 100644 --- a/examples/creating-image-items/creating-an-image.lisp +++ b/examples/creating-image-items/creating-an-image.lisp @@ -6,7 +6,7 @@ ;;; It is a simple demonstration of creating and using the ;;; image AGI item, and it assumes that the smalllogo.gif -;;; and ref-brain.gif files are in the GUI/AGI-images directory +;;; and ref-brain.gif files are in the gui/AGI-images directory ;;; if you use a visible window to see the images. ;;; ;;; To run the task call the run-test function. It has one diff --git a/examples/creating-image-items/creating_an_image.py b/examples/creating-image-items/creating_an_image.py index 44b55ed..8753d2b 100644 --- a/examples/creating-image-items/creating_an_image.py +++ b/examples/creating-image-items/creating_an_image.py @@ -3,7 +3,7 @@ # # It is a simple demonstration of creating and using the # image AGI item, and it assumes that the smalllogo.gif -# and ref-brain.gif files are in the GUI/AGI-images directory +# and ref-brain.gif files are in the gui/AGI-images directory # if you use a visible window to see the images. # # To run the task call the run_test function. It has one diff --git a/examples/creating-image-items/readme.txt b/examples/creating-image-items/readme.txt index 2979e92..9f6ae0d 100644 --- a/examples/creating-image-items/readme.txt +++ b/examples/creating-image-items/readme.txt @@ -4,7 +4,7 @@ image item available through the AGI. The creating-an-image.lisp and creating-an-image.py files define simple test functions which open an experiment window and add an image item. If a visible window is requested then -the .gif files from the GUI/AGI-images directory are displayed +the .gif files from the gui/AGI-images directory are displayed in the visible virtual window created by the ACT-R Environment. Details on using the test functions can be found in the comments of those files. diff --git a/examples/creating-modules/external/goal.py b/examples/creating-modules/external/goal.py index 3e04ff3..df7a6f1 100644 --- a/examples/creating-modules/external/goal.py +++ b/examples/creating-modules/external/goal.py @@ -68,27 +68,18 @@ def query(name,buffer,slot,value): actr.add_command('query-pgoal',query,'Query function for Python goal module') - def request (name,buffer,spec): chunk_desc = actr.chunk_spec_to_chunk_def(spec) - actr.release_chunk_spec(spec) - + if chunk_desc: - actr.schedule_event_now('create-goal-buffer-chunk',params=[buffer,chunk_desc],module='goal',priority= -100) + actr.schedule_set_buffer_chunk('goal',spec,0,module='goal',priority= -1000) + actr.schedule_event_now('release-chunk-spec-id',params=[spec],module='goal',priority= -1001,output=False) else: actr.print_warning('Invalid request made to the goal buffer.') actr.add_command('request-pgoal',request,'Request function for Python goal module') -def create_goal_buffer_chunk (buffer,chunk_desc): - name = actr.define_chunks(chunk_desc)[0] - actr.schedule_set_buffer_chunk(buffer,name,0,module='goal',priority= -1000) - actr.schedule_event_now("purge-chunk",params=[name],module='goal',priority=':min',maintenance=True) - -actr.add_command('create-goal-buffer-chunk',create_goal_buffer_chunk,"Command for goal module to put a chunk into the buffer and delete the original.") - - def buffer_mod(name,buffer,spec): actr.schedule_mod_buffer_chunk(buffer,spec,0,module='goal',priority=20) actr.schedule_event_now('release-chunk-spec-id',params=[spec],module='goal',priority=19,maintenance=True) diff --git a/examples/creating-modules/external/goal_complete.py b/examples/creating-modules/external/goal_complete.py index 53079b0..e2d9231 100644 --- a/examples/creating-modules/external/goal_complete.py +++ b/examples/creating-modules/external/goal_complete.py @@ -341,24 +341,16 @@ def query (model,name,buffer,slot,value): def request (model,name,buffer,spec): chunk_desc = actr.evaluate('chunk-spec-to-chunk-def',model,spec) - actr.evaluate('release-chunk-spec-id',model,spec) - + if chunk_desc: - actr.evaluate('schedule-event-now',model,'create_goal_buffer_chunk',[['params',[buffer,chunk_desc]],['module','goal'],['priority',-100]]) + actr.evaluate('schedule-set-buffer-chunk',model,'goal',spec,0,[['module','goal'],['priority',-1000]]) + actr.evaluate('schedule-event-now',model,'release-chunk-spec-id',[['params',[spec]],['module','goal'],['priority',-1001],['output',False]]) + else: actr.evaluate('print-warning',model,'Invalid request made to the goal buffer.') actr.add_command('request_pgoal',request,'Request function for Python goal module') - -def create_goal_buffer_chunk (model,buffer,chunk_desc): - name = actr.evaluate('define-chunks',model,chunk_desc)[0] - actr.evaluate('schedule-set-buffer-chunk',model,buffer,name,0,[['module','goal'],['priority',-1000]]) - actr.evaluate('schedule-event-now',model,'purge-chunk',[['params',[name]],['module','goal'],['priority',':min'],['maintenance',True]]) - -actr.add_command('create_goal_buffer_chunk',create_goal_buffer_chunk,"Command for goal module to put a chunk into the buffer and delete the original.") - - def buffer_mod(model,name,buffer,spec): actr.evaluate('schedule-mod-buffer-chunk',model,buffer,spec,0,[['module','goal'],['priority',20]]) actr.evaluate('schedule-event-now',model,'release-chunk-spec-id',[['params',[spec]],['module','goal'],['priority',19],['maintenance',True]]) diff --git a/examples/creating-modules/external/simple_declarative.py b/examples/creating-modules/external/simple_declarative.py index 4074e5d..a40799d 100644 --- a/examples/creating-modules/external/simple_declarative.py +++ b/examples/creating-modules/external/simple_declarative.py @@ -217,9 +217,20 @@ def buffer_cleared(name,buffer,chunk): actr.call_command("merge-chunks",match[0],chunk) - else: # otherwise just add it as a new chunk + else: # otherwise check if we can store it - add_chunk_to_dm(module,chunk) + if actr.call_command("chunk-not-storable",chunk) : + + # can't store it so store a copy + + copy = actr.copy_chunk(chunk) + add_chunk_to_dm(module,copy) + + else : + + # safe to store it directly + + add_chunk_to_dm(chunk) module.lock.release() diff --git a/examples/creating-modules/internal/all-components-model.lisp b/examples/creating-modules/internal/all-components-model.lisp index a6a07ec..5985e6a 100644 --- a/examples/creating-modules/internal/all-components-model.lisp +++ b/examples/creating-modules/internal/all-components-model.lisp @@ -123,44 +123,45 @@ Model definition code starts evaluating here Demo module's parameter function called with parameter (:ESC . T) :esc change noted Demo module's parameter function called with parameter (:DEMO-PARAM . 0.2) -#|Warning: Production DEMO2-REQUEST-WITH-REQUEST-PARAMETER makes a request to buffer DEMO2 without a query in the conditions. |# > (run-it) - 0.000 GOAL SET-BUFFER-CHUNK GOAL FREE NIL - 0.000 PROCEDURAL CONFLICT-RESOLUTION + 0.000 GOAL SET-BUFFER-CHUNK GOAL FREE NIL + 0.000 PROCEDURAL CONFLICT-RESOLUTION Demo module's query function called to query the DEMO1 buffer for STATE FREE Demo module detects that a production will be making a request to the DEMO1 buffer - 0.000 PROCEDURAL PRODUCTION-SELECTED CLEAR-GOAL-REQUEST-DEMO1 - 0.000 PROCEDURAL QUERY-BUFFER-ACTION DEMO1 - 0.050 PROCEDURAL PRODUCTION-FIRED CLEAR-GOAL-REQUEST-DEMO1 - 0.050 PROCEDURAL MODULE-REQUEST DEMO1 + 0.000 PROCEDURAL PRODUCTION-SELECTED CLEAR-GOAL-REQUEST-DEMO1 + 0.000 PROCEDURAL QUERY-BUFFER-ACTION DEMO1 + 0.050 PROCEDURAL PRODUCTION-FIRED CLEAR-GOAL-REQUEST-DEMO1 + 0.050 PROCEDURAL MODULE-REQUEST DEMO1 Request to the DEMO1 buffer: "= STATE T" - 0.050 PROCEDURAL CLEAR-BUFFER GOAL -The demo module detects that the GOAL buffer is clearing chunk FREE-0 - 0.050 PROCEDURAL CLEAR-BUFFER DEMO1 - 0.050 DEMO SET-BUFFER-CHUNK DEMO1 CHUNK0 - 0.050 PROCEDURAL CONFLICT-RESOLUTION - 0.050 PROCEDURAL PRODUCTION-SELECTED HARVEST-DEMO1-MOD-REQUEST-DEMO1 - 0.050 PROCEDURAL BUFFER-READ-ACTION DEMO1 - 0.100 PROCEDURAL PRODUCTION-FIRED HARVEST-DEMO1-MOD-REQUEST-DEMO1 - 0.100 PROCEDURAL MODULE-MOD-REQUEST DEMO1 + 0.050 PROCEDURAL CLEAR-BUFFER GOAL +The demo module detects that the GOAL buffer is clearing chunk GOAL-CHUNK0 which is not storeable + 0.050 PROCEDURAL CLEAR-BUFFER DEMO1 + 0.050 DEMO SET-BUFFER-CHUNK DEMO1 CHUNK0 + 0.050 PROCEDURAL CONFLICT-RESOLUTION +Demo module's query function called to query the DEMO1 buffer for STATE FREE + 0.050 PROCEDURAL PRODUCTION-SELECTED HARVEST-DEMO1-MOD-REQUEST-DEMO1 + 0.050 PROCEDURAL BUFFER-READ-ACTION DEMO1 + 0.050 PROCEDURAL QUERY-BUFFER-ACTION DEMO1 + 0.100 PROCEDURAL PRODUCTION-FIRED HARVEST-DEMO1-MOD-REQUEST-DEMO1 + 0.100 PROCEDURAL MODULE-MOD-REQUEST DEMO1 A buffer modification request was made to the DEMO1 buffer: "= SLOT 0". - 0.100 DEMO MOD-BUFFER-CHUNK DEMO1 - 0.100 PROCEDURAL CONFLICT-RESOLUTION + 0.100 DEMO MOD-BUFFER-CHUNK DEMO1 + 0.100 PROCEDURAL CONFLICT-RESOLUTION Demo module's query function called to query the DEMO2 buffer for STATE FREE Demo module detects that a production will be making a request to the DEMO2 buffer - 0.100 PROCEDURAL PRODUCTION-SELECTED MAKE-DEMO2-REQUEST - 0.100 PROCEDURAL BUFFER-READ-ACTION DEMO1 - 0.100 PROCEDURAL QUERY-BUFFER-ACTION DEMO2 - 0.150 PROCEDURAL PRODUCTION-FIRED MAKE-DEMO2-REQUEST - 0.150 PROCEDURAL MOD-BUFFER-CHUNK DEMO1 - 0.150 PROCEDURAL MODULE-REQUEST DEMO2 + 0.100 PROCEDURAL PRODUCTION-SELECTED MAKE-DEMO2-REQUEST + 0.100 PROCEDURAL BUFFER-READ-ACTION DEMO1 + 0.100 PROCEDURAL QUERY-BUFFER-ACTION DEMO2 + 0.150 PROCEDURAL PRODUCTION-FIRED MAKE-DEMO2-REQUEST + 0.150 PROCEDURAL MOD-BUFFER-CHUNK DEMO1 + 0.150 PROCEDURAL MODULE-REQUEST DEMO2 Request to the DEMO2 buffer: "= CREATE-CHUNK T" - 0.150 PROCEDURAL CLEAR-BUFFER DEMO2 - 0.150 PROCEDURAL CONFLICT-RESOLUTION - 0.150 ------ Stopped because time limit reached + 0.150 PROCEDURAL CLEAR-BUFFER DEMO2 + 0.150 PROCEDURAL CONFLICT-RESOLUTION + 0.150 ------ Stopped because time limit reached DEMO1: buffer empty : NIL buffer full : T @@ -187,38 +188,38 @@ Demo module's query function called to query the DEMO2 buffer for STATE ERROR state error : NIL Demo module's query function called to query the DEMO2 buffer for DETECT-JAM T detect-jam : NIL -DEMO1: CHUNK0-0 -CHUNK0-0 +DEMO1: DEMO1-CHUNK0 +DEMO1-CHUNK0 STATE T SLOT 1 DEMO2: NIL - 0.250 DEMO SET-BUFFER-CHUNK DEMO2 RESULT0 - 0.250 DEMO FINISH-DEMO2-REQUEST - 0.250 PROCEDURAL CONFLICT-RESOLUTION + 0.250 DEMO SET-BUFFER-CHUNK DEMO2 RESULT0 + 0.250 DEMO FINISH-DEMO2-REQUEST + 0.250 PROCEDURAL CONFLICT-RESOLUTION Demo module's query function called to query the DEMO2 buffer for DETECT-JAM NIL - 0.250 PROCEDURAL PRODUCTION-SELECTED MOD-REQUEST-TO-DEMO2 - 0.250 PROCEDURAL BUFFER-READ-ACTION DEMO1 - 0.250 PROCEDURAL BUFFER-READ-ACTION DEMO2 - 0.250 PROCEDURAL QUERY-BUFFER-ACTION DEMO2 - 0.300 PROCEDURAL PRODUCTION-FIRED MOD-REQUEST-TO-DEMO2 - 0.300 PROCEDURAL MODULE-MOD-REQUEST DEMO2 + 0.250 PROCEDURAL PRODUCTION-SELECTED MOD-REQUEST-TO-DEMO2 + 0.250 PROCEDURAL BUFFER-READ-ACTION DEMO1 + 0.250 PROCEDURAL BUFFER-READ-ACTION DEMO2 + 0.250 PROCEDURAL QUERY-BUFFER-ACTION DEMO2 + 0.300 PROCEDURAL PRODUCTION-FIRED MOD-REQUEST-TO-DEMO2 + 0.300 PROCEDURAL MODULE-MOD-REQUEST DEMO2 A buffer modification request was made to the DEMO2 buffer: "= ANSWER 10". - 0.300 PROCEDURAL CONFLICT-RESOLUTION + 0.300 PROCEDURAL CONFLICT-RESOLUTION Demo module's query function called to query the DEMO2 buffer for DETECT-JAM NIL - 0.300 PROCEDURAL PRODUCTION-SELECTED MOD-REQUEST-TO-DEMO2 - 0.300 PROCEDURAL BUFFER-READ-ACTION DEMO1 - 0.300 PROCEDURAL BUFFER-READ-ACTION DEMO2 - 0.300 PROCEDURAL QUERY-BUFFER-ACTION DEMO2 - 0.350 PROCEDURAL PRODUCTION-FIRED MOD-REQUEST-TO-DEMO2 - 0.350 PROCEDURAL MODULE-MOD-REQUEST DEMO2 + 0.300 PROCEDURAL PRODUCTION-SELECTED MOD-REQUEST-TO-DEMO2 + 0.300 PROCEDURAL BUFFER-READ-ACTION DEMO1 + 0.300 PROCEDURAL BUFFER-READ-ACTION DEMO2 + 0.300 PROCEDURAL QUERY-BUFFER-ACTION DEMO2 + 0.350 PROCEDURAL PRODUCTION-FIRED MOD-REQUEST-TO-DEMO2 + 0.350 PROCEDURAL MODULE-MOD-REQUEST DEMO2 A buffer modification request was made to the DEMO2 buffer: "= ANSWER 10". #|Warning: Demo module's demo2 buffer can only process one request at a time. |# - 0.350 PROCEDURAL CONFLICT-RESOLUTION + 0.350 PROCEDURAL CONFLICT-RESOLUTION Demo module's query function called to query the DEMO2 buffer for DETECT-JAM NIL - 0.350 ------ Stopped because time limit reached + 0.350 ------ Stopped because time limit reached DEMO2: buffer empty : NIL buffer full : T @@ -233,18 +234,20 @@ Demo module's query function called to query the DEMO2 buffer for STATE ERROR state error : NIL Demo module's query function called to query the DEMO2 buffer for DETECT-JAM T detect-jam : T -DEMO2: RESULT0-0 [RESULT0] -RESULT0-0 +DEMO2: DEMO2-CHUNK0 [RESULT0] +DEMO2-CHUNK0 DEMO-RESULT T - 0.500 DEMO MOD-BUFFER-CHUNK DEMO2 - 0.500 DEMO FINISH-DEMO2-REQUEST - 0.500 PROCEDURAL CONFLICT-RESOLUTION + 0.500 DEMO MOD-BUFFER-CHUNK DEMO2 + 0.500 DEMO FINISH-DEMO2-REQUEST + 0.500 PROCEDURAL CONFLICT-RESOLUTION +Demo module's query function called to query the DEMO2 buffer for STATE FREE Demo module detects that a production will be making a request to the DEMO2 buffer - 0.500 PROCEDURAL PRODUCTION-SELECTED DEMO2-REQUEST-WITH-REQUEST-PARAMETER - 0.500 PROCEDURAL BUFFER-READ-ACTION DEMO1 - 0.500 PROCEDURAL BUFFER-READ-ACTION DEMO2 - 0.500 ------ Stopped because time limit reached + 0.500 PROCEDURAL PRODUCTION-SELECTED DEMO2-REQUEST-WITH-REQUEST-PARAMETER + 0.500 PROCEDURAL BUFFER-READ-ACTION DEMO1 + 0.500 PROCEDURAL BUFFER-READ-ACTION DEMO2 + 0.500 PROCEDURAL QUERY-BUFFER-ACTION DEMO2 + 0.500 ------ Stopped because time limit reached DEMO2: buffer empty : NIL buffer full : T @@ -259,30 +262,30 @@ Demo module's query function called to query the DEMO2 buffer for STATE ERROR state error : NIL Demo module's query function called to query the DEMO2 buffer for DETECT-JAM T detect-jam : NIL -DEMO2: RESULT0-0 -RESULT0-0 +DEMO2: DEMO2-CHUNK0 +DEMO2-CHUNK0 ANSWER 10 DEMO-RESULT T - 0.550 PROCEDURAL PRODUCTION-FIRED DEMO2-REQUEST-WITH-REQUEST-PARAMETER - 0.550 PROCEDURAL MOD-BUFFER-CHUNK DEMO1 - 0.550 PROCEDURAL MODULE-REQUEST DEMO2 + 0.550 PROCEDURAL PRODUCTION-FIRED DEMO2-REQUEST-WITH-REQUEST-PARAMETER + 0.550 PROCEDURAL MOD-BUFFER-CHUNK DEMO1 + 0.550 PROCEDURAL MODULE-REQUEST DEMO2 Request to the DEMO2 buffer: "= :VALUE 15 = CREATE-CHUNK T" - 0.550 PROCEDURAL CLEAR-BUFFER DEMO2 -The demo module detects that the DEMO2 buffer is clearing chunk RESULT0-0 - 0.550 PROCEDURAL CONFLICT-RESOLUTION - 0.650 DEMO SET-BUFFER-CHUNK DEMO2 RESULT1 - 0.650 DEMO FINISH-DEMO2-REQUEST - 0.650 PROCEDURAL CONFLICT-RESOLUTION + 0.550 PROCEDURAL CLEAR-BUFFER DEMO2 +The demo module detects that the DEMO2 buffer is clearing chunk DEMO2-CHUNK0 which is not storeable + 0.550 PROCEDURAL CONFLICT-RESOLUTION + 0.650 DEMO SET-BUFFER-CHUNK DEMO2 RESULT1 + 0.650 DEMO FINISH-DEMO2-REQUEST + 0.650 PROCEDURAL CONFLICT-RESOLUTION Demo module's query function called to query the DEMO2 buffer for STATE FREE Demo module detects that a production will be making a request to the DEMO2 buffer - 0.650 PROCEDURAL PRODUCTION-SELECTED INVALID-DEMO2-REQUEST - 0.650 PROCEDURAL BUFFER-READ-ACTION DEMO1 - 0.650 PROCEDURAL BUFFER-READ-ACTION DEMO2 - 0.650 PROCEDURAL QUERY-BUFFER-ACTION DEMO2 - 0.650 ------ Stopped because time limit reached + 0.650 PROCEDURAL PRODUCTION-SELECTED INVALID-DEMO2-REQUEST + 0.650 PROCEDURAL BUFFER-READ-ACTION DEMO1 + 0.650 PROCEDURAL BUFFER-READ-ACTION DEMO2 + 0.650 PROCEDURAL QUERY-BUFFER-ACTION DEMO2 + 0.650 ------ Stopped because time limit reached DEMO2: buffer empty : NIL buffer full : T @@ -297,21 +300,21 @@ Demo module's query function called to query the DEMO2 buffer for STATE ERROR state error : NIL Demo module's query function called to query the DEMO2 buffer for DETECT-JAM T detect-jam : NIL -DEMO2: RESULT1-0 [RESULT1] -RESULT1-0 +DEMO2: DEMO2-CHUNK0 [RESULT1] +DEMO2-CHUNK0 ANSWER 15 DEMO-RESULT T - 0.700 PROCEDURAL PRODUCTION-FIRED INVALID-DEMO2-REQUEST - 0.700 PROCEDURAL MODULE-REQUEST DEMO2 + 0.700 PROCEDURAL PRODUCTION-FIRED INVALID-DEMO2-REQUEST + 0.700 PROCEDURAL MODULE-REQUEST DEMO2 Request to the DEMO2 buffer: "" #|Warning: Invalid request to the demo2 buffer: "" |# - 0.700 PROCEDURAL CLEAR-BUFFER DEMO2 -The demo module detects that the DEMO2 buffer is clearing chunk RESULT1-0 - 0.700 PROCEDURAL CONFLICT-RESOLUTION - 0.800 ------ Stopped because time limit reached + 0.700 PROCEDURAL CLEAR-BUFFER DEMO2 +The demo module detects that the DEMO2 buffer is clearing chunk DEMO2-CHUNK0 which is not storeable + 0.700 PROCEDURAL CONFLICT-RESOLUTION + 0.800 ------ Stopped because time limit reached DEMO2: buffer empty : T buffer full : NIL diff --git a/examples/creating-modules/internal/all-components-module.lisp b/examples/creating-modules/internal/all-components-module.lisp index ee482b9..9b1045b 100644 --- a/examples/creating-modules/internal/all-components-module.lisp +++ b/examples/creating-modules/internal/all-components-module.lisp @@ -45,6 +45,8 @@ ;;; 2020.06.01 Dan [5.0] ;;; : * Define the chunk-types in the creation function instead of ;;; : the reset function now. +;;; 2021.06.14 Dan +;;; : * Check the storability of the chunk in the clear buffer fn. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; General Docs: @@ -373,7 +375,7 @@ (defun demo-detect-clearing (instance buffer chunk) (declare (ignore instance)) - (act-r-output "The demo module detects that the ~s buffer is clearing chunk ~s" buffer chunk)) + (act-r-output "The demo module detects that the ~s buffer is clearing chunk ~s which is ~:[storable~;not storeable~]" buffer chunk (chunk-not-storable chunk))) ;;; This function will be called whenever a request to the ;;; demo module will be made by a production which has been diff --git a/examples/creating-modules/internal/demo-module.lisp b/examples/creating-modules/internal/demo-module.lisp index 830519d..ea515d8 100644 --- a/examples/creating-modules/internal/demo-module.lisp +++ b/examples/creating-modules/internal/demo-module.lisp @@ -62,15 +62,13 @@ (defun demo-create-chunk (demo spec) (if (demo-module-busy demo) (model-warning "Cannot handle request when busy") - (let* ((chunk-def (chunk-spec-to-chunk-def spec)) - (chunk (when chunk-def - (car (define-chunks-fct (list chunk-def)))))) - (when chunk + (let ((chunk-def (chunk-spec-to-chunk-def spec))) + (when chunk-def (let ((delay (if (demo-module-esc demo) (demo-module-delay demo) 0))) (setf (demo-module-busy demo) t) - (schedule-set-buffer-chunk 'create chunk delay :module 'demo) + (schedule-set-buffer-chunk 'create spec delay :module 'demo) (schedule-event-relative delay 'free-demo-module :params (list demo) :module 'demo)))))) (defun free-demo-module (demo) @@ -117,65 +115,61 @@ #| -? (load "ACT-R:examples;creating-modules;internal;demo-module.lisp") -#P"C:/Users/db30/desktop/actr7.x/examples/creating-modules/internal/demo-module.lisp" -? (load "ACT-R:examples;creating-modules;internal;demo-model.lisp") +> (trace demo-module-requests demo-module-queries create-demo-module reset-demo-module delete-demo-module demo-module-params) +(DEMO-MODULE-PARAMS DELETE-DEMO-MODULE RESET-DEMO-MODULE CREATE-DEMO-MODULE DEMO-MODULE-QUERIES + DEMO-MODULE-REQUESTS) +> (reset) + 0[5]: (RESET-DEMO-MODULE #S(DEMO-MODULE :DELAY 0.15 :ESC T :BUSY NIL)) + 0[5]: returned DEMO-OUTPUT + 0[5]: (DEMO-MODULE-PARAMS #S(DEMO-MODULE :DELAY 0.15 :ESC T :BUSY NIL) (:CREATE-DELAY . 0.1)) + 0[5]: returned 0.1 + 0[5]: (DEMO-MODULE-PARAMS #S(DEMO-MODULE :DELAY 0.1 :ESC T :BUSY NIL) (:ESC)) + 0[5]: returned NIL + 0[5]: (DEMO-MODULE-PARAMS #S(DEMO-MODULE :DELAY 0.1 :ESC NIL :BUSY NIL) (:ESC . T)) + 0[5]: returned T + 0[5]: (DEMO-MODULE-PARAMS #S(DEMO-MODULE :DELAY 0.1 :ESC T :BUSY NIL) (:CREATE-DELAY . 0.15)) + 0[5]: returned 0.15 #|Warning: Production P2 has a condition for buffer CREATE with an isa that provides no tests. |# -#|Warning: Production P2 makes a request to buffer OUTPUT without a query in the conditions. |# -#P"C:/Users/db30/desktop/actr7.x/examples/creating-modules/internal/demo-model.lisp" -? (trace demo-module-requests demo-module-queries create-demo-module reset-demo-module delete-demo-module demo-module-params) -NIL -? (reset) -0> Calling (RESET-DEMO-MODULE #S(DEMO-MODULE :DELAY 0.15 :ESC T :BUSY NIL)) -<0 RESET-DEMO-MODULE returned DEMO-OUTPUT -0> Calling (DEMO-MODULE-PARAMS #S(DEMO-MODULE :DELAY 0.15 :ESC T :BUSY NIL) (:ESC)) -<0 DEMO-MODULE-PARAMS returned NIL -0> Calling (DEMO-MODULE-PARAMS #S(DEMO-MODULE :DELAY 0.15 :ESC NIL :BUSY NIL) (:CREATE-DELAY . 0.1)) -<0 DEMO-MODULE-PARAMS returned 0.1 -0> Calling (DEMO-MODULE-PARAMS #S(DEMO-MODULE :DELAY 0.1 :ESC NIL :BUSY NIL) (:ESC . T)) -<0 DEMO-MODULE-PARAMS returned T -0> Calling (DEMO-MODULE-PARAMS #S(DEMO-MODULE :DELAY 0.1 :ESC T :BUSY NIL) (:CREATE-DELAY . 0.15)) -<0 DEMO-MODULE-PARAMS returned 0.15 -#|Warning: Production P2 has a condition for buffer CREATE with an isa that provides no tests. |# -#|Warning: Production P2 makes a request to buffer OUTPUT without a query in the conditions. |# T -? (run 1) +> (run 1) 0.000 PROCEDURAL CONFLICT-RESOLUTION -0> Calling (DEMO-MODULE-QUERIES #S(DEMO-MODULE :DELAY 0.15 :ESC T :BUSY NIL) CREATE STATE FREE) -<0 DEMO-MODULE-QUERIES returned T + 0[5]: (DEMO-MODULE-QUERIES #S(DEMO-MODULE :DELAY 0.15 :ESC T :BUSY NIL) CREATE STATE FREE) + 0[5]: returned T 0.000 PROCEDURAL PRODUCTION-SELECTED P1 0.000 PROCEDURAL QUERY-BUFFER-ACTION GOAL 0.000 PROCEDURAL QUERY-BUFFER-ACTION CREATE 0.050 PROCEDURAL PRODUCTION-FIRED P1 0.050 PROCEDURAL MODULE-REQUEST GOAL 0.050 PROCEDURAL MODULE-REQUEST CREATE -0> Calling (DEMO-MODULE-REQUESTS #S(DEMO-MODULE :DELAY 0.15 :ESC T :BUSY NIL) CREATE #S(ACT-R-CHUNK-SPEC :FILLED-SLOTS 108086391056891904 :EMPTY-SLOTS 0 :REQUEST-PARAM-SLOTS 0 :DUPLICATE-SLOTS 0 :EQUAL-SLOTS 108086391056891904 :NEGATED-SLOTS 0 :RELATIVE-SLOTS 0 :VARIABLES NIL :SLOT-VARS NIL :DEPENDENCIES NIL :SLOTS (#S(ACT-R-SLOT-SPEC :MODIFIER = :NAME SCREEN-X :VALUE 10 :TESTABLE T :VARIABLE NIL :REQUEST-PARAM NIL) #S(ACT-R-SLOT-SPEC :MODIFIER = :NAME SCREEN-Y :VALUE 20 :TESTABLE T :VARIABLE NIL :REQUEST-PARAM NIL)))) -<0 DEMO-MODULE-REQUESTS returned 15 + 0[5]: (DEMO-MODULE-REQUESTS #S(DEMO-MODULE :DELAY 0.15 :ESC T :BUSY NIL) CREATE #S(ACT-R-CHUNK-SPEC :FILLED-SLOTS 422212465065984 :EMPTY-SLOTS 0 :REQUEST-PARAM-SLOTS 0 :DUPLICATE-SLOTS 0 :EQUAL-SLOTS 422212465065984 :NEGATED-SLOTS 0 :RELATIVE-SLOTS 0 :VARIABLES NIL :SLOT-VARS NIL :DEPENDENCIES NIL :SLOTS (#2=#S(ACT-R-SLOT-SPEC :MODIFIER = :NAME SCREEN-X :VALUE 10 :VARIABLE NIL) #1=#S(ACT-R-SLOT-SPEC :MODIFIER = :NAME SCREEN-Y :VALUE 20 :VARIABLE NIL)) :TESTABLE-SLOTS (#1# #2#) ...)) + 0[5]: returned 15 0.050 PROCEDURAL CLEAR-BUFFER GOAL 0.050 PROCEDURAL CLEAR-BUFFER CREATE - 0.050 GOAL CREATE-NEW-BUFFER-CHUNK GOAL - 0.050 GOAL SET-BUFFER-CHUNK GOAL CHUNK1 + 0.050 GOAL SET-BUFFER-CHUNK-FROM-SPEC GOAL 0.050 PROCEDURAL CONFLICT-RESOLUTION - 0.200 DEMO SET-BUFFER-CHUNK CREATE CHUNK0 + 0.200 DEMO SET-BUFFER-CHUNK-FROM-SPEC CREATE 0.200 DEMO FREE-DEMO-MODULE #S(DEMO-MODULE :DELAY 0.15 :ESC T :BUSY T) 0.200 PROCEDURAL CONFLICT-RESOLUTION + 0[5]: (DEMO-MODULE-QUERIES #S(DEMO-MODULE :DELAY 0.15 :ESC T :BUSY NIL) OUTPUT STATE FREE) + 0[5]: returned T 0.200 PROCEDURAL PRODUCTION-SELECTED P2 0.200 PROCEDURAL BUFFER-READ-ACTION CREATE + 0.200 PROCEDURAL QUERY-BUFFER-ACTION OUTPUT 0.250 PROCEDURAL PRODUCTION-FIRED P2 0.250 PROCEDURAL MODULE-REQUEST OUTPUT -0> Calling (DEMO-MODULE-REQUESTS #S(DEMO-MODULE :DELAY 0.15 :ESC T :BUSY NIL) OUTPUT #S(ACT-R-CHUNK-SPEC :FILLED-SLOTS 6291456 :EMPTY-SLOTS 0 :REQUEST-PARAM-SLOTS 0 :DUPLICATE-SLOTS 0 :EQUAL-SLOTS 6291456 :NEGATED-SLOTS 0 :RELATIVE-SLOTS 0 :VARIABLES NIL :SLOT-VARS NIL :DEPENDENCIES NIL :SLOTS (#S(ACT-R-SLOT-SPEC :MODIFIER = :NAME VALUE :VALUE CHUNK0-0 :TESTABLE T :VARIABLE NIL :REQUEST-PARAM NIL) #S(ACT-R-SLOT-SPEC :MODIFIER = :NAME DEMO-OUTPUT :VALUE T :TESTABLE T :VARIABLE NIL :REQUEST-PARAM NIL)))) -Value: CHUNK0-0 -<0 DEMO-MODULE-REQUESTS returned NIL + 0[5]: (DEMO-MODULE-REQUESTS #S(DEMO-MODULE :DELAY 0.15 :ESC T :BUSY NIL) OUTPUT #S(ACT-R-CHUNK-SPEC :FILLED-SLOTS 604462909807348947091456 :EMPTY-SLOTS 0 :REQUEST-PARAM-SLOTS 0 :DUPLICATE-SLOTS 0 :EQUAL-SLOTS 604462909807348947091456 :NEGATED-SLOTS 0 :RELATIVE-SLOTS 0 :VARIABLES NIL :SLOT-VARS NIL :DEPENDENCIES NIL :SLOTS (#2=#S(ACT-R-SLOT-SPEC :MODIFIER = :NAME VALUE :VALUE CHUNK0 :VARIABLE NIL) #1=#S(ACT-R-SLOT-SPEC :MODIFIER = :NAME DEMO-OUTPUT :VALUE T :VARIABLE NIL)) :TESTABLE-SLOTS (#1# #2#) ...)) +Value: CHUNK0 + 0[5]: returned NIL 0.250 PROCEDURAL CLEAR-BUFFER CREATE 0.250 PROCEDURAL CLEAR-BUFFER OUTPUT 0.250 PROCEDURAL CONFLICT-RESOLUTION 0.250 ------ Stopped because no events left to process 0.25 -26 +25 NIL -? (clear-all) -0> Calling (DELETE-DEMO-MODULE #S(DEMO-MODULE :DELAY 0.15 :ESC T :BUSY NIL)) -<0 DELETE-DEMO-MODULE returned NIL +> (clear-all) + 0[5]: (DELETE-DEMO-MODULE #S(DEMO-MODULE :DELAY 0.15 :ESC T :BUSY NIL)) + 0[5]: returned NIL NIL |# diff --git a/examples/creating-modules/internal/simple-goal-style-model.lisp b/examples/creating-modules/internal/simple-goal-style-model.lisp index 7a4ea4e..4ab1269 100644 --- a/examples/creating-modules/internal/simple-goal-style-model.lisp +++ b/examples/creating-modules/internal/simple-goal-style-model.lisp @@ -41,29 +41,29 @@ Here is an example run of this model along with the buffer-status and buffer-chunk results after the run > (run 1) - 0.000 PROCEDURAL CONFLICT-RESOLUTION - 0.000 PROCEDURAL PRODUCTION-SELECTED CHECK-IT-IS-EMPTY - 0.000 PROCEDURAL QUERY-BUFFER-ACTION NEW-GOAL - 0.050 PROCEDURAL PRODUCTION-FIRED CHECK-IT-IS-EMPTY - 0.050 PROCEDURAL MODULE-REQUEST NEW-GOAL - 0.050 PROCEDURAL CLEAR-BUFFER NEW-GOAL - 0.050 NEW-GOAL CREATE-NEW-BUFFER-CHUNK NEW-GOAL ISA GOAL-CHUNK - 0.050 NEW-GOAL SET-BUFFER-CHUNK NEW-GOAL GOAL-CHUNK0 - 0.050 PROCEDURAL CONFLICT-RESOLUTION - 0.050 PROCEDURAL PRODUCTION-SELECTED NOTE-START - 0.050 PROCEDURAL BUFFER-READ-ACTION NEW-GOAL - 0.100 PROCEDURAL PRODUCTION-FIRED NOTE-START - 0.100 PROCEDURAL MODULE-MOD-REQUEST NEW-GOAL - 0.100 NEW-GOAL MOD-BUFFER-CHUNK NEW-GOAL - 0.100 PROCEDURAL CONFLICT-RESOLUTION - 0.100 PROCEDURAL PRODUCTION-SELECTED FINISH - 0.100 PROCEDURAL BUFFER-READ-ACTION NEW-GOAL - 0.150 PROCEDURAL PRODUCTION-FIRED FINISH - 0.150 PROCEDURAL MOD-BUFFER-CHUNK NEW-GOAL - 0.150 PROCEDURAL CONFLICT-RESOLUTION - 0.150 ------ Stopped because no events left to process + 0.000 PROCEDURAL CONFLICT-RESOLUTION + 0.000 PROCEDURAL PRODUCTION-SELECTED CHECK-IT-IS-EMPTY + 0.000 PROCEDURAL QUERY-BUFFER-ACTION NEW-GOAL + 0.050 PROCEDURAL PRODUCTION-FIRED CHECK-IT-IS-EMPTY + 0.050 PROCEDURAL MODULE-REQUEST NEW-GOAL + 0.050 PROCEDURAL CLEAR-BUFFER NEW-GOAL + 0.050 NEW-GOAL SET-BUFFER-CHUNK-FROM-SPEC NEW-GOAL + 0.050 PROCEDURAL CONFLICT-RESOLUTION + 0.050 PROCEDURAL PRODUCTION-SELECTED NOTE-START + 0.050 PROCEDURAL BUFFER-READ-ACTION NEW-GOAL + 0.050 PROCEDURAL QUERY-BUFFER-ACTION NEW-GOAL + 0.100 PROCEDURAL PRODUCTION-FIRED NOTE-START + 0.100 PROCEDURAL MODULE-MOD-REQUEST NEW-GOAL + 0.100 NEW-GOAL MOD-BUFFER-CHUNK NEW-GOAL + 0.100 PROCEDURAL CONFLICT-RESOLUTION + 0.100 PROCEDURAL PRODUCTION-SELECTED FINISH + 0.100 PROCEDURAL BUFFER-READ-ACTION NEW-GOAL + 0.150 PROCEDURAL PRODUCTION-FIRED FINISH + 0.150 PROCEDURAL MOD-BUFFER-CHUNK NEW-GOAL + 0.150 PROCEDURAL CONFLICT-RESOLUTION + 0.150 ------ Stopped because no events left to process 0.15 -25 +24 NIL > (buffer-status new-goal) @@ -77,11 +77,10 @@ NEW-GOAL: state busy : NIL state error : NIL (NEW-GOAL) - > (buffer-chunk new-goal) -NEW-GOAL: CHUNK0-0 -CHUNK0-0 +NEW-GOAL: NEW-GOAL-CHUNK0 +NEW-GOAL-CHUNK0 STATE DONE -(CHUNK0-0) +(NEW-GOAL-CHUNK0) |# diff --git a/extras/blending/blending-test-1.lisp b/extras/blending/blending-test-1.lisp index 3675729..dfd8614 100644 --- a/extras/blending/blending-test-1.lisp +++ b/extras/blending/blending-test-1.lisp @@ -169,7 +169,7 @@ Computing activation and latency for the blended chunk Activation for blended chunk is: 4.8876944 0.050 PROCEDURAL CONFLICT-RESOLUTION 0.058 BLENDING BLENDING-COMPLETE - 0.058 BLENDING SET-BUFFER-CHUNK BLENDING CHUNK0 + 0.058 BLENDING SET-BUFFER-CHUNK-FROM-SPEC BLENDING 0.058 PROCEDURAL CONFLICT-RESOLUTION 0.108 PROCEDURAL PRODUCTION-FIRED P2 BLENDED VALUE IS 2.82841 AND SIZE IS SMALL @@ -223,6 +223,6 @@ Not above threshold so blending failed 0.126 PROCEDURAL CONFLICT-RESOLUTION 0.126 ------ Stopped because no events left to process 0.126 -28 +27 NIL |# diff --git a/extras/blending/blending-test-2.lisp b/extras/blending/blending-test-2.lisp index de42627..90eec4d 100644 --- a/extras/blending/blending-test-2.lisp +++ b/extras/blending/blending-test-2.lisp @@ -104,7 +104,6 @@ ) #| Here's a trace of the run -CG-USER(542): (run 1) 0.000 PROCEDURAL CONFLICT-RESOLUTION 0.050 PROCEDURAL PRODUCTION-FIRED P1 0.050 PROCEDURAL CLEAR-BUFFER BLENDING @@ -186,7 +185,7 @@ Computing activation and latency for the blended chunk Activation for blended chunk is: 5.0881505 0.050 PROCEDURAL CONFLICT-RESOLUTION 0.056 BLENDING BLENDING-COMPLETE - 0.056 BLENDING SET-BUFFER-CHUNK BLENDING CHUNK0 + 0.056 BLENDING SET-BUFFER-CHUNK-FROM-SPEC BLENDING 0.056 PROCEDURAL CONFLICT-RESOLUTION 0.106 PROCEDURAL PRODUCTION-FIRED P2 BLENDED VALUE IS 2.189969 AND SIZE IS MEDIUM @@ -273,6 +272,6 @@ Not above threshold so blending failed 0.113 PROCEDURAL CONFLICT-RESOLUTION 0.113 ------ Stopped because no events left to process 0.113 -28 +27 NIL |# diff --git a/extras/blending/blending-test-3.lisp b/extras/blending/blending-test-3.lisp index e9554d1..a84efd7 100644 --- a/extras/blending/blending-test-3.lisp +++ b/extras/blending/blending-test-3.lisp @@ -123,7 +123,6 @@ ) #| Here's a trace of the run -CG-USER(140): (run 1) 0.000 PROCEDURAL CONFLICT-RESOLUTION 0.050 PROCEDURAL PRODUCTION-FIRED P1 0.050 PROCEDURAL CLEAR-BUFFER BLENDING @@ -171,7 +170,7 @@ Computing activation and latency for the blended chunk Activation for blended chunk is: 4.8876944 0.050 PROCEDURAL CONFLICT-RESOLUTION 0.058 BLENDING BLENDING-COMPLETE - 0.058 BLENDING SET-BUFFER-CHUNK BLENDING CHUNK0 + 0.058 BLENDING SET-BUFFER-CHUNK-FROM-SPEC BLENDING 0.058 PROCEDURAL CONFLICT-RESOLUTION 0.108 PROCEDURAL PRODUCTION-FIRED P2 BLENDED SIZE IS "tiny" @@ -208,6 +207,6 @@ Not above threshold so blending failed 0.126 PROCEDURAL CONFLICT-RESOLUTION 0.126 ------ Stopped because no events left to process 0.126 -28 +27 NIL |# diff --git a/extras/blending/blending-test-4.lisp b/extras/blending/blending-test-4.lisp index eb5354c..ddf30ef 100644 --- a/extras/blending/blending-test-4.lisp +++ b/extras/blending/blending-test-4.lisp @@ -137,7 +137,6 @@ ) #| Here's a trace of the run -CG-USER(544): (run 1) 0.000 PROCEDURAL CONFLICT-RESOLUTION 0.050 PROCEDURAL PRODUCTION-FIRED P1 0.050 PROCEDURAL CLEAR-BUFFER BLENDING @@ -176,7 +175,7 @@ Computing activation and latency for the blended chunk Activation for blended chunk is: 4.8876944 0.050 PROCEDURAL CONFLICT-RESOLUTION 0.058 BLENDING BLENDING-COMPLETE - 0.058 BLENDING SET-BUFFER-CHUNK BLENDING CHUNK0 + 0.058 BLENDING SET-BUFFER-CHUNK-FROM-SPEC BLENDING 0.058 PROCEDURAL CONFLICT-RESOLUTION 0.108 PROCEDURAL PRODUCTION-FIRED P2 BLENDED SIZE IS SMALL @@ -213,6 +212,6 @@ Not above threshold so blending failed 0.126 PROCEDURAL CONFLICT-RESOLUTION 0.126 ------ Stopped because no events left to process 0.126 -28 +27 NIL |# diff --git a/extras/blending/blending-test-5.lisp b/extras/blending/blending-test-5.lisp index 54bdb81..3185107 100644 --- a/extras/blending/blending-test-5.lisp +++ b/extras/blending/blending-test-5.lisp @@ -115,7 +115,6 @@ ) #| Here's a trace of the run -CG-USER(545): (run 1) 0.000 PROCEDURAL CONFLICT-RESOLUTION 0.050 PROCEDURAL PRODUCTION-FIRED P1 0.050 PROCEDURAL CLEAR-BUFFER BLENDING @@ -215,13 +214,13 @@ Computing activation and latency for the blended chunk Activation for blended chunk is: 4.3135276 0.050 PROCEDURAL CONFLICT-RESOLUTION 0.063 BLENDING BLENDING-COMPLETE - 0.063 BLENDING SET-BUFFER-CHUNK BLENDING CHUNK0 + 0.063 BLENDING SET-BUFFER-CHUNK-FROM-SPEC BLENDING 0.063 PROCEDURAL CONFLICT-RESOLUTION 0.113 PROCEDURAL PRODUCTION-FIRED P2 BLENDED VALUE IS 2.1176336 AND SIZE IS MEDIUM 0.113 PROCEDURAL CLEAR-BUFFER BLENDING 0.113 PROCEDURAL CLEAR-BUFFER GOAL - 0.113 GOAL SET-BUFFER-CHUNK GOAL CHUNK1 + 0.113 GOAL SET-BUFFER-CHUNK-FROM-SPEC GOAL 0.113 BLENDING START-BLENDING Blending request for chunks with slots (VALUE) Blending temperature is: 1.5 @@ -318,10 +317,10 @@ Computing activation and latency for the blended chunk Activation for blended chunk is: 5.029959 0.113 PROCEDURAL CONFLICT-RESOLUTION 0.120 BLENDING BLENDING-COMPLETE - 0.120 BLENDING SET-BUFFER-CHUNK BLENDING CHUNK2 + 0.120 BLENDING SET-BUFFER-CHUNK-FROM-SPEC BLENDING 0.120 PROCEDURAL CONFLICT-RESOLUTION 0.120 ------ Stopped because no events left to process 0.12 -37 +33 NIL |# diff --git a/extras/blending/blending-test-6.lisp b/extras/blending/blending-test-6.lisp index 36fce68..b91af4e 100644 --- a/extras/blending/blending-test-6.lisp +++ b/extras/blending/blending-test-6.lisp @@ -99,7 +99,6 @@ ) #| Here's a trace of the run -CG-USER(546): (run 1) 0.000 PROCEDURAL CONFLICT-RESOLUTION 0.050 PROCEDURAL PRODUCTION-FIRED P1 0.050 PROCEDURAL CLEAR-BUFFER BLENDING @@ -158,7 +157,7 @@ Computing activation and latency for the blended chunk Activation for blended chunk is: 4.8876944 0.050 PROCEDURAL CONFLICT-RESOLUTION 0.058 BLENDING BLENDING-COMPLETE - 0.058 BLENDING SET-BUFFER-CHUNK BLENDING CHUNK0 + 0.058 BLENDING SET-BUFFER-CHUNK-FROM-SPEC BLENDING 0.058 PROCEDURAL CONFLICT-RESOLUTION 0.108 PROCEDURAL PRODUCTION-FIRED P2 BLENDED SIZE IS SMALL @@ -191,6 +190,6 @@ Not above threshold so blending failed 0.126 PROCEDURAL CONFLICT-RESOLUTION 0.126 ------ Stopped because no events left to process 0.126 -28 +27 NIL |# diff --git a/extras/blending/blending-test-7.lisp b/extras/blending/blending-test-7.lisp index 720fd7a..858ceb8 100644 --- a/extras/blending/blending-test-7.lisp +++ b/extras/blending/blending-test-7.lisp @@ -99,7 +99,6 @@ ) #| Here's a trace of the run -CG-USER(547): (run 1) 0.000 PROCEDURAL CONFLICT-RESOLUTION 0.050 PROCEDURAL PRODUCTION-FIRED P1 0.050 PROCEDURAL CLEAR-BUFFER BLENDING @@ -119,41 +118,7 @@ Chunk E matches blending request Probability of recall 3.7122225e-6 -Slots to be blended: (SIZE VALUE KEY) -Finding blended value for slot: SIZE -Matched chunks' slots contain: (X-LARGE TINY SMALL) -Magnitude values for those items: (X-LARGE TINY SMALL) -When all magnitudes are chunks blending based on similarities to all related chunks -Intersection of slots for values is: (SIZE-TYPE) - Comparing value X-LARGE - Chunk B with probability 0.0018145373 slot value X-LARGE similarity: 0.0 cumulative result: 0.0 - Chunk C with probability 0.9981818 slot value TINY similarity: -0.9 cumulative result: 0.80852723 - Chunk E with probability 3.7122225e-6 slot value SMALL similarity: -0.6 cumulative result: 0.80852854 - Comparing value LARGE - Chunk B with probability 0.0018145373 slot value X-LARGE similarity: -0.1 cumulative result: 1.8145374e-5 - Chunk C with probability 0.9981818 slot value TINY similarity: -0.6 cumulative result: 0.35936362 - Chunk E with probability 3.7122225e-6 slot value SMALL similarity: -0.3 cumulative result: 0.35936394 - Comparing value MEDIUM - Chunk B with probability 0.0018145373 slot value X-LARGE similarity: -0.3 cumulative result: 1.6330836e-4 - Chunk C with probability 0.9981818 slot value TINY similarity: -0.3 cumulative result: 0.089999676 - Chunk E with probability 3.7122225e-6 slot value SMALL similarity: -0.1 cumulative result: 0.08999971 - Comparing value SMALL - Chunk B with probability 0.0018145373 slot value X-LARGE similarity: -0.6 cumulative result: 6.5323344e-4 - Chunk C with probability 0.9981818 slot value TINY similarity: -0.1 cumulative result: 0.010635052 - Chunk E with probability 3.7122225e-6 slot value SMALL similarity: 0.0 cumulative result: 0.010635052 - Comparing value TINY - Chunk B with probability 0.0018145373 slot value X-LARGE similarity: -0.9 cumulative result: 0.0014697751 - Chunk C with probability 0.9981818 slot value TINY similarity: 0.0 cumulative result: 0.0014697751 - Chunk E with probability 3.7122225e-6 slot value SMALL similarity: -0.1 cumulative result: 0.0014698122 - Final result: TINY -Finding blended value for slot: VALUE -Matched chunks' slots contain: (2 3 3) -Magnitude values for those items: (2 3 3) -With numeric magnitudes blending by weighted average - Chunk B with probability 0.0018145373 times magnitude 2.0 = 0.0036290747 cumulative result: 0.0036290747 - Chunk C with probability 0.9981818 times magnitude 3.0 = 2.9945455 cumulative result: 2.9981744 - Chunk E with probability 3.7122225e-6 times magnitude 3.0 = 1.1136667e-5 cumulative result: 2.9981856 - Final result: 2.9981856 +Slots to be blended: (KEY VALUE SIZE) Finding blended value for slot: KEY Matched chunks' slots contain: (KEY-1 KEY-1 KEY-2) Magnitude values for those items: (KEY-1 KEY-1 KEY-2) @@ -200,8 +165,42 @@ No intersecting slots found all chunks will be tested Chunk C with probability 0.9981818 slot value KEY-1 similarity: -1.0 cumulative result: 0.99999636 Chunk E with probability 3.7122225e-6 slot value KEY-2 similarity: -1.0 cumulative result: 1.0000001 Final result: D +Finding blended value for slot: VALUE +Matched chunks' slots contain: (2 3 3) +Magnitude values for those items: (2 3 3) +With numeric magnitudes blending by weighted average + Chunk B with probability 0.0018145373 times magnitude 2.0 = 0.0036290747 cumulative result: 0.0036290747 + Chunk C with probability 0.9981818 times magnitude 3.0 = 2.9945455 cumulative result: 2.9981744 + Chunk E with probability 3.7122225e-6 times magnitude 3.0 = 1.1136667e-5 cumulative result: 2.9981856 + Final result: 2.9981856 +Finding blended value for slot: SIZE +Matched chunks' slots contain: (X-LARGE TINY SMALL) +Magnitude values for those items: (X-LARGE TINY SMALL) +When all magnitudes are chunks blending based on similarities to all related chunks +Intersection of slots for values is: (SIZE-TYPE) + Comparing value X-LARGE + Chunk B with probability 0.0018145373 slot value X-LARGE similarity: 0.0 cumulative result: 0.0 + Chunk C with probability 0.9981818 slot value TINY similarity: -0.9 cumulative result: 0.80852723 + Chunk E with probability 3.7122225e-6 slot value SMALL similarity: -0.6 cumulative result: 0.80852854 + Comparing value LARGE + Chunk B with probability 0.0018145373 slot value X-LARGE similarity: -0.1 cumulative result: 1.8145374e-5 + Chunk C with probability 0.9981818 slot value TINY similarity: -0.6 cumulative result: 0.35936362 + Chunk E with probability 3.7122225e-6 slot value SMALL similarity: -0.3 cumulative result: 0.35936394 + Comparing value MEDIUM + Chunk B with probability 0.0018145373 slot value X-LARGE similarity: -0.3 cumulative result: 1.6330836e-4 + Chunk C with probability 0.9981818 slot value TINY similarity: -0.3 cumulative result: 0.089999676 + Chunk E with probability 3.7122225e-6 slot value SMALL similarity: -0.1 cumulative result: 0.08999971 + Comparing value SMALL + Chunk B with probability 0.0018145373 slot value X-LARGE similarity: -0.6 cumulative result: 6.5323344e-4 + Chunk C with probability 0.9981818 slot value TINY similarity: -0.1 cumulative result: 0.010635052 + Chunk E with probability 3.7122225e-6 slot value SMALL similarity: 0.0 cumulative result: 0.010635052 + Comparing value TINY + Chunk B with probability 0.0018145373 slot value X-LARGE similarity: -0.9 cumulative result: 0.0014697751 + Chunk C with probability 0.9981818 slot value TINY similarity: 0.0 cumulative result: 0.0014697751 + Chunk E with probability 3.7122225e-6 slot value SMALL similarity: -0.1 cumulative result: 0.0014698122 + Final result: TINY This is the definition of the blended chunk: -(SIZE TINY VALUE 2.9981856 KEY D) +(KEY D VALUE 2.9981856 SIZE TINY) Computing activation and latency for the blended chunk Activation of chunk B is 2.5325232 @@ -210,13 +209,13 @@ Computing activation and latency for the blended chunk Activation for blended chunk is: 4.8763266 0.050 PROCEDURAL CONFLICT-RESOLUTION 0.058 BLENDING BLENDING-COMPLETE - 0.058 BLENDING SET-BUFFER-CHUNK BLENDING CHUNK0 + 0.058 BLENDING SET-BUFFER-CHUNK-FROM-SPEC BLENDING 0.058 PROCEDURAL CONFLICT-RESOLUTION 0.108 PROCEDURAL PRODUCTION-FIRED P2 BLENDED VALUE IS 2.9981856 SIZE IS TINY AND KEY IS D 0.108 PROCEDURAL CONFLICT-RESOLUTION 0.108 ------ Stopped because no events left to process 0.108 -23 +22 NIL |# diff --git a/extras/blending/blending-test-8.lisp b/extras/blending/blending-test-8.lisp index 93b455e..d4551e5 100644 --- a/extras/blending/blending-test-8.lisp +++ b/extras/blending/blending-test-8.lisp @@ -109,7 +109,6 @@ ) #| Here's a trace of the run -CG-USER(548): (run 1) 0.000 PROCEDURAL CONFLICT-RESOLUTION 0.050 PROCEDURAL PRODUCTION-FIRED P1 0.050 PROCEDURAL CLEAR-BUFFER BLENDING @@ -165,7 +164,7 @@ Computing activation and latency for the blended chunk Activation for blended chunk is: 4.8876944 0.050 PROCEDURAL CONFLICT-RESOLUTION 0.058 BLENDING BLENDING-COMPLETE - 0.058 BLENDING SET-BUFFER-CHUNK BLENDING CHUNK0 + 0.058 BLENDING SET-BUFFER-CHUNK-FROM-SPEC BLENDING 0.058 PROCEDURAL CONFLICT-RESOLUTION 0.108 PROCEDURAL PRODUCTION-FIRED P2 BLENDED VALUE IS 2.82841 AND SIZE IS TINY @@ -219,6 +218,6 @@ Not above threshold so blending failed 0.126 PROCEDURAL CONFLICT-RESOLUTION 0.126 ------ Stopped because no events left to process 0.126 -28 +27 NIL |# diff --git a/extras/blending/blending.lisp b/extras/blending/blending.lisp index a7813f0..725abc5 100644 --- a/extras/blending/blending.lisp +++ b/extras/blending/blending.lisp @@ -13,7 +13,7 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Filename : blending.lisp -;;; Version : 4.3 +;;; Version : 4.5 ;;; ;;; Description : Base module code to handle blended retrieval requests. ;;; @@ -222,6 +222,9 @@ ;;; 2020.08.26 Dan ;;; : * Removed the path for require-compiled since it's not needed ;;; : and results in warnings in SBCL. +;;; 2021.06.09 Dan [4.5] +;;; : * Don't need create-new-buffer-chunk because the spec can +;;; : be sent directly. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; General Docs: @@ -253,8 +256,6 @@ ;;; Thus it is independent of the normal declarative module and it's possible to ;;; have both a retrieval request and a blending request active at the same time. ;;; -;;; Using create-new-buffer-chunk from the goal-style module codebase to handle -;;; the chunk creation/cleanup. ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -266,9 +267,6 @@ #+(and :clean-actr (not :packaged-actr) :ALLEGRO-IDE) (in-package :cg-user) #-(or (not :clean-actr) :packaged-actr :ALLEGRO-IDE) (in-package :cl-user) -;; To be safe since I'm using the goal-style code's create-buffer-chunk function - -(require-compiled "GOAL-STYLE-MODULE") (suppress-extension-warnings) (extend-chunks blended-activation :default-value nil) @@ -904,7 +902,7 @@ ;; using the goal-style module's function which handles ;; the scheduling and some extra cleanup. - (create-new-buffer-chunk 'blending chunk-list) + (schedule-set-buffer-chunk 'blending (define-chunk-spec-fct chunk-list) 0 :priority -1000 :module 'blending) (schedule-event-after-module 'blending 'call-blending-result-hooks :maintenance t :output nil :destination 'blending :module 'blending)) @@ -975,7 +973,7 @@ ;; Have to have version and a doc strings - :version "4.4" + :version "4.5" :documentation "Module which adds a new buffer to do blended retrievals" ;; functions to handle the interfacing for the module diff --git a/extras/chunk-tree-viewer/readme.txt b/extras/chunk-tree-viewer/readme.txt index ef1f20f..9121c3a 100644 --- a/extras/chunk-tree-viewer/readme.txt +++ b/extras/chunk-tree-viewer/readme.txt @@ -11,7 +11,7 @@ Conference on Cognitive Modeling. July 27-29, 2007, Ann Arbor, Michigan which is also included as HeibergHarrisBall.pdf. The tool is included with the Environment but disabled by default. To -enable the tool you must rename a file in the environment/GUI/dialogs +enable the tool you must rename a file in the environment/gui/dialogs directory of the ACT-R distribution (either the standalone or the source code version). The file named "35a-chunk-tree.tcx" must be renamed to "35a-chunk-tree.tcl" before starting the Environment. Doing so will diff --git a/extras/chunk-tree-viewer/tree-viewer.doc b/extras/chunk-tree-viewer/tree-viewer.doc new file mode 100644 index 0000000..ac57b0e Binary files /dev/null and b/extras/chunk-tree-viewer/tree-viewer.doc differ diff --git a/extras/chunk-tree-viewer/tree-viewer.pdf b/extras/chunk-tree-viewer/tree-viewer.pdf deleted file mode 100644 index 2539a05..0000000 Binary files a/extras/chunk-tree-viewer/tree-viewer.pdf and /dev/null differ diff --git a/extras/extended-motor-actions/motor-extension.lisp b/extras/extended-motor-actions/motor-extension.lisp index d81ada4..399115d 100644 --- a/extras/extended-motor-actions/motor-extension.lisp +++ b/extras/extended-motor-actions/motor-extension.lisp @@ -205,6 +205,8 @@ ;;; : so it displays in the low detail trace. Prior to the fix ;;; : for preparation free they were all just calling it and had ;;; : the event shown automatically in the low detail trace. +;;; 2021.01.08 Dan +;;; : * Didn't update the module version with the last change. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; General Docs: @@ -1493,7 +1495,7 @@ :query 'generic-state-query :creation 'create-motor-extension-module :reset (list nil nil 'reset-hand-tracker) - :version "6.0" + :version "6.1" :documentation "Extends motor module with dual processor and/or execution states and finger holding actions.") diff --git a/extras/tracker/tracker.doc b/extras/tracker/tracker.doc new file mode 100644 index 0000000..2b3663e Binary files /dev/null and b/extras/tracker/tracker.doc differ diff --git a/extras/tracker/tracker.lisp b/extras/tracker/tracker.lisp index 70fba9d..a090423 100644 --- a/extras/tracker/tracker.lisp +++ b/extras/tracker/tracker.lisp @@ -13,7 +13,7 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Filename : tracker.lisp -;;; Version : 5.3 +;;; Version : 6.0 ;;; ;;; Description : Module to create "trackers" which can learn a mapping of values ;;; : in monitored slots for "good" and/or "bad" events to an output @@ -182,6 +182,9 @@ ;;; : * Fixed yet another bug with the modification request -- it ;;; : was modifying the chunk currently in the buffer instead of ;;; : the underlying chunk since it's a copied multi-buffer. +;;; 2021.06.07 Dan [6.0] +;;; : * Also monitor for overwrite-buffer-chunk in addition to +;;; : set-buffer-chunk and mod-buffer-chunk actions. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; General Docs: @@ -1128,7 +1131,7 @@ :request 'request-tracker :delete 'delete-tracker :query 'tracker-query - :version "5.3" + :version "6.0" :documentation "Module which can learn an outcome value based on one or two events monitored in buffer slots.") (defun updated-tracker-value (module tracker buffer slot value scale which) @@ -1149,24 +1152,23 @@ (defun tracker-check-for-buffer-changes (event) - (cond ((eq (evt-action event) 'set-buffer-chunk) + (cond ((or (eq (evt-action event) 'set-buffer-chunk) (eq (evt-action event) 'overwrite-buffer-chunk)) (let ((module (get-module :tracker)) (changed-buffer (first (evt-params event)))) (bt:with-recursive-lock-held ((tracker-lock module)) (dolist (x (trackers module)) (when (tracker-active x) - (when (eq changed-buffer (tracker-good-buffer x)) + (when (or (eq changed-buffer (tracker-good-buffer x)) (eq changed-buffer (tracker-bad-buffer x))) (let* ((chunk (buffer-read changed-buffer)) - (slot (tracker-good-slot x)) (slots (and chunk (chunk-filled-slots-list-fct chunk)))) - (when (find slot slots) - (incf (tracker-good-value x) (updated-tracker-value module x changed-buffer slot (fast-chunk-slot-value-fct chunk slot) (tracker-good-scale x) 'good))))) - (when (eq changed-buffer (tracker-bad-buffer x)) - (let* ((chunk (buffer-read changed-buffer)) - (slot (tracker-bad-slot x)) - (slots (and chunk (chunk-filled-slots-list-fct chunk)))) - (when (find slot slots) - (incf (tracker-bad-value x) (updated-tracker-value module x changed-buffer slot (fast-chunk-slot-value-fct chunk slot) (tracker-bad-scale x) 'bad)))))))))) + (when (eq changed-buffer (tracker-good-buffer x)) + (let ((slot (tracker-good-slot x))) + (when (find slot slots) + (incf (tracker-good-value x) (updated-tracker-value module x changed-buffer slot (fast-chunk-slot-value-fct chunk slot) (tracker-good-scale x) 'good))))) + (when (eq changed-buffer (tracker-bad-buffer x)) + (let ((slot (tracker-bad-slot x))) + (when (find slot slots) + (incf (tracker-bad-value x) (updated-tracker-value module x changed-buffer slot (fast-chunk-slot-value-fct chunk slot) (tracker-bad-scale x) 'bad)))))))))))) ((eq (evt-action event) 'mod-buffer-chunk) (let* ((module (get-module :tracker)) (changed-buffer (first (evt-params event))) diff --git a/extras/tracker/tracker.pdf b/extras/tracker/tracker.pdf deleted file mode 100644 index 390da37..0000000 Binary files a/extras/tracker/tracker.pdf and /dev/null differ diff --git a/framework/buffers.lisp b/framework/buffers.lisp index 7391cc7..d8ab0f7 100644 --- a/framework/buffers.lisp +++ b/framework/buffers.lisp @@ -13,14 +13,14 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Filename : buffers.lisp -;;; Version : 6.0 +;;; Version : 7.0 ;;; ;;; Description : Functions that define the operation of buffers. ;;; ;;; Bugs : ;;; ;;; To do : [] Finish documentation. -;;; [] Investigate the copy sematics and probably optimize things. +;;; [7.0] 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. @@ -483,6 +483,31 @@ ;;; : for SBCL as was done previously). ;;; : * Removed an unnecessary case in a cond to avoid a warning ;;; : from SBCL. +;;; 2021.06.03 Dan [7.0] +;;; : * Use the reusable chunks associated with each buffer now to +;;; : avoid having to copy a chunk unless the buffer has had its +;;; : reuse? flag cleared. +;;; 2021.06.09 Dan +;;; : * The reusable chunk needs to be created the first time it's +;;; : needed since doing so at reset for all buffers ends up +;;; : costing more than it saves in short models e.g. fan without +;;; : PM that's run for one trial and reset repeatedly which would +;;; : save copying 2 (goal and retrieval) but the cost for filling +;;; : all at the start is creating 11 chunks. +;;; 2021.06.14 Dan +;;; : * Added buffer-slot-value to get the value of the chunk in a +;;; : buffer as a single action instead of having to do buffer- +;;; : read and then chunk-slot-value. +;;; 2021.06.25 Dan +;;; : * Allow set-buffer-chunk and overwrite-buffer-chunk to take a +;;; : list as well as a true chunk-spec and then create the spec +;;; : from the list. +;;; 2021.07.15 Dan +;;; : * Fixed the external overwrite-buffer-chunk command so that it +;;; : has requested default to nil like the internal function. +;;; 2021.09.10 Dan +;;; : * Buffer-slot-value-external needs to encode the result so that +;;; : strings are handled properly. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; General Docs: @@ -965,6 +990,24 @@ (add-act-r-command "buffer-read" 'buffer-read-external "Return the name of the chunk in a buffer. Params: buffer-name." nil) +(defun buffer-slot-value (buffer-name slot-name) + (verify-current-model + "buffer-slot-value called with no current model." + (let ((buffer (buffer-instance buffer-name))) + (if buffer + (bt:with-recursive-lock-held ((act-r-buffer-lock buffer)) + (awhen (act-r-buffer-chunk buffer) + (fast-chunk-slot-value-fct it slot-name))) + (print-warning "Buffer-slot-value called with an invalid buffer name ~S" buffer-name))))) + +(defun buffer-slot-value-external (buffer-name slot-name) + (encode-string (buffer-slot-value (string->name buffer-name) (string->name slot-name)))) + +(add-act-r-command "buffer-slot-value" 'buffer-slot-value-external "Return the value of a slot for the chunk in a buffer. Params: buffer-name slot-name." nil) + + + + (defun schedule-buffer-read (buffer-name time-delta &key (module :none) (priority 0) (output t) time-in-ms) (verify-current-model "schedule-buffer-read called with no current model." @@ -1242,15 +1285,18 @@ (add-act-r-command "set-buffer-failure" 'set-buffer-failure-external "Set the failure flag for a buffer. Params: buffer-name {< ignore-if-full , requested >}") -(defun set-buffer-chunk (buffer-name chunk-name &optional (requested t)) - "Forces a copy unless it's a multi-buffer and this chunk is in the set" +(defun set-buffer-chunk (buffer-name chunk-name-or-spec &optional (requested t)) (verify-current-model "set-buffer-chunk called with no current model." - (let ((buffer (buffer-instance buffer-name))) + (let ((buffer (buffer-instance buffer-name)) + (chunk-or-spec (or (get-chunk chunk-name-or-spec) + (and (act-r-chunk-spec-p chunk-name-or-spec) chunk-name-or-spec) + (id-to-chunk-spec chunk-name-or-spec) + (and (listp chunk-name-or-spec) (define-chunk-spec-fct chunk-name-or-spec))))) (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)) + ((null chunk-or-spec) + (print-warning "set-buffer-chunk called with an invalid chunk name or chunk-spec ~S" chunk-name-or-spec)) (t (bt:with-recursive-lock-held ((act-r-buffer-lock buffer)) (when (act-r-buffer-chunk buffer) @@ -1258,13 +1304,48 @@ (setf (act-r-buffer-requested buffer) requested) - (let ((copy-name (if (or (act-r-buffer-copy buffer) (chunk-buffer-set-invalid chunk-name) (null (gethash chunk-name (act-r-buffer-chunk-set buffer)))) - (copy-chunk-fct chunk-name) - chunk-name))) - (when (and (show-copy-buffer-trace) (not (eq copy-name chunk-name))) + + (let ((new-name (if (act-r-chunk-spec-p chunk-or-spec) + (cond ((act-r-buffer-reuse? buffer) + + (unless (act-r-buffer-reuse-chunk buffer) + (let ((name (new-name-fct (format nil "~s-chunk" (act-r-buffer-name buffer))))) + (define-chunks-fct (list name)) + (make-chunk-reusable name) + (setf (act-r-buffer-reuse-chunk buffer) name))) + + (aif (copy-chunk-spec-to-chunk-fct chunk-or-spec (act-r-buffer-reuse-chunk buffer)) + it + (progn + (print-warning "set-buffer-chunk could not convert given chunk-spec to a chunk") + (return-from set-buffer-chunk nil)))) + (t + (aif (chunk-spec-to-chunk-def chunk-or-spec) + (car (define-chunks-fct (list it))) + (progn + (print-warning "set-buffer-chunk failed to convert chunk-spec to a chunk") + (return-from set-buffer-chunk nil))))) + + (cond ((act-r-buffer-reuse? buffer) + (unless (act-r-buffer-reuse-chunk buffer) + (let ((name (new-name-fct (format nil "~s-chunk" (act-r-buffer-name buffer))))) + (define-chunks-fct (list name)) + (make-chunk-reusable name) + (setf (act-r-buffer-reuse-chunk buffer) name))) + (copy-chunk-to-chunk-fct chunk-name-or-spec (act-r-buffer-reuse-chunk buffer))) + ((or (act-r-buffer-copy buffer) + (chunk-buffer-set-invalid chunk-name-or-spec) + (null (gethash chunk-name-or-spec (act-r-buffer-chunk-set buffer)))) + (copy-chunk-fct chunk-name-or-spec)) + (t + chunk-name-or-spec))))) + + (when (and (show-copy-buffer-trace) + (not (act-r-chunk-spec-p chunk-or-spec)) + (not (eq new-name chunk-name-or-spec))) (schedule-event-now nil :maintenance t :module 'buffer :priority :max - :details (concatenate 'string "Buffer " (string buffer-name) " copied chunk " (string chunk-name) " to " (string copy-name)) + :details (concatenate 'string "Buffer " (string buffer-name) " copied chunk " (string chunk-name-or-spec) " to " (string new-name)) :output 'medium)) ;; setting the buffer clears the failure flag @@ -1274,22 +1355,25 @@ (bt:with-lock-held ((act-r-model-buffers-lock m)) (setf (act-r-model-buffer-state m) (logior (act-r-model-buffer-state m) (act-r-buffer-mask buffer))))) - (setf (act-r-buffer-chunk buffer) copy-name)))))))) + (setf (act-r-buffer-chunk buffer) new-name)))))))) -(defun set-buffer-chunk-external (buffer-name chunk-name &optional (requested t)) - (set-buffer-chunk (string->name buffer-name) (string->name chunk-name) requested)) +(defun set-buffer-chunk-external (buffer-name chunk-name-or-spec &optional (requested t)) + (set-buffer-chunk (string->name buffer-name) (if (listp chunk-name-or-spec) (decode-string-names chunk-name-or-spec) (string->name chunk-name-or-spec)) requested)) -(add-act-r-command "set-buffer-chunk" 'set-buffer-chunk-external "Copy a chunk directly into a buffer. Params: buffer-name chunk-name {requested?}") +(add-act-r-command "set-buffer-chunk" 'set-buffer-chunk-external "Copy a chunk into a buffer or create a chunk given a chunk-spec. Params: buffer-name chunk-name-or-spec {requested?}") -(defun schedule-set-buffer-chunk (buffer-name chunk-name time-delta &key (module :none) (priority 0) (output 'low) (requested t) time-in-ms) +(defun schedule-set-buffer-chunk (buffer-name chunk-name-or-spec time-delta &key (module :none) (priority 0) (output 'low) (requested t) time-in-ms) (verify-current-model "schedule-set-buffer-chunk called with no current model." (let ((buffer (buffer-instance buffer-name))) (cond ((null buffer) (print-warning "schedule-set-buffer-chunk called with an invalid buffer name ~S" buffer-name)) - ((null (get-chunk chunk-name)) - (print-warning "schedule-set-buffer-chunk called with an invalid chunk name ~S" chunk-name)) + ((null (or (get-chunk chunk-name-or-spec) + (act-r-chunk-spec-p chunk-name-or-spec) + (id-to-chunk-spec chunk-name-or-spec) + (listp chunk-name-or-spec))) + (print-warning "schedule-set-buffer-chunk called with an invalid chunk name or chunk-spec ~S" chunk-name-or-spec)) ((not (numberp time-delta)) (print-warning "schedule-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))) @@ -1299,44 +1383,93 @@ :time-in-ms time-in-ms :module module :priority priority - :params (if requested - (list buffer-name chunk-name) - (list buffer-name chunk-name nil)) - :output output)))))) + :params (list buffer-name chunk-name-or-spec requested) + :details (if (symbolp chunk-name-or-spec) ;; it's a chunk name + (if requested + (concatenate 'string (string 'set-buffer-chunk) " " + (string buffer-name) " " + (string chunk-name-or-spec)) + (concatenate 'string (string 'set-buffer-chunk) " " + (string buffer-name) " " + (string chunk-name-or-spec) " NIL")) + (if requested + (concatenate 'string (string 'set-buffer-chunk-from-spec) " " + (string buffer-name) " " + ) + (concatenate 'string (string 'set-buffer-chunk-from-spec) " " + (string buffer-name) " NIL"))) + + :output output)))))) (defun external-schedule-set-buffer-chunk (buffer-name chunk-name time-delta &optional params) (multiple-value-bind (valid ol) (process-options-list params 'schedule-set-buffer-chunk '(:module :priority :output :requested :time-in-ms)) (when valid - (apply 'schedule-set-buffer-chunk (string->name buffer-name) (string->name chunk-name) time-delta (convert-options-list-items ol '(:module :priority :output) nil))))) + (apply 'schedule-set-buffer-chunk (string->name buffer-name) (if (listp chunk-name) (decode-string-names chunk-name) (string->name chunk-name)) time-delta (convert-options-list-items ol '(:module :priority :output) nil))))) (add-act-r-command "schedule-set-buffer-chunk" 'external-schedule-set-buffer-chunk - "Create an event to occur at the specified amount of time from now to place a chunk in a buffer. Params: buffer-name chunk-name time-delay { < module, priority, output, time-in-ms, requested > }." + "Create an event to occur at the specified amount of time from now to place a chunk in a buffer. Params: buffer-name chunk-name-or-spec time-delay { < module, priority, output, time-in-ms, requested > }." nil) -(defun overwrite-buffer-chunk (buffer-name chunk-name &optional (requested nil)) - "Also forces a copy of the chunk unless it's in the set of a multi-buffer" +(defun overwrite-buffer-chunk (buffer-name chunk-name-or-spec &optional (requested nil)) (verify-current-model "overwrite-buffer-chunk called with no current model." - (let ((buffer (buffer-instance buffer-name))) + (let ((buffer (buffer-instance buffer-name)) + (chunk-or-spec (or (get-chunk chunk-name-or-spec) + (and (act-r-chunk-spec-p chunk-name-or-spec) chunk-name-or-spec) + (id-to-chunk-spec chunk-name-or-spec) + (and (listp chunk-name-or-spec) (define-chunk-spec-fct chunk-name-or-spec))))) (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)) + ((null chunk-or-spec) + (print-warning "overwrite-buffer-chunk called with an invalid chunk name or chunk-spec ~S" chunk-name-or-spec)) (t (bt:with-recursive-lock-held ((act-r-buffer-lock buffer)) (setf (act-r-buffer-requested buffer) requested) - (let ((copy-name (if (or (act-r-buffer-copy buffer) (chunk-buffer-set-invalid chunk-name) (null (gethash chunk-name (act-r-buffer-chunk-set buffer)))) - (copy-chunk-fct chunk-name) - chunk-name))) - (when (and (show-copy-buffer-trace) (not (eq copy-name chunk-name))) + + (let ((copy-name (if (act-r-chunk-spec-p chunk-or-spec) + (cond ((act-r-buffer-reuse? buffer) + (unless (act-r-buffer-reuse-chunk buffer) + (let ((name (new-name-fct (format nil "~s-chunk" (act-r-buffer-name buffer))))) + (define-chunks-fct (list name)) + (make-chunk-reusable name) + (setf (act-r-buffer-reuse-chunk buffer) name))) + (aif (copy-chunk-spec-to-chunk-fct chunk-or-spec (act-r-buffer-reuse-chunk buffer)) + it + (progn + (print-warning "overwrite-buffer-chunk could not convert given chunk-spec to a chunk") + (return-from overwrite-buffer-chunk nil)))) + (t + (aif (chunk-spec-to-chunk-def chunk-or-spec) + (car (define-chunks-fct (list it))) + (progn + (print-warning "overwrite-buffer-chunk failed to convert chunk-spec to a chunk") + (return-from overwrite-buffer-chunk nil))))) + + (cond ((act-r-buffer-reuse? buffer) + (unless (act-r-buffer-reuse-chunk buffer) + (let ((name (new-name-fct (format nil "~s-chunk" (act-r-buffer-name buffer))))) + (define-chunks-fct (list name)) + (make-chunk-reusable name) + (setf (act-r-buffer-reuse-chunk buffer) name))) + (copy-chunk-to-chunk-fct chunk-name-or-spec (act-r-buffer-reuse-chunk buffer))) + ((or (act-r-buffer-copy buffer) + (chunk-buffer-set-invalid chunk-name-or-spec) + (null (gethash chunk-name-or-spec (act-r-buffer-chunk-set buffer)))) + (copy-chunk-fct chunk-name-or-spec)) + (t + chunk-name-or-spec))))) + + (when (and (show-copy-buffer-trace) + (not (act-r-chunk-spec-p chunk-or-spec)) + (not (eq copy-name chunk-name-or-spec))) (schedule-event-now nil :maintenance t :module 'buffer :priority :max - :details (concatenate 'string "Buffer " (string buffer-name) " copied chunk " (string chunk-name) " to " (string copy-name)) + :details (concatenate 'string "Buffer " (string buffer-name) " copied chunk " (string chunk-name-or-spec) " to " (string copy-name)) :output 'medium)) (let ((m (current-model-struct))) @@ -1347,33 +1480,48 @@ -(defun overwrite-buffer-chunk-external (buffer-name chunk-name &optional (requested t)) - (overwrite-buffer-chunk (string->name buffer-name) (string->name chunk-name) requested)) +(defun overwrite-buffer-chunk-external (buffer-name chunk-name &optional (requested nil)) + (overwrite-buffer-chunk (string->name buffer-name) (if (listp chunk-name) (decode-string-names chunk-name) (string->name chunk-name)) requested)) -(add-act-r-command "overwrite-buffer-chunk" 'overwrite-buffer-chunk-external "Put a chunk in a buffer without clearing the buffer first. Params: buffer-name chunk-name {requested}") +(add-act-r-command "overwrite-buffer-chunk" 'overwrite-buffer-chunk-external "Put a chunk in a buffer without clearing the buffer first. Params: buffer-name chunk-name-or-spec {requested}") -(defun schedule-overwrite-buffer-chunk (buffer-name chunk-name time-delta &key (module :none) (priority 0) (output 'low) (requested nil) time-in-ms) +(defun schedule-overwrite-buffer-chunk (buffer-name chunk-name-or-spec time-delta &key (module :none) (priority 0) (output 'low) (requested nil) time-in-ms) (verify-current-model "overwrite-buffer-chunk called with no current model." (let ((buffer (buffer-instance buffer-name))) (cond ((null buffer) (print-warning "schedule-overwrite-buffer-chunk called with an invalid buffer name ~S" buffer-name)) - ((null (get-chunk chunk-name)) - (print-warning "schedule-overwrite-buffer-chunk called with an invalid chunk name ~S" chunk-name)) + ((null (or (get-chunk chunk-name-or-spec) + (act-r-chunk-spec-p chunk-name-or-spec) + (id-to-chunk-spec chunk-name-or-spec) + (listp chunk-name-or-spec))) + (print-warning "schedule-overwrite-buffer-chunk called with an invalid chunk name or spec ~S" chunk-name-or-spec)) ((not (numberp time-delta)) (print-warning "schedule-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 "schedule-overwrite-buffer-chunk called with an invalid priority ~S" priority)) (t - (schedule-event-relative time-delta 'overwrite-buffer-chunk + (schedule-event-relative time-delta 'overwrite-buffer-chunk :time-in-ms time-in-ms :module module :priority priority - :params (list buffer-name chunk-name requested) - :details (when requested - (format nil "~s ~s ~s" 'overwrite-buffer-chunk buffer-name chunk-name)) + :params (list buffer-name chunk-name-or-spec requested) + :details (if (symbolp chunk-name-or-spec) ;; it's a chunk name + (if requested + (concatenate 'string (string 'overwrite-buffer-chunk) " " + (string buffer-name) " " + (string chunk-name-or-spec)) + (concatenate 'string (string 'overwrite-buffer-chunk) " " + (string buffer-name) " " + (string chunk-name-or-spec) " NIL")) + (if requested + (concatenate 'string (string 'overwrite-buffer-chunk-from-spec) " " + (string buffer-name) " " + ) + (concatenate 'string (string 'overwrite-buffer-chunk-from-spec) " " + (string buffer-name) " NIL"))) :output output)))))) @@ -1382,7 +1530,7 @@ (multiple-value-bind (valid ol) (process-options-list params 'schedule-overwrite-buffer-chunk '(:module :priority :output :requested :time-in-ms)) (when valid - (apply 'schedule-overwrite-buffer-chunk (string->name buffer-name) (string->name chunk-name) time-delta (convert-options-list-items ol '(:module :priority :output) nil))))) + (apply 'schedule-overwrite-buffer-chunk (string->name buffer-name) (if (listp chunk-name) (decode-string-names chunk-name) (string->name chunk-name)) time-delta (convert-options-list-items ol '(:module :priority :output) nil))))) (add-act-r-command "schedule-overwrite-buffer-chunk" 'external-schedule-overwrite-buffer-chunk "Create an event to occur at the specified amount of time from now to place a chunk in a buffer without clearing the buffer first. Params: buffer-name chunk-name time-delay { < module, priority, output, time-in-ms, requested > }." @@ -1731,6 +1879,20 @@ (let ((b (buffers))) (every (lambda (y) (find y b)) x))))) +;;; Turn off the no-copy mechanism for a buffer. +;;; Should be done during reset (called during the model definition +;;; is also fine). + +(defun buffer-requires-copies (buffer-name) + (let ((buffer (buffer-instance buffer-name))) + (if (null buffer) + (print-warning "buffer-requires-copies called with an invalid buffer name ~S" buffer-name) + + (bt:with-recursive-lock-held ((act-r-buffer-lock buffer)) + (setf (act-r-buffer-reuse? buffer) nil) + t)))) + + #| This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public diff --git a/framework/chunk-spec.lisp b/framework/chunk-spec.lisp index 94280bc..3cd8155 100644 --- a/framework/chunk-spec.lisp +++ b/framework/chunk-spec.lisp @@ -318,6 +318,8 @@ ;;; 2020.08.25 Dan ;;; : * Fixed a bug with chunk-spec-slots when it was given an id ;;; : instead of an actual chunk-spec. +;;; 2021.07.15 Dan +;;; : * Fixed a typo in a warning in verify-single-explicit-value. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; General Docs: @@ -864,7 +866,7 @@ (var (if (and (stringp var-char) (> (length var-char) 0)) (char var-char 0) var-char))) (if (and value (characterp var) (symbolp value) (char-equal var (char (symbol-name value) 0))) - (values nil (print-warning "~a slot must be explict - not a variable in a ~a command to the ~s module." slot cmd module)) + (values nil (print-warning "~a slot must be explicit - not a variable in a ~a command to the ~s module." slot cmd module)) (values value t)))))) (aif (id-to-chunk-spec chunk-spec) (verify-single-explicit-value it slot module cmd var-char) diff --git a/framework/chunks.lisp b/framework/chunks.lisp index 0ec9dfd..9c5029a 100644 --- a/framework/chunks.lisp +++ b/framework/chunks.lisp @@ -13,7 +13,7 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Filename : chunks.lisp -;;; Version : 5.0 +;;; Version : 6.0 ;;; ;;; Description : Definition of chunks and the function that manipulate them. ;;; @@ -577,6 +577,16 @@ ;;; : instead of the undefined value. (Can happen if there isn't ;;; : a copy function because it only sets the default when needed ;;; : if there isn't one.) +;;; 2021.06.03 Dan [6.0] +;;; : * Add the option of a "reusable" chunk -- something that is +;;; : safe for a buffer to use repeatedly. They will still be +;;; : safe to merge as c2 (it will update the params of c1 but not +;;; : link it to c2), but must be copied if needed to store. +;;; : The make-chunk-reusable command sets it to be such a chunk. +;;; : * There's a new command that should be checked by something +;;; : that wants to "store" a chunk that was cleared from a buffer +;;; : or was specified in a request slot: chunk-not-storable. If +;;; : that is true then a copy should be made and stored instead. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; General Docs: @@ -612,7 +622,8 @@ (declaim (ftype (function () t) update-chunks-on-the-fly)) (declaim (ftype (function (t) t) release-name-fct)) (declaim (ftype (function () t) notify-on-the-fly-hooks)) - +(declaim (ftype (function (t) t) id-to-chunk-spec)) +(declaim (ftype (function (t) t) chunk-spec-to-chunk-def)) (defvar *chunk-parameters-count* 0) @@ -909,6 +920,152 @@ (add-act-r-command "copy-chunk" 'external-copy-chunk-fct "Returns the name of a chunk which is a copy of the chunk name provided. Params: chunk-name." nil) + +(defun copy-chunk-to-chunk-fct (from-chunk to-chunk) + "Copy the from-chunk into the reusable chunk to-chunk" + (let ((f-chunk (get-chunk-warn from-chunk)) + (t-chunk (get-chunk-warn to-chunk))) + (when (and f-chunk t-chunk) + (bt:with-recursive-lock-held ((act-r-chunk-lock f-chunk)) + (bt:with-recursive-lock-held ((act-r-chunk-lock t-chunk)) + + (when (act-r-chunk-not-storable t-chunk) ;; it's reusable + + (let (param-count undefined copy-list) + (bt:with-lock-held (*chunk-parameters-lock*) + (setf param-count *chunk-parameters-count*) + (setf copy-list *chunk-parameters-copy-list*) + (setf undefined *chunk-parameter-undefined*)) + + ;; clear the back links from current values of t-chunk + + (when (update-chunks-on-the-fly) + (bt:with-recursive-lock-held ((act-r-model-chunk-lock (current-model-struct))) + (dolist (current (act-r-chunk-slot-value-lists t-chunk)) + (let ((old (cdr current))) + (when (chunk-p-fct old) + (let* ((bl (chunk-back-links old)) + (new-links (remove (act-r-slot-name (car current)) (gethash to-chunk bl)))) + (if new-links + (setf (gethash to-chunk bl) new-links) + (remhash to-chunk bl)))))))) + + + ;; copy the values from the other chunk + + (setf (act-r-chunk-base-name t-chunk) (act-r-chunk-base-name f-chunk)) + (setf (act-r-chunk-filled-slots t-chunk) (act-r-chunk-filled-slots f-chunk)) + (setf (act-r-chunk-slot-value-lists t-chunk) (copy-tree (act-r-chunk-slot-value-lists f-chunk))) + (setf (act-r-chunk-parameter-values t-chunk) + (make-array param-count :initial-element undefined)) + + ;; Create the back links as needed + + (when (update-chunks-on-the-fly) + (bt:with-recursive-lock-held ((act-r-model-chunk-lock (current-model-struct))) + (dolist (slot (act-r-chunk-slot-value-lists t-chunk)) + (let ((slot-name (act-r-slot-name (car slot))) + (old (cdr slot))) + (when (chunk-p-fct old) + + (let ((bl (chunk-back-links old))) + (if (hash-table-p bl) + (push slot-name (gethash to-chunk bl)) + (let ((ht (make-hash-table))) + (setf (gethash to-chunk ht) (list slot-name)) + (setf (chunk-back-links old) ht))))))))) + + ;; update its parameters for only those that need it + + (dolist (param copy-list) + (if (act-r-chunk-parameter-copy param) + (let ((current (aref (act-r-chunk-parameter-values f-chunk) (act-r-chunk-parameter-index param)))) + (setf (aref (act-r-chunk-parameter-values t-chunk) (act-r-chunk-parameter-index param)) + (dispatch-apply (act-r-chunk-parameter-copy param) + (if (eq current undefined) + (chunk-parameter-default param t-chunk) + current)))) + (setf (aref (act-r-chunk-parameter-values t-chunk) (act-r-chunk-parameter-index param)) + (dispatch-apply (act-r-chunk-parameter-copy-from-chunk param) from-chunk))))) + + ;; note the original + + (setf (act-r-chunk-copied-from t-chunk) from-chunk) + + to-chunk)))))) + +(defun external-copy-chunk-to-chunk-fct (from-chunk to-chunk) + (copy-chunk-to-chunk-fct (string->name from-chunk) (string->name to-chunk))) + +(add-act-r-command "copy-chunk-to-chunk-fct" 'external-copy-chunk-to-chunk-fct "Copy the from-chunk into the reusable chunk to-chunk and returns to-chunk if successful. Params: from-chunk to-chunk." nil) + + + +(defun buffer-chunk-spec-to-chunk-list (chunk-spec) + "Convert a chunk-spec to a list of slot-value conses" + (if (act-r-chunk-spec-p chunk-spec) + (unless (or (not (zerop (act-r-chunk-spec-request-param-slots chunk-spec))) ; don't allow request params + (act-r-chunk-spec-slot-vars chunk-spec) + (act-r-chunk-spec-variables chunk-spec) + (not (zerop (act-r-chunk-spec-duplicate-slots chunk-spec))) + (not (zerop (act-r-chunk-spec-negated-slots chunk-spec))) + (not (zerop (act-r-chunk-spec-relative-slots chunk-spec)))) + (values t + (mapcar (lambda (x) + (unless (keywordp (act-r-slot-spec-name x)) + (cons (act-r-slot-spec-name x) (act-r-slot-spec-value x)))) + (act-r-chunk-spec-slots chunk-spec)))) + + (awhen (id-to-chunk-spec chunk-spec) + (chunk-spec-to-chunk-def it)))) + +(defun copy-chunk-spec-to-chunk-fct (chunk-spec to-chunk) + "Copy the info from the chunk-spec into the reusable chunk to-chunk" + (multiple-value-bind (valid slots) (buffer-chunk-spec-to-chunk-list chunk-spec) + (when valid + (let ((t-chunk (get-chunk-warn to-chunk))) + (when t-chunk + (bt:with-recursive-lock-held ((act-r-chunk-lock t-chunk)) + + (when (act-r-chunk-not-storable t-chunk) ;; it's reusable + + (let (param-count undefined) + (bt:with-lock-held (*chunk-parameters-lock*) + (setf param-count *chunk-parameters-count*) + + (setf undefined *chunk-parameter-undefined*)) + + ;; clear the back links from current values of t-chunk + + (when (update-chunks-on-the-fly) + (bt:with-recursive-lock-held ((act-r-model-chunk-lock (current-model-struct))) + (dolist (current (act-r-chunk-slot-value-lists t-chunk)) + (let ((old (cdr current))) + (when (chunk-p-fct old) + (let* ((bl (chunk-back-links old)) + (new-links (remove (act-r-slot-name (car current)) (gethash to-chunk bl)))) + (if new-links + (setf (gethash to-chunk bl) new-links) + (remhash to-chunk bl)))))))) + + ;; set initial-values in the copy + + (setf (act-r-chunk-base-name t-chunk) nil) + (setf (act-r-chunk-filled-slots t-chunk) 0) + (setf (act-r-chunk-slot-value-lists t-chunk) nil) + (setf (act-r-chunk-parameter-values t-chunk) + (make-array param-count :initial-element undefined)) + + ;; don't need to call copy parameters since there's no chunk to + ;; actually copy from... + + (dolist (s slots) + (awhen (valid-slot-name (car s)) ;; should be valid since was in a spec + (set-c-slot-value t-chunk it (car s) (cdr s)))) ;; handles all the details + + to-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)) @@ -1209,7 +1366,35 @@ (add-act-r-command "make-chunk-immutable" 'external-make-chunk-immutable "Prevent any changes to a chunk's contents. Params: chunk-name") +(defun make-chunk-reusable (chunk-name) + (let ((c (get-chunk chunk-name))) + (when c + (bt:with-recursive-lock-held ((act-r-chunk-lock c)) + (if (and (null (act-r-chunk-not-storable c)) + (= (length (act-r-chunk-merged-chunks c)) 1) + (eq chunk-name (car (act-r-chunk-merged-chunks c)))) + (progn + (setf (act-r-chunk-merged-chunks c) nil) + (setf (act-r-chunk-not-storable c) t) + t) + nil))))) + +(defun external-make-chunk-reusable (chunk) + (make-chunk-reusable (string->name chunk))) + +(add-act-r-command "make-chunk-reusable" 'external-make-chunk-reusable "Mark a chunk so that it can be used with copy-to-chunk and not be deletable. Params: chunk-name") + +(defun chunk-not-storable (chunk-name) + (let ((c (get-chunk chunk-name))) + (when c + (bt:with-recursive-lock-held ((act-r-chunk-lock c)) + (act-r-chunk-not-storable c))))) +(defun external-chunk-not-storable (chunk) + (chunk-not-storable (string->name chunk))) + +(add-act-r-command "chunk-not-storable" 'external-chunk-not-storable "Check if a chunk has been marked as not storable (a reusable chunk). Params: chunk-name") + (defun set-chk-slot-value (c slot-name value) ;; only call when the lock is held "internal chunk slot setting function" @@ -1388,45 +1573,48 @@ (bt:with-recursive-lock-held ((act-r-chunk-lock c)) (if (act-r-chunk-immutable c) (print-warning "Cannot delete chunk ~s because it is marked as immutable." chunk-name) - (let ((tn (act-r-chunk-name c)) - (model (current-model-struct))) - (bt:with-recursive-lock-held ((act-r-model-chunk-lock model)) - - ;; If this chunk has back-links from others to it then warn because - ;; that's likely a problem - (when (update-chunks-on-the-fly) - (let ((bl (chunk-back-links chunk-name))) - (when (and (hash-table-p bl) (not (zerop (hash-table-count bl)))) - (model-warning "Chunk ~s is being deleted but it is still used as a slot value in other chunks." chunk-name)) - - (when (not (eq tn chunk-name)) - (let ((t-bl (chunk-back-links tn))) - (when (and (hash-table-p t-bl) (not (zerop (hash-table-count t-bl)))) - (model-warning "Chunk ~s is being deleted but its true name ~s is still used as a slot value in other chunks." chunk-name tn))))) - - ;; Delete all of the back-links to this chunk + (if (act-r-chunk-not-storable c) + (print-warning "Cannot delete chunk ~s because it is marked as reusable." chunk-name) + + (let ((tn (act-r-chunk-name c)) + (model (current-model-struct))) + (bt:with-recursive-lock-held ((act-r-model-chunk-lock model)) - (dolist (slots (act-r-chunk-slot-value-lists c)) - (let ((slot-name (act-r-slot-name (car slots))) - (old (cdr slots))) - (when (chunk-p-fct old) - (let* ((bl (chunk-back-links old)) - (new-links (remove slot-name (gethash tn bl)))) - (if new-links - (setf (gethash tn bl) new-links) - (remhash tn bl))))))) - - ;; Take all the related chunks out of the main hash-table - - (dolist (x (act-r-chunk-merged-chunks c)) - (remhash x (act-r-model-chunks-table model)) + ;; If this chunk has back-links from others to it then warn because + ;; that's likely a problem + (when (update-chunks-on-the-fly) + (let ((bl (chunk-back-links chunk-name))) + (when (and (hash-table-p bl) (not (zerop (hash-table-count bl)))) + (model-warning "Chunk ~s is being deleted but it is still used as a slot value in other chunks." chunk-name)) + + (when (not (eq tn chunk-name)) + (let ((t-bl (chunk-back-links tn))) + (when (and (hash-table-p t-bl) (not (zerop (hash-table-count t-bl)))) + (model-warning "Chunk ~s is being deleted but its true name ~s is still used as a slot value in other chunks." chunk-name tn))))) + + ;; Delete all of the back-links to this chunk + + (dolist (slots (act-r-chunk-slot-value-lists c)) + (let ((slot-name (act-r-slot-name (car slots))) + (old (cdr slots))) + (when (chunk-p-fct old) + (let* ((bl (chunk-back-links old)) + (new-links (remove slot-name (gethash tn bl)))) + (if new-links + (setf (gethash tn bl) new-links) + (remhash tn bl))))))) - ;; Take them out of the meta-data table too + ;; Take all the related chunks out of the main hash-table - (when (update-chunks-on-the-fly) - (remhash x (act-r-model-chunk-ref-table model))))) - - chunk-name)))))) + (dolist (x (act-r-chunk-merged-chunks c)) + (remhash x (act-r-model-chunks-table model)) + + ;; Take them out of the meta-data table too + + (when (update-chunks-on-the-fly) + (remhash x (act-r-model-chunk-ref-table model))))) + + chunk-name))))))) (defmacro purge-chunk (chunk-name) "delete a chunk and release its name" diff --git a/framework/dispatcher.lisp b/framework/dispatcher.lisp index 414357c..c943e49 100644 --- a/framework/dispatcher.lisp +++ b/framework/dispatcher.lisp @@ -553,6 +553,19 @@ ;;; : to a string with an IPv4 address to bypass getting one from ;;; : usocket (could be set before loading since it's defined with ;;; : defvar here). +;;; 2021.02.18 Dan +;;; : * When it falls back to local-host after failing to start with +;;; : the real address it needs to also restart with the initial +;;; : port number. +;;; 2021.05.07 Dan +;;; : * Use concatenate instead of format in the redefinition of the +;;; : encode-json method for handling keywords since it's usually +;;; : a lot faster. +;;; : * Also hide the redefinition warning about it by just sending +;;; : *standard-output* and *error-output* to a string-stream. +;;; 2021.05.11 Dan +;;; : * Changed reference to GUI directory to gui to avoid issues +;;; : with logical pathnames (particularlly in SBCL). ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; General Docs: @@ -807,7 +820,13 @@ (format nil "'~a'" s) s)) +(defvar *hide-warnings-stream* (make-string-output-stream)) +(defvar *original-output* *standard-output*) +(defvar *original-error* *error-output*) +(setf *standard-output* *hide-warnings-stream* + *error-output* *hide-warnings-stream*) + ;; Need to make sure keyword symbols keep the colon on the front ;; so can't just use the symbol-name of a symbol. @@ -819,12 +838,15 @@ (let ((mapped (car (rassoc s json::+json-lisp-symbol-tokens+)))) (if mapped (progn (write-string mapped stream) nil) - (let ((s (funcall json::*lisp-identifier-name-to-json* (if (keywordp s) (format nil "~s" s) (symbol-name s))))) + (let ((s (funcall json::*lisp-identifier-name-to-json* (if (keywordp s) (concatenate 'string ":" (symbol-name s)) (symbol-name s))))) (json::write-json-string s stream))))) (setf json:*lisp-identifier-name-to-json* 'identity) +(setf *standard-output* *original-output* + *error-output* *original-error*) + ;;; These handle the underlying processing. ;;; They're called either from Lisp functions or the ;;; code that's processing the incoming data. @@ -1164,7 +1186,8 @@ #-:single-threaded-act-r (defun start-des (&optional (create t) (given-host *default-host*) (remote-port 2650)) (bt:start-multiprocessing) - (let* ((host (if given-host + (let* ((starting-port remote-port) + (host (if given-host (progn (setf *server-host* (ignore-errors (map 'vector 'parse-integer (usocket::split-sequence #\. given-host)))) given-host) @@ -1207,7 +1230,7 @@ (setf host (progn (setf first-try nil) - + (setf remote-port starting-port) (let ((local-host-ip (ignore-errors (find-if (lambda (x) (and (= (length x) 4) (not (every 'zerop x)))) (usocket::get-hosts-by-name "localhost"))))) (setf *allow-external-connections* t) @@ -1255,14 +1278,14 @@ (error (x) (send-error-output "Error ~/print-error-message/ occurred while trying to write the port number to ~s~%" x (translate-logical-pathname "~/act-r-port-num.txt")))) - (handler-case (with-open-file (f (translate-logical-pathname "ACT-R:environment;GUI;init;05-current-net.tcl") :direction :output :if-exists :supersede :if-does-not-exist :create) + (handler-case (with-open-file (f (translate-logical-pathname "ACT-R:environment;gui;init;05-current-net.tcl") :direction :output :if-exists :supersede :if-does-not-exist :create) (multiple-value-bind (second minute hour date month year) (get-decoded-time) (format f "# Port settings for ACT-R server started at ~2,'0d:~2,'0d:~2,'0d ~d/~2,'0d/~d~%set actr_port ~d~%set actr_address \"~a\"~%" hour minute second month date year remote-port host))) (error (x) - (send-error-output "Error ~/print-error-message/ occurred while trying to write the Environment network config file ~s~%" x (translate-logical-pathname "ACT-R:environment;GUI;init;05-current-net.tcl")))) + (send-error-output "Error ~/print-error-message/ occurred while trying to write the Environment network config file ~s~%" x (translate-logical-pathname "ACT-R:environment;gui;init;05-current-net.tcl")))) t) diff --git a/framework/events.lisp b/framework/events.lisp index 7531351..10d4964 100644 --- a/framework/events.lisp +++ b/framework/events.lisp @@ -84,6 +84,9 @@ ;;; : * Switch from defconstant to the define-constant macro to ;;; : avoid issues with SBCL (instead of redefining defconstant ;;; : for SBCL as was done previously). +;;; 2021.07.06 Dan +;;; : * Changed the external evt-params to encode strings in the +;;; : list since that may be important. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; General Docs: @@ -223,6 +226,12 @@ t) (values nil nil))) +(defun external-evt-params (event) + (aif (get-event-by-id event) + (values (encode-string-names (act-r-event-params it)) + t) + (values nil nil))) + (add-act-r-command "evt-time" 'evt-time "Return the time of an event in seconds. Params: event-id") (add-act-r-command "evt-mstime" 'evt-mstime "Return the time of an event in milliseconds. Params: event-id") (add-act-r-command "evt-priority" 'evt-priority "Return the priority of an event. Params: event-id") @@ -230,7 +239,7 @@ (add-act-r-command "evt-model" 'evt-model "Return the model of an event. Params: event-id") (add-act-r-command "evt-module" 'evt-module "Return the module of an event. Params: event-id") (add-act-r-command "evt-destination" 'evt-destination "Return the destination of an event. Params: event-id") -(add-act-r-command "evt-params" 'evt-params "Return the parameters of an event. Params: event-id") +(add-act-r-command "evt-params" 'external-evt-params "Return the parameters of an event. Params: event-id") (add-act-r-command "evt-details" 'evt-details "Return the details of an event. Params: event-id") (add-act-r-command "evt-output" 'evt-output "Return the output setting of an event. Params: event-id") diff --git a/framework/internal-structures.lisp b/framework/internal-structures.lisp index ef4408c..820fa6b 100644 --- a/framework/internal-structures.lisp +++ b/framework/internal-structures.lisp @@ -13,7 +13,7 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Filename : internal-structures.lisp -;;; Version : 4.0 +;;; Version : 5.0 ;;; ;;; Description : All of the defstructs for the internal code. ;;; @@ -460,6 +460,11 @@ ;;; : * Added slots to the act-r-output struct to indicate ;;; : whether the :v and :cmdt are using the same stream to fix ;;; : a problem when they're set to the same file. +;;; 2021.06.03 Dan [5.0] +;;; : * Buffer struct has a slot to store the name of the reusable +;;; : chunk that it will use, and a flag to indicate if it should +;;; : use it. +;;; : * Chunk struct has a slot to indicate not storable. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; General Docs: @@ -515,7 +520,9 @@ (lock (bt:make-recursive-lock "buffer-lock")) index mask - module-instance) + module-instance + reuse-chunk + reuse?) (defstruct act-r-chunk-spec "The internal structure of a chunk-spec" @@ -570,6 +577,7 @@ merged-chunks parameter-values immutable + not-storable (lock (bt:make-recursive-lock))) (defstruct act-r-chunk-parameter diff --git a/framework/model.lisp b/framework/model.lisp index bd54012..0d2d6e6 100644 --- a/framework/model.lisp +++ b/framework/model.lisp @@ -13,7 +13,7 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Filename : model.lisp -;;; Version : 4.0 +;;; Version : 4.1 ;;; ;;; Description : Functions that support the abstraction of a model ;;; @@ -234,6 +234,17 @@ ;;; : reset (much faster than redefining every time). ;;; : * Any chunk defined at creation time is automatically marked ;;; : as immutable. +;;; 2021.06.03 Dan [4.1] +;;; : * Set the reuse? flag for the buffers at init and reset and +;;; : create the initial chunk for the buffer. +;;; 2021.06.09 Dan +;;; : * Don't actually create the initial chunk for the buffers +;;; : because that's a big performance hit for tasks that run a +;;; : non-learning short trial & reset approach (fan model in the +;;; : tutorial for example). +;;; 2021.07.16 Dan +;;; : * Only set the reuse? flag if it's not a multi buffer. +;;; : * Delete-model wasn't returning t on success. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; General Docs: @@ -474,6 +485,10 @@ (dolist (x (act-r-buffer-queries buffer)) (add-buffer-query x)) + (unless (act-r-buffer-multi buffer) + (setf (act-r-buffer-reuse? buffer) t)) + (setf (act-r-buffer-reuse-chunk buffer) nil) + (setf (gethash buffer-name (act-r-model-buffers new-model)) buffer))) *buffers-table*)))) @@ -481,6 +496,21 @@ (dolist (m (act-r-model-module-instances new-model)) (reset-module m)) + #|;; Just set all the reusable slots to nil above instead of setting + them here (here because naming module needs to be reset) since + it's an added cost to do this for a buffer that doesn't get a chunk in the + model + + (bt:with-lock-held ((act-r-model-buffers-lock new-model)) + + (maphash (lambda (buffer-name buffer-struct) + (let ((name (new-name-fct (format nil "~s-buffer-chunk" buffer-name)))) + (define-chunks-fct (list name)) + (make-chunk-reusable name) + (setf (act-r-buffer-reuse-chunk buffer-struct) name))) + + (act-r-model-buffers new-model))) + |# (maphash (lambda (parameter-name parameter) (sgp-fct (list parameter-name (act-r-parameter-default parameter)))) @@ -648,6 +678,10 @@ (dolist (x (act-r-buffer-queries buffer)) (add-buffer-query x)) + (unless (act-r-buffer-multi buffer) + (setf (act-r-buffer-reuse? buffer) t)) + (setf (act-r-buffer-reuse-chunk buffer) nil) + (setf (gethash buffer-name (act-r-model-buffers new-model)) buffer))) *buffers-table*)))) @@ -655,6 +689,19 @@ (dolist (m (act-r-model-module-instances new-model)) (reset-module m)) + #| ;; Create the reusable chunks for the buffers (needs to happen after naming module reset) + + (bt:with-lock-held ((act-r-model-buffers-lock new-model)) + + (maphash (lambda (buffer-name buffer-struct) + (let ((name (new-name-fct (format nil "~s-buffer-chunk" buffer-name)))) + (define-chunks-fct (list name)) + (make-chunk-reusable name) + (setf (act-r-buffer-reuse-chunk buffer-struct) name))) + + (act-r-model-buffers new-model))) + |# + (maphash (lambda (parameter-name parameter) (sgp-fct (list parameter-name (act-r-parameter-default parameter)))) (bt:with-lock-held (*parameters-table-lock*) *act-r-parameters-table*)) @@ -711,25 +758,26 @@ (let ((mp (current-mp))) (if model-name (aif (cdr (assoc model-name (bt:with-lock-held ((meta-p-models-lock mp)) (meta-p-models mp)))) - (bt:with-lock-held (*define-model-lock*) - (unwind-protect - (let ((*current-act-r-model* it)) - (setf *defining-model* t) - - (delete-all-model-events mp model-name) - - (dolist (c (bt:with-lock-held ((meta-p-component-lock (current-mp))) (meta-p-component-list (current-mp)))) - (when (act-r-component-model-destroy (cdr c)) - (funcall (act-r-component-model-destroy (cdr c)) (act-r-component-instance (cdr c)) model-name))) - - (unwind-protect - (dolist (module-name (all-module-names)) - (delete-module module-name)) + (progn + (bt:with-lock-held (*define-model-lock*) + (unwind-protect + (let ((*current-act-r-model* it)) + (setf *defining-model* t) - (remove-model model-name))) - - t) - (setf *defining-model* nil)) + (delete-all-model-events mp model-name) + + (dolist (c (bt:with-lock-held ((meta-p-component-lock (current-mp))) (meta-p-component-list (current-mp)))) + (when (act-r-component-model-destroy (cdr c)) + (funcall (act-r-component-model-destroy (cdr c)) (act-r-component-instance (cdr c)) model-name))) + + (unwind-protect + (dolist (module-name (all-module-names)) + (delete-module module-name)) + + (remove-model model-name))) + t) + (setf *defining-model* nil)) + t) (print-warning "No model named ~S in current meta-process." model-name)) (print-warning "No current model to delete."))))) @@ -877,6 +925,11 @@ (add-buffer-query x)) ;; clear any flags (setf (act-r-buffer-flags buffer) nil) + + (unless (act-r-buffer-multi buffer) + (setf (act-r-buffer-reuse? buffer) t)) + ;; Clear any previous name (will be created as needed) + (setf (act-r-buffer-reuse-chunk buffer) nil) )) (act-r-model-buffers model))) @@ -885,6 +938,19 @@ (dolist (module-name (act-r-model-module-instances model)) (reset-module module-name)) + #| ;; Create the reusable chunks for the buffers (needs to happen after naming module reset) + + (bt:with-lock-held ((act-r-model-buffers-lock model)) + + (maphash (lambda (buffer-name buffer-struct) + (let ((name (new-name-fct (format nil "~s-buffer-chunk" buffer-name)))) + (define-chunks-fct (list name)) + (make-chunk-reusable name) + (setf (act-r-buffer-reuse-chunk buffer-struct) name))) + + (act-r-model-buffers model))) + |# + (maphash (lambda (parameter-name parameter) (sgp-fct (list parameter-name (act-r-parameter-default parameter)))) (bt:with-lock-held (*parameters-table-lock*) *act-r-parameters-table*)) diff --git a/framework/version-string.lisp b/framework/version-string.lisp index 711a7a1..05dd2f0 100644 --- a/framework/version-string.lisp +++ b/framework/version-string.lisp @@ -80,10 +80,10 @@ #-(or (not :clean-actr) :packaged-actr :ALLEGRO-IDE) (in-package :cl-user) (defvar *actr-architecture-version* "7") -(defvar *actr-major-version-string* "21") -(defvar *actr-minor-version-string* "6") -(defvar *actr-repository-number* "3099") -(defvar *actr-release-tag* "2020-12-21") +(defvar *actr-major-version-string* "27") +(defvar *actr-minor-version-string* nil) +(defvar *actr-repository-number* "3193") +(defvar *actr-release-tag* "2021-09-15") (defvar *actr-version-string* (format nil "~a.~a~@[.~a~]-<~@[~a:~]~a>" *actr-architecture-version* diff --git a/modules/production-compilation.lisp b/modules/production-compilation.lisp index 41d4b21..fd7af7b 100644 --- a/modules/production-compilation.lisp +++ b/modules/production-compilation.lisp @@ -13,7 +13,7 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Filename : production-compilation.lisp -;;; Version : 4.6 +;;; Version : 5.0 ;;; ;;; Description : Implements the production compilation mechnaism in ACT-R 6. ;;; @@ -27,7 +27,7 @@ ;;; : in the composition function, and then remove the clean-up ;;; : hack at the end. Not entirely sure, but definitely worth ;;; : investigating at some point. -;;; : [ ] Consider whether dynamic slots which are used between +;;; : [X v5.0] Consider whether dynamic slots which are used between ;;; : two productions (the pre-instantiate case) could remain ;;; : dynamic by only instantiating for the mapping. Probably ;;; : leaves a lot of loose ends, but there are some notes in @@ -558,6 +558,23 @@ ;;; 2020.12.01 Dan [4.6] ;;; : * More testing suggests :rir is stable, and with some minor ;;; : cleanup of the code it's being made available now. +;;; 2021.01.11 Dan +;;; : * Fixed an issue with variabilized slots in actions which are +;;; : set with explicitly bound variables not properly creating +;;; : the new production. +;;; 2021.02.08 Dan +;;; : * Fix a bug where removal of duplicate LHS safe-binds didn't +;;; : remap the variables in RHS safe-eval and output commands +;;; : that were added from p2. +;;; 2021.02.10 Dan [5.0] +;;; : * Remove the pre-instantiation step and put that on the buffer +;;; : mechanisms to handle in the mapping and composing fns when +;;; : needed because it was preventing some desired generality and +;;; : didn't actually work "right" in some cases. +;;; 2021.02.19 Dan +;;; : * When composing the buffer= and buffer+ actions need to +;;; : exclude dynamic p1 slots whose instantiation is overridden +;;; : with something in p2 (which may also have been dynamic). ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; General Docs: @@ -679,9 +696,12 @@ ;;; that buffer in the new production. Cell D1 holds the name of a function to call for ;;; performing any extra compatibility test necessary after composability ;;; has been determined for the productions, or the value nil if there is -;;; no additional test necessary for this type. Cell A2 is a list of the buffers -;;; which will be set to this type, or the value :default if this should be the -;;; default type for any unspecified buffers. +;;; no additional test necessary for this type. Cell E1 is no longer used. +;;; Cell F1 is t or nil to indicate whether a request-harvest pair of the buffer +;;; should be dropped out. Cell G1 holds the name of a function to call to provide +;;; some details when this type blocked the composition of two productions. Cell A2 +;;; is a list of the buffers which will be set to this type, or the value :default if +;;; this should be the default type for any unspecified buffers. ;;; ;;; The table in rows 5-45 specifies the conditions under which the ;;; usage of this buffer type in the two productions can be composed. @@ -1072,7 +1092,7 @@ (define-parameter :tt :default-value 2.0 :valid-test 'posnum :warning "a positive number" :documentation "Threshold time")) - :version "4.6" + :version "5.0" :documentation "A module that assists the primary procedural module with compiling productions" :creation 'create-composition-module :reset (list 'reset-production-compilation 'reset-production-compilation2) @@ -1473,6 +1493,15 @@ (defun compose-rep-slots (s) (second s)) + + +(defun instantiate-slot-names (rep bindings) + (mapcar (lambda (x) + (if (chunk-spec-variable-p (spec-slot-name x)) + (list (spec-slot-op x) (cdr (assoc (spec-slot-name x) bindings)) (spec-slot-value x)) + x)) + rep)) + (defun compose-productions (module p1 p1-s p2 p2-s) @@ -1503,68 +1532,9 @@ (setf (production-drop-out-buffers-map p2-name) nil))) - ;; To allow for proper mapping of variables and values between - ;; p1 and p2 it may be necessary to instantiate slot name variables - ;; in dynamic productions. - ;; - ;; This should only be necessary if a buffer allows for modifications on - ;; the RHS of p1 which could be carried over to the conditions of p2 for now, but - ;; there may be other conditions that are discovered in the future. - ;; - ;; The compilation type needs to indicate if that is possible and may also - ;; specify a constraint on when to allow it to happen (which presumably is - ;; just for efficency because conditional application of this for other - ;; reasons could lead to unusual results in the newly composed production). - ;; - (dolist (b p1-indices) - (let* ((comp-type (get-compilation-type-struct (car b) module)) - (instantiate (comp-buffer-type-pre-instantiate comp-type))) - - (when instantiate - - (let* ((c2 (find-if (lambda (x) (and (char= (compose-rep-op x) #\=) (eq (car b) (compose-rep-name x)))) (first p2-s))) - (a1= (find-if (lambda (x) (and (char= (compose-rep-op x) #\=) (eq (car b) (compose-rep-name x)))) (second p1-s))) - - (a1+ (find-if (lambda (x) (and (char= (compose-rep-op x) #\+) (eq (car b) (compose-rep-name x)))) (second p1-s))) - (a1* (find-if (lambda (x) (and (char= (compose-rep-op x) #\*) (eq (car b) (compose-rep-name x)))) (second p1-s))) - - ;; if there's a + action that overrides the = and * actions - (mod-vars (if a1+ - (mapcan (lambda (x) - (when (chunk-spec-variable-p (spec-slot-name x)) - (list (spec-slot-name x)))) - (compose-rep-slots a1+)) - (append (mapcan (lambda (x) - (when (chunk-spec-variable-p (spec-slot-name x)) - (list (spec-slot-name x)))) - (compose-rep-slots a1=)) - (mapcan (lambda (x) - (when (chunk-spec-variable-p (spec-slot-name x)) - (list (spec-slot-name x)))) - (compose-rep-slots a1*))))) - (cond-vars (mapcan (lambda (x) - (when (chunk-spec-variable-p (spec-slot-name x)) - (list (spec-slot-name x)))) - (compose-rep-slots c2)))) - - (cond ((and mod-vars cond-vars) - (let* ((p1-instantiations (previous-production-bindings (compilation-module-previous module))) - (s1 (remove-if-not (lambda (x) (find x mod-vars)) p1-instantiations :key 'car)) - (s2 (remove-if-not (lambda (x) (find x cond-vars)) (production-compilation-instan p2-name) :key 'car))) - - (setf p1-s (replace-variables-special p1-s s1)) - (let ((cv (remove-if-not (lambda (x) (find x s1 :key 'cdr)) s2 :key 'cdr))) - (setf p2-s (replace-variables-special p2-s cv))))) - - ((and mod-vars (compose-rep-slots c2)) ;; variables in the modification and any slots tested in c2 - (let* ((p1-instantiations (previous-production-bindings (compilation-module-previous module))) - (s1 (remove-if-not (lambda (x) (find x mod-vars)) p1-instantiations :key 'car))) - - (setf p1-s (replace-variables-special p1-s s1)))) - (cond-vars - (let ((s2 (remove-if-not (lambda (x) (find x cond-vars)) (production-compilation-instan p2-name) :key 'car))) - (setf p2-s (replace-variables-special p2-s s2))))))))) + ;;; The pre-instantiate step was here ... + (let* ((mappings nil) @@ -1581,7 +1551,7 @@ (when map-fn (setf mappings (append (funcall map-fn buffer module p1 p1-s (aif (cdr (assoc buffer p1-indices)) it 0) p2 p2-s (aif (cdr (assoc buffer p2-indices)) it 0)) mappings))))) - + ;;; Current mechanism for !safe-bind! on the RHS of P1 is to ;;; add its binding as a constant value and drop the bind. ;;; also add the bindings for all variables used in the bind's evaluation. @@ -1628,10 +1598,10 @@ (setf mapping it))) ;; this doesn't replace constants which is a good thing... - + (setf p1-s (replace-variables-special p1-s (list mapping))) (setf p2-s (replace-variables-special p2-s (list mapping))) - + (dolist (x mappings) (when (eq (car x) (car mapping)) (replace mappings (list (cons (cdr mapping) (cdr x))) :start1 (position x mappings :test 'equal)))))))) @@ -1676,13 +1646,14 @@ ;;; another variable replace pass... (let ((duplicate-bindings nil) - (existing-bindings nil)) + (existing-bindings nil) + expr) (dolist (x (first p2-s)) (when (find (compose-rep-name x) '(safe-bind)) (push x existing-bindings) (push x (first p3-s)))) - + (dolist (x (first p1-s)) (when (find (compose-rep-name x) '(safe-bind)) (aif (find (second (compose-rep-slots x)) existing-bindings :test 'equalp :key (lambda (y) (second (compose-rep-slots y)))) @@ -1690,21 +1661,31 @@ (push x (first p3-s))))) (when duplicate-bindings - (setf p3-s (replace-variables-special p3-s duplicate-bindings)))) + (setf p3-s (replace-variables-special p3-s duplicate-bindings))) + ;; These need to respect the duplicate bindings so put them in the loop + ;; where that's computed and replace them when needed - (dolist (x (first p1-s)) - (when (find (compose-rep-name x) '(safe-eval)) - (unless (find x (first p3-s) :test 'equal) ;; no need for duplicate evals - (push x (first p3-s))))) - - ;;; Here's where we remove the rhs binds from p1 - - (dolist (x (second p1-s)) - (when (find (compose-rep-name x) '(#|safe-bind|# safe-eval output #|stop|#)) ;; p1 can't have a stop... - (unless (find x (second p3-s) :test 'equal) - (push x (second p3-s))))) - + (dolist (x (first p1-s)) + (when (find (compose-rep-name x) '(safe-eval)) + (if duplicate-bindings + (setf expr (replace-variables-for-eval x duplicate-bindings)) + (setf expr x)) + (unless (find expr (first p3-s) :test 'equal) ;; no need for duplicate evals + (push expr (first p3-s))))) + + ;; Here's where we remove the rhs binds from p1 (by only adding the evals and outputs + ;; note only duplicate evals are removed not duplicate output because maybe that + ;; output is important and it's only going to show in the trace anyway + + (dolist (x (second p1-s)) + (when (find (compose-rep-name x) '(safe-eval output)) + (if duplicate-bindings + (setf expr (replace-variables-for-eval x duplicate-bindings)) + (setf expr x)) + (unless (and (eq (compose-rep-name x) 'safe-eval) + (find expr (second p3-s) :test 'equal)) + (push expr (second p3-s)))))) ;; Double check that everything gets bound ;; The assumption being that it had to come from the second @@ -1880,19 +1861,25 @@ (defun replace-variables-special (arg bindings) - (let ((res (list nil nil))) - (dolist (x (first arg)) - (push-last (if (char= (compose-rep-op x) #\!) - (replace-variables-for-eval x bindings) - (replace-variables x bindings)) - (first res))) - (dolist (x (second arg)) - (push-last (if (or (eq (compose-rep-name x) 'safe-eval) - (eq (compose-rep-name x) 'safe-bind)) - (replace-variables-for-eval x bindings) - (replace-variables x bindings)) - (second res))) - res)) + (list + (mapcar (lambda (x) + (list (car x) + (cond ((eq (compose-rep-name x) 'safe-eval) + (replace-variables-for-eval (second x) bindings)) + ((eq (compose-rep-name x) 'safe-bind) + (cons (car (second x)) (replace-variables-for-eval (cdr (second x)) bindings))) + (t + (replace-variables (second x) bindings))))) + (first arg)) + (mapcar (lambda (x) + (list (car x) + (cond ((eq (compose-rep-name x) 'safe-eval) + (replace-variables-for-eval (second x) bindings)) + ((eq (compose-rep-name x) 'safe-bind) + (cons (car (second x)) (replace-variables-for-eval (cdr (second x)) bindings))) + (t + (replace-variables (second x) bindings))))) + (second arg)))) @@ -2285,27 +2272,41 @@ compose-rep)) -(defun buffer+-union (a1 a2) +(defun buffer+-union (a1 a2 bindings) (let* ((a2-slots (mapcar 'spec-slot-name (compose-rep-slots a2))) + (a2-no-dynamic (mapcar (lambda (x) (if (chunk-spec-variable-p x) + (cdr (assoc x bindings)) + x)) + a2-slots)) + (a1-remain (remove-if (lambda (x) (and (eq (spec-slot-op x) '=) - (find (spec-slot-name x) a2-slots))) + + (or + (find (spec-slot-name x) a2-slots) ;; matches could be static or dynamic + (find (spec-slot-name x) a2-no-dynamic) + (and (chunk-spec-variable-p (spec-slot-name x)) + ;; the instantiated slot value matches something in the instantiated p2 slots + (find (cdr (assoc (spec-slot-name x) bindings)) a2-no-dynamic))))) (compose-rep-slots a1)))) - (list (first a1) (append a1-remain (compose-rep-slots a2))))) + (list (first a1) (append a1-remain (compose-rep-slots a2))))) ;; should this remove-duplicates ? -(defun buffer=-union (a1 a2) ;; same as above now since + and = are represented the same - (buffer+-union a1 a2)) +(defun buffer=-union (a1 a2 bindings) ;; same as above now since + and = are represented the same + (buffer+-union a1 a2 bindings)) -(defun buffer-condition-union (c1 c2 a1) ;; c1 + (c2-a1) +(defun buffer-condition-union (c1 c2 a1 bindings) ;; c1 + (c2-a1) (when (or c1 c2) (if (null c2) c1 - (let* ((a1-slots (mapcar 'spec-slot-name (compose-rep-slots a1))) + (let* ((a1-slots (replace-variables (mapcar 'spec-slot-name (compose-rep-slots a1)) bindings)) + (c2-remain (remove-if (lambda (x) - (find (spec-slot-name x) a1-slots)) + (aif (cdr (assoc (spec-slot-name x) bindings)) ;; if it's a variable use the binding + (find it a1-slots) + (find (spec-slot-name x) a1-slots))) (compose-rep-slots c2)))) (if (null c1) (list (first c2) c2-remain) @@ -2475,13 +2476,13 @@ ;; Write out the stubs for the functions specified (when map - (format outfile "(defun ~a (module p1 p1-s p2 p2-s buffer)~%)~%" map)) + (format outfile "(defun ~a (buffer module p1 p1-s p1-index p2 p2-s p2-index)~%)~%" map)) (when compose - (format outfile "(defun ~a (p1 p1-s p2 p2-s buffer)~%)~%" compose)) + (format outfile "(defun ~a (buffer module p1 p1-s p1-index p2 p2-s p2-index)~%)~%" compose)) (when consistency - (format outfile "(defun ~a (buffer module p1 p2)~%)~%" consistency)) + (format outfile "(defun ~a (buffer module p1 p1-s p1-index p2 p2-s p2-index)~%)~%" consistency)) (when pre-instan - (format outfile "(defun ~a (buffer-and-index p2)~%)~%" pre-instan)) + (format outfile "(defun ~a (buffer module p1 p1-s p1-index p2 p2-s p2-index)~%)~%" pre-instan)) (when whynot (format outfile "(defun ~a (p1-index p2-index failed-function)~%)~%" whynot)) @@ -2490,7 +2491,7 @@ (let (done) (dolist (x table) (when (and (third x) (not (eq (third x) t)) (not (find (third x) done))) - (format outfile "(defun ~a (buffer p1 p2)~%)~%" (third x)) + (format outfile "(defun ~a (buffer module p1 p1-s p1-index p2 p2-s p2-index)~%)~%" (third x)) (push (third x) done)))) ;; Write the buffer definition itself diff --git a/modules/temporal.lisp b/modules/temporal.lisp index e45cd4f..fd0ece7 100644 --- a/modules/temporal.lisp +++ b/modules/temporal.lisp @@ -13,7 +13,7 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Filename : temporal.lisp -;;; Version : 3.1 +;;; Version : 4.0 ;;; ;;; Description : Implementation of the temporal module. ;;; @@ -102,6 +102,12 @@ ;;; 2020.07.06 Dan [3.1] ;;; : * Got rid of the temporal-clear dummy function and just ;;; : schedule nil since the details are all that matters. +;;; 2021.03.10 Dan [3.2] +;;; : * Also put temporal on the do-not-query list. +;;; 2021.06.07 Dan [4.0] +;;; : * Instead of using create-new-buffer-chunk just schedule +;;; : set-buffer-chunk with a spec, and create that spec at reset +;;; : so it doesn't have to happen every time. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; General Docs: @@ -137,7 +143,8 @@ tick ticks next-increment - record-ticks) + record-ticks + spec) (defun create-temporal-module (model-name) (declare (ignore model-name)) @@ -152,10 +159,11 @@ (setf (temporal-module-next-increment instance) nil)) (defun temporal-reset-2 (instance) - (declare (ignore instance)) + + (setf (temporal-module-spec instance) (define-chunk-spec isa time)) ;; Do NOT strict harvest the temporal buffer by default - (sgp :do-not-harvest temporal) + (sgp :do-not-harvest temporal :do-not-query temporal) ) @@ -198,9 +206,8 @@ (if (not (verify-single-explicit-value chunk-spec 'ticks 'temporal 'time)) (print-warning "Invalid time request made to the temporal module.") (progn - (schedule-event-now 'create-new-buffer-chunk :module 'temporal - :priority -100 :params (list 'temporal '(isa time)) - :details "create-new-buffer-chunk isa time") + (schedule-set-buffer-chunk 'temporal (temporal-module-spec instance) 0 + :module 'temporal :priority -1000) (setf (temporal-module-tick instance) (max 1 (+ (temporal-module-time-start-increment instance) @@ -280,7 +287,7 @@ (define-parameter :record-ticks :valid-test 'tornil :default-value t :warning "t or nil" :documentation "Record each time increment as a buffer event") ) - :version "3.1" + :version "4.0" :documentation "The temporal module is used to estimate short time intervals" :creation 'create-temporal-module :query 'temporal-query diff --git a/modules/utility-and-reward-1.lisp b/modules/utility-and-reward-1.lisp index 2d16ce8..be70734 100644 --- a/modules/utility-and-reward-1.lisp +++ b/modules/utility-and-reward-1.lisp @@ -181,6 +181,9 @@ ;;; 2020.08.26 Dan ;;; : * Removed the path for require-compiled since it's not needed ;;; : and results in warnings in SBCL. +;;; 2021.07.09 Dan +;;; : * Fixed a bug with spp setting :at because it was returning +;;; : the time in ms instead of seconds. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; General: ;;; @@ -744,9 +747,12 @@ (:at (setf value (safe-seconds->ms value 'spp)) - (set-parameter production-at :at - (nonneg value) - "a positive number")) + (let ((res (set-parameter production-at :at + (nonneg value) + "a positive number"))) + (if (numberp res) + (ms->seconds res) + res))) (:reward ;; can't use set-parameter because I need to test ;; the original value before setting it but the diff --git a/other-files/buffer-history.lisp b/other-files/buffer-history.lisp index 3a7ef16..03eb69e 100644 --- a/other-files/buffer-history.lisp +++ b/other-files/buffer-history.lisp @@ -81,6 +81,9 @@ ;;; : * Need to protect access to time using meta-p-schedule-lock. ;;; 2020.01.13 Dan [2.1] ;;; : * Removed the lambda from the module interface. +;;; 2021.06.07 Dan +;;; : * Deal with set-buffer-chunk and overwrite-... possibly having +;;; : a chunk-spec as the second parameter. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; General Docs: @@ -154,7 +157,12 @@ (when (save-history module) (case (act-r-event-action event) (set-buffer-chunk - (push-last (list (first (act-r-event-params event)) "set-buffer-chunk" (printed-chunk (second (act-r-event-params event))) (printed-buffer-status (first (act-r-event-params event)))) + (push-last (list (first (act-r-event-params event)) + "set-buffer-chunk" + (if (symbolp (second (act-r-event-params event))) + (printed-chunk (second (act-r-event-params event))) + (printed-chunk-spec (second (act-r-event-params event)))) + (printed-buffer-status (first (act-r-event-params event)))) (current-data module))) (clear-buffer (push-last (list (first (act-r-event-params event)) "clear-buffer" "" (printed-buffer-status (first (act-r-event-params event)))) @@ -163,7 +171,12 @@ (push-last (list (first (act-r-event-params event)) "mod-buffer-chunk" (printed-chunk-spec (second (act-r-event-params event))) (printed-buffer-status (first (act-r-event-params event)))) (current-data module))) (overwrite-buffer-chunk - (push-last (list (first (act-r-event-params event)) "overwrite-buffer-chunk" (printed-chunk (second (act-r-event-params event))) (printed-buffer-status (first (act-r-event-params event)))) + (push-last (list (first (act-r-event-params event)) + "overwrite-buffer-chunk" + (if (symbolp (second (act-r-event-params event))) + (printed-chunk (second (act-r-event-params event))) + (printed-chunk-spec (second (act-r-event-params event)))) + (printed-buffer-status (first (act-r-event-params event)))) (current-data module))) (module-request (push-last (list (first (act-r-event-params event)) "module-request" (printed-chunk-spec (second (act-r-event-params event))) (printed-buffer-status (first (act-r-event-params event)))) diff --git a/support/goal-style-module.lisp b/support/goal-style-module.lisp index 812c5b0..6fc3b10 100644 --- a/support/goal-style-module.lisp +++ b/support/goal-style-module.lisp @@ -13,7 +13,7 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Filename : goal-style-module.lisp -;;; Version : 2.0 +;;; Version : 3.0 ;;; ;;; Description : Functions that allow one to easily create a module that ;;; : acts like the basic ACT-R goal module/buffer. @@ -77,6 +77,10 @@ ;;; 2020.08.26 Dan ;;; : * Removed the path for require-compiled in the examples since ;;; : it's not needed and results in warnings in SBCL. +;;; 2021.06.04 Dan [3.0] +;;; : * Don't need to create a temp chunk and schedule an event to +;;; : delete that now since the spec can be sent directly to +;;; : set-buffer-chunk, and remove create-new-buffer-chunk. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; General Docs: @@ -185,7 +189,7 @@ ;;; other than free, busy, or error is given then it prints a warning and returns nil. ;;; ;;; -;;; (defun goal-style-request (instance buffer-name chunk-spec &optional (delay 0) (priority -100))) +;;; (defun goal-style-request (instance buffer-name chunk-spec &optional (delay 0) (priority -1000))) ;;; ;;; This can be used as the request function of a module to allow it to ;;; operate like the goal module i.e. create new chunks in response to a @@ -209,21 +213,6 @@ ;;; priority (10) to ensure that all of the modification is made before a ;;; - action in the production clears it. ;;; -;;; (defun create-new-buffer-chunk (buffer-name chunk-description &key (priority -1000))) -;;; -;;; A function that creates a new chunk based on the chunk description in the -;;; chunk-description value provided (a list as appropriate for passing as one of -;;; the lists to define-chunks-fct) and schedules that it be placed into the buffer -;;; called buffer-name with the specified priority at the current time. This is -;;; used by goal-style-request to create the chunk, but may be used on its own if -;;; one wants to schedule the creation of a chunk in a buffer. This function -;;; automatically deletes the "original" chunk created after the buffer makes its -;;; copy through an event that is not output. -;;; The priority is used to schedule a set-buffer-chunk action. The default -;;; priority is "very low" so that other module's actions will generally take -;;; place first, but one exception is the declarative modules retrieval requests -;;; which have a priority of -2000 thus by default this new chunk will be a source -;;; of spreading activation. ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -253,25 +242,12 @@ (print-warning "Unknown query state ~s to ~s buffer" value buffer-name))) (print-warning "Unknown query ~s ~s to the ~s buffer" slot value buffer-name))) -(defun goal-style-request (instance buffer-name chunk-spec &optional (delay 0) (priority -100)) +(defun goal-style-request (instance buffer-name chunk-spec &optional (delay 0) (priority -1000)) (declare (ignore instance)) - (let ((chunk-description (chunk-spec-to-chunk-def chunk-spec))) - (if chunk-description - (schedule-event-relative delay 'create-new-buffer-chunk - :module buffer-name :priority priority - :details (concatenate 'string (symbol-name 'create-new-buffer-chunk) " " (symbol-name buffer-name)) - :params (list buffer-name chunk-description)) - (print-warning "Invalid request made of the ~a buffer." buffer-name)))) - -(defun create-new-buffer-chunk (buffer-name chunk-description &key (priority -1000)) - (let ((chunk-name (car (define-chunks-fct (list chunk-description))))) - (schedule-set-buffer-chunk buffer-name chunk-name 0 :module buffer-name :priority priority) - ;; because the chunk is only being created to be copied into the buffer - ;; just get rid of it after that happens to keep the chunk count down - (schedule-event-relative 0 'clean-up-goal-chunk :module :none :output nil - :priority :min :params (list chunk-name) - :details "Clean-up unneeded chunk" :maintenance t) - nil)) + (if (chunk-spec-to-chunk-def chunk-spec) + (schedule-set-buffer-chunk buffer-name chunk-spec delay + :module buffer-name :priority priority) + (print-warning "Invalid request made of the ~a buffer." buffer-name))) (defun clean-up-goal-chunk (name) diff --git a/support/production-parsing.lisp b/support/production-parsing.lisp index 9188a69..2db0b64 100644 --- a/support/production-parsing.lisp +++ b/support/production-parsing.lisp @@ -13,7 +13,7 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Filename : production-parsing-support.lisp -;;; Version : 5.1 +;;; Version : 7.0 ;;; ;;; Description : Functions and code that's used by both p and p* parsing. ;;; @@ -293,6 +293,19 @@ ;;; : the condition and action parse tables because they must be ;;; : evaluated in the same order at reset so actually sort them ;;; : by their slot-name indices. +;;; 2021.03.10 Dan [6.0] +;;; : * Add explict state free queries for buffers that have a +;;; : request, aren't on the do-not-query list, and don't have a +;;; : query already in the production. +;;; 2021.04.21 Dan +;;; : * There was an incorrect implicit condition for the - slot val +;;; : situation because that added an implicit constraint that +;;; : it couldn't be nil, but that is valid in that situation. +;;; 2021.06.04 Dan [7.0] +;;; : * The overwrite action now just passes the spec instead of +;;; : creating a dummy chunk to use since that's valid now. +;;; : * If a buffer variable is used in the production then that +;;; : buffer must continue to copy chunks. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; General Docs: @@ -447,6 +460,16 @@ (rhs-dependencies nil) (unbound-vars nil)) + + ;; set buffers whose variables are used to require copies + + (dolist (b (production-lhs-buffers production)) + (let ((var (buffer-name->variable b))) + (when (or (find var lhs-variables) + (find var rhs-variables)) + (buffer-requires-copies b)))) + + (setf (production-variables production) (remove-duplicates (append lhs-variables rhs-variables buffer-variables))) @@ -803,7 +826,8 @@ (push-last (new-condition :type 'test-slot :value value :test 'safe-chunk-slot-equal :result nil) others) ;; if it's '- nil' then that's got an implicit test the slot must be full - (awhen (must-be implicit nil) (push it implicit))) + (when (null value) + (awhen (must-be implicit nil) (push it implicit)))) (t ;; Explicitly this must be a number @@ -1111,6 +1135,7 @@ :time-in-ms t :module 'procedural :priority 90 + :requested nil :output (procedural-rhst prod))) (production-actions production))) (t @@ -1118,23 +1143,18 @@ (lambda () (multiple-value-bind (spec extended) (instantiate-chunk-spec spec (production-bindings production)) - (let ((dummy-chunk (car (define-chunks-fct (list (chunk-spec-to-chunk-def spec)))))) - (schedule-overwrite-buffer-chunk target dummy-chunk 0 - :time-in-ms t - :module 'procedural - :priority 90 - :output (procedural-rhst prod)) - (when extended - (schedule-event-now 'extend-buffer-chunk - :module 'procedural - :priority 91 - :params (list target) - :output (procedural-rhst prod))) - (schedule-event-now 'delete-chunk-fct + (schedule-overwrite-buffer-chunk target spec 0 + :time-in-ms t + :module 'procedural + :priority 90 + :requested nil + :output (procedural-rhst prod)) + (when extended + (schedule-event-now 'extend-buffer-chunk :module 'procedural - :params (list dummy-chunk) - :priority 89 - :output nil)))) + :priority 91 + :params (list target) + :output (procedural-rhst prod))))) (production-actions production))))) (#\- (push-last @@ -1246,6 +1266,42 @@ ;; make sure the bindings happen first (setf (production-actions production) (append (mapcar 'cdr rhs-binds) (production-actions production)))) + ;;; Add explicit state free queries for buffers that are + ;;; not on the do-not-query list and have a request or modification request + ;;; on the RHS of the production + + (dolist (y rhs) + (let ((buffer (production-statement-target y))) + (when (and (or (eql #\+ (production-statement-op y)) + (eql #\* (production-statement-op y))) + + (not (find buffer (procedural-do-not-query prod))) + (not (find-if (lambda (x) + (and (eql #\? (production-statement-op x)) + (eql buffer (production-statement-target x)))) + lhs))) + (let* ((spec (define-chunk-spec-fct '(state free))) + (cr (make-cr-condition :type 'query :buffer buffer + :slot 'state + :value 'free + :test spec + :result t))) + + + ;; these production slots are already set with other values above + + (push-last cr (production-constants production)) + (push-last (list 'query-buffer buffer spec) (production-selection-code production)) + + ;; Add the statement to the lhs + (push-last (make-production-statement + :op #\? + :target buffer + :definition (list 'state 'free) + :spec spec) + (production-lhs production)))))) + + ;;; Add the implicit clears for strict harvesting (dolist (y lhs) (when (or (eql #\= (production-statement-op y)) diff --git a/support/time-functions.lisp b/support/time-functions.lisp index 6a72313..6e62f07 100644 --- a/support/time-functions.lisp +++ b/support/time-functions.lisp @@ -13,7 +13,7 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Filename : time-functions.lisp -;;; Version : 1.0 +;;; Version : 2.0 ;;; ;;; Description : Macro to execute code and record the time spent in specified ;;; : functions. @@ -34,6 +34,12 @@ ;;; 2020.08.26 Dan ;;; : * Removed the path for require-compiled doc since it's not needed ;;; : and results in warnings in SBCL. +;;; 2021.04.21 Dan [2.0] +;;; : * Added an alterative version that just records the cumulative +;;; : time and a count instead of the individual ones becasue the +;;; : extra storage requirements may affect the timing. +;;; 2021.06.14 Dan +;;; : * Don't need to pass the function name to create-ctimed-closure. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; General Docs: @@ -133,6 +139,49 @@ (dolist (,fn ,old-defs) (setf (fdefinition (car ,fn)) (cdr ,fn))))))) + + + +(defmacro create-ctimed-closure (c results) + (let ((start (gensym))) + `(let ((,start nil)) + (lambda (&rest rest) + (if ,start + (apply ,c rest) + (unwind-protect + (progn + (setf ,start (get-internal-real-time)) + (apply ,c rest)) + (progn + (incf (first ,results)) + (incf (second ,results) (- (get-internal-real-time) ,start)) + (setf ,start nil)))))))) + +(defmacro ctime-functions ((&rest fns) &body body) + (let ((results (gensym)) + (old-defs (gensym)) + (fn (gensym)) + (f (gensym)) + (c (gensym)) + (d (gensym))) + + `(let ((,results nil) + (,old-defs (mapcan (lambda (x) (when (fboundp x) (list (cons x (fdefinition x))))) ',fns))) + (unwind-protect + (progn + (dolist (,fn ,old-defs) + (let ((,f (car ,fn)) + (,c (cdr ,fn)) + (,d (list 0 0))) + (push (cons ,f ,d) ,results) + (setf (fdefinition ,f) + (create-ctimed-closure ,c ,d)) + (compile ,f))) + (values ,results (progn ,@body))) + (dolist (,fn ,old-defs) + (setf (fdefinition (car ,fn)) (cdr ,fn))))))) + + (provide "TIME-FUNCTIONS") #| Example: diff --git a/tools/buffer-trace.lisp b/tools/buffer-trace.lisp index 7ac5e68..e7c78be 100644 --- a/tools/buffer-trace.lisp +++ b/tools/buffer-trace.lisp @@ -147,6 +147,9 @@ ;;; : to allow specifying start and stop times. ;;; 2020.01.14 Dan [3.1] ;;; : * Buffer-trace history constituents can't be lambdas. +;;; 2021.06.07 Dan +;;; : * Deal with set-buffer-chunk and overwrite-... possibly having +;;; : a chunk-spec as the second parameter. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; General Docs: @@ -294,7 +297,10 @@ ((set-buffer-chunk overwrite-buffer-chunk) (let ((bn (car (act-r-event-params evt)))) (awhen (find bn (buffer-record-buffers (btm-current-summary btm)) :key 'buffer-summary-name) - (setf (buffer-summary-chunk-name it) (string (second (act-r-event-params evt))))))) + (setf (buffer-summary-chunk-name it) + (if (symbolp (second (act-r-event-params evt))) + (string (second (act-r-event-params evt))) + (format nil "~S" (chunk-spec-to-chunk-def (second (act-r-event-params evt))))))))) (mod-buffer-chunk (let ((bn (car (act-r-event-params evt)))) diff --git a/tools/goal-compilation.lisp b/tools/goal-compilation.lisp index 122b8d7..854efde 100644 --- a/tools/goal-compilation.lisp +++ b/tools/goal-compilation.lisp @@ -13,7 +13,7 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Filename : goal-compilation.lisp -;;; Version : 4.0 +;;; Version : 6.0 ;;; ;;; Description : Production compilation GOAL style definition. ;;; @@ -71,6 +71,20 @@ ;;; : name -- the symbol naming the buffer or bang action ;;; : token -- the symbol of the production item for op and name ;;; : slots -- list of slot-spec lists +;;; 2021.02.05 Dan [5.0] +;;; : * Allowing the 9,8 case to happen if the mod in p1 is an empty +;;; : mod when the buffer is strict harvested and then just drop +;;; : the empty mod. +;;; 2021.02.10 Dan [6.0] +;;; : * There isn't a pre-instantiation step for variablized slots +;;; : now so that needs to be done here instead for both mapping +;;; : and composition. +;;; : * Needs to deal with var->var, const->var, var->const, and +;;; : the possibility of multiple vars being bound to the same +;;; : slot name. +;;; 2021.02.23 Dan +;;; : * Wasn't catching the possible action to action mappings for +;;; : dynamic slots, only the action to condition. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; #+:packaged-actr (in-package :act-r) @@ -95,9 +109,10 @@ (declare (ignore p1)) (let* ((ppm (compilation-module-ppm module)) + (p1-bindings (previous-production-bindings (compilation-module-previous module))) + (p2-bindings (production-compilation-instan (production-name p2))) (bindings (when ppm - (append (previous-production-bindings (compilation-module-previous module)) - (production-compilation-instan (production-name p2)))))) + (append p1-bindings p2-bindings)))) (cond (;; The RHS + to LHS = case -- also overrides when there's a RHS * in p1 (and (find p1-index '(4 12 13 44)) @@ -107,18 +122,82 @@ ;; here the slots of interest are just the intersection of the two sets (let* ((mappings nil) - (p1-slots (compose-rep-slots (find-if (lambda (x) (and (char= #\+ (compose-rep-op x)) (eq buffer (compose-rep-name x)))) (second p1-s)))) - (p2-slots (compose-rep-slots (find-if (lambda (x) (and (char= #\= (compose-rep-op x)) (eq buffer (compose-rep-name x)))) (first p2-s)))) - (interesting-slots (intersection (mapcan (lambda (x) - (when (eq (spec-slot-op x) '=) - (list (spec-slot-name x)))) - p1-slots) - (mapcan (lambda (x) - (when (eq (spec-slot-op x) '=) - (list (spec-slot-name x)))) - p2-slots)))) + (original-p1-slots (compose-rep-slots (find-if (lambda (x) (and (char= #\+ (compose-rep-op x)) (eq buffer (compose-rep-name x)))) (second p1-s)))) + (original-p2-slots (compose-rep-slots (find-if (lambda (x) (and (char= #\= (compose-rep-op x)) (eq buffer (compose-rep-name x)))) (first p2-s)))) + (original-p2-rhs-slots (compose-rep-slots (find-if (lambda (x) (and (eq buffer (compose-rep-name x)) + (or (char= #\= (compose-rep-op x)) + (char= #\* (compose-rep-op x))))) + (second p2-s)))) + (p1-var-slots (mapcar (lambda (x) (assoc (spec-slot-name x) p1-bindings)) (remove-if-not 'chunk-spec-variable-p original-p1-slots :key 'spec-slot-name))) + (p2-var-slots (mapcar (lambda (x) (assoc (spec-slot-name x) p2-bindings)) (remove-if-not 'chunk-spec-variable-p original-p2-slots :key 'spec-slot-name))) + (p2-rhs-var-slots (mapcar (lambda (x) (assoc (spec-slot-name x) p2-bindings)) (remove-if-not 'chunk-spec-variable-p original-p2-rhs-slots :key 'spec-slot-name))) + + (p1-slots (instantiate-slot-names + original-p1-slots + p1-bindings)) + (p2-slots (instantiate-slot-names + original-p2-slots + p2-bindings)) + (p2-rhs-slots (instantiate-slot-names + original-p2-rhs-slots + p2-bindings)) + (interesting-slots (remove-duplicates (append (mapcan (lambda (x) + (when (eq (spec-slot-op x) '=) + (list (spec-slot-name x)))) + p1-slots) + (mapcan (lambda (x) + (when (eq (spec-slot-op x) '=) + (list (spec-slot-name x)))) + p2-slots) + (mapcan (lambda (x) + (when (eq (spec-slot-op x) '=) + (list (spec-slot-name x)))) + p2-rhs-slots))))) - (dolist (slot (remove-duplicates interesting-slots)) + + (dolist (slot interesting-slots) + + (when (or p1-var-slots p2-var-slots p2-rhs-var-slots) ;; there are dynamic slots which may need to be mapped + ;; if the same slot is variablized in both or a var slot maps + ;; to a constant slot in either direction (multiple options + ;; possible as well as multiple variables matching the same slot) + + + (when (and (rassoc slot p1-var-slots) ;; it's a variable in action and condition both + (rassoc slot p2-var-slots)) ;; so need to add all the variable to variable mappings + (dolist (p1-var (mapcar 'car (remove-if-not (lambda (x) (eq (cdr x) slot)) p1-var-slots))) + (dolist (p2-var (mapcar 'car (remove-if-not (lambda (x) (eq (cdr x) slot)) p2-var-slots))) + (push (cons p1-var p2-var) mappings)))) + + (when (and (rassoc slot p1-var-slots) ;; it's a variable in both actions + (rassoc slot p2-rhs-var-slots)) ;; so need to add all the variable to variable mappings + (dolist (p1-var (mapcar 'car (remove-if-not (lambda (x) (eq (cdr x) slot)) p1-var-slots))) + (dolist (p2-var (mapcar 'car (remove-if-not (lambda (x) (eq (cdr x) slot)) p2-rhs-var-slots))) + (push (cons p1-var p2-var) mappings)))) + + + (when (and (rassoc slot p1-var-slots) ;; it's a variable in p1 and const in p2 so need to instantiate + (find slot original-p2-slots :key 'spec-slot-name)) ;; all p1 vars + (dolist (p1-var (mapcar 'car (remove-if-not (lambda (x) (eq (cdr x) slot)) p1-var-slots))) + (push (cons p1-var slot) mappings))) + + (when (and (rassoc slot p1-var-slots) ;; it's a variable in p1 and const in p2 action so need to instantiate + (find slot original-p2-rhs-slots :key 'spec-slot-name)) ;; all p1 vars + (dolist (p1-var (mapcar 'car (remove-if-not (lambda (x) (eq (cdr x) slot)) p1-var-slots))) + (push (cons p1-var slot) mappings))) + + (when (and (rassoc slot p2-var-slots) ;; it's a variable in p2 and const in p1 so need to instantiate + (find slot original-p1-slots :key 'spec-slot-name)) ;; all p2 vars + (dolist (p2-var (mapcar 'car (remove-if-not (lambda (x) (eq (cdr x) slot)) p2-var-slots))) + (push (cons p2-var slot) mappings))) + + (when (and (rassoc slot p2-rhs-var-slots) ;; it's a variable in p2 action and const in p1 so need to instantiate + (find slot original-p1-slots :key 'spec-slot-name)) ;; all p2 vars + (dolist (p2-var (mapcar 'car (remove-if-not (lambda (x) (eq (cdr x) slot)) p2-rhs-var-slots))) + (push (cons p2-var slot) mappings)))) + + + (dolist (p1slots (remove-if-not (lambda (x) (and (eq (spec-slot-op x) '=) (eq (spec-slot-name x) slot))) p1-slots)) (dolist (p2slots (remove-if-not (lambda (x) (and (eq (spec-slot-op x) '=) (eq (spec-slot-name x) slot))) p2-slots)) (if (constant-value-p (spec-slot-value p2slots) module) @@ -144,25 +223,97 @@ (let* ((mappings nil) - (p1-slotsa (compose-rep-slots (find-if (lambda (x) (and (char= #\= (compose-rep-op x)) (eq buffer (compose-rep-name x)))) (first p1-s)))) - (p1-slotsb (compose-rep-slots (find-if (lambda (x) (and (char= #\= (compose-rep-op x)) (eq buffer (compose-rep-name x)))) (second p1-s)))) - (p2-slots (compose-rep-slots (find-if (lambda (x) (and (char= #\= (compose-rep-op x)) (eq buffer (compose-rep-name x)))) (first p2-s)))) + (original-p1a-slots (compose-rep-slots (find-if (lambda (x) (and (char= #\= (compose-rep-op x)) (eq buffer (compose-rep-name x)))) (first p1-s)))) + (original-p1b-slots (compose-rep-slots (find-if (lambda (x) (and (char= #\= (compose-rep-op x)) (eq buffer (compose-rep-name x)))) (second p1-s)))) + + (original-p2-slots (compose-rep-slots (find-if (lambda (x) (and (char= #\= (compose-rep-op x)) (eq buffer (compose-rep-name x)))) (first p2-s)))) + (original-p2-rhs-slots (compose-rep-slots (find-if (lambda (x) (and (eq buffer (compose-rep-name x)) + (or (char= #\= (compose-rep-op x)) + (char= #\* (compose-rep-op x))))) + (second p2-s)))) + + (p1-var-slotsa (mapcar (lambda (x) (assoc (spec-slot-name x) p1-bindings)) (remove-if-not 'chunk-spec-variable-p original-p1a-slots :key 'spec-slot-name))) + (p1-var-slotsb (mapcar (lambda (x) (assoc (spec-slot-name x) p1-bindings)) (remove-if-not 'chunk-spec-variable-p original-p1b-slots :key 'spec-slot-name))) + (p2-var-slots (mapcar (lambda (x) (assoc (spec-slot-name x) p2-bindings)) (remove-if-not 'chunk-spec-variable-p original-p2-slots :key 'spec-slot-name))) + (p2-rhs-var-slots (mapcar (lambda (x) (assoc (spec-slot-name x) p2-bindings)) (remove-if-not 'chunk-spec-variable-p original-p2-rhs-slots :key 'spec-slot-name))) + + (p1-slotsa (instantiate-slot-names + original-p1a-slots + p1-bindings)) + (p1-slotsb (instantiate-slot-names + original-p1b-slots + p1-bindings)) + (p2-slots (instantiate-slot-names + original-p2-slots + p2-bindings)) + (p2-rhs-slots (instantiate-slot-names + original-p2-rhs-slots + p2-bindings)) (p1-slots (append (remove-if (lambda (x) (or (not (eq (spec-slot-op x) '=)) (find (spec-slot-name x) p1-slotsb :key 'spec-slot-name))) p1-slotsa) p1-slotsb)) - (interesting-slots (intersection (mapcan (lambda (x) - (list (spec-slot-name x))) - p1-slots) - (mapcan (lambda (x) - (when (eq (spec-slot-op x) '=) - (list (spec-slot-name x)))) - p2-slots)))) + + (p1-var-slots (remove-duplicates (append p1-var-slotsa p1-var-slotsb) :test 'equalp)) + + (interesting-slots (remove-duplicates (append (mapcan (lambda (x) + (when (eq (spec-slot-op x) '=) + (list (spec-slot-name x)))) + p1-slots) + (mapcan (lambda (x) + (when (eq (spec-slot-op x) '=) + (list (spec-slot-name x)))) + p2-slots) + (mapcan (lambda (x) + (when (eq (spec-slot-op x) '=) + (list (spec-slot-name x)))) + p2-rhs-slots))))) - - (dolist (slot (remove-duplicates interesting-slots)) + (dolist (slot interesting-slots) + + (when (or p1-var-slots p2-var-slots p2-rhs-var-slots) ;; there are dynamic slots which may need to be mapped + ;; if the same slot is variablized in both or a var slot maps + ;; to a constant slot in either direction (multiple options + ;; possible as well as multiple variables matching the same slot) + + + (when (and (rassoc slot p1-var-slots) ;; it's a variable in both + (rassoc slot p2-var-slots)) ;; so need to add all the variable to variable mappings + (dolist (p1-var (mapcar 'car (remove-if-not (lambda (x) (eq (cdr x) slot)) p1-var-slots))) + (dolist (p2-var (mapcar 'car (remove-if-not (lambda (x) (eq (cdr x) slot)) p2-var-slots))) + (push (cons p1-var p2-var) mappings)))) + + (when (and (rassoc slot p1-var-slotsb) ;; it's a variable in both actions + (rassoc slot p2-rhs-var-slots)) ;; so need to add all the variable to variable mappings + (dolist (p1-var (mapcar 'car (remove-if-not (lambda (x) (eq (cdr x) slot)) p1-var-slotsb))) + (dolist (p2-var (mapcar 'car (remove-if-not (lambda (x) (eq (cdr x) slot)) p2-rhs-var-slots))) + (push (cons p1-var p2-var) mappings)))) + + (when (and (rassoc slot p1-var-slots) ;; it's a variable in p1 and const in p2 so need to instantiate + (find slot original-p2-slots :key 'spec-slot-name)) ;; all p1 vars + (dolist (p1-var (mapcar 'car (remove-if-not (lambda (x) (eq (cdr x) slot)) p1-var-slots))) + (push (cons p1-var slot) mappings))) + + (when (and (rassoc slot p1-var-slotsb) ;; it's a variable in p1 and const in p2 action so need to instantiate + (find slot original-p2-rhs-slots :key 'spec-slot-name)) ;; all p1 vars + (dolist (p1-var (mapcar 'car (remove-if-not (lambda (x) (eq (cdr x) slot)) p1-var-slotsb))) + (push (cons p1-var slot) mappings))) + + (when (and (rassoc slot p2-var-slots) ;; it's a variable in p2 and const in p1 (somewhere) so need to instantiate + (or ;; all p2 vars + (find slot original-p1a-slots :key 'spec-slot-name) + (find slot original-p1b-slots :key 'spec-slot-name))) + (dolist (p2-var (mapcar 'car (remove-if-not (lambda (x) (eq (cdr x) slot)) p2-var-slots))) + (push (cons p2-var slot) mappings))) + + (when (and (rassoc slot p2-rhs-var-slots) ;; it's a variable in p2 action and const in p1 so need to instantiate + (find slot original-p1b-slots :key 'spec-slot-name)) ;; all p2 vars + (dolist (p2-var (mapcar 'car (remove-if-not (lambda (x) (eq (cdr x) slot)) p2-rhs-var-slots))) + (push (cons p2-var slot) mappings)))) + + (dolist (p1slots (remove-if-not (lambda (x) (eq (spec-slot-name x) slot)) p1-slots)) (dolist (p2slots (remove-if-not (lambda (x) (eq (spec-slot-name x) slot)) p2-slots)) @@ -190,25 +341,97 @@ (let* ((mappings nil) - (p1-slotsa (compose-rep-slots (find-if (lambda (x) (and (char= #\= (compose-rep-op x)) (eq buffer (compose-rep-name x)))) (first p1-s)))) - (p1-slotsb (compose-rep-slots (find-if (lambda (x) (and (char= #\* (compose-rep-op x)) (eq buffer (compose-rep-name x)))) (second p1-s)))) - (p2-slots (compose-rep-slots (find-if (lambda (x) (and (char= #\= (compose-rep-op x)) (eq buffer (compose-rep-name x)))) (first p2-s)))) + (original-p1a-slots (compose-rep-slots (find-if (lambda (x) (and (char= #\= (compose-rep-op x)) (eq buffer (compose-rep-name x)))) (first p1-s)))) + (original-p1b-slots (compose-rep-slots (find-if (lambda (x) (and (char= #\* (compose-rep-op x)) (eq buffer (compose-rep-name x)))) (second p1-s)))) + + (original-p2-slots (compose-rep-slots (find-if (lambda (x) (and (char= #\= (compose-rep-op x)) (eq buffer (compose-rep-name x)))) (first p2-s)))) + (original-p2-rhs-slots (compose-rep-slots (find-if (lambda (x) (and (eq buffer (compose-rep-name x)) + (or (char= #\= (compose-rep-op x)) + (char= #\* (compose-rep-op x))))) + (second p2-s)))) + + (p1-var-slotsa (mapcar (lambda (x) (assoc (spec-slot-name x) p1-bindings)) (remove-if-not 'chunk-spec-variable-p original-p1a-slots :key 'spec-slot-name))) + (p1-var-slotsb (mapcar (lambda (x) (assoc (spec-slot-name x) p1-bindings)) (remove-if-not 'chunk-spec-variable-p original-p1b-slots :key 'spec-slot-name))) + (p2-var-slots (mapcar (lambda (x) (assoc (spec-slot-name x) p2-bindings)) (remove-if-not 'chunk-spec-variable-p original-p2-slots :key 'spec-slot-name))) + (p2-rhs-var-slots (mapcar (lambda (x) (assoc (spec-slot-name x) p2-bindings)) (remove-if-not 'chunk-spec-variable-p original-p2-rhs-slots :key 'spec-slot-name))) + + (p1-slotsa (instantiate-slot-names + original-p1a-slots + p1-bindings)) + (p1-slotsb (instantiate-slot-names + original-p1b-slots + p1-bindings)) + (p2-slots (instantiate-slot-names + original-p2-slots + p2-bindings)) + (p2-rhs-slots (instantiate-slot-names + original-p2-rhs-slots + p2-bindings)) (p1-slots (append (remove-if (lambda (x) (or (not (eq (spec-slot-op x) '=)) (find (spec-slot-name x) p1-slotsb :key 'spec-slot-name))) p1-slotsa) p1-slotsb)) - (interesting-slots (intersection (mapcan (lambda (x) - (list (spec-slot-name x))) - p1-slots) - (mapcan (lambda (x) - (when (eq (spec-slot-op x) '=) - (list (spec-slot-name x)))) - p2-slots)))) + + (p1-var-slots (remove-duplicates (append p1-var-slotsa p1-var-slotsb) :test 'equalp)) + + (interesting-slots (remove-duplicates (append (mapcan (lambda (x) + (when (eq (spec-slot-op x) '=) + (list (spec-slot-name x)))) + p1-slots) + (mapcan (lambda (x) + (when (eq (spec-slot-op x) '=) + (list (spec-slot-name x)))) + p2-slots) + (mapcan (lambda (x) + (when (eq (spec-slot-op x) '=) + (list (spec-slot-name x)))) + p2-rhs-slots))))) - - (dolist (slot (remove-duplicates interesting-slots)) + (dolist (slot interesting-slots) + + (when (or p1-var-slots p2-var-slots p2-rhs-var-slots) ;; there are dynamic slots which may need to be mapped + ;; if the same slot is variablized in both or a var slot maps + ;; to a constant slot in either direction (multiple options + ;; possible as well as multiple variables matching the same slot) + + + (when (and (rassoc slot p1-var-slots) ;; it's a variable in both + (rassoc slot p2-var-slots)) ;; so need to add all the variable to variable mappings + (dolist (p1-var (mapcar 'car (remove-if-not (lambda (x) (eq (cdr x) slot)) p1-var-slots))) + (dolist (p2-var (mapcar 'car (remove-if-not (lambda (x) (eq (cdr x) slot)) p2-var-slots))) + (push (cons p1-var p2-var) mappings)))) + + (when (and (rassoc slot p1-var-slotsb) ;; it's a variable in both actions + (rassoc slot p2-rhs-var-slots)) ;; so need to add all the variable to variable mappings + (dolist (p1-var (mapcar 'car (remove-if-not (lambda (x) (eq (cdr x) slot)) p1-var-slotsb))) + (dolist (p2-var (mapcar 'car (remove-if-not (lambda (x) (eq (cdr x) slot)) p2-rhs-var-slots))) + (push (cons p1-var p2-var) mappings)))) + + (when (and (rassoc slot p1-var-slots) ;; it's a variable in p1 and const in p2 so need to instantiate + (find slot original-p2-slots :key 'spec-slot-name)) ;; all p1 vars + (dolist (p1-var (mapcar 'car (remove-if-not (lambda (x) (eq (cdr x) slot)) p1-var-slots))) + (push (cons p1-var slot) mappings))) + + (when (and (rassoc slot p1-var-slotsb) ;; it's a variable in p1 and const in p2 action so need to instantiate + (find slot original-p2-rhs-slots :key 'spec-slot-name)) ;; all p1 vars + (dolist (p1-var (mapcar 'car (remove-if-not (lambda (x) (eq (cdr x) slot)) p1-var-slotsb))) + (push (cons p1-var slot) mappings))) + + (when (and (rassoc slot p2-var-slots) ;; it's a variable in p2 and const in p1 (somewhere) so need to instantiate + (or ;; all p2 vars + (find slot original-p1a-slots :key 'spec-slot-name) + (find slot original-p1b-slots :key 'spec-slot-name))) + (dolist (p2-var (mapcar 'car (remove-if-not (lambda (x) (eq (cdr x) slot)) p2-var-slots))) + (push (cons p2-var slot) mappings))) + + (when (and (rassoc slot p2-rhs-var-slots) ;; it's a variable in p2 action and const in p1 so need to instantiate + (find slot original-p1b-slots :key 'spec-slot-name)) ;; all p2 vars + (dolist (p2-var (mapcar 'car (remove-if-not (lambda (x) (eq (cdr x) slot)) p2-rhs-var-slots))) + (push (cons p2-var slot) mappings)))) + + (dolist (p1slots (remove-if-not (lambda (x) (eq (spec-slot-name x) slot)) p1-slots)) (dolist (p2slots (remove-if-not (lambda (x) (eq (spec-slot-name x) slot)) p2-slots)) @@ -245,18 +468,28 @@ (let* ((mappings nil) - (p1-slots (compose-rep-slots (find-if (lambda (x) (and (char= #\= (compose-rep-op x)) (eq buffer (compose-rep-name x)))) (first p1-s)))) - (p2-slots (compose-rep-slots (find-if (lambda (x) (and (char= #\= (compose-rep-op x)) (eq buffer (compose-rep-name x)))) (first p2-s)))) + (original-p1-slots (compose-rep-slots (find-if (lambda (x) (and (char= #\+ (compose-rep-op x)) (eq buffer (compose-rep-name x)))) (first p1-s)))) + (original-p2-slots (compose-rep-slots (find-if (lambda (x) (and (char= #\= (compose-rep-op x)) (eq buffer (compose-rep-name x)))) (first p2-s)))) + + (p1-slots (instantiate-slot-names + original-p1-slots + p1-bindings)) + (p2-slots (instantiate-slot-names + original-p2-slots + p2-bindings)) (interesting-slots (intersection (mapcan (lambda (x) - (when (eq (spec-slot-op x) '=) - (list (spec-slot-name x)))) + (when (eq (spec-slot-op x) '=) + (list (spec-slot-name x)))) p1-slots) (mapcan (lambda (x) (when (eq (spec-slot-op x) '=) - (list (spec-slot-name x)))) + (list (spec-slot-name x)))) p2-slots)))) - (dolist (slot (remove-duplicates interesting-slots)) + (dolist (slot interesting-slots) + + ;; no dynamic slot issues because can't assume anything from just the conditions + (dolist (p1slots (remove-if-not (lambda (x) (and (eq (spec-slot-op x) '=) (eq (spec-slot-name x) slot))) p1-slots)) (dolist (p2slots (remove-if-not (lambda (x) (and (eq (spec-slot-op x) '=) (eq (spec-slot-name x) slot))) p2-slots)) (if (constant-value-p (spec-slot-value p2slots) module) @@ -273,7 +506,6 @@ nil)))) (defun COMPOSE-GOAL-BUFFER (buffer module p1 p1-s p1-index p2 p2-s p2-index) - (declare (ignore module p2 p2-index)) ;; This is based on the limited set of conditions that can ;; be composed. ;; @@ -305,7 +537,9 @@ (a1+ (find-if (lambda (x) (and (char= #\+ (compose-rep-op x)) (eq buffer (compose-rep-name x)))) (second p1-s))) (a2+ (find-if (lambda (x) (and (char= #\+ (compose-rep-op x)) (eq buffer (compose-rep-name x)))) (second p2-s))) (a1* (find-if (lambda (x) (and (char= #\* (compose-rep-op x)) (eq buffer (compose-rep-name x)))) (second p1-s))) - (a2* (find-if (lambda (x) (and (char= #\* (compose-rep-op x)) (eq buffer (compose-rep-name x)))) (second p2-s)))) + (a2* (find-if (lambda (x) (and (char= #\* (compose-rep-op x)) (eq buffer (compose-rep-name x)))) (second p2-s))) + (bindings (append (previous-production-bindings (compilation-module-previous module)) + (production-compilation-instan (production-name p2))))) (case p1-index ((4 12 13 44) @@ -315,17 +549,17 @@ (list a1=) (list a1*))) (cond ((and a1+ a2=) - (awhen (buffer+-union a1+ a2=) + (awhen (buffer+-union a1+ a2= bindings) (list it))) ((and a1+ a2*) - (awhen (buffer+-union a1+ a2*) + (awhen (buffer+-union a1+ a2* bindings) (list it))) (a1+ (list a1+)) (t nil))))) ((0 8) - (list (awhen (buffer-condition-union c1 c2 a1=) ;; a1= is always nil, though so why use it? + (list (awhen (buffer-condition-union c1 c2 a1= bindings) ;; a1= is always nil, though so why use it? (list it)) (append (when a2= (list a2=)) @@ -334,17 +568,21 @@ (when a2+ (list a2+))))) ((9 40) - (list (awhen (buffer-condition-union c1 c2 (if a1= a1= a1*)) + (list (awhen (buffer-condition-union c1 c2 (if a1= a1= a1*) bindings) (list it)) (append - (cond ((and a1* a2=) - (awhen (buffer=-union a1* a2=) + (cond ((and (= p2-index 8) + (not (find buffer (compilation-module-no-harvest module))) ;; it is strict harvested + (null (second a1=))) ;; the mod in a1 is a null mod + nil) + ((and a1* a2=) + (awhen (buffer=-union a1* a2= bindings) (list it))) ((or a1= a2=) ;; if there's at least one = union those - (awhen (buffer=-union a1= a2=) + (awhen (buffer=-union a1= a2= bindings) (list it))) ((or a1* a2*) ;; if there's at least one * union those - (awhen (buffer=-union a1* a2*) + (awhen (buffer=-union a1* a2* bindings) (list it))) (t nil)) @@ -415,6 +653,13 @@ (declare (ignore p1 p1-s p1-index p2 p2-s p2-index)) (find buffer (compilation-module-no-harvest module))) +(defun NO-GOAL-HARVESTING-OR-NULL-MOD (buffer module p1 p1-s p1-index p2 p2-s p2-index) + (declare (ignore p1 p1-index p2 p2-s p2-index)) + (or (find buffer (compilation-module-no-harvest module)) + (let ((mod (find-if (lambda (x) (and (char= #\= (compose-rep-op x)) (eq buffer (compose-rep-name x)))) (second p1-s)))) + (and mod (null (second mod)))))) + + (defun G-B-C1 (buffer module p1 p1-s p1-index p2 p2-s p2-index) (and (no-rhs-goal-ref buffer module p1 p1-s p1-index p2 p2-s p2-index) (no-goal-harvesting buffer module p1 p1-s p1-index p2 p2-s p2-index))) @@ -463,7 +708,7 @@ (13 0 T) (12 40 NO-RHS-GOAL-REF) (12 9 NO-RHS-GOAL-REF) (12 8 G-B-C1) (12 0 T) (9 13 T) (9 12 T) (9 9 T) - (9 8 NO-GOAL-HARVESTING) (9 4 T) (9 0 T) + (9 8 NO-GOAL-HARVESTING-OR-NULL-MOD) (9 4 T) (9 0 T) (8 44 NO-GOAL-HARVESTING) (8 40 NO-GOAL-HARVESTING) (8 13 NO-GOAL-HARVESTING) diff --git a/tools/image-feature.lisp b/tools/image-feature.lisp index 30d8be1..045aaa6 100644 --- a/tools/image-feature.lisp +++ b/tools/image-feature.lisp @@ -52,13 +52,16 @@ ;;; 2019.08.27 Dan ;;; : * Use new-symbol-fct instead of new-name-fct because it can be ;;; : used when there isn't a current model. +;;; 2021.05.11 Dan +;;; : * Changed reference to GUI directory to gui to avoid issues +;;; : with logical pathnames (particularlly in SBCL). ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; General Docs: ;;; ;;; Create a new virtual dialog item called an image which can be used to draw ;;; .gif files in the visible virtual windows if those images are located in the -;;; GUI/AGI-images directory of the Environment. +;;; gui/AGI-images directory of the Environment. ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -74,7 +77,7 @@ ;;; ;;; Win is the window reference (as with other AGI items), text is a string which ;;; will be the value the model sees for attending the item. File should be the -;;; name of a file in the GUI/AGI-images directory of the Environment to display +;;; name of a file in the gui/AGI-images directory of the Environment to display ;;; in the visible virtual window. X and y are the coordinates for the upper left ;;; corner of the image in the window. Width and height specify the size of the ;;; image for display purposes and the .gif file will be clipped to fit if diff --git a/tools/imaginal-compilation.lisp b/tools/imaginal-compilation.lisp index 321ef74..2b3775f 100644 --- a/tools/imaginal-compilation.lisp +++ b/tools/imaginal-compilation.lisp @@ -13,7 +13,7 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Filename : imaginal-compilation.lisp -;;; Version : 4.1 +;;; Version : 6.0 ;;; ;;; Description : Production compilation IMAGINAL style definition. ;;; @@ -74,6 +74,20 @@ ;;; : was strict harvested from p1 otherwise you end up with a ;;; : production that can't fire since it tests for both there ;;; : being a chunk in the buffer and a query that it's empty. +;;; 2021.02.05 Dan [5.0] +;;; : * Allowing the 9,8 28,8 9,24 25,24 cases to happen if the mod +;;; : in p1 is an empty mod when the buffer is strict harvested +;;; : and then just drop the empty mod. +;;; 2021.02.10 Dan [6.0] +;;; : * There isn't a pre-instantiation step for variablized slots +;;; : now so that needs to be done here instead for both mapping +;;; : and composition. +;;; : * Needs to deal with var->var, const->var, var->const, and +;;; : the possibility of multiple vars being bound to the same +;;; : slot name. +;;; 2021.02.23 Dan +;;; : * Wasn't catching the possible dynamic action to action +;;; : mappings. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; #+:packaged-actr (in-package :act-r) @@ -90,9 +104,10 @@ ;; a RHS * to a LHS = (declare (ignore p1)) (let* ((ppm (compilation-module-ppm module)) + (p1-bindings (previous-production-bindings (compilation-module-previous module))) + (p2-bindings (production-compilation-instan (production-name p2))) (bindings (when ppm - (append (previous-production-bindings (compilation-module-previous module)) - (production-compilation-instan (production-name p2)))))) + (append p1-bindings p2-bindings)))) (cond (;; The RHS + to LHS = case (and (find p1-index '(4 12 13 20 28 29)) @@ -105,18 +120,82 @@ ;; (let* ((mappings nil) - (p1-slots (compose-rep-slots (find-if (lambda (x) (and (char= #\+ (compose-rep-op x)) (eq buffer (compose-rep-name x)))) (second p1-s)))) - (p2-slots (compose-rep-slots (find-if (lambda (x) (and (char= #\= (compose-rep-op x)) (eq buffer (compose-rep-name x)))) (first p2-s)))) - (interesting-slots (intersection (mapcan (lambda (x) - (when (eq (spec-slot-op x) '=) - (list (spec-slot-name x)))) - p1-slots) - (mapcan (lambda (x) - (when (eq (spec-slot-op x) '=) - (list (spec-slot-name x)))) - p2-slots)))) + (original-p1-slots (compose-rep-slots (find-if (lambda (x) (and (char= #\+ (compose-rep-op x)) (eq buffer (compose-rep-name x)))) (second p1-s)))) + (original-p2-slots (compose-rep-slots (find-if (lambda (x) (and (char= #\= (compose-rep-op x)) (eq buffer (compose-rep-name x)))) (first p2-s)))) + (original-p2-rhs-slots (compose-rep-slots (find-if (lambda (x) (and (eq buffer (compose-rep-name x)) + (or (char= #\= (compose-rep-op x)) + (char= #\* (compose-rep-op x))))) + (second p2-s)))) + (p1-var-slots (mapcar (lambda (x) (assoc (spec-slot-name x) p1-bindings)) (remove-if-not 'chunk-spec-variable-p original-p1-slots :key 'spec-slot-name))) + (p2-var-slots (mapcar (lambda (x) (assoc (spec-slot-name x) p2-bindings)) (remove-if-not 'chunk-spec-variable-p original-p2-slots :key 'spec-slot-name))) + (p2-rhs-var-slots (mapcar (lambda (x) (assoc (spec-slot-name x) p2-bindings)) (remove-if-not 'chunk-spec-variable-p original-p2-rhs-slots :key 'spec-slot-name))) + + (p1-slots (instantiate-slot-names + original-p1-slots + p1-bindings)) + (p2-slots (instantiate-slot-names + original-p2-slots + p2-bindings)) + (p2-rhs-slots (instantiate-slot-names + original-p2-rhs-slots + p2-bindings)) + (interesting-slots (remove-duplicates (append (mapcan (lambda (x) + (when (eq (spec-slot-op x) '=) + (list (spec-slot-name x)))) + p1-slots) + (mapcan (lambda (x) + (when (eq (spec-slot-op x) '=) + (list (spec-slot-name x)))) + p2-slots) + (mapcan (lambda (x) + (when (eq (spec-slot-op x) '=) + (list (spec-slot-name x)))) + p2-rhs-slots))))) - (dolist (slot (remove-duplicates interesting-slots)) + + (dolist (slot interesting-slots) + + (when (or p1-var-slots p2-var-slots p2-rhs-var-slots) ;; there are dynamic slots which may need to be mapped + ;; if the same slot is variablized in both or a var slot maps + ;; to a constant slot in either direction (multiple options + ;; possible as well as multiple variables matching the same slot) + + + (when (and (rassoc slot p1-var-slots) ;; it's a variable in action and condition both + (rassoc slot p2-var-slots)) ;; so need to add all the variable to variable mappings + (dolist (p1-var (mapcar 'car (remove-if-not (lambda (x) (eq (cdr x) slot)) p1-var-slots))) + (dolist (p2-var (mapcar 'car (remove-if-not (lambda (x) (eq (cdr x) slot)) p2-var-slots))) + (push (cons p1-var p2-var) mappings)))) + + (when (and (rassoc slot p1-var-slots) ;; it's a variable in both actions + (rassoc slot p2-rhs-var-slots)) ;; so need to add all the variable to variable mappings + (dolist (p1-var (mapcar 'car (remove-if-not (lambda (x) (eq (cdr x) slot)) p1-var-slots))) + (dolist (p2-var (mapcar 'car (remove-if-not (lambda (x) (eq (cdr x) slot)) p2-rhs-var-slots))) + (push (cons p1-var p2-var) mappings)))) + + + (when (and (rassoc slot p1-var-slots) ;; it's a variable in p1 and const in p2 so need to instantiate + (find slot original-p2-slots :key 'spec-slot-name)) ;; all p1 vars + (dolist (p1-var (mapcar 'car (remove-if-not (lambda (x) (eq (cdr x) slot)) p1-var-slots))) + (push (cons p1-var slot) mappings))) + + (when (and (rassoc slot p1-var-slots) ;; it's a variable in p1 and const in p2 action so need to instantiate + (find slot original-p2-rhs-slots :key 'spec-slot-name)) ;; all p1 vars + (dolist (p1-var (mapcar 'car (remove-if-not (lambda (x) (eq (cdr x) slot)) p1-var-slots))) + (push (cons p1-var slot) mappings))) + + (when (and (rassoc slot p2-var-slots) ;; it's a variable in p2 and const in p1 so need to instantiate + (find slot original-p1-slots :key 'spec-slot-name)) ;; all p2 vars + (dolist (p2-var (mapcar 'car (remove-if-not (lambda (x) (eq (cdr x) slot)) p2-var-slots))) + (push (cons p2-var slot) mappings))) + + (when (and (rassoc slot p2-rhs-var-slots) ;; it's a variable in p2 action and const in p1 so need to instantiate + (find slot original-p1-slots :key 'spec-slot-name)) ;; all p2 vars + (dolist (p2-var (mapcar 'car (remove-if-not (lambda (x) (eq (cdr x) slot)) p2-rhs-var-slots))) + (push (cons p2-var slot) mappings)))) + + + (dolist (p1slots (remove-if-not (lambda (x) (and (eq (spec-slot-op x) '=) (eq (spec-slot-name x) slot))) p1-slots)) (dolist (p2slots (remove-if-not (lambda (x) (and (eq (spec-slot-op x) '=) (eq (spec-slot-name x) slot))) p2-slots)) (if (constant-value-p (spec-slot-value p2slots) module) @@ -142,25 +221,97 @@ (let* ((mappings nil) - (p1-slotsa (compose-rep-slots (find-if (lambda (x) (and (char= #\= (compose-rep-op x)) (eq buffer (compose-rep-name x)))) (first p1-s)))) - (p1-slotsb (compose-rep-slots (find-if (lambda (x) (and (char= #\= (compose-rep-op x)) (eq buffer (compose-rep-name x)))) (second p1-s)))) - (p2-slots (compose-rep-slots (find-if (lambda (x) (and (char= #\= (compose-rep-op x)) (eq buffer (compose-rep-name x)))) (first p2-s)))) + (original-p1a-slots (compose-rep-slots (find-if (lambda (x) (and (char= #\= (compose-rep-op x)) (eq buffer (compose-rep-name x)))) (first p1-s)))) + (original-p1b-slots (compose-rep-slots (find-if (lambda (x) (and (char= #\= (compose-rep-op x)) (eq buffer (compose-rep-name x)))) (second p1-s)))) + + (original-p2-slots (compose-rep-slots (find-if (lambda (x) (and (char= #\= (compose-rep-op x)) (eq buffer (compose-rep-name x)))) (first p2-s)))) + (original-p2-rhs-slots (compose-rep-slots (find-if (lambda (x) (and (eq buffer (compose-rep-name x)) + (or (char= #\= (compose-rep-op x)) + (char= #\* (compose-rep-op x))))) + (second p2-s)))) + + (p1-var-slotsa (mapcar (lambda (x) (assoc (spec-slot-name x) p1-bindings)) (remove-if-not 'chunk-spec-variable-p original-p1a-slots :key 'spec-slot-name))) + (p1-var-slotsb (mapcar (lambda (x) (assoc (spec-slot-name x) p1-bindings)) (remove-if-not 'chunk-spec-variable-p original-p1b-slots :key 'spec-slot-name))) + (p2-var-slots (mapcar (lambda (x) (assoc (spec-slot-name x) p2-bindings)) (remove-if-not 'chunk-spec-variable-p original-p2-slots :key 'spec-slot-name))) + (p2-rhs-var-slots (mapcar (lambda (x) (assoc (spec-slot-name x) p2-bindings)) (remove-if-not 'chunk-spec-variable-p original-p2-rhs-slots :key 'spec-slot-name))) + + (p1-slotsa (instantiate-slot-names + original-p1a-slots + p1-bindings)) + (p1-slotsb (instantiate-slot-names + original-p1b-slots + p1-bindings)) + (p2-slots (instantiate-slot-names + original-p2-slots + p2-bindings)) + (p2-rhs-slots (instantiate-slot-names + original-p2-rhs-slots + p2-bindings)) (p1-slots (append (remove-if (lambda (x) (or (not (eq (spec-slot-op x) '=)) (find (spec-slot-name x) p1-slotsb :key 'spec-slot-name))) p1-slotsa) p1-slotsb)) - (interesting-slots (intersection (mapcan (lambda (x) - (list (spec-slot-name x))) - p1-slots) - (mapcan (lambda (x) - (when (eq (spec-slot-op x) '=) - (list (spec-slot-name x)))) - p2-slots)))) + + (p1-var-slots (remove-duplicates (append p1-var-slotsa p1-var-slotsb) :test 'equalp)) + + (interesting-slots (remove-duplicates (append (mapcan (lambda (x) + (when (eq (spec-slot-op x) '=) + (list (spec-slot-name x)))) + p1-slots) + (mapcan (lambda (x) + (when (eq (spec-slot-op x) '=) + (list (spec-slot-name x)))) + p2-slots) + (mapcan (lambda (x) + (when (eq (spec-slot-op x) '=) + (list (spec-slot-name x)))) + p2-rhs-slots))))) - - (dolist (slot (remove-duplicates interesting-slots)) + (dolist (slot interesting-slots) + + (when (or p1-var-slots p2-var-slots p2-rhs-var-slots) ;; there are dynamic slots which may need to be mapped + ;; if the same slot is variablized in both or a var slot maps + ;; to a constant slot in either direction (multiple options + ;; possible as well as multiple variables matching the same slot) + + + (when (and (rassoc slot p1-var-slots) ;; it's a variable in both + (rassoc slot p2-var-slots)) ;; so need to add all the variable to variable mappings + (dolist (p1-var (mapcar 'car (remove-if-not (lambda (x) (eq (cdr x) slot)) p1-var-slots))) + (dolist (p2-var (mapcar 'car (remove-if-not (lambda (x) (eq (cdr x) slot)) p2-var-slots))) + (push (cons p1-var p2-var) mappings)))) + + (when (and (rassoc slot p1-var-slotsb) ;; it's a variable in both actions + (rassoc slot p2-rhs-var-slots)) ;; so need to add all the variable to variable mappings + (dolist (p1-var (mapcar 'car (remove-if-not (lambda (x) (eq (cdr x) slot)) p1-var-slotsb))) + (dolist (p2-var (mapcar 'car (remove-if-not (lambda (x) (eq (cdr x) slot)) p2-rhs-var-slots))) + (push (cons p1-var p2-var) mappings)))) + + (when (and (rassoc slot p1-var-slots) ;; it's a variable in p1 and const in p2 so need to instantiate + (find slot original-p2-slots :key 'spec-slot-name)) ;; all p1 vars + (dolist (p1-var (mapcar 'car (remove-if-not (lambda (x) (eq (cdr x) slot)) p1-var-slots))) + (push (cons p1-var slot) mappings))) + + (when (and (rassoc slot p1-var-slotsb) ;; it's a variable in p1 and const in p2 action so need to instantiate + (find slot original-p2-rhs-slots :key 'spec-slot-name)) ;; all p1 vars + (dolist (p1-var (mapcar 'car (remove-if-not (lambda (x) (eq (cdr x) slot)) p1-var-slotsb))) + (push (cons p1-var slot) mappings))) + + (when (and (rassoc slot p2-var-slots) ;; it's a variable in p2 and const in p1 (somewhere) so need to instantiate + (or ;; all p2 vars + (find slot original-p1a-slots :key 'spec-slot-name) + (find slot original-p1b-slots :key 'spec-slot-name))) + (dolist (p2-var (mapcar 'car (remove-if-not (lambda (x) (eq (cdr x) slot)) p2-var-slots))) + (push (cons p2-var slot) mappings))) + + (when (and (rassoc slot p2-rhs-var-slots) ;; it's a variable in p2 action and const in p1 so need to instantiate + (find slot original-p1b-slots :key 'spec-slot-name)) ;; all p2 vars + (dolist (p2-var (mapcar 'car (remove-if-not (lambda (x) (eq (cdr x) slot)) p2-rhs-var-slots))) + (push (cons p2-var slot) mappings)))) + + (dolist (p1slots (remove-if-not (lambda (x) (eq (spec-slot-name x) slot)) p1-slots)) (dolist (p2slots (remove-if-not (lambda (x) (eq (spec-slot-name x) slot)) p2-slots)) @@ -188,25 +339,97 @@ (let* ((mappings nil) - (p1-slotsa (compose-rep-slots (find-if (lambda (x) (and (char= #\= (compose-rep-op x)) (eq buffer (compose-rep-name x)))) (first p1-s)))) - (p1-slotsb (compose-rep-slots (find-if (lambda (x) (and (char= #\* (compose-rep-op x)) (eq buffer (compose-rep-name x)))) (second p1-s)))) - (p2-slots (compose-rep-slots (find-if (lambda (x) (and (char= #\= (compose-rep-op x)) (eq buffer (compose-rep-name x)))) (first p2-s)))) + (original-p1a-slots (compose-rep-slots (find-if (lambda (x) (and (char= #\= (compose-rep-op x)) (eq buffer (compose-rep-name x)))) (first p1-s)))) + (original-p1b-slots (compose-rep-slots (find-if (lambda (x) (and (char= #\* (compose-rep-op x)) (eq buffer (compose-rep-name x)))) (second p1-s)))) + + (original-p2-slots (compose-rep-slots (find-if (lambda (x) (and (char= #\= (compose-rep-op x)) (eq buffer (compose-rep-name x)))) (first p2-s)))) + (original-p2-rhs-slots (compose-rep-slots (find-if (lambda (x) (and (eq buffer (compose-rep-name x)) + (or (char= #\= (compose-rep-op x)) + (char= #\* (compose-rep-op x))))) + (second p2-s)))) + + (p1-var-slotsa (mapcar (lambda (x) (assoc (spec-slot-name x) p1-bindings)) (remove-if-not 'chunk-spec-variable-p original-p1a-slots :key 'spec-slot-name))) + (p1-var-slotsb (mapcar (lambda (x) (assoc (spec-slot-name x) p1-bindings)) (remove-if-not 'chunk-spec-variable-p original-p1b-slots :key 'spec-slot-name))) + (p2-var-slots (mapcar (lambda (x) (assoc (spec-slot-name x) p2-bindings)) (remove-if-not 'chunk-spec-variable-p original-p2-slots :key 'spec-slot-name))) + (p2-rhs-var-slots (mapcar (lambda (x) (assoc (spec-slot-name x) p2-bindings)) (remove-if-not 'chunk-spec-variable-p original-p2-rhs-slots :key 'spec-slot-name))) + + (p1-slotsa (instantiate-slot-names + original-p1a-slots + p1-bindings)) + (p1-slotsb (instantiate-slot-names + original-p1b-slots + p1-bindings)) + (p2-slots (instantiate-slot-names + original-p2-slots + p2-bindings)) + (p2-rhs-slots (instantiate-slot-names + original-p2-rhs-slots + p2-bindings)) (p1-slots (append (remove-if (lambda (x) (or (not (eq (spec-slot-op x) '=)) (find (spec-slot-name x) p1-slotsb :key 'spec-slot-name))) p1-slotsa) p1-slotsb)) - (interesting-slots (intersection (mapcan (lambda (x) - (list (spec-slot-name x))) - p1-slots) - (mapcan (lambda (x) - (when (eq (spec-slot-op x) '=) - (list (spec-slot-name x)))) - p2-slots)))) + + (p1-var-slots (remove-duplicates (append p1-var-slotsa p1-var-slotsb) :test 'equalp)) + + (interesting-slots (remove-duplicates (append (mapcan (lambda (x) + (when (eq (spec-slot-op x) '=) + (list (spec-slot-name x)))) + p1-slots) + (mapcan (lambda (x) + (when (eq (spec-slot-op x) '=) + (list (spec-slot-name x)))) + p2-slots) + (mapcan (lambda (x) + (when (eq (spec-slot-op x) '=) + (list (spec-slot-name x)))) + p2-rhs-slots))))) - - (dolist (slot (remove-duplicates interesting-slots)) + (dolist (slot interesting-slots) + + (when (or p1-var-slots p2-var-slots p2-rhs-var-slots) ;; there are dynamic slots which may need to be mapped + ;; if the same slot is variablized in both or a var slot maps + ;; to a constant slot in either direction (multiple options + ;; possible as well as multiple variables matching the same slot) + + + (when (and (rassoc slot p1-var-slots) ;; it's a variable in both + (rassoc slot p2-var-slots)) ;; so need to add all the variable to variable mappings + (dolist (p1-var (mapcar 'car (remove-if-not (lambda (x) (eq (cdr x) slot)) p1-var-slots))) + (dolist (p2-var (mapcar 'car (remove-if-not (lambda (x) (eq (cdr x) slot)) p2-var-slots))) + (push (cons p1-var p2-var) mappings)))) + + (when (and (rassoc slot p1-var-slotsb) ;; it's a variable in both actions + (rassoc slot p2-rhs-var-slots)) ;; so need to add all the variable to variable mappings + (dolist (p1-var (mapcar 'car (remove-if-not (lambda (x) (eq (cdr x) slot)) p1-var-slotsb))) + (dolist (p2-var (mapcar 'car (remove-if-not (lambda (x) (eq (cdr x) slot)) p2-rhs-var-slots))) + (push (cons p1-var p2-var) mappings)))) + + (when (and (rassoc slot p1-var-slots) ;; it's a variable in p1 and const in p2 so need to instantiate + (find slot original-p2-slots :key 'spec-slot-name)) ;; all p1 vars + (dolist (p1-var (mapcar 'car (remove-if-not (lambda (x) (eq (cdr x) slot)) p1-var-slots))) + (push (cons p1-var slot) mappings))) + + (when (and (rassoc slot p1-var-slotsb) ;; it's a variable in p1 and const in p2 action so need to instantiate + (find slot original-p2-rhs-slots :key 'spec-slot-name)) ;; all p1 vars + (dolist (p1-var (mapcar 'car (remove-if-not (lambda (x) (eq (cdr x) slot)) p1-var-slotsb))) + (push (cons p1-var slot) mappings))) + + (when (and (rassoc slot p2-var-slots) ;; it's a variable in p2 and const in p1 (somewhere) so need to instantiate + (or ;; all p2 vars + (find slot original-p1a-slots :key 'spec-slot-name) + (find slot original-p1b-slots :key 'spec-slot-name))) + (dolist (p2-var (mapcar 'car (remove-if-not (lambda (x) (eq (cdr x) slot)) p2-var-slots))) + (push (cons p2-var slot) mappings))) + + (when (and (rassoc slot p2-rhs-var-slots) ;; it's a variable in p2 action and const in p1 so need to instantiate + (find slot original-p1b-slots :key 'spec-slot-name)) ;; all p2 vars + (dolist (p2-var (mapcar 'car (remove-if-not (lambda (x) (eq (cdr x) slot)) p2-rhs-var-slots))) + (push (cons p2-var slot) mappings)))) + + (dolist (p1slots (remove-if-not (lambda (x) (eq (spec-slot-name x) slot)) p1-slots)) (dolist (p2slots (remove-if-not (lambda (x) (eq (spec-slot-name x) slot)) p2-slots)) @@ -243,18 +466,28 @@ (let* ((mappings nil) - (p1-slots (compose-rep-slots (find-if (lambda (x) (and (char= #\= (compose-rep-op x)) (eq buffer (compose-rep-name x)))) (first p1-s)))) - (p2-slots (compose-rep-slots (find-if (lambda (x) (and (char= #\= (compose-rep-op x)) (eq buffer (compose-rep-name x)))) (first p2-s)))) + (original-p1-slots (compose-rep-slots (find-if (lambda (x) (and (char= #\= (compose-rep-op x)) (eq buffer (compose-rep-name x)))) (first p1-s)))) + (original-p2-slots (compose-rep-slots (find-if (lambda (x) (and (char= #\= (compose-rep-op x)) (eq buffer (compose-rep-name x)))) (first p2-s)))) + + (p1-slots (instantiate-slot-names + original-p1-slots + p1-bindings)) + (p2-slots (instantiate-slot-names + original-p2-slots + p2-bindings)) (interesting-slots (intersection (mapcan (lambda (x) - (when (eq (spec-slot-op x) '=) - (list (spec-slot-name x)))) + (when (eq (spec-slot-op x) '=) + (list (spec-slot-name x)))) p1-slots) (mapcan (lambda (x) (when (eq (spec-slot-op x) '=) - (list (spec-slot-name x)))) + (list (spec-slot-name x)))) p2-slots)))) - (dolist (slot (remove-duplicates interesting-slots)) + (dolist (slot interesting-slots) + + ;; no dynamic slot issues because can't make assumptions based on conditions alone + (dolist (p1slots (remove-if-not (lambda (x) (and (eq (spec-slot-op x) '=) (eq (spec-slot-name x) slot))) p1-slots)) (dolist (p2slots (remove-if-not (lambda (x) (and (eq (spec-slot-op x) '=) (eq (spec-slot-name x) slot))) p2-slots)) (if (constant-value-p (spec-slot-value p2slots) module) @@ -295,7 +528,7 @@ ;; the second unioned in and overriding and ;; the + of the second if there is one ;; - (declare (ignore p1 p2)) + (declare (ignore p1)) (let ((c1 (find-if (lambda (x) (and (char= #\= (compose-rep-op x)) (eq buffer (compose-rep-name x)))) (first p1-s))) (c2 (find-if (lambda (x) (and (char= #\= (compose-rep-op x)) (eq buffer (compose-rep-name x)))) (first p2-s))) @@ -308,7 +541,9 @@ (a1+ (find-if (lambda (x) (and (char= #\+ (compose-rep-op x)) (eq buffer (compose-rep-name x)))) (second p1-s))) (a2+ (find-if (lambda (x) (and (char= #\+ (compose-rep-op x)) (eq buffer (compose-rep-name x)))) (second p2-s))) (a1* (find-if (lambda (x) (and (char= #\* (compose-rep-op x)) (eq buffer (compose-rep-name x)))) (second p1-s))) - (a2* (find-if (lambda (x) (and (char= #\* (compose-rep-op x)) (eq buffer (compose-rep-name x)))) (second p2-s)))) + (a2* (find-if (lambda (x) (and (char= #\* (compose-rep-op x)) (eq buffer (compose-rep-name x)))) (second p2-s))) + (bindings (append (previous-production-bindings (compilation-module-previous module)) + (production-compilation-instan (production-name p2))))) (case p1-index ((4 12 13 20 28 29) @@ -323,10 +558,10 @@ (list a1=) (list a1*))) (cond ((and a1+ a2=) - (awhen (buffer+-union a1+ a2=) + (awhen (buffer+-union a1+ a2= bindings) (list it))) ((and a1+ a2*) - (awhen (buffer+-union a1+ a2*) + (awhen (buffer+-union a1+ a2* bindings) (list it))) (a1+ (list a1+)) @@ -334,7 +569,7 @@ nil))))) ((0 8 16 24) (list (append - (awhen (buffer-condition-union c1 c2 a1=) + (awhen (buffer-condition-union c1 c2 a1= bindings) (list it)) (if q1 (list q1) @@ -358,7 +593,7 @@ (list a2+))))) ((9 40 25 56) (list (append - (awhen (buffer-condition-union c1 c2 (if a1= a1= a1*)) + (awhen (buffer-condition-union c1 c2 (if a1= a1= a1*) bindings) (list it)) (if q1 (list q1) @@ -366,14 +601,18 @@ (not (and (= p1-index 40) (or (= p2-index 24) (= p2-index 25) (= p2-index 56))))) (list q2) nil))) - (append (cond ((and a1* a2=) - (awhen (buffer=-union a1* a2=) + (append (cond ((and (or (= p2-index 8) (= p2-index 24)) + (not (find buffer (compilation-module-no-harvest module))) ;; it is strict harvested + (null (second a1=))) ;; the mod in a1 is a null mod + nil) + ((and a1* a2=) + (awhen (buffer=-union a1* a2= bindings) (list it))) ((or a1= a2=) ;; if there's at least one = union those - (awhen (buffer=-union a1= a2=) + (awhen (buffer=-union a1= a2= bindings) (list it))) ((or a1* a2*) ;; if there's at least one * union those - (awhen (buffer=-union a1* a2*) + (awhen (buffer=-union a1* a2* bindings) (list it))) (t nil)) ;; can't have other mix of = and * so just ignore @@ -498,7 +737,18 @@ "Not strict harvested and p2 query must be state free" (and (i-b-c5 buffer module p1 p1-s p1-index p2 p2-s p2-index) (i-b-c3 buffer module p1 p1-s p1-index p2 p2-s p2-index))) - + +(defun I-B-C9 (buffer module p1 p1-s p1-index p2 p2-s p2-index) + (declare (ignore p1 p1-index p2 p2-s p2-index)) + (or (find buffer (compilation-module-no-harvest module)) + (let ((mod (find-if (lambda (x) (and (char= #\= (compose-rep-op x)) (eq buffer (compose-rep-name x)))) (second p1-s)))) + (and mod (null (second mod)))))) + +(defun I-B-C10 (buffer module p1 p1-s p1-index p2 p2-s p2-index) + "Not strict harvested and p2 query must be state free" + (and (i-b-c2 buffer module p1 p1-s p1-index p2 p2-s p2-index) + (i-b-c9 buffer module p1 p1-s p1-index p2 p2-s p2-index))) + (defun imaginal-reason (p1-index p2-index failed-function) (cond ((eql failed-function 'no-rhs-imaginal-ref) @@ -584,13 +834,13 @@ (25 29 I-B-C2) (25 28 I-B-C2) (25 25 I-B-C2) - (25 24 I-B-C6) + (25 24 I-B-C10) (25 20 I-B-C2) (25 16 I-B-C2) (25 13 T) (25 12 T) (25 9 T) - (25 8 I-B-C5) + (25 8 I-B-C9) (25 4 T) (25 0 T) (24 56 I-B-C6) @@ -648,13 +898,13 @@ (9 29 T) (9 28 T) (9 25 T) - (9 24 I-B-C5) + (9 24 I-B-C9) (9 20 T) (9 16 T) (9 13 T) (9 12 T) (9 9 T) - (9 8 I-B-C5) + (9 8 I-B-C9) (9 4 T) (9 0 T) (8 56 I-B-C5) diff --git a/tools/perceptual-compilation.lisp b/tools/perceptual-compilation.lisp index a2589a5..b808a68 100644 --- a/tools/perceptual-compilation.lisp +++ b/tools/perceptual-compilation.lisp @@ -49,6 +49,10 @@ ;;; : being a chunk in the buffer and a query that it's empty. ;;; 2020.11.10 Dan ;;; : * Fixed the typo of modfication in the failure strings. +;;; 2021.02.17 Dan +;;; : * Updated the calls to buffer-condition-union since that needs +;;; : a 4th parameter of bindings that may be needed deal with +;;; : dynamic issues (not needed for perceptual). ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; #+:packaged-actr (in-package :act-r) @@ -108,7 +112,7 @@ (list a1+)))) (8 (list (append - (awhen (buffer-condition-union c1 c2 nil) + (awhen (buffer-condition-union c1 c2 nil nil) (list it)) (if q2 (if (find buffer (compilation-module-no-harvest module)) @@ -124,7 +128,7 @@ (list a2+)))) ((16 24) (list (append - (awhen (buffer-condition-union c1 c2 nil) + (awhen (buffer-condition-union c1 c2 nil nil) (list it)) (when q1 (list q1))) diff --git a/tutorial/lisp/bst-ppm.lisp b/tutorial/lisp/bst-ppm.lisp index aefdba7..8697971 100644 --- a/tutorial/lisp/bst-ppm.lisp +++ b/tutorial/lisp/bst-ppm.lisp @@ -1,3 +1,20 @@ +; ACT-R tutorial unit8 building sticks experiment. +; This experiment displays three posssible sticks +; which can be used to create a given target stick's +; length. It is an isomorph of Luchins water jug +; problem, and the experiment for the model is the +; one from: +; +; Lovett, M. C., & Anderson, J. R. (1996). History of success +; and current context in problem solving: Combined influences +; on operator selection. Cognitive Psychology, 31, 168-217. +; +; The task is presented with buttons to pick the sticks +; and a button to reset the current trial. + + +; Global variables to hold the information about the +; current trial information. (defvar *target*) (defvar *current-stick*) @@ -7,6 +24,9 @@ (defvar *window* nil) (defvar *visible* nil) +; The data from the experiment, the lengths of the sticks +; used in the experiment, and two example problems for +; demonstration. (defvar *bst-exp-data* '(20.0 67.0 20.0 47.0 87.0 20.0 80.0 93.0 83.0 13.0 29.0 27.0 80.0 73.0 53.0)) @@ -22,6 +42,9 @@ (defvar *no-learn-stims* '((15 200 41 103)(10 200 29 132))) +; build-display takes the lengths of the sticks for a trial. +; It sets the global variables and draws the initial interface. + (defun build-display (a b c goal) (setf *target* goal) @@ -41,6 +64,13 @@ (add-line-to-exp-window *window* (list 75 85) (list (+ c 75) 85) 'black) (add-line-to-exp-window *window* (list 75 110) (list (+ goal 75) 110) 'green)) + +; button-pressed will be added as the bst-button-pressed command +; for use as the action of the stick choice buttons. It takes +; a parameter to indicate the length of the stick and whether +; the stick is associated with under or over shoot as a first +; choice. + (defun button-pressed (len dir) (unless *choice* (setf *choice* dir)) @@ -51,16 +81,30 @@ (incf *current-stick* len)) (update-current-line))) +; reset-display will be added as the bst-reseet-button-pressed +; command for use as the action of the reset buttons. If the +; trial is not over, then it sets the current stick length to 0 +; and redraws it. (defun reset-display () (unless *done* (setf *current-stick* 0) (update-current-line))) +; Add the commands for those two functions so they can be +; used as button actions. (add-act-r-command "bst-ppm-button-pressed" 'button-pressed "Choice button action for the Building Sticks Task. Do not call directly") (add-act-r-command "bst-ppm-reset-button-pressed" 'reset-display "Reset button action for the Building Sticks Task. Do not call directly") +; update-current-line compares the length of the current +; stick to the target stick length. If they match the +; the trial is over, it redraws the current line, and +; displays the done prompt. If it is zero it removes the +; line from the display. If there is a current line then +; it is updated to match the current length, and if there +; is not a current line then one is drawn and saved for +; future modification. (defun update-current-line () (cond ((= *current-stick* *target*) @@ -76,6 +120,13 @@ (t (setf *current-line* (add-line-to-exp-window *window* (list 75 135) (list (+ *current-stick* 75) 135) 'blue))))) +; do-experiment takes a required parameter which is +; a list of stick lengths and an optional parameter +; which indicates whether a person is doing the task. +; It draws the initial sticks and then waits for +; a person to complete the task or runs the model +; for up to a minute to do the task. + (defun do-experiment (sticks &optional human) (apply 'build-display sticks) (if human @@ -86,6 +137,10 @@ (start-hand-at-mouse) (run 60 *visible*)))) +; wait-for-human takes no parameters. It waits for +; a person to finish the task, and then waits one +; more second after the done prompt is displayed to +; give the person a chance to read it. (defun wait-for-human () (while (not *done*) @@ -95,6 +150,18 @@ (while (< (- (get-time nil) start-time) 1000) (process-events)))) +; bst-set takes three required parameters and one optional +; parameter. The first parameter indicates whether it +; is a person or the model performing the task, and the +; second indicates whether it should use a visible or +; virtual window. The third parameter is a list of +; stick lengths for the trials to present. The optional +; parameter indicates whether the model should learn from +; trial to trial or be reset before each new trial. +; It returns a list of strings indicating whether each +; trial presented was started with the over-shoot or +; under-shoot approach. + (defun bst-set (human visible stims &optional (learn t)) (setf *visible* visible) (let ((result nil)) @@ -105,6 +172,18 @@ (push *choice* result)) (reverse result))) +; bst-test is used to run multiple instances of the 2 demo +; problems. It takes one required parameter which indicates +; how many times to run that set of two items, and an optional +; parameter to indicate if it should be a person or model +; doing the task. It returns a list with the counts of the +; times over-shoot was tried on each of the problems. +; When the model runs the task it is not learning, and starts +; each trial as if it were the first time doing the task. +; If the model is running once through the set then it will +; use a visible window to show the interaction, otherwise it +; will use a virtual window. + (defun bst-test (n &optional human) (let ((stims *no-learn-stims*)) @@ -116,6 +195,18 @@ (if (string-equal x "over") 1 0)) (bst-set human (or human (= n 1)) stims nil)))))))) +; bst-ppm-experiment is used to run the full experiment multiple +; times and report the results and fit to the experiment data. +; It has a required parameter which indicates how many times +; to run the task, and an optional parameter indicating whether +; it should be a person performing the task. +; It collects the over- or under- shoot choices for each problem +; and computes the proportion of time it's chosen for comparison +; to the original data. It displays the data and its fit to the +; data from the original experiment along with the average utility +; value over the trials for the productions in the model which make +; the choice of strategy. + (defun bst-ppm-experiment (n &optional human) (let ((stims *exp-stims*)) @@ -148,16 +239,32 @@ (dolist (x p-values) (format t "~12s: ~6,4f~%" (car x) (/ (second x) n)))))) +; production-u-value returns the current :u parameter +; value from the indicated production. + (defun production-u-value (prod) (caar (spp-fct (list prod :u)))) +; A similarity hook function to return +; similarity values between numbers which +; are expected to be line lengths. + (defun number-sims (a b) (when (and (numberp a) (numberp b)) (/ (abs (- a b)) -300))) - (add-act-r-command "bst-number-sims" 'number-sims "Similarity hook function for building sticks task.") +; The compute-difference function is used as the +; function called by an imaginal-action buffer +; request. It creates a chunk which is a copy of +; the chunk in the imaginal buffer and adds a +; slot called difference which holds the difference +; between the length of the current line and the +; target line. That chunk's name is returned +; so that the imaginal module will place it into +; the imaginal buffer. + (defun compute-difference () (let* ((chunk (buffer-read 'imaginal)) (new-chunk (copy-chunk-fct chunk))) @@ -166,4 +273,8 @@ (add-act-r-command "bst-compute-difference" 'compute-difference "Imaginal action function to compute the difference between sticks.") +; Load the corresponding ACT-R starting model. +; Done after adding the bst-compute-difference and bst-number-sims +; commands because they are used in the model and should exist first. + (load-act-r-model "ACT-R:tutorial;unit8;bst-ppm-model.lisp") diff --git a/tutorial/lisp/bst.lisp b/tutorial/lisp/bst.lisp index 8c4c1b8..51326d4 100644 --- a/tutorial/lisp/bst.lisp +++ b/tutorial/lisp/bst.lisp @@ -1,6 +1,25 @@ +; ACT-R tutorial unit6 building sticks experiment. +; This experiment displays three posssible sticks +; which can be used to create a given target stick's +; length. It is an isomorph of Luchins water jug +; problem, and the experiment for the model is the +; one from: +; +; Lovett, M. C., & Anderson, J. R. (1996). History of success +; and current context in problem solving: Combined influences +; on operator selection. Cognitive Psychology, 31, 168-217. +; +; The task is presented with buttons to pick the sticks +; and a button to reset the current trial. + + +; Load the corresponding ACT-R starting model. (load-act-r-model "ACT-R:tutorial;unit6;bst-model.lisp") +; Global variables to hold the information about the +; current trial information. + (defvar *target*) (defvar *current-stick*) (defvar *current-line*) @@ -9,6 +28,9 @@ (defvar *window* nil) (defvar *visible* nil) +; The data from the experiment, the lengths of the sticks +; used in the experiment, and two example problems for +; demonstration. (defvar *bst-exp-data* '(20.0 67.0 20.0 47.0 87.0 20.0 80.0 93.0 83.0 13.0 29.0 27.0 80.0 73.0 53.0)) @@ -24,6 +46,10 @@ (defvar *no-learn-stims* '((15 200 41 103)(10 200 29 132))) + +; build-display takes the lengths of the sticks for a trial. +; It sets the global variables and draws the initial interface. + (defun build-display (a b c goal) (setf *target* goal) @@ -33,26 +59,52 @@ (setf *current-line* nil) (setf *window* (open-exp-window "Building Sticks Task" :visible *visible* :width 600 :height 400)) + ; Add buttons for the participant to press in the window. + ; The :action specifies a command to call and any parameters to pass it + ; when that button is pressed. The others describe the details of how + ; the button is shown. + (add-button-to-exp-window *window* :text "A" :x 5 :y 23 :action (list "bst-button-pressed" a "under") :height 24 :width 40) (add-button-to-exp-window *window* :text "B" :x 5 :y 48 :action (list "bst-button-pressed" b "over") :height 24 :width 40) (add-button-to-exp-window *window* :text "C" :x 5 :y 73 :action (list "bst-button-pressed" c "under") :height 24 :width 40) (add-button-to-exp-window *window* :text "Reset" :x 5 :y 123 :action "bst-reset-button-pressed" :height 24 :width 65) + ; Draw the lines for the choices and target. + (add-line-to-exp-window *window* (list 75 35) (list (+ a 75) 35) 'black) (add-line-to-exp-window *window* (list 75 60) (list (+ b 75) 60) 'black) (add-line-to-exp-window *window* (list 75 85) (list (+ c 75) 85) 'black) (add-line-to-exp-window *window* (list 75 110) (list (+ goal 75) 110) 'green)) +; button-pressed will be added as the bst-button-pressed command +; for use as the action of the stick choice buttons. It takes +; a parameter to indicate the length of the stick and whether +; the stick is associated with under or over shoot as a first +; choice. + (defun button-pressed (len dir) + + ; If there is no choice recorded for this trial + ; set that to dir. + (unless *choice* (setf *choice* dir)) + ; If the trial is not done then add or subtract + ; this stick from the target as appropriate and + ; call update-current-line to check its length + ; and redraw it. + (unless *done* (if (> *current-stick* *target*) (decf *current-stick* len) (incf *current-stick* len)) (update-current-line))) +; reset-display will be added as the bst-reseet-button-pressed +; command for use as the action of the reset buttons. If the +; trial is not over, then it sets the current stick length to 0 +; and redraws it. (defun reset-display () (unless *done* @@ -60,9 +112,20 @@ (update-current-line))) +; Add the commands for those two functions so they can be +; used as button actions. + (add-act-r-command "bst-button-pressed" 'button-pressed "Choice button action for the Building Sticks Task. Do not call directly") (add-act-r-command "bst-reset-button-pressed" 'reset-display "Reset button action for the Building Sticks Task. Do not call directly") +; update-current-line compares the length of the current +; stick to the target stick length. If they match the +; the trial is over, it redraws the current line, and +; displays the done prompt. If it is zero it removes the +; line from the display. If there is a current line then +; it is updated to match the current length, and if there +; is not a current line then one is drawn and saved for +; future modification. (defun update-current-line () (cond ((= *current-stick* *target*) @@ -78,17 +141,34 @@ (t (setf *current-line* (add-line-to-exp-window *window* (list 75 135) (list (+ *current-stick* 75) 135) 'blue))))) +; do-experiment takes a required parameter which is +; a list of stick lengths and an optional parameter +; which indicates whether a person is doing the task. +; It draws the initial sticks and then waits for +; a person to complete the task or runs the model +; for up to a minute to do the task. + (defun do-experiment (sticks &optional human) (apply 'build-display sticks) (if human (when (visible-virtuals-available?) (wait-for-human)) (progn + + ; Make sure the model is interacting with + ; the current display and that it has its + ; right hand on the virtual mouse cursor. + (install-device *window*) (start-hand-at-mouse) (run 60 *visible*)))) +; wait-for-human takes no parameters. It waits for +; a person to finish the task, and then waits one +; more second after the done prompt is displayed to +; give the person a chance to read it. + (defun wait-for-human () (while (not *done*) (process-events)) @@ -97,6 +177,18 @@ (while (< (- (get-time nil) start-time) 1000) (process-events)))) +; bst-set takes three required parameters and one optional +; parameter. The first parameter indicates whether it +; is a person or the model performing the task, and the +; second indicates whether it should use a visible or +; virtual window. The third parameter is a list of +; stick lengths for the trials to present. The optional +; parameter indicates whether the model should learn from +; trial to trial or be reset before each new trial. +; It returns a list of strings indicating whether each +; trial presented was started with the over-shoot or +; under-shoot approach. + (defun bst-set (human visible stims &optional (learn t)) (setf *visible* visible) (let ((result nil)) @@ -107,6 +199,18 @@ (push *choice* result)) (reverse result))) +; bst-test is used to run multiple instances of the 2 demo +; problems. It takes one required parameter which indicates +; how many times to run that set of two items, and an optional +; parameter to indicate if it should be a person or model +; doing the task. It returns a list with the counts of the +; times over-shoot was tried on each of the problems. +; When the model runs the task it is not learning, and starts +; each trial as if it were the first time doing the task. +; If the model is running once through the set then it will +; use a visible window to show the interaction, otherwise it +; will use a virtual window. + (defun bst-test (n &optional human) (let ((stims *no-learn-stims*)) @@ -118,6 +222,18 @@ (if (string-equal x "over") 1 0)) (bst-set human (or human (= n 1)) stims nil)))))))) +; bst-experiment is used to run the full experiment multiple +; times and report the results and fit to the experiment data. +; It has a required parameter which indicates how many times +; to run the task, and an optional parameter indicating whether +; it should be a person performing the task. +; It collects the over- or under- shoot choices for each problem +; and computes the proportion of time it's chosen for comparison +; to the original data. It displays the data and its fit to the +; data from the original experiment along with the average utility +; value over the trials for each of the four productions in the +; model which make the choice. + (defun bst-experiment (n &optional human) (let ((stims *exp-stims*)) @@ -129,6 +245,9 @@ (mapcar (lambda (x) (if (string-equal x "over") 1 0)) (bst-set human human stims)))) + + ; Use no-output to suppress the output from the spp command + (no-output (setf p-values (mapcar (lambda (x) (list (car x) (+ (second x) (production-u-value (car x))))) @@ -150,5 +269,8 @@ (dolist (x p-values) (format t "~12s: ~6,4f~%" (car x) (/ (second x) n)))))) +; production-u-value returns the current :u parameter +; value from the indicated production. + (defun production-u-value (prod) (caar (spp-fct (list prod :u)))) diff --git a/tutorial/lisp/categorize.lisp b/tutorial/lisp/categorize.lisp index 709e2ac..130ae9d 100644 --- a/tutorial/lisp/categorize.lisp +++ b/tutorial/lisp/categorize.lisp @@ -1,3 +1,21 @@ +; ACT-R tutorial unit8 categorization experiment. +; This task sequentially presents the model with +; features which the model must classify as +; being small, medium, or large given a numeric +; description, and then after those features have +; been encoded it must make a choice as to which +; category of items it belongs based on the +; examples that it has pre-encoded in declarative +; memory. It is an abstraction and simplification +; of a face categorizing task: +; +; Nosofsky, R. M. (1991). Tests of an exemplar model for relating +; perceptual classification and recognition memory. Journal of Experimental +; Psychology: Human Perception and Performance. 17, 3-27. +; + +; These are the feature sets for the categories (based on +; the general values). (defvar *cat1* '((small large medium small) (medium small large medium) @@ -11,6 +29,11 @@ (large small large large) (large small small large))) + +; This is the data indicating the category 1 choice proportions +; for the set of stims below (represented by their underlying +; normalized numeric values) + (defparameter *cat-data* '(0.975 0.85 0.987 1.0 0.963 0.075 0.138 0.087 0.05 0.025 0.937 0.544 0.988 0.087)) (defparameter *stims* '((-1.025 0.493 0.048 -0.666) @@ -28,12 +51,20 @@ (-0.856 0.197 0.241 0.007) (0.704 -0.287 -0.164 0.178))) + +; Global values for the similarity distribution, the mapping of +; sizes to an anchor point, the default slot names, and the +; offset to use for the presented stimulus values. + (defparameter *sigma2* .15) (defparameter *size-mappings* (list (cons "small" -.9) (cons "medium" 0) (cons "large" .9))) (defparameter *slots* '(eh es nl mh)) - (defvar *attribute-offset* 0) +; Functions for computing the similarity values using a +; normal distribution around the anchor point for a value +; and then scaling them from -1 to 0. + (defun scale-sim (x max) (- (/ x max) 1.0)) @@ -42,7 +73,6 @@ (defparameter *max-norm* (normal 0 *sigma2* 0)) - (defun size-similarities (a b) (let ((number (if (numberp b) (- b *attribute-offset*) nil)) (size (if (find a '("small" "medium" "large") :test 'string-equal) a nil))) @@ -52,6 +82,15 @@ (add-act-r-command "size-similarities" 'size-similarities "Categorize model's similarity hook function.") +; categorize-stimulus resets the model and then presents the four +; feature values provided (which should be numbers from -2 to 2) to +; the model with the default slot names for features and then +; creates a goal chunk with state categorize for the model to +; determine a category for the features it encoded. If the +; model provides a category of 1 or 2 (by setting the category slot +; of the chunk in the imaginal buffer) then that value is +; returned, otherwise it returns nil. + (defun categorize-stimulus (a b c d) (setf *attribute-offset* 0) (setf *slots* '(EH ES NL MH)) @@ -60,13 +99,38 @@ (if (zerop (car result)) 2 1)))) +; categorize-attribute takes two values which represent the +; name and value for an attribute in the task. it presents +; the attribute to the model by setting slots of the chunk in +; the goal buffer and then running the model. The state slot +; is set to add-attribute, the name slot is set to the name +; provided, and the value slot is set to the value provided. +; The model should encode that value into a general description +; (small, medium, or large) and store that into a slot of the +; chunk in the imaginal buffer with the provided name. +; It does not reset the model. + (defmacro categorize-attribute (name value) `(present-one-attribute-fct ',name ,value)) +; Create a new chunk for the goal buffer with the values provided +; and run the model. + (defun present-one-attribute-fct (name value) - (goal-focus-fct (car (define-chunks-fct `((state add-attribute name ,name value ,(+ *attribute-offset* value)))))) + (schedule-set-buffer-chunk 'goal `(state add-attribute name ,name value ,(+ *attribute-offset* value)) 0) (run 20)) +; categorize-experiment takes one required value which +; is how many times to run the whole experiment (one presentation +; of each of the 14 testing stims). It has one optional parameter +; which indicates an offset to add to the values that are presented +; if it is provided, and accepts 4 additional parameters which +; specify the names of the attributes to present to the model (the +; default names will be used if none are provided). It runs the +; experiments, determines the proportion of category choices for +; each item, reports the fit to the experimental data, and prints +; out the proportion of choices for category 1. + (defmacro categorize-experiment (n &optional offset &rest slots) `(categorize-fct ,n ,offset ',slots)) @@ -125,21 +189,29 @@ (dolist (x (permute-list (mapcar 'cons *slots* stim))) (present-one-attribute-fct (car x) (cdr x))) - (let ((goal (car (define-chunks-fct '((state categorize)))))) - (goal-focus-fct goal) - (run 20) - (let ((category (chunk-slot-value-fct (buffer-read 'imaginal) 'category))) - - (cond ((not (numberp category)) - (model-output "Model did not provide a category.") - (cons 0 0)) - ((= 1 category) - (cons 1 1)) - ((= 2 category) - (cons 0 1)) - (t - (model-output "Model provided invalid category.") - (cons 0 0)))))) + (schedule-set-buffer-chunk 'goal '(state categorize) 0) + (run 20) + (let ((category (chunk-slot-value-fct (buffer-read 'imaginal) 'category))) + + (cond ((not (numberp category)) + (model-output "Model did not provide a category.") + (cons 0 0)) + ((= 1 category) + (cons 1 1)) + ((= 2 category) + (cons 0 1)) + (t + (model-output "Model provided invalid category.") + (cons 0 0))))) + +; create-example-memories is called in the model +; definition to add chunks for the training examples +; to the model's declarative memory. The chunks are +; created with the appropriate slots for the features +; based on the values provided by the modeler to +; run the experiment or the default slots if not +; running the experiment or alternate names were +; not provided. (defun create-example-memories () (dolist (x *slots*) @@ -153,4 +225,8 @@ (add-act-r-command "create-example-memories" 'create-example-memories "Categorize task function to add the initial example chunks to simulate the training process.") +; Need to load the model after the "create-example-memories" command +; has been added since that command is called during the model +; creation. + (load-act-r-model "ACT-R:tutorial;unit8;categorize-model.lisp") diff --git a/tutorial/lisp/demo2.lisp b/tutorial/lisp/demo2.lisp index 3633644..dabd898 100644 --- a/tutorial/lisp/demo2.lisp +++ b/tutorial/lisp/demo2.lisp @@ -1,43 +1,130 @@ +; ACT-R tutorial unit 2 demo2 task. +; This experiment opens a window, displays a character, +; waits for a keypress, clears the window after there +; is a keypress, and then reports the key that was pressed. + +; Start by loading the corresponding tutorial model + (load-act-r-model "ACT-R:tutorial;unit2;demo2-model.lisp") + +; Create a variable to store the key that was pressed. + (defvar *response* nil) +; This is the function which we will have ACT-R call when +; a key is pressed in the experiment window which is signaled +; by the output-key action. +; That action provides two parameters to the function called. +; The first is the name of the model that performed the keypress +; or nil if it wasn't generated by a model, and the second +; is a string with the name of the key that was pressed. + (defun respond-to-key-press (model key) + ; we aren't using the model so declare that to avoid warnings + (declare (ignore model)) + ; store the key that was pressed in the *response* variable + (setf *response* key) + + ; call the AGI command that clears the window + (clear-exp-window)) +; This is the function that runs the experiment for either a +; person or a model. It has one optional parameter which if +; provided as a true value (anything not nil) will run a person. +; If it is not provided or nil is specified then it will run the +; ACT-R model. + (defun demo2-experiment (&optional human) + ; Reset the ACT-R system and any models that are defined to + ; their initial states. + (reset) + ; Create three variable: + ; items - a randomized list of letter strings which is randomized + ; using the ACT-R function permute-list + ; text1 - the first string from the randomized list which will be the + ; one presented in the experiment + ; window - the ACT-R window device list returned by using the ACT-R + ; function open-exp-window to create a new window for + ; displaying the experiment + (let* ((items (permute-list '("B" "C" "D" "F" "G" "H" "J" "K" "L" "M" "N" "P" "Q" "R" "S" "T" "V" "W" "X" "Y" "Z"))) (text1 (first items)) (window (open-exp-window "Letter recognition"))) + ; display the text1 item in the window that was opened + (add-text-to-exp-window window text1 :x 125 :y 150) + ; These next two function calls are how we tell ACT-R that it should + ; call our respond-to-key-press function when there is a keypress + ; in the experiment. + + ; First we need to create a command in ACT-R that corresponds + ; to our function so that ACT-R is able to use the function. + (add-act-r-command "demo2-key-press" 'respond-to-key-press "Demo2 task output-key monitor") + + ; Then, we use that command which we created to 'monitor' + ; the output-key action which is triggered by keypress in the + ; experiment window of ACT-R so that when an output-key happens + ; our function is called. + (monitor-act-r-command "output-key" "demo2-key-press") + ; Set the *response* value to nil to remove any value it may + ; have from a previous run of the experiment. + (setf *response* nil) + ; Here is where we actually "run" the experiment. + ; It either waits for a person to press a key or runs ACT-R + ; for up to 10 seconds giving the model a chance to do the + ; experiment. + (if human + + ; If a person is doing the task then for safety + ; we make sure there is a visible window that they + ; can use to do the task, and if so, loop until the + ; *response* variable is non-nil calling the + ; process-events function to allow the system a + ; chance to handle any interactions. + (when (visible-virtuals-available?) (while (null *response*) (process-events))) + ; If it is not a human then use install-device so that + ; the features in the window will be seen by the model + ; (that will also automatically provide the model with + ; access to a virtual keyboard and mouse). Then use + ; the ACT-R run function to run the model for up to 10 + ; seconds in real-time mode. + (progn (install-device window) (run 10 t))) + ; To avoid any issues with our function for keypresses in this + ; experiment interfering with other experiments we should stop + ; monitoring output-key and then remove our command. + (remove-act-r-command-monitor "output-key" "demo2-key-press") (remove-act-r-command "demo2-key-press") + ; return the result of the keypress + *response*)) diff --git a/tutorial/lisp/fan-no-pm.lisp b/tutorial/lisp/fan-no-pm.lisp index 70a0417..e3fb42f 100644 --- a/tutorial/lisp/fan-no-pm.lisp +++ b/tutorial/lisp/fan-no-pm.lisp @@ -1,6 +1,28 @@ +; ACT-R tutorial unit 5 fan task. +; This experiment presents a model with a person-location pair +; of items and the model must respond whether that pair of items +; was part of the study set that it has recorded in memory. +; The task and data to which the model is fit are in the paper: +; +; Anderson, J. R. (1974). Retrieval of propositional information from +; long-term memory. Cognitive Psychology, 5, 451 - 474. +; +; The results are reported are the time to respond to the probe +; based on the 'fan' of the items presented (how many places a person +; is in or how many people are in the place) and whether the probe +; is or isn't in the test set. +; +; This version of the task does not use the perceptual or motor +; modules of ACT-R and instead places the probes directly into +; slots of the goal buffer and reads the model's response from +; a slot of the goal buffer when done. + +; Load the corresponding model for the task. (load-act-r-model "ACT-R:tutorial;unit5;fan-no-pm-model.lisp") +; Create a variable with the original experiment data. + (defvar *person-location-data* '(1.11 1.17 1.22 1.17 1.20 1.22 1.15 1.23 1.36 @@ -8,23 +30,49 @@ 1.25 1.36 1.29 1.26 1.47 1.47)) +; The fan-sentence function takes 4 parameters. +; The first two are the strings of the person and location +; to present. The third is t or nil to indicate whether +; this was or wasn't in the study set, and the last is +; either the symbol person or location to indicate which +; of the productions the model should use for retrieval. +; +; It presents the probe items given directly to the model +; through the goal buffer, runs the model, and +; returns a list indicating how many seconds the model +; ran and t or nil to indicate if the response was correct. + (defun fan-sentence (person location target term) (reset) + ; disable the production that isn't being used for retrieval + (case term (person (pdisable retrieve-from-location)) (location (pdisable retrieve-from-person))) + ; modify the chunk named goal (which will be set in the goal buffer + ; when the model runs) to set the arg1 and arg2 slots to the probe + ; items and state slot to test + (mod-chunk-fct 'goal (list 'arg1 person 'arg2 location 'state 'test)) + ; run the model recording the time spent running + ; and get the value from the state slot of the goal buffer representing the + ; model's response to the task + (let ((response-time (run 30.0)) - (response (chunk-slot-value-fct (buffer-read 'goal) 'state))) + (response (buffer-slot-value 'goal 'state))) (list response-time (or (and target (string-equal response "k")) (and (null target) (string-equal response "d")))))) - +; do-person-location requires one parameter which is either +; the symbol person or location to indicate which of the +; productions the model should use for retrieval. +; It runs one trial of each fan condition and returns a list +; of the results. (defun do-person-location (term) (let ((test-set '(("lawyer" "store" t)("captain" "cave" t)("hippie" "church" t) @@ -42,6 +90,10 @@ (reverse results))) +; fan-experiment runs the model through one trial of +; each condition using each of the retrieval productions +; and averages the results then displays the results. + (defun fan-experiment () (output-person-location (mapcar (lambda (x y) (list (/ (+ (car x) (car y)) 2.0) diff --git a/tutorial/lisp/fan.lisp b/tutorial/lisp/fan.lisp index 81ed6cf..2f73f75 100644 --- a/tutorial/lisp/fan.lisp +++ b/tutorial/lisp/fan.lisp @@ -1,6 +1,26 @@ +; ACT-R tutorial unit 5 fan task. +; This experiment presents a model with a person-location pair +; of items and the model must respond whether that pair of items +; was part of the study set that it has recorded in memory. +; The task and data to which the model is fit are in the paper: +; +; Anderson, J. R. (1974). Retrieval of propositional information from +; long-term memory. Cognitive Psychology, 5, 451 - 474. +; +; The results are reported are the time to respond to the probe +; based on the 'fan' of the items presented (how many places a person +; is in or how many people are in the place) and whether the probe +; is or isn't in the test set. +; +; This version of the task presents the probe items in a window +; which the model must read to complete the task. + +; Load the corresponding model for the task. (load-act-r-model "ACT-R:tutorial;unit5;fan-model.lisp") +; Create a variable with the original experiment data. + (defvar *person-location-data* '(1.11 1.17 1.22 1.17 1.20 1.22 1.15 1.23 1.36 @@ -8,9 +28,24 @@ 1.25 1.36 1.29 1.26 1.47 1.47)) +; create variables to hold the model's response and the time of +; that response. + (defvar *response*) (defvar *response-time*) +; The fan-sentence function takes 4 parameters. +; The first two are the strings of the person and location +; to present. The third is t or nil to indicate whether +; this was or wasn't in the study set, and the last is +; either the symbol person or location to indicate which +; of the productions the model should use for retrieval. +; +; It presents the probe items given in a window, runs the +; model, and returns a list indicating how many seconds it +; took to respond (or 30 if no response was made) and t or nil +; to indicate if the response was correct. + (defun fan-sentence (person location target term) (reset) @@ -26,6 +61,8 @@ (add-act-r-command "fan-response" 'respond-to-key-press "Fan experiment model response") (monitor-act-r-command "output-key" "fan-response") + ; disable the production that isn't being used for retrieval + (case term (person (pdisable retrieve-from-location)) (location (pdisable retrieve-from-person))) @@ -48,12 +85,21 @@ (and (null target) (string-equal *response* "d"))))))) +; respond-to-key-press is set to monitor the output-key command +; and records the time and key that was pressed by the model. + (defun respond-to-key-press (model key) (declare (ignore model)) (setf *response-time* (get-time)) (setf *response* key)) +; do-person-location requires one parameter which is either +; the symbol person or location to indicate which of the +; productions the model should use for retrieval. +; It runs one trial of each fan condition and returns a list +; of the results. + (defun do-person-location (term) (let ((results nil)) @@ -80,6 +126,9 @@ (reverse results))) +; fan-experiment runs the model through one trial of +; each condition using each of the retrieval productions +; and averages the results then displays the results. (defun fan-experiment () (output-person-location (mapcar (lambda (x y) diff --git a/tutorial/lisp/grouped.lisp b/tutorial/lisp/grouped.lisp index cb02e0a..8dcf6d7 100644 --- a/tutorial/lisp/grouped.lisp +++ b/tutorial/lisp/grouped.lisp @@ -1,8 +1,22 @@ +; ACT-R tutorial unit 5 grouped task. +; This is a simple example task to show partial matching. +; It simply runs the model and records values that the +; model provides and returns the list of provided values +; in the order provided after the run. + +; Load the corresponding model for the task. (load-act-r-model "ACT-R:tutorial;unit5;grouped-model.lisp") +; Create a varaiable to hold the values from the model + (defvar *response* nil) +; The recall function creates a command for +; the record-response function, clears the response +; list, runs the model, and returns the response list +; in the order provided by the model. + (defun grouped-recall () (add-act-r-command "grouped-response" 'record-response "Response recording function for the tutorial grouped model.") (setf *response* nil) @@ -11,5 +25,7 @@ (remove-act-r-command "grouped-response") (reverse *response*)) +; Store a value provided by the model on the response list + (defun record-response (value) (push value *response*)) diff --git a/tutorial/lisp/onehit.lisp b/tutorial/lisp/onehit.lisp index eb1cc02..de69182 100644 --- a/tutorial/lisp/onehit.lisp +++ b/tutorial/lisp/onehit.lisp @@ -1,3 +1,19 @@ +; ACT-R tutorial unit 5 one-hit blackjack task +; +; This file implements the one-hit blackjack game +; that is described in the unit text and allows +; one to run a model against a human opponent or +; an opponent controlled by functions created +; to play the game. It also allows one to control +; the decks of cards that are used to provide +; different situations for the model to learn. + + +; Before loading the model define the function +; that will be used to compute the similarities +; between numbers and add a command for it because +; that command name is used in the model's parameter +; settings. (defun 1hit-bj-number-sims (a b) (when (and (numberp a) (numberp b)) @@ -8,6 +24,12 @@ (load-act-r-model "ACT-R:tutorial;unit5;1hit-blackjack-model.lisp") + +; Define a lot of global variables to control the +; details of the game, a code-based opponent, +; record responses, and keep track of whether the +; output-key action is being monitored. + (defvar *deck1*) (defvar *deck2*) (defvar *opponent-rule*) @@ -17,11 +39,23 @@ (defvar *opponent-threshold*) (defvar *key-monitor-installed* nil) + +; respond-to-keypress will be monitoring the +; output-key command and will be called when a +; key is pressed by the model or a human playing +; the game. It records the key in the corresponding +; variable based on who made it. + (defun respond-to-keypress (model key) (if model (setf *model-action* key) (setf *human-action* key))) +; These functions are used to create the command and monitor +; output-key and correspondingly remove the monitor and command +; when needed because it is more efficient to do so once instead +; of on each trial (as has been done for most prior tasks) since +; this will require running many trials to collect the data. (defun add-key-monitor () (unless *key-monitor-installed* @@ -36,6 +70,12 @@ (setf *key-monitor-installed* nil)) +; onehit-hands takes one required parameter which is a number of +; hands to play and an optional parameter which if specified as +; non-nil will print out the details of the hands. +; It plays the game based on the settings of the global varaibles +; for the decks of cards and opponent functions and returns the +; list of results. (defun onehit-hands (hands &optional (print-game nil)) (let ((scores (list 0 0 0 0)) @@ -77,6 +117,11 @@ scores)) +; onehit-blocks takes two required parameters which are how many +; blocks of hands to play and how many hands are in a block. +; It plays the specified number of blocks and returns the list +; of results by block. + (defun onehit-blocks (blocks block-size) (let (res (need-to-remove (add-key-monitor))) @@ -86,6 +131,11 @@ (remove-key-monitor)) (reverse res))) +; game0 function sets the global variables to configure +; the default game -- the regular distribution of cards +; in a deck and an opponent which has a fixed threshold +; of 15 for deciding whether to hit or stay and which does +; not process the feedback. (defun game0 () (setf *deck1* 'regular-deck) @@ -95,6 +145,15 @@ (setf *opponent-feedback* nil)) +; onehit-learning requires one paramter which is how many +; 100 hand games to play. There are two optional paramters +; which indicate whether a graph of the results should be +; drawn in an experiment window (default is t which draws it) +; and to specify a function to use to set the variables that +; configure the game play (the default is game0). +; It returns a list with the average win percentages from +; the n games in both blocks of 20 and blocks of 5 hands. + (defun onehit-learning (n &optional (graph t) (game 'game0)) (let ((data nil) (need-to-remove (add-key-monitor))) @@ -120,6 +179,8 @@ (/ (apply '+ (subseq percentages 15 20)) 5)) percentages)))) +; draw-graph takes a list of percentages and displays them in +; a graph using an experiment window for output. (defun draw-graph (points) (let ((w (open-exp-window "Data" :visible t :width 550 :height 460))) @@ -137,18 +198,33 @@ 'blue)) (butlast points) (cdr points))))) +; deal takes a deck function and returns a list of +; the next three cards that it returns when called. + (defun deal (deck) (list (funcall deck) (funcall deck) (funcall deck))) + +; score-cards takes a list of cards and an optional value +; indicating the number over which a hand busts (defaults to 21). +; It returns the total value of those cards treating 1s as 11 +; if possible without busting. + (defun score-cards (cards &optional (bust 21)) (let ((total (apply '+ cards))) (dotimes (i (count 1 cards)) (when (<= (+ total 10) bust) (incf total 10))) total)) - + + +; compute-outcome takes a list of cards for each player and an +; optional value indicating the number over which a hand busts. +; It computes the total for each hand of cards and returns the +; result (win, lose, or bust) for the first list of cards. + (defun compute-outcome (p1cards p2cards &optional (bust 21)) (let ((p1tot (score-cards p1cards bust)) (p2tot (score-cards p2cards bust))) @@ -157,7 +233,15 @@ (if (or (> p2tot bust) (> p1tot p2tot)) 'win 'lose)))) - + +; show-model-cards takes two parameters. The first is a list of +; the model's starting cards and the second is the opponent's face +; up card. If there is a chunk in the model's goal buffer it is +; modified to the initial state of the game. If there is not a +; chunk in the goal buffer then a new chunk is created and placed +; into the buffer. Then the model is run for exactly 10 seconds +; and any response it made is returned. + (defun show-model-cards (mcards ocard) (if (buffer-read 'goal) (mod-focus-fct `(mc1 ,(first mcards) mc2 ,(second mcards) mc3 nil @@ -175,6 +259,15 @@ (run-full-time 10) *model-action*) +; show-model-results takes four parameters. The first is a list of +; the model's final cards and the second is the list of the opponent's +; final cards. The third is the model's end result and the fourth is +; the opponents end result. +; If there is a chunk in the model's goal buffer it is modified to +; the results state of the game with all the information. If there +; is not a chunk in the goal buffer then a new chunk is created with +; the results information and placed into the buffer. Then the model +; is run for exactly 10 seconds. (defun show-model-results (mcards ocards mres ores) (if (buffer-read 'goal) @@ -199,6 +292,13 @@ (run-full-time 10)) +; play-human takes two parameters. The first is the list of +; the player's cards and the other is the model's face up card. +; It opens an experiment window to display that information to +; a person and waits exactly 10 seconds before continuing the +; game. It returns the key press the player made, or "s" (stay) +; if no key was pressed. + (defun play-human (cards oc1) (let ((win (open-exp-window "Human"))) (add-text-to-exp-window win "You" :x 50 :y 20) @@ -222,7 +322,14 @@ (if *human-action* *human-action* "s"))) - + +; show-human-results takes four parameters. The first is a list of +; the player's final cards and the second is the list of the model's +; final cards. The third is the player's end result and the fourth is +; the model's end result. +; All of the cards and outcomes are displayed in an experiment +; window and it waits 10 seconds before continuing. + (defun show-human-results (own-cards others-cards own-result others-result) (let ((win (open-exp-window "Human"))) (add-text-to-exp-window win "You" :x 50 :y 20) @@ -244,6 +351,13 @@ (while (< (- (get-time nil) start-time) 10000) (process-events))))) +; play-against-model requries one parameter which is how many +; hands to play and an optional parameter indicating whether +; the hand information should be printed. It sets the global +; variables to those needed to have a person play against the +; model and then runs for the indicated number of hands. After +; that, it sets the variables back to the values they had +; before. (defun play-against-model (count &optional (print-game nil)) (if (visible-virtuals-available?) @@ -258,6 +372,9 @@ (setf *opponent-feedback* old-feedback)))) (print-warning "Cannot play against the model without a visible window available."))) +; show-opponent-cards and show-opponent-results are used +; by the game code to call the appropriate function for +; the non-model player to receive the game information. (defun show-opponent-cards (cards mc1) (funcall *opponent-rule* cards mc1)) @@ -266,19 +383,46 @@ (when *opponent-feedback* (funcall *opponent-feedback* ocards mcards ores mres))) +; The functions below are used to create the game0 and game1 +; situations. + + +; regular-deck takes no parameters and returns a number +; between 1 and 10 with 10s being 4 times as likely as +; other numbers. This is used as the deck function for +; both players in game0. + (defun regular-deck () (min 10 (1+ (act-r-random 13)))) +; fixed-threshold implements a rule for an opponent +; that will always hit below a fixed threshold. It +; is used in game0 for the opponent. + (defun fixed-threshold (cards mc1) (if (< (score-cards cards) *opponent-threshold*) "h" "s")) -(defvar *card-list* nil) +; always-hit implements a rule for an opponent +; that will always hit. It is used for the opponent +; in game1. (defun always-hit (cards mc1) "h") +; Create a variable for a list of cards, and +; a function that will place the 6 cards onto +; that list for the player decks (the first 3 +; cards are the model's and the next 3 are for +; the opponent). That deck function is used for +; both players and represents the situation in +; game1 where the opponent's face up card is +; a perfect predictor for the action the model +; needs to take to win. + +(defvar *card-list* nil) + (defun load-stacked-deck () (let* ((c1 (+ 5 (act-r-random 6))) (c2 (+ 7 (act-r-random 4))) @@ -293,6 +437,9 @@ (t (setf *card-list* (load-stacked-deck)) (pop *card-list*)))) +; function to set variables to the values needed to +; implement game1 + (defun game1 () (setf *card-list* nil) (setf *deck1* 'stacked-deck) @@ -300,5 +447,6 @@ (setf *opponent-rule* 'always-hit) (setf *opponent-feedback* nil)) +; call game0 to set the initial game variable values. (game0) diff --git a/tutorial/lisp/paired.lisp b/tutorial/lisp/paired.lisp index 6f38655..080dfea 100644 --- a/tutorial/lisp/paired.lisp +++ b/tutorial/lisp/paired.lisp @@ -1,5 +1,24 @@ +; ACT-R tutorial unit 4 paired associate task. +; This experiment runs several trials of presenting a +; word prompt, and waiting 5 seconds for a response, +; then it displays the correct response (which will be +; a digit) and waits 5 seconds before starting the next +; trial. The time to respond to the initial prompt and +; the correctness of the response are recorded for +; comparison to the humam data of the task that had +; 20 different pairs (the digits were each paired with +; two words) over 8 blocks (a randomized ordering of the +; 20 pairs). + + +; Load the corresponding model for the task + (load-act-r-model "ACT-R:tutorial;unit4;paired-model.lisp") +; Global variables to hold the participant's response, the time of +; that response, the possible stimuli, and the data from the +; original experiment. + (defvar *response* nil) (defvar *response-time* nil) @@ -11,12 +30,22 @@ (defvar *paired-latencies* '(0.0 2.158 1.967 1.762 1.680 1.552 1.467 1.402)) (defvar *paired-probability* '(0.000 .526 .667 .798 .887 .924 .958 .954)) +; paired-task takes two required parameters: the number of stimuli to +; present in a block and the number of blocks to run. The optional +; parameter if specified as true will run a person instead of the model. + (defun paired-task (size trials &optional human) + ; Create a command for the respond-to-key-press function so that + ; it can be used to monitor "output-key". + (add-act-r-command "paired-response" 'respond-to-key-press "Paired associate task key press response monitor") (monitor-act-r-command "output-key" "paired-response") + ; Run the function that does the actual experiment, return the result + ; of that, and remove the monitor and command that were added. + (prog1 (do-experiment size trials human) @@ -25,19 +54,39 @@ (remove-act-r-command "paired-response"))) +; respond-to-key-press will record the time of a key press +; using get-time (which reports model time if passed a true +; value or real time if passed nil, and model will be nil +; if it is a person performing the task) and the key that +; was pressed. + (defun respond-to-key-press (model key) (setf *response-time* (get-time model)) (setf *response* key)) +; do-experiment takes three parameters, the number of pairs to +; present per block, the number of blocks, and whether it is a +; person performing the task. It runs the number of blocks +; requested collecting the correctness and timing data per +; block, and then returns a list with lists where each sublist +; represents a block with the first item being % correct and +; the second mean response time. (defun do-experiment (size trials human) (if (and human (not (visible-virtuals-available?))) (print-warning "Cannot run the task as a person without a visible window available.") + (progn + (reset) + ; create a varaible to hold the data, an indication of whether the + ; model is performing the task, and an opened experiment window that + ; is visible if a human is performing the task or virtual if it is + ; a model. + (let* ((result nil) (model (not human)) (window (open-exp-window "Paired-Associate Experiment" :visible human))) @@ -45,40 +94,74 @@ (when model (install-device window)) + ; Loop over the number of blocks + (dotimes (i trials) (let ((score 0.0) (time 0.0)) + ; randomize the list of items to present which are + ; taken from the possible pairs + (dolist (x (permute-list (subseq *pairs* (- 20 size)))) + ; clear the window and display the prompt + (clear-exp-window window) (add-text-to-exp-window window (first x) :x 150 :y 150) + ; clear the response and record the time when the trial + ; is started + (setf *response* nil) (let ((start (get-time model))) + ; If it's the model run it for exactly 5 seconds + ; and if it's a person wait for 5 seconds of real + ; time to pass. + (if model (run-full-time 5) (while (< (- (get-time nil) start) 5000) (process-events))) + ; If there is a correct response increment the + ; count of correct answers and the cumulative + ; response times. + (when (equal *response* (second x)) (incf score 1.0) (incf time (- *response-time* start))) + ; Clear the window and display the correct response + (clear-exp-window window) (add-text-to-exp-window window (second x) :x 150 :y 150) (setf start (get-time model)) + ; If it's the model run it for exactly 5 seconds + ; and if it's a person wait for 5 seconds of real + ; time to pass. + (if model (run-full-time 5) (while (< (- (get-time nil) start) 5000) (process-events))))) + ; push a list with the percentage correct and mean response time + ; onto the result list. + (push (list (/ score size) (if (> score 0) (/ time score 1000.0) 0)) result))) + ; return the reversed result list so that it's in presentation order + ; (since they were pushed onto the list). + (reverse result))))) +; paired-experiment takes one required parameter which is the number of times +; to run a model through the original experiment (20 pairs for 8 trials each). +; It collects the data from those trials which is passed to the output-data +; function for averaging and comparison to the original data. (defun paired-experiment (n) (let ((data nil)) @@ -91,6 +174,12 @@ data (paired-task 20 8))))) (output-data data n))) +; output-data takes two required parameters which are a list of cumulative +; data items from the experiment and the number of experiment repetitions +; that were collected. It averages the results of the latency and accuracy +; data and calls print-results to display the comparison to the original +; data along with the average results. + (defun output-data (data n) (print-results (mapcar (lambda (x) (/ (second x) n)) data) *paired-latencies* "Latency") (print-results (mapcar (lambda (x) (/ (first x) n)) data) *paired-probability* "Accuracy")) diff --git a/tutorial/lisp/past-tense.lisp b/tutorial/lisp/past-tense.lisp index fc994b5..fc758d5 100644 --- a/tutorial/lisp/past-tense.lisp +++ b/tutorial/lisp/past-tense.lisp @@ -1,6 +1,27 @@ +; ACT-R tutorial unit 7 past-tense task. +; This task presents the model with an English +; verb (taken from a very small sample of verbs) +; randomly chosen based on the frequency of that +; verb's usage relative to the other verbs in the +; set. The model is then supposed to generate +; the past-tense for that verb. For every verb +; that the model must generate, it receives two +; randomly chosen correctly formed past-tenses +; which are merged into declarative memory. The +; code reports the percentages of correctly and +; incorrectly formed past-tenses by the model and +; will display a graph of the correctness for the +; irregular verbs which tend to show a U-shape in +; their learning. + + +; Load the corresponding model for the task (load-act-r-model "ACT-R:tutorial;unit7;past-tense-model.lisp") +; Global variables to hold the collected data and the verbs +; along with their frequencies. + (defvar *report*) (defvar *total-count*) (defvar *word-list* nil) @@ -29,6 +50,17 @@ (lose I 274 lost))) +; make-word-freq-list takes one parameter which is a list +; of verb description lists (as created above for the *verbs* +; variable) that contains the verb, whether it has a regular +; or irregular past-tense, it's relative frequency, and the +; stem for its past-tense (either the verb itself for a regular +; or the correct irregular inflection). It returns a list +; with a list for each verb that has a cumulative frequency +; value and the three components for specifying the chunk +; of the verb's past-tense (the verb, stem, and suffix slot +; values). + (defun make-word-freq-list (l) (let ((data nil) (count 0)) @@ -40,29 +72,47 @@ (setf *total-count* count) data)) +; random-word returns a list with the slot values for +; a randomly choosen word from those in the *word-list* list +; based on frequency. + (defun random-word () (let ((num (act-r-random *total-count*))) (cdr (find-if (lambda (x) (< num (first x))) *word-list*)))) +; make-one-goal randomly chooses a verb to present to the +; model in the imaginal buffer and sets the goal to be a +; copy of the starting-goal chunk. It returns the verb list +; for the chosen verb. + (defun make-one-goal () (let ((word (random-word))) - (set-buffer-chunk 'imaginal - (car (define-chunks-fct - (list (list 'verb (first word)))))) + (set-buffer-chunk 'imaginal (list 'verb (first word))) (goal-focus starting-goal) word)) +; add-past-tense-to-memory randomly chooses a verb to +; merge into the model's declartive memory. It does +; the merging by setting the imaginal buffer to a +; chunk which has the appropriate slots set and then +; clearing the buffer. + (defun add-past-tense-to-memory () - (let ((word (random-word))) - (set-buffer-chunk 'imaginal - (car (define-chunks-fct - (list (mapcan (lambda (x y) (list x y)) - '(verb stem suffix) word))))) - (clear-buffer 'imaginal))) + (set-buffer-chunk 'imaginal (mapcan (lambda (x y) (list x y)) + '(verb stem suffix) (random-word))) + (clear-buffer 'imaginal)) + +; print-header prints the column labels for the data displayed. (defun print-header () (format t "~%trials Irregular Regular No inflection Inflected correctly~%")) +; past-tense-results prints out the performance of the model +; averaged over blocks of 1000 verbs, and optionally draws a +; graph of the correctness of inflected irregular verbs (by +; default it draws the graph but providing a value of nil +; will suppress the graph) + (defun past-tense-results (&optional (graph t)) (print-header) (let ((data (rep-f-i 0 (length *report*) 1000))) @@ -70,6 +120,11 @@ (graph-it data)) data)) +; graph-it requires one parameter which is a list of +; data which it draws in an experiment window scaling +; increments on the x and y axis to fit the data to +; the size of the graph. + (defun graph-it (data) (let* ((win (open-exp-window "Irregular Verbs correct" :visible t :width 500 :height 475)) (low (apply 'min data)) @@ -105,12 +160,18 @@ (list this-x this-y) 'red)))) +; safe-div takes two parameters, n and d and returns +; n/d unless d is 0 in which case it returns 0. (defun safe-div (n d) (if (zerop d) 0 (/ n d))) +; rep-f-i computes the average performance of the model +; given a range of elements in the data in blocks of size +; count and prints those values. + (defun rep-f-i (start end count) (let ((data nil)) (dotimes (i (ceiling (- end start) count)) @@ -142,6 +203,13 @@ (push-last correct data)))) data)) +; add-to-report takes two parameters which are the verb +; that was presented to the model and the resulting chunk +; that it had in the imaginal buffer. It records the +; result based on the type of verb and correctness of +; the response. It also reports warnings for verbs +; that are formed incorrectly by the model. + (defun add-to-report (target chunk) (let ((stem (chunk-slot-value-fct chunk 'stem)) (word (chunk-slot-value-fct chunk 'verb)) @@ -171,21 +239,46 @@ (push-last (list irreg 'error) *report*))))) +; define a global variable and a function that will be +; used to monitor the trigger-reward command so that +; the code can verify whether or not the model receives +; a reward on each trial. + (defvar *reward-check*) (defun verify-reward (&rest r) (declare (ignore r)) (setf *reward-check* t)) +; past-tense-trials is used to run the model through +; the task. It takes one required parameter which +; is the number of trials to present. It has two +; optional parameters. The firt of those indicates +; whether the model should continue doing the task +; or be reset and start over. The default is to +; start over, but providing a non-nil value will +; cause it to continue. The second optional parameter +; controls whether the trace is shown or not. The +; default is to not show the trace, but providing +; a value of t will show the trace. + (defun past-tense-trials (n &optional (cont nil)(v nil)) + ; add a command to monitor trigger-reward + (add-act-r-command "reward-check" 'verify-reward "Past tense code check for a reward each trial.") (monitor-act-r-command "trigger-reward" "reward-check") + ; if there isn't a word list created yet or the + ; model is supposed to start over then + ; reset and create chunks for the verbs on the + ; list. + (when (or (null *word-list*) (null cont)) (reset) - (setf *word-list* (make-word-freq-list *verbs*)) + (unless *word-list* + (setf *word-list* (make-word-freq-list *verbs*))) (let ((new nil)) (dolist (x *word-list*) (mapcar (lambda (y) (pushnew y new)) (cdr x))) @@ -197,35 +290,62 @@ (print-header) (setf *report* nil)) + ; set the :v value as provided + (sgp-fct (list :v v)) + ; present the n trials and report the data in + ; blocks of 100 as it goes. + (let* ((start (* 100 (floor (length *report*) 100))) (count (mod (length *report*) 100))) (dotimes (i n) + + ; Add the two random past-tenses to memory (add-past-tense-to-memory) (add-past-tense-to-memory) + + ; run the model up to 100 seconds to + ; process a randomly chosen past-tense + ; and record the data outputting it + ; if there're 100 items to output + (setf *reward-check* nil) (let ((target (make-one-goal)) (duration (run 100))) + (add-to-report target (buffer-read 'imaginal)) (clear-buffer 'imaginal) (incf count) (when (= count 100) (rep-f-i start (+ start 100) 100) (setf count 0) - (incf start 100)) + (incf start 100)) + + ; If the model didn't get a reward or + ; spent all 100s running warn about that. + (unless *reward-check* (print-warning "Model did not receive a reward when given ~s." (first target))) - (run-full-time (- 200 duration)) - (when (= duration 100) (print-warning "Model spent 100 seconds generating a past tense for ~s." - (first target))))) + (first target))) + + ; run the model until 200 seconds have + ; passed since the start of the trial + + (run-full-time (- 200 duration)))) + + ; if there are any remaining data items + ; report them (< 100 after the last block). + (rep-f-i start (+ start count) 100)) + ; remove the monitor for trigger-reward + (remove-act-r-command-monitor "trigger-reward" "reward-check") (remove-act-r-command "reward-check") nil) diff --git a/tutorial/lisp/pcomp-issues.lisp b/tutorial/lisp/pcomp-issues.lisp index 55c21fa..d13c37d 100644 --- a/tutorial/lisp/pcomp-issues.lisp +++ b/tutorial/lisp/pcomp-issues.lisp @@ -1,3 +1,5 @@ +; ACT-R tutorial unit7 task for investigating production +; compilation modeling issues. (load-act-r-model "ACT-R:tutorial;unit7;production-compilation-issues-model.lisp") @@ -54,7 +56,7 @@ (defun game-over () *task-over*) -(defun pcomp-issues-trials (&optional (n 200) (reset t) (output t)) +(defun pcomp-issues-trials (&optional (n 150) (reset t) (output t)) (when reset (reset)) (setf *window* (open-exp-window "Compilation task" :visible nil)) (setf *times* nil) @@ -63,31 +65,23 @@ (setf *exp-length* n) (present-next-trial) (install-device *window*) - ; (add-act-r-command "compilation-issues-game-over" 'game-over "Test for the production compilation issues game being over") + (add-act-r-command "compilation-issues-response" 'respond-to-key-press "Compilation issues key press response monitor") (monitor-act-r-command "output-key" "compilation-issues-response") - ; This would be the direct translation of the old task code: - ; (run-until-condition "compilation-issues-game-over") - ; However, the performance hit for that is immense - ; if it has to go out through the dispatcher. - - ; So, instead will just take the run it a long enough - ; time approach since the screen stops updating once - ; the task is over and the model will have nothing to do. - + ; just run the model a long time to let it finish the trial (run 20000) (remove-act-r-command-monitor "output-key" "compilation-issues-response") (remove-act-r-command "compilation-issues-response") - ; (remove-act-r-command "compilation-issues-game-over") + (analyze-results output)) (defun pcomp-issues-game (n &optional show-games) - (let ((scores (make-list 20 :initial-element 0)) - (times (make-list 20 :initial-element 0))) + (let ((scores (make-list 15 :initial-element 0)) + (times (make-list 15 :initial-element 0))) (dotimes (i n) - (let ((result (pcomp-issues-trials 200 t show-games))) + (let ((result (pcomp-issues-trials 150 t show-games))) (setf scores (mapcar '+ scores (first result))) (setf times (mapcar '+ times (second result))))) (format t "~%Average Score of ~d trials~%" n) diff --git a/tutorial/lisp/pm-issues.lisp b/tutorial/lisp/pm-issues.lisp index 028b1b7..a244793 100644 --- a/tutorial/lisp/pm-issues.lisp +++ b/tutorial/lisp/pm-issues.lisp @@ -1,3 +1,6 @@ +; ACT-R tutorial unit 3 code for a simple task to +; investigate potential perceptual and motor issues +; with models. (load-act-r-model "ACT-R:tutorial;unit3;perceptual-motor-issues-model.lisp") @@ -37,7 +40,7 @@ (add-act-r-command "pm-issue-display" 'display-prompt "Perceptual-motor issues task prompt display") - (schedule-event-relative time "pm-issue-display" :params (list window task) :time-in-ms t) + (schedule-event-relative time "pm-issue-display" :params (list window task) :time-in-ms t :output 'medium) (setf *response* nil) (setf *response-time* nil) diff --git a/tutorial/lisp/siegler.lisp b/tutorial/lisp/siegler.lisp index a7c5778..8c8e540 100644 --- a/tutorial/lisp/siegler.lisp +++ b/tutorial/lisp/siegler.lisp @@ -1,6 +1,23 @@ +; ACT-R tutorial unit 5 siegler task. +; This experiment presents a model with a pair of numbers aurally +; and the model must respond vocally with the sum of those numbers. +; The task and data to which the model is fit are in the paper: +; +; Siegler, R. S., & Shrager, J. (1984). Strategy choices in addition +; and subtraction: How do children know what to do? In C. Sophian (Ed.), +; Origins of cognitive skills (pp. 229-293). Hillsdale, NJ: Erlbaum. +; +; The original experiment was performed with 4 year-olds who made +; many errors in their responses. + +; Load the corresponding model for the task. (load-act-r-model "ACT-R:tutorial;unit5;siegler-model.lisp") +; Create variables for the response, to record whether the +; monitoring function is currently available, and a subset of +; the original data for comparison. + (defvar *response*) (defvar *monitor-installed* nil) @@ -11,13 +28,20 @@ (0 0 .07 .09 .25 .45 .08 .01 .01 .06) (.04 0 0 .05 .21 .09 .48 0 .02 .11))) - +; record-model-speech will be monitoring the output-speech +; command called by the microphone device so that it can +; record the model's speech output. (defun record-model-speech (model string) (declare (ignore model)) (setf *response* string)) +; Because the task can be run as a single trial, or over +; larger blocks it's more efficient to only install and +; remove the monitor once for the run instead of on each +; trial as has been done in other tasks. These functions +; are used to do that when necessary. (defun add-speech-monitor () (unless *monitor-installed* @@ -30,6 +54,11 @@ (remove-act-r-command "siegler-response") (setf *monitor-installed* nil)) +; siegler-trial takes two parameters which must be numbers +; It resets the model and adds a microphone device to record +; the models speech output. Then, the numbers are presented +; aurally to the model using new-digit-sound, and after +; running the model it returns any vocal response that it made. (defun siegler-trial (arg1 arg2) (reset) @@ -44,7 +73,9 @@ *response*)) - +; siegler-set runs one trial for each of the addition +; problems in the data set and returns the results of +; those trials. (defun siegler-set () @@ -59,6 +90,11 @@ (remove-speech-monitor)) data)) +; siegler-experiment requires one parameter which is how many +; sets of trials to run. It runs that many trials collecting +; the responses and then passes those to analyze to compute the +; response percentages, compare the data to the experimental data, +; and display the results. (defun siegler-experiment (n) (add-speech-monitor) diff --git a/tutorial/lisp/sperling.lisp b/tutorial/lisp/sperling.lisp index c437091..3ee3bf9 100644 --- a/tutorial/lisp/sperling.lisp +++ b/tutorial/lisp/sperling.lisp @@ -1,15 +1,52 @@ +; ACT-R tutorial unit 3 demonstration task. +; The sperling experiment displays a block of 12 +; letters in the window, with 3 lines of 4 letters +; per line for a brief time. After the display has +; been presented a tone sound is generated to indicate +; which row of letters must be reported (the timing of +; the tone relative to the initial display of the +; letters is variable). After the letters go away +; the participant must press the keys to indicate which +; letters were in the target row, and press the spacebar +; to indicate completion. + + +; Load the corresponding tutorial model (load-act-r-model "ACT-R:tutorial;unit3;sperling-model.lisp") +; Define some global variables: *responses* holds the list of +; keys pressed by the participant, *show-responses* indicates +; whether or not to print out the responses provided after a +; trial is run, and *sperling-exp-data* holds the results of +; the original experiment (number of correct responses from +; the target row based on the delay of the tone) for +; comparison to the model's performance. + (defvar *responses* nil) (defparameter *show-responses* t) (defvar *sperling-exp-data* '(3.03 2.40 2.03 1.50)) +; The sperling-trial function runs a single trial of the task +; and returns the number of correct responses. It requires one +; parameter which is the time in seconds to delay the tone +; after the items have been presented. + (defun sperling-trial (onset-time) + ; Reset ACT-R and all models to initial state + (reset) + ; create some local variables to perform the trial: + ; letters: is a randomized list of letter strings + ; answers: will be the list of letters in the target row + ; row: a random number from 0-2 indicating which row will + ; be the target + ; window: an experiment window created to display the task + ; freq: will be set to the frequency of the tone to present + (let* ((letters (permute-list '("B" "C" "D" "F" "G" "H" "J" "K" "L" "M" "N" "P" "Q" "R" "S" "T" "V" "W" "X" "Y" "Z"))) @@ -18,15 +55,23 @@ (window (open-exp-window "Sperling Experiment" :visible t)) freq) + ; Show the first 12 letters from the list in the window in + ; three rows of four and record which ones are in the target + ; row in the answers variable. + (dotimes (i 3) (dotimes (j 4) (let ((txt (nth (+ j (* i 4)) letters))) (when (= i row) (push txt answers)) (add-text-to-exp-window window txt :x (+ 75 (* j 50)) :y (+ 100 (* i 50)))))) - + + ; Tell the model to interact with that window + (install-device window) + ; Set the freq variable based on which row is the target + (case row (0 (setf freq 2000)) @@ -35,25 +80,56 @@ (2 (setf freq 500))) + ; Create a tone with frequency freq for .5 seconds + ; starting at the indicated onset-time + (new-tone-sound freq .5 onset-time) + + ; To simulate the persistent visual memory for the model + ; we will not clear the display until after a randomly + ; chosen time between .9 and 1.1 seconds has passed. + ; This is done by scheduling the clear-exp-window command + ; to be called after that amount of time has passed. + (schedule-event-relative (+ 900 (act-r-random 200)) "clear-exp-window" :params (list window) :time-in-ms t) + ; clear the response variable + (setf *responses* nil) + ; Add a command for our respond-to-key-press function so that + ; ACT-R can call it. + (add-act-r-command "sperling-response" 'respond-to-key-press "Sperling task key press response monitor") + + ; Monitor the output-key action so that our respond-to-key-press + ; function is called when a key is pressed. + (monitor-act-r-command "output-key" "sperling-response") - + + ; Run the model for up to 30 seconds in real time mode. + (run 30 t) + ; Stop monitoring the output-key action and remove our command. + (remove-act-r-command-monitor "output-key" "sperling-response") (remove-act-r-command "sperling-response") + ; If the *show-responses* variable is non-nil then print out + ; the correct answers and the responses that were provided + (when *show-responses* (format t "~%~%answers: ~S~%responses: ~S~%" answers *responses*)) + ; Call the compute-score function to determine the number of + ; correct responses and return the result. + (compute-score answers))) +; The compute-score function counts how many of the correct answers +; were provided by the participant and returns that number. (defun compute-score (answers) (let ((score 0)) @@ -62,12 +138,20 @@ (incf score))))) +; This function is the one that will be called when the participant +; presses a key, and it just records the result in the *responses* +; list unless it is the space bar. + (defun respond-to-key-press (model key) (declare (ignore model)) (unless (string-equal key "space") (push key *responses*))) +; The report-data function takes a list of the average number of items +; reported in the target row ordered by onset delay. It compares those +; to the original experiment's data based on correlation and mean deviation +; then calls print-results to display the data. (defun report-data (data) @@ -75,6 +159,9 @@ (mean-deviation data *sperling-exp-data*) (print-results data)) +; The print-results function takes a list of the average target row data +; and prints that in a table along with the original experiment's data. + (defun print-results (data) (format t "~%Condition Current Participant Original Experiment~%") @@ -85,6 +172,10 @@ (format t " ~4,2F sec. ~6,2F ~6,2F~%" (car condition) (car temp1) (car temp2)))) +; The one-block function runs a trial of the experiment at each +; of the experiment's tone onset conditions in a random order. +; It returns a list of the correct answer counts in the order +; of onset duration (lowest first). (defun one-block () (let ((result nil)) @@ -93,6 +184,11 @@ (push (cons x (sperling-trial x)) result)) (mapcar 'cdr (sort result '< :key 'car)))) +; The sperling-experiment function takes one required parameter which +; is the number of blocks to run in the experiment (where each block +; is one trial at each of the 4 possible onset times). It collects +; the data over blocks, averages the results, and passes that to the +; report-data function for display. (defun sperling-experiment (n) (let ((results (list 0 0 0 0))) diff --git a/tutorial/lisp/subitize.lisp b/tutorial/lisp/subitize.lisp index 73d239a..55520b9 100644 --- a/tutorial/lisp/subitize.lisp +++ b/tutorial/lisp/subitize.lisp @@ -1,11 +1,32 @@ +; ACT-R tutorial unit3 subitize experiment. +; This experiment displays a number of Xs on +; the screen and the participant must respond +; with how many are there. A human participant +; must press a key from 0-9 (where 0 represents +; 10 items) but a model must speak the count +; (which is how the original experiment was +; performed). The time of the response and its +; correctness are recorded. + +; Load the corresponding ACT-R starting model. (load-act-r-model "ACT-R:tutorial;unit3;subitize-model.lisp") +; Define some global variables to hold the response +; given and the time it occurred. + (defvar *response* nil) (defvar *response-time* nil) +; A variable holding the data from the original experiment + (defvar *subitize-exp-data* '(.6 .65 .7 .86 1.12 1.5 1.79 2.13 2.15 2.58)) +; Two functions for converting an integer to a string +; as either the word e.g. "one" or the digits e.g. "1" +; for comparison to the response given by a model (spoken) +; or a person (keypress). + (defun number-to-word (n) (format nil "~r" n)) @@ -14,50 +35,111 @@ "0" (princ-to-string n))) +; The subitize-trial function presents one trial of the task. +; It requires one parameter which is the number of items to +; present (should be an integer from 1-10), and has an optional +; parameter which indicates whether it is the model or a person +; performing the task. It returns a list with the time it took +; the participant to respond and t if the response was correct +; or the list (30 nil) if the response was incorrect or no +; response was provided. + (defun subitize-trial (n &optional human) + ; Reset ACT-R and all models to initial state + (reset) + ; create some local variables to perform the trial: + ; points: is a list of randomized x,y coordinates to display the Xs + ; from the generate-points function + ; window: an experiment window created to display the task + ; start: the current time at the start of the trial + ; as given by the ACT-R get-time function which + ; needs to be provided whether it is the model or + ; a person doing the task to get the appropriate time + ; answer: a variable to hold the correct answer for the trial + (let ((points (generate-points n)) (window (open-exp-window "Subitizing Experiment")) (start (get-time (if human nil t))) answer) + ; Display an x at each of the points + (dolist (point points) (add-text-to-exp-window window "x" :x (first point) :y (second point))) + ; clear the response variables + (setf *response* nil) (setf *response-time* nil) + ; Run the trial + (if human (when (visible-virtuals-available?) + + ; If a human is doing the task and there is a visible + ; window available for them to interact with then + ; add a command and monitor the output-key action + (add-act-r-command "subitize-response" 'respond-to-key-press "Subitize task human response") (monitor-act-r-command "output-key" "subitize-response") + ; Set the correct answer string for a key press + (setf answer (number-to-string n)) + + ; Wait until there is a response + (while (null *response*) (process-events)) + ; Stop monitoring output-key and remove the command + (remove-act-r-command-monitor "output-key" "subitize-response") (remove-act-r-command "subitize-response")) (progn + + ; If a model is doing the task add a command and monitor + ; the output-speech action + (add-act-r-command "subitize-response" 'record-model-speech "Subitize task model response") (monitor-act-r-command "output-speech" "subitize-response") + ; Set the correct answer string for a spoken response + (setf answer (number-to-word n)) + + ; Tell the model to interact with the created window + (install-device window) + ; Run the model for up to 30 seconds in real time mode + (run 30 t) + ; Stop monitoring output-speech and remove the command + (remove-act-r-command-monitor "output-speech" "subitize-response") (remove-act-r-command "subitize-response"))) + ; If a response is given and it matches the correct answer + ; then return a list with the time since the trial started + ; in seconds and t, otherwise return a list of 30 and nil + (if (and *response* (string-equal answer *response*)) (list (/ (- *response-time* start) 1000.0) t) (list 30 nil)))) +; Subitize-experiment takes one optional parameter which indicates +; whether it is a human or model performing the task. Then it +; presents a trial for each of the counts from 1-10 in a randomized +; order, and passes the results to report-data sorted by item count. + (defun subitize-experiment (&optional human) (let (results) (dolist (items (permute-list '(10 9 8 7 6 5 4 3 2 1))) @@ -66,19 +148,32 @@ (setf results (sort results '< :key 'car)) (report-data (mapcar 'second results)))) +; Report-data compares the times in the provided data to +; the original experiment data and then passes it to print-results +; for output. + (defun report-data (data) (let ((rts (mapcar 'first data))) (correlation rts *subitize-exp-data*) (mean-deviation rts *subitize-exp-data*) (print-results data))) +; Print-results outputs a table with the times and correctness +; values from the current experiment along with the data from +; the origial experiment. + (defun print-results (data) (format t "Items Current Participant Original Experiment~%") (dotimes (i (length data)) (format t "~3d ~5,2f (~3s) ~5,2f~%" (1+ i) (car (nth i data)) (second (nth i data)) (nth i *subitize-exp-data*)))) - + +; The next three functions: generate-points, new-distinct-point, and +; too-close are used to generate a list of random x,y lists for the +; coordinates to display the Xs so that they are within the bounds of +; the window and non-overlapping. + (defun generate-points (n) (let ((points nil)) (dotimes (i n points) @@ -94,12 +189,22 @@ (< (abs (- (cadr new-point) (cadr a))) 40))) points)) + +; Respond-to-key-press is monitoring output-key to record +; the current time and key pressed when a human is performing +; the task. + (defun respond-to-key-press (model key) (declare (ignore model)) (setf *response-time* (get-time nil)) (setf *response* key)) + +; Record-model-speech is monitoring output-speech to record +; the current time and word spoken when a model is performing +; the task. + (defun record-model-speech (model string) (declare (ignore model)) (setf *response-time* (get-time t)) diff --git a/tutorial/lisp/ul-issues.lisp b/tutorial/lisp/ul-issues.lisp index 9bfe2d4..9d16b9b 100644 --- a/tutorial/lisp/ul-issues.lisp +++ b/tutorial/lisp/ul-issues.lisp @@ -1,3 +1,6 @@ +; ACT-R tutorial unit7 task for investigating utility +; learning modeling issues. + (defun present-choose () (goal-focus initial-goal) (schedule-event-relative 5 "utility-learning-issues-show-result" diff --git a/tutorial/lisp/unit2.lisp b/tutorial/lisp/unit2.lisp index 5b64376..c7c37ff 100644 --- a/tutorial/lisp/unit2.lisp +++ b/tutorial/lisp/unit2.lisp @@ -1,16 +1,63 @@ +; ACT-R tutorial unit 2 assignment task. +; This experiment opens a window, displays 3 characters +; with two being the same and one different, waits for a +; keypress, and then reports whether the key that was +; pressed matches the different letter or not. + + +; Load the corresponding tutorial model + (load-act-r-model "ACT-R:tutorial;unit2;unit2-assignment-model.lisp") +; Create a variable to store the key that was pressed. + (defvar *response* nil) +; This is the function which we will have ACT-R call when +; a key is pressed in the experiment window which is signaled +; by the output-key action. + +; That action provides two parameters to the function called. +; The first is the name of the model that performed the keypress +; or nil if it wasn't generated by a model, and the second +; is a string with the name of the key that was pressed. + (defun respond-to-key-press (model key) (declare (ignore model)) + ; just store the key that was pressed in the response variable + (setf *response* key)) +; This is the function that runs the experiment for either a +; person or a model. It has one optional parameter which if +; provided as a non-nil value will run a person. +; If it is not provided or nil is specified then it will run +; the model. + (defun unit2-experiment (&optional human) + ; Reset the ACT-R system and any models that are defined to + ; their initial states. + (reset) + ; Create variable for the items needed to run the exeperiment: + ; items - a randomized list of letter strings which is randomized + ; using the ACT-R function permute_list + ; target - the first string from the randomized list which will be the + ; one that is different in the display + ; foil - the second item from the list which will be displayed + ; twice + ; window - the ACT-R window device list returned by using the ACT-R + ; function open-exp-window to create a new window for + ; displaying the experiment + ; text# - three text items that will hold the letters to be + ; displayed all initialized to the foil letter to start + ; index - a random value from 0-2 generated from the act-r-random + ; function which is used to determine which of the three + ; text variables will be set to the target + (let* ((items (permute-list '("B" "C" "D" "F" "G" "H" "J" "K" "L" "M" "N" "P" "Q" "R" "S" "T" "V" "W" "X" "Y" "Z"))) (target (first items)) @@ -21,33 +68,75 @@ (text3 foil) (index (act-r-random 3))) + ; Set the randomly chosen item to be the target letter + (case index (0 (setf text1 target)) (1 (setf text2 target)) (2 (setf text3 target))) + ; display the three letters in the window + (add-text-to-exp-window window text1 :x 125 :y 75) (add-text-to-exp-window window text2 :x 75 :y 175) (add-text-to-exp-window window text3 :x 175 :y 175) + ; Set the response value to nil to remove any value it may + ; have from a previous run of the experiment. + (setf *response* nil) + ; Create a command in ACT-R that corresponds to our respond-to-key-press + ; function so that ACT-R is able to use the function. + (add-act-r-command "unit2-key-press" 'respond-to-key-press "Assignment 2 task output-key monitor") + + ; Monitor the output-key action so that when an output-key happens + ; our function is called. + (monitor-act-r-command "output-key" "unit2-key-press") + + ; Here is where we actually "run" the experiment. + ; It either waits for a person to press a key or runs ACT-R + ; for up to 10 seconds giving the model a chance to do the + ; experiment. (if human - (if (visible-virtuals-available?) + + ; If a person is doing the task then for safety + ; we make sure there is a visible window that they + ; can use to do the task, and if so, loop until the + ; response variable is not nil calling the ACT-R + ; process-events function to allow the system a + ; chance to handle any interactions. + + (if (visible-virtuals-available?) (while (null *response*) (process-events))) (progn + + ; If it is not a human then use install-device so that + ; the features in the window will be seen by the model + ; (that will also automatically provide the model with + ; access to a virtual keyboard and mouse). Then use + ; the ACT-R run function to run the model for up to 10 + ; seconds in real-time mode. + (install-device window) (run 10 t))) + ; To avoid any issues with our function for keypresses in this + ; experiment interfering with other experiments we should stop + ; monitoring output-key and then remove our command. + (remove-act-r-command-monitor "output-key" "unit2-key-press") (remove-act-r-command "unit2-key-press") - + + ; If the response matches the target return True otherwise + ; return False. + (if (string-equal *response* target) t nil))) diff --git a/tutorial/lisp/zbrodoff.lisp b/tutorial/lisp/zbrodoff.lisp index 163e726..e82fa09 100644 --- a/tutorial/lisp/zbrodoff.lisp +++ b/tutorial/lisp/zbrodoff.lisp @@ -1,15 +1,60 @@ +; ACT-R tutorial unit 4 zbrodoff task. +; This experiment presents participants with alpha-arithmetic +; problems like "A + 2 = C" which they must respond to by +; pressing k if the problem is correct or d if it is not. +; The code runs the control condition from the paper: +; +; Zbrodoff, N. J. (1995). Why is 9 + 7 harder than 2 + 3? +; Strength and interference as explanations of the problem-size +; effect. Memory & Cognition, 23 (6), 689-700. +; +; That condition presents problems with addends of 2, 3, and 4 +; with equal frequency in blocks of 192 trials where half of the +; trials in a block are correct and half are false. The +; data for comparison is the average response time by block +; and addend for correct answers (including both true and +; false problems). + + +; Load the corresponding model for the task (load-act-r-model "ACT-R:tutorial;unit4;zbrodoff-model.lisp") +; Global variables to hold the trials to present, the results that have +; been collected, and the original data for comparison. + (defvar *trials*) (defvar *results*) (defvar *zbrodoff-control-data* '(1.84 2.46 2.82 1.21 1.45 1.42 1.14 1.21 1.17)) +; Also create a variable to indicate whether it will be a model or person. +; This is done to keep the number of parameters needed to run the functions +; smaller since one may want a visible window for either a person or model +; and this avoids having to specify both who is running and whether the window +; should be shown. + (defparameter *run-model* t) +; Because the data collection for this task is a little more involved +; we're going to record the trials in a structure to keep everything +; together and organized instead of just a list of items as has been +; done for other experiments. This will also allow us to store all of +; the information needed to present a trial together so that we can +; create them all in advance which can be useful when running in an +; event-driven style. A trial will hold the block number, the addend +; value, the text of the problem to display, the correct answer, whether +; the window should be visible or not, whether the response from the +; participant was correct, the time the trial started, and the response +; time. + (defstruct trial block addend text answer visible correct start time) +; The construct-trial function takes a block number, a list of the items +; which describe the problem to present, and an optional parameter to +; indicate whether or not the window should be visible. It creates +; and returns a trial structure containing the appropriate information. + (defun construct-trial (block problem &optional visible) (destructuring-bind (addend1 addend2 sum answer) problem (make-trial :block block @@ -18,81 +63,160 @@ :answer answer :visible visible))) +; The present-trial function takes one parameter which is a trial +; structure and an optional parameter which indicates whether or not +; to open a new window for this trial (since this task is running +; continuously it will run faster if it uses the same window repeatedly, +; but because the same code is used to run it for a variety of +; different situations it needs to know when to start over with a +; new display). (defun present-trial (trial &optional (new-window t)) (if new-window + ; If a new window is requested it opens one using + ; the visible status indicated in the trial and + ; if the model is performing the task it installs + ; that window device for the model. + (let ((w (open-exp-window "Alpha-arithmetic Experiment" :visible (trial-visible trial)))) (when *run-model* (install-device w))) + + ; otherwise it just clears the current window + (clear-exp-window)) + ; add the text from the trial to the window and set the + ; start time in the trial structure. + (add-text-to-exp-window nil (trial-text trial) :x 100 :y 150) (setf (trial-start trial) (get-time *run-model*))) +; The respond-to-key-press function will be set up to monitor +; the output-key actions, and thus will be called with two parameters +; when a key is pressed: the name of the model that pressed the key +; (or nil if it is a person) and the string naming the key that was +; pressed. +; Unlike the previous tasks, since this one is event-driven we will +; actually do more than just record the key and time in this function. +; It will also present the next trial if there is one so that the +; model can continue to run in the task until it is complete. (defun respond-to-key-press (model key) (declare (ignore model)) - + + ; Remove the current trial from the list, and then set the response time + ; and correctness in the structure before adding it to the results list. + (let ((trial (pop *trials*))) (setf (trial-time trial) (/ (- (get-time *run-model*) (trial-start trial)) 1000.0)) (setf (trial-correct trial) (string-equal (trial-answer trial) key)) (push trial *results*)) + ; If there are any trials left to present then present the first of them now. + (when *trials* (present-trial (first *trials*) nil))) +; The collect-responses function takes no parameters and runs all of +; the trials available. -(defun collect-responses (count) - (setf *results* nil) - - (add-act-r-command "zbrodoff-response" 'respond-to-key-press - "Zbrodoff task key press response monitor") - (monitor-act-r-command "output-key" "zbrodoff-response") +(defun collect-responses () - (present-trial (first *trials*)) - - (if *run-model* - (run (* 10 count)) - (if (visible-virtuals-available?) - (while (< (length *results*) count) - (process-events)))) + ; record how many trials need to be run - (remove-act-r-command-monitor "output-key" "zbrodoff-response") - (remove-act-r-command "zbrodoff-response")) - + (let ((total (length *trials*))) + + ; Create a command for respond-to-key-press and monitor output-key. + + (add-act-r-command "zbrodoff-response" 'respond-to-key-press + "Zbrodoff task key press response monitor") + (monitor-act-r-command "output-key" "zbrodoff-response") + + ; present the first trial + + (present-trial (first *trials*)) + + ; If it's a model doing the task run for 10s per trial, + ; and if it's a person loop until there are as many results + ; as there were trials to run. + + (if *run-model* + (run (* 10 total)) + (if (visible-virtuals-available?) + (while (< (length *results*) total) + (process-events)))) + + ; stop monitoring and remove the command + + (remove-act-r-command-monitor "output-key" "zbrodoff-response") + (remove-act-r-command "zbrodoff-response"))) +; The zbrodoff-problem function takes 4 required parameters. +; The first three are the strings of the elements of the problem +; to present e.g. "A" "2" "C" to preset "A + 2 = C". The fourth +; is a string with the key press that will be a correct response +; which is "k" if the problem is correct and "d" if the problem +; is not correct. The optional parameter can be specified as true +; to have the window displayed, but if not provided defaults to +; not showing the window for a model and showing it for a person. +; It clears the current results, creates a list with the single +; trial specified and runs the task for that trial and displays +; the results. + (defun zbrodoff-problem (addend1 addend2 sum answer &optional (visible (not *run-model*))) + (setf *results* nil) (setf *trials* (list (construct-trial 1 (list addend1 addend2 sum answer) visible))) - (collect-responses 1) + (collect-responses) (analyze-results)) +; Zbrodoff-set and zbrodoff-block are similar to zbrodoff-problem +; except that instead of presenting a single trial they present +; a full set (24 trials) or block (192 trials) of items. (defun zbrodoff-set (&optional (visible (not *run-model*))) + (setf *results* nil) (setf *trials* (create-set 1 visible)) - (collect-responses 24) + (collect-responses) (analyze-results)) - (defun zbrodoff-block (&optional (visible (not *run-model*))) - (setf *trials* nil) + + (setf *results* nil) (dotimes (i 8) (setf *trials* (append *trials* (create-set 1 visible)))) - (collect-responses 192) + (collect-responses) (analyze-results)) +; Zbrodoff-experiment has two optioal parameters. The first is +; whether or not to show the window which defaults to not shown +; if it's a model or shown for a person, and the second is whether +; or not to display the results after the experiment is run (the +; default is to show them). +; It resets the model, generates three blocks of trials, runs +; those trials, and reports the results. + (defun zbrodoff-experiment (&optional (visible (not *run-model*)) (show t)) (reset) (setf *trials* nil) (dotimes (j 3) (dotimes (i 8) (setf *trials* (append *trials* (create-set (+ j 1) visible))))) - (collect-responses 576) + + (setf *results* nil) + (collect-responses) (analyze-results show)) +; Zbrodoff-compare takes one required parameter which is the number +; of times to run a model through the full experiment. It runs +; the model that many times and averages the results of those +; runs which it compares to the original data for the task and +; then displays the results. + (defun zbrodoff-compare (n) (let ((results nil)) (dotimes (i n) @@ -108,7 +232,12 @@ (print-analysis rts counts '(1 2 3) '("2" "3" "4") '(64 64 64))))) - + +; Analyze-results takes one optional parameter which +; indicates whether or not to print the results in addition +; to averaging the times by addend and block and returning +; the averaged results and counts of correct items in a list. + (defun analyze-results (&optional (show t)) (let* ((blocks (sort (remove-duplicates (mapcar 'trial-block *results*)) '<)) (addends (sort (remove-duplicates (mapcar 'trial-addend *results*) @@ -140,7 +269,8 @@ (list (reverse rts) (reverse counts)))) - +; print-analysis displays a table with the data items provided. + (defun print-analysis (rts counts blocks addends totals) (format t "~% ") (dotimes (addend (length addends)) @@ -152,6 +282,10 @@ (nth (+ addend (* block (length addends))) counts)))) (terpri)) +; This varaible holds the problems to be presented +; in one set of the task -- 4 problems with each addend +; in a correct equation and 4 problems with each addend +; in an incorrect equation. (defvar *data-set* '(("a" "2" "c" "k")("d" "2" "f" "k") ("b" "3" "e" "k")("e" "3" "h" "k") @@ -167,9 +301,11 @@ ("c" "4" "h" "d")("f" "4" "k" "d"))) +; Create-set takes a block number and whether the items +; should be visible and returns a randomized list of +; trial structures representing one set of data with +; those conditions. - - (defun create-set (block visible) (mapcar (lambda (x) (construct-trial block x visible)) diff --git a/tutorial/python/actr.py b/tutorial/python/actr.py index 89427ca..7db2eba 100644 --- a/tutorial/python/actr.py +++ b/tutorial/python/actr.py @@ -1,9 +1,38 @@ +""" +This file implements a connection to the ACT-R remote interface +and defines functions which can call the ACT-R commands that are +used in the tasks from the ACT-R tutorial. + +The call_command function can be used to call ACT-R commands +for which a corresponding function has not been provided. + +It is not "the" ACT-R interface in Python. It is only an interface +which is sufficient for using the ACT-R tutorial tasks from Python. + +There are some assumptions about how the connection is implemented +and processed which may not be suitable for other purposes. Also, +a simpler interface may be more useful in other cases when speed of +operation is important. + +There is an example of a simpler interface that implements only a +specific set of commands being made available to ACT-R in the file: + +examples/creating-modules/external/goal_complete.py + +There are of course many other ways one could also handle the +communication process. + +""" + import json import threading import socket import time import os import sys +import __main__ +import imp + current_connection = None @@ -565,6 +594,9 @@ def pprint_chunks (*chunks): def chunk_slot_value (chunk_name, slot_name): return current_connection.evaluate_single("chunk-slot-value", chunk_name, slot_name) +def buffer_slot_value (buffer_name, slot_name): + return current_connection.evaluate_single("buffer-slot-value", buffer_name, slot_name) + def set_chunk_slot_value (chunk_name, slot_name, new_value): return current_connection.evaluate_single("set-chunk-slot-value", chunk_name, slot_name, new_value) @@ -870,4 +902,69 @@ def permute_list(l): return result def call_command(command,*parameters): - return current_connection.evaluate_single(command,*parameters) \ No newline at end of file + return current_connection.evaluate_single(command,*parameters) + + +def import_from_path(fullpath,reload=False): + """ + Import a file with full path specification. Allows one to + import from anywhere, something __import__ does not do. + """ + path, filename = os.path.split(fullpath) + filename, ext = os.path.splitext(filename) + if ext == '.py': + sys.path.insert(0, path) + module = __import__(filename) + if reload: ## not used at this point + imp.reload(module) + del sys.path[0] + return module + else: + return False + + +def env_loader(path): + """ + Ugly solution to something probably not necessary, + but seems some novice ACT-R users that wanted to use + Python wanted to use the 'load ACT-R code' button for + the Python files too. So, this provides a way that + such a button could be implemented and make the module + available directly from the interactive prompt from which + actr was imported so that it would still match the tutorial + descriptions. + """ + global __main__ + + try: + module=import_from_path(path) + + if module: + setattr(__main__,module.__name__,module) + return True + else: + return "Only a .py file can be imported" + except: + print("Problem with trying to import from ",path) + print(sys.exc_info()) + return str(sys.exc_info()[1]) + + +from pathlib import Path + +starting_dir = Path(__file__).parent.absolute() + +def env_loader_no_path(file): + """ + Add the current file's path to the file name given and then + pass it off to env_loader + """ + + return(env_loader(starting_dir.joinpath(file))) + + +add_command("Python-import-from-file",env_loader,"Import a Python module and make it available directly from the interactive prompt. Params: pathname") + +add_command("load-python-module-html",env_loader_no_path,"Import a python module from the directory containing the actr.py module and make it available directly from the interactive prompt. Params: filename") + + diff --git a/tutorial/python/bst.py b/tutorial/python/bst.py index 12abc04..2e341ea 100644 --- a/tutorial/python/bst.py +++ b/tutorial/python/bst.py @@ -1,7 +1,28 @@ +# ACT-R tutorial unit6 building sticks experiment. +# This experiment displays three posssible sticks +# which can be used to create a given target stick's +# length. It is an isomorph of Luchins water jug +# problem, and the experiment for the model is the +# one from: +# +# Lovett, M. C., & Anderson, J. R. (1996). History of success +# and current context in problem solving: Combined influences +# on operator selection. Cognitive Psychology, 31, 168-217. +# +# The task is presented with buttons to pick the sticks +# and a button to reset the current trial. + +# Import the actr module for tutorial tasks + import actr +# Load the corresponding ACT-R starting model. + actr.load_act_r_model ("ACT-R:tutorial;unit6;bst-model.lisp") +# Global variables to hold the information about the +# current trial information. + target = None current_stick = None current_line = None @@ -10,6 +31,10 @@ window = None visible = False +# The data from the experiment, the lengths of the sticks +# used in the experiment, and two example problems for +# demonstration. + exp_data = [20, 67, 20, 47, 87, 20, 80, 93, 83, 13, 29, 27, 80, 73, 53] exp_stims = [[15,250,55,125],[10,155,22,101],[14,200,37,112], [22,200,32,114],[10,243,37,159],[22,175,40,73], @@ -19,6 +44,9 @@ no_learn_stims = [[15,200,41,103],[10,200,29,132]] +# build_display takes the lengths of the sticks for a trial. +# It sets the global variables and draws the initial interface. + def build_display (a,b,c,goal): global window,target,current_stick,done,current_line,choice @@ -29,22 +57,44 @@ def build_display (a,b,c,goal): current_line = None window = actr.open_exp_window("Building Sticks Task",visible=visible,width=600,height=400) + # Add buttons for the participant to press in the window. + # The action specifies a command to call and any parameters to pass it + # when that button is pressed. The others describe the details of how + # the button is shown. + actr.add_button_to_exp_window(window, text="A", x=5, y=23, action=["bst-button-pressed",a,"under"], height=24, width=40) actr.add_button_to_exp_window(window, text="B", x=5, y=48, action=["bst-button-pressed",b,"over"], height=24, width=40) actr.add_button_to_exp_window(window, text="C", x=5, y=73, action=["bst-button-pressed",c,"under"], height=24, width=40) actr.add_button_to_exp_window(window, text="Reset", x=5, y=123, action="bst-reset-button-pressed", height=24, width=65) + # Draw the lines for the choices and target. + actr.add_line_to_exp_window(window,[75,35],[a + 75,35],"black") actr.add_line_to_exp_window(window,[75,60],[b + 75,60],"black") actr.add_line_to_exp_window(window,[75,85],[c + 75,85],"black") actr.add_line_to_exp_window(window,[75,110],[goal + 75,110],"green") + +# button_pressed will be added as the bst-button-pressed command +# for use as the action of the stick choice buttons. It takes +# a parameter to indicate the length of the stick and whether +# the stick is associated with under or over shoot as a first +# choice. + def button_pressed(len,dir): global choice,current_stick + # If there is no choice recorded for this trial + # set that to dir. + if not(choice): choice = dir + # If the trial is not done then add or subtract + # this stick from the target as appropriate and + # call update_current_line to check its length + # and redraw it. + if not(done): if current_stick > target: current_stick -= len @@ -53,6 +103,10 @@ def button_pressed(len,dir): update_current_line() +# reset_display will be added as the bst-reseet-button-pressed +# command for use as the action of the reset buttons. If the +# trial is not over, then it sets the current stick length to 0 +# and redraws it. def reset_display(): global current_stick @@ -61,10 +115,20 @@ def reset_display(): current_stick = 0 update_current_line() +# Add the commands for those two functions so they can be +# used as button actions. actr.add_command("bst-button-pressed",button_pressed,"Choice button action for the Building Sticks Task. Do not call directly") actr.add_command("bst-reset-button-pressed",reset_display,"Reset button action for the Building Sticks Task. Do not call directly") +# update_current_line compares the length of the current +# stick to the target stick length. If they match the +# the trial is over, it redraws the current line, and +# displays the done prompt. If it is zero it removes the +# line from the display. If there is a current line then +# it is updated to match the current length, and if there +# is not a current line then one is drawn and saved for +# future modification. def update_current_line(): global current_line,done @@ -82,6 +146,12 @@ def update_current_line(): else: current_line = actr.add_line_to_exp_window(window,[75,135],[current_stick + 75,135],"blue") +# do_experiment takes a required parameter which is +# a list of stick lengths and an optional parameter +# which indicates whether a person is doing the task. +# It draws the initial sticks and then waits for +# a person to complete the task or runs the model +# for up to a minute to do the task. def do_experiment(sticks, human=False): build_display(*sticks) @@ -94,6 +164,12 @@ def do_experiment(sticks, human=False): actr.start_hand_at_mouse() actr.run(60,visible) + +# wait_for_human takes no parameters. It waits for +# a person to finish the task, and then waits one +# more second after the done prompt is displayed to +# give the person a chance to read it. + def wait_for_human (): while not(done): actr.process_events() @@ -102,6 +178,18 @@ def wait_for_human (): while (actr.get_time(False) - start) < 1000: actr.process_events() +# bst_set takes three required parameters and one optional +# parameter. The first parameter indicates whether it +# is a person or the model performing the task, and the +# second indicates whether it should use a visible or +# virtual window. The third parameter is a list of +# stick lengths for the trials to present. The optional +# parameter indicates whether the model should learn from +# trial to trial or be reset before each new trial. +# It returns a list of strings indicating whether each +# trial presented was started with the over-shoot or +# under-shoot approach. + def bst_set(human,vis,stims,learn=True): global visible @@ -117,6 +205,18 @@ def bst_set(human,vis,stims,learn=True): return result +# test is used to run multiple instances of the 2 demo +# problems. It takes one required parameter which indicates +# how many times to run that set of two items, and an optional +# parameter to indicate if it should be a person or model +# doing the task. It returns a list with the counts of the +# times over-shoot was tried on each of the problems. +# When the model runs the task it is not learning, and starts +# each trial as if it were the first time doing the task. +# If the model is running once through the set then it will +# use a visible window to show the interaction, otherwise it +# will use a virtual window. + def test(n,human=False): l = len(no_learn_stims) @@ -138,6 +238,19 @@ def test(n,human=False): return result + +# experiment is used to run the full experiment multiple +# times and report the results and fit to the experiment data. +# It has a required parameter which indicates how many times +# to run the task, and an optional parameter indicating whether +# it should be a person performing the task. +# It collects the over- or under- shoot choices for each problem +# and computes the proportion of time it's chosen for comparison +# to the original data. It displays the data and its fit to the +# data from the original experiment along with the average utility +# value over the trials for each of the four productions in the +# model which make the choice. + def experiment(n,human=False): l = len(exp_stims) @@ -151,11 +264,13 @@ def experiment(n,human=False): if d[j] == "over": result[j] += 1 + # Usehide_output to suppress the output from the spp command in Python actr.hide_output() for p in p_values: p[1]+=production_u_value(p[0]) + # Use unhide_output to restore model output in Python actr.unhide_output() result = list(map(lambda x: 100 * x / n,result)) @@ -180,7 +295,8 @@ def experiment(n,human=False): for p in p_values: print("%-12s: %6.4f"%(p[0],p[1]/n)) - +# production_u_value returns the current :u parameter +# value from the indicated production. def production_u_value(prod): return actr.spp(prod,":u")[0][0] \ No newline at end of file diff --git a/tutorial/python/bst_ppm.py b/tutorial/python/bst_ppm.py index 3b9fdde..47e14eb 100644 --- a/tutorial/python/bst_ppm.py +++ b/tutorial/python/bst_ppm.py @@ -1,7 +1,26 @@ +# ACT-R tutorial unit6 building sticks experiment. +# This experiment displays three posssible sticks +# which can be used to create a given target stick's +# length. It is an isomorph of Luchins water jug +# problem, and the experiment for the model is the +# one from: +# +# Lovett, M. C., & Anderson, J. R. (1996). History of success +# and current context in problem solving: Combined influences +# on operator selection. Cognitive Psychology, 31, 168-217. +# +# The task is presented with buttons to pick the sticks +# and a button to reset the current trial. + +# Import the actr module for tutorial tasks and the numbers +# module for the Number class + import actr -import math import numbers +# Global variables to hold the information about the +# current trial information. + target = None current_stick = None current_line = None @@ -10,6 +29,10 @@ window = None visible = False +# The data from the experiment, the lengths of the sticks +# used in the experiment, and two example problems for +# demonstration. + exp_data = [20, 67, 20, 47, 87, 20, 80, 93, 83, 13, 29, 27, 80, 73, 53] exp_stims = [[15,250,55,125],[10,155,22,101],[14,200,37,112], [22,200,32,114],[10,243,37,159],[22,175,40,73], @@ -19,6 +42,9 @@ no_learn_stims = [[15,200,41,103],[10,200,29,132]] +# build_display takes the lengths of the sticks for a trial. +# It sets the global variables and draws the initial interface. + def build_display (a,b,c,goal): global window,target,current_stick,done,current_line,choice @@ -39,6 +65,12 @@ def build_display (a,b,c,goal): actr.add_line_to_exp_window(window,[75,85],[c + 75,85],"black") actr.add_line_to_exp_window(window,[75,110],[goal + 75,110],"green") +# button_pressed will be added as the bst-button-pressed command +# for use as the action of the stick choice buttons. It takes +# a parameter to indicate the length of the stick and whether +# the stick is associated with under or over shoot as a first +# choice. + def button_pressed(len,dir): global choice,current_stick @@ -53,6 +85,10 @@ def button_pressed(len,dir): update_current_line() +# reset_display will be added as the bst-reseet-button-pressed +# command for use as the action of the reset buttons. If the +# trial is not over, then it sets the current stick length to 0 +# and redraws it. def reset_display(): global current_stick @@ -61,10 +97,20 @@ def reset_display(): current_stick = 0 update_current_line() +# Add the commands for those two functions so they can be +# used as button actions. actr.add_command("bst-ppm-button-pressed",button_pressed,"Choice button action for the Building Sticks Task. Do not call directly") actr.add_command("bst-ppm-reset-button-pressed",reset_display,"Reset button action for the Building Sticks Task. Do not call directly") +# update_current_line compares the length of the current +# stick to the target stick length. If they match the +# the trial is over, it redraws the current line, and +# displays the done prompt. If it is zero it removes the +# line from the display. If there is a current line then +# it is updated to match the current length, and if there +# is not a current line then one is drawn and saved for +# future modification. def update_current_line(): global current_line,done @@ -82,6 +128,12 @@ def update_current_line(): else: current_line = actr.add_line_to_exp_window(window,[75,135],[current_stick + 75,135],"blue") +# do_experiment takes a required parameter which is +# a list of stick lengths and an optional parameter +# which indicates whether a person is doing the task. +# It draws the initial sticks and then waits for +# a person to complete the task or runs the model +# for up to a minute to do the task. def do_experiment(sticks, human=False): build_display(*sticks) @@ -94,6 +146,11 @@ def do_experiment(sticks, human=False): actr.start_hand_at_mouse() actr.run(60,visible) +# wait_for_human takes no parameters. It waits for +# a person to finish the task, and then waits one +# more second after the done prompt is displayed to +# give the person a chance to read it. + def wait_for_human (): while not(done): actr.process_events() @@ -102,6 +159,18 @@ def wait_for_human (): while (actr.get_time(False) - start) < 1000: actr.process_events() +# bst_set takes three required parameters and one optional +# parameter. The first parameter indicates whether it +# is a person or the model performing the task, and the +# second indicates whether it should use a visible or +# virtual window. The third parameter is a list of +# stick lengths for the trials to present. The optional +# parameter indicates whether the model should learn from +# trial to trial or be reset before each new trial. +# It returns a list of strings indicating whether each +# trial presented was started with the over-shoot or +# under-shoot approach. + def bst_set(human,vis,stims,learn=True): global visible @@ -117,6 +186,18 @@ def bst_set(human,vis,stims,learn=True): return result +# test is used to run multiple instances of the 2 demo +# problems. It takes one required parameter which indicates +# how many times to run that set of two items, and an optional +# parameter to indicate if it should be a person or model +# doing the task. It returns a list with the counts of the +# times over-shoot was tried on each of the problems. +# When the model runs the task it is not learning, and starts +# each trial as if it were the first time doing the task. +# If the model is running once through the set then it will +# use a visible window to show the interaction, otherwise it +# will use a virtual window. + def test(n,human=False): l = len(no_learn_stims) @@ -138,6 +219,19 @@ def test(n,human=False): return result + +# experiment is used to run the full experiment multiple +# times and report the results and fit to the experiment data. +# It has a required parameter which indicates how many times +# to run the task, and an optional parameter indicating whether +# it should be a person performing the task. +# It collects the over- or under- shoot choices for each problem +# and computes the proportion of time it's chosen for comparison +# to the original data. It displays the data and its fit to the +# data from the original experiment along with the average utility +# value over the trials for each of the four productions in the +# model which make the choice. + def experiment(n,human=False): l = len(exp_stims) @@ -180,11 +274,16 @@ def experiment(n,human=False): for p in p_values: print("%-12s: %6.4f"%(p[0],p[1]/n)) - +# production_u_value returns the current :u parameter +# value from the indicated production. def production_u_value(prod): return actr.spp(prod,":u")[0][0] +# A similarity hook function to return +# similarity values between numbers which +# are expected to be line lengths. + def number_sims(a,b): if isinstance(b,numbers.Number) and isinstance(a,numbers.Number): return abs(a - b) / -300 @@ -193,7 +292,16 @@ def number_sims(a,b): actr.add_command("bst-number-sims",number_sims,"Similarity hook function for building sticks task.") - +# The compute_difference function is used as the +# function called by an imaginal-action buffer +# request. It creates a chunk which is a copy of +# the chunk in the imaginal buffer and adds a +# slot called difference which holds the difference +# between the length of the current line and the +# target line. That chunk's name is returned +# so that the imaginal module will place it into +# the imaginal buffer. + def compute_difference(): c = actr.buffer_read('imaginal') n = actr.copy_chunk(c) @@ -202,4 +310,9 @@ def compute_difference(): actr.add_command("bst-compute-difference",compute_difference,"Imaginal action function to compute the difference between sticks.") + +# Load the corresponding ACT-R starting model. +# Done after adding the bst-compute-difference and bst-number-sims +# commands because they are used in the model and should exist first. + actr.load_act_r_model ("ACT-R:tutorial;unit8;bst-ppm-model.lisp") diff --git a/tutorial/python/categorize.py b/tutorial/python/categorize.py index 3ccaf2b..3dae810 100644 --- a/tutorial/python/categorize.py +++ b/tutorial/python/categorize.py @@ -1,7 +1,29 @@ +# ACT-R tutorial unit8 categorization experiment. +# This task sequentially presents the model with +# features which the model must classify as +# being small, medium, or large given a numeric +# description, and then after those features have +# been encoded it must make a choice as to which +# category of items it belongs based on the +# examples that it has pre-encoded in declarative +# memory. It is an abstraction and simplification +# of a face categorizing task: +# +# Nosofsky, R. M. (1991). Tests of an exemplar model for relating +# perceptual classification and recognition memory. Journal of Experimental +# Psychology: Human Perception and Performance. 17, 3-27. + +# Import the actr module for tutorial tasks, the math +# module for sqrt, pi, and exp, and the numbers module +# for the Number class. + import actr import math import numbers +# These are the feature sets for the categories (based on +# the general values). + cat1 = [["small","large","medium","small"], ["medium","small","large","medium"], ["small","medium","medium","medium"], @@ -14,6 +36,10 @@ ["large","small","large","large"], ["large","small","small","large"]] +# This is the data indicating the category 1 choice proportions +# for the set of stims below (represented by their underlying +# normalized numeric values) + cat_data = [0.975, 0.85, 0.987, 1.0, 0.963, 0.075, 0.138, 0.087, 0.05, 0.025, 0.937, 0.544, 0.988, 0.087] stims = [[-1.025, 0.493, 0.048, -0.666], @@ -31,12 +57,20 @@ [-0.856, 0.197, 0.241, 0.007], [0.704, -0.287, -0.164, 0.178]] + +# Global values for the similarity distribution, the mapping of +# sizes to an anchor point, the default slot names, and the +# offset to use for the presented stimulus values. + sigma2 = .15 size_mappings = {"small":-.9, "medium":0, "large":.9} slots = ["eh", "es", "nl", "mh"] - offset = 0 +# Functions for computing the similarity values using a +# normal distribution around the anchor point for a value +# and then scaling them from -1 to 0. + def scale_sim(x, max): return( (x / max) - 1.0) @@ -54,6 +88,15 @@ def size_similarities(a, b): actr.add_command("size-similarities", size_similarities,"Categorize model's similarity hook function.") +# categorize-stimulus resets the model and then presents the four +# feature values provided (which should be numbers from -2 to 2) to +# the model with the default slot names for features and then +# creates a goal chunk with state categorize for the model to +# determine a category for the features it encoded. If the +# model provides a category of 1 or 2 (by setting the category slot +# of the chunk in the imaginal buffer) then that value is +# returned, otherwise it returns nil. + def stimulus(a,b,c,d): global offset,slots @@ -65,12 +108,33 @@ def stimulus(a,b,c,d): else: return (False) +# categorize-attribute takes two values which represent the +# name and value for an attribute in the task. it presents +# the attribute to the model by setting slots of the chunk in +# the goal buffer and then running the model. The state slot +# is set to add-attribute, the name slot is set to the name +# provided, and the value slot is set to the value provided. +# The model should encode that value into a general description +# (small, medium, or large) and store that into a slot of the +# chunk in the imaginal buffer with the provided name. +# It does not reset the model. + def attribute(name,value): - goal = actr.define_chunks(["state","add-attribute","name",name,"value", (value + offset)])[0] - actr.goal_focus(goal) + actr.schedule_set_buffer_chunk("goal",["state","add-attribute","name",name,"value", (value + offset)], 0) actr.run(20) +# categorize-experiment takes one required value which +# is how many times to run the whole experiment (one presentation +# of each of the 14 testing stims). It has one optional parameter +# which indicates an offset to add to the values that are presented +# if it is provided, and accepts 4 additional parameters which +# specify the names of the attributes to present to the model (the +# default names will be used if none are provided). It runs the +# experiments, determines the proportion of category choices for +# each item, reports the fit to the experimental data, and prints +# out the proportion of choices for category 1. + def experiment(n,new_offset=0,s1="eh",s2="es",s3="nl",s4="mh"): global offset,slots @@ -153,8 +217,7 @@ def trial(*features): for slot,value in actr.permute_list(list(zip(slots,features))): attribute(slot,value) - goal = actr.define_chunks(["state","categorize"])[0] - actr.goal_focus(goal) + actr.schedule_set_buffer_chunk("goal",["state","categorize"], 0) actr.run(20) answer = actr.chunk_slot_value(actr.buffer_read("imaginal"),"category") @@ -169,6 +232,15 @@ def trial(*features): actr.model_output("Model did not respond or provided a non-numeric category.") return((0,False)) +# create-example-memories is called in the model +# definition to add chunks for the training examples +# to the model's declarative memory. The chunks are +# created with the appropriate slots for the features +# based on the values provided by the modeler to +# run the experiment or the default slots if not +# running the experiment or alternate names were +# not provided. + def create_example_memories(): for s in slots: @@ -191,6 +263,10 @@ def create_example_memories(): actr.add_command("create-example-memories",create_example_memories,"Categorize task function to add the initial example chunks to simulate the training process.") +# Need to load the model after the "create-example-memories" command +# has been added since that command is called during the model +# creation. + actr.load_act_r_model("ACT-R:tutorial;unit8;categorize-model.lisp") diff --git a/tutorial/python/demo2.py b/tutorial/python/demo2.py index beac015..35cb7d8 100644 --- a/tutorial/python/demo2.py +++ b/tutorial/python/demo2.py @@ -1,46 +1,140 @@ +# ACT-R tutorial unit 2 demo2 task. +# This experiment opens a window, displays a character, +# waits for a keypress, clears the window after there +# is a keypress, and then reports the key that was pressed. + +# Import the actr module for tutorial tasks import actr +# Load the corresponding tutorial model + actr.load_act_r_model("ACT-R:tutorial;unit2;demo2-model.lisp") + +# Create a variable to store the key that was pressed. + response = False + +# This is the function which we will have ACT-R call when +# a key is pressed in the experiment window which is signaled +# by the output-key action. + +# That action provides two parameters to the function called. +# The first is the name of the model that performed the keypress +# or None if it wasn't generated by a model, and the second +# is a string with the name of the key that was pressed. + + def respond_to_key_press (model,key): - global response + # store the key that was pressed in the response variable + # call the AGI command that clears the window + + global response response = key + actr.clear_exp_window() + + + +# This is the function that runs the experiment for either a +# person or a model. It has one optional parameter which if +# provided as True will run a person. +# If it is not provided or any other value is specified then +# it will run the model. def experiment (human=False): + # Reset the ACT-R system and any models that are defined to + # their initial states. + actr.reset() + # Create three variable: + # items - a randomized list of letter strings which is randomized + # using the ACT-R function permute_list + # text1 - the first string from the randomized list which will be the + # one presented in the experiment + # window - the ACT-R window device list returned by using the ACT-R + # function open_exp_window to create a new window for + # displaying the experiment + + items = actr.permute_list(["B","C","D","F","G","H","J","K","L", "M","N","P","Q","R","S","T","V","W", "X","Y","Z"]) text1 = items[0] window = actr.open_exp_window("Letter recognition") + # display the text1 item in the window that was opened + actr.add_text_to_exp_window(window, text1, x=125, y=150) + + # These next two function calls are how we tell ACT-R that it should + # call our respond_to_key_press function when there is a keypress + # in the experiment. + + # First we need to create a command in ACT-R that corresponds + # to our function so that ACT-R is able to use the function. + actr.add_command("demo2-key-press",respond_to_key_press, "Demo2 task output-key monitor") + + # Then, we use that command which we created to 'monitor' + # the output-key action which is triggered by keypress in the + # experiment window of ACT-R so that when an output-key happens + # our function is called. + actr.monitor_command("output-key","demo2-key-press") - + + # Set the response value to False to remove any value it may + # have from a previous run of the experiment. + global response response = False + # Here is where we actually "run" the experiment. + # It either waits for a person to press a key or runs ACT-R + # for up to 10 seconds giving the model a chance to do the + # experiment. + + if human == True: + + # If a person is doing the task then for safety + # we make sure there is a visible window that they + # can use to do the task, and if so, loop until the + # response variable is not False calling the ACT-R + # process_events function to allow the system a + # chance to handle any interactions. + if actr.visible_virtuals_available(): while response == False: actr.process_events() else: + + # If it is not a human then use install_device so that + # the features in the window will be seen by the model + # (that will also automatically provide the model with + # access to a virtual keyboard and mouse). Then use + # the ACT-R run function to run the model for up to 10 + # seconds in real-time mode. + actr.install_device(window) actr.run(10,True) + # To avoid any issues with our function for keypresses in this + # experiment interfering with other experiments we should stop + # monitoring output-key and then remove our command. + actr.remove_command_monitor("output-key","demo2-key-press") actr.remove_command("demo2-key-press") + # return the result of the keypress + return response diff --git a/tutorial/python/fan.py b/tutorial/python/fan.py index 17194e4..8f0b7ed 100644 --- a/tutorial/python/fan.py +++ b/tutorial/python/fan.py @@ -1,7 +1,30 @@ +# ACT-R tutorial unit 5 fan task. +# This experiment presents a model with a person-location pair +# of items and the model must respond whether that pair of items +# was part of the study set that it has recorded in memory. +# The task and data to which the model is fit are in the paper: +# +# Anderson, J. R. (1974). Retrieval of propositional information from +# long-term memory. Cognitive Psychology, 5, 451 - 474. +# +# The results are reported are the time to respond to the probe +# based on the 'fan' of the items presented (how many places a person +# is in or how many people are in the place) and whether the probe +# is or isn't in the test set. +# +# This version of the task presents the probe items in a window +# which the model must read to complete the task. + +# Import the actr module for tutorial tasks + import actr +# Load the corresponding model for the task. + actr.load_act_r_model("ACT-R:tutorial;unit5;fan-model.lisp") +# Create a variable with the original experiment data. + person_location_data = [1.11, 1.17, 1.22, 1.17, 1.20, 1.22, 1.15, 1.23, 1.36, @@ -9,9 +32,25 @@ 1.25, 1.36, 1.29, 1.26, 1.47, 1.47] +# create variables to hold the model's response and the time of +# that response. + response = False response_time = False + +# The sentence function takes 4 parameters. +# The first two are the strings of the person and location +# to present. The third is True or False to indicate whether +# this was or wasn't in the study set, and the last is +# either the string 'person' or 'location' to indicate which +# of the productions the model should use for retrieval. +# +# It presents the probe items given in a window, runs the +# model, and returns a tuple indicating how many seconds it +# took to respond (or 30 if no response was made) and True or False +# to indicate if the response was correct. + def sentence (person, location, target, term): actr.reset() @@ -24,6 +63,8 @@ def sentence (person, location, target, term): actr.add_command("fan-response",respond_to_key_press,"Fan experiment model response") actr.monitor_command("output-key","fan-response") + # disable the production that isn't being used for retrieval + if term == 'person': actr.pdisable("retrieve-from-location") else: @@ -57,12 +98,20 @@ def sentence (person, location, target, term): return (response_time / 1000,False) +# respond_to_key_press is set to monitor the output-key command +# and records the time and key that was pressed by the model. + def respond_to_key_press (model,key): global response,response_time response_time = actr.get_time() response = key +# do_person_location requires one parameter which is either +# the string 'person' or 'location' to indicate which of the +# productions the model should use for retrieval. +# It runs one trial of each fan condition and returns a list +# of the results. def do_person_location(term): @@ -91,6 +140,9 @@ def do_person_location(term): return results +# experiment runs the model through one trial of +# each condition using each of the retrieval productions +# and averages the results then displays the results. def experiment(): diff --git a/tutorial/python/fan_no_pm.py b/tutorial/python/fan_no_pm.py index ea48f51..b845bf2 100644 --- a/tutorial/python/fan_no_pm.py +++ b/tutorial/python/fan_no_pm.py @@ -1,7 +1,32 @@ +# ACT-R tutorial unit 5 fan task. +# This experiment presents a model with a person-location pair +# of items and the model must respond whether that pair of items +# was part of the study set that it has recorded in memory. +# The task and data to which the model is fit are in the paper: +# +# Anderson, J. R. (1974). Retrieval of propositional information from +# long-term memory. Cognitive Psychology, 5, 451 - 474. +# +# The results are reported are the time to respond to the probe +# based on the 'fan' of the items presented (how many places a person +# is in or how many people are in the place) and whether the probe +# is or isn't in the test set. +# +# This version of the task does not use the perceptual or motor +# modules of ACT-R and instead places the probes directly into +# slots of the goal buffer and reads the model's response from +# a slot of the goal buffer when done. + +# Import the actr module for tutorial tasks + import actr +# Load the corresponding model for the task. + actr.load_act_r_model("ACT-R:tutorial;unit5;fan-no-pm-model.lisp") +# Create a variable with the original experiment data. + person_location_data = [1.11, 1.17, 1.22, 1.17, 1.20, 1.22, 1.15, 1.23, 1.36, @@ -9,19 +34,41 @@ 1.25, 1.36, 1.29, 1.26, 1.47, 1.47] +# The sentence function takes 4 parameters. +# The first two are the strings with a string of the person and location +# to present e.g. "'hippie'". The third is True or False to indicate whether +# this was or wasn't in the study set, and the last is +# either the string 'person' or 'location' to indicate which +# of the productions the model should use for retrieval. +# +# It presents the probe items given directly to the model +# through the goal buffer, runs the model, and +# returns a tuple indicating how many seconds the model +# ran and True or False to indicate if the response was correct. + def sentence (person, location, target, term): actr.reset() + # disable the production that isn't being used for retrieval + if term == 'person': actr.pdisable("retrieve-from-location") else: actr.pdisable("retrieve-from-person") + # modify the chunk named goal (which will be placed into the goal buffer + # when the model runs) to set the arg1 and arg2 slots to the probe + # items and state slot to test + actr.mod_chunk("goal","arg1",person,"arg2",location,"state","test") + # run the model recording the time spent running + # and get the value from the state slot of the goal buffer representing the + # model's response to the task + response_time = actr.run(30)[0] - response = actr.chunk_slot_value(actr.buffer_read("goal"),"state") + response = actr.buffer_slot_value("goal","state") if target: if response.lower() == "'k'".lower(): @@ -34,7 +81,11 @@ def sentence (person, location, target, term): else: return (response_time ,False) - +# do_person_location requires one parameter which is either +# the string 'person' or 'location' to indicate which of the +# productions the model should use for retrieval. +# It runs one trial of each fan condition and returns a list +# of the results. def do_person_location(term): @@ -63,6 +114,9 @@ def do_person_location(term): return data +# experiment runs the model through one trial of +# each condition using each of the retrieval productions +# and averages the results then displays the results. def experiment(): diff --git a/tutorial/python/grouped.py b/tutorial/python/grouped.py index 5851d89..a45cfab 100644 --- a/tutorial/python/grouped.py +++ b/tutorial/python/grouped.py @@ -1,10 +1,25 @@ +# ACT-R tutorial unit 5 grouped task. +# This is a simple example task to show partial matching. +# It simply runs the model and records values that the +# model provides and returns the list of provided values +# in the order provided after the run. + +# Import the actr module for tutorial tasks import actr +# Load the corresponding model for the task. + actr.load_act_r_model("ACT-R:tutorial;unit5;grouped-model.lisp") +# Create a variable to hold the responses + response = [] +# The recall function creates a command for +# the record_response function, clears the response +# list, runs the model, and returns the response list. + def recall (): actr.add_command("grouped-response",record_response,"Response recording function for the tutorial grouped model.") @@ -15,6 +30,9 @@ def recall (): actr.remove_command("grouped-response") return response + +# Store a value provided by the model on the response list + def record_response (item): global response diff --git a/tutorial/python/onehit.py b/tutorial/python/onehit.py index 6b20f00..24bb654 100644 --- a/tutorial/python/onehit.py +++ b/tutorial/python/onehit.py @@ -1,7 +1,27 @@ +# ACT-R tutorial unit 5 one-hit blackjack task +# +# This file implements the one-hit blackjack game +# that is described in the unit text and allows +# one to run a model against a human opponent or +# an opponent controlled by functions created +# to play the game. It also allows one to control +# the decks of cards that are used to provide +# different situations for the model to learn. + +# Import the actr module for tutorial tasks, math +# for the floor function, and numbers for the Number class. + import actr import math import numbers + +# Before loading the model define the function +# that will be used to compute the similarities +# between numbers and add a command for it because +# that command name is used in the model's parameter +# settings. + def onehit_bj_number_sims(a,b): if isinstance(b,numbers.Number) and isinstance(a,numbers.Number): @@ -14,6 +34,12 @@ def onehit_bj_number_sims(a,b): actr.load_act_r_model("ACT-R:tutorial;unit5;1hit-blackjack-model.lisp") + +# Define a lot of global variables to control the +# details of the game, a code-based opponent, +# record responses, and keep track of whether the +# output-key action is being monitored. + deck1 = None deck2 = None opponent_rule = None @@ -23,6 +49,13 @@ def onehit_bj_number_sims(a,b): opponent_threshold = None key_monitor_installed = False + +# respond_to_keypress will be monitoring the +# output-key command and will be called when a +# key is pressed by the model or a human playing +# the game. It records the key in the corresponding +# variable based on who made it. + def respond_to_keypress(model,key): global model_action,human_action @@ -31,7 +64,11 @@ def respond_to_keypress(model,key): else: human_action = key - +# These functions are used to create the command and monitor +# output-key and correspondingly remove the monitor and command +# when needed because it is more efficient to do so once instead +# of on each trial (as has been done for most prior tasks) since +# this will require running many trials to collect the data. def add_key_monitor(): global key_monitor_installed @@ -53,6 +90,12 @@ def remove_key_monitor(): global key_monitor_installed key_monitor_installed = False +# hands takes one required parameter which is a number of +# hands to play and an optional parameter which if specified as +# True will print out the details of the hands. +# It plays the game based on the settings of the global varaibles +# for the decks of cards and opponent functions and returns the +# list of results. def hands(hands,print_game=False): @@ -102,6 +145,11 @@ def hands(hands,print_game=False): return scores +# blocks takes two required parameters which are how many +# blocks of hands to play and how many hands are in a block. +# It plays the specified number of blocks and returns the list +# of results by block. + def blocks(blocks,block_size): res = [] @@ -115,6 +163,12 @@ def blocks(blocks,block_size): return res +# game0 function sets the global variables to configure +# the default game -- the regular distribution of cards +# in a deck and an opponent which has a fixed threshold +# of 15 for deciding whether to hit or stay and which does +# not process the feedback. + def game0(): global deck1,deck2,opponent_threshold,opponent_rule,opponent_feedback @@ -124,10 +178,22 @@ def game0(): opponent_threshold = 15 opponent_feedback = None +# sum_lists is used to add results lists +# together for the data collection below def sum_lists(x,y): return list(map(lambda v,w: v + w,x,y)) + +# learning requires one paramter which is how many 100 hand +# games to play. There are two optional paramters which +# indicate whether a graph of the results should be drawn +# in an experiment window (default is t which draws it) +# and to specify a function to use to set the variables that +# configure the game play (the default is game0). +# It returns a list with the average win percentages from +# the n games in both blocks of 20 and blocks of 5 hands. + def learning(n,graph=True,game=game0): data = [[0,0,0,0]]*20 @@ -152,6 +218,8 @@ def learning(n,graph=True,game=game0): sum(percentages[15:20])/5], percentages] +# draw_graph takes a list of percentages and displays them in +# a graph using an experiment window for output. def draw_graph(points): @@ -172,9 +240,19 @@ def draw_graph(points): 'blue') x += 25 + +# deal takes a deck function and returns a list of +# the next three cards that it returns when called. + def deal(deck): return [deck(),deck(),deck()] + +# score_cards takes a list of cards and an optional value +# indicating the number over which a hand busts (defaults to 21). +# It returns the total value of those cards treating 1s as 11 +# if possible without busting. + def score_cards(cards,bust=21): total = sum(cards) @@ -185,6 +263,11 @@ def score_cards(cards,bust=21): return total +# compute_outcome takes a list of cards for each player and an +# optional value indicating the number over which a hand busts. +# It computes the total for each hand of cards and returns the +# result (win, lose, or bust) for the first list of cards. + def compute_outcome(p1cards,p2cards,bust=21): p1tot = score_cards(p1cards,bust) p2tot = score_cards(p2cards,bust) @@ -197,6 +280,14 @@ def compute_outcome(p1cards,p2cards,bust=21): else: return 'lose' +# show_model_cards takes two parameters. The first is a list of +# the model's starting cards and the second is the opponent's face +# up card. If there is a chunk in the model's goal buffer it is +# modified to the initial state of the game. If there is not a +# chunk in the goal buffer then a new chunk is created and placed +# into the buffer. Then the model is run for exactly 10 seconds +# and any response it made is returned. + def show_model_cards(mcards,ocard): if actr.buffer_read('goal'): @@ -215,6 +306,16 @@ def show_model_cards(mcards,ocard): actr.run_full_time(10) return model_action +# show_model_results takes four parameters. The first is a list of +# the model's final cards and the second is the list of the opponent's +# final cards. The third is the model's end result and the fourth is +# the opponents end result. +# If there is a chunk in the model's goal buffer it is modified to +# the results state of the game with all the information. If there +# is not a chunk in the goal buffer then a new chunk is created with +# the results information and placed into the buffer. Then the model +# is run for exactly 10 seconds. + def show_model_results(mcards,ocards,mres,ores): if len(mcards) ==3: @@ -243,6 +344,14 @@ def show_model_results(mcards,ocards,mres,ores): actr.run_full_time(10) + +# play_human takes two parameters. The first is the list of +# the player's cards and the other is the model's face up card. +# It opens an experiment window to display that information to +# a person and waits exactly 10 seconds before continuing the +# game. It returns the key press the player made, or 's' (stay) +# if no key was pressed. + def play_human(cards,oc1): win = actr.open_exp_window('Human') @@ -270,6 +379,13 @@ def play_human(cards,oc1): else: return 's' +# show_human_results takes four parameters. The first is a list of +# the player's final cards and the second is the list of the model's +# final cards. The third is the player's end result and the fourth is +# the model's end result. +# All of the cards and outcomes are displayed in an experiment +# window and it waits 10 seconds before continuing. + def show_human_results(own_cards,others_cards,own_result,others_result): win = actr.open_exp_window('Human') @@ -296,6 +412,14 @@ def show_human_results(own_cards,others_cards,own_result,others_result): while (actr.get_time(False) - start_time) < 10000: actr.process_events() +# play_against_model requries one parameter which is how many +# hands to play and an optional parameter indicating whether +# the hand information should be printed. It sets the global +# variables to those needed to have a person play against the +# model and then runs for the indicated number of hands. After +# that, it sets the variables back to the values they had +# before. + def play_against_model(count,print_games=False): global opponent_rule,opponent_feedback @@ -317,6 +441,10 @@ def play_against_model(count,print_games=False): else: actr.print_warning("Cannot play against the model without a visible window available.") +# show_opponent_cards and show_opponent_results are used +# by the game code to call the appropriate function for +# the non-model player to receive the game information. + def show_opponent_cards(ocards,mc1): return opponent_rule(ocards,mc1) @@ -325,9 +453,23 @@ def show_opponent_results(ocards,mcards,ores,mres): opponent_feedback(ocards,mcards,ores,mres) +# The functions below are used to create the game0 and game1 +# situations. + + +# regular_deck takes no parameters and returns a number +# between 1 and 10 with 10s being 4 times as likely as +# other numbers. This is used as the deck function for +# both players in game0. + def regular_deck(): return min(10,actr.random(13)+1) + +# fixed_threshold implements a rule for an opponent +# that will always hit below a fixed threshold. It +# is used in game0 for the opponent. + def fixed_threshold(cards,mc1): if score_cards(cards) < opponent_threshold: @@ -335,13 +477,25 @@ def fixed_threshold(cards,mc1): else: return 's' +# always_hit implements a rule for an opponent +# that will always hit. It is used for the opponent +# in game1. - -card_list = [] - def always_hit(cards,mc1): return 'h' +# Create a variable for a list of cards, and +# a function that will place the 6 cards onto +# that list for the player decks (the first 3 +# cards are the model's and the next 3 are for +# the opponent). That deck function is used for +# both players and represents the situation in +# game1 where the opponent's face up card is +# a perfect predictor for the action the model +# needs to take to win. + +card_list = [] + def load_stacked_deck(): c1 = 5 + actr.random(6) c2 = 7 + actr.random(4) @@ -369,7 +523,10 @@ def stacked_deck(): card_list = card_list[1:] return c - + +# function to set variables to the values needed to +# implement game1 + def game1(): global deck1,deck2,opponent_threshold,opponent_rule,opponent_feedback,card_list @@ -379,5 +536,6 @@ def game1(): opponent_rule = always_hit opponent_feedback = None +# call game0 to set the initial game variable values. -game0() \ No newline at end of file +game0() diff --git a/tutorial/python/paired.py b/tutorial/python/paired.py index 40c62dd..56264da 100644 --- a/tutorial/python/paired.py +++ b/tutorial/python/paired.py @@ -1,7 +1,27 @@ +# ACT-R tutorial unit 4 paired associate task. +# This experiment runs several trials of presenting a +# word prompt, and waiting 5 seconds for a response, +# then it displays the correct response (which will be +# a digit) and waits 5 seconds before starting the next +# trial. The time to respond to the initial prompt and +# the correctness of the response are recorded for +# comparison to the humam data of the task that had +# 20 different pairs (the digits were each paired with +# two words) over 8 blocks (a randomized ordering of the +# 20 pairs). + +# Import the actr module for tutorial tasks + import actr +# Load the corresponding model for the task + actr.load_act_r_model("ACT-R:tutorial;unit4;paired-model.lisp") +# Global variables to hold the participant's response, the time of +# that response, the possible stimuli, and the data from the +# original experiment. + response = False response_time = False @@ -12,12 +32,22 @@ latencies = [0.0, 2.158, 1.967, 1.762, 1.680, 1.552, 1.467, 1.402] probabilities = [0.0, .526, .667, .798, .887, .924, .958, .954] +# task takes two required parameters: the number of stimuli to +# present in a block and the number of blocks to run. The optional +# parameter if specified as True will run a person instead of the model. + def task (size,trials,human=False): + # Create a command for the respond_to_key_press function so that + # it can be used to monitor "output-key". + actr.add_command("paired-response",respond_to_key_press, "Paired associate task key press response monitor") actr.monitor_command("output-key","paired-response") + # Run the function that does the actual experiment, remove the monitor + # and command that were added, and return the results. + result = do_experiment(size,trials,human) actr.remove_command_monitor("output-key","paired-response") @@ -25,6 +55,11 @@ def task (size,trials,human=False): return result +# respond_to_key_press will record the time of a key press +# using actr.get_time (which reports model time if passed a true +# value or real time if passed None/False, and model will be None +# if it is a person performing the task) and the key that +# was pressed. def respond_to_key_press (model,key): global response,response_time @@ -33,6 +68,14 @@ def respond_to_key_press (model,key): response = key +# do_experiment takes three parameters, the number of pairs to +# present per block, the number of blocks, and whether it is a +# person performing the task. It runs the number of blocks +# requested collecting the correctness and timing data per +# block, and then returns a list with lists where each sublist +# represents a block with the first item being % correct and +# the second mean response time. + def do_experiment(size, trials, human): @@ -42,6 +85,11 @@ def do_experiment(size, trials, human): actr.reset() + # create a varaible to hold the data, an indication of whether the + # model is performing the task, and an opened experiment window that + # is visible if a human is performing the task or virtual if it is + # a model. + result = [] model = not(human) window = actr.open_exp_window("Paired-Associate Experiment", visible=human) @@ -49,39 +97,65 @@ def do_experiment(size, trials, human): if model: actr.install_device(window) + # loop over the number of blocks + for i in range(trials): score = 0 time = 0 + # randomize the list of items to present which are + # taken from the possible pairs + for prompt,associate in actr.permute_list(pairs[20 - size:]): + # clear the window and display the prompt + actr.clear_exp_window(window) actr.add_text_to_exp_window (window, prompt, x=150 , y=150) + # clear the response and record the time when the trial + # is started + global response response = '' start = actr.get_time(model) + # If it's the model run it for exactly 5 seconds + # and if it's a person wait for 5 seconds of real + # time to pass. + if model: actr.run_full_time(5) else: while (actr.get_time(False) - start) < 5000: actr.process_events() + # If there is a correct response increment the + # count of correct answers and the cumulative + # response times. + if response == associate: score += 1 time += response_time - start + # Clear the window and display the correct response + actr.clear_exp_window(window) actr.add_text_to_exp_window (window, associate, x=150 , y=150) start = actr.get_time(model) + # If it's the model run it for exactly 5 seconds + # and if it's a person wait for 5 seconds of real + # time to pass. + if model: actr.run_full_time(5) else: while (actr.get_time(False) - start) < 5000: actr.process_events() + # Record the score and time data in the result list + if score > 0: average_time = time / score / 1000.0 else: @@ -91,6 +165,13 @@ def do_experiment(size, trials, human): return result + +# experiment takes one required parameter which is the number of times +# to run a model through the original experiment (20 pairs for 8 trials each). +# It collects the data from those trials which is passed to the output_data +# function for averaging and comparison to the original data. + + def experiment(n): for i in range(n): @@ -102,6 +183,12 @@ def experiment(n): output_data(data,n) +# output_data takes two required parameters which are a list of cumulative +# data items from the experiment and the number of experiment repetitions +# that were collected. It averages the results of the latency and accuracy +# data and calls print_results to display the comparison to the original +# data along with the average results. + def output_data(data,n): print_results(list(map(lambda x: x[1]/n,data)),latencies,"Latency") diff --git a/tutorial/python/past_tense.py b/tutorial/python/past_tense.py index 82f2517..a0b8e36 100644 --- a/tutorial/python/past_tense.py +++ b/tutorial/python/past_tense.py @@ -1,8 +1,32 @@ +# ACT-R tutorial unit 7 past-tense task. +# This task presents the model with an English +# verb (taken from a very small sample of verbs) +# randomly chosen based on the frequency of that +# verb's usage relative to the other verbs in the +# set. The model is then supposed to generate +# the past-tense for that verb. For every verb +# that the model must generate, it receives two +# randomly chosen correctly formed past-tenses +# which are merged into declarative memory. The +# code reports the percentages of correctly and +# incorrectly formed past-tenses by the model and +# will display a graph of the correctness for the +# irregular verbs which tend to show a U-shape in +# their learning. + +# Import the actr module for tutorial tasks and +# math for the floor and ceil functions. + import actr import math +# Load the corresponding model for the task + actr.load_act_r_model("ACT-R:tutorial;unit7;past-tense-model.lisp") +# Global variables to hold the collected data and the verbs +# along with their frequencies. + report = [] total_count = 0 word_list = [] @@ -30,6 +54,18 @@ ['start','r',386,'start'], ['lose','i',274,'lost']] + +# make_word_freq_list takes one parameter which is a list +# of verb description lists (as created above for the verbs +# variable) that contains the verb, whether it has a regular +# or irregular past-tense, it's relative frequency, and the +# stem for its past-tense (either the verb itself for a regular +# or the correct irregular inflection). It returns a list +# with a list for each verb that has a cumulative frequency +# value and the three components for specifying the chunk +# of the verb's past-tense (the verb, stem, and suffix slot +# values). + def make_word_freq_list (l): data = [] @@ -49,6 +85,10 @@ def make_word_freq_list (l): return(data) +# random_word returns a list with the slot values for +# a randomly choosen word from those in the word_list list +# based on frequency. + def random_word(): num=actr.random(total_count) @@ -58,32 +98,46 @@ def random_word(): return(i[1:]) +# make_one_goal randomly chooses a verb to present to the +# model in the imaginal buffer and sets the goal to be a +# copy of the starting-goal chunk. It returns the verb list +# for the chosen verb. + def make_one_goal(): word = random_word() - actr.set_buffer_chunk('imaginal',actr.define_chunks(['verb',word[0]])[0]) + actr.set_buffer_chunk('imaginal',['verb',word[0]]) actr.goal_focus('starting-goal') return(word) +# add_past_tense_to_memory randomly chooses a verb to +# merge into the model's declartive memory. It does +# the merging by setting the imaginal buffer to a +# chunk which has the appropriate slots set and then +# clearing the buffer. def add_past_tense_to_memory (): word = random_word() - actr.set_buffer_chunk('imaginal', - actr.define_chunks(['verb',word[0], - 'stem',word[1], - 'suffix',word[2]])[0]) + actr.set_buffer_chunk('imaginal',['verb',word[0],'stem',word[1],'suffix',word[2]]) actr.clear_buffer('imaginal') +# print_header prints the column labels for the data displayed. + def print_header(): print () print ( "trials Irregular Regular No inflection Inflected correctly") +# results prints out the performance of the model +# averaged over blocks of 1000 verbs, and optionally draws a +# graph of the correctness of inflected irregular verbs (by +# default it draws the graph but providing a value of False or None +# will suppress the graph) def results(graph=True): @@ -93,6 +147,10 @@ def results(graph=True): graph_it(data) return(data) +# graph_it requires one parameter which is a list of +# data which it draws in an experiment window scaling +# increments on the x and y axis to fit the data to +# the size of the graph def graph_it(data): @@ -128,6 +186,8 @@ def graph_it(data): lasty = y +# safe_div takes two parameters, n and d and returns +# n/d unless d is 0 in which case it returns 0. def safe_div(n, d): if d == 0: @@ -135,6 +195,10 @@ def safe_div(n, d): else: return (n / d) +# rep_f_i computes the average performance of the model +# given a range of elements in the data in blocks of size +# count and prints those values. + def rep_f_i(start,end,count): data = [] @@ -168,6 +232,12 @@ def rep_f_i(start,end,count): return data +# add_to_report takes two parameters which are the verb +# that was presented to the model and the resulting chunk +# that it had in the imaginal buffer. It records the +# result based on the type of verb and correctness of +# the response. It also reports warnings for verbs +# that are formed incorrectly by the model. def add_to_report(target, chunk): global report @@ -194,21 +264,45 @@ def add_to_report(target, chunk): (target[0],word,stem,suffix)) report.append([irreg,'error']) + +# create a global variable and a function that will be +# used to monitor the trigger-reward command so that +# the code can verify whether or not the model receives +# a reward on each trial. + reward_check = False def verify_reward(*params): global reward_check reward_check = True +# trials is used to run the model through +# the task. It takes one required parameter which +# is the number of trials to present. It has two +# optional parameters. The firt of those indicates +# whether the model should continue doing the task +# or be reset and start over. The default is to +# start over, but providing a true value will +# cause it to continue. The second optional parameter +# controls whether the trace is shown or not. The +# default is to not show the trace, but providing +# a value of True will show the trace. def trials(n,cont=False,v=False): global report,word_list,reward_check - + + # add a command to monitor trigger-reward + actr.add_command("reward-check",verify_reward, "Past tense code check for a reward each trial.") actr.monitor_command("trigger-reward","reward-check") + # if there isn't a word list created yet or the + # model is supposed to start over then + # reset and create chunks for the verbs on the + # list. + if not(cont) or not(word_list): actr.reset() word_list = make_word_freq_list(verbs) @@ -223,15 +317,27 @@ def trials(n,cont=False,v=False): print_header() report = [] - + + # set the :v value as provided + actr.set_parameter_value(":v",v) + # present the n trials and report the data in + # blocks of 100 as it goes. + start = 100 * math.floor(len(report) / 100) count = len(report) % 100 for i in range(n): + # Add the two random past-tenses to memory add_past_tense_to_memory() add_past_tense_to_memory() + + # run the model up to 100 seconds to + # process a randomly chosen past-tense + # and record the data outputting it + # if there're 100 items to output + reward_check = False target = make_one_goal() duration = actr.run(100)[0] @@ -243,17 +349,29 @@ def trials(n,cont=False,v=False): rep_f_i(start, start + 100, 100) count = 0 start += 100 + + # If the model didn't get a reward or + # spent all 100s running warn about that. + if not(reward_check): actr.print_warning("Model did not receive a reward when given %s."% target[0]) - actr.run_full_time(200 - duration) - if duration == 100: actr.print_warning("Model spent 100 seconds generating a past tense for %s."% target[0]) + # run the model until 200 seconds have + # passed since the start of the trial + + actr.run_full_time(200 - duration) + + # if there are any remaining data items + # report them (< 100 after the last block). + rep_f_i(start,start+count,100) + # remove the monitor for trigger-reward + actr.remove_command_monitor("trigger-reward","reward-check") actr.remove_command("reward-check") diff --git a/tutorial/python/pcomp_issues.py b/tutorial/python/pcomp_issues.py index ce5be52..027528e 100644 --- a/tutorial/python/pcomp_issues.py +++ b/tutorial/python/pcomp_issues.py @@ -1,3 +1,5 @@ +# ACT-R tutorial unit7 task for investigating production +# compilation modeling issues. import actr @@ -67,7 +69,7 @@ def present_next_trial(): def game_over(): return task_over -def trials(n=200,reset=True,output=True): +def trials(n=150,reset=True,output=True): global responses,task_over,exp_length,window if reset: @@ -80,29 +82,24 @@ def trials(n=200,reset=True,output=True): exp_length = n present_next_trial() actr.install_device(window) -# actr.add_command('compilation-issues-game-over',game_over,"Test for the production compilation issues game being over") + actr.add_command('compilation-issues-response',respond_to_key_press,"Compilation issues key press response monitor") actr.monitor_command('output-key','compilation-issues-response') -# this is how the original ran: actr.run_until_condition('compilation-issues-game-over') -# however performing a remote call for each event to determine the stopping point -# takes almost 2 orders of magnitude longer to run! So instead just run -# sufficiently long to complete the task and assume the model stops when there's -# nothing left to do. + # Just run a long time to have the model perform the task actr.run(20000) actr.remove_command_monitor('output-key','compilation-issues-response') actr.remove_command ('compilation-issues-response') -# actr.remove_command ('compilation-issues-game-over') return analyze_results(output) def game(n,show_games=False): - scores = [0]*20 - times = [0]*20 + scores = [0]*15 + times = [0]*15 for i in range(n): - r = trials(200,True,show_games) + r = trials(150,True,show_games) scores = list(map(lambda x,y: x + y,scores,r[0])) times = list(map(lambda x,y: x + y,times,r[1])) print("Average Score of %d trials"%n) diff --git a/tutorial/python/pm_issues.py b/tutorial/python/pm_issues.py index 5f1119c..9520a3d 100644 --- a/tutorial/python/pm_issues.py +++ b/tutorial/python/pm_issues.py @@ -1,3 +1,7 @@ +# ACT-R tutorial unit 3 code for a simple task to +# investigate potential perceptual and motor issues +# with models. + import actr actr.load_act_r_model("ACT-R:tutorial;unit3;perceptual-motor-issues-model.lisp") diff --git a/tutorial/python/siegler.py b/tutorial/python/siegler.py index f485de8..f80ca25 100644 --- a/tutorial/python/siegler.py +++ b/tutorial/python/siegler.py @@ -1,7 +1,27 @@ +# ACT-R tutorial unit 5 siegler task. +# This experiment presents a model with a pair of numbers aurally +# and the model must respond vocally with the sum of those numbers. +# The task and data to which the model is fit are in the paper: +# +# Siegler, R. S., & Shrager, J. (1984). Strategy choices in addition +# and subtraction: How do children know what to do? In C. Sophian (Ed.), +# Origins of cognitive skills (pp. 229-293). Hillsdale, NJ: Erlbaum. +# +# The original experiment was performed with 4 year-olds who made +# many errors in their responses. + +# Import the actr module for tutorial tasks + import actr +# Load the corresponding model for the task. + actr.load_act_r_model("ACT-R:tutorial;unit5;siegler-model.lisp") +# Create variables for the response, to record whether the +# monitoring function is currently available, and a subset of +# the original data for comparison. + response = False monitor_installed = False @@ -13,11 +33,21 @@ [.04, 0, 0, .05, .21, .09, .48, 0, .02, .11]] +# record_model_speech will be monitoring the output-speech +# command called by the microphone device so that it can +# record the model's speech output. + def record_model_speech (model,string): global response response = string.lower() +# Because the task can be run as a single trial, or over +# larger blocks it's more efficient to only install and +# remove the monitor once for the run instead of on each +# trial as has been done in other tasks. These functions +# are used to do that when necessary. + def add_speech_monitor(): global monitor_installed @@ -37,6 +67,11 @@ def remove_speech_monitor(): global monitor_installed monitor_installed = False +# trial takes two parameters which must be numbers. +# It resets the model and adds a microphone device to record +# the models speech output. Then, the numbers are presented +# aurally to the model using new-digit-sound, and after +# running the model it returns any vocal response that it made. def trial(arg1,arg2): @@ -53,6 +88,8 @@ def trial(arg1,arg2): return response +# set runs one trial for each of the addition problems +# in the data set and returns the results of those trials. def set (): @@ -66,6 +103,12 @@ def set (): return data +# experiment requires one parameter which is how many sets +# of trials to run. It runs that many trials collecting the +# responses and then passes those to analyze to compute the +# response percentages, compare the data to the experimental +# data, and display the results. + def experiment(n): add_speech_monitor() diff --git a/tutorial/python/sperling.py b/tutorial/python/sperling.py index 5b36097..61e6526 100644 --- a/tutorial/python/sperling.py +++ b/tutorial/python/sperling.py @@ -1,16 +1,54 @@ +# ACT-R tutorial unit 3 demonstration task. +# The sperling experiment displays a block of 12 +# letters in the window, with 3 lines of 4 letters +# per line for a brief time. After the display has +# been presented a tone sound is generated to indicate +# which row of letters must be reported (the timing of +# the tone relative to the initial display of the +# letters is variable). After the letters go away +# the participant must press the keys to indicate which +# letters were in the target row, and press the spacebar +# to indicate completion. + +# Import the actr module for tutorial tasks + import actr +# Load the corresponding tutorial model + actr.load_act_r_model("ACT-R:tutorial;unit3;sperling-model.lisp") +# Define some global variables: responses holds the list of +# keys pressed by the participant, show_responses indicates +# whether or not to print out the responses provided after a +# trial is run, and exp_data holds the results of the +# original experiment (number of correct responses from +# the target row based on the delay of the tone) for +# comparison to the model's performance. + responses = [] show_responses = True exp_data = [3.03,2.4,2.03,1.5] +# The trial function runs a single trial of the task +# and returns the number of correct responses. It requires one +# parameter which is the time in seconds to delay the tone +# after the items have been presented. + def trial(onset_time): + # Reset ACT-R and all models to initial state + actr.reset() + # create some local variables to perform the trial: + # letters: is a randomized list of letter strings + # answers: will be the list of letters in the target row + # row: a random number from 0-2 indicating which row will + # be the target + # window: an experiment window created to display the task + letters = actr.permute_list(["B","C","D","F","G","H","J", "K","L","M","N","P","Q","R", "S","T","V","W","X","Y","Z"]) @@ -18,6 +56,10 @@ def trial(onset_time): row = actr.random(3) window = actr.open_exp_window("Sperling Experiment", visible=True) + # Show the first 12 letters from the list in the window in + # three rows of four and record which ones are in the target + # row in the answers variable. + for i in range(3): for j in range(4): txt = letters[j + (i * 4)] @@ -25,8 +67,12 @@ def trial(onset_time): answers.append(txt) actr.add_text_to_exp_window(window, txt, x=(75 + (j * 50)), y=(100 + (i * 50))) + # Tell the model to interact with that window + actr.install_device(window) + # Set the freq variable based on which row is the target + if row == 0: freq = 2000 elif row == 1: @@ -34,29 +80,60 @@ def trial(onset_time): else: freq = 500 + # Create a tone with frequency freq for .5 seconds + # starting at the indicated onset_time + actr.new_tone_sound(freq,.5,onset_time) + + # To simulate the persistent visual memory for the model + # we will not clear the display until after a randomly + # chosen time between .9 and 1.1 seconds has passed. + # This is done by scheduling the clear-exp-window command + # to be called after that amount of time has passed. + actr.schedule_event_relative(900 + actr.random(200), "clear-exp-window", params=[window],time_in_ms=True) + # clear the response variable + global responses responses = [] + # Add a command for our respond_to_key_press function so that + # ACT-R can call it. + actr.add_command("sperling-response",respond_to_key_press, "Sperling task key press response monitor") + + # Monitor the output-key action so that our respond_to_key_press + # function is called when a key is pressed. + actr.monitor_command("output-key","sperling-response") + # Run the model for up to 30 seconds in real time mode. + actr.run(30,True) + # Stop monitoring the output-key action and remove our command. + actr.remove_command_monitor("output-key","sperling-response") actr.remove_command("sperling-response") + # If the show_responses variable is True then print out + # the correct answers and the responses that were provided + if show_responses: print("answers: %s"%answers) print("responses: %s"%responses) + # Call the compute_score function to determine the number of + # correct responses and return the result. + return(compute_score(answers)) +# The compute_score function counts how many of the correct answers +# were provided by the participant and returns that number. def compute_score(answers): @@ -68,18 +145,30 @@ def compute_score(answers): return(score) +# This function is the one that will be called when the participant +# presses a key, and it just records the result in the responses +# list unless it is the space bar. + def respond_to_key_press (model,key): global responses if not(key.lower() == "space"): responses.append(key) +# The report_data function takes a list of the average number of items +# reported in the target row ordered by onset delay. It compares those +# to the original experiment's data based on correlation and mean deviation +# then calls print_results to display the data. + def report_data(data): actr.correlation(data,exp_data) actr.mean_deviation(data,exp_data) print_results (data) +# The print_results function takes a list of the average target row data +# and prints that in a table along with the original experiment's data. + def print_results(data): print("Condition Current Participant Original Experiment") @@ -87,6 +176,11 @@ def print_results(data): print(" %4.2f sec. %6.2f %6.2f"%(c,d,o)) +# The one_block function runs a trial of the experiment at each +# of the experiment's tone onset conditions in a random order. +# It returns a list of the correct answer counts in the order +# of onset duration (lowest first). + def one_block(): result = [] @@ -97,6 +191,13 @@ def one_block(): result.sort() return (list(map(lambda x: x[1],result))) + +# The experiment function takes one required parameter which is +# the number of blocks to run in the experiment (where each block +# is one trial at each of the 4 possible onset times). It collects +# the data over blocks, averages the results, and passes that to the +# report_data function for display. + def experiment(n): results=[0,0,0,0] diff --git a/tutorial/python/subitize.py b/tutorial/python/subitize.py index 19dfc48..28d57f8 100644 --- a/tutorial/python/subitize.py +++ b/tutorial/python/subitize.py @@ -1,12 +1,36 @@ +# ACT-R tutorial unit3 subitize experiment. +# This experiment displays a number of Xs on +# the screen and the participant must respond +# with how many are there. A human participant +# must press a key from 0-9 (where 0 represents +# 10 items) but a model must speak the count +# (which is how the original experiment was +# performed). The time of the response and its +# correctness are recorded. + +# Import the actr module for tutorial tasks + import actr +# Load the corresponding ACT-R starting model. + actr.load_act_r_model("ACT-R:tutorial;unit3;subitize-model.lisp") +# Create some global variables to hold the response +# given and the time it occurred + response = False response_time = False +# A variable holding the data from the original experiment + exp_data = [.6,.65,.7,.86, 1.12,1.5,1.79,2.13,2.15,2.58] +# Two functions for converting an integer to a string +# as either the word e.g. "one" or the digits e.g. "1" +# for comparison to the response given by a model (spoken) +# or a person (keypress). + def number_to_word (n): map = ['','one','two','three','four','five','six','seven','eight','nine','ten'] return map[n] @@ -17,53 +41,112 @@ def number_to_string (n): else: return str(n) +# The trial function presents one trial of the task. +# It requires one parameter which is the number of items to +# present (should be an integer from 1-10), and has an optional +# parameter which indicates whether it is the model or a person +# performing the task. It returns a list with the time it took +# the participant to respond and True if the response was correct +# or the list [30, False] if the response was incorrect or no +# response was provided. def trial (n,human=False): + # Reset ACT-R and all models to initial state + actr.reset() + # create some local variables to perform the trial: + # points: is a list of randomized x,y coordinates to display the Xs + # from the generate_points function + # window: an experiment window created to display the task + # start: the current time at the start of the trial + # as given by the ACT-R get_time function which + # needs to be provided whether it is the model or + # a person doing the task to get the appropriate time + points = generate_points(n) window = actr.open_exp_window("Subitizing Experiment") start = actr.get_time(not(human)) - + + # Display an x at each of the points + for point in points: actr.add_text_to_exp_window(window, "x", x=point[0], y=point[1]) + # clear the response variables + global response,response_time response = '' response_time = False + # Run the trial + if human: if actr.visible_virtuals_available(): + + # If a human is doing the task and there is a visible + # window available for them to interact with then + # add a command and monitor the output-key action + actr.add_command("subitize-response",respond_to_key_press, "Subitize task human response") actr.monitor_command("output-key","subitize-response") + # Set the correct answer string for a key press + answer = number_to_string(n) + + # Wait until there is a response + while response == '': actr.process_events() + # Stop monitoring output-key and remove the command + actr.remove_command_monitor("output-key","subitize-response") actr.remove_command("subitize-response") else: + + # If a model is doing the task add a command and + # monitor the output-speech action + actr.add_command("subitize-response",record_model_speech, "Subitize task model response") actr.monitor_command("output-speech","subitize-response") + # Set the correct answer string for a spoken response + answer = number_to_word(n) + + # Tell the model to interact with the created window + actr.install_device(window) + # Run the model for up to 30 seconds in real time mode + actr.run(30,True) + # Stop monitoring output-speech and remove the command + actr.remove_command_monitor("output-speech","subitize-response") actr.remove_command("subitize-response") + # If a response is given and it matches the correct answer + # then return a list with the time since the trial started + # in seconds and True, otherwise return a list of 30 and False + if response != '' and response.lower() == answer.lower(): return [(response_time - start) / 1000.0, True] else: return [30, False] +# experiment takes one optional parameter which indicates +# whether it is a human or model performing the task. Then it +# presents a trial for each of the counts from 1-10 in a randomized +# order, and passes the results to report_data sorted by item count. + def experiment(human=False): results = [] @@ -73,6 +156,10 @@ def experiment(human=False): results.sort() report_data(list(map(lambda x: x[1],results))) +# report-data compares the times in the provided data to +# the original experiment data and then passes it to print_results +# for output. + def report_data(data): rts = list(map(lambda x: x[0],data)) @@ -80,6 +167,10 @@ def report_data(data): actr.mean_deviation(rts,exp_data) print_results(data) +# print_results outputs a table with the times and correctness +# values from the current experiment along with the data from +# the origial experiment. + def print_results(data): print("Items Current Participant Original Experiment") @@ -87,6 +178,11 @@ def print_results(data): print("%3d %5.2f (%-5s) %5.2f" % (count+1,d[0],d[1],original)) +# The next three functions: generate_points, new_distinct_point, and +# too_close are used to generate a list of random x,y lists for the +# coordinates to display the Xs so that they are within the bounds of +# the window and non-overlapping. + def generate_points(n): p=[] for i in range(n): @@ -108,12 +204,22 @@ def too_close (x,y,p): else: return False + +# respond_to_key_press is monitoring output-key to record +# the current time and key pressed when a human is performing +# the task. + def respond_to_key_press (model,key): global response,response_time response_time = actr.get_time(False) response = key + +# record_model_speech is monitoring output-speech to record +# the current time and word spoken when a model is performing +# the task. + def record_model_speech (model,string): global response,response_time diff --git a/tutorial/python/ul_issues.py b/tutorial/python/ul_issues.py index bc45689..51ac4a8 100644 --- a/tutorial/python/ul_issues.py +++ b/tutorial/python/ul_issues.py @@ -1,3 +1,6 @@ +# ACT-R tutorial unit7 task for investigating utility +# learning modeling issues. + import actr def present_choose(): diff --git a/tutorial/python/unit2.py b/tutorial/python/unit2.py index 2969326..a3ffbfa 100644 --- a/tutorial/python/unit2.py +++ b/tutorial/python/unit2.py @@ -1,19 +1,67 @@ +# ACT-R tutorial unit 2 assignment task. +# This experiment opens a window, displays 3 characters +# with two being the same and one different, waits for a +# keypress, and then reports whether the key that was +# pressed matches the different letter or not. + +# Import the actr module for tutorial tasks import actr +# Load the corresponding tutorial model + actr.load_act_r_model("ACT-R:tutorial;unit2;unit2-assignment-model.lisp") +# Create a variable to store the key that was pressed. + response = False +# This is the function which we will have ACT-R call when +# a key is pressed in the experiment window which is signaled +# by the output-key action. + +# That action provides two parameters to the function called. +# The first is the name of the model that performed the keypress +# or None if it wasn't generated by a model, and the second +# is a string with the name of the key that was pressed. + def respond_to_key_press (model,key): - global response + # just store the key that was pressed in the response variable + + global response response = key + +# This is the function that runs the experiment for either a +# person or a model. It has one optional parameter which if +# provided as True will run a person. +# If it is not provided or any other value is specified then +# it will run the model. + def experiment (human=False): + # Reset the ACT-R system and any models that are defined to + # their initial states. + actr.reset() + + # Create variable for the items needed to run the exeperiment: + # items - a randomized list of letter strings which is randomized + # using the ACT-R function permute_list + # target - the first string from the randomized list which will be the + # one that is different in the display + # foil - the second item from the list which will be displayed + # twice + # window - the ACT-R window device list returned by using the ACT-R + # function open_exp_window to create a new window for + # displaying the experiment + # text# - three text items that will hold the letters to be + # displayed all initialized to the foil letter to start + # index - a random value from 0-2 generated from the actr.random + # function which is used to determine which of the three + # text variables will be set to the target items = actr.permute_list(["B","C","D","F","G","H","J","K","L", "M","N","P","Q","R","S","T","V","W", @@ -25,6 +73,8 @@ def experiment (human=False): text2 = foil text3 = foil index = actr.random(3) + + # Set the randomly chosen item to be the target letter if index == 0: text1 = target @@ -32,29 +82,69 @@ def experiment (human=False): text2 = target else: text3 = target + + # display the three letters in the window actr.add_text_to_exp_window(window, text1, x=125, y=75) actr.add_text_to_exp_window(window, text2, x=75, y=175) actr.add_text_to_exp_window(window, text3, x=175, y=175) + # Create a command in ACT-R that corresponds to our respond_to_key_press + # function so that ACT-R is able to use the function. + actr.add_command("unit2-key-press",respond_to_key_press, "Assignment 2 task output-key monitor") + + # Monitor the output-key action so that when an output-key happens + # our function is called. + actr.monitor_command("output-key","unit2-key-press") + # Set the response value to '' to remove any value it may + # have from a previous run of the experiment. + global response response = '' + # Here is where we actually "run" the experiment. + # It either waits for a person to press a key or runs ACT-R + # for up to 10 seconds giving the model a chance to do the + # experiment. + if human == True: + + # If a person is doing the task then for safety + # we make sure there is a visible window that they + # can use to do the task, and if so, loop until the + # response variable is not '' calling the ACT-R + # process_events function to allow the system a + # chance to handle any interactions. + if actr.visible_virtuals_available(): while response == '': actr.process_events() else: + + # If it is not a human then use install_device so that + # the features in the window will be seen by the model + # (that will also automatically provide the model with + # access to a virtual keyboard and mouse). Then use + # the ACT-R run function to run the model for up to 10 + # seconds in real-time mode. + actr.install_device(window) actr.run(10,True) + # To avoid any issues with our function for keypresses in this + # experiment interfering with other experiments we should stop + # monitoring output-key and then remove our command. + actr.remove_command_monitor("output-key","unit2-key-press") actr.remove_command ("unit2-key-press") + + # If the response matches the target return True otherwise + # return False. if response.lower() == target.lower(): return True diff --git a/tutorial/python/zbrodoff.py b/tutorial/python/zbrodoff.py index 04e5db4..1b92016 100644 --- a/tutorial/python/zbrodoff.py +++ b/tutorial/python/zbrodoff.py @@ -1,14 +1,56 @@ +# ACT-R tutorial unit 4 zbrodoff task. +# This experiment presents participants with alpha-arithmetic +# problems like "A + 2 = C" which they must respond to by +# pressing k if the problem is correct or d if it is not. +# The code runs the control condition from the paper: +# +# Zbrodoff, N. J. (1995). Why is 9 + 7 harder than 2 + 3? +# Strength and interference as explanations of the problem-size +# effect. Memory & Cognition, 23 (6), 689-700. +# +# That condition presents problems with addends of 2, 3, and 4 +# with equal frequency in blocks of 192 trials where half of the +# trials in a block are correct and half are false. The +# data for comparison is the average response time by block +# and addend for correct answers (including both true and +# false problems). + +# Import the actr module for tutorial tasks + import actr +# Load the corresponding model for the task + actr.load_act_r_model("ACT-R:tutorial;unit4;zbrodoff-model.lisp") +# Global variables to hold the trials to present, the results that have +# been collected, and the original data for comparison. + trials = [] results = [] control_data = [1.84, 2.46, 2.82, 1.21, 1.45, 1.42, 1.14, 1.21, 1.17] +# Also create a variable to indicate whether it will be a model or person. +# This is done to keep the number of parameters needed to run the functions +# smaller since one may want a visible window for either a person or model +# and this avoids having to specify both who is running and whether the window +# should be shown. + run_model = True +# Because the data collection for this task is a little more involved +# we're going to record the trials in a class to keep everything +# together and organized instead of just a list of items as has been +# done for other experiments. This will also allow us to store all of +# the information needed to present a trial together so that we can +# create them all in advance which can be useful when running in an +# event-driven style. A trial will hold the block number, the addend +# value, the text of the problem to display, the correct answer, whether +# the window should be visible or not, whether the response from the +# participant was correct, the time the trial started, and the response +# time. + class trial(): def __init__(self,block,addend1,addend2,sum,answer,visible=None): self.block = block @@ -21,23 +63,55 @@ def __init__(self,block,addend1,addend2,sum,answer,visible=None): self.visible = visible self.correct = False +# The present_trial function takes one parameter which is a trial +# structure and an optional parameter which indicates whether or not +# to open a new window for this trial (since this task is running +# continuously it will run faster if it uses the same window repeatedly, +# but because the same code is used to run it for a variety of +# different situations it needs to know when to start over with a +# new display). + def present_trial(trial, new_window = True): if new_window: + # If a new window is requested it opens one using + # the visible status indicated in the trial and + # if the model is performing the task it installs + # that window device for the model. + w = actr.open_exp_window("Alpha-arithmetic Experiment", visible=trial.visible) if run_model: actr.install_device(w) else: + + # otherwise it just clears the current window + actr.clear_exp_window() + # add the text from the trial to the window and set the + # start time in the trial structure. + actr.add_text_to_exp_window(None, trial.text, x=100, y=150) trial.start = actr.get_time(run_model) +# The respond_to_key_press function will be set up to monitor +# the output-key actions, and thus will be called with two parameters +# when a key is pressed: the name of the model that pressed the key +# (or None if it is a person) and the string naming the key that was +# pressed. +# Unlike the previous tasks, since this one is event-driven we will +# actually do more than just record the key and time in this function. +# It will also present the next trial if there is one so that the +# model can continue to run in the task until it is complete. + def respond_to_key_press (model,key): global trials,results + # Set the response time and correctness in the trial + # and add it to the results list. + trials[0].time = (actr.get_time(run_model) - trials[0].start) / 1000.0 if key.lower() == trials[0].answer : @@ -45,60 +119,111 @@ def respond_to_key_press (model,key): results.append(trials[0]) + # Remove the current trial, and if there are any trials left to + # present then present the first of them now. + trials = trials[1:] if len(trials) > 0 : present_trial(trials[0],False) -def collect_responses(count): - global results +# The collect_responses function takes no parameters and runs all of +# the trials available. - results = [] +def collect_responses(): + + # record how many trials need to be run + + total = len(trials) + + # Create a command for respond_to_key_press and monitor output-key. actr.add_command("zbrodoff-response", respond_to_key_press, "Zbrodoff task key press response monitor") actr.monitor_command("output-key","zbrodoff-response") + # present the first trial + present_trial(trials[0]) + # If it's a model doing the task run for 10s per trial, + # and if it's a person loop until there are as many results + # as there were trials to run. + if run_model : - actr.run(10 * count) + actr.run(10 * total) else: if actr.visible_virtuals_available(): - while len(results) < count: + while len(results) < total: actr.process_events() + # stop monitoring and remove the command + actr.remove_command_monitor("output-key","zbrodoff-response") actr.remove_command("zbrodoff-response") +# The problem function takes 4 required parameters. +# The first three are the strings of the elements of the problem +# to present e.g. "A","2","C" to preset "A + 2 = C". The fourth +# is a string with the key press that will be a correct response +# which is "k" if the problem is correct and "d" if the problem +# is not correct. The optional parameter can be specified as True +# to have the window displayed, but if not provided defaults to +# not showing the window. +# It clears the current results, creates a list with the single +# trial specified and runs the task for that trial and displays +# the results. + def problem(addend1,addend2,sum,answer,visible=None): + global results + results = [] + global trials trials = [trial(1,addend1,addend2,sum,answer,visible)] - collect_responses(1) + collect_responses() return analyze_results() +# set and block are similar to problem except that instead +# of presenting a single trial they present a full set (24 +# trials) or block (192 trials) of items. + def set(visible=None): + global results + results = [] + global trials trials = create_set(1,visible) - collect_responses(24) + collect_responses() return analyze_results() def block(visible=None): + + global results + results = [] + global trials trials = [] for i in range(8): trials = trials + create_set(1,visible) - collect_responses(192) + collect_responses() return analyze_results() + +# experiment has two optioal parameters. The first is +# whether or not to show the window which defaults to not shown, +# and the second is whether or not to display the results after +# the experiment is run (the default is to show them). +# It resets the model, generates three blocks of trials, runs +# those trials, and reports the results. + def experiment(visible=None,show=True): actr.reset() @@ -110,10 +235,19 @@ def experiment(visible=None,show=True): for i in range(8): trials = trials + create_set(j+1,visible) - collect_responses(576) + global results + results = [] + + collect_responses() return analyze_results(show) +# compare takes one required parameter which is the number +# of times to run a model through the full experiment. It runs +# the model that many times and averages the results of those +# runs which it compares to the original data for the task and +# then displays the results. + def compare(n): rts = [0,0,0,0,0,0,0,0,0] @@ -132,6 +266,10 @@ def compare(n): print_analysis(rts,counts,[1,2,3],['2','3','4'], [192,192,192]) +# analyze_results takes one optional parameter which +# indicates whether or not to print the results in addition +# to averaging the times by addend and block and returning +# the averaged results and counts of correct items in a list. def analyze_results(show=True): @@ -172,6 +310,7 @@ def analyze_results(show=True): return (rts, counts) +# print_analysis displays a table with the data items provided. def print_analysis(rts,counts,blocks,addends,totals): @@ -185,7 +324,12 @@ def print_analysis(rts,counts,blocks,addends,totals): for a in range(len(addends)): print(" %6.3f (%2d)" % (rts[a+b*len(addends)],counts[a+b*len(addends)]),end="") print() - + + +# This varaible holds the problems to be presented +# in one set of the task -- 4 problems with each addend +# in a correct equation and 4 problems with each addend +# in an incorrect equation. data_set = [["a","2","c","k"],["d","2","f","k"], ["b","3","e","k"],["e","3","h","k"], @@ -201,6 +345,11 @@ def print_analysis(rts,counts,blocks,addends,totals): ["c","4","h","d"],["f","4","k","d"]] +# create_set takes a block number and whether the items +# should be visible and returns a randomized list of +# trial structures representing one set of data with +# those conditions. + def create_set(block,visible): return list(map(lambda x: trial(block,*x,visible=visible), actr.permute_list(data_set))) diff --git a/tutorial/unit1/count.lisp b/tutorial/unit1/count.lisp index dc945a2..32b22a9 100644 --- a/tutorial/unit1/count.lisp +++ b/tutorial/unit1/count.lisp @@ -32,7 +32,7 @@ number =num1 ) -(P increment +(p increment =goal> ISA count-from count =num1 @@ -51,7 +51,7 @@ !output! (=num1) ) -(P stop +(p stop =goal> ISA count-from count =num diff --git a/tutorial/unit1/unit1.pdf b/tutorial/unit1/unit1.pdf index 87aab99..24f22b7 100644 Binary files a/tutorial/unit1/unit1.pdf and b/tutorial/unit1/unit1.pdf differ diff --git a/tutorial/unit1/unit1_code.pdf b/tutorial/unit1/unit1_code.pdf index f6dd125..70bf5c6 100644 Binary files a/tutorial/unit1/unit1_code.pdf and b/tutorial/unit1/unit1_code.pdf differ diff --git a/tutorial/unit1/unit1_modeling.pdf b/tutorial/unit1/unit1_modeling.pdf index 541a876..105616b 100644 Binary files a/tutorial/unit1/unit1_modeling.pdf and b/tutorial/unit1/unit1_modeling.pdf differ diff --git a/tutorial/unit2/unit2.pdf b/tutorial/unit2/unit2.pdf index 2b90f06..fef6ced 100644 Binary files a/tutorial/unit2/unit2.pdf and b/tutorial/unit2/unit2.pdf differ diff --git a/tutorial/unit2/unit2_code.pdf b/tutorial/unit2/unit2_code.pdf index f84d858..6dfd666 100644 Binary files a/tutorial/unit2/unit2_code.pdf and b/tutorial/unit2/unit2_code.pdf differ diff --git a/tutorial/unit3/perceptual-motor-issues-model.lisp b/tutorial/unit3/perceptual-motor-issues-model.lisp index b2a4655..af5730d 100644 --- a/tutorial/unit3/perceptual-motor-issues-model.lisp +++ b/tutorial/unit3/perceptual-motor-issues-model.lisp @@ -2,8 +2,8 @@ (define-model perceptual-motor-issues - (sgp :seed (101 1)) - (sgp :v t :show-focus t :trace-detail medium :er t :style-warnings nil) + (sgp :seed (101 0)) + (sgp :v t :show-focus t :trace-detail medium :er t) (chunk-type letter name next previous) (chunk-type task letter) diff --git a/tutorial/unit3/unit3.pdf b/tutorial/unit3/unit3.pdf index 22da8dd..5de038a 100644 Binary files a/tutorial/unit3/unit3.pdf and b/tutorial/unit3/unit3.pdf differ diff --git a/tutorial/unit3/unit3_code.pdf b/tutorial/unit3/unit3_code.pdf index c4f7f5c..764dcf4 100644 Binary files a/tutorial/unit3/unit3_code.pdf and b/tutorial/unit3/unit3_code.pdf differ diff --git a/tutorial/unit3/unit3_modeling.pdf b/tutorial/unit3/unit3_modeling.pdf index 68e0b27..562f935 100644 Binary files a/tutorial/unit3/unit3_modeling.pdf and b/tutorial/unit3/unit3_modeling.pdf differ diff --git a/tutorial/unit4/unit4.pdf b/tutorial/unit4/unit4.pdf index 0cc8116..101bdb1 100644 Binary files a/tutorial/unit4/unit4.pdf and b/tutorial/unit4/unit4.pdf differ diff --git a/tutorial/unit4/unit4_code.pdf b/tutorial/unit4/unit4_code.pdf index f0e7981..6ebea05 100644 Binary files a/tutorial/unit4/unit4_code.pdf and b/tutorial/unit4/unit4_code.pdf differ diff --git a/tutorial/unit4/zbrodoff-model.lisp b/tutorial/unit4/zbrodoff-model.lisp index c2a22e3..600003f 100644 --- a/tutorial/unit4/zbrodoff-model.lisp +++ b/tutorial/unit4/zbrodoff-model.lisp @@ -275,7 +275,7 @@ next =new vocal-rep =txt ?vocal> - state free + preparation free ==> +vocal> cmd subvocalize @@ -298,8 +298,6 @@ isa problem result =let arg2 =val - ?vocal> - state free ?manual> state free @@ -315,14 +313,11 @@ =goal> ISA goal count =val - target =let + - target =let =imaginal> isa problem - - result =let - - result nil + result =let arg2 =val - ?vocal> - state free ?manual> state free diff --git a/tutorial/unit5/1hit-blackjack-model.lisp b/tutorial/unit5/1hit-blackjack-model.lisp index 0e535ea..af6a817 100644 --- a/tutorial/unit5/1hit-blackjack-model.lisp +++ b/tutorial/unit5/1hit-blackjack-model.lisp @@ -3,14 +3,16 @@ (define-model 1-hit-model ;; do not change these parameters - (sgp :esc t :bll .5 :ol t :sim-hook "1hit-bj-number-sims" :cache-sim-hook-results t :er t :lf 0) + (sgp :esc t :bll .5 :ol t :sim-hook "1hit-bj-number-sims" + :cache-sim-hook-results t :er t :lf 0) ;; adjust these as needed (sgp :v nil :ans .2 :mp 10.0 :rt -60) ;; This type holds all the game info - (chunk-type game-state mc1 mc2 mc3 mstart mtot mresult oc1 oc2 oc3 ostart otot oresult state) + (chunk-type game-state + mc1 mc2 mc3 mstart mtot mresult oc1 oc2 oc3 ostart otot oresult state) ;; This chunk-type should be modified to contain the information needed ;; for your model's learning strategy diff --git a/tutorial/unit5/fan-no-pm-model.lisp b/tutorial/unit5/fan-no-pm-model.lisp index c7561f8..07d679a 100644 --- a/tutorial/unit5/fan-no-pm-model.lisp +++ b/tutorial/unit5/fan-no-pm-model.lisp @@ -162,5 +162,6 @@ (spp mismatch-person-no :at .21) (spp respond-yes :at .21) (spp start :at .250) - (spp harvest-person :at .285)) + (spp harvest-person :at .285) + ) diff --git a/tutorial/unit5/unit5.pdf b/tutorial/unit5/unit5.pdf index bdb66bd..e40910b 100644 Binary files a/tutorial/unit5/unit5.pdf and b/tutorial/unit5/unit5.pdf differ diff --git a/tutorial/unit5/unit5_code.pdf b/tutorial/unit5/unit5_code.pdf index 3bb8d54..1bc54cf 100644 Binary files a/tutorial/unit5/unit5_code.pdf and b/tutorial/unit5/unit5_code.pdf differ diff --git a/tutorial/unit5/unit5_modeling.pdf b/tutorial/unit5/unit5_modeling.pdf index 95cdeab..a0853e2 100644 Binary files a/tutorial/unit5/unit5_modeling.pdf and b/tutorial/unit5/unit5_modeling.pdf differ diff --git a/tutorial/unit6/unit6.pdf b/tutorial/unit6/unit6.pdf index c6dc111..ab1ddd7 100644 Binary files a/tutorial/unit6/unit6.pdf and b/tutorial/unit6/unit6.pdf differ diff --git a/tutorial/unit6/unit6_code.pdf b/tutorial/unit6/unit6_code.pdf index 073283e..b9a7f37 100644 Binary files a/tutorial/unit6/unit6_code.pdf and b/tutorial/unit6/unit6_code.pdf differ diff --git a/tutorial/unit7/unit7.pdf b/tutorial/unit7/unit7.pdf index be6d296..5918245 100644 Binary files a/tutorial/unit7/unit7.pdf and b/tutorial/unit7/unit7.pdf differ diff --git a/tutorial/unit7/unit7_code.pdf b/tutorial/unit7/unit7_code.pdf index 72f71c3..b9b0b44 100644 Binary files a/tutorial/unit7/unit7_code.pdf and b/tutorial/unit7/unit7_code.pdf differ diff --git a/tutorial/unit7/unit7_modeling.pdf b/tutorial/unit7/unit7_modeling.pdf index 8181240..b19496f 100644 Binary files a/tutorial/unit7/unit7_modeling.pdf and b/tutorial/unit7/unit7_modeling.pdf differ diff --git a/tutorial/unit8/categorize-model.lisp b/tutorial/unit8/categorize-model.lisp index 8c48b1e..857e8be 100644 --- a/tutorial/unit8/categorize-model.lisp +++ b/tutorial/unit8/categorize-model.lisp @@ -23,7 +23,7 @@ (small large -.8)) - (set-buffer-chunk 'imaginal (first (define-chunks (category unknown)))) + (set-buffer-chunk 'imaginal '(category unknown)) ;; Declare the goal buffer chunk-type usage which is going to be set from ;; outside of the model. diff --git a/tutorial/unit8/paired-dynamic-model.lisp b/tutorial/unit8/paired-dynamic-model.lisp index 41a04d7..10d23cb 100644 --- a/tutorial/unit8/paired-dynamic-model.lisp +++ b/tutorial/unit8/paired-dynamic-model.lisp @@ -12,12 +12,12 @@ (respond)(type)(new-trial)(complete-task)(ready)(retrieving-operator)(process)(retrieving-result)) (add-dm - (op1 isa operator pre start action read label word post stimulus-read) - (op2 isa operator pre stimulus-read action retrieve required word label number post recalled) - (op3 isa operator pre recalled slot number success respond failure wait) - (op4 isa operator pre respond action type required number post wait) - (op5 isa operator pre wait action read label number post new-trial) - (op6 isa operator pre new-trial action complete-task post start)) + (op1 isa operator pre start action read label word post stimulus-read) + (op2 isa operator pre stimulus-read action retrieve required word label number post recalled) + (op3 isa operator pre recalled slot number success respond failure wait) + (op4 isa operator pre respond action type required number post wait) + (op5 isa operator pre wait action read label number post new-trial) + (op6 isa operator pre new-trial action complete-task post start)) (set-all-base-levels 1000) @@ -101,7 +101,7 @@ =goal> step ready) -(p retireve-associate +(p retrieve-associate =goal> isa task step retrieving-operator diff --git a/tutorial/unit8/unit8.pdf b/tutorial/unit8/unit8.pdf index c810db4..167a998 100644 Binary files a/tutorial/unit8/unit8.pdf and b/tutorial/unit8/unit8.pdf differ diff --git a/tutorial/unit8/unit8_code.pdf b/tutorial/unit8/unit8_code.pdf index 928b3b6..3166efe 100644 Binary files a/tutorial/unit8/unit8_code.pdf and b/tutorial/unit8/unit8_code.pdf differ