;;;;;;;;;;;;;;;;;;;;;;;;<pre><xmp>
;;;

;; To run the model, call the function named demo

;; This function takes two lists.
;; The first list is the values of A, B, and C
;; These values are restricted to integers in the range 0-9, inclusive.

;; The second list is T1, OPERATOR, T2, and T3, which specify
;; an equation of the form T1X OPERATOR T2 = T3

;; T1, T2, and T3 can appear as numbers (no substitution)
;; or as A, B, or C (require substitution)

;; The value of X (the solution) must be an integer in the range 0-9, inclusive.

;; Example:
;; (demo '(3 4 5) '(A - C 16)) creates the equation AX-C=16,
;; which solves to X=7


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



;;;; here's where the model starts


(defparameter *ret-exp* 8.18)
(defparameter *man-exp* 7.431)
(defparameter *imag-exp* 3.0542)
(defparameter *ret-scale* 0.691)
(defparameter *man-scale* 0.635)
(defparameter *imag-scale* 1.6475)

(defvar *v* nil)

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

(defparameter *ret-mag* (/ 0.933 (gammafn *ret-exp*)))
(defparameter *man-mag* (/ 3.826 (gammafn *man-exp*)))
(defparameter *imag-mag* (/ 3.4858 (gammafn *imag-exp*)))

(setf *actr-enabled-p* t)

(defparameter equation-set 
  '(((58 1 7) (1 + 0 5))
    ((58 1 7) (5 + 0 15))
    ((58 1 7) (1 + 3 8))
    ((58 1 7) (5 + 3 18))
    ((1 3 5) (a + 0 c))
    ((5 3 15) (a + 0 c))
    ((1 3 8) (a + 3 c))
    ((5 3 18) (a + 3 c))))

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

(defvar *a*)
(defvar *b*)
(defvar *c*)
(defvar *t1*)
(defvar *t2*)
(defvar *op*)
(defvar *t3*)

(defvar *WWW-interface*)

(setf  *WWW-interface* 
      '((:heading "fMRI Experiment 1" 2)
        (:heading "Parameters" 3)
        (:table)
        (:table)
        "scale, s (retrieval):" (:string :sy *ret-scale* 0.691)  (:new-row)
        "scale, s (imaginal):"  (:string :sy *imag-scale* 1.6475) (:new-row)
        "scale, s (manual):"    (:string :sy *man-scale* 0.635)  (:new-row)       
        "exponent, a (retrieval):" (:string :sy *ret-exp* 8.18)  (:new-row)
        "exponent, a (imaginal):"  (:string :sy *imag-exp* 3.0542) (:new-row)
        "exponent, a (manual):"    (:string :sy *man-exp* 7.431)   (:new-row)      
        "magnitude, M (retrieval):" (:string :sy *ret-mag* 0.933)  (:new-row)
        "magnitude, M (imaginal):"  (:string :sy *imag-mag* 3.4858) (:new-row)
        "magnitude, M (manual):"    (:string :sy *man-mag* 3.826)         
        
        (: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)
        "A: " (:string :sy *a* 3) (:new-row)
        "B: " (:string :sy *b* 4) (:new-row)
        "C: " (:string :sy *c* 5)  
        (:table-end)
        (:table)
        "first term:"  (:string :sy *t1* "a") (:new-row)
        "operator:"    (:string :sy *op* "-") (:new-row)
        "second term:" (:string :sy *t2* "c") (:new-row)
        "third term:"  (:string :sy *t3* 16)  
        (: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 terms specify the terms of the equation and can be either numbers or the symbols a, b or, c. The operator is the operator of the equation which can be either + or -, and the values for a, b, and c are the values the participant was to substitute for those symbols in the equation.  The default values above specify the equation \"aX - c = 16\".  Which is solved to X=7 when the a and c vaules are substituted in.  For the model to solve the equation the value of X found must be an integer in the range of 0-9, inclusive."
        (: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 (list *a* *b* *c*) (list *t1* *op* *t2* *t3*)) 
                                    )
                                  (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 demo (constants coefficients)
  (cond ((not (legaltest constants coefficients)) (format t "Invalid equation.  The solution for X must be an integer 0-9."))
        (t 
         (princ "The constant set was A = ") 
         (princ (first constants)) 
         (princ ", B = ")
         (princ (second constants)) 
         (princ ", C = ") 
         (princ (third constants)) 
         (terpri)
         (reset)
         (encode-it constants coefficients)
         (test-equation (format nil "~d ~d ~d" (first constants)
                          (second constants) (third constants))
                        (format nil "~d X ~a ~d = ~d" (first coefficients)
                          (second coefficients) 
                          (third coefficients)(fourth coefficients))))))


(defun legaltest (constants coefficients)
  (and (equal (length constants) 3)
       (equal (length coefficients) 4)
       (numberp (first constants))
       (numberp (second constants))
       (numberp (third constants))
       (or (numberp (first coefficients)) (member (first coefficients) '(a b c)))
       (member (second coefficients) '(+ -))
       (or (numberp (third coefficients)) (member (third coefficients) '(a b c)))
       (or (numberp (fourth coefficients)) (member (fourth coefficients) '(a b c)))
       (equal (type-of (solve-equation constants coefficients)) 'fixnum)
       (< (solve-equation constants coefficients) 10)
       (>= (solve-equation constants coefficients) 0)))

(defun solve-equation (constants coefficients)
  (setf coefficients (subst (first constants) 'a coefficients))
  (setf coefficients (subst (second constants) 'b coefficients))
  (setf coefficients (subst (third constants) 'c coefficients))
  (/ (funcall (if (equal (second coefficients) '+) #'- #'+) (fourth coefficients) (third coefficients)) (first coefficients))
)

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

(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 transform (start val)
  (push *time* *visual*))


(defun test-equation (set equation)
  (let (result start-time)
    (princ "The equation was ") (princ equation) (terpri)
  (setf *retrieved* nil *productions* nil *visual* 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))
  
  (add-visual-items-to-rpm-window *experiment-window* 
                                  (make-static-text-for-rpm-window *experiment-window* 
                                                                   :x 25
                                                                   :y 150
                                                                   :width 275
                                                                   :text set))
  (if *actr-enabled-p*
      (let ((goal (new-name "GOAL")))
        (pm-install-device *experiment-window*)
        (add-dm-fct (list (cons goal `(isa do-set constant a))))
        (goal-focus-fct  (list goal))
        (pm-proc-display ) 
        
        (pm-run 3 :full-time t)
        (lose-focus)
        (mod-focus term nil)
        (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 equation))
        
        (pm-proc-display)
        
        (setf start-time (pm-get-time))
        (pm-run 30)
        (generate *response* (/ (- *hold-time* start-time) 1000.0) (reverse *retrieved*)
                  (reverse *visual*)))
    
    (progn ;;; person
      (sleep 3)
      (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 equation))
       (setf start-time (pm-get-time))
      (setf *hold-time* nil)
      (while (null *hold-time*)
        (allow-event-manager *experiment-window*))
      (setf result (list *response* (/ (- *hold-time* start-time) 1000.0))))
      )

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

#+:(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)
  (if key
    (setf *response* (string key))
    (setf *response* key))
  (setf *hold-time* (pm-get-time)))



(defun generate (answer time retrieval imag)
  (let ((imaginal (mapcar #'(lambda (x) (list x .2)) imag))
        (res (list nil nil nil)))
    (format t "~%The model's answer is ~S and it was generated in ~6,3f seconds~%~%" answer time) 
    (format t " Scan  Time(sec) Imaginal  Retrieval   Motor~%")
    
    (dotimes (scan 14)
      (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 (list (list (+ 2.6 time) .4)) *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 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 encode-digits (n)
  (do ((count 0 (1+ count))
       (result nil (cons (list count 'isa 'symbol 
                               'string (prin1-to-string count)
                               'type 'integer) result)))
      ((equal count n) (eval `(add-dm ,@result)))))

(defun encode-it (constants equation)
  (let* ((subbed (subst (first constants) 'a
                        (subst (second constants) 'b
                               (subst (third constants) 'c equation))))
         (op (case (second equation) (+ '-) (- '+)))
         (part (apply op
                      (list (fourth subbed) (third subbed))))
         (end (/ part (first subbed))))
    (eval `(add-dm
            (fact1 isa arithmetic-fact arg1 ,(fourth subbed) arg2 ,(third subbed)
                   operator ,op result ,part)
            (fact2 isa arithmetic-fact arg1 ,part arg2 ,(first subbed)
                   operator / result ,end)))))

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

(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=\"22\">
        <PARAM name=\"ymax\" value=\"1.0\">
        <PARAM name=\"ymin\" value=\"0.0\">
        <PARAM name=\"longestline\" value=\"14\">
        <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;18.75;20.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;18.75;20.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;18.75;20.25;\"> ")

      (dotimes (i 3) 
        (format *standard-output* "<PARAM name=\"yval~s\" value=\"" i)
        (dotimes (j 14)
          (format *standard-output* "~6,3f;" (nth (- 13 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>")))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;</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 .6 :ga 0.00))

(setf *latency-fn* 'old-latency)
(pm-set-params :show-focus t)

(chunk-type do-set constant term)
(chunk-type solve-equation state)
(chunk-type symbol string type inverted-by)
(chunk-type arithmetic-fact arg1 arg2 operator result)
(chunk-type equation slope variable operator operand relation value)

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

(add-dm (a isa symbol string "a" type letter)
        (b isa symbol string "b" type letter)
        (c isa symbol string "c" type letter))

(sdp :base-level 2)
 
(add-dm 
        (+ isa symbol string "+" type operator inverted-by -)
        (* isa symbol string "*" type operator inverted-by /)
        (- isa symbol string "-" type operator inverted-by +)
        (/ isa symbol string "/" type operator inverted-by *)
        (f38 isa arithmetic-fact arg1 8 arg2 3 operator - result 5)
        (f318 isa arithmetic-fact arg1 18 arg2 3 operator - result 15)
        (f315 isa arithmetic-fact arg1 15 arg2 5 operator / result 3))


(P find-next-term-set
   =goal>
      ISA         do-set
      term        nil
==>
   +visual-location>
      ISA         visual-location
      screen-x    lowest
      attended    nil
   =goal>
      term        looking
)

(P attend-next-term-set
   =goal>
      ISA         do-set
      term        looking
   =visual-state>
      ISA         module-state
      modality    free
   =visual-location>
      ISA         visual-location
==>
   =goal>
      term        attending
   +visual>
      ISA         visual-object
      screen-pos  =visual-location
)

(P encode-term
   =goal>
      ISA         do-set
      term        attending
   =visual>
      ISA         text
      value       =term
      status      nil
==>
   +retrieval>
    isa SYMBOL
    string =term
   =goal>
      term        retrieving)

(P encode-a-term
   =goal>
      ISA         do-set
      term        retrieving
      constant        a
   =retrieval>
    isa SYMBOL
==>
   =goal>
      term =retrieval
   +goal>
      isa         do-set
      constant        b
)

(P encode-b-term
   =goal>
      ISA         do-set
      term        retrieving
      constant        b
   =retrieval>
    isa SYMBOL
==>
   =goal>
      term =retrieval
   +goal>
      isa         do-set
      constant        c
)

(P encode-c-term
   =goal>
      ISA         do-set
      term        retrieving
      constant        c
   =retrieval>
    isa SYMBOL
==>
   =goal>
      term =retrieval
   +goal>
      isa         solve-equation
      state       ready
 -visual-location>     
)

(P find-right-term
   =goal>
      ISA         solve-equation
      state       ready
   =visual-location>
      isa visual-location
==>
   +visual-location>
      ISA         visual-location
      screen-x    highest
      attended    nil
   -retrieval>
   +imaginal>
      isa equation
      variable X
      relation equals
   =goal>
      state        processing
)

(P translate-value
   =goal>
      ISA         solve-equation
   =retrieval>
      isa symbol
    type letter  
   =imaginal>
     isa equation
     value nil
==>
   =imaginal>
      value =retrieval
   +retrieval>
       isa do-set
       constant =retrieval
)

(P translate-operand
   =goal>
      ISA         solve-equation
   =retrieval>
      isa symbol
    type letter  
   =imaginal>
     isa equation
     value =
     operand nil
==>
   =imaginal>
      operand =retrieval
   +retrieval>
       isa do-set
       constant =retrieval
)

(P translate-slope
   =goal>
      ISA         solve-equation
   =retrieval>
      isa symbol
    type letter  
   =imaginal>
     isa equation
     operand =
     slope nil
==>
   =imaginal>
     slope =retrieval
   +retrieval>
       isa do-set
       constant =retrieval
)

(P process-value-letter
   =goal>
      ISA         solve-equation
   =retrieval>
      isa do-set
      term =val 
      constant =con
   =imaginal>
      isa equation
      value =con 
==>
   +visual-location>
      ISA         visual-location
      screen-x    (within 60 80)
      attended    nil
   =imaginal>
       value =val
 )

(P process-value-integer
   =goal>
      ISA         solve-equation
   =retrieval>
      isa symbol
    type Integer
   =imaginal>
      isa equation
      value nil
==>
   +visual-location>
      ISA         visual-location
      screen-x    (within 60 80)
      attended    nil
   =imaginal>
       value =retrieval
 )


   

(P process-0-integer
   =goal>
      ISA         solve-equation
   =retrieval>
      isa symbol
      string "0"
    type Integer 
   =imaginal>
      isa equation
      value =value
      operand nil
==>
   =imaginal>
      operator plus
      operand 0
   +visual-location>
      ISA         visual-location
      screen-x   (within 20 40)
      attended    nil
)

(P process-0-letter
   =goal>
      ISA         solve-equation
    =retrieval>
       isa DO-SET
       term 0   
       constant =con
   =imaginal>
       isa equation
       operand =con
==>
   =imaginal>
       operand 0
       operator +
   +visual-location>
      ISA         visual-location
      screen-x    (within 20 40)
      attended    nil
)

(P process-op1-letter
   =goal>
      ISA         solve-equation
    =retrieval>
       isa DO-SET
       term =val 
       constant =con
     - term 0
   =imaginal>
      isa equation
      value =
      operand =con
==>
  =imaginal>
      operand =retrieval
   +visual-location>
      ISA         visual-location
      screen-x    (within 50 70)
      attended    nil
)

(P process-op1-integer
   =goal>
      ISA         solve-equation
   =retrieval>
      isa symbol
    -  string "0"
    type Integer 
   =imaginal>
      isa equation
      value =
    - value =retrieval
      operand nil
==>
  =imaginal>
      operand =retrieval
   +visual-location>
      ISA         visual-location
      screen-x    (within 50 70)
      attended    nil
)

(P process-operator
   =goal>
      ISA         solve-equation
   =retrieval>
      isa symbol
      type operator
      inverted-by    =opposite
   =imaginal>
      isa equation
      operand =
      operator nil
==>
   =imaginal>
      operator =opposite 
   +retrieval>
      isa arithmetic-fact
      arg1 =val1
      arg2 =val2
      operator =opposite
)

(p finish-operation1
   =goal>
      ISA         solve-equation
   =retrieval>
      isa arithmetic-fact
      result    =val
   =imaginal>
      isa equation
      operator =op
      slope nil
    - value =val
==>
   =imaginal>
       operand 0
       value =val
   +visual-location>
      ISA         visual-location
      screen-x    (within 20 40)
      attended    nil)

(P process-1-integer
   =goal>
      ISA         solve-equation
   =retrieval>
      isa symbol
      string "1"
    type Integer     
   =imaginal>
      isa equation
      operand =val
      slope nil
==>
   =imaginal>
      slope 1
)

(P process-1-letter
   =goal>
      ISA         solve-equation
    =retrieval>
       isa DO-SET
       term 1
       constant =con
    =imaginal>
       isa equation
       slope =con
==>
    =imaginal>
       slope 1
)


(P process-op2-integer
   =goal>
      ISA         solve-equation
   =retrieval>
      isa symbol
    - string "1"
    type Integer  
   =imaginal>
      isa equation
      slope nil
      operand =
     - operand =retrieval
==>
  =imaginal>
      slope =retrieval
   +retrieval>
      isa arithmetic-fact
      arg1 =val1
      arg2 =retrieval
      operator /)

(P process-op2-letter
   =goal>
      ISA         solve-equation
    =retrieval>
       isa DO-SET
       term =val2
       constant =con
      - term 1
    =imaginal>
       isa equation
       slope =con
==>
   =imaginal>
       slope =val2
   +retrieval>
      isa arithmetic-fact
      arg1 =val1
      arg2 =val2
      operator /)

(p finish-operation2
   =goal>
      ISA         solve-equation
   =retrieval>
      isa arithmetic-fact
      result    =val
   =imaginal>
      isa equation
      slope =x
    - slope 1
==>
   =imaginal>
       slope 1
       value =val)

(p attend-next-term-equation
   =goal>
      ISA         solve-equation
   =visual-state>
      ISA         module-state
      modality    free
   =visual-location>
      ISA         visual-location
   =imaginal>
      isa equation
      slope nil
==>
   +visual>
      ISA         visual-object
      screen-pos  =visual-location
   -visual-location>
)



(P encode
   =goal>
      ISA         solve-equation
   =visual>
      ISA         text
      value       =term
      status      nil
==>
   -visual>
   +retrieval>
      isa          symbol
      string       =term
)

(p retrieve-key
   =goal>
    isa SOLVE-EQUATION
    state processing
   =imaginal>
    isa equation
    value =val
    operand 0
    slope 1
==>
  =goal>
     state waiting
  +retrieval> =val)

(p generate-answer
   =goal>
    isa SOLVE-EQUATION
    state waiting
   =retrieval>
    isa SYMBOL
    string =ans
   =imaginal>
    isa equation
    value =val
    operand 0
    slope 1
   =manual-state>
      ISA         module-state
      modality    free
==>
  =goal>
     state stop
  +manual>
      ISA         press-key
      key         =ans)