;;;;;;;;;;;;;;;;;;;;<pre><xmp>
;;;
;;; ACT-R 4.0 model 
;;;
;;; to run the model call
;;; (run-all-tw-law n m)
;;; where n is the number of words per study list
;;; and m is the number of runs of the model


(defvar *a-words*)
(defvar *b-words*)
(defvar *study-list*)
(defvar *pas*)
(defvar *ans*)
(defvar *results*)
(defvar *rt*)
(defvar *s*)
(defvar *display-table*)
(defvar *all-results*)
(defvar *final-stats*)
(defvar *words*)
(defvar *num-runs*)
(defvar *v*)
(defvar *text*)
(defvar *graphic*)
(defvar *overlay*)

(setf *pas* .5)
(setf *ans* .5)
(setf *rt* 0)
(setf *s* 0.5)
(setf *words* 40)
(setf *num-runs* 1)
(setf *v* nil)
(setf *text* t)
(setf *graphic* nil)
(setf *overlay* nil)
(setf *display-table* nil)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; 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 "Tulving-Wiseman Law model" 2)
        (:table)
        
        (:table)
        "Permanant noise: "     (:string :sy *pas*   .5)  (:new-row)
        "Transient noise:"    (:string :sy *ans* .5) (:new-row)
        "Relational noise:"     (:string :sy *s*   0.5)    (:new-row)
        "Response threshold: "  (:string :sy *rt* 0)  (:new-row)
        "Words per list (10-100): "  (:string :sy *words* 40)  (:new-row)
        "Number of runs (1-50):"  (:string :sy *num-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 values from the Tulving-Wiseman Law" "(progn
                                                              (setf *final-stats* nil)
                                                             (dotimes (i 21)
                                                                (setf *final-stats* (cons (list (- 1 (* i .05)) (tw-law (- 1 (* i .05)))) *final-stats*)))
                                                             (display-tw-law *final-stats* nil))")
       
        (:new-para)
        
        (:button "Run model" "
                              (if (and (numberp *pas*) (numberp *ans*) (numberp *num-runs*)
                                        (numberp *s*) (numberp *rt*) (numberp *words*))
                                                (run-all-tw-law (min 100 (max 10 *words*)) (min 50 (max 1 *num-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 about 1 minute for 10 runs of the model with 40 words"
        (:new-line)
        "- The trace of 1 run of 40 words is approximatly 600k (400 pages) in size"
        (:new-para)))



(defun generate-words-tw-law (n s)
  (let ((word-list nil))
    (dotimes (i n word-list)
        (push  (gensym s) word-list))))

(defun noisy-ia-tw-law (s)
    (let ((p (random 1.0)))
    (* s (log (/ p (- 1.0 p))))))

(defun create-word-chunks-tw-law (n)
  (let* ((a-words (generate-words-tw-law n "A"))
        (b-words (generate-words-tw-law n "B"))
        (a-s a-words)
        (b-s b-words))
    (dotimes (i n)
      (let ((a (random-member-tw-law a-s))
            (b (random-member-tw-law b-s)))
        (addwm-fct (list (list b 'isa 'word )))
        (addwm-fct (list (list a 'isa 'word )))
        (set-ia-fct (list (list b a (noisy-ia-tw-law *s*))))
        (setf a-s (remove a a-s))
        (setf b-s (remove b b-s))))

    (list a-words b-words)))

(defun add-noise-to-ia-tw-law (x)
        (set-ia-fct (list (list (chunk-slot-value-fct x 'a) x (+ 4.0 (noisy-ia-tw-law *s*))))))

(defun optimize-tw-law (list-len num-lists)
  (optimize-multidimensional
   '((*ans* 1 0.2 0.05)
     (*pas* 1 0.2 0.05)
     (*s* 1 0.2 0.05))
   (list 'run-all-tw-law list-len num-lists)
   '(deviate-tw-law *final-stats*)))

(defun random-member-tw-law (l)
  (nth (random (length l)) l))

(defun tw-law (x)
  (+ x (* .5 (- x (* x x)))))


(defun randomize-list-tw-law (l)
  (do* ((item (random-member-tw-law l) (random-member-tw-law nl))
        (nl (remove item l) (remove item nl))
        (rl (list item) (cons item rl)))
       ((null nl) rl)))
       

(defun recog-test-tw-law ()
  (setf *results* nil)
  (dolist (i (randomize-list-tw-law *b-words*))
    (let ((g 'goal1))
      (mod-chunk-fct g (list 'word i))
      (goal-focus-fct (list g))
      (run))))

(defun recall-test-tw-law ()
  (dolist (i (randomize-list-tw-law *a-words*))
    (let ((g 'goal2))
     (mod-chunk-fct g (list 'cue i))
      (goal-focus-fct (list g))
      (run))))

(defun run-all-tw-law (list-len num-lists)
  (setf *all-results* nil)
  (setf *final-stats* nil)
  (let ((trials '(0.5 0.25 0
                  -.25 -.50 -.75 -1.00 -1.25 -1.5 -1.75 -2.00 -2.25 -2.5 -2.75 -3.00 -3.25 -3.5
                  -3.75 -4 -4.25 -4.5 -4.75 -5.0 -5.25 -5.5)))
  (dotimes (i num-lists)
    (dotimes (i (length trials))
      (run-experiment-tw-law list-len (nth i trials))
      (let ((res (analyze-results-tw-law *results*)))
        (let ((ent (assoc (nth i trials) *all-results*)))
          (if ent
              (setf (second ent) (mapcar #'+ res (second ent)))
              (setf *all-results* (cons (list (nth i trials) res) *all-results*)))))))

  (dolist (x *all-results*)
    (let* ((vals (second x))
           (a (first vals))
           (b (second vals))
           (c (third vals))
           (d (fourth vals))
           (recog (if (zerop (+ a b c d)) 0.0 (/ (+ a c) (+ a b c d))))
           (tw-val (tw-law recog))
           (recoggivenrecall (if (zerop (+ a b)) 0.0 (/ a (+ a b)))))
      (setf *final-stats* (cons (list recog tw-val recoggivenrecall) *final-stats*)))))
  (display-tw-law *final-stats* t))


(defun display-tw-law (data simulation)
  (let ((law nil))
    (setf data (sort data #'< :key #'first))

    (when (and simulation *overlay*)
      (dotimes (i 21)
        (setf law (cons (list (- 1 (* i .05)) (tw-law (- 1 (* i .05)))) law))))
    
    (when simulation
      (format *standard-output* "~%~%Parameters for run: (~S ~S ~S ~S ~S ~S)"
              *pas* *ans* *s* *rt* *words* *num-runs*))
    
    (when *text*
      (format *standard-output* "~%~%~a data:~%~%" (if simulation "Simulation" "Tulving-Wiseman Law"))
      
      (format *standard-output* "P(Rn)        P(Rn|Rc)~%")
      
      (dolist (x data)
        (format *standard-output* "~5,3f        ~5,3f~%" (first x) (if simulation (third x) (second x))))
      
      (format *standard-output* "~%")
      
      (when (and simulation *overlay*)
        (format *standard-output* "~%Tulving-Wiseman Law data:~%~%")
        
        (format *standard-output* "P(Rn)        P(Rn|Rc)~%")
        
        (dolist (x data)
          (format *standard-output* "~5,3f        ~5,3f~%" (first x) (second x)))
        
        (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 = 500 
        height = 500> 

        <PARAM name=\"title\" value=\"Tulving-Wiseman Law\">
        <PARAM name=\"xmin\" value=\"0\">
        <PARAM name=\"xmax\" value=\"1.0\">
        <PARAM name=\"ymax\" value=\"1.0\">
        <PARAM name=\"ymin\" value=\"0\">
        <PARAM name=\"ydiv\" value=\".05\">
        <PARAM name=\"yspacing\" value=\".1\">
        <PARAM name=\"xdiv\" value=\".05\">
        <PARAM name=\"xspacing\" value=\".1\">
        <PARAM name=\"numlines\" value=\"~s\">
        <PARAM name=\"longestline\" value=\"~s\">
        <PARAM name=\"lcolor0\" value=\"0\">
        <PARAM name=\"lstyle0\" value=\"~s\">
        <PARAM name=\"xname\" value=\"P(Rn)\">
        <PARAM name=\"yname\" value=\"P(Rn|Rc)\">"
              (if (and simulation *overlay*) 2 1) 
              (if (and simulation *overlay*) (max (length data) (length law)) (length data))
              (if simulation 2 6553))
      
      
      
      (format *standard-output* "<PARAM name=\"xval0\" value=\"")
      
      (dolist (x data)
        (format *standard-output* "~3,2f;" (first x)))
      
      (format *standard-output* "\">")
       
      (format *standard-output* "<PARAM name=\"name0\" value=\"~a\">"
              (if simulation "Simulation" "Tulving-Wiseman Law"))
      
      (format *standard-output* "<PARAM name=\"yval0\" value=\"")
      
      (dolist (x data)
        (format *standard-output* "~3,2f;" (if simulation (third x) (second x))))
      
      (format *standard-output* "\">")
      
      
      (when (and simulation *overlay*)
        
        (format *standard-output* "
        <PARAM name=\"lcolor1\" value=\"0\">
        <PARAM name=\"lstyle1\" value=\"6553\">
        <PARAM name=\"xval1\" value=\"")
        
        (dolist (x law)
          (format *standard-output* "~3,2f;" (first x)))
        
        (format *standard-output* "\">")
        
        (format *standard-output* "<PARAM name=\"name1\" value=\"Tulving-Wiseman Law\">")
        
        (format *standard-output* "<PARAM name=\"yval1\" value=\"")
        
        (dolist (x law)
          (format *standard-output* "~3,2f;" (second x)))
        
        (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 deviate-tw-law (res)
  (apply #'+ (map 'list #'(lambda (x) (let ((y (- (second x) (third x)))) (* y y))) res)))


(defun run-experiment-tw-law (n base)
  (reset)
  (sgp-fct (list :rt *rt* :pas *pas* :ans *ans* :er t :v *v* :blc base))
  
  (let ((words (create-word-chunks-tw-law n))
        (g (gensym "GOAL")))
    (setf *a-words* (car words))
    (setf *b-words* (second words))
    (setf *study-list* (map 'list #'cons *a-words* *b-words*))
    (add-dm-fct (list (list g 'isa 'study-pair 'context 'c1)))
    (goal-focus-fct (list g))
    (run) 
    (add-dm (goal1 isa recognize context c1) (goal2 isa recall context c1))
    (mapcar 'add-noise-to-ia-tw-law (no-output (swm isa memory-token)))
    (recog-test-tw-law)
    (recall-test-tw-law)))

(defun analyze-results-tw-law (results)
  (let ((a 0)
        (b 0)
        (c 0)
        (d 0))
    (dolist (i results)
      (when (and (= 0 (second i)) (= 0 (third i))) (incf d))
      (when (and (= 0 (second i)) (= 1 (third i))) (incf b))
      (when (and (= 1 (second i)) (= 0 (third i))) (incf c))
      (when (and (= 1 (second i)) (= 1 (third i))) (incf a)))

    (when *display-table* (format t "~%~4d ~4d~%~4d ~4d~%" a b c d))

    (list a b c d)))


(defun recog-count-tw-law (word val)
  (setf *results* (cons (list word val 0) *results*)))

(defun recall-count-tw-law (word val)
  (setf (third (assoc word *results*)) val))


(defun items-remaining-tw-law ()
  (not (null *study-list*)))

(defun get-current-a-tw-law ()
  (car (no-output (wm-fct (list (caar *study-list*))))))

(defun get-current-b-tw-law ()
  (car (no-output (wm-fct (list (cdr (pop *study-list*)))))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;</xmp><pre><a name="model">
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;</a>
;;;
;;; The ACT-R model

(clearall)

(chunk-type word)
(chunk-type  memory-token a b context)
(chunk-type context)
(chunk-type recall cue context)
(chunk-type recognize word context)
(chunk-type study-pair context)

(add-dm (c1 isa context))



(p attend
"
  IF the goal is to study words 
  THEN create a memory token of the current context
     mark it in the goal
     and push the memory token on the goal stack
"
   =goal>
      isa study-pair
      context =context

   !eval! (items-remaining-tw-law)
==>
   =newgoal>
      isa memory-token
      context =context

   !push! =newgoal
)


(p create-token
"
  IF the goal is a memory token
  THEN store the word chunk in the goal
     and create a rehearsal fact for this word
     and focus on the rehearsal fact
"
   =goal>
      isa memory-token
      a nil
      b nil
==>
   !bind! =a  (get-current-a-tw-law)
   !bind! =b (get-current-b-tw-law)

   =goal>
       a =a
       b =b
)


(p study-item
"
"
   =goal>
      isa memory-token
      a =a
      b =b
      context =c

   =a>
     isa word

   =b>
      isa word
==>
   !pop!
)




(p recognize-word
   =goal>
      isa recognize
      word =word
      context =context

   =mem-token>
      isa memory-token
      context =context
      b =word
==>
  !eval! (recog-count-tw-law =word 1)
  !pop!
)

(p dont-recognize
   =goal>
   isa recognize
   word =word
   context =context
==>
   !eval! (recog-count-tw-law =word 0)
   !pop!
)

(parameters dont-recognize :r .5)

(p recall-word
   =goal>
      isa recall
      cue =cue
      context =context

   =mem-token>
      isa memory-token
      a =cue
      b =word

==>
  !eval! (recall-count-tw-law =word 1)
  !pop!
)

(p dont-recall
   =goal>
   isa recall
   cue =cue
   context =context
==>
   !pop!
)

(parameters dont-recall :r .5)