; the ACT-R that yields BOLD predictions must be loaded in LISP to run this model
; to run the model call (do-all n) where n is the number of iterations through the 10 problem digits.
; This produces the predicted BOLD response.   Note, as is the case in newer ACT-R, the production activity is treated
; as 50 msec periods rather than point activity as described in the paper.   One can get the numbers for the paper by basically 
; multiplying by 20.   All these numbers have to be mutliplied by the magnitude numbers given in the paper to get the predictions
; displayed in that paper.  Currently, this requires loading bold.lisp which is the extras folder of the ACT-R release.   
; Perhaps at some time this will be part of the standard ACT-R simulation program.



(defvar *goal*)
(defvar *results*)
(defvar *number*)
(defvar *ready-flag*)
(defvar *position*)
(defparameter *array* (make-array (list 1 10)))
(defparameter *t* -0.5)
(defparameter *a* .05)
(defparameter *max-f* 4)
(defparameter *count* 0)
(defvar *failure-flag*)
(defvar *break*)
(defvar *times*)
(defvar *target*)
(defvar *up-times*)
(defparameter *min* .1)
(defvar *macc*)
(defvar *mcaudate*)
(defvar *mparietal*)
(defvar *mvisual*)
(defvar *mmotor*)
(defvar *mprefrontal*)
(defvar *monset-regions*)
(defvar *t-array*)
(defvar *mega-times*)
(defparameter *acc* (make-list 82 :initial-element 0))
(defparameter *caudate* (make-list 82 :initial-element 0))
(defparameter *parietal* (make-list 82 :initial-element 0))
(defparameter *visual* (make-list 82 :initial-element 0))
(defparameter *motor* (make-list 82 :initial-element 0))
(defparameter *prefrontal* (make-list 82 :initial-element 0))
(defparameter *onset-regions* (make-list 82 :initial-element 0))


(defun output-bold (a b c d e f g) 
  (princ "     ACC  Caudate  Pariet Visual   Motor  Prefron  Onset")
   (terpri)
   (print-n 0 0 0 0 0 0 0)
   (mapcar 'print-n a b c d e f g))

(defun print-n (a b c d e f g)
  (princ (format nil "~8,3F~8,3F~8,3F~8,3F~8,3F~8,3F~8,3F" a b c d e f g)) (terpri))

(defun template (number) (if (> number 69) (make-list 85 :initial-element 0) (make-list 82 :initial-element 0) ))

(defun extract-lengths ()
  (do ((temp *results* (cdr temp))
       (result nil (cons (ceiling (/ (caar temp) 1500)) result)))
      ((null temp) 
       (mapcar '- result (cons 1 result)))))

(defun average-bold (n)
  (setf *acc* (mapcar #'(lambda (x) (/ x n)) *acc*))
  (setf *caudate*  (mapcar #'(lambda (x) (/ x n)) *caudate*))
  (setf *parietal*  (mapcar #'(lambda (x) (/ x n)) *parietal*))
  (setf *visual*  (mapcar #'(lambda (x) (/ x n)) *visual*))
  (setf *motor*  (mapcar #'(lambda (x) (/ x n)) *motor*))
  (setf *prefrontal* (mapcar #'(lambda (x) (/ x n)) *prefrontal*))
  (setf *onset-regions*  (mapcar #'(lambda (x) (/ x n)) *onset-regions*)))

(defun average-bold1 (n lis)
  (mapcar #'(lambda (x) (/ x n)) lis))

(defun accumulate-bold ()
  (do ((temp (append (mapcar 'cdr (no-output (predict-bold-response))) (LIST (onset-predict))) (cdr temp))
       (regions '(*visual* *caudate* *acc*   *prefrontal* *parietal*  *motor* *onset-regions*) (cdr regions)))
       ((null temp) nil)
     (set (car regions) (update-bold-fincham (car temp) (eval (car regions)) (append (extract-lengths) '(15))
                                       (if (> (length (eval (car regions))) 82) '(30 1 3 3 12 1 14 1 4 1 15) '(30 1 3 12 1 14 1 4 1 15))))))

(defun update-bold-fincham (data set data-lengths set-lengths)
  (do ((temp-dl data-lengths (cdr temp-dl))
       (temp-sl set-lengths (cdr temp-sl))
       (temp-data (mapcar #'(lambda (x) (- x (car data))) (cdr data)) (nthcdr (car temp-dl) temp-data))
       (temp-set set (nthcdr (car temp-sl) temp-set))
       (result nil (append result (split-fincham (first-n (car temp-dl) temp-data)
                                                 (first-n (car temp-sl) temp-set)))))
      ((null temp-dl) result)))

(defun first-n (n lis) (reverse (nthcdr (- (length lis) n) (reverse lis))))

(defun split-fincham (data set)
  (let ((front (first-half data))
        (back (reverse (second-half data)) ))
  (do ((data1 front (cdr data1))
        (data2 back  (cdr data2) )
        (set1 (first-half set) (cdr set1))
        (set2 (reverse (second-half set)) (cdr set2))
        (result1 nil (cons (+ (or (car data1) (car (last front))) (car set1)) result1))
        (result2 nil (if set2 (cons (+ (or (car data2) (car (last back)) (car data)) (car set2)) result2) result2)))
      ((null set1) (append (reverse result1) result2)))))


(defun second-half (lis) (nthcdr (ceiling (/ (length lis) 2)) lis))

(defun first-half (lis) (reverse (nthcdr (floor(/ (length lis) 2)) (reverse lis))))


(defun onset-predict () (bold_point-predict (mapcar #'(lambda (x) (+ 1.5 (/ x 1000.0)))
                                                 (append '(0 1500) (mapcar 'car (reverse *results*)) (list (+ 1500 (caar *results*)))))
                                            (get-module bold) 0 (mp-time)))


(defparameter *ans* (make-array '(9 11)))
(defparameter *data* (make-array '(9 11) :initial-contents
                                 '((16	28	39	48	28	19	27	28	12	20	13)
                                   (246	0	0	1	0	0	0	0	0	0	0)
                                   (222	12	3	1	3	0	4	4	3	0	0)
                                   (159	47	25	15	10	8	15	8	5	1	0)
                                   (251	1	0	0	1	0	0	0	1	0	0)
                                   (46	82	30	18	18	9	12	8	3	3	0)
                                   (232	1	0	1	0	0	1	0	0	0	0)
                                   (186	22	8	7	2	1	1	0	2	0	0)
                                   (233	0	0	0	0	0	0	0	0	0	0))))


(defun tr-time (lis) 
  (do ((temp lis (cdr temp))
       (result nil (cons (* 1.5 (car temp)) result)))
      ((null temp) (reverse result))))

(defparameter *bounds* (make-array '(10 12) :initial-contents 
                                   (mapcar 'tr-time'((0 5 10 15 20 25 30 40 50 60 80 1000)
                                     (0 5 10 15 20 25 30 40 50 60 80 1000)
                                     (0 5 10 15 20 25 30 40 50 60 80 1000)
                                     (0 5 10 15 20 25 30 40 50 60 80 1000)
                                     (0 5 10 15 20 25 30 40 50 60 80 1000)
                                     (0 5 10 15 20 25 30 40 50 60 80 1000)
                                     (0 5 10 15 20 25 30 40 50 60 80 1000)
                                     (0 5 10 15 20 25 30 40 50 60 80 1000)
                                     (0 5 10 15 20 25 30 40 50 60 80 1000)
                                     (0 5 10 15 20 25 30 40 50 60 80 1000)))))
                        

(defun exp-time () (+ 3 (/ (log (random 1.0)) (- *a*))))

(defun do-all (n)
  (setf *macc* (template 67) *mcaudate* (template 67) *mparietal* (template 67) 
        *mvisual* (template 67) *mmotor* (template 67) *mprefrontal* (template 67) 
        *monset-regions* (template 67) )
  (setf *t-array* (make-array (list 10 11)))
  (setf *mega-times* nil)
  (do ((temp '(59 61 62 63 64 65 66 67 70 71) (cdr temp)))
      ((null temp) (setf *mega-times* (reverse *mega-times*))
       (output-bold (m-average *macc*) (m-average *mcaudate*) (m-average *mparietal*) (m-average *mvisual*)
              (m-average *mmotor*) (m-average *mprefrontal*) (m-average *monset-regions*) )
       *t-array*)
    (run-n (car temp) n)
    (setf *mega-times* (cons *times* *mega-times*))
    (let ((array (freq n *bounds* (> (car temp) 69))))
      (do ((i 0  (1+ i)))
          ((= i 10) nil)
        (do ((j 0 (1+ j)))
            ((= j 11) nil)
          (setf (aref *t-array* i j) (+ (aref *t-array* i j) (aref array i j))))))
      (setf *macc* (mega-update *acc* *macc*))
      (setf *mcaudate* (mega-update *caudate* *mcaudate*))
      (setf *mparietal* (mega-update *parietal* *mparietal*))
      (setf *mvisual* (mega-update *visual* *mvisual*))
      (setf *mmotor* (mega-update *motor* *mmotor*))
      (setf *mprefrontal* (mega-update *prefrontal* *mprefrontal*))
      (setf *monset-regions* (mega-update *onset-regions* *monset-regions*))))


(defun m-average (lis)
  (mapcar #'(lambda (x) (/ x 10)) lis))

(defun compress (lis)
  (let ((front (first-n 31 lis))
        (middle (first-n 6 (nthcdr 31 lis)))
        (end (nthcdr 37 lis)))
    (append front (list (/ (+ (first middle) (fourth middle)) 2)
                        (/ (+ (second middle) (fifth middle)) 2)
                        (/ (+ (third middle) (sixth middle)) 2)) end)))

(defun mega-update (result mega)
  (if (> (length result) 82) (setf result (compress result)))
  (mapcar '+ mega result))


(defun run-n (number n)
  (setf *array* (make-array (list n (if (> number 69) 11 10))))
  (setf *times* '(0 0 0 0 0 0 0 0 0 0))
  (setf *acc* (template number) *caudate* (template number) *parietal* (template number) 
        *visual* (template number) *motor* (template number) *prefrontal* (template number) 
        *onset-regions* (template number) )
  (do ((i 0 (1+ i)))
      ((= i n) 
      (average-bold n)
       )
    (setf *count* i)
    (present-trial number)
    (cond ((equal (do-math *results*) number)
      (setf (aref *array* i (if (> number 69) 10 9)) (/ (caar *results*) 1000.0))
      (setf *times* (mapcar '+ *times* (mapcar 'car *results*)))
      (accumulate-bold))
          (t (print i)  (setf i (1- i))))))


(defun sq (x) (* x x))

(defun freq (n bounds long)
    (setf *ans* (make-array (list 10 11)))
  (do ((j 0  (1+ j)))
      ((= j (if long 11 10)) *ans*)
  (do ((i 0 (1+ i)))
      ((= i n) nil)
    (do ((k 0 (1+ k)))
        ((= k 12) nil)
      (let ((jj (if (and long (> j 2)) (1- j) j))) 
      (if  (and (> (aref *array* i j) (aref bounds jj k))
              (<= (aref *array* i j)  (aref bounds jj (1+ k)))) (return (incf (aref *ans* jj k)))))))))


(defun present-trial (number)
  (let ((goal (new-name-fct 'goal))
         (window (open-exp-window "Arithmetic Experiment" :visible nil)))
    (setf *results* nil)(setf *ready-flag* t) (setf *position* 0)  
    (setf *failure-flag* nil *up-times* nil *break* -1) 
    (setf *number* (second (assoc number '((59 "59") (61 "61") (62 "62") (63 "63") (64 "64")
                                           (65 "65") (66 "66") (67 "67") (70 "70") (71 "71")))))
    (setf *goal* (read-from-string *number*))
    (setf *target* number)
    (reset)  
    (install-device window)     
    (eval `(add-dm (,goal isa goal step get-ready)))     
    (eval `(goal-focus ,goal))
    (add-text-to-exp-window :text "*" :x 25 :y 100 :width 25)
    (proc-display :clear t) 
    (schedule-event 1.5 'present-problem)
    (schedule-event (+ 1.5 (exp-time))  'set-failure)
    (run 1000)
    (run-full-time (- 22.5 (- (/ (get-time) 1000.0) (ready (caar *results*)))))
    *results*))

(defun present-problem ()
  (clear-exp-window)
      (add-text-to-exp-window :text *number* :x 25 :y 150 :width 25)
    (proc-display :clear t) )

(defun set-failure () (setf *failure-flag* t))

(defun image-failure () (and *failure-flag* (< (length *results*) 9)))

(defun finish-up ()
  (do ((temp (meta-p-events (current-mp)) (cdr temp)))
      ((null temp) 
            (schedule-event  (+ 1.5 (ready (get-time))) 'rest-period))
    (if (eq (evt-action (car temp)) 'set-failure) (delete-event (car temp)))))
      
(defun failure ()
  (clear-buffer 'imaginal)
   (setf *failure-flag* nil)
  (schedule-event (+ (/ (get-time) 1000) (exp-time))  'set-failure))

(defun done-test (image)
  (= (+ (get-image-value image) (get-parent-value image)) *target*))


(defun left-ok (image1 image2)
  (> (+ (get-left-value image2) (get-parent-value image1)) (do-math *results*)))

(defun right-ok (image1 image2)
  (> (+ (get-image-value image2) (get-parent-value image1)) (do-math *results*)))

(defun get-left-value (image)
  (let ((tens (chunk-slot-value-fct image 'left-tens))
         (ones (chunk-slot-value-fct image 'left-ones)))
    (+  (* 10 (get-number tens)) (get-number ones))))

(defun get-right-value (image)
  (let ((tens (chunk-slot-value-fct image 'right-tens))
         (ones (chunk-slot-value-fct image 'right-ones)))
    (+  (* 10 (get-number tens)) (get-number ones))))

(defun get-parent-value (image)
  (let ((left (chunk-slot-value-fct image 'left))
         (right (chunk-slot-value-fct image 'right)))
    (cond ((or (eq left 'top) (eq right 'top)) 0)
          (left (get-parent-value left))
          (right (+ (get-left-value right) (get-parent-value right)))
          (t 0))))

(defun get-image-value (image)
  (let* ((number (chunk-slot-value-fct image 'number))
         (tens (chunk-slot-value-fct number 'tens))
         (ones (chunk-slot-value-fct number 'ones)))
    (+ (* 10 (get-number tens)) (get-number ones))))

(defun get-number (integer)
  (case integer
    (#\0 0)
    (#\1 1)
    (#\2 2)
    (#\3 3)
    (#\4 4)
    (#\5 5)
    (#\6 6)
    (#\7 7)
    (#\8 8)
    (#\9 9) 
    (zero 0)
    (one 1)
    (two 2)
    (three 3)
    (four 4)
    (five 5)
    (six 6)
    (seven 7)
    (eight 8)
    (nine 9)))

(defun do-math (lis) (apply '+ (mapcar 'get-number (mapcar 'second lis))))

(defun ready (time) 
   (* 1.5 (ceiling (/ time 1500))))

(defmethod rpm-window-key-event-handler ((win rpm-window) key)
    (schedule-event  (ready (get-time)) 'enable)
    (setf *ready-flag* nil) 
    (setf key (case key
                (#\j #\6)
                (#\k #\7)
                (#\l #\8)
                (#\; #\9)
                (#\Space #\5)))
    (add-text-to-exp-window :text (string key) :x (+ 75 (* 25 *position*)) :y 200 :width 25)    
    (proc-display :clear t) 
    (incf *position*)
    (if (null *results*) 
      (setf (aref *array* *count* 0) (- (/ (get-time) 1000.0) 1.5))
      (setf (aref *array* *count* (length *results*)) (- (/ (get-time) 1000) (bound (/ (caar *results*) 1000)) )))
    (push (list (get-time) key)  *results*)
    (if (= (do-math *results*) *goal*) (finish-up)))

(defun bound (time) (* 1.5 (ceiling (/ time 1.5))))

(defun enable ()  (setf *ready-flag* t))

(defun rest-period ()
  (clear-exp-window)    (add-text-to-exp-window :text "*" :x 25 :y 100 :width 25)
    (proc-display :clear t) )

(defun less-val (a b) (member (chunk-slot-value-fct b 'ones) 
                              (member (chunk-slot-value-fct a 'ones)
                                      '(zero one two three four five six seven eight nine))))

(defvar *timer*)

(clear-all)
(define-model yulin

(eval `(sgp :esc t :egs 0.1  :ol t :rt -.5 :bll .5 :ul nil  :epl nil :lf 1.0  :v nil :optimize-visual nil
            :model-warnings nil :do-not-harvest imaginal  :MODEL-WARNINGS nil :MOTOR-INITIATION-TIME .2
            ::save-buffer-trace t :traced-buffers (visual production goal retrieval imaginal manual)
            :ga 0 :ans .25 :trace-detail low :alpha .2))


(chunk-type number tens ones half remainder key punch)
(chunk-type image number left-tens left-ones left right right-tens right-ones slot)
(chunk-type goal step step1)
(chunk-type instructions)
(chunk-type addition-fact arg1 arg2 sum)

(setf *timer* (random 1.0))

    (eval `(sgp :lf ,(+ *timer* (random 0.5)) :rt ,*t* 
            :IMAGINAL-DELAY ,(+ *timer* (random 0.5)) ))


(add-dm (top isa image)   
        (instructions isa instructions)
        (image17 isa image number seventeen left-tens zero left-ones nine right-tens zero right-ones eight)
        (image16 isa image number sixteen left-tens zero left-ones nine right-tens zero right-ones seven)
        (image15 isa image number fifteen left-tens zero left-ones eight right-tens zero right-ones seven)
        (image14 isa image number fourteen left-tens zero left-ones eight right-tens zero right-ones six)
        (image13 isa image number thirteen left-tens zero left-ones seven right-tens zero right-ones six)
        (image12 isa image number twelve left-tens zero left-ones seven right-tens zero right-ones five)
        (image11 isa image number eleven left-tens zero left-ones six right-tens zero right-ones five)
        (zero isa number tens zero ones zero half zero remainder zero key "0")
        (one isa number tens zero ones one half zero remainder one key "1")
        (two isa number tens zero ones two half one remainder zero key "2")
        (three isa number tens zero ones three half one remainder one key "3")
        (four isa number tens zero ones four half two remainder zero key "4")
        (five isa number tens zero ones five half two remainder one key "5" punch thumb)
        (six isa number tens zero ones six half three remainder zero key "6" punch index)
        (seven isa number tens zero ones seven half three remainder one key "7" punch middle)
        (eight isa number tens zero ones eight half four remainder zero key "8" punch ring)
        (nine isa number tens zero ones nine half four remainder one key "9" punch pinkie)
        (ten isa number tens one ones zero half five remainder zero)
        (eleven isa number tens one ones one half five remainder one)
        (twelve isa number tens one ones two half six remainder zero)
        (thirteen isa number tens one ones three half six remainder one)
        (fourteen isa number tens one ones four half seven remainder zero)
        (fifteen isa number tens one ones five half seven remainder one)
        (sixteen isa number tens one ones six half eight remainder zero)
        (seventeen isa number tens one ones seven half eight remainder one)
        (eightteen isa number tens one ones eight half nine remainder zero)
        (nineteen isa number tens one ones nine half nine remainder one)
        (n20 isa number tens two ones zero)
        (n21 isa number tens two ones one)
        (n22 isa number tens two ones two)
        (n23 isa number tens two ones three)
        (n24 isa number tens two ones four)
        (n25 isa number tens two ones five)
        (n26 isa number tens two ones six)
        (n27 isa number tens two ones seven)
        (n28 isa number tens two ones eight)
        (n29 isa number tens two ones nine)
        (n30 isa number tens three ones zero)
        (n31 isa number tens three ones one)
        (n32 isa number tens three ones two)
        (n33 isa number tens three ones three)
        (n34 isa number tens three ones four)
        (n35 isa number tens three ones five)
        (n36 isa number tens three ones six)
        (n37 isa number tens three ones seven)
        (n38 isa number tens three ones eight)
        (n39 isa number tens three ones nine)
        (n40 isa number tens four ones zero)
        (n41 isa number tens four ones one)
        (n42 isa number tens four ones two)
        (n43 isa number tens four ones three)
        (n44 isa number tens four ones four)
        (n45 isa number tens four ones five)
        (n46 isa number tens four ones six)
        (n47 isa number tens four ones seven)
        (n48 isa number tens four ones eight)
        (n49 isa number tens four ones nine)
        (n50 isa number tens five ones zero)
        (n51 isa number tens five ones one)
        (n52 isa number tens five ones two)
        (n53 isa number tens five ones three)
        (n54 isa number tens five ones four)
        (n55 isa number tens five ones five)
        (n56 isa number tens five ones six)
        (n57 isa number tens five ones seven)
        (n58 isa number tens five ones eight)
        (n59 isa number tens five ones nine)
        (n60 isa number tens six ones zero)
        (n61 isa number tens six ones one)
        (n62 isa number tens six ones two)
        (n63 isa number tens six ones three)
        (n64 isa number tens six ones four)
        (n65 isa number tens six ones five)
        (n66 isa number tens six ones six)
        (n67 isa number tens six ones seven)
        (n68 isa number tens six ones eight)
        (n69 isa number tens six ones nine)
        (n70 isa number tens seven ones zero)
        (n71 isa number tens seven ones one)
        (n72 isa number tens seven ones two)
        (n73 isa number tens seven ones three)
        (n74 isa number tens seven ones four)
        (n75 isa number tens seven ones five)
        (n76 isa number tens seven ones six)
        (n77 isa number tens seven ones seven)
        (n78 isa number tens seven ones eight)
        (n79 isa number tens seven ones nine)
        (n80 isa number tens eight ones zero)
        (n81 isa number tens eight ones one)
        (n82 isa number tens eight ones two)
        (n83 isa number tens eight ones three)
        (n84 isa number tens eight ones four)
        (n85 isa number tens eight ones five)
        (n86 isa number tens eight ones six)
        (n87 isa number tens eight ones seven)
        (n88 isa number tens eight ones eight)
        (n89 isa number tens eight ones nine)
        (n90 isa number tens nine ones zero)
        (n91 isa number tens nine ones one)
        (n92 isa number tens nine ones two)
        (n93 isa number tens nine ones three)
        (n94 isa number tens nine ones four)
        (n95 isa number tens nine ones five)
        (n96 isa number tens nine ones six)
        (n97 isa number tens nine ones seven)
        (n98 isa number tens nine ones eight)
        (n99 isa number tens nine ones nine)
        (thirty-nine isa number tens three ones nine)
        (sixty-seven isa number tens six ones seven)
        (fact00 isa addition-fact arg1 zero arg2 zero sum zero)
        (fact01 isa addition-fact arg1 zero arg2 one sum one)
        (fact02 isa addition-fact arg1 zero arg2 two sum two)
        (fact03 isa addition-fact arg1 zero arg2 three sum three)
        (fact04 isa addition-fact arg1 zero arg2 four sum four)
        (fact05 isa addition-fact arg1 zero arg2 five sum five)
        (fact06 isa addition-fact arg1 zero arg2 six sum six)
        (fact07 isa addition-fact arg1 zero arg2 seven sum seven)
        (fact08 isa addition-fact arg1 zero arg2 eight sum eight)
        (fact09 isa addition-fact arg1 zero arg2 nine sum nine)
        (fact10 isa addition-fact arg1 one arg2 zero sum one)
        (fact11 isa addition-fact arg1 one arg2 one sum two)
        (fact12 isa addition-fact arg1 one arg2 two sum three)
        (fact13 isa addition-fact arg1 one arg2 three sum four)
        (fact14 isa addition-fact arg1 one arg2 four sum five)
        (fact15 isa addition-fact arg1 one arg2 five sum six)
        (fact16 isa addition-fact arg1 one arg2 six sum seven)
        (fact17 isa addition-fact arg1 one arg2 seven sum eight)
        (fact18 isa addition-fact arg1 one arg2 eight sum nine)
        (fact19 isa addition-fact arg1 one arg2 nine sum ten)
        (fact20 isa addition-fact arg1 two arg2 zero sum two)
        (fact21 isa addition-fact arg1 two arg2 one sum three)
        (fact22 isa addition-fact arg1 two arg2 two sum four)
        (fact23 isa addition-fact arg1 two arg2 three sum five)
        (fact24 isa addition-fact arg1 two arg2 four sum six)
        (fact25 isa addition-fact arg1 two arg2 five sum seven)
        (fact26 isa addition-fact arg1 two arg2 six sum eight)
        (fact27 isa addition-fact arg1 two arg2 seven sum nine)
        (fact28 isa addition-fact arg1 two arg2 eight sum ten)
        (fact29 isa addition-fact arg1 two arg2 nine sum eleven)
        (fact30 isa addition-fact arg1 three arg2 zero sum three)
        (fact31 isa addition-fact arg1 three arg2 one sum four)
        (fact32 isa addition-fact arg1 three arg2 two sum five)
        (fact33 isa addition-fact arg1 three arg2 three sum six)
        (fact34 isa addition-fact arg1 three arg2 four sum seven)
        (fact35 isa addition-fact arg1 three arg2 five sum eight)
        (fact36 isa addition-fact arg1 three arg2 six sum nine)
        (fact37 isa addition-fact arg1 three arg2 seven sum ten)
        (fact38 isa addition-fact arg1 three arg2 eight sum eleven)
        (fact39 isa addition-fact arg1 three arg2 nine sum twelve)
        (fact40 isa addition-fact arg1 four arg2 zero sum four)
        (fact41 isa addition-fact arg1 four arg2 one sum five)
        (fact42 isa addition-fact arg1 four arg2 two sum six)
        (fact43 isa addition-fact arg1 four arg2 three sum seven)
        (fact44 isa addition-fact arg1 four arg2 four sum eight)
        (fact45 isa addition-fact arg1 four arg2 five sum nine)
        (fact46 isa addition-fact arg1 four arg2 six sum ten)
        (fact47 isa addition-fact arg1 four arg2 seven sum eleven)
        (fact48 isa addition-fact arg1 four arg2 eight sum twelve)
        (fact49 isa addition-fact arg1 four arg2 nine sum thirteen)
        (fact50 isa addition-fact arg1 five arg2 zero sum five)
        (fact51 isa addition-fact arg1 five arg2 one sum six)
        (fact52 isa addition-fact arg1 five arg2 two sum seven)
        (fact53 isa addition-fact arg1 five arg2 three sum eight)
        (fact54 isa addition-fact arg1 five arg2 four sum nine)
        (fact55 isa addition-fact arg1 five arg2 five sum ten)
        (fact56 isa addition-fact arg1 five arg2 six sum eleven)
        (fact57 isa addition-fact arg1 five arg2 seven sum twelve)
        (fact58 isa addition-fact arg1 five arg2 eight sum thirteen)
        (fact59 isa addition-fact arg1 five arg2 nine sum fourteen)
        (fact60 isa addition-fact arg1 six arg2 zero sum six)
        (fact61 isa addition-fact arg1 six arg2 one sum seven)
        (fact62 isa addition-fact arg1 six arg2 two sum eight)
        (fact63 isa addition-fact arg1 six arg2 three sum nine)
        (fact64 isa addition-fact arg1 six arg2 four sum ten)
        (fact65 isa addition-fact arg1 six arg2 five sum eleven)
        (fact66 isa addition-fact arg1 six arg2 six sum twelve)
        (fact67 isa addition-fact arg1 six arg2 seven sum thirteen)
        (fact68 isa addition-fact arg1 six arg2 eight sum fourteen)
        (fact69 isa addition-fact arg1 six arg2 nine sum fifteen)
        (fact70 isa addition-fact arg1 seven arg2 zero sum seven)
        (fact71 isa addition-fact arg1 seven arg2 one sum eight)
        (fact72 isa addition-fact arg1 seven arg2 two sum nine)
        (fact73 isa addition-fact arg1 seven arg2 three sum ten)
        (fact74 isa addition-fact arg1 seven arg2 four sum eleven)
        (fact75 isa addition-fact arg1 seven arg2 five sum twelve)
        (fact76 isa addition-fact arg1 seven arg2 six sum thirteen)
        (fact77 isa addition-fact arg1 seven arg2 seven sum fourteen)
        (fact78 isa addition-fact arg1 seven arg2 eight sum fifteen)
        (fact79 isa addition-fact arg1 seven arg2 nine sum sixteen)
        (fact80 isa addition-fact arg1 eight arg2 zero sum eight)
        (fact81 isa addition-fact arg1 eight arg2 one sum nine)
        (fact82 isa addition-fact arg1 eight arg2 two sum ten)
        (fact83 isa addition-fact arg1 eight arg2 three sum eleven)
        (fact84 isa addition-fact arg1 eight arg2 four sum twelve)
        (fact85 isa addition-fact arg1 eight arg2 five sum thirteen)
        (fact86 isa addition-fact arg1 eight arg2 six sum fourteen)
        (fact87 isa addition-fact arg1 eight arg2 seven sum fifteen)
        (fact88 isa addition-fact arg1 eight arg2 eight sum sixteen)
        (fact89 isa addition-fact arg1 eight arg2 nine sum seventeen)
        (fact90 isa addition-fact arg1 nine arg2 zero sum nine)
        (fact91 isa addition-fact arg1 nine arg2 one sum ten)
        (fact92 isa addition-fact arg1 nine arg2 two sum eleven)
        (fact93 isa addition-fact arg1 nine arg2 three sum twelve)
        (fact94 isa addition-fact arg1 nine arg2 four sum thirteen)
        (fact95 isa addition-fact arg1 nine arg2 five sum fourteen)
        (fact96 isa addition-fact arg1 nine arg2 six sum fifteen)
        (fact97 isa addition-fact arg1 nine arg2 seven sum sixteen)
        (fact98 isa addition-fact arg1 nine arg2 eight sum seventeen)
        (fact99 isa addition-fact arg1 nine arg2 nine sum eightteen))

(sdp :references 2000 :creation-time -1000000)
(sdp instructions :references 60 :creation-time -1800)

(p encode-location
  =visual-location>
     isa visual-location
  ?visual>
     state free
==>
   +visual> 
      ISA         move-attention
      screen-pos =visual-location)

(p rest
   =goal>
      isa goal
      step done
  =visual>
      isa visual-object
      value "*"
   =imaginal>
      isa image
==>
   +imaginal>
       slot "*"
  +goal>
     step rest)

(p get-set
   =goal>
      isa goal
      step get-ready
  =visual>
      isa visual-object
      value "*"
==>
  +imaginal>
      isa image
      slot "*"
  +retrieval>
    isa instructions
  +goal>
     step start )


(p encode-tens
    =goal>
      isa goal
      step start
  =visual>
     isa visual-object
     value =val
   - value "*"
  =retrieval>
      isa instructions
  ?visual>
     state free
   ?imaginal>
      state free
==>
  +visual-location>
       ISA         visual-location
      > screen-x 30
      < screen-x 50
  +retrieval>
        isa number
        key =val)

(p encode-ones
    =goal>
      isa goal
      step start
  =visual>
     isa visual-object
     value =val
  =retrieval>
     isa number
  ?visual>
     state free
   ?imaginal>
      state free
==>
  +retrieval>
        isa number
        key =val
   +imaginal>
        isa image
        left top
        right-tens =retrieval)

(p retrieve-number
    =goal>
      isa goal
      step start
  =imaginal>
     isa image    
      right-tens =tens
  =retrieval>
     isa number
   ?imaginal>
      state free
==>
  +retrieval>
        isa number
        tens =tens
        ones =retrieval
   +goal>
        step encode-left
  +imaginal>
        right-ones =retrieval)

(p encode-number
    =goal>
      isa goal
      step encode-left
  =imaginal>
     isa image
      number nil
      right-tens =tens
   -  right-tens one
  =retrieval>
     isa number
   ?imaginal>
      state free
==>
  +retrieval> =tens
  +imaginal>
        number =retrieval)

(p encode-teen
    =goal>
      isa goal
      step encode-left
  =imaginal>
     isa image
      right-tens one
  =retrieval>
     isa number
   ?imaginal>
      state free
==>
  +retrieval> 
      isa image
      number =retrieval
      left nil
      right nil
  +imaginal>
        number =retrieval)

(p decompose-onesa
   =goal>
      isa goal
      step encode-left
  =imaginal>
     isa image
      number =num
      left-tens nil
      right-ones =ones
   =retrieval>
      isa number
      half =val
      remainder zero
   ?imaginal>
      state free
==>
   +retrieval> =ones
  +imaginal>
      left-tens =val)

(p decompose-onesb
   =goal>
      isa goal
      step encode-left
  =imaginal>
     isa image
      number =num
      left-tens nil
      right-ones =ones
   =retrieval>
      isa number
      half =val
      remainder one
   ?imaginal>
      state free
==>
   +retrieval> 
      isa number
      tens one
      ones =ones
    +imaginal>
      left-tens =val)

(p add-tens
   =goal>
      isa goal
      step encode-left
  =imaginal>
     isa image
      left-ones nil
      left-tens =x
      right-tens =tens
   =retrieval>
      isa number
      half =val
   ?imaginal>
      state free
==>
    +retrieval>
       isa addition-fact
       arg1 =tens
       arg2 =val)

(p check-sum
   =goal>
      isa goal
      step encode-left
  =imaginal>
     isa image
      left-ones nil
      left-tens =x
   =retrieval>
      isa addition-fact
      sum =sum
==>
   =imaginal>
      left-ones =sum
   +retrieval> =sum)

(p left-ones-carry
   =goal>
      isa goal
      step encode-left
  =imaginal>
     isa image
     left-ones =x
      left-tens =tens
   =retrieval>
      isa number
      tens one
      ones =value
   ?imaginal>
      state free
==>
    +retrieval>
      isa addition-fact
      arg1 one
      arg2 =tens
    +imaginal>
      left-ones =value)

(p process-carry
   =goal>
      isa goal
      step encode-left
   =retrieval>
      isa addition-fact
      sum =ans
  =imaginal>
     isa image
     left-ones =x
   ?imaginal>
      state free
==>
    +imaginal>
      left-tens =ans
    +goal>
      step encode-right)


(p left-ones-no-carry
   =goal>
      isa goal
      step encode-left
  =imaginal>
     isa image
     left-ones =x
      left-tens =y
    - left-tens zero
      right-ones =ones
   =retrieval>
      isa number
      tens zero
      ones =value
   ?imaginal>
      state free
==>
    +imaginal>
      left-ones =value
    +goal>
      step encode-right)

(p subtract-ones
   =goal>
      isa goal
      step encode-right
  =imaginal>
     isa image
      right-ones =rones
      left-ones =lones
   ?imaginal>
      state free
   ?retrieval>
       buffer empty
       state free
!eval! (less-val =lones =rones)
==>
  =imaginal>
      right-ones nil
  +retrieval>
      isa  addition-fact
      arg1 =lones
      sum =rones)

(p borrow1
   =goal>
      isa goal
      step encode-right
  =imaginal>
     isa image
      right-ones =rones
      left-ones =lones
      right-tens =tens
   ?retrieval>
       buffer empty
       state free
   ?imaginal>
      state free
!eval! (not (less-val =lones =rones)  ) 
==>
  +retrieval>
      isa  addition-fact
      arg1 one
      sum =tens)

(p borrow2
   =goal>
      isa goal
      step encode-right
  =imaginal>
     isa image
      right-ones =ones
      right-tens =x
   =retrieval>
      isa addition-fact
      arg2 =ans
   ?imaginal>
      state free
==>
  +retrieval>
      isa number
      tens one
      ones =ones
    +imaginal>
      right-tens =ans)

(p borrow3
   =goal>
      isa goal
      step encode-right
  =imaginal>
     isa image
      left-ones =ones
      right-tens =x
   =retrieval>
      isa number
   ?imaginal>
      state free
==>
  =imaginal>
      right-ones nil
  +retrieval>
      isa addition-fact
      arg1 =ones
      sum =retrieval)

(p subtract-tens
    =goal>
      isa goal
      step encode-right
  =imaginal>
     isa image
      left-tens =ltens
      right-ones nil
      right-tens =rtens
    =retrieval>
      isa addition-fact
      arg2 =ans
   ?imaginal>
      state free
==>
  +retrieval>
      isa addition-fact
      arg1 =ltens
      sum =rtens
    +imaginal>
      right-ones =ans
      right-tens nil)

(p subgoal-left
    =goal>
      isa goal
      step encode-right
  =imaginal>
     isa image
     right-tens nil
      left-tens =tens
    - left-tens zero
      left-ones =ones
    =retrieval>
      isa addition-fact
      arg2 =ans
   ?imaginal>
      state free
!eval! (left-ok =imaginal =imaginal)
==>
  +retrieval>
      isa number
      tens =tens
      ones =ones
    =imaginal>
      right-tens =ans
   +goal>
      step encode-left
    +imaginal>
       isa image 
       right-tens =tens
       right-ones =ones
       left =imaginal)


(p subgoal-right-instead-of-left
    =goal>
      isa goal
      step encode-right
  =imaginal>
     isa image
     right-tens nil
     right-ones =rones
      left-tens =tens
    - left-tens zero
      left-ones =ones
    =retrieval>
      isa addition-fact
      arg2 =ans
    - arg2 zero
   ?imaginal>
      state free
!eval! (and (not (left-ok =imaginal =imaginal)) (right-ok =imaginal =imaginal))
==>
  +retrieval>
      isa number
      tens =ans
      ones =rones
    =imaginal>
      right-tens =ans
   +goal>
      step encode-left
    +imaginal>
       isa image 
       right-tens =ans
       right-ones =rones
       right =imaginal)

(p key-right-instead-of-left
    =goal>
      isa goal
      step encode-left
  =retrieval>
     isa image
      left-ones =lones
      right-ones =rones
    =imaginal>
      isa image
   ?imaginal>
      state free
!eval! (not (left-ok =imaginal =retrieval))
==>
    +imaginal>
      left-tens zero
      left-ones =lones
      right-tens zero
      right-ones =rones
   +RETRIEVAL> =RONES
   +GOAL>
       STEP KEY-RIGHT
)

(p key-right-instead-of-left1
    =goal>
      isa goal
      step encode-right
  =imaginal>
     isa image
     right-tens nil
      left-tens =tens
    - left-tens zero
      left-ones =ones
      right-ones =rones
      left =parent
    =retrieval>
      isa addition-fact
      arg2 zero
   ?imaginal>
      state free
!eval! (not (left-ok =imaginal =imaginal))
==>
   +RETRIEVAL> =rones
   +GOAL>
       STEP KEY-RIGHT
)

(p get-left-key
    =goal>
      isa goal
      step encode-left
  =retrieval>
     isa image
      left-ones =lones
      right-ones =rones
    =imaginal>
      isa image
   ?imaginal>
      state free
!eval! (left-ok =imaginal =retrieval)
==>
    +imaginal>
      left-tens zero
      left-ones =lones
      right-tens zero
      right-ones =rones
    +retrieval> =lones)

(p get-right-key-instead-of-left
    =goal>
      isa goal
      step encode-right
  =imaginal>
     isa image
     right-tens nil
      left-tens =tens
     left-tens zero
      left-ones =ones
      right-ones =rones
    =retrieval>
      isa addition-fact
      arg2 =ans
   ?imaginal>
      state free
!eval! (not (left-ok =imaginal =imaginal))
==>
    +imaginal>
      right-tens =ans
    +goal>
      step key-right
    +retrieval> =rones)

(p key-left
   =goal>
      isa goal
      step encode-left
  =imaginal>
     isa image
      right-tens zero
      left-tens zero
      right-ones =ones   
   =retrieval>
      isa number
      punch =val
    ?manual>
      state free
   ?imaginal>
      state free
!eval! *ready-flag*
==>
   +goal>
      step key-right
   +retrieval> =ones
   +manual>
       ISA	punch
       hand right
       finger =val
)

(p key-right
   =goal>
      isa goal
      step key-right
  =imaginal>
     isa image
      left =parent
   =retrieval>
      isa number
      punch =val
    ?manual>
      state free
    ?imaginal>
      state free
!eval! *ready-flag*
==>
   +goal>
      step up
   +retrieval> =parent
   +manual>
       ISA	punch
       hand right
       finger =val
)

(p key-right-up
   =goal>
      isa goal
      step key-right
  =imaginal>
     isa image
      right =parent
   =retrieval>
      isa number
      punch =val
    ?manual>
      state free
    ?imaginal>
      state free
!eval! *ready-flag*
!eval! (not (done-test =imaginal))
==>
   +goal>
      step up
   +retrieval> =parent
   +manual>
       ISA	punch
       hand right
       finger =val
)

(p key-right-done
   =goal>
      isa goal
      step key-right
  =imaginal>
     isa image
      right =parent
   =retrieval>
      isa number
      punch =val
    ?manual>
      state free
    ?imaginal>
      state free
!eval! *ready-flag*
!eval! (done-test =imaginal)
==>
   +goal>
      step done
   +manual>
       ISA	punch
       hand right
       finger =val
)

(p go-up-left
  =goal>
     ISA GOAL
      STEP  up
   =retrieval>
      isa image
      left =parent
   !EVAL! (not (RIGHT-OK =RETRIEVAL =RETRIEVAL))
==>
   +retrieval> =parent)

(p go-up-right
  =goal>
     ISA GOAL
      STEP  up
   =retrieval>
      isa image
      right =parent
   !EVAL! (not (RIGHT-OK =RETRIEVAL =RETRIEVAL))
==>
   +retrieval> =parent)

(p key-right-parent
   =goal>
      isa goal
      step up
   =retrieval>
      isa image
      right-tens zero
      right-ones =ones
      left =parent
  =imaginal>
     isa image
    ?manual>
      state free
   ?imaginal>
      state free
==>
   +retrieval> =ones
   +goal>
      step key-right
   +imaginal> =retrieval
)

(P SUBGOAL-RIGHT
   =GOAL>
       ISA GOAL
       STEP up
   =imaginal>
       isa image
   =RETRIEVAL>
       ISA IMAGE
     - right =imaginal
       left-TENS =LTENS
       left-ONES =LONES
    -  RIGHT-TENS ZERO
       RIGHT-TENS =TENS
       RIGHT-ONES =ONES
   ?MANUAL>
       STATE FREE
   ?imaginal>
      state free
!eval! (right-ok =retrieval =retrieval)
 ==>
   +RETRIEVAL>
       ISA NUMBER
       TENS =TENS
       ONES =ONES
   +GOAL>
       step encode-left
   +IMAGINAL>
       ISA IMAGE
       RIGHT-TENS =TENS
       RIGHT-ONES =ONES
       right =retrieval
)

(P done
   =GOAL>
       ISA GOAL
       STEP up
   =imaginal>
       isa image
   =RETRIEVAL>
       ISA IMAGE
       left top
   ?MANUAL>
       STATE FREE
   ?imaginal>
      state free
!eval! (not (right-ok =retrieval =retrieval))
 ==>
   +GOAL>
       STEP done
)

(p parent-failure
   =goal>
      isa goal
     - step start
   ?retrieval>
      state error
  ?visual>
     state free
==>
-imaginal>
  +retrieval>
    isa instructions
 +visual>
     isa clear
  +goal>
      step start
  +visual-location>
       ISA VISUAL-LOCATION
        screen-x lowest
     )

(p image-failure
    =goal>
       isa goal
!eval! (image-failure)
    ?manual>
      state free
  ?visual>
     state free
   ?imaginal>
      state free
==>
-imaginal>
  +retrieval>
    isa instructions
+visual>
     isa clear
!eval! (failure)
  +goal>
      step start
  +visual-location>
       ISA VISUAL-LOCATION
       screen-x lowest
     )

)