;;; Stroop Finst 
;;;
;;; Authors      : Ion Juvina and Daniel Dickison 
;;; Copyright    : (c) 2008 Ion Juvina and Daniel Dickison 
;;; Address      : ijuvina@cmu.edu
;;; 
;;; this model uses decaying declarative finsts to account for between-trial effects in a modified Stroop paradigm 
;;; it does not make errors - it just accounts for the corrects 
;;; shows within-trial (interf and facil) and between-trial effects 

;;; implementational issues 
;; special buffers: sts and sts1 (they simulate decaying short-term storage)
;; the purpose of this short-term storage is to give some stability to the recency effect
;; because the recency effect is washed out at large Ns by base level learning 
;; at decent Ns the model works fine without these additional buffers    
;; To do: 
;; split the content of the goal buffer; transfer the problem space representations in the imaginal buffer 
;; (this won't change anything in the simulation data, it's just a recommended modeling style)  
 
(setf *buffer-file* 
  (make-pathname 
   :device (pathname-device *load-pathname*)
   :directory (pathname-directory *load-pathname*)
   :name "buffer"))
(compile-and-load *buffer-file*)

(defvar *neutral-words*)
(defvar *words*)
(defvar *word*)

(defparameter *default-finst-half-life* 1.9) ; was 2.0
(defparameter *default-finst-max-activation* -1.9) ; was -2.0

(defun display-stimulus (word color)
  (clear-exp-window)
  (add-text-to-exp-window :text (string word) :x 100 :y 50 :color color)
  (proc-display))

(defun display-left-prompt (word)
  (add-text-to-exp-window :text (string word) :x 25 :y 50 :color 'black)
  (proc-display))

(defun display-right-prompt (word)
  (add-text-to-exp-window :text (string word) :x 175 :y 50 :color 'black)
  (proc-display))

(defun do-exp (m n) ; m is the no of subjects, n is the number of trials
  (reset)
  (setq p (merge-pathnames "res.txt"))
  (with-open-file (s p :direction :output :if-exists :supersede)
  (format s "~6,1F ~6,1F ~6,1F ~6,1F ~6,1F ~6,1F ~6,1F ~6,1F ~6,1F ~%" "Cond" "Correct" "RT" "StimText" "StimColor" "PromptL" "PromptR" "Trial" "Subject"))
  (dotimes (k m)  
     (reset)     
     (let ((res (do-subject (+ k 1) n))) ; k+1 is the subject number  n is the no of trials 
       (format t "~6,1F ~%" (+ k 1)))))

(defun do-subject (k n) ; n is the no of trials

  (reset)
  (let ((goal-1 (new-name "GOAL")))
    (eval `(add-dm (,goal-1 isa choose-color state attend)))
    (eval `(goal-focus ,goal-1)))

    (loop for i from 1 to n do 
        (let* ((j (first (permute-list '(0 1 2)))) ; one of the 3 conditions
               (res (do-trial j)))
          (setq p (merge-pathnames "res.txt"))
          (with-open-file (s p :direction :output :if-exists :append)
            (format s "~6,1F ~6,1F ~6,1F ~6,1F ~6,1F ~6,1F ~6,1F ~6,1F ~6,1F ~%" (nth 0 res) (nth 1 res) (nth 2 res) (nth 3 res) (nth 4 res) (nth 5 res) (nth 6 res) i k)))))

(defun do-trial (c) ; c is 0=neutral,1=congruent,or 2=conflicting 
;  (reset)
  (setf *colors* (permute-list '(red green yellow blue)))
  (setf *neutral-words* (permute-list '("Order" "Action" "Side" "Part" "Family" "Look" "Screen" "Pen" "Button" "Table")))
  (setf stim-color (first *colors*) other-color (second *colors*))
  (setf correct nil)
  (setf left-prompt nil right-prompt nil)

  (progn
  (when (= c 0) (setf stim-word (first *neutral-words*))) 
  (when (= c 1) (setf stim-word (first *colors*))) 
  (when (= c 2) (setf stim-word (second *colors*)))) 

  (progn
   (let* ((window (open-exp-window "Stroop" :visible nil)))
   (if *actr-enabled-p*
        (progn
          (install-device window)
          (proc-display)))
   (display-stimulus stim-word stim-color)
   (if (= (random 2) 0) 
     (progn
       (display-left-prompt stim-color)
       (display-right-prompt other-color)
       (setf left-prompt stim-color right-prompt other-color))
     (progn
       (display-left-prompt other-color)
       (display-right-prompt stim-color)
       (setf left-prompt other-color right-prompt stim-color)))
   (setf start-time (get-time))
   (run 50 :real-time nil)
   (setf RT (- (get-time) start-time)))
  (list c correct RT stim-word stim-color left-prompt right-prompt)))

(defun make-finst-decay-bl-hook (&key (dm (get-module declarative))
                                      (half-life *default-finst-half-life*)
                                      (max-activation *default-finst-max-activation*))
  (lambda (chunk)
    (+ (default-base-level-activation dm chunk)
       (compute-finst-activation dm chunk half-life max-activation))))



(defun compute-finst-activation (dm chunk half-life max-activation)
  (let ((finst-time (cdr
                     (find chunk (dm-finsts dm)
                           :key #'car
                           :test #'eq-chunks-fct)))
        (current-time (mp-time)))
    (if finst-time
      (let ((val
             (/ max-activation
                (expt 2 (/ (- current-time finst-time)
                           half-life)))))
        (when (dm-act dm)
          (model-output "Finst activation: ~F" val))
        val)
      0)))




(defun default-base-level-activation (dm chunk)
  "This is the default base-level computation, lifted from the function base-level-activation of ACT-R 6 from September 2007.  This is necessary because I want to modify the base level computed by the default algorithm, not replace it entirely."
  (let ((base-level
         (cond ((dm-bll dm)
                (+ (progn
                     (when (dm-act dm)
                       (model-output "Starting with blc: ~f" (dm-blc dm)))
                     (dm-blc dm))
                   (cond ((zerop (chunk-reference-count chunk))
                          (model-warning "Cannot compute base-level for a chunk with no references.")
                          -999999.0)
                         (t ;; just use the ACT-R 5 function basically as is for now
                          (compute-references dm (chunk-reference-count chunk)
                                              (chunk-reference-list chunk) (chunk-creation-time chunk)
                                              (- (dm-bll dm)))))))
               (t ;; bll nil
                (if (chunk-base-level chunk)
                    (progn
                      (when (dm-act dm)
                        (model-output "User provided chunk base-level: ~f" (chunk-base-level chunk)))
                      (chunk-base-level chunk))
                    (progn
                      (when (dm-act dm)
                        (model-output "Starting with blc: ~f" (dm-blc dm)))
                      (dm-blc dm)))))))
    (when (dm-act dm)
      (model-output "Total base-level: ~f" base-level))
    base-level))

(clear-all)

(define-model StroopFinst4

(sgp-fct (list :bl-hook (make-finst-decay-bl-hook)))
(sgp :esc t :trace-detail high :v t
:ACT t
:lf                         .2 ; was .1
:bll                        .5 ; was .5 
:egs                        .5 ;
:ans                       .25 ; was .25  
:rt                       -3.5 ;  because we don't want retrieval failure at this stage  
:MAS                         3 ;   default: NIL        : Maximum Associative Strength
:GA                          1 ;   default: 1          : source spread for the GOAL buffer
;:UL                          t ;   default: NIL
:ALPHA                     0.2 ;   default: 0.2        : Production learning rate
:VISUAL-ACTIVATION           1 ;   default: 0          : source spread for the VISUAL buffer
:VISUAL-NUM-FINSTS           1 ;   default: 4          : Number of visual finsts.
:sts-ACTIVATION           0.44 ;   default: 2          : source spread for the sts buffer
:sts1-ACTIVATION          0.11 ;   default: 1          : source spread for the sts1 buffer
:MOTOR-INITIATION-TIME    0.01 ;   default: 0.05       : Time to initiate a motor movement.
:MOTOR-BURST-TIME         0.01 ;   default: 0.05       : Minimum time for any movement.
:DECLARATIVE-NUM-FINSTS      4 ;  default: 4          : Number of declarative finst markers
:DECLARATIVE-FINST-SPAN      4 ;  default: 3.0        : Duration of declarative finst markers in seconds
)

(chunk-type choose-color color color-name word caution state)
(chunk-type color-concept value name text)
(chunk-type color-name text value)
(chunk-type read-words state)
(chunk-type previous-stimuli color word)
(add-dm (detect isa chunk))
(add-dm (attend isa chunk))
(add-dm (encode isa chunk))
(add-dm (encode-word isa chunk))
(add-dm (start isa chunk))
(add-dm (retrieve isa chunk))
(add-dm (retrieve-concept isa chunk))
(add-dm (retrieve-name isa chunk))
(add-dm (encode-name isa chunk))
(add-dm (retrieve-name-specified isa chunk))
(add-dm (retrieved-name isa chunk))
(add-dm (retrieve-word isa chunk))
(add-dm (double-check isa chunk))
(add-dm (feedback isa chunk))
(add-dm (read isa chunk))
(add-dm (compare isa chunk))
(add-dm (attend-prompt isa chunk))
(add-dm (attend-prompt-location isa chunk))
(add-dm (switch-prompt isa chunk))
(add-dm (correct-nearerror isa chunk))

(add-dm (name-red isa color-name text "red" value red))
(add-dm (name-green isa color-name text "green" value green))
(add-dm (name-blue isa color-name text "blue" value blue))
(add-dm (name-yellow isa color-name text "yellow" value yellow))
(add-dm (redness isa color-concept value red name name-red text "red"))
(add-dm (greenness isa color-concept value green name name-green text "green"))
(add-dm (blueness isa color-concept value blue name name-blue text "blue"))
(add-dm (yellowness isa color-concept value yellow name name-yellow text "yellow"))


(add-dm (n1 isa color-concept name "Order"))
(add-dm (n2 isa color-concept name "Action"))
(add-dm (n3 isa color-concept name "Side"))
(add-dm (n4 isa color-concept name "Part"))
(add-dm (n5 isa color-concept name "Family"))
(add-dm (n6 isa color-concept name "Look"))
(add-dm (n7 isa color-concept name "Screen"))
(add-dm (n8 isa color-concept name "Pen"))
(add-dm (n9 isa color-concept name "Button"))
(add-dm (n10 isa color-concept name "Table"))
(add-dm (goal isa choose-color state attend))

(add-sji (name-red redness 2) (name-blue blueness 2)(name-green greenness 2)(name-yellow yellowness 2))
(add-sji (red redness 1) (blue blueness 1)(green greenness 1)(yellow yellowness 1))

(P attend-middle-location
   =goal>
      ISA         choose-color
      state       attend
   =visual-location>
      ISA         visual-location
   ?visual-location>
      state       free
==>
   +visual-location>
      ISA         visual-location
      > screen-x  90
      < screen-x  170
      screen-y    60
   =goal>
      state       start
)

(P attend-middle-word
   =goal>
      ISA         choose-color
      state       start
   =visual-location>
      ISA         visual-location
   ?visual>
      state       free
==>
   +visual>
      ISA         move-attention
      screen-pos  =visual-location
   =goal>
      state       encode
)

;;; this is the encoding of the two stimulus features: color and word ;;;;;;;;;;;;;;;;;;;;; encoding ;;;;;;;;;;;;;;;;;;;;;;;;;;;

(P create-word-chunk-red  
   =goal>
      ISA         choose-color
      state       encode
   =visual>
      isa         text
      value       "red"
      color       =color
==>
   =visual>
   =goal>
      color       =color
      word        name-red
      state       retrieve-concept)

(P create-word-chunk-green  
   =goal>
      ISA         choose-color
      state       encode
   =visual>
      isa         text
      value       "green"
      color       =color
==>
   =visual>
   =goal>
      color       =color
      word        name-green
      state       retrieve-concept)

(P create-word-chunk-blue  
   =goal>
      ISA         choose-color
      state       encode
   =visual>
      isa         text
      value       "blue"
      color       =color
==>
   =visual>
   =goal>
      color       =color
      word        name-blue
      state       retrieve-concept)

(P create-word-chunk-yellow  
   =goal>
      ISA         choose-color
      state       encode
   =visual>
      isa         text
      value       "yellow"
      color       =color
==>
   =visual>
   =goal>
      color       =color
      word        name-yellow
      state       retrieve-concept)

(P encode-neutral-word  
   =goal>
      ISA         choose-color
      state       encode
   =visual>
      isa         text
      value       =neutral-word
      color       =color
==>
   =visual>
   =goal>
      color       =color
      word        =neutral-word
      state       retrieve-concept)

;;; here starts the main strategy ;;;;;;;;;;;;;;;;;;;;; main strategy ;;;;;;;;;;;;;;;;;;;;;;;;;;;

(P retrieve-color-concept  
   =goal>
      ISA         choose-color
      color       =color
      state       retrieve-concept
   ?retrieval>
      state       free
==>
   +retrieval> 
      isa         color-concept
   =goal>
      state       encode-name)

(P failure-to-retrieve-color-concept-make-error   
   =goal>
      ISA         choose-color
      color       =color
      state       encode-name
   ?retrieval>
      state       error
   ?manual>
      state       free
==>
   +manual>              
     isa      press-key     
     key      "W"
   -visual-location>
   =goal>
      word        nil
      color       nil
      color-name  nil
      state       attend
!eval! (setf correct nil)
!eval! (clear-exp-window))

(P notice-word-retrieval-and-re-retrieve-color-concept
   =goal>
      ISA         choose-color
      color       =color
      word        =word
      state       encode-name
   =retrieval> 
      isa         color-concept
      - value     =color
      name        =word
   ?retrieval>
      state       free 
   ?vocal>
      state       free
==>
   +vocal>        isa         subvocalize 
      string      "wrong color name!!!"
   +retrieval> 
      isa         color-concept
      value       =color
   =goal>
      state       encode-name)

(P notice-wrong-retrieval-and-re-retrieve-color-concept
   =goal>
      ISA         choose-color
      color       =color
      word        =word
      state       encode-name
   =retrieval> 
      isa         color-concept
      - value     =color
      - name      =word
   ?retrieval>
      state       free 
==>
   +retrieval> 
      isa         color-concept
      value       =color
   =goal>
      state       encode-name)

(P encode-color-name-first-time
   =goal>
      ISA         choose-color
      color       =color
      state       encode-name
   =retrieval> 
      isa         color-concept
      value       =color
      text        =color-name
   =visual>
      isa         text
      value       =word
      color       =color
   ?sts>
      state       free
      buffer      empty
==>
   +sts>
      isa         previous-stimuli
      color       =color
      word        =word
   =goal>
      color-name  =color-name
      state       attend-prompt)

(P encode-color-name
   =goal>
      ISA         choose-color
      color       =color
      state       encode-name
   =retrieval> 
      isa         color-concept
      value       =color
      text        =color-name
   =visual>
      isa         text
      value       =word
      color       =color
   =sts>
      isa         previous-stimuli
      color       =color1
      word        =word1
   ?sts1>
      state       free
==>
   =sts>
      color       =color
      word        =word
   +sts1>
      isa         previous-stimuli
      color       =color1
      word        =word1
   =goal>
      color-name  =color-name
      state       attend-prompt)

(P attend-prompt-location  
   =goal>
      ISA         choose-color
      state       attend-prompt
   ?visual-location>
      buffer      empty
      state       free
==>
   +visual-location>
      ISA         visual-location
      screen-y    60
      color       black
      :attended   nil
   =goal>
      state       detect)

(P attend-prompt
   =goal>
      ISA         choose-color
      state       detect
   =visual-location>
      ISA         visual-location
   ?visual>
      state       free
==>
   +visual>
      ISA         move-attention
      screen-pos  =visual-location
   =goal>
      state       compare
)

(P attend-prompt-later
   =goal>
      ISA         choose-color
      state       compare
   =visual-location>
      ISA         visual-location
   ?visual>
      state       free
==>
   +visual>
      ISA         move-attention
      screen-pos  =visual-location
)

;;; now it comes the selection ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; selection ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(P matching-color-name-and-prompt 
   =goal>
      ISA         choose-color
      color-name  =color-name
      word        =word
      state       compare
   =visual>
      isa         text
      value       =color-name
   ?manual>
      state    free
   ?retrieval>
      state       free
==>
   +manual>              
     isa      press-key     
     key      "Z"
   -visual-location>
   =goal>
      word        nil
      color       nil
      color-name  nil
      state       attend
!eval! (setf correct t)
!eval! (clear-exp-window)
)

;;; prompt mismatch 

(P no-matching-color-name-and-prompt-so-try-prompt-again 
   =goal>
      ISA         choose-color
      color-name  =color-name
      word        =word
      state       compare
   =visual>
      isa         text
      - value     =color-name
   ?retrieval>
      state       free
==>
   +visual-location>
      ISA         visual-location
      screen-y    60
      color       black
      :attended   nil
   =goal>
      state       detect
)

(spp :u 100)

;;; these are protected they should not compete because the task is to answer as quick as possible 

(spp matching-color-name-and-prompt :u 1500000)

;;; these are particular cases that need protection 

(spp notice-word-retrieval-and-re-retrieve-color-concept :u 150)
(spp notice-wrong-retrieval-and-re-retrieve-color-concept :u 150)

;;; these productions are faster cuz they just create chunks 

(spp create-word-chunk-red :AT 0.005)

(spp create-word-chunk-blue :AT 0.005)

(spp create-word-chunk-green :AT 0.005)

(spp create-word-chunk-yellow :AT 0.005)

; the neutral word takes longer to encode 

(spp encode-neutral-word :AT 0.065)

;;; looking at the middle word is faster cuz it's always the same 
;;; looking at the prompts is a bit longer but still faster than the default 

(spp attend-middle-location :AT 0.02)
(spp attend-middle-word :AT 0.02)
(spp attend-prompt-location :AT 0.03)
(spp attend-prompt :AT 0.03)

;;; making errors starts low (actually never)

(spp failure-to-retrieve-color-concept-make-error :u 50)
 
;;; encode neutral word should start lower too to make sure it applies only to neutral words 

(spp encode-neutral-word :u 50)

;;; the rule that detects conflict takes longer

(spp notice-word-retrieval-and-re-retrieve-color-concept :AT 0.1)
(spp notice-wrong-retrieval-and-re-retrieve-color-concept :AT 0.1)

(setf *actr-enabled-p* t)
(goal-focus goal))