;;;;;;;;;;;;;;;;;;;;;;;;<pre>
;;;
;;; This file contains the ACT-R model of the
;;; Siegler and Shrager experiment presented 
;;; in Chapter 3.
;;; 
;;; A WWW interface and a command line interface
;;; are provided.  
;;; To run the command line version, call
;;; (do-siegler n)
;;; replacing n with the number of runs to
;;; simulate.
;;;
;;; requires ACT-R 4.0

;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; This section contains the LISP functions to simulate
;;; the experiment, implement the interface, collect the
;;; data, and display the results
;;;
;;; The ACT-R Model starts further down
;;;

;;; Global variables

(defvar *answer*)
(defvar *data*)
(defvar *noise*)
(defvar *threshold*)
(defvar *penalty*)
(defvar *v*)
(defvar *runs*)

(setf *noise* .56)
(setf *threshold* 0)
(setf *penalty* 13)
(setf *v* nil)
(setf *runs* 100)

(defparameter *siegler-data* (make-array '(6 10) :initial-contents
                                        '((0.00 0.05 0.86 0.00 0.02 0.00 0.02 0.00 0.00 0.06)
                                          (0.00 0.04 0.07 0.75 0.04 0.00 0.02 0.00 0.00 0.09)
                                          (0.00 0.02 0.00 0.10 0.75 0.05 0.01 0.03 0.00 0.06)
                                          (0.02 0.00 0.04 0.05 0.80 0.04 0.00 0.05 0.00 0.00)
                                          (0.00 0.00 0.07 0.09 0.25 0.45 0.08 0.01 0.01 0.06)
                                          (0.04 0.00 0.00 0.05 0.21 0.09 0.48 0.00 0.02 0.11))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; This section contains the interface for the WWW using the
;;; ACT-R on the Web application by Elmar Schwarz

(defvar *WWW-interface*)

(setf  *WWW-interface* 
      '((:heading "Siegler and Shrager model" 2)
        (:table)
        
        (:table)
        "Noise (s):"             (:string :sy *noise*   .56)  (:new-row)
        "Threshold:"             (:string :sy *threshold*  0)  (:new-row)
        "Penalty:"               (:string :sy *penalty* 1.3)  (:new-row)
        "Number of runs (1-500):" (:string :sy *runs*    100) 
        
        (:table-end)
       
        (:table)
        (:checkbox "Trace" :sy *v*  nil) 
        (:table-end)
        (:table-end)
        (:new-para)
        
        (:button "Show Experiment Results" "(display-siegler *siegler-data* nil 1)")
       
        (:new-para)
        
        (:button "Run model" "(progn 
                                (when (numberp *penalty*) 
                                    (setf *penalty* (* 10 *penalty*))) 
                              (if (and (numberp *penalty*) (numberp *threshold*)  
                                       (numberp *noise*) (numberp *runs*))
                                   (do-siegler (min 500 (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 100 runs of the model"
        (:new-line)
        "- The trace of 100 runs is approximatly 80k (55 pages) in size"
        (:new-para)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; This section contains the LISP functions to simulate
;;; the experiment, and display the results



(defun map-answer-siegler (ans)
  (case ans
    (0 0)
    (1 1)
    (2 2)
    (3 3)
    (4 4)
    (5 5)
    (6 6)
    (7 7)
    (8 8)
    (t 9)))


(defun increment-base-siegler (lis)
  (do ((temp lis (cdr temp)))
      ((null temp) nil)
    (sdp-fct (list (car temp) :base-level 1))))

(defun decrement-base-siegler (lis)
  (do ((temp lis (cdr temp)))
      ((null temp) nil)
    (sdp-fct (list (car temp) :base-level -1))))

(defun do-up-ias-siegler (lis)
  (do ((temp lis (cdr temp)))
      ((null temp) lis)
    (cond ((equal (chunk-slot-value-fct (car temp) 'arg1)
                  (chunk-slot-value-fct (car temp) 'arg2))
           (set-ia-fct (list (list (chunk-slot-value-fct (car temp) 'arg1) (car temp) 2)
                             (list (chunk-slot-value-fct (car temp) 'arg2) (car temp) 2))))
          (t  (set-ia-fct (list (list (chunk-slot-value-fct (car temp) 'arg1) (car temp) 1)
                      (list (chunk-slot-value-fct (car temp) 'arg2) (car temp) 1)))))))



(defun do-problem-siegler (arg1 arg2)
  (setf *answer* nil)
  (modwme-fct 'goal (list 'arg1 arg1 'arg2 arg2 'answer nil))
  (goal-focus goal) 
  (run)
  (map-answer-siegler *answer*))

(defun setup-siegler ()
  (sgp-fct (list :ans *noise* :mp *penalty* :rt *threshold* :v *v* :pm t))

  (setsimilarities (one zero .9)
                   (two zero .8)
                   (three zero .7)
                   (four zero .6)
                   (five zero .5)
                   (one two .9)
                   (one three .8)
                   (one four .7)
                   (one five .6)
                   (two three .9)
                   (two four .8)
                   (two five .7)
                   (three four .9)
                   (three five .8)
                   (four five .9))
  
  (increment-base-siegler '(0+0 0+1 0+2 0+3 0+4 0+5 1+0 1+1 1+2 1+3 1+4 1+5
                            2+0 2+1 3+0 3+1 4+0 4+1 5+0 5+1))
  
  (decrement-base-siegler '(3+3 3+4 3+5 4+3 4+4 4+5 5+3 5+4 5+5))
  
  (do-up-ias-siegler '(0+0 0+1 0+2 0+3 0+4 0+5 1+0 1+1 1+2 1+3 1+4 1+5
                       2+0 2+1 2+2 2+3 2+4 2+5 3+0 3+1 3+2 3+3 3+4 3+5
                       4+0 4+1 4+2 4+3 4+4 4+5 5+0 5+1 5+2 5+3 5+4 5+5)))


(defun do-siegler (n)
  (reset)
  (setup-siegler)
  
  (setf *data* (make-array '(6 10) :initial-element 0.0))
  (do ((count 0 (1+ count))
       (p11 (do-problem-siegler 'one 'one) (do-problem-siegler 'one 'one))
       (p12 (do-problem-siegler 'one 'two) (do-problem-siegler 'one 'two))
       (p13 (do-problem-siegler 'one 'three) (do-problem-siegler 'one 'three))
       (p22 (do-problem-siegler 'two 'two) (do-problem-siegler 'two 'two))
       (p23 (do-problem-siegler 'two 'three) (do-problem-siegler 'two 'three))
       (p33 (do-problem-siegler 'three 'three) (do-problem-siegler 'three 'three)))
      ((equal count n) (display-siegler *data* t n))
    
    (setf (aref *data* 0 p11) (1+ (aref *data* 0 p11)))
    (setf (aref *data* 1 p12) (1+ (aref *data* 1 p12)))
    (setf (aref *data* 2 p13) (1+ (aref *data* 2 p13)))
    (setf (aref *data* 3 p22) (1+ (aref *data* 3 p22)))
    (setf (aref *data* 4 p23) (1+ (aref *data* 4 p23)))
    (setf (aref *data* 5 p33) (1+ (aref *data* 5 p33)))))

(defun display-siegler (data simulation n)
  (when simulation 
    (format *standard-output* "~%~%Parameters for run: (~S ~S ~S ~S)~%" 
            *noise* *threshold* (/ *penalty* 10.0)  n))

  (format *standard-output* "~%~a data:~%~%" (if simulation "Simulation" "Experimental"))
  (format *standard-output* "Problem                              Answer~%")
  (format *standard-output* "            0     1     2     3     4     5     6     7     8    other~%")
  
  (dotimes (i 6)
    (format *standard-output* "~s+~s      " (case i (0 1) (1 1) (2 1) (3 2) (4 2) (5 3))
            (case i (0 1) (1 2) (2 3) (3 2) (4 3) (5 3)))
    (dotimes (j 10)
      (format t "~6,2f" (/ (aref data i j) n) ))
    (format t "~%")))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;<a name="model">
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;</a>
;;;
;;; This section contains the ACT-R model
;;;
;;;

(clearall)

(sgp-fct (list :ans *noise* :mp *penalty* :rt *threshold* :v nil :pm t))

(chunk-type problem arg1 arg2 answer)
(chunk-type add-fact arg1 arg2 sum)

(add-dm
   (goal isa problem)
   (zero isa chunk)
   (one isa chunk)
   (two isa chunk)
   (three isa chunk)
   (four isa chunk)
   (five isa chunk)
   (six isa chunk)
   (seven isa chunk)
   (eight isa chunk)
   (nine isa chunk)
   (ten isa chunk)
   (0+0 isa add-fact arg1 zero arg2 zero sum 0)
   (0+1 isa add-fact arg1 zero arg2 one sum 1)
   (0+2 isa add-fact arg1 zero arg2 two sum 2)
   (0+3 isa add-fact arg1 zero arg2 three sum 3)
   (0+4 isa add-fact arg1 zero arg2 four sum 4)
   (0+5 isa add-fact arg1 zero arg2 five sum 5)
   (1+0 isa add-fact arg1 one arg2 zero sum 1)
   (1+1 isa add-fact arg1 one arg2 one sum 2)
   (1+2 isa add-fact arg1 one arg2 two sum 3)
   (1+3 isa add-fact arg1 one arg2 three sum 4)
   (1+4 isa add-fact arg1 one arg2 four sum 5)
   (1+5 isa add-fact arg1 one arg2 five sum 6)
   (2+0 isa add-fact arg1 two arg2 zero sum 2)
   (2+1 isa add-fact arg1 two arg2 one sum 3)
   (2+2 isa add-fact arg1 two arg2 two sum 4)
   (2+3 isa add-fact arg1 two arg2 three sum 5)
   (2+4 isa add-fact arg1 two arg2 four sum 6)
   (2+5 isa add-fact arg1 two arg2 five sum 7)
   (3+0 isa add-fact arg1 three arg2 zero sum 3)
   (3+1 isa add-fact arg1 three arg2 one sum 4)
   (3+2 isa add-fact arg1 three arg2 two sum 5)
   (3+3 isa add-fact arg1 three arg2 three sum 6)
   (3+4 isa add-fact arg1 three arg2 four sum 7)
   (3+5 isa add-fact arg1 three arg2 five sum 8)
   (4+0 isa add-fact arg1 four arg2 zero sum 4)
   (4+1 isa add-fact arg1 four arg2 one sum 5)
   (4+2 isa add-fact arg1 four arg2 two sum 6)
   (4+3 isa add-fact arg1 four arg2 three sum 7)
   (4+4 isa add-fact arg1 four arg2 four sum 8)
   (4+5 isa add-fact arg1 four arg2 five sum 9)
   (5+0 isa add-fact arg1 five arg2 zero sum 5)
   (5+1 isa add-fact arg1 five arg2 one sum 6)
   (5+2 isa add-fact arg1 five arg2 two sum 7)
   (5+3 isa add-fact arg1 five arg2 three sum 8)
   (5+4 isa add-fact arg1 five arg2 four sum 9)
   (5+5 isa add-fact arg1 five arg2 five sum 10))



(p find-sum
"
  IF the goal is to say what =arg1 plus =arg2 are
     and =arg1 + =arg2 = =sum
  THEN answer =sum
"
   =goal>
      isa problem
      arg1 =arg1
      arg2 =arg2
      answer nil

   =fact>
      isa add-fact
      arg1 =arg1
      arg2 =arg2
      sum  =sum
==>
   =goal>
      answer =sum

   !eval! (setf *answer* =sum)

   !output! ("~S plus ~S is ~S~%" =arg1 =arg2 =sum)

   !pop!
)