;;;;;;;;;;;;;;;;;;;;;;;;<pre><xmp>
;;;
;;;
;;; Requires ACT-R 4.0
;;;
;;; to run the model call
;;; (do-jacoby-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 *deep-words*)
(defvar *shallow-words*)
(defvar *prebuffer-words*)
(defvar *postbuffer-words*)
(defvar *distract-words*)
(defvar *study-words*)
(defvar *stop-it*)
(defvar *answered*)
(defvar *condition*)
(defvar *which-test*)
(defvar *which-condition*)
(defvar *test-word*)
(defvar *correct-answer*)
(defvar *low-ia*)
(defvar *high-ia*)
(defvar *an*)
(defvar *rt*)
(defvar *v*)
(defvar *factor*)
(defvar *penalty*)
(defvar *runs*)
(defvar *respond*)
(defvar *encode*)
(defvar *rehearse*)


(setf *respond* .5)
(setf *encode* .2)
(setf *rehearse* 2.0)
(setf *penalty* 15)
(setf *factor* .5)
(setf *low-ia*  .4)
(setf *high-ia* 3.8)
(setf *an* .45)
(setf *rt* 0.1)
(setf *v* nil)
(setf *runs* 1)

(defparameter *letters-for-jacoby* #(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 *jacoby-results* (make-array '(3 3) :initial-contents '((.51 .45 .30)(.60 .47 .29)(.33 .43 .26))))
(defparameter *total-jacoby* (make-array '(3 3) :initial-contents '((40 40 80) (40 40 80) (40 40 80))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; 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 "Process Dissociation Model" 2)
        (:hidden :sy *low-ia*  .4)
        (:hidden :sy *high-ia* 3.8)
        (:table)

        (:table)
        "Noise (s): "   (:string :sy *an* .45)             (:new-row)
        "Threshold: "                        (:string :sy *rt* 0.1)  (: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* 2) (: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-jacoby-results *jacoby-results* nil)")
        (:new-para)
        (:button "Run model" "(progn 
                               (when (numberp *penalty*) 
                                (setf *penalty* (* 10 *penalty*)))
                               (if (and (numberp *penalty*) (numberp *an*) 
                                        (numberp *rt*) (numberp *factor*) 
                                        (numberp *runs*) (numberp *encode*) 
                                        (numberp *rehearse*) 
                                        (numberp *respond*))  
                                 (progn  
                                    (do-jacoby-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 90k (60 pages) in size"
        (:new-para)))

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

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

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




;;; generate-words-jacoby 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-jacoby ()
  (dotimes (i 26)
    (add-dm-fct (list (list (intern (string-upcase (format nil "LET-~a" (aref *letters-for-jacoby* i)))) 'isa 'letter)))
    (setsimilarities-fct (list (list (intern (string-upcase (format nil "LET-~a" (aref *letters-for-jacoby* i)))) '- 1))))
  (let ((words nil))
    (do ((1-2-pairs (generate-n-unique-pairs-jacoby 164) (cdr 1-2-pairs))
         (3-4-pairs (generate-n-unique-pairs-jacoby 328) (cddr 3-4-pairs)))
        ((null 1-2-pairs) words)
      (let* ((first-pair (car 1-2-pairs))
             (second-pair (car 3-4-pairs))
             (third-pair (second 3-4-pairs))
             (word1 (intern (string-upcase (format nil "~a~a~a~a" (subseq (car first-pair) 4) 
                                   (subseq (cdr first-pair) 4) (subseq (car second-pair) 4)
                                   (subseq (cdr second-pair) 4)))))
             (word2 (intern (string-upcase (format nil "~a~a~a~a" (subseq (car first-pair) 4) 
                                   (subseq (cdr first-pair) 4) (subseq (car third-pair) 4)
                                   (subseq (cdr third-pair) 4))))))
        (add-dm-fct (list (list word1 'isa 'word 'first (intern (car first-pair)) 'second (intern (cdr first-pair))
                                'third (intern (car second-pair))  'fourth (intern (cdr second-pair)))) :reset-ia nil)
        (add-dm-fct (list (list word2 'isa 'word 'first (intern (car first-pair)) 'second (intern (cdr first-pair))
                                'third (intern (car third-pair))  'fourth (intern (cdr third-pair)))) :reset-ia nil)
        (setia-fct (list (list word1 (intern (car second-pair)) 100)))
        (setia-fct (list (list word1 (intern (cdr first-pair)) 100)))
        (setia-fct (list (list word1 (intern (cdr second-pair)) 100)))
        (setia-fct (list (list word1 (intern (car first-pair)) 100)))
        (setia-fct (list (list word1 '- .1)))
        (setia-fct (list (list word2 (intern (car third-pair)) 100)))
        (setia-fct (list (list word2 (intern (cdr first-pair)) 100)))
        (setia-fct (list (list word2 (intern (cdr third-pair)) 100)))
        (setia-fct (list (list word2 (intern (car first-pair)) 100)))
        (setia-fct (list (list word2 '- .1)))
        (setia-fct (list (list (intern (car second-pair))  word1 *low-ia*)))
        (setia-fct (list (list  (intern (cdr first-pair)) word1  *low-ia*)))
        (setia-fct (list (list  (intern (cdr second-pair)) word1  *low-ia*)))
        (setia-fct (list (list (intern (car first-pair)) word1  *high-ia*)))
        (setia-fct (list (list  '- word1 .1)))
        (setia-fct (list (list (intern (car third-pair))  word2 *low-ia*)))
        (setia-fct (list (list  (intern (cdr first-pair)) word2  *low-ia*)))
        (setia-fct (list (list  (intern (cdr third-pair)) word2  *low-ia*)))
        (setia-fct (list (list (intern (car first-pair)) word2  *high-ia*)))
        (setia-fct (list (list  '- word2 .1)))
        (setia-fct (list (list word1 word1 100)))
        (setia-fct (list (list word2 word2 100)))
        (setf words (append (list word1) words (list word2)))))
    (setf *deep-words* (subseq words 0 40))
    (setf *shallow-words* (subseq words 40 80))
    (setf *prebuffer-words* (subseq words 80 82))
    (setf *postbuffer-words* (subseq words 82 84))
    (setf *distract-words* (subseq words 84 164))
    (setf *study-words* (append *prebuffer-words* (permut-for-jacoby (append *deep-words* *shallow-words*)) *postbuffer-words*))
    (setallbaselevels 6 -1000)
    (dotimes (i 26)
      (setbaselevels-fct (list (list (intern (string-upcase (format nil "LET-~a" (aref *letters-for-jacoby* i)))) 200 -1000))))))

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

(defun permut-for-jacoby (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-jacoby-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-jacoby-experiment (n)
  (setf *answered* (make-array '(3 3) :initial-element 0))
  (dotimes (count n)
    (run-implicit-jacoby-experiment 'indirect)
    
    (run-implicit-jacoby-experiment 'inclusion)
    
    (run-implicit-jacoby-experiment 'exclusion))
  (dotimes (i 3)
    (dotimes (j 3)
      
      (setf (aref *answered* i j) (* 1.0 (/ (aref *answered* i j) (* n (aref *total-jacoby* i j)))))))
  (display-jacoby-results *answered* t))


(defun set-implicit-jacoby-parameters ()
  (sgp-fct (list :al nil :bll .5 :era t :pm t :mp *penalty* :ans *an* :rt *rt* :lf *factor* :v *v*))
  (parameters-fct 'complete-word-indirect (list :effort *respond*))
  (parameters-fct 'rehearse-word-deep (list :effort *rehearse*))
  (parameters-fct 'attend (list :effort *encode*))
  (parameters-fct 'complete-word-inclusion-2 (list :effort *respond*))
  (parameters-fct 'complete-word-inclusion-4 (list :effort *respond* :r .5))
  (parameters-fct 'complete-word-exclusion-4 (list :effort *respond* :r .75)))

;;; 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-jacoby-experiment (cond)
  (let ((count))
    (case cond (indirect (setf *which-condition* 0))
          (inclusion (setf *which-condition* 1))
          (exclusion (setf *which-condition* 2)))        
    (setf *condition* cond)
    (reset)
    (set-implicit-jacoby-parameters)
    (no-output (generate-words-jacoby))
    (setf *stop-it* 0)
    (add-dm-fct '((goal isa study-words))  :reset-ia nil)
    
    (wmfocus goal) 
    (run) 
    (setf count 0)
    
    (dolist (x (permut-for-jacoby (append *distract-words* *shallow-words* *deep-words*)))
      (mod-chunk-fct 'newgoal  (list  'first (eval `(chunk-slot-value ,x first))
                                      'second (eval `(chunk-slot-value ,x second))
                                      'third '-  'fourth '- ))
      (actr-time-fct (- (+ count 336) (actr-time)))
      (setf count (+ count 5))
      (wmfocus newgoal)
      (setbaselevels (newgoal 2))
      (setf *test-word* (car (no-output (dm-fct (list x)))))
      (setf *correct-answer* nil)
      (cond ((member x *deep-words*) (setf *which-test* 0))
            ((member x *shallow-words*) (setf *which-test* 1))
            (t (setf *which-test* 2)))
      (run))))


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

(defun get-word-for-jacoby ()
  (let ((word (pop *study-words*)))
    (setf *stop-it* (+ 4.0 *stop-it*))
    (car (no-output (wm-fct (list word))))))


;;; jacoby-exp-response 

(defun jacoby-exp-response (word)
  
  (cond ((equal word *test-word*)
         (setf (aref *answered* *which-condition* *which-test*) (1+ (aref *answered* *which-condition* *which-test*))))))

;;; display-jacoby-results

(defun display-jacoby-results (data sim)
  (when sim
    (format *standard-output* "~%~%Parameters for run: (~S ~S ~S ~S ~S ~S ~S ~S)~%"
            *an* *rt* *factor* (/ *penalty* 10) *respond* *encode* *rehearse* *runs*))

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

  (format *standard-output* "                                        Study Processing~%")
  (format *standard-output* "Performance Measure	Semantic	Nonsemantic	New~%")
  (format *standard-output* "~%Test~%")
  (format *standard-output* "Indirect                ~5,2F             ~5,2F        ~5,2F~%" (aref data 0 0) (aref data 0 1) (aref data 0 2))
  (format *standard-output* "Inclusion               ~5,2F             ~5,2F        ~5,2F~%" (aref data 1 0) (aref data 1 1) (aref data 1 2))
  (format *standard-output* "Exclusion               ~5,2F             ~5,2F        ~5,2F~%" (aref data 2 0) (aref data 2 1) (aref data 2 2))
  (format *standard-output* "~%Estimate~%")
  (format *standard-output* "Controlled              ~5,2F             ~5,2F~%" (- (aref data 1 0) (aref data 2 0)) (- (aref data 1 1) (aref data 2 1)))
  (format *standard-output* "Automatic               ~5,2F             ~5,2F~%~%" (/ (aref data 2 0) (- 1 (- (aref data 1 0) (aref data 2 0))))
          (/ (aref data 2 1) (- 1 (- (aref data 1 1) (aref data 2 1))))))



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

(clearall)

(sgp :v nil)

;; chunks for study items

(chunk-type word first second third fourth tag)

(chunk-type letter)

;; chunks for goals

(chunk-type study-words word)
(chunk-type memory-token item context)
(chunk-type rehearse-word word)

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

(add-dm (- isa letter) (list isa chunk)
        (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
     word nil

  !eval! *study-words*
==>
  =goal>
      word (!eval! (get-word-for-jacoby )))

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

(p push-rehearse
  =goal>
     isa study-words
     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
==>
  =goal>
     word nil
  =memory-token>
      isa memory-token
      item =word
      context list
  =newgoal>
     isa rehearse-word
     word =word
   !push! =newgoal
)

(p rehearse-word-deep
"
  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
   !eval! (member =word *deep-words*) ;(car (get-name-fct (list =word)))
   =word>
      isa word
   =context>
      isa memory-token
      item =word
      context list
   !eval! (< (actr-time) *stop-it*)

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

(parameters-fct 'rehearse-word-deep (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 :effort 1.0)

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

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

(p complete-word-indirect
"
  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
!eval! (equal *condition* 'indirect)

   =f>
      isa letter

   =s>
      isa letter

   =t>
      isa letter

   =fo>
      isa letter

   =word>
      isa word
      first =f
      second =s
      third =t
      fourth =fo
      tag nil
==>
   !output! ("completes word as ~S~%" =word)

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

   !pop!
)

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

(p complete-word-inclusion-1

   =goal>
      isa complete-words
      first =f
      second =s
      third =t
      fourth =fo
      target nil
!eval! (equal *condition* 'inclusion)

   =f>
      isa letter

   =s>
      isa letter

   =t>
      isa letter

   =fo>
      isa letter

   =word>
      isa word
      first =f
      second =s
      third =t
      fourth =fo
      tag nil
==>
  =word>
     tag t
  =goal>
      target =word
      answer =word)

(p complete-word-inclusion-2
   =goal>
      isa complete-words
      first =f
      second =s
      third =t
      fourth =fo
      target =word
!eval! (equal *condition* 'inclusion)
   =token>
      isa memory-token
      item =word
      context list
==>
 =goal>
    target nil
    answer nil
   !output! ("completes word as ~S~%" =word)

   !eval! (jacoby-exp-response =word)
!pop!
)

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

(p complete-word-inclusion-3
   =goal>
      isa complete-words
      first =f
      second =s
      third =t
      fourth =fo
      target =word
!eval! (equal *condition* 'inclusion)

   =f>
      isa letter

   =s>
      isa letter

   =t>
      isa letter

   =fo>
      isa letter

   =word1>
      isa word
      first =f
      second =s
      third =t
      fourth =fo
      tag nil
==>
  =word1>
     tag t
  =goal>
      target =word1)

(parameters complete-word-inclusion-3 :r .75)

(p complete-word-inclusion-4
   =goal>
      isa complete-words
      first =f
      second =s
      third =t
      fourth =fo
      answer =word
!eval! (equal *condition* 'inclusion)
==>
  =goal>
      answer nil
      target nil


   !output! ("completes word as ~S~%" =word)

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

   !pop!
)
(parameters-fct 'complete-word-inclusion-4 (list :effort *respond* :r .5))

(p complete-word-exclusion-1
   =goal>
      isa complete-words
      first =f
      second =s
      third =t
      fourth =fo
      target nil
!eval! (equal *condition* 'exclusion)

   =f>
      isa letter

   =s>
      isa letter

   =t>
      isa letter

   =fo>
      isa letter

   =word>
      isa word
      first =f
      second =s
      third =t
      fourth =fo
      tag nil
==>
  !output! ("~s" =word)
  =word>
     tag t
  =goal>
      target =word)

(p complete-word-exclusion-2
   =goal>
      isa complete-words
      first =f
      second =s
      third =t
      fourth =fo
      target =word
!eval! (equal *condition* 'exclusion)
   =token>
      isa memory-token
      item =word
      context list
==>
  =goal>
      target nil)


(p complete-word-exclusion-4
   =goal>
      isa complete-words
      first =f
      second =s
      third =t
      fourth =fo
      target =word
!eval! (equal *condition* 'exclusion)
==>
  =goal>
      target nil


   !output! ("completes word as ~S~%" =word)

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

   !pop!
)

(parameters-fct 'complete-word-exclusion-4 (list :effort *respond* :r .75))



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

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