;;;;;;;;;;;;;;;;;;;;;;;;<pre>
;;;
;;; This file contains the ACT-R model of the
;;; Johnston Experiment presented in Chapter 5
;;;
;;; ACT-R version 4 required
;;; 
;;; A WWW interface and a command line interface
;;; are provided.  
;;; To run the command line version, call
;;; (doit-johnston n)
;;; replacing n with the number of runs to
;;; simulate.

;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; 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 *noise*)
(defvar *stop-it*)
(defvar *sf*)
(defvar *ff*)
(defvar *ft*)
(defvar *st*)
(defvar *items*)
(defvar *data*)
(defvar *word*)
(defvar *read-time*)
(defvar *intercept*)
(defvar *test-flag*)
(defvar *johnson*)
(defvar *word-number*)
(defvar *threshold*)
(defvar *factor*)
(defvar *v*)
(defvar *runs*)
(defvar *penalty*)
(defvar *respond*)
(defvar *encode*)
(defvar *rehearse*)

(setf *respond* .5)
(setf *encode* .2)
(setf *rehearse* .5)
(setf *intercept* .55)
(setf *noise* .55)
(setf *threshold* .9)
(setf *factor* 1.3)
(setf *word-number* 1.0)
(setf *v* nil)
(setf *penalty* 15)

(defparameter *johnston-contexts* '(l1 l2 l3 l4 l5  l0))


(defparameter *johnston-data* (make-array '(2 4 2) :initial-contents
                                         '(((.73 .27) (.72 .28) (.39 .61) (.35 .65))
                                           ((1.313 1.521) (1.531 1.737)(1.455 1.67)(1.789 1.918)))))

(defparameter *johnston-results* (make-array '(2 4 2) :initial-contents
                                            '(((73 27) (72 28) (39 61) (35 65))
                                              ((95.849 41.067) (110.232 48.636)(56.745 101.87)(62.615 124.67)))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; 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 "Johnston simulation" 2)
        (:table)
        
        (:table)
        "Noise (s): "        (:string :sy *noise* .55)          (:new-row)
        "Threshold: "        (:string :sy *threshold* .9)     (:new-row)
        "Scale factor (F): " (:string :sy *factor* 1.3)         (: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)
        "Encodeing time of fast test (sec.): " (:string :sy *intercept* .55) (:new-row)
        "Number of runs (1-20): "   (:string :sy *runs* 1)
        (:table-end)
         (:hidden :sy *word-number* 1.0)

        (:table)
        (:checkbox "Trace" :sy *v*  nil) 
        (:table-end)
        
        (:table-end)
        
        (:new-para)
        (:button "Show Experiment Results" "(progn
                                            (format *standard-output* \"~%~%Experimental data:~%\")
                                            (output-johnston *johnston-results* (/ 1 .44)))")
        (:new-para)
        (:button "Run model" "(progn 
                                (when (numberp *penalty*) 
                                  (setf *penalty* (* 10 *penalty*))) 
                              (if (and (numberp *noise*) (numberp *threshold*) 
                                       (numberp *factor*) (numberp *penalty*)                  
                                       (numberp *respond*) (numberp *encode*) 
                                       (numberp *rehearse*) (numberp *intercept*) 
                                       (numberp *runs*))                           
                                 (doit-johnston (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 125k (80 pages) in size"
        (:new-para)))


;;; make-up-items-johnston takes 2 parameters
;;; a count of the number of words (m) and the 
;;; number of letters to use to form the words (n)
;;; and then generates a set of letter chunks for each of
;;; the 4 positions in the word, and creates chunks
;;; for m random words, setting the baselevels
;;; of the words very low, *word-number* times out
;;; of the last 1000 (*word-number* is set to 1)
;;; and returns the list of word chunks

(defun make-up-items-johnston (m n)
  (let* ((first (make-up-letters-johnston "FIRST" n))
         (first (append first (nthcdr (floor n 2) first) (nthcdr (* 3 (floor n 4)) first)
                        (nthcdr (* 7 (floor n 8)) first)(nthcdr (* 7 (floor n 8)) first)))
         (second (make-up-letters-johnston "SECOND" n))
         (second (append second (nthcdr (floor n 2) second)(nthcdr (* 3 (floor n 4)) second)
                         (nthcdr (* 7 (floor n 8)) second)(nthcdr (* 7 (floor n 8)) second)))
         (third (make-up-letters-johnston "THIRD" n))
         (third (append third (nthcdr (floor n 2) third)(nthcdr (* 3 (floor n 4)) third)
                        (nthcdr (* 7 (floor n 8)) third)(nthcdr (* 7 (floor n 8)) third)))
         (fourth (make-up-letters-johnston "FOURTH" n))
         (fourth (append fourth (nthcdr (floor n 2) fourth)(nthcdr (* 3 (floor n 4)) fourth)
                         (nthcdr (* 7 (floor n 8)) fourth)(nthcdr (* 7 (floor n 8)) fourth))))
    (do ((count 0 (1+ count))
         (result nil (cons (make-word-johnston (randmem-johnston first) (randmem-johnston second)
                                               (randmem-johnston third) (randmem-johnston fourth))
                           result)))
        ((equal count m)  (reset-ia) 
         (setlevel-johnston *word-number* (no-output (do-up-ias-johnston (add-dm-fct result))) 1000)))))

;;; setlevel-johnston takes 3 parameters,
;;; the number of occurences (count), a list of
;;; chunks (lis), and the time for those occurences (time)
;;; it then sets the base level of the chunks in the list
;;; to have occured count times since being created at time
;;; time

(defun setlevel-johnston ( count lis time)
  (do ((temp lis (cdr temp)))
      ((null temp) lis)
    (eval `(set-base-levels (,(car temp) ,count ,(- time))))))

;;; do-up-ias-johnston takes one parameter
;;; a list of word chunks
;;; for each word in the list the ia
;;; between the letters and the word is increased
;;; by 2

(defun do-up-ias-johnston (lis)
  (do ((temp lis (cdr temp)))
      ((null temp) lis)
    (set-ia-fct (list (list (chunk-slot-value-fct (car temp) 'first) (car temp) 
                            (+ 2.0 (ia-fct (chunk-slot-value-fct (car temp) 'first) (car temp)))) 
                      (list (chunk-slot-value-fct (car temp) 'second) (car temp)
                            (+ 2.0 (ia-fct (chunk-slot-value-fct (car temp) 'second) (car temp))))
                      (list (chunk-slot-value-fct (car temp) 'third) (car temp)
                            (+ 2.0 (ia-fct (chunk-slot-value-fct (car temp) 'third) (car temp))))
                      (list (chunk-slot-value-fct (car temp) 'fourth) (car temp) 
                            (+ 2.0 (ia-fct (chunk-slot-value-fct (car temp) 'fourth) (car temp))))))))

;;; randmem-johnston takes one parameter 
;;; a list, and returns a random item from 
;;; the list

(defun randmem-johnston (lis)
  (nth (random (length lis)) lis))

;;; make-up-letters-johnston takes two parameters
;;; a string identifier, and the number of items
;;; it then generates that number of letter chunks
;;; with the name of the chunks starting with
;;; the identifier

(defun make-up-letters-johnston (index n)
  (do ((count 0 (1+ count))
       (result nil (cons `(,(gentemp index) isa letter) result)))
      ((equal count n) (add-dm-fct result))))

;;; make-word-johnston takes four parameters,
;;; all letter chunks, and returns the act-r
;;; definition of the word composed of those
;;; four letters, that can be passed to 
;;; add-dm  

(defun make-word-johnston (a b c d)
  `(,(gentemp "W") isa word first ,a second ,b
                          third ,c fourth ,d))

;;; setup-materials-johnston takes 2 parameters
;;; the number of words (m) and the number
;;; of letters used to make those words (n)
;;; and calls the functions to generate the 
;;; letters and words, and the memory tokens 
;;; for previous instances of the words,
;;; and then sets the base levels for the 
;;; previous memory tokens, and returns the
;;; list of word chunks
 
(defun setup-materials-johnston (m n)
  (let ((words (make-up-items-johnston m n)))
   (do ((temp words (cdr temp))
        (items nil (append (setup-johnston (car temp) 3) items)))
       ((null temp) 
        (setlevel-johnston 3 (add-dm-fct items :reset-ia nil) 400)
          words))))

;;; setup johnsto takes 2 parameters,
;;; a word chunk and a count of previous
;;; occurences.  it then creates a list of
;;; chunk definitions for that many different 
;;; previous occurences of that word,
;;; and returns the list

(defun setup-johnston (word n)
  (do ((count 0 (1+ count))
       (result nil (cons   `(,(gentemp "C") isa memory-token 
                             context ,(nth count *johnston-contexts*)
                             first ,(chunk-slot-value-fct word 'first)
                             second ,(chunk-slot-value-fct word 'second)
                             third ,(chunk-slot-value-fct word 'third)
                             fourth ,(chunk-slot-value-fct word 'fourth)
                             name ,word) result)))
      ((= count n) result)))

;;; doit-johnston takes on parameter,
;;; the number of trials of the experiment to 
;;; simulate, it runs that many simulations
;;; of the experiment and then displays the
;;; results

(defun doit-johnston (n) 
  (setf *data* (make-array '(2 4 2) :initial-element 0))
  (do ((count 0 (1+ count)))
      ((equal count n) nil)
    (reset)
    (set-params-johnston)
    (run-experiment-johnston))

  (format *standard-output* "~%~%Parameters for run: (~S ~S ~S ~S ~S ~S ~S ~S ~S)~%~%Simulation data:~%"
          *noise* *threshold* *factor* *penalty* *respond* *encode* *rehearse* *intercept* n)
  (output-johnston *data* n))

;;; output-johnston takes 2 parameters,
;;; the array containing the data for 
;;; runs of the johnston experiment, and the 
;;; number of runs represented in the data
;;; and displays the accuracy and response time
;;; averages for the different conditions
 
(defun output-johnston (stats n)
  (format *standard-output* "~%Fast Encoding~%")
  (format *standard-output* "         Accuracy %     RT (sec.)~%")
  (format *standard-output* "Hits:      ~4,1F%          ~5,3F~%" (/ (aref stats 0 0 0) (* .44 n)) (if (zerop (aref stats 0 0 0))
                                                                                                      0.0
                                                                                                      (/ (aref stats 1 0 0) (aref stats 0 0 0)))) 
  (format *standard-output* "Misses:    ~4,1F%          ~5,3F~%" (/ (aref stats 0 0 1) (* .44 n)) (if (zerop (aref stats 0 0 1))
                                                                                                      0.0
                                                                                                      (/ (aref stats 1 0 1) (aref stats 0 0 1)))) 
  (format *standard-output* "FAs:       ~4,1F%          ~5,3F~%" (/ (aref stats 0 2 0) (* .44 n)) (if (zerop (aref stats 0 2 0))
                                                                                                      0.0
                                                                                                      (/ (aref stats 1 2 0) (aref stats 0 2 0)))) 
  (format *standard-output* "Rejects:   ~4,1F%          ~5,3F~%" (/ (aref stats 0 2 1) (* .44 n)) (if (zerop (aref stats 0 2 1))
                                                                                                      0.0
                                                                                                      (/ (aref stats 1 2 1) (aref stats 0 2 1)))) 
  (format *standard-output* "~%Slow Encoding~%")
  (format *standard-output* "         Accuracy %     RT (sec.)~%")
  (format *standard-output* "Hits:      ~4,1F%          ~5,3F~%" (/ (aref stats 0 1 0) (* .44 n)) (if (zerop (aref stats 0 1 0))
                                                                                                      0.0
                                                                                                      (/ (aref stats 1 1 0) (aref stats 0 1 0)))) 
  (format *standard-output* "Misses:    ~4,1F%          ~5,3F~%" (/ (aref stats 0 1 1) (* .44 n)) (if (zerop (aref stats 0 1 1))
                                                                                                      0.0
                                                                                                      (/ (aref stats 1 1 1) (aref stats 0 1 1)))) 
  (format *standard-output* "FAs:       ~4,1F%          ~5,3F~%" (/ (aref stats 0 3 0) (* .44 n)) (if (zerop (aref stats 0 3 0))
                                                                                                      0.0
                                                                                                      (/ (aref stats 1 3 0) (aref stats 0 3 0)))) 
  (format *standard-output* "Rejects:   ~4,1F%          ~5,3F~%" (/ (aref stats 0 3 1) (* .44 n)) (if (zerop (aref stats 0 3 1))
                                                                                                      0.0
                                                                                                      (/ (aref stats 1 3 1) (aref stats 0 3 1)))))

;;; run-experiment-johnston takes no parameters
;;; it generates the materials for one run
;;; of the johnston experiment, and then calls
;;; the act-r simulation

(defun run-experiment-johnston ()
  (let* ((materials (setup-materials-johnston 206 26))
         (pre (nthcdr 202 materials))
         (materials (nthcdr 4 (reverse materials)))
         (post (nthcdr 198 materials))
         (materials (nthcdr 4 (reverse materials)))
         (fast-t (nthcdr 154 materials))
         (materials (nthcdr 44 (reverse materials)))
         (slow-t (nthcdr 110 materials))
         (materials (nthcdr 44 (reverse materials)))
         (buffer  (nthcdr 88 materials))
         (materials (nthcdr 22 (reverse materials)))
         (fast-f (nthcdr 44 materials))
         (slow-f (nthcdr 44 (reverse materials)))
         (study (append pre (permut-johnston (append fast-t slow-t)) post))
         (test (append (permut-johnston (append pre post buffer))
                       (permut-johnston (append fast-t slow-t fast-f slow-f)))))
    (setsimilarities (l0 l1 .9)(l0 l2 .9)(l0 l3 .9)
                     (l1 l2 .9)(l1 l3 .9))
    (setf *test-flag* nil)
    (setf *stop-it* 0) 
    (setf *ft* fast-t)
    (setf *st* slow-t)
    (setf *ff* fast-f)
    (setf *sf* slow-f)

    (add-dm-fct '((goal isa study-words context L0)) :reset-ia nil )
    (setf *items* study)
    (wmfocus goal) 
    (run)

    (setf *items* test) (setf *test-flag* t)
    (add-dm-fct '((newgoal isa recognize-words context L0)) :reset-ia nil)
    (wmfocus newgoal) 
    (run)))

;;; permut-johnston takes one parameter
;;; a list, and returns a randomly 
;;; permuted version of that list

(defun permut-johnston (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)))))

;;; set-params-johnston is used to set
;;; the parameters of the model before each run
;;; it is needed for the WWW interface

(defun set-params-johnston ()
  (sgp-fct (list :bll .5 :ans *noise* :mp *penalty* :era t :ol t
                 :pm t :rt *threshold* :lf *factor* :v *v*))
  
  (parameters-fct 'rehearse-skip (list :r .5 :effort *rehearse*))
  (parameters-fct 'rehearse-token (list :effort *rehearse* :strength 2))
  (parameters-fct 'attend (list :effort *encode*))
  (parameters-fct 'attend-test (list :effort *intercept*))
  (parameters-fct 'accept-word (list :effort *respond*))
  (parameters-fct 'reject-a-word-2 (list :r .5 :effort *respond*))
  (setf *pop-upon-failure* t))


;;; get-word-johnston takes one parameter,
;;; a goal chunk
;;; it places the letters of the word being presented
;;; into the goal, increments the time until the next
;;; word is to be presented, and if it is currently
;;; being tested on a word from the slow presentation
;;; condition adds .2 seconds to the time of encodeing

(defun get-word-johnston (goal)
  (setf *stop-it* (+ 2.0 *stop-it*))
  (setf *word* (pop *items*))
  (cond ((and *test-flag* (or (member *word* *st*) (member *word* *sf*)))
         (actr-time .2)))
   (let ((first (chunk-slot-value-fct *word* 'first))
          (second (chunk-slot-value-fct *word* 'second))
          (third (chunk-slot-value-fct *word* 'third))
          (fourth (chunk-slot-value-fct *word* 'fourth)))
     (mod-chunk-fct goal `(first ,first second ,second third ,third fourth ,fourth))))


;;; analyze-johnston takes 2 parameters
;;; a word chunk and a response, 
;;; it then updates the data array 
;;; to record the response and the 
;;; time of the response

(defun analyze-johnston (word response)
  (let ((i))
    (cond ((member word *ft*)(setf i 0))
          ((member word *st*)(setf i 1))
          ((member word *ff*)(setf i 2))
          ((member word *sf*)(setf i 3)))
    (cond ((not i) nil)
          ((eq response 'yes) (setf (aref *data* 0 i 0) 
                                    (1+ (aref *data*  0 i 0)))
           (setf (aref *data* 1 i 0) (+ (aref *data* 1 i 0) (min 10.0 *read-time*))))
          (t (setf (aref *data*  0 i 1) 
                   (1+ (aref *data*  0 i 1)))
             (setf (aref *data* 1 i 1) (+ (aref *data* 1 i 1) (min 10.0 *read-time*)))))))


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

(clearall)

(sgp-fct (list :bll .5 :ans *noise* :mp *penalty* :era t :ol t
               :pm t :rt *threshold* :lf *factor* :v nil))

(chunk-type study-words context)
(chunk-type recognize-words context)
(chunk-type recognize-word context target first second third fourth)
(chunk-type word first second third fourth)
(chunk-type memory-token name context first second third fourth)
(chunk-type letter)
(chunk-type context)
(chunk-type rehearsal-fact count name)

;;; add the contexts to memory

(add-dm (l0 isa context)
       (l1 isa context)
       (l2 isa context)
       (l3 isa context))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Productions
;;;

(p attend
"
  IF the goal is to study words 
     and there are items left to study
     and a new word has been presented
  THEN
     create a memory token for the
     letters of the word being presented in 
     the current context, and push it as a goal
"
   =goal>
      isa study-words
      context =context

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

  !eval! *items*
==>
   =newgoal>
      isa memory-token
      context =context

   !eval! (get-word-johnston =newgoal)

   !push! =newgoal
)

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


(p create-token
"
  IF the goal is a memory token of the 
     letters of a word
     and a word chunk having those letters 
     can be recalled
  THEN mark the word in the goal
     and create a reharsal fact chunk for the word
     and focus on the rehersal fact
"
   =goal>
      isa memory-token
      first =1
      second =2
      third =3
      fourth =4

   =name>
      isa word
      first =1
      second =2
      third =3
      fourth =4
==>
   =goal>
       name =name

   =token>
       isa rehearsal-fact
       name =name

   !focus-on! =token
)


(p initialize-count
"
  IF the goal is a rehearsal fact
  THEN set the count of the fact to 0
     and pop the goal
"
   =goal>
      isa rehearsal-fact
==>
   =goal>
      count 0

   !pop!
)


(p recognize-count
"
  IF the goal is a rehearsal fact
     and a rehearsal fact can be recalled
     with the same name 
  THEN mark the goal with the count from 
     the recalled fact
     and pop the goal
"
   =goal>
      isa rehearsal-fact
      name =name

   =mem>
      isa rehearsal-fact
      name =name
      count =count
==>
   =goal>
      count =count

   !pop!
)


(p rehearse-token
"
  IF the goal is to study words
     and there is still time to study this 
     word (a new word has not yet been presented)
     and a memory-token can be retrieved with
     the current context
     and the word in that token can be retrieved
     and the rehearsal fact for that word has
     a count that is less than 3
  THEN increment the count in the rehearsal fact
"
   =goal>
      isa study-words
      context =context

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

   =memory>
      isa memory-token
      name   =name
      context  =context

   =name>
       isa word
 
   =token>
      isa rehearsal-fact
      count  =count
      name =name
    - count 3
==>
   =token>
      count (!eval! (1+ =count))
)

(parameters-fct 'rehearse-token (list :effort *rehearse* :strength 2))


(p rehearse-skip
"
  IF the goal is to study words
     and there is still time to study this 
     word (a new word has not yet been presented)
  THEN do nothing
"
   =goal>
      isa study-words
      context =context

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

(parameters-fct 'rehearse-skip (list :r .5 :effort *rehearse*))


(p attend-test
"
  IF the goal is to recognize words
     and there are words to recognize
  THEN create a new goal to recognize
     the word in the current context
     and store the letters into the new goal
     and push the new goal
"
   =goal>
      isa recognize-words
      context =context

   !eval! *items*
==>
   !eval! (setf *read-time* (actr-time))
   
   =newgoal>
      isa recognize-word
      context =context

   !eval! (get-word-johnston =newgoal)

   !push! =newgoal
)

(parameters-fct 'attend-test (list :effort *intercept*))


(p probe-token-say
"
  IF the goal is to recognize a word
     and a word with the same letters can be recalled
  THEN marke that word in the goal
"
   =goal>
      isa recognize-word
      first =1
      second =2
      third =3
      fourth =4
      target nil

   =name>
      isa word
      first =1
      second =2
      third =3
      fourth =4
==>

   !eval! (setf *read-time* (+ .5 (- (actr-time) *read-time*)))

   =goal>
       target =name
)

(parameters probe-token-say  :effort .5)


(p default-token-say
"
  IF the goal is to recognize a word
  THEN do nothing
"
   =goal>
      isa recognize-word
      first =1
      second =2
      third =3
      fourth =4
      target nil
==>
)

(parameters default-token-say :r .5)


(p accept-word
"
  IF the goal is to recognize a word
     and there is a memory token of that
     word occuring in the current context
  THEN respond yes
     and pop the goal
"
   =goal>
      isa recognize-word
      target =word
      context =context

   =token>
     isa memory-token
     name =word
     context =context
==>
   !eval! (analyze-johnston *word* 'yes)

   !pop!
)

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


(p reject-a-word-2
"
  IF the goal is to recognize a word
  THEN respond no
     and pop the goal
"
   =goal>
      isa recognize-word
      target =word
      context =context
==>
   !eval! (analyze-johnston *word* 'no)

   !pop!
)

(parameters-fct 'reject-a-word-2 (list :r .5 :effort *respond*))