;;;;;;;;;;;;;;;;;;;;;<pre>
;;;
;;; ACT-R model of experiment 1 in the
;;; Hayman and Tulving paper,
;;; as reported in chapter 7
;;;
;;;
;;; Requires ACT-R 4.0 
;;;
;;; to run the model call
;;; (do-ht-experiment n)
;;; where n is the number of runs

;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; 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 *test1-words*)
(defvar *test2-words*)
(defvar *prebuffer-words*)
(defvar *postbuffer-words*)
(defvar *distract1-words*)
(defvar *distract2-words*)
(defvar *study-words*)
(defvar *stop-it*)
(defvar *answered*)
(defvar *which-test*)
(defvar *test-word*)
(defvar total-t1-st-cond)
(defvar total-t1-st-cond-shown)
(defvar total-t2-st-cond)
(defvar total-t2-st-cond-shown)
(defvar total-t2-st-cont)
(defvar total-t2-st-cont-shown)
(defvar total-t1-ns-cond)
(defvar total-t1-ns-cond-shown)
(defvar total-t2-ns-cond)
(defvar total-t2-ns-cond-shown)
(defvar total-t2-ns-cont)
(defvar total-t2-ns-cont-shown)
(defvar *correct-answer*)
(defvar *ht-low-ia*)
(defvar *ht-high-ia*)
(defvar *ht-pan*)
(defvar *ht-an*) 
(defvar *same-scores*)
(defvar *diff-scores*)
(defvar *ht-rt*)
(defvar *v*)
(defvar *factor*)
(defvar *penalty*)
(defvar *runs*)
(defvar *respond*)
(defvar *encode*)
(defvar *rehearse*)
(defvar *noise*)

(setf *respond* .5)
(setf *encode* .2)
(setf *rehearse* .5)

(setf *penalty* 15)
(setf *factor* .5)
(setf *ht-low-ia*  .4)
(setf *ht-high-ia* 3.8)
(setf *noise* .3)
(setf *ht-pan* (/ *noise* (sqrt 2)))
(setf *ht-an* (/ *noise* (sqrt 2))) 
(setf *ht-rt* -.45)
(setf *v* nil)
(setf *runs* 1)



(defparameter *letters-for-ht* #(A B C D E F G H I J K L M N O P Q R S T U V W X Y Z))
(defparameter *same-ht-data* '(.324 .168 .359 .198 .093 .183))
(defparameter *diff-ht-data* '(.353 .336 .369 .186 .191 .174))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; 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 "Hayman and Tulving Experiment model" 2)
        (:hidden :sy *ht-low-ia*  .4)
        (:hidden :sy *ht-high-ia* 3.8)
        (:table)
        
        (:table)
        "Noise (s): "   (:string :sy *noise* .3)             (:new-row)
        "Threshold: "                        (:string :sy *ht-rt* -.45)  (:new-row)
        "Scale factor (F): "                 (:string :sy *factor* .5)       (:new-row)
        "Mismatch Penalty:"                  (:string :sy *penalty* 1.5) (:new-row)
        "Response time (sec.): " (:string :sy *respond* .5)        (:new-row)
        "Encoding time (sec.): " (:string :sy *encode* .2)         (:new-row)
        "Rehearsal time (sec.): " (:string :sy *rehearse* .5) (:new-row)
        "Number of runs (1 - 20): "          (:string :sy *runs* 1)
        
        (:table-end)
        
        (:table)
        (:checkbox "Trace" :sy *v*  nil) (:new-row)
        (:table-end)
        
        (:table-end)
        
        (:new-para)
        (:button "Show Experiment Results" "(display-ht-results *same-ht-data* *diff-ht-data* nil)")
        (:new-para)
        (:button "Run model" "(progn 
                                (when (numberp *penalty*) 
                                   (setf *penalty* (* 10 *penalty*)))
                               (if (and (numberp *penalty*)
                                        (numberp *noise*) (numberp *ht-rt*) 
                                        (numberp *factor*) (numberp *runs*)
                                        (numberp *encode*) (numberp *rehearse*)
                                        (numberp *respond*))                  
                                       (progn
                                      (setf *ht-an* (/ *noise* (sqrt 2)))
                                      (setf *ht-pan* (/ *noise* (sqrt 2)))
                                      (do-ht-experiment (min 20 (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 about 1 minute for 1 run of the model"
        (:new-line)
        "- The trace of 1 run is approximatly 350k (250 pages) in size"
        (:new-para)))


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

;;; generate-n-unique-pairs-ht takes one 
;;; parameter, the number of letter pairs to generate,
;;; and returns the list containig n distinct
;;; letter pairs

(defun generate-n-unique-pairs-ht (n)
  (do ((count 0)
       (pairs nil)
       (pair (cons (string-upcase (format nil "LET-~a" (aref *letters-for-ht* (random 26)))) (string-upcase (format nil "LET-~a" (aref *letters-for-ht* (random 26)))))
             (cons (string-upcase (format nil "LET-~a" (aref *letters-for-ht* (random 26)))) (string-upcase (format nil "LET-~a" (aref *letters-for-ht* (random 26)))))))
      ((= count n) pairs)
    (unless (member pair pairs :test #'equal)
      (setf pairs (cons pair pairs))
      (incf count))))

;;; generate-words-ht creates the chunks
;;; for the letters, sets the similarity 
;;; between each one and the - (used to represent 
;;; a missing letter) to 1
;;; then generates the 4 letter 'words' to use
;;; for the stimuli by combinding distinct pairs
;;; such that no two words have the same first and third letters
;;; or the same second and fourth letters
;;; the chunks for the words are then created and
;;; the ia between the word and its first letter is set to *high-ia*
;;; and the ia between the word and the rest of the letters 
;;; is set to *low-ia*
;;; next the list of words is broken into the separate
;;; lists for the different parts of the experiment,
;;; and finally the baselevel activations are set for the
;;; words and for the letters

(defun generate-words-ht ()
  (dotimes (i 26)
    (add-dm-fct (list (list (intern (string-upcase (format nil "LET-~a" (aref *letters-for-ht* i)))) 'isa 'letter)))
    (setsimilarities-fct (list (list (intern (string-upcase (format nil "LET-~a" (aref *letters-for-ht* i)))) '- 1))))
  (let ((words nil))
    (do ((1-3-pairs (generate-n-unique-pairs-ht 224) (cdr 1-3-pairs))
         (2-4-pairs (generate-n-unique-pairs-ht 224) (cdr 2-4-pairs)))
        ((null 1-3-pairs))
      (let* ((first-pair (car 1-3-pairs))
             (second-pair (car 2-4-pairs))
             (word (intern (string-upcase (format nil "~a~a~a~a" (subseq (car first-pair) 4) (subseq (car second-pair) 4)
                                   (subseq (cdr first-pair) 4) (subseq (cdr second-pair) 4))))))
        (add-dm-fct (list (list word 'isa 'word 'first (intern (car first-pair)) 'second (intern (car second-pair))
                                'third (intern (cdr first-pair)) 'fourth (intern (cdr second-pair)))) :reset-ia nil)


        (setia-fct (list (list word (intern (car second-pair)) *ht-low-ia*)))
        (setia-fct (list (list word (intern (cdr first-pair)) *ht-low-ia*)))
        (setia-fct (list (list word (intern (cdr second-pair)) *ht-low-ia*)))
        (setia-fct (list (list word (intern (car first-pair)) *ht-high-ia*)))
        (setia-fct (list (list word '- .1)))


        (setia-fct (list (list (intern (car second-pair))  word *ht-low-ia*)))
        (setia-fct (list (list  (intern (cdr first-pair)) word  *ht-low-ia*)))
        (setia-fct (list (list  (intern (cdr second-pair)) word  *ht-low-ia*)))
        (setia-fct (list (list (intern (car first-pair)) word  *ht-high-ia*)))
        (setia-fct (list (list  '- word .1)))

        (setf words (cons (list word (car first-pair) (car second-pair) (cdr first-pair)
                                (cdr second-pair) (random 2)) words))))
    (setf *test1-words* (subseq words 0 32))
    (setf *test2-words* (subseq words 32 64))
    (setf *prebuffer-words* (subseq words 64 80))
    (setf *postbuffer-words* (subseq words 80 160))
    (setf *distract1-words* (subseq words 160 192))
    (setf *distract2-words* (subseq words 192))
    (setf *study-words* (append *prebuffer-words* (permut-for-ht (append *test1-words* *test2-words*)) *postbuffer-words*))
    (setallbaselevels 8 -10000)
    
    (dotimes (i 26)
      (setbaselevels-fct (list (list (intern (string-upcase (format nil "LET-~a" (aref *letters-for-ht* i)))) 200 -1000))))))

;;; permut-for-ht takes one parameter
;;; a list, and returns the same list in 
;;; a random order

(defun permut-for-ht (lis)
  (do ((result  (list (nth (random (length lis)) lis))
                (cons (nth (random (length lis)) lis) result)))
      ((null lis) result)
    (setf lis (remove (car result) lis :count 1))
    (cond ((null lis) (return result)))))

;;; do-ht-experiment takes one parameter, the
;;; number of runs throught the experiment
;;; to simulate, and then runs n simulations
;;; in both the same and different condition
;;; and displays the results

(defun do-ht-experiment (n)
  (setf *answered* (make-array 2))
  (setf *same-scores* (do-one-implicit-ht n t))
  (setf *diff-scores* (do-one-implicit-ht n nil))
  (display-ht-results *same-scores* *diff-scores* t))

;;; do-one-implicit-ht takes 2 parameters, the
;;; numbr of simulations to run, and whether the
;;; condition is the same fragment (same = t) or a different
;;; fragment (same = nil)
;;; it returns a list of the accuracies
;;; for each type of fragment

(defun do-one-implicit-ht (n same)
  (setf total-t1-st-cond 0)
  (setf total-t1-st-cond-shown 0 )
  (setf total-t2-st-cond 0)
  (setf total-t2-st-cond-shown 0)
  (setf total-t2-st-cont 0)
  (setf total-t2-st-cont-shown 0)
  (setf total-t1-ns-cond 0)
  (setf total-t1-ns-cond-shown 0)
  (setf total-t2-ns-cond 0)
  (setf total-t2-ns-cond-shown 0)
  (setf total-t2-ns-cont 0)
  (setf total-t2-ns-cont-shown 0)
  
  (dotimes (i n)
    (run-implicit-ht-experiment same))
  
  (list  (/ total-t1-st-cond total-t1-st-cond-shown )
         (/ total-t2-st-cond total-t2-st-cond-shown)
         (/ total-t2-st-cont total-t2-st-cont-shown )
         (/ total-t1-ns-cond total-t1-ns-cond-shown )
         (/ total-t2-ns-cond total-t2-ns-cond-shown )
         (/ total-t2-ns-cont total-t2-ns-cont-shown )))
 

;;; set-implicit-ht-parameters 
;;; sets the ACT-R parameters for the simulation
;;; it is called prior to each run

(defun set-implicit-ht-parameters ()
  (sgp-fct (list :al nil :bll .5 :era t :pm t :mp *penalty* :ans *ht-an* :pas *ht-pan* :rt *ht-rt* :lf *factor* :v *v*))
  (parameters-fct 'complete-word (list :effort *respond*))
  (parameters-fct 'rehearse-word (list :effort *rehearse*))
  (parameters-fct 'attend (list :effort *encode*)))

;;; run-implicit-ht-experiment takes one parameter
;;; which specifies the type of fragment to display
;;; in test 2 for the incorrect responses from test 1
;;; if same is t then the same fragment is shown, if
;;; it is nil then the opposite fragment is shown
;;; first the list of words is studied,
;;; then the two test phases are run

(defun run-implicit-ht-experiment (same)
  (reset)
  (set-implicit-ht-parameters)
  (generate-words-ht)
  (setf *stop-it* 0) 
  (setf (aref *answered* 0) nil)
  (setf (aref *answered* 1) nil)
  (add-dm-fct '((goal isa study-words))  :reset-ia nil)
  
  (wmfocus goal) 
  
  (run)

  (actr-time 180)
  (setf *which-test* 0)
  
  (dolist (x (permut-for-ht (append *distract1-words* *test1-words*)))
    (if (= (nth 5 x) 0)
        (mod-chunk-fct 'newgoal  (list  'first (intern (nth 1 x)) 'second '- 'third (intern (nth 3 x)) 'fourth '- ))
        (mod-chunk-fct 'newgoal (list  'first '- 'second (intern (nth 2 x)) 'third '- 'fourth (intern (nth 4 x)) )))
    (wmfocus newgoal)
    (setbaselevels (newgoal 2))
    (setf *test-word* (car (no-output (swm-fct (list 'isa 'word 'first (intern (nth 1 x)) 'third (intern (nth 3 x)))))))
    
    (setf *correct-answer* nil)
    
    (run))
  
  (actr-time 180)
   
  (setf *which-test* 1)
  
  (let ((missed (missed-test1-for-ht)))
    
    (dolist (x (permut-for-ht (append *distract2-words* *test2-words* (missed-test1-for-ht))))
      (if (member x missed :test #'equal)
          (if same
              (if (= (nth 5 x) 0)
                  (mod-chunk-fct 'newgoal (list  'first (intern (nth 1 x)) 'second '- 'third (intern (nth 3 x)) 'fourth '- ))
                  (mod-chunk-fct 'newgoal (list  'first '- 'second (intern (nth 2 x)) 'third '- 'fourth (intern (nth 4 x)) )))
              (if (= (nth 5 x) 0)
                  (mod-chunk-fct 'newgoal (list  'first '- 'second (intern (nth 2 x)) 'third '- 'fourth (intern (nth 4 x)) ))
                  (mod-chunk-fct 'newgoal (list  'first (intern (nth 1 x)) 'second '- 'third (intern (nth 3 x)) 'fourth '- ))))
          (if (= (nth 5 x) 0)
              (mod-chunk-fct 'newgoal (list  'first (intern (nth 1 x)) 'second '- 'third (intern (nth 3 x)) 'fourth '- ))
              (mod-chunk-fct 'newgoal (list  'first '- 'second (intern (nth 2 x)) 'third '- 'fourth (intern (nth 4 x)) ))))
      (wmfocus newgoal)
      (setbaselevels (newgoal 2))
      (setf *test-word* (car (no-output (swm-fct (list 'isa 'word 'second (intern (nth 2 x)) 'fourth (intern (nth 4 x)))))))
      (setf *correct-answer* nil)

      (run)))
  (stats-for-ht))

;;; get-word-for-ht takes no parameters,
;;; and sets the stopping time, and returns the next word

(defun get-word-for-ht (goal)
  (let ((word (pop *study-words*)))
    (setf *stop-it* (+ 4.0 *stop-it*))
;    (modwme-fct goal (list 'word (car word)))
    (car word)))
 
;;; missed-test1-for-ht takes no parameters
;;; and returns the list of words that were 
;;; answered incorrectly on the first test
 
(defun missed-test1-for-ht ()
  (let ((test1-words (append *test1-words* *distract1-words*)))
    (dolist (x (aref *answered* 0) test1-words)
      (when (member x test1-words :key #'car :test #'eq)
        (setf test1-words (remove x test1-words :key #'car :test #'eq :count 1))))))

;;; count-words-for-ht takes 2 parameters
;;; takes 2 lists of words, and returns the 
;;; number of words in the first list that are 
;;; in the second list

(defun count-words-for-ht (words which-list)
  (let ((n 0))
    (dolist (x words n)
    (when (member x which-list :key #'car :test #'eq)
      (incf n)))))

;;; stats-for-ht takes no parameters,
;;; and increments the global variables for the 
;;; statistics of the experiment

(defun stats-for-ht ()
  (let* ((t1-st-cond-count (count-words-for-ht (aref *answered* 0) *test1-words*))
         (t1-ns-cond-count (count-words-for-ht (aref *answered* 0) *distract1-words*)))
 
    (incf total-t1-st-cond t1-st-cond-count)
    (incf total-t1-st-cond-shown 32)
    (incf total-t2-st-cond (count-words-for-ht (aref *answered* 1) *test1-words*))
    (incf total-t2-st-cond-shown (- 32 t1-st-cond-count))
    (incf total-t2-st-cont (count-words-for-ht (aref *answered* 1) *test2-words*))
    (incf total-t2-st-cont-shown 32)
    (incf total-t1-ns-cond t1-ns-cond-count)
    (incf total-t1-ns-cond-shown 32)
    (incf total-t2-ns-cond (count-words-for-ht (aref *answered* 1) *distract1-words*))
    (incf total-t2-ns-cond-shown (- 32 t1-ns-cond-count))
    (incf total-t2-ns-cont (count-words-for-ht (aref *answered* 1) *distract2-words*))
    (incf total-t2-ns-cont-shown 32)))

;;; ht-exp-response takes one parameter
;;; a word, and adds that word to the proper list of 
;;; correctly answered words, and sets the *correct-answer*
;;; flag to t

(defun ht-exp-response (word)
  (setf *correct-answer* t)
  (setf (aref *answered* *which-test*) (cons word (aref *answered* *which-test*))))


;;; display-ht-results takes three parameters,
;;; the data for the same condition, the data for the
;;; different condition, and wheter the data is for the
;;; simulation or not, and displays a table with
;;; the results listed as percentages

(defun display-ht-results (same-data diff-data simulation)
  (when simulation 
    (format *standard-output* "~%~%Parameters for run: (~S ~S ~S ~S ~S ~S ~S ~S)~%"
            *noise* *ht-rt* *factor* *penalty* *respond* *encode* *rehearse* *runs*))

  (format *standard-output* "~%~a data:~%~%" (if simulation "Simulation" "Experimental"))

  (format *standard-output* "                   Studied Words        Nonstudied Words~%")
  (format *standard-output* "                 Test 1     Test 2     Test 1     Test 2~%")
  (format *standard-output* "                              Same fragments~%~%")
  (format *standard-output* "Conditional      ~4,1F%      ~4,1F%      ~4,1F%     ~4,1F%~%" (* 100 (nth 0 same-data)) (* 100 (nth 1 same-data)) (* 100 (nth 3 same-data)) (* 100 (nth 4 same-data)))
  (format *standard-output* "Control                     ~4,1F%                ~4,1F%~%~%" (* 100 (nth 2 same-data)) (* 100 (nth 5 same-data)))
  (format *standard-output* "                           Different fragments~%~%")
  (format *standard-output* "Conditional      ~4,1F%      ~4,1F%      ~4,1F%     ~4,1F%~%" (* 100 (nth 0 diff-data)) (* 100 (nth 1 diff-data)) (* 100 (nth 3 diff-data)) (* 100 (nth 4 diff-data)))
  (format *standard-output* "Control                     ~4,1F%                ~4,1F%~%~%" (* 100 (nth 2 diff-data)) (* 100 (nth 5 diff-data))))



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

(clearall)

;; chunks for study items
      
(chunk-type word first second third fourth)

(chunk-type letter)

;; chunks for goals 

(chunk-type study-words word)

(chunk-type rehearse-word word)

(chunk-type complete-words first second third fourth)


(add-dm (- isa letter)
        (newgoal isa complete-words))


;;; productions

(p attend
"
  IF the goal is to study words
     and the time has not expired
     and there are words to study
  THEN create and push a  goal to 
     rehearse the current word
"
  =goal>
     isa study-words
      
  !eval! (>= (actr-time) *stop-it*)

  !eval! *study-words*
==>
  =newgoal>
     isa rehearse-word
     word (!eval! (get-word-for-ht =newgoal))
 
;     !eval! (get-word-for-ht =newgoal)
  
   !push! =newgoal
)

(parameters-fct 'attend (list :effort *encode*))


(p rehearse-word
"
  IF the goal is to rehearse a word
     and the word and all of its
     letters can be retrieved
     and there is still time to rehearse it
  THEN report that it is being rehearsed
"
   =goal>
      isa rehearse-word
      word =word

   =word>
      isa word
      first =f
      second =s
      third =t
      fourth =fo
   =f>
      isa letter

   =s>
      isa letter

   =t>
      isa letter

   =fo>
      isa letter

   !eval! (< (actr-time) *stop-it*)

==>
   !output! ("Rehearsing ~S.~%" =word)
)

(parameters-fct 'rehearse-word (list :effort *rehearse*))


(p rehearse-skip
"
  IF the goal is to rehearse a word
  THEN do nothing
"
   =goal>
      isa rehearse-word
   
   !eval! (< (actr-time) *stop-it*)
==>
)

(parameters rehearse-skip :r .5)


(p done-rehearsing
"
  IF the goal is to rehearse a word
     and the time has passed 
  THEN pop the goal
"
   =goal>
      isa rehearse-word

   !eval! (>= (actr-time) *stop-it*)
==>
   !pop!
)


(p complete-word
"
  IF the goal is to complete a word
     and the letters and a word
     composed of those letters
     can be retrieved 
     and the word matches the
     presented word
  THEN respond with the word
     and pop the goal
"
   =goal>
      isa complete-words
      first =f
      second =s
      third =t
      fourth =fo

   =f>
      isa letter

   =s>
      isa letter

   =t>
      isa letter

   =fo>
      isa letter

   =word>
      isa word
      first =f
      second =s
      third =t
      fourth =fo

   !eval! (eq =word *test-word*)
==>
   !output! ("completes word as ~S~%" =word)

   !eval! (ht-exp-response =word)

   !pop!
)

(parameters-fct 'complete-word (list :effort *respond*))


(p cant-complete
"
  IF the goal is to complete a word
  THEN pop the goal
"
   =goal>
      isa complete-words
==>
   !pop!
)

(parameters cant-complete :r .5 :effort 15)