;;;;;;;;;;;;;;;;;;;;;;;;<pre><xmp>
;; To run the model, call the function demo
;; There are three parameters to pass to the demo function,
;; representing prefix, postfix, and the characters on the right of the equation

;; Prefix values may be nil, 2, 3, 4, or 5
;; Postfix values must be a list of 2 characters or nil.  The characters must be 2, 3, 4, or 5
;; RHS of equation must be a list of 2 characters or 4 characters, contingent on postfix
;; So, if Postfix is nil, RHS must be 4 characters
;;     if Postfix is 2 characters, RHS must be 2 characters

;; Example (demo nil '(2 3) '(2 3))

(defparameter *visual* nil)
(defparameter *retrieved* nil)
(defparameter *productions* nil)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 
;;; This is the modular-buffers code from Christian to add
;;; a new buffer to ACT-R 5

;;; Patch to implement modular buffers
;;; Link buffer name (e.g imaginal) and global variable (e.g. *imaginal*)
;;; to up to four calls:
;;; = lhs: current content of buffer (default refers to global variable)
;;; + rhs: main call for buffer action (no default!)
;;; = rhs: changes contents of buffer (default modifies buffer chunk)
;;; - rhs: clear buffer (default sets buffer to nil)
;;; Not clear whether to link buffer to specific chunk types.  Probably not.
;;; Chunk type will be passed on as argument along with slots.
;;; State buffer should be implemented as separate buffer link.
;;; This is a generalization of *buffer-keywords* which only contains the alist
;;; linking the buffer name to the global variable under ACT-R's control.
;;; This would turn out to be enough for goal!!!
;;; The first argument for all these functions is the buffer name.

(defparameter *buffers* nil
  "Buffers with their global variable and function calls.")

(defstruct buffer-calls "Keeps the calls to buffers in a structure"
  equal-lhs plus-rhs equal-rhs minus-rhs)

(defmacro define-buffer (buffer-name variable-name &key
                                     equal-lhs plus-rhs equal-rhs minus-rhs)
  `(define-buffer-fct ',buffer-name ',variable-name
     :equal-lhs ',equal-lhs :plus-rhs ',plus-rhs 
     :equal-rhs ',equal-rhs :minus-rhs ',minus-rhs))

(defun define-buffer-fct (buffer-name variable-name &key
                                      equal-lhs plus-rhs equal-rhs minus-rhs)
  (push-last (list buffer-name variable-name
                   (make-buffer-calls :equal-lhs equal-lhs :plus-rhs plus-rhs 
                                      :equal-rhs equal-rhs :minus-rhs minus-rhs))
             *buffers*)
  ;;; global variable defined in separate module??
  )

(defun compile-lhs (production lhs initializations bindings index)
  "Compiles the left-hand side of production.
   Add the instantiation-adding call."
  (let ((code nil)
        (form nil))
    (dolist (clause lhs)
      (let ((key (pop clause))
            (type nil)
            (tests nil)
            (binds nil)
            (slot nil)
            (value nil)
            (negation nil))
        (setf form
              (cond
               ((retrievalp key)
                (setf key (var>var key))
                (with-binding binding direct key bindings index
                  (set-variable-type production type key (pop clause))
                  (when type
                    (cond ((and (member (wme-type-name type) '(visual-location audio-event) :test #'eq)
                                    (member '(time now) clause :test #'equal)) ;; compatibility with the old hack
                           (setf clause (delete '(time now) clause :test #'equal))
                           (setf (variable-type binding) type)
                           (let* ((fct-args (rest (assoc (wme-type-name type) *pm-calls* :test #'eq)))
                                  (pm-call (list (first fct-args)))
                                  (argument-alist (rest fct-args)))
                             (dolist (slot-value clause)
                               (let* ((negation (when (equal (first slot-value) '-)
                                                  (pop slot-value)))
                                      (slot (first slot-value))
                                      (value (second slot-value))
                                      (mapping (assoc slot argument-alist)))
                                 (cond (mapping
                                        (when (and (or (not (variablep value))
                                                       (get-variable-binding value bindings))
                                                   (second mapping))
                                          (setf value (sub-eval-vars value bindings nil))
                                          (nconc pm-call (list (second mapping)
                                                               (if negation
                                                                 (list 'pm-not-equal value)
                                                                 value)))))
                                       (t
                                        (signal-warn "SLOT ~S OF CHUNK ~S TYPE ~S IN PRODUCTION ~S IS UNDEFINED."
                                                     slot key type production)))))
                             (compile-lhs-slots tests binds)
                             (list (if (and *enable-rational-analysis* code)
                                     ; the goal cannot be partial-matched
                                     'external-test-and-bind-pm
                                     'external-test-and-bind)
                                   (variable-index binding)
                                   pm-call
                                   type nil binds)))
                          ((or (member key '(=visual-state =aural-state =manual-state =vocal-state)) ;; reserved keywords for states
                               (eq (wme-type-name type) 'module-state))
                           (setf clause (delete '(time now) clause :test #'equal))
                           (setf (variable-type binding) type)
                           (let* ((fct-args (rest (assoc (wme-type-name type) *pm-calls* :test #'eq)))
                                  (pm-call (list (first fct-args)))
                                  (argument-alist (rest fct-args)))
                             (when (and (member key '(=visual-state =aural-state =manual-state =vocal-state))
                                        (not (assoc 'module clause)))
                               (nconc pm-call (list :module (case key
                                                              (=visual-state :vision)
                                                              (=aural-state :audio)
                                                              (=manual-state :motor)
                                                              (=vocal-state :speech)))))
                             (dolist (slot-value clause)
                               (let* ((negation (when (equal (first slot-value) '-)
                                                  (pop slot-value)))
                                      (slot (first slot-value))
                                      (value (second slot-value))
                                      (mapping (assoc slot argument-alist)))
                                 (cond (mapping
                                        (when (and (or (not (variablep value))
                                                       (get-variable-binding value bindings))
                                                   (second mapping))
                                          (setf value (sub-eval-vars value bindings nil))
                                          (nconc pm-call (list (second mapping)
                                                               (if negation
                                                                 (list 'pm-not-equal value)
                                                                 value)))))
                                       (t
                                        (signal-warn "SLOT ~S OF CHUNK ~S TYPE ~S IN PRODUCTION ~S IS UNDEFINED."
                                                     slot key type production)))))
                             
                             (compile-lhs-slots tests binds)
                             (list 'buffer-test-and-bind ;;  It is all a buffer match now
                                   (variable-index binding)
                                   pm-call
                                   type nil binds)))
                          ((or (member key '(=visual =aural)) ;; reserved keywords for visual and sound objects
                               (and (or (member 'visual-object (wme-type-supertypes type)
                                                :test #'eq :key #'wme-type-name)
                                        (member 'sound (wme-type-supertypes type)
                                                :test #'eq :key #'wme-type-name))
                                    (member '(time now) clause :test #'equal)))
                           (setf clause (delete '(time now) clause :test #'equal))
                           (setf (variable-type binding) type)
                           (compile-lhs-slots tests binds)
                           (list 'buffer-test-and-bind ;;  It is all a buffer match now
                                 (variable-index binding)
                                 (list (second (assoc (if (or (member 'visual-object (wme-type-supertypes type)
                                                                      :test #'eq :key #'wme-type-name)
                                                              (eq key '=visual))
                                                        'visual-object 'sound)
                                                      *pm-calls* :test #'eq)))
                                 type tests binds))
                          ((member key '(=manual =manual-location =vocal =vocal-location))
                           (signal-warn "RESERVED KEYWORD NOT YET IMPLEMENTED."))
                          ((assoc (var=var key) *buffers*)   ;;; lhs buffer matching
                           (let ((buffer (assoc (var=var key) *buffers*)))
                             (setf (variable-type binding) type)
                             (compile-lhs-slots tests binds)
                             (list 'buffer-test-and-bind
                                   (variable-index binding)
                                   (list (buffer-calls-equal-lhs (third buffer))
                                         (list (first buffer) (second buffer)))
                                   type tests binds)))
                          (t  ;; includes =visual-location and =aural-location because they are now buffers
                           (setf (variable-type binding) type)
                           (compile-lhs-slots tests binds)
                           (list (if (assoc (variable-index binding) initializations :test #'=)
                                   ;; Fixed buffers have their special test to avoid activation
                                   'direct-test-and-bind-buffer
                                   (if *enable-rational-analysis*
                                     (if direct 'direct-test-and-bind-pm
                                         'indirect-test-and-bind-pm)
                                     (if direct 'direct-test-and-bind
                                         'indirect-test-and-bind)))
                                 (variable-index binding) type tests binds))))))
               ((eq '!eval! key)
                (list 'eval-test (sub-eval-vars (first clause) bindings)))
               ((eq '!bind! key)
                (with-binding binding bound (first clause) bindings index
                  (when bound
                    (signal-warn "VARIABLE ~S ALREADY BOUND IN PRODUCTION ~A."
                                 (first clause) production))
                  (list 'bind-lhs (variable-index binding)
                        (sub-eval-vars (second clause) bindings))))
               ((eq '!find-location! key)
                (with-binding binding bound (first clause) bindings index
                  (when bound
                    (signal-warn "VARIABLE ~S ALREADY BOUND IN PRODUCTION ~A."
                                 (first clause) production))
                  (list 'bind-find-location (variable-index binding)
                        (sub-eval-vars (cons 'list (quote-arguments (rest clause)))
                                       bindings))))
               (t (signal-warn "UNKNOWN COMMAND ~S IN PRODUCTION ~A."
                               key production))))
        (setf code (nconc code form))))
    ;; FIX: split into goal and retrievals when ERA is enabled.
    (values (if *enable-rational-analysis*
              (let ((direct-length (first-retrieval-index code initializations)))
                (cons (nconc (subseq code 0 direct-length) (list 'add-instantiation-to-conflict-set))
                      (nconc (subseq code direct-length) (list 'not))))
              (nconc code (list 'add-instantiation-to-conflict-set)))
            bindings index)))

(defun compile-rhs (production rhs bindings index)
  "Compiles the right-hand side of production."
  (let ((code nil)
        (returns nil)
        (goal-stack (list (variable-name (first bindings)))))        
    (dolist (clause rhs)
      (let ((key (pop clause))
            (type nil)
            (assigns nil)
            (slot nil)
            (value nil)
            (negation nil))
        (setf code (nconc code
         (cond ((retrievalp key)
                (setf key (var>var key))
                (when (actionp key) (setf key (var=var key))) ;; strip out the +
                (cond ((clearp key)  ;; clearing buffers 
                       (setf key (var=var key))  ;; strip out the -
                       (cond ((member key '(visual manual aural vocal))  ;; clearing modules
                              (let ((command-call (list (case key 
                                                          (visual :vision)
                                                          (aural :audio)
                                                          (manual :motor)
                                                          (vocal :speech)) 'clear)))
                                (list (list 'action-command
                                            (sub-eval-vars (cons 'list (quote-arguments command-call))
                                                           bindings)))))
                             ((assoc key *buffer-keywords*)  ;; clearing ACT-R buffers
                              (list (list 'assign-buffer key nil)))
                             ((assoc key *buffers*)   ;;; rhs buffer clearing
                              (let ((buffer (assoc key *buffers*)))
                                (list (list (buffer-calls-minus-rhs (third buffer))
                                            (first buffer) (second buffer)))))
                             (t
                              (signal-warn "UNKNOWN BUFFER ~S CANNOT CLEAR." key))))
                      ((and (or (assoc key *buffer-keywords*)
                                ;; directly manipulate PM buffers
                                (member key '(visual manual vocal aural
                                              =visual =manual =vocal =aural))) 
                            (null (rest clause))
                            (null (rest (first clause)))
                            (listp (first (first clause))))
                       ;; assignment to buffer of result of function call
                       (list (list 'assign-buffer key
                                   (sub-eval-vars (first (first clause)) bindings))))
                      ((and (not (variablep key)) (assoc key *buffer-keywords*)
                            (null (rest clause)) (null (rest (first clause))))
                       ;; direct assignment to buffers, including goal focus and direct retrieval
                       (let ((binding (get-variable-binding (first (first clause)) bindings)))
                         (cond ((eq key 'goal)  ;; focus on goal
                                (setf goal-stack (butlast goal-stack))
                                (push-last key goal-stack)
                                (list (list 'focus-fct 
                                            (variable-index binding)
                                            (subgoal-returns key returns))))
                               ((eq key 'retrieval)   ;; direct retrieval
                                (list (list 'handle-failure
                                            (if *enable-rational-analysis*
                                              'direct-test-and-bind-pm
                                              'direct-test-and-bind)
                                            (variable-index binding)
                                            type nil nil
                                            'assign-retrieval
                                            (variable-index binding))))
                               (t  ;; other buffer assignment
                                (list (list 'assign-buffer key (variable-index binding)))))))
                      (t
                       (with-binding binding modify key bindings index
                         (cond (modify
                                (setf type (variable-type binding))
                                (if (and type (not (integerp type)))
                                  (when (eq 'isa (caar clause))
                                    (set-variable-type production type key (pop clause))
                                    (unless (or (eq type (variable-type binding))
                                                (assoc key *buffer-keywords*))
                                      (signal-warn "TYPE OF VARIABLE ~S IS BEING REDEFINED IN PRODUCTION ~A."
                                                   key production)))
                                  (set-variable-type production type key (pop clause))))
                               (t
                                (set-variable-type production type key (pop clause))))
                         (when type
                           (cond ((or (eq 'retrieval key)
                                      (member (list '!retrieve! key) rhs :test #'equal))
                                  (let ((tests nil)
                                        (binds nil))
                                    (compile-lhs-slots tests binds)
                                    (list (list 'handle-failure
                                                (if *enable-rational-analysis*
                                                  (if modify
                                                    'direct-test-and-bind-pm
                                                    'indirect-test-and-bind-pm)
                                                  (if modify
                                                    'direct-test-and-bind
                                                    'indirect-test-and-bind))
                                                nil
                                                type tests binds
                                                'assign-retrieval
                                                nil))))
                                 ;;; Partial implementation of RHS buffers.
                                 ;;; Full implementation will require further standardization of RPM conventions
                                 ((member key '(visual manual visual-location vocal aural aural-location))
                                  (let* ((fct-args (rest (assoc (wme-type-name type) *rhs-pm-calls* :test #'eq)))
                                         (command-call (copy-seq (first fct-args)))
                                         (argument-alist (rest fct-args)))
                                    (dolist (slot-value (translate-comparison-tests clause))
                                      (let* ((slot (first slot-value))
                                             (value (second slot-value))
                                             (mapping (assoc slot argument-alist)))
                                        (if mapping
                                          (setf command-call
                                                (nconc command-call (if (second mapping) (list (second mapping) value)
                                                                        (list value))))
                                          (signal-warn "SLOT ~S OF CHUNK ~S TYPE ~S IN PRODUCTION ~S IS UNDEFINED."
                                                       slot key type production))))
                                    (list (list 'action-command
                                                (sub-eval-vars (cons 'list (quote-arguments command-call))
                                                               bindings)))))
                                 ((member key '(visual-state manual-location manual-state vocal-location vocal-state aural-state))
                                  (signal-warn "RESERVED KEYWORD ~A NOT YET IMPLEMENTED." key))
                                 ((assoc key *buffers*)  ;;; rhs buffer action
                                  (let ((buffer (assoc key *buffers*))
                                        (arguments (sub-eval-vars (cons 'list (quote-arguments (cons 'isa (cons type (flatten clause)))))
                                                                  bindings)))
                                    (list (list (buffer-calls-plus-rhs (third buffer))
                                                (first buffer) (second buffer)
                                                arguments))))
                                  ((assoc (var=var key) *buffers*)   ;;; rhs buffer modification
                                   (let ((buffer (assoc (var=var key) *buffers*))
                                         (arguments (sub-eval-vars (cons 'list (quote-arguments (flatten clause)))
                                                                  bindings)))
                                     (list (list (buffer-calls-equal-rhs (third buffer))
                                                 (first buffer) (second buffer) arguments))))
                                 (t
                                  (compile-rhs-slots assigns returns binding)
                                  (cons
                                   (if modify
                                     (list 'modify-old-wme (variable-index binding)
                                           type assigns)
                                     (list 'create-new-wme (variable-index binding)
                                           (if (variablep key) (var=var key) key) type assigns))
                                   (when (and (or (eq '=newgoal key) (eq 'newgoal key) (eq 'goal key))
                                              (not (member (list '!push! key) rhs :test #'equal))
                                              (not (member (list '!focus-on! key) rhs :test #'equal)))
                                     (setf goal-stack (butlast goal-stack))
                                     (push-last key goal-stack)
                                     (list (list 'focus-fct 
                                                 (variable-index binding)
                                                 (subgoal-returns key returns))))))))))))
               ((eq '!retrieve! key) ;; do nothing since retrieval already done
                nil)
               ((eq '!push! key)
                (let* ((subgoal (first clause))
                       (binding (get-safe-variable-binding subgoal bindings production)))
                  (when binding
                    (push-last subgoal goal-stack)
                    (list (list 'push-fct
                                (variable-index binding)
                                (subgoal-returns subgoal returns))))))
               ((eq '!pop! key)
                ;;; FIX: pop from the end of the stack
                (setf goal-stack (butlast goal-stack))
                (list (list 'pop-fct)))
               ((eq '!focus-on! key)
                (let* ((subgoal (first clause))
                       (binding (get-safe-variable-binding subgoal bindings production)))
                  (when binding
                    ;;; FIX: do not assume that there is something on the stack
                    (setf goal-stack (butlast goal-stack))
                    (push-last subgoal goal-stack)
                    (list (list 'focus-fct 
                                (variable-index binding)
                                (subgoal-returns subgoal returns))))))
               ((eq '!output! key)
                (list (list 'output (compile-output clause bindings production))))
               ((eq '!eval! key)
                (list (list 'eval-side (sub-eval-vars (first clause) bindings))))
               ((eq '!bind! key)
                (with-binding binding bound (first clause) bindings index
                  (when bound
                    (signal-warn "VARIABLE ~S ALREADY BOUND IN PRODUCTION ~A."
                                 (first clause) production))
                  (list (list 'bind-rhs (variable-index binding)
                              (sub-eval-vars (second clause) bindings)))))
               ((eq '!move-attention! key)
                (with-binding binding bound (first clause) bindings index
                  (when bound
                    (signal-warn "VARIABLE ~S ALREADY BOUND IN PRODUCTION ~A."
                                 (first clause) production))
                  (list (list 'bind-move-attention (variable-index binding)
                              (sub-eval-vars (cons 'list (quote-arguments (rest clause)))
                                             bindings)))))
               ((eq '!press-key! key)
                (list (list 'visual-action 'press-key
                            (sub-eval-vars (cons 'list (quote-arguments clause))
                                           bindings))))
               ((eq '!move-mouse! key)
                (list (list 'visual-action 'move-mouse
                            (sub-eval-vars (cons 'list (quote-arguments clause))
                                           bindings))))
               ((eq '!click-mouse! key)
                (list (list 'visual-action 'click-mouse
                            (sub-eval-vars (cons 'list (quote-arguments clause))
                                           bindings))))
               ((eq '!send-command! key)
                (list (list 'action-command
                            (sub-eval-vars (cons 'list (quote-arguments clause))
                                           bindings))))
               ((eq '!delete! key)
                (let ((binding (get-safe-variable-binding (first clause) bindings production)))
                  (when binding
                    (list (list 'delete-wme-variable (variable-index binding))))))
               ((or (eq '!copy! key) (eq '!copywme! key))
                (with-binding binding bound (first clause) bindings index
                  (when bound
                    (signal-warn "VARIABLE ~S ALREADY BOUND IN PRODUCTION ~A."
                                 (first clause) production))
                  (list (list 'copy-chunk-variable (variable-index binding)
                              (sub-eval-vars (cons 'list (rest clause))
                                             bindings)))))
               ((eq '!stop! key)
                (list (list 'stop)))
               ((eq '!restart! key)
                (list (list 'restart-top-goal)))
               (t (signal-warn "UNKNOWN COMMAND ~S IN PRODUCTION ~A." key production)))))))
    ; remove the unknown commands
    ; (setf code (delete nil code :test #'eq))
    ; translate wme variables into relative goal stack indices for value returns
    (dolist (return returns)
      (let ((from-position
             (position (variable-name (variable-index return))
                       goal-stack :test #'eq)))
        (if from-position
          (dolist (destination (variable-returns return))
            (let ((to-position (position (first destination) goal-stack :test #'eq)))
              (if (and (numberp to-position) (> from-position to-position))
                (rplaca destination (- from-position to-position 1))
                (signal-warn "VARIABLE ~A CANNOT BE RETURNED BECAUSE CHUNK ~A IS NOT ON THE STACK BELOW SUBGOAL ~A IN PRODUCTION ~A."
                       (variable-name return) (first destination)
                       (variable-name (variable-index return)) production))))
          (signal-warn "VARIABLE ~A CANNOT BE RETURNED BECAUSE CHUNK ~A IS NOT ON THE STACK IN PRODUCTION ~A."
                       (variable-name return)
                       (variable-name (variable-index return)) production))))
    (values code bindings index)))

(defun clear-all-fct (&optional (save-model t))
  "Clears everything."
  (clear-used-symbols-fct)
  (setf *compile-eval-calls* nil)
  (when *load-pathname*
    (setf *model* (when save-model (list *load-pathname*)))
    (when (eq save-model t)
      (load-model-list *load-pathname*)))
  (setf *time* 0.0)
  (setf *start-time* 0.0)
  (setf *default-action-time* 0.05)
  (setf *latency* 0.0)
  (setf *cycle* 0)
  (setf *spread-stamp* 0)
  (setf *wme-number* 0.0)
  (setf *buffers* nil)
  (setf *declarative-memory* nil)
  (setf *hash-names* (make-hash-table :test #'eq :size 1000))
  (init-types)
  (setf *procedural-memory* nil)
  (setf *goal-activation* 0.0)
  (setf *goal-sources* nil)
  (setf *wmfocus* nil)
  (setf *wmfocus-list* nil)
  (setf *goal-stack* nil)
  (setf *goal-depth* 1)
  (setf *g* 20.0)
  (setf *exp-gain-noise* nil)
  (setf *retrieval* nil)
  (setf *retrieval-scheduler* nil)
  (setf *visual-location* nil)
  (setf *aural-location* nil)
  (setf *previous-instantiations* nil)
  (setf *previous-instantiation* nil)
  (setf *instantiation* nil)
  (setf *extra-instantiation* nil)
  (setf *conflict-set* nil)
  (setf *sum-exp-act* 0.0)
  (setf *latency-fn* 'competitive-latency)
  (setf *latency-factor* 1.0)
  (setf *latency-exponent* 1.0)
  (setf *base-level-constant* 0.0)
  (setf *activation-sources* nil)
  (setf *activation-noise* nil)
  (setf *permanent-activation-noise* nil)
  (setf *mismatch-penalty* 1.0)
  (setf *retrieval-threshold* nil)
  (setf *partial-matching* nil)
  (setf *max-sim* 1.0)
  (setf *max-dif* -10.0)
  (setf *temperature* 1.0)
  (setf *blending* nil)
  (setf *break-productions* nil)
  (setf *failed-productions* nil)
  (setf *cost-penalty* 1.0)
  (setf *initial-experience* 10.0)
  (setf *threshold-time* 2.0)
  (setf *enable-production-learning* nil)
  (setf *reinforce-analogized-production* t)
  (setf *production-compilation-parameters* nil)
  (setf *enable-rational-analysis* nil)
  (setf *enable-randomness* nil)
  (setf *utility-threshold* 0.0)
  (setf *optimized-learning* t)
  (setf *base-level-learning* nil)
  (setf *associative-learning* nil)
  (setf *strength-learning* nil)
  (setf *parameters-learning* nil)
  (setf *command-trace* t)
  (setf *output-trace* t)
  (setf *cycle-trace* t)
  (setf *latency-trace* nil)
  (setf *partial-matching-trace* nil)
  (setf *blending-trace* nil)
  (setf *production-compilation-trace* t)
  (setf *activation-trace* nil)
  (setf *conflict-resolution-trace* nil)
  (setf *conflict-set-trace* nil)
  (setf *goal-trace* nil)
  (setf *dm-trace* nil)
  (setf *production-trace* nil)
  (setf *matches-trace* nil)
  (setf *exact-matching-trace* nil)
  (setf *verbose* t)
  (setf *abort-instantiation* t)
  (setf *parameter-sets* nil)
  (setf *similarity-hook-fn* nil)
  (setf *blending-hook-fn* 'blending-arithmetic-mean)
  (setf *conflict-set-hook-fn* nil)
  (setf *firing-hook-fn* nil)
  (setf *cycle-hook-fn* nil)
  (setf *web-hook-fn* nil)
  (setf *end-run-hook-fn* nil)
  (setf *step-fn* 'step-fct)
  (setf *stop* nil)
  (setf *save-state-changes* nil)
  (setf *pop-upon-failure* nil)
  (when *init-hook-fn* (funcall *init-hook-fn*)))


;;; and here's the code to implement the new buffer

(defparameter *imaginal* nil
  "The global variable for holding buffer content has to be defined separately.")

(defun get-buffer-content (arguments)
  "Argument is a list containing the name of the buffer and its global variable."
  (let* ((name (pop arguments))
         (buffer (pop arguments))
         (chunk (symbol-value buffer)))
    (signal-output *exact-matching-trace* "BUFFER ~A holds CHUNK ~A." name chunk)    
    (symbol-value buffer)))

(defun clear-buffer (arguments)
  "Argument is a list containing the name of the buffer and its global variable."
  (let ((name (pop arguments))
        (buffer (pop arguments)))
    (signal-output *dm-trace* "Clearing BUFFER ~A." name)    
    (setf (symbol-value buffer) nil)))

(defun create-buffer-chunk (arguments)
  "Arguments are a list containing the name of the buffer, the global variable
   holding the buffer contents, then the chunk description with isa and slots.
   THIS LAST ARGUMENT MUST BE FUNCALLED TO RESOLVE THE VALUE OF PRODUCTION VARIABLES."
  (let* ((name (pop arguments))
         (buffer (pop arguments))
         (chunk (new-name-fct name))
         (specs (funcall (pop arguments))))
    (signal-output *dm-trace* "Creating CHUNK ~A in BUFFER ~A with specs ~S."
                   chunk name specs)
    (add-dm-fct (list (cons chunk specs)))
    (setf (symbol-value buffer) (get-wme chunk))))

(defun modify-buffer-chunk (arguments)
  "Arguments are a list containing the name of the buffer, the global variable
   holding the buffer contents, then the chunk description with slots but no isa.
   THIS LAST ARGUMENT MUST BE FUNCALLED TO RESOLVE THE VALUE OF PRODUCTION VARIABLES."
   (push *time* *visual*)
   (let* ((name (pop arguments))
         (buffer (pop arguments))
         (chunk (symbol-value buffer))
         (specs (funcall (pop arguments))))
    (signal-output *dm-trace* "Modifying CHUNK ~A in BUFFER ~A with specs ~S."
                   chunk name specs)
    (mod-chunk-fct chunk specs)))


(setf *actr-enabled-p* t)

(defparameter *sim* .5)

(defun gammafn (x)
  (* (expt x x) (exp (- x)) (sqrt (* 2 pi x)) (1+ (/ 1 (* 12 x)))))

(defparameter *ret-exp* 10)
(defparameter *man-exp* 2.732)
(defparameter *imag-exp* 2.559)
(defparameter *ret-scale* 0.543)
(defparameter *man-scale* 1.687)
(defparameter *imag-scale* 2.158)
(defparameter *ret-mag* (/ 0.657 (gammafn *ret-exp*)))
(defparameter *man-mag* (/ 4.798 (gammafn *man-exp*)))
(defparameter *imag-mag* (/ 2.379 (gammafn *imag-exp*)))

(defvar *experiment-window* nil)
(defvar *response* nil)
(defvar *hold-time* nil)
(defparameter *graphic* nil)

(defparameter *v* nil)

(defvar *a*)
(defvar *b*)
(defvar *c*)

(defvar *WWW-interface*)

(setf  *WWW-interface* 
      '((:heading "fMRI Experiment 2" 2)
        (:heading "Parameters" 3)
        (:table)
        (:table)
        "scale, s (retrieval):" (:string :sy *ret-scale* 0.543)  (:new-row)
        "scale, s (imaginal):"  (:string :sy *imag-scale* 2.158) (:new-row)
        "scale, s (manual):"    (:string :sy *man-scale* 1.687)  (:new-row)       
        "exponent, a (retrieval):" (:string :sy *ret-exp* 10)  (:new-row)
        "exponent, a (imaginal):"  (:string :sy *imag-exp* 2.559) (:new-row)
        "exponent, a (manual):"    (:string :sy *man-exp* 2.732)   (:new-row)      
        "magnitude, M (retrieval):" (:string :sy *ret-mag* 0.657)  (:new-row)
        "magnitude, M (imaginal):"  (:string :sy *imag-mag* 2.379) (:new-row)
        "magnitude, M (manual):"    (:string :sy *man-mag* 4.798)         
       
        (:table-end)
        
        (:table)
        (:checkbox "Trace" :sy *v*  nil)                (:new-row)
        (:checkbox "Graphic output" :sy *graphic*  nil) (:new-row)
        (:table-end)
        (:table-end)
        
        (:new-para)
        
        (:heading "Equation" 3)
        (:table)
        (:table)
        "prefix: "           (:string :sy *a* "nil") (:new-row)
        "postfix: "          (:string :sy *b* "(2 3)") (:new-row)
        "right expression: " (:string :sy *c* "(2 3)")  
        (:table-end)
        (:table-end)
(:new-para)
"The values for the equation parameters allow you to specify the conditions of the trial presented to the model (see the paper for more details). The three parameters specify the prefix, postfix, and the characters on the right of the equation.  The prefix values may be nil, 2, 3, 4, or 5.  The postfix must be a list of 2 characters or nil, and the characters must be 2, 3, 4, or 5. The right expression must be a list of either 2 or 4 characters, contingent on the postfix.  So, if postfix is nil, right expression must be 4 characters and if postfix is 2 characters right expression must be 2 characters.  The default values specify the problem \"P 2 3 <-> 2 3\"."   


        (:new-para)
        (:button "Run model" "(if (and 
                                       (numberp *ret-scale*) (numberp *man-scale*) 
                                       (numberp *imag-scale*)(numberp *ret-exp*) (numberp *man-exp*) 
                                       (numberp *imag-exp*)(numberp *ret-mag*) (numberp *man-mag*) 
                                       (numberp *imag-mag*))
                                 (progn
                                    (setf *ret-mag* (/ *ret-mag* (gammafn *ret-exp*)))
                                      (setf *man-mag* (/ *man-mag* (gammafn *man-exp*)))
                                      (setf *imag-mag* (/ *imag-mag* (gammafn *imag-exp*)))
                                    (demo *a* *b* *c*))
                                (format *standard-output* \"~%~%All parameters must be numbers.~%\"))")
        (:reset "Default values")
        (:button "Production Rules" "(let ((prods (no-output (pp))))
                                       (dolist (x prods)
                                         (pp-fct (list x))
                                         (spp-fct (list x))
                                         (format *standard-output* \"~%\")))")
        (:button "Chunk types" "(chunk-type)")
        (:button "Chunks" "(dm)")
        (:new-para)
         "TIME and SIZE:"
        (:new-para)
        "- It usually takes less than 1 minute to run the model"
        (:new-line)
        "- The trace of 1 run is approximatly 3k (2 pages) in size"
        (:use-actr5)))



(defun count-productions (x) (push *time* *productions*))

(defun transform (start val)
  (push *time* *visual*))

(defun average (x y) (/ (+ x y) 2))

(defun test-equation (eq)
  (princ "The equation is ")(princ eq) (terpri)
  (setf *visual* nil *retrieved* nil *productions* nil)
  (when (open-rpm-window? *experiment-window*)
    (close-rpm-window *experiment-window*))
  
  (setf *experiment-window* (make-rpm-window :visible nil ;; model probably doesn't work with t but a person can do it then
                                             :title "Equation Experiment"
                                             :width 300 :height 300))
  
  (if *actr-enabled-p* 
      (let ((goal (new-name "GOAL"))
            (result nil))
        (reset) 
        (add-dm-fct (list (cons goal `(isa goal step start))))
        (goal-focus-fct  (list goal))
        (add-visual-items-to-rpm-window *experiment-window* 
                                        (make-static-text-for-rpm-window *experiment-window* 
                                                                         :x 25
                                                                         :y 150
                                                                         :width 275
                                                                         :text eq)) 
        
        (pm-install-device *experiment-window*)
        (pm-proc-display)
        (setf *response* nil)
        (setf *hold-time* nil)
        
        (pm-run 18.0)
        
        (push (list *response* (if *hold-time* (/ *hold-time* 1000.0))) result)
        
        (lose-focus)
        (remove-all-items-from-rpm-window *experiment-window*)
        (add-visual-items-to-rpm-window *experiment-window* 
                                        (make-static-text-for-rpm-window *experiment-window* 
                                                                         :x 25
                                                                         :y 150
                                                                         :width 275
                                                                         :text "X <-> ")) 
        
        (pm-proc-display)
        
        (do ((count 0 (1+ count))
             (steps '(first second third fourth) (cdr steps))
             (pos 75 (+ pos 50))
             (start-time (pm-get-time) (pm-get-time)))
            ((equal count 4) (generate (mapcar 'first (reverse result))
                                       (mapcar 'second (reverse result))
                                       (reverse *retrieved*)
                                       (reverse *visual*)))
          
          
          (add-visual-items-to-rpm-window *experiment-window* 
                                          (make-static-text-for-rpm-window *experiment-window* 
                                                                           :x pos
                                                                           :y 150
                                                                           :width 25
                                                                           :text "*")) 
          
          (pm-proc-display)
          
          (setf *response* nil)
          (setf *hold-time* nil)
          (pm-run 1.5 :full-time t)
          
          
          (push (list *response* (if *hold-time* (/ (- *hold-time* start-time) 1000.0))) result)
          
          ))
    (let ((start-time nil))
      ;; for a person
      
      (add-visual-items-to-rpm-window *experiment-window* 
                                      (make-static-text-for-rpm-window *experiment-window* 
                                                                       :x 25
                                                                       :y 150
                                                                       :width 275
                                                                       :text eq)) 
      (setf *response* nil)
      (setf *hold-time* nil)
      (setf start-time (pm-get-time))
      (while (and (null *response*) (< (- (pm-get-time) start-time 18000)))
        (allow-event-manager *experiment-window*))
             
      (remove-all-items-from-rpm-window *experiment-window*)
      (add-visual-items-to-rpm-window *experiment-window* 
                                      (make-static-text-for-rpm-window *experiment-window* 
                                                                       :x 25
                                                                       :y 150
                                                                       :width 275
                                                                       :text "X <-> ")) 
      
        (dotimes (i 4)
          
          (add-visual-items-to-rpm-window *experiment-window* 
                                          (make-static-text-for-rpm-window *experiment-window* 
                                                                           :x (+ 75 (* i 50))
                                                                           :y 150
                                                                           :width 25
                                                                           :text "*")) 
          (sleep 1.5))))

    (close-rpm-window *experiment-window*))


#+:(or :mcl :allegro-ide) (defmethod rpm-window-key-event-handler ((win rpm-window) key)
      (setf *response* (string key))
      (setf *hold-time* (pm-get-time))
      )


(defmethod rpm-window-key-event-handler ((win virtual-window) key)
  (setf *response* (string key))
  (setf *hold-time* (pm-get-time)))


 
 
(defun demo (prefix postfix right)
  (let ((equation (cond ((not (legaltest prefix postfix right)) 'illegal)
                        (prefix (cond (postfix (format nil "~d P ~d ~d <-> ~d ~d"
                                                 prefix (first postfix) (second postfix)
                                                 (first right) (second right)))
                                      (t (format nil "~d P <-> ~d ~d ~d ~d" prefix
                                           (first right) (second right)
                                           (third right) (fourth right)))))
                        (postfix (format nil "P ~d ~d <-> ~d ~d" (first postfix) (second postfix)
                                   (first right) (second right)))
                        (t (format nil "P <-> ~d ~d ~d ~d" (first right) (second right)
                             (third right) (fourth right))))))
    (cond ((not (equal equation 'illegal)) (test-equation equation))
          (t (format t "Invalid equation.")))))

(defun legaltest (prefix postfix right)
  (and (or (and (= (length postfix) 2) (= (length right) 2))
           (and (= (length postfix) 0) (= (length right) 4)))
       (do ((temp (if prefix (cons prefix (append postfix right))
                    (append postfix right)) (cdr temp)))
           ((null temp) t)
         (cond ((not (member (car temp) '(2 3 4 5))) (return nil))))))




(defun generate (answer times ret imag)
  (let* ((imaginal (mapcar #'(lambda (x) (list (+ 3 x) .2)) imag))
         (rt (+ 3 (car times)))
         (retrieval (mapcar #'(lambda (x) (list (+ 3 (first x)) (second x))) ret))
         (manual (do ((temp (cddr times) (cdr temp))
                      (result (list (list (+ rt -.3 (second times)) .3)
                                    (list (- rt 0.4) .3))
                              (cons (list (+ (caar result) 1.5) .3) result)))
                     ((null temp) (reverse result))))
        (res (list nil nil nil)))
    (format t "~%The model's answer is ~{~a~} and it was generated in ~6,3f seconds~%~%" answer (- rt 3)) 
    (format t " Scan  Time(sec) Imaginal  Retrieval   Motor~%")
    
    (dotimes (scan 12)
      (let* ((mean (+ .75 (* scan 1.5)))
             (i (* *imag-mag* (bold-fn mean imaginal *imag-exp* *imag-scale*)))
             (r (* *ret-mag* (bold-fn mean retrieval *ret-exp* *ret-scale*)))
             (m (* *man-mag* (bold-fn mean manual *man-exp* *man-scale*))))
        (format t "~4d~10,3f~10,3f~10,3f~10,3f~%" (1+ scan) mean i r m) 
        (push i (first res))
        (push r (second res))
        (push m (third res))))
    (draw-graphs res)))

(defun draw-graphs (data)
  (unless *graphic* (format *standard-output* 
                        "~%</pre>If your browser supports JAVA, you 
                               can display the data in a graph by checking 
                               the Graphic output box on the interface page.<pre>~%~%"))
  (when *graphic*
    (format *standard-output* " 
        <applet 
        code = \"DansGraphs.class\" 
        width = 500 
        height = 400> 
        <PARAM name=\"title\" value=\"Model BOLD Response Predictions\">
        <PARAM name=\"xmin\" value=\"0\">
        <PARAM name=\"xmax\" value=\"18\">
        <PARAM name=\"ymax\" value=\"1.0\">
        <PARAM name=\"ymin\" value=\"0.0\">
        <PARAM name=\"longestline\" value=\"12\">
        <PARAM name=\"numlines\" value=\"3\">
        <PARAM name=\"xdiv\" value=\"1\">
        <PARAM name=\"xspacing\" value=\"5\">
        <PARAM name=\"ydiv\" value=\"0.1\">
        <PARAM name=\"yspacing\" value=\"0.2\">
        <PARAM name=\"xname\" value=\"Time (sec.)\">
        <PARAM name=\"yname\" value=\"Percent change\">
        <PARAM name=\"name0\" value=\"Imaginal\">
        <PARAM name=\"lcolor0\" value=\"0\">
        <PARAM name=\"lstyle0\" value=\"2\">
        <PARAM name=\"xval0\" value=\"0.75;2.25;3.75;5.25;6.75;8.25;9.75;11.25;12.75;14.25;15.75;17.25;\">
        <PARAM name=\"name1\" value=\"Retrieval\">
        <PARAM name=\"lcolor1\" value=\"1\">
        <PARAM name=\"lstyle1\" value=\"2\">
        <PARAM name=\"xval1\" value=\"0.75;2.25;3.75;5.25;6.75;8.25;9.75;11.25;12.75;14.25;15.75;17.25;\">
        <PARAM name=\"name2\" value=\"Manual\">
        <PARAM name=\"lcolor2\" value=\"2\">
        <PARAM name=\"lstyle2\" value=\"2\">
        <PARAM name=\"xval2\" value=\"0.75;2.25;3.75;5.25;6.75;8.25;9.75;11.25;12.75;14.25;15.75;17.25;\"> ")

      (dotimes (i 3) 
        (format *standard-output* "<PARAM name=\"yval~s\" value=\"" i)
        (dotimes (j 12)
          (format *standard-output* "~6,3f;" (nth (- 11 j) (nth i data))))
      
      (format *standard-output* "\">"))

    (format *standard-output* "
             <HR> Either your browser does not support JAVA or this graph has scrolled off the top of the display.~%
             </HR></applet>")))

(defun integrate (t1 t2 exp scale)
  (let* ((nt1 (/ t1 scale))
         (nt2 (/ t2 scale))
         (nt12 (/ (+ nt1 nt2) 2))
         (start (* (expt nt1 exp) (exp (- nt1))))
         (mid (* (expt nt12 exp) (exp (- nt12))))
         (end (* (expt nt2 exp) (exp (- nt2)))))
    (* (- nt2 nt1) .25 (+ start mid mid end))))

(defun sqr (x) (* x x))

(defun bold-fn (time lis exp scale)
  (do ((temp lis (cdr temp))
       (signal 0 (+ signal (calculate-bold time (caar temp) (cadar temp) exp scale))))
      ((or (null temp) (< time (caar temp))) (return signal))))

(defun calculate-bold (current past length exp scale)
  (integrate (- current past) (+ length (- current past))
             exp scale))

(defun assign-retrieval (arguments)
  "Assigns to the variable *retrieval-scheduler* the result and latency of the retrieval.
   The variable *retrieval* is also reset to nil waiting for the result."
  (let ((retrieval (if (first arguments)
                       (instantiation-variable *instantiation* (pop arguments))
                     *retrieval-scheduler*)))
    (signal-output *latency-trace* "Latency ~6,3F: ~A Retrieval" *latency* retrieval)
    (setf *retrieved* (push (list *time* *latency*) *retrieved*))
    (setf *retrieval* nil)
    (setf *retrieval-scheduler* (cons (+ *time* *latency*) retrieval))))


(defun string-similarity (string1 string2)
  (when (and (stringp string1) (stringp string2))
    (if (equal string1 string2) 
        *max-sim*
      *sim*)))

(defun lose-focus ()
  (setf (current-marker (vis-m *mp*)) nil)
  (setf (currently-attended (vis-m *mp*)) nil)
  )

(defparameter trial1 "P <-> 2 3 4 5")
(defparameter trial2 "5 P <-> 2 3 4 5")
(defparameter trial3 "3 P <-> 2 3 4 5")
(defparameter trial4 "2 P <-> 5 3 4 5")
(defparameter trial5 "2 P <-> 2 3 4 5")
(defparameter trial6 "2 P <-> 4 3 2 5")
(defparameter trial7 "2 P <-> 3 3 2 5")
(defparameter trial8 "4 P <-> 3 3 2 5")
(defparameter trial9 "4 P <-> 4 3 2 5")
(defparameter trial10 "4 P <-> 2 3 4 5")
(defparameter trial11 "4 P <-> 5 3 4 5")
(defparameter trial12 "5 P 2 3 <-> 4 5")
(defparameter trial13 "2 P 2 3 <-> 4 5")
(defparameter trial14 "2 P 2 3 <-> 2 5")
(defparameter trial15 "2 P 4 3 <-> 4 5")
(defparameter trial16 "2 P 4 3 <-> 2 5")
(defparameter trial17 "4 P 4 3 <-> 2 5")
(defparameter trial18 "4 P 4 3 <-> 4 5")
(defparameter trial19 "4 P 2 3 <-> 2 5")
(defparameter trial20 "4 P 2 3 <-> 4 5")
(defparameter trial21 "3 P 2 3 <-> 4 5")

(defun do-experiment (flag)
  (setf *v* flag)
  (mapcar #'(lambda (x) (test-equation x )) 
                (list trial1 trial2 trial2 trial2 trial2 trial3 trial3 trial3 trial3
                     trial4 trial5 trial6 trial7 trial8 trial9 trial10 trial11
                     trial12 trial12 trial12 trial12 trial21 trial21 trial21 trial21
                     trial13 trial14 trial15 trial16 trial17 trial18 trial19 trial20)))
    


(;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;</xmp><pre><a name="model">
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;</a>
;;;
;;; This section contains the ACT-R productions
;;; and memory definitions for the simulation

clear-all)
(pm-reset)
 
(define-buffer imaginal *imaginal*
  :equal-lhs get-buffer-content
  :plus-rhs create-buffer-chunk
  :equal-rhs modify-buffer-chunk
  :minus-rhs clear-buffer)

(sgp-fct (list :v *v* :esc t :lf .65 :ga 0.00))

(setf *latency-fn* 'old-latency)
 
(chunk-type goal step position)
(chunk-type invert operator action arg)
(chunk-type operator identity inverse)
(chunk-type fact relation arg1 arg2)
(chunk-type equation op1 arg1 op2 arg2 relation op3 arg3 op4 arg4)

(add-dm (rule1 isa invert operator "5" action null)
        (rule2 isa invert operator "3" action flip)
        (rule3 isa invert operator "2" action exchange)
        (rule4 isa invert operator "4" action exchange)
        (rule5 isa invert operator arg action copy arg fourth)
        (rule6 isa invert operator operator action copy-exchange arg third)
        (first isa chunk) (second isa chunk)
        (third isa chunk) (fourth isa chunk)
        (arg-position isa fact relation position arg1 arguments arg2 even)
        (2 isa operator identity "2" inverse "3")
        (3 isa operator identity "3" inverse "2")
        (4 isa operator identity "4" inverse "5")
        (5 isa operator identity "5" inverse "4"))

 (setf *firing-hook-fn* #'count-productions)

(p start
   =goal>
      isa goal
      step start
==>
  +imaginal>
      isa equation
      relation "<->"
  +visual-location>
      isa visual-location
      value  "<->"
  =goal>
      step right)

(p right
   =goal>
      isa goal
      step right
   =visual-location>
      isa visual-location
      screen-x =x
==>
!bind! =x1 (+ =x 5)
!bind! =y (+ =x 25)
   +visual-location>
      Isa visual-location
     screen-x (within =x1 =y)
     attended nil
   =goal>
      step look-first)

(p look-first
   =goal>
      isa goal
      step look-first
   =visual-location>
      isa visual-location
==>
   +visual>
      ISA         visual-object
      screen-pos  =visual-location
   =goal>
      step encode-first)


(p encode-first
   =goal>
      isa goal
      step encode-first
   =visual>
      isa text
      value =value
   =visual-location>
      isa visual-location
      screen-x =x
   =imaginal>
      isa equation
      op3 nil
==>
!bind! =y (+ =x 20)
   =imaginal>
       op3 =value
   +visual-location>
      Isa visual-location
     screen-x (within =x =y)
     attended nil
   =goal>
      step look-second)

(spp encode-first :effort .15)

(p look-second
   =goal>
      isa goal
      step look-second
   =visual-location>
      isa visual-location
==>
   +visual>
      ISA         visual-object
      screen-pos  =visual-location
   =goal>
      step encode-second)


(p encode-second
   =goal>
      isa goal
      step encode-second
   =visual>
      isa text
      value =value
   =visual-location>
      isa visual-location
      screen-x =x
   =imaginal>
      isa equation
      arg3 nil
==>
!bind! =y (+ =x 20)
   =imaginal>
       arg3 =value
   +visual-location>
     Isa visual-location
     screen-x (within =x =y)
     attended nil
   =goal>
      step look-third)

(spp encode-second :effort .15)

(p look-third
   =goal>
      isa goal
      step look-third
   =visual-location>
      isa visual-location
==>
   +visual>
      ISA         visual-object
      screen-pos  =visual-location
   =goal>
      step encode-third)

(p left-short
   =goal>
      isa goal
      step look-third
   =visual-location>
      isa error
==>
  +visual-location>
      isa visual-location
      value  "<->"
   =goal>
      step left)


(p encode-third
   =goal>
      isa goal
      step encode-third
   =visual>
      isa text
      value =value
   =visual-location>
      isa visual-location
      screen-x =x
   =imaginal>
      isa equation
      op4 nil
==>
!bind! =y (+ =x 20)
   =imaginal>
       op4 =value
   +visual-location>
     Isa visual-location
     screen-x (within =x =y)
     attended nil
   =goal>
      step look-fourth)

(spp encode-third :effort .15)

(p look-fourth
   =goal>
      isa goal
      step look-fourth
   =visual-location>
      isa visual-location
==>
   +visual>
      ISA         visual-object
      screen-pos  =visual-location
   =goal>
      step encode-fourth)



(p encode-fourth
   =goal>
      isa goal
      step encode-fourth
   =visual>
      isa text
      value =value
   =visual-location>
      isa visual-location
      screen-x =x
   =imaginal>
      isa equation
      arg4 nil
==>
   =imaginal>
      arg4 =value
  +visual-location>
      isa visual-location
      value  "<->"
   =goal>
      step  left)

(spp encode-fourth :effort .15)



(p check-for-P
   =goal>
      isa goal
      step left
   =visual-location>
      isa visual-location
      screen-x =x
==>
!bind! =x1 (- =x 1)
!bind! =y (- =x 25)
   +visual-location>
     Isa visual-location
     screen-x (within =y =x1)
     attended nil
   =goal>
      step check-for-P)

(p encode-for-P
   =goal>
      isa goal
      step check-for-P
   =visual-location>
      isa visual-location
==>
   =goal>
      step encode-for-P
   +visual>
      ISA         visual-object
      screen-pos  =visual-location)

(p process-P
   =goal>
      isa goal
      step encode-for-P
   =visual>
      isa text
      value "p"
   =visual-location>
      isa visual-location
      screen-x =x
   =imaginal>
      isa equation
==>
   =imaginal>
      arg1 "p"
!bind! =x1 (- =x 1)
!bind! =y (- =x 25)
   +visual-location>
     Isa visual-location
     screen-x (within =y =x1)
     attended nil
=goal>
     step look-past-P)

(spp process-P :effort .15)

(p encode-fourth-left
   =goal>
      isa goal
      step encode-for-P
   =visual-location>
      isa visual-location
      screen-x =x
   =visual>
      isa text
      value =value
   -  value "p"
   =imaginal>
      isa equation
      arg2 nil
==>
   =imaginal>
      arg2 =value
+retrieval>
    isa invert
    operator arg
=goal>
    step invert-fourth)

(spp encode-fourth-left :effort .15)

(p invert-fourth
   =goal>
      isa goal
      step invert-fourth
   =visual-location>
      isa visual-location
      screen-x =x
   =imaginal>
      isa equation
      arg2 =value
   =retrieval>
      isa invert
      action copy
      arg fourth
==>
  =imaginal>
      arg4 =value
      arg2 nil
!bind! =x1 (- =x 1)
!bind! =y (- =x 25)
   +visual-location>
     Isa visual-location
     screen-x (within =y =x1)
     attended nil
   =goal>
      step look-third-left)

(spp invert-fourth :effort .15)

(p look-third-left
   =goal>
      isa goal
      step look-third-left
   =visual-location>
      isa visual-location
==>
   +visual>
      ISA         visual-object
      screen-pos  =visual-location
   =goal>
      step encode-third-left)

(p encode-third-left
   =goal>
      isa goal
      step encode-third-left
   =visual>
      isa text
      value =value
   =imaginal>
      isa equation
      op2 nil
==>
   =imaginal>
      op2 =value
+retrieval>
    isa invert
    operator operator
=goal>
    step invert-third)

(spp encode-third-left :effort .15)

(p copy-invert-third
   =goal>
      isa goal
      step invert-third
   =imaginal>
      isa equation
      op2 =value
   =retrieval>
      isa invert
      action copy-exchange
      arg third
==>
+retrieval>
    isa operator
    identity =value
=goal>
    step copy-exchange-third)

(p exchange-third
   =goal>
      isa goal
      step copy-exchange-third
   =retrieval>
      isa operator
      identity =old
      inverse =value
   =imaginal>
      isa equation
      op2 =old
==>
   =imaginal>
      op4 =value
      op2 nil
   =goal>
      step left)

(spp exchange-third :effort .15)

(p nothing-past-P
   =goal>
      isa goal
      step look-past-P
      
   =visual-location>
      isa error
==>
  -visual-location>
  =goal>
      step first
  +manual>
      ISA         press-key
      key         "1")

(p look-for-prefix
   =goal>
      isa goal
      step look-past-P
      
   =visual-location>
      isa visual-location
==>
   +visual>
      ISA         visual-object
      screen-pos  =visual-location
   =goal>
      step encode-prefix)


(p encode-prefix
   =goal>
      isa goal
      step encode-prefix
   =visual>
      isa text
      value =op
  =imaginal>
      isa equation
      op1 nil
==>
  =imaginal>
      op1 =op
  =goal>
     step transform-prefix
  +retrieval>
     isa invert
     operator =op)

(spp encode-prefix :effort .15)

(p null-transform
   =goal>
      isa goal
      step transform-prefix
   =retrieval>
      isa invert
      action null
==>
   -visual-location>
   =goal>
      step first
  +manual>
      ISA         press-key
      key         "1")

(p flip-transform
   =goal>
      isa goal
      step transform-prefix
   =retrieval>
      isa invert
      action flip
   =imaginal>
       isa equation
       op1 =val
==>
   =imaginal>
       op1 nil
   +retrieval>
      isa fact
      relation position
      arg1 arguments
    =goal>
       step retrieve-position)

(spp flip-transform :effort .15)

(p flip-position
   =goal>
      isa goal
      step retrieve-position
   =retrieval>
      isa fact
      arg2 even
   =imaginal>
      isa equation
      arg3 =arg3
      arg4 =arg4
==>
-visual-location>
=imaginal>
      arg4 =arg3
      arg3 =arg4
=goal>
      step first
  +manual>
      ISA         press-key
      key         "1")

(spp flip-position :effort .15)

(p exchange-transform
   =goal>
      isa goal
      step transform-prefix
   =retrieval>
      isa invert
      action exchange
   =visual>
      isa text
      value =op
==>
   +retrieval>
      isa operator
      identity =op
   =goal>
      step retrieving-inverse)


(p retrieve-inverse
   =goal>
      isa goal
      step retrieving-inverse
   =retrieval>
      isa operator
      identity =val1
      inverse =val2
   =imaginal>
       isa equation
       op1 =op
==>
   =imaginal>
       op1 nil
=goal>
   step exchange-first)

(spp retrieve-inverse :effort .15)

(p skip-first-exchange
   =goal>
      isa goal
      step exchange-first
   =retrieval>
      isa operator
      identity =val1
      inverse =val2
   =imaginal>
      isa equation
    - op3 =val1
    - op3 =val2
==>
   =goal>
     step exchange-third)

(p forward-first-exchange
   =goal>
      isa goal
      step exchange-first
   =retrieval>
      isa operator
      identity =val1
      inverse =val2
   =imaginal>
      isa equation
      op3 =val1
==>
   =imaginal> 
      op3 =val2
   =goal>
     step exchange-third)

(spp forward-first-exchange :effort .15)

(p reverse-first-exchange
   =goal>
      isa goal
      step exchange-first
   =retrieval>
      isa operator
      identity =val1
      inverse =val2
   =imaginal>
      isa equation
      op3 =val2
==>
   =imaginal> 
      op3 =val1
   =goal>
     step exchange-third)

(spp reverse-first-exchange :effort .15)

(p skip-second-exchange
   =goal>
      isa goal
      step exchange-third
   =retrieval>
      isa operator
      identity =val1
      inverse =val2
   =imaginal>
      isa equation
    - op4 =val1
    - op4 =val2
==>
  -visual-location>
  =goal>  
     step first
  +manual>
      ISA         press-key
      key         "1")

(p forward-second-exchange
   =goal>
      isa goal
      step exchange-third
   =retrieval>
      isa operator
      identity =val1
      inverse =val2
   =imaginal>
      isa equation
      op4 =val1
==>
  =imaginal>
      op4 =val2
  -visual-location>
  =goal>     
      step first
  +manual>
      ISA         press-key
      key         "1")

(spp forward-second-exchange :effort .15)

(p backward-second-exchange
   =goal>
      isa goal
      step exchange-third
   =retrieval>
      isa operator
      identity =val1
      inverse =val2
   =imaginal>
      isa equation
      op4 =val2
==>
  =imaginal>
      op4 =val1
  -visual-location>
  =goal>     
      step first
  +manual>
      ISA         press-key
      key         "1")

(spp backward-second-exchange :effort .15)

(p retrieve-first
   =goal>
      isa goal
      step first
   =imaginal>
      isa equation
      op3 =arg
   =visual-location>
     isa visual-location
==>
   -visual-location>
   =goal>
      step second
  +manual>
      ISA         press-key
      key         =arg)

(p retrieve-second 
   =goal>
      isa goal
      step second
   =imaginal>
      isa equation
      arg3 =arg
   =visual-location>
     isa visual-location
==>
   -visual-location>
   =goal>
      step third
  +manual>
      ISA         press-key
      key         =arg)

(p retrieve-third
   =goal>
      isa goal
      step third
   =imaginal>
      isa equation
      op4 =arg
   =visual-location>
     isa visual-location
==>
   -visual-location>
   =goal>
      step fourth
  +manual>
      ISA         press-key
      key         =arg)

(p retrieve-fourth
   =goal>
      isa goal
      step fourth
   =imaginal>
      isa equation
      arg4 =arg
   =visual-location>
     isa visual-location
==>
   -visual-location>
   =goal>
      step stop
  +manual>
      ISA         press-key
      key         =arg)