;;;;;;;;;;;;;;;;;;;;;;;;<pre><xmp>
;;;
(defvar *goal*)
(setf *goal* '((1 c) (2 c) (3 c) (4 c) (5 c)))
(defvar *problem*)
(setf *problem* '((1 a) (2 a) (3 a) (4 a) (5 a)))
(defvar *remember*)
(defvar *stack*)
(defvar *sequence*)
(setf *remember* 0)
(defvar *action*)
(setf *action* 2.5)
(defparameter *encode* 1.4)
(defvar *errors*)
(defvar *disk*)
(defvar *start*)
(defvar *peg*)
(defvar *action*)
(defvar *error*)
(defvar *result*)
(defvar *click*)
(setf *click* 0.80)
(defvar *top*)
(defvar *results*)
(defparameter *noise* 0.15)
(defparameter *thresh* -1.45)
(defparameter *base* 1.15)
(defparameter *slip* .95)

(defparameter *v* nil)
(defparameter *text* t)
(defparameter *graphic* nil)
(defparameter *overlay* nil)
(defparameter *runs* 1)

(defvar exp-data (make-array '(10 2 3) :initial-contents
                             '(((0.94	0.65	0.90)(	2823	4011	2930))
                               ((0.96	0.93	0.91)(	2672	2699	2732))
                               ((0.96	0.95	0.95)(	2702	2701	2698))
                               ((0.96	0.94	0.97)(	2669	2695	2632))
                               ((0.89	0.90	0.87)(	2973	3109	2903))
                               ((0.96	0.98	0.98)(	2853	2852	2640))
                               ((0.75	0.79	0.83)(	3258	3211	2792))
                               ((0.95	0.96	0.95)(	2709	2697	2684))
                               ((0.97	0.97	0.98)(	2645	2659	2638))
                               ((0.95	0.98	0.99)(	2825	2824	2694)))))


(defvar *WWW-interface*)

(setf  *WWW-interface* 
      '((:heading "Model for Tower Of Hanoi: Evidence For The Cost Of Goal Retrieval " 2)
        (:table)
        
        (:table)
        "Noise:" (:string :sy *noise*  .15)  (:new-row)
        "Threshold:"  (:string :sy *thresh* -1.45)  (:new-row)
        "Probabilitiy of a slip:"  (:string :sy *slip* .05)  (:new-row)
        "Number of runs (1-100):"  (:string :sy *runs* 10)  
       
        
        (:table-end)
        
        (:table)
        (:checkbox "Trace" :sy *v*  nil) (:new-row)
        (:checkbox "Text output" :sy *text*  t) (:new-row)
        (:checkbox "Graphic output" :sy *graphic*  nil) (:new-row)
        (:checkbox "Show simulation and experiment data on one graph" :sy *overlay*  nil) 
        (:table-end)
        (:table-end)
        
        (:new-para)
        
        (:button "Show Experiment Results" "(output-results exp-data nil)")
        (:new-para)
        (:button "Run model" "(if (and (numberp *noise*) (numberp *thresh*)
                                       (numberp *slip*) (<= *slip* 1.0) (>= *slip* 0)
                                       (numberp *runs*))
                                  (progn
                                    (setf *slip* (- 1 *slip*))
                                    (experiment (min 100 (max 1 *runs*))))
                                  (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 for 10 runs of the model"
        (:new-line)
        "- The trace of 1 run is approximatly 20k (15 pages) in size"))


(defun match-up (disk peg action)
  (cond ((equal (list disk peg action) (car *sequence*)) 
         (setf *sequence* (cdr *sequence*))
         (setf *result* (append *result* (list *error* *disk* *peg* *action*) ))
         (setf *error* 0)
         (update-problem disk peg action)
         nil)
        (t (setf *errors* (1+ *errors*)) (setf *error* 1) (car *sequence*))))

(defun super (lis)
  (do ((temp lis (cdr temp)))
      ((> (caar temp) 2) (car temp))))

(defun parent (item lis)
  (do ((temp (cdr (member item lis :test 'equal)) (cdr temp)))
      ((null temp) nil)
    (cond ((> (caar temp) (car item)) (return t)))))


(defun compute-sequence (problem goal)
    (solve problem goal (length problem)))

(defun solve (start end n)
  (cond ((equal n 0) nil)
        ((equal (nth (1- n) start) (nth (1- n) end)) 
         (solve start end (1- n)))
        ((legal start end n) (append (list (list n (car end) 'do-it))
                                     (solve start end (1- n))))
        (t (append (list (list n (car end) 'post))
                   (solve (front start (1- n)) (pyramid (other-disk (nth (1- n) end)
                                                                    (nth (1- n) start))
                                                                    (1- n)) (1- n))
                   (solve (append (pyramid (other-disk (nth (1- n) end)
                                                       (nth (1- n) start))
                                                       (1- n)) (nthcdr (1- n) start))
                          end n)))))

(defun pyramid (disk n)
  (do ((count 0 (1+ count))
       (lis nil (cons disk lis)))
      ((equal count n) lis)))

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

(defun legal (start end n)
  (let ((other (other-disk (nth (1- n) start) (nth (1- n) end))))
    (do ((count 0 (1+ count))
         (temp start (cdr temp)))        
        ((equal count (1- n)) t)
      (cond ((not (equal (car temp) other)) (return nil))))))
                          
(defun encode-goal (x)
  (cadr (assoc x *goal*)))

(defun encode-problem (x)
  (cond ((zerop x) 'done)
        (t   (cadr (assoc x *problem*)))))

(defun other-disk (x y)
  (car (remove x (remove y '(a b c)))))

(defun update-problem (d p a)
  (cond ((and (equal a 'do-it) (equal d *top*)) (setf *top* (1- *top*))))
  (cond ((equal a 'post) (setf *stack* (1+ *stack*)))
        (t (cond ((> d 1) (setf *stack* (1- *stack*))))
           (let ((pair (assoc d *problem*)))
             (setf *problem* (subst (list d p) pair *problem* :test 'equal))))))

(defun report-time ()
  (let  ((answer (- (+ *action* *time*) *remember*)))
    (setf *remember* (+ *action* *time*)) answer))

(defun cycle (n)
  (do ((count 0 (1+ count))
       (result nil (cons (do-it-46) result)))
      ((equal count n) (reverse result))))

(defun do-it-46 () (setf *errors* 0) (setf *result* nil) (setf *error* 0) (setf *top* 5)
       (setf *start* 0) (reset) (setf *problem* '((1 a) (2 a) (3 a) (4 a) (5 a)))
       (setf *sequence* (compute-sequence (mapcar 'cadr *problem*) (mapcar 'cadr *goal*)))
       (setf *stack* 0)(run)(list *cycle* *time* *errors* *result*))

(defun analyze-this (x lis)
  (let* ((moves (/ (length x) 4))
         (time 0) 
         (result (make-array '(3 10 2) :initial-element 0))
         (start (first (car lis)))
         (end (second (car lis)))
         (index (third (car lis))))
    (setf lis (cdr lis))
    (do ((i 0 (1+ i))
         (temp x (cddddr temp)))
        ((equal i moves) result)
      (cond ((and lis (equal i end))
             (setf start (first (car lis)))
             (setf end (second (car lis)))
             (setf index (third (car lis)))
             (setf lis (cdr lis)))
            ((and (zerop (car temp)) (>= i start) (< i end))
             (setf (aref result index (- i  start) 0) 
                   (1+ (aref result index (- i  start) 0) ))
             (setf (aref result index (- i  start) 1) 
                   (+ (aref result index (- i  start) 1) 
                      (- (if (null (cdddr x)) *time*
                             (+ (fourth temp) *click*)) time)))))
      (setf time (if (null (cdddr x)) *time*
                     (+ (fourth temp) *click*))))))




(defun analysis-46 (n)
  (let ((results (make-array '(3 10 2) :initial-element 0)))
    (do ((count 0 (1+ count)))
        ((equal count n) (setf *results* results))
      (let ((temp (analyze-this (fourth (do-it-46))
                              '((2 12 0) (13 23 1) (25 35 0)(36 46 2)))))
       (do ((i 0 (1+ i)))
           ((equal i 3) nil)
         (do ((j 0 (1+ j)))
             ((equal j 10) nil)
             (do ((k 0 (1+ k)))
                 ((equal k 2) nil)
               (setf (aref results i j k) (+ (aref results i j k) (aref temp i j k))))))))))

(defun analyze-results (results n)
  (let ((answer (make-array '(10 2 3)))
        (div (make-array '(3) :initial-contents (list (* n 2) n n))))
  (do ((i 0 (1+ i)))
      ((equal i 3) answer)
    (do ((j 0 (1+ j)))
        ((equal j 10) nil)
      (setf (aref answer j 0 i)(* *slip* (/ (aref results i j 0) (aref div i))))
        (cond ((zerop (aref results i j 0)) (setf (aref answer j 1 i) 0))
              (t (setf  (aref answer j 1 i)
                        (* 1000 (/ (aref results i j 1) (aref results i j 0))))))))))
#|
(defun output-results (results model)
  (do ((i 0 (1+ i)))
      ((equal i 10) nil)
    (terpri)
    (do ((j 0 (1+ j)))
        ((equal j 2) nil)
      (do ((k 0 (1+ k)))
          ((equal k 3) nil)
        (cond ((zerop j) (princ (format nil "~8,3F" (aref results i j k))))
            (t (princ (format nil "~6D" 
                              (round  (aref results i j k))))))))))
|#

(defun output-results (data simulation)
  (let ((names '("Post 3" "Post 2" "Move 1" "Move 2" "Move 1" "Move 3" "Post 2" "Move 1" "Move 2" "Move 1"))) 
  (when simulation 
    (format *standard-output* "~%~%Parameters for run: (~S ~S ~S ~S)~%" 
            *noise* *thresh* (- 1 *slip*) (min 100 (max 1 *runs*))))
  
  (when *text*
    (format *standard-output* "~%~%~a latencies (msec.):~%" (if simulation "Simulation" "Experimental"))
    (format *standard-output* "~%Action                Condition ~%")
    (format *standard-output* "~%              Under 4   Under 5   End ~%")
    (dotimes (i 10)
      (format *standard-output* "~11a~10,0f~10,0f~10,0f~%" (nth i names) (aref data i 1 0) (aref data i 1 1) (aref data i 1 2)))
    (format *standard-output* "~%")
    (format *standard-output* "~%~%~a Proportion of perfect moves:~%" (if simulation "Simulation" "Experimental"))
    (format *standard-output* "~%Action                Condition ~%")
    (format *standard-output* "~%              Under 4   Under 5   End ~%")
    (dotimes (i 10)
      (format *standard-output* "~11a~10,2f~10,2f~10,2f~%" (nth i names) (aref data i 0 0) (aref data i 0 1) (aref data i 0 2)))
    (format *standard-output* "~%")
    
    (when (and simulation *overlay*)
      (format *standard-output* "~%~%Experimental latencies (msec.):~%" )
      (format *standard-output* "~%Action                Condition ~%")
      (format *standard-output* "~%              Under 4   Under 5   End ~%")
      (dotimes (i 10)
        (format *standard-output* "~11a~10,0f~10,0f~10,0f~%" (nth i names) (aref exp-data i 1 0) (aref exp-data i 1 1) (aref exp-data i 1 2)))
      (format *standard-output* "~%")
      (format *standard-output* "~%~%Experimental Proportion of perfect moves:~%" )
      (format *standard-output* "~%Action                Condition ~%")
      (format *standard-output* "~%              Under 4   Under 5   End ~%")
      (dotimes (i 10)
        (format *standard-output* "~11a~10,2f~10,2f~10,2f~%" (nth i names) (aref exp-data i 0 0) (aref exp-data i 0 1) (aref exp-data i 0 2)))
      (format *standard-output* "~%")

      )
    
    (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 = 600 
        height = 600> 
        <PARAM name=\"title\" value=\"Latency Data\">
        <PARAM name=\"xmin\" value=\"1\">
        <PARAM name=\"xmax\" value=\"10\">
        <PARAM name=\"ymax\" value=\"4000\">
        <PARAM name=\"ymin\" value=\"2000\">
        <PARAM name=\"longestline\" value=\"10\">
        <PARAM name=\"numlines\" value=\"~S\">
        <PARAM name=\"numxlabels\" value=\"10\">
        <PARAM name=\"xlabels\" value=\"Post 3;Post 2;Move 1;Move 2;Move 1;Move 3;Post 2;Move 1;Move 2;Move 1;\">
        <PARAM name=\"widestxlabel\" value=\"WWWWWW\">
        <PARAM name=\"ydiv\" value=\"250\">
        <PARAM name=\"yspacing\" value=\"500\">
        <PARAM name=\"xname\" value=\"Action\">
        <PARAM name=\"yname\" value=\"Latency msec.\">
        <PARAM name=\"name0\" value=\"~a - Under 4\">
        <PARAM name=\"lcolor0\" value=\"0\">
        <PARAM name=\"lstyle0\" value=\"~s\">
        <PARAM name=\"xval0\" value=\"1;2;3;4;5;6;7;8;9;10;\">
        <PARAM name=\"name1\" value=\"~a - Under 5\">
        <PARAM name=\"lcolor1\" value=\"1\">
        <PARAM name=\"lstyle1\" value=\"~s\">
        <PARAM name=\"xval1\" value=\"1;2;3;4;5;6;7;8;9;10;\">
        <PARAM name=\"name2\" value=\"~a - End\">
        <PARAM name=\"lcolor2\" value=\"2\">
        <PARAM name=\"lstyle2\" value=\"~s\">
        <PARAM name=\"xval2\" value=\"1;2;3;4;5;6;7;8;9;10;\"> "
            (if (and simulation *overlay*) 6 3)
            (if simulation "Simulation" "Experimental")
            (if simulation 2 6553)
            (if simulation "Simulation" "Experimental")
            (if simulation 2 6553)
            (if simulation "Simulation" "Experimental")
            (if simulation 2 6553))

    (dotimes (i 3)
      (format *standard-output* "<PARAM name=\"yval~a\" value=\"" i)
      (dotimes (j 10)
        (format *standard-output* "~6,0f;" (aref data j 1 i)))
      
      (format *standard-output* "\">"))

    
    (when (and *overlay* simulation)
      (format *standard-output* "
        <PARAM name=\"name3\" value=\"Experimental - Under 4\">
        <PARAM name=\"lcolor3\" value=\"0\">
        <PARAM name=\"lstyle3\" value=\"6553\">
        <PARAM name=\"xval3\" value=\"1;2;3;4;5;6;7;8;9;10;\">
        <PARAM name=\"name4\" value=\"Experimental - Under 5\">
        <PARAM name=\"lcolor4\" value=\"1\">
        <PARAM name=\"lstyle4\" value=\"6553\">
        <PARAM name=\"xval4\" value=\"1;2;3;4;5;6;7;8;9;10;\">
        <PARAM name=\"name5\" value=\"Experimental - End\">
        <PARAM name=\"lcolor5\" value=\"2\">
        <PARAM name=\"lstyle5\" value=\"6553\">
        <PARAM name=\"xval5\" value=\"1;2;3;4;5;6;7;8;9;10;\"> ")

      (dotimes (i 3)
        (format *standard-output* "<PARAM name=\"yval~a\" value=\"" (+ 3 i))
        (dotimes (j 10)
          (format *standard-output* "~6,0f;" (aref exp-data j 1 i)))
        
        (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>~%
        <applet 
        code = \"DansGraphs.class\" 
        width = 600 
        height = 600> 
        <PARAM name=\"title\" value=\"Perfect moves\">
        <PARAM name=\"xmin\" value=\"1\">
        <PARAM name=\"xmax\" value=\"10\">
        <PARAM name=\"ymax\" value=\"1.0\">
        <PARAM name=\"ymin\" value=\"0.5\">
        <PARAM name=\"longestline\" value=\"10\">
        <PARAM name=\"numlines\" value=\"~S\">
        <PARAM name=\"numxlabels\" value=\"10\">
        <PARAM name=\"xlabels\" value=\"Post 3;Post 2;Move 1;Move 2;Move 1;Move 3;Post 2;Move 1;Move 2;Move 1;\">
        <PARAM name=\"widestxlabel\" value=\"WWWWWW\">
        <PARAM name=\"ydiv\" value=\".05\">
        <PARAM name=\"yspacing\" value=\".1\">
        <PARAM name=\"xname\" value=\"Action\">
        <PARAM name=\"yname\" value=\"Proportion\">
        <PARAM name=\"name0\" value=\"~a - Under 4\">
        <PARAM name=\"lcolor0\" value=\"0\">
        <PARAM name=\"lstyle0\" value=\"~s\">
        <PARAM name=\"xval0\" value=\"1;2;3;4;5;6;7;8;9;10;\">
        <PARAM name=\"name1\" value=\"~a - Under 5\">
        <PARAM name=\"lcolor1\" value=\"1\">
        <PARAM name=\"lstyle1\" value=\"~s\">
        <PARAM name=\"xval1\" value=\"1;2;3;4;5;6;7;8;9;10;\">
        <PARAM name=\"name2\" value=\"~a - End\">
        <PARAM name=\"lcolor2\" value=\"2\">
        <PARAM name=\"lstyle2\" value=\"~s\">
        <PARAM name=\"xval2\" value=\"1;2;3;4;5;6;7;8;9;10;\"> "
            (if (and simulation *overlay*) 6 3)
            (if simulation "Simulation" "Experimental")
            (if simulation 2 6553)
            (if simulation "Simulation" "Experimental")
            (if simulation 2 6553)
            (if simulation "Simulation" "Experimental")
            (if simulation 2 6553))

    (dotimes (i 3)
      (format *standard-output* "<PARAM name=\"yval~a\" value=\"" i)
      (dotimes (j 10)
        (format *standard-output* "~6,2f;" (aref data j 0 i)))
      
      (format *standard-output* "\">"))

    
    (when (and *overlay* simulation)
      (format *standard-output* "
        <PARAM name=\"name3\" value=\"Experimental - Under 4\">
        <PARAM name=\"lcolor3\" value=\"0\">
        <PARAM name=\"lstyle3\" value=\"6553\">
        <PARAM name=\"xval3\" value=\"1;2;3;4;5;6;7;8;9;10;\">
        <PARAM name=\"name4\" value=\"Experimental - Under 5\">
        <PARAM name=\"lcolor4\" value=\"1\">
        <PARAM name=\"lstyle4\" value=\"6553\">
        <PARAM name=\"xval4\" value=\"1;2;3;4;5;6;7;8;9;10;\">
        <PARAM name=\"name5\" value=\"Experimental - End\">
        <PARAM name=\"lcolor5\" value=\"2\">
        <PARAM name=\"lstyle5\" value=\"6553\">
        <PARAM name=\"xval5\" value=\"1;2;3;4;5;6;7;8;9;10;\"> ")

      (dotimes (i 3)
        (format *standard-output* "<PARAM name=\"yval~a\" value=\"" (+ 3 i))
        (dotimes (j 10)
          (format *standard-output* "~6,2f;" (aref exp-data j 0 i)))
        
        (format *standard-output* "\">")))

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



(defun experiment (n)
  (output-results (analyze-results (analysis-46 n) n) t))


                     


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

(clearall)

(sgp-fct (list :er t :era t :v *v* :OL nil :bll .5 :lf 0.01 :ga 0 :pm nil :mp 0 :ans *noise* :rt *thresh* ))

(chunk-type do-tower p-disk p-from p-to check spare check-loc parent success child)

(add-dm (goal isa do-tower)  (peg isa chunk) (action isa chunk) (done isa chunk)
        (skip isa chunk) (error isa chunk) (junk isa chunk)
        (1 isa chunk) (2 isa chunk) (3 isa chunk) (4 isa chunk) (5 isa chunk)
        (a isa chunk) (b isa chunk) (c isa chunk) (0 isa chunk) (failure isa chunk))

(goal-focus goal)

(p Start-Up 
   =goal>
       isa do-tower
       p-disk nil
==>
   =goal>
       p-disk 5)

(eval `(spp Start-Up :effort ,*encode*))

(p Note-Target-Peg
   =goal>
       isa do-tower
       p-disk =size
       p-to nil
==>
!bind! =spare (other-disk (encode-problem =size) (encode-goal =size))
!bind! =to (encode-goal =size)
   =goal>
       spare =spare
       p-to =to)


(p Note-Source-Peg
   =goal>
       isa do-tower
       p-disk =size
       p-from nil
       p-to =to
==>
!bind! =spare (other-disk (encode-problem =size) =to)
!bind! =from (encode-problem =size)
   =goal>
       spare =spare
       p-from =from)


(p Disk-There
   =goal>
      isa do-tower
      p-disk =size
    - p-disk 1
      p-to =target
      p-from =target
      success nil
==>
   =goal>
      success t
   =newgoal>
      isa do-tower
      p-disk (!eval! (1- =size))
      p-to nil
      p-from nil
!focus-on! =newgoal)

(p Size-of-Check
   =goal>
      isa do-tower
      p-disk =size
      p-to =target
    - p-from =target
      p-from =source
      check nil
==>
   =goal>
      check (!eval! (1- =size)))



(p Location-of-Check
    =goal>
      isa do-tower
      check =disk
    - check 0
    - check skip
      check =check
      check-loc nil
    - success action
    - success peg
==>
    =goal>
      check-loc (!eval! (encode-problem =disk)))



(p Blocked-Source-old
     =goal>
       isa do-tower
       p-disk =disk
       p-from =peg
       p-to =p
       check-loc =peg
       success nil
       spare =spare
!eval! (<  (- *top* =disk)  *stack*)
==>
     =goal>
       success failure)

(p Blocked-Source
     =goal>
       isa do-tower
       p-disk =disk
       p-from =peg
       p-to =p
       check-loc =peg
       success nil
       spare =spare
!eval! (>=  (- *top* =disk)  *stack*)
==>
!eval! (setf *disk* *time*)
!output! =disk
     =goal>
       success peg)

(spp Blocked-Source :effort .750)

(p Blocked-Destination-old
     =goal>
       isa do-tower
       p-disk =disk
       p-to =peg
       check-loc =peg
       success nil
       spare =spare
!eval!(or (<  (- *top* =disk)  *stack*)
          (and (equal *top* 5) (equal =disk 3) (equal *stack* 2)))
==>
     =goal>
       success failure)

(p Blocked-Destination
     =goal>
       isa do-tower
       p-disk =disk
       p-to =peg
       check-loc =peg
       success nil
       spare =spare
!eval! (and (>=  (- *top* =disk)  *stack*)
           (not (and (equal *top* 5) (equal =disk 3) (equal *stack* 2))))
==>
!eval! (setf *disk* *time*)
!output! =disk
     =goal>
       success peg)

(spp Blocked-Destination :effort .750)

(p no-blocks
     =goal>
       isa do-tower
       check =disk
       spare =peg   
       check-loc =peg
==>
     =goal>
       check (!eval! (1- =disk))
       check-loc nil)

(p Subgoal-Blocker
    =goal>
       isa do-tower
       check-loc =loc1
       spare =loc2
    -  spare =loc1
       check =size
       success failure
!eval! (> =size 1)
==>
    =newgoal>
       isa do-tower
       p-disk =size
       p-from =loc1
       p-to =loc2
       parent =goal
       check (!eval! (1- =size))
      check-loc (!eval! (encode-problem (1- =size)))
      spare (!eval! (other-disk =loc2 =loc1))
    =goal>
       check-loc nil
       child =newgoal
!focus-on! =newgoal)

(p receive-error
      =goal>
         isa do-tower
         success =lis
!eval! (listp =lis)
==>
=newgoal>
       isa do-tower
       p-disk (!eval! (car =lis))
       p-to (!eval! (cadr =lis))
!focus-on! =newgoal)

(spp receive-error :r .5)

(p Move-disk-1-2
    =goal>
       isa do-tower
       check 1
       success failure
       check-loc =p
       disk 2
       p-from =q
       p-to =r
!eval! (or (equal =p =q) (equal =p =r))
==>
!eval! (setf *disk* *time*)
!output! 1
    =goal>
       success peg
       check skip)

(spp move-disk-1-2 :effort .750)

(p Move-disk-1
    =goal>
       isa do-tower
       p-disk 1
       p-from =x
       p-to =p
       success nil
==>
!eval! (setf *disk* *time*)
!output! 1
    =goal>
       success peg)

(spp move-disk-1 :effort .750)

(p Move-disk-rest
    =goal>
       isa do-tower
      - p-disk 1
       p-disk =d
       p-from =x
       p-to =p
       check 0
       success failure
==>
!eval! (setf *disk* *time*)
!output! =d
    =goal>
       success peg)

(spp move-disk-rest :effort .750)

(p Move-disk-rest-nil
    =goal>
       isa do-tower
      - p-disk 1
       p-disk =d
       p-from =x
       p-to =p
       check 0
       success nil
==>
!eval! (setf *disk* *time*)
!output! =d
    =goal>
       success peg)

(spp move-disk-rest-nil :effort .750)


(p Move-peg
    =goal>
       isa do-tower
       p-disk =d
       p-from =x
       p-to =p
       success peg
     - check skip
==>
!eval! (setf *peg* *time*)
!output! =p
    =goal>
       success action)

(spp move-peg :effort *base*)

(p Move-peg-1-2
    =goal>
       isa do-tower
       p-disk =d
       p-from =x
       spare =p
       success peg
       check skip
==>
!eval! (setf *peg* *time*)
!output! =p
    =goal>
       success action)

(spp move-peg-1-2 :effort *base*)


(p Move-action-do-it
    =goal>
       isa do-tower
       p-disk =d
       p-from =x
       p-to =p
       check 0
      success action
==>
!eval! (setf *action* *time*)
!output! do-it
    =goal>
       success (!eval! (or (match-up =d =p 'do-it) t)))

(eval `(spp move-action-do-it :effort ,*click*))

(p Move-action-do-it-1-2
    =goal>
       isa do-tower
       p-disk =d
       p-from =x
       spare =p
       check skip
      success action
==>
!eval! (setf *action* *time*)
!output! do-it
    =goal>
       success (!eval! (or (match-up 1 =p 'do-it) 'failure))
       check 0)

(eval `(spp move-action-do-it-1-2 :effort ,*click*))

(p Move-action-post
    =goal>
       isa do-tower
       p-disk =d
       p-from =x
       p-to =p
      - check 0
      - check skip
      success action
==>
!eval! (setf *action* *time*)
!output! post
    =goal>
       success (!eval! (or (match-up =d =p 'post) 'failure)))

(eval `(spp Move-action-post :effort ,*click*))



(p Reset-Top
    =goal>
       isa do-tower
       p-disk =d
    -  p-disk 1
       p-to =p
       parent nil
       spare =spare
       success t
==>
     =newgoal>
        isa do-tower
        p-disk (!eval! (1- =d))
        p-to nil
        p-from =spare
        check (!eval! (1- (1- =d)))
!focus-on! =newgoal)


(p Retrieve-Parent
    =goal>
       isa do-tower
       p-disk =disk
       success t
       parent =parent
!eval! (> *stack* 0)
    =parent>
       isa do-tower
==>
!focus-on! =parent)

(p Recompute
    =goal>
       isa do-tower
       success t
!eval! (> *top* 0)
==>
;!eval! (print 'Recompute)
!eval! (setf *error* 1)
=newgoal>
       isa do-tower
       p-disk 5
!focus-on! =newgoal)

(spp recompute :b 5)

(p Recompute-1
    =goal>
       isa do-tower
       success t
       p-disk =disk
       parent =p
!eval! (> *top* 0)
==>
;!eval! (print 'Recompute-1)
;!eval! (print =disk)
;!eval! (sdp-fct (list =p))
=newgoal>
       isa do-tower
       p-disk 5
!focus-on! =newgoal)

(eval `(spp recompute-1 :b 5 :effort ,*encode*))

(p Success
    =goal>
       isa do-tower
       success t
       p-disk 1
       parent nil
!eval! (equal *stack* 0)
==>
!pop!)

(p pop-failure
   =goal>
       isa do-tower
==>
!output! =goal
!pop!)

(spp pop-failure :r .25)