;;; Free Recall  
;;;
;;; Author: 	Ion Juvina 
;;; Address: 	ijuvina@cmu.edu
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;special buffers: sts sts1 and sts2 (they simulate decaying short term storage)
(setf *buffer-file* 
  (make-pathname 
   :device (pathname-device *load-pathname*)
   :directory (pathname-directory *load-pathname*)
   :name "buffer"))
(compile-and-load *buffer-file*)

(defvar *words*)
(defvar *response*)

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

;;; data 
 
(defparameter *data* '(.82 .79 .69 .61 .5 .44 .35 .45 .4 .39 .38 .39 .43 .42 .48 .5 .51 .52 .68 .93)) 

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

(defun do-exp (m) ; m is the no of subjects 
  (reset)
  (let ((s1 0)(s2 0)(s3 0)(s4 0)(s5 0)(s6 0)(s7 0)(s8 0)(s9 0)(s10 0)(s11 0)(s12 0)(s13 0)(s14 0)(s15 0)(s16 0)(s17 0)(s18 0)(s19 0)(s20 0)) ; the probabilities associated with serial positions
    (dotimes (k m)  
     (reset)
      (let ((res (do-subject)))  
        (setf s1 (+ s1 (first res)) s2 (+ s2 (second res)) s3 (+ s3 (nth 2 res)) s4 (+ s4 (nth 3 res)) s5 (+ s5 (nth 4 res)) 
              s6 (+ s6 (nth 5 res)) s7 (+ s7 (nth 6 res)) s8 (+ s8 (nth 7 res)) s9 (+ s9 (nth 8 res)) s10 (+ s10 (nth 9 res)) 
              s11 (+ s11 (nth 10 res)) s12 (+ s12 (nth 11 res)) s13 (+ s13 (nth 12 res)) s14 (+ s14 (nth 13 res)) s15 (+ s15 (nth 14 res)) 
              s16 (+ s16 (nth 15 res)) s17 (+ s17 (nth 16 res)) s18 (+ s18 (nth 17 res)) s19 (+ s19 (nth 18 res)) s20 (+ s20 (nth 19 res)) 
        ) 
        (dolist (i res) (format t "~6,1F " i))
	(format t "~%"))) (format t "~%")
    (format t "~6,1F ~6,1F ~6,1F ~6,1F ~6,1F ~6,1F ~6,1F ~6,1F ~6,1F ~6,1F ~6,1F ~6,1F ~6,1F ~6,1F ~6,1F ~6,1F ~6,1F ~6,1F ~6,1F ~6,1F ~%" (/ s1 m)(/ s2 m)(/ s3 m)(/ s4 m)(/ s5 m)
	(/ s6 m)(/ s7 m)(/ s8 m)(/ s9 m)(/ s10 m)(/ s11 m)(/ s12 m)(/ s13 m)(/ s14 m)(/ s15 m)(/ s16 m)(/ s17 m)(/ s18 m)(/ s19 m)(/ s20 m))

    (correlation (list (/ s1 m)(/ s2 m)(/ s3 m)(/ s4 m)(/ s5 m)(/ s6 m)(/ s7 m)(/ s8 m)(/ s9 m)(/ s10 m)(/ s11 m)(/ s12 m)(/ s13 m)(/ s14 m)(/ s15 m)(/ s16 m)(/ s17 m)(/ s18 m)(/ s19 m)(/ s20 m)) *data*)
    (mean-deviation (list (/ s1 m)(/ s2 m)(/ s3 m)(/ s4 m)(/ s5 m)(/ s6 m)(/ s7 m)(/ s8 m)(/ s9 m)(/ s10 m)(/ s11 m)(/ s12 m)(/ s13 m)(/ s14 m)(/ s15 m)(/ s16 m)(/ s17 m)(/ s18 m)(/ s19 m)(/ s20 m)) *data*)
  )
*data*
)

(defun do-subject ()  
  (reset)

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

  (let ((r1 0)(r2 0)(r3 0)(r4 0)(r5 0)(r6 0)(r7 0)(r8 0)(r9 0)(r10 0)(r11 0)(r12 0)(r13 0)(r14 0)(r15 0)(r16 0)(r17 0)(r18 0)(r19 0)(r20 0)) ; it becomes t if the corresponding word is recalled 
   (setf *words* '("red" "green" "blue" "yellow" "order" "action" "side" "part" "family" "look" "memory" "whatever" "something" "fourteen" "fifteen" "sixteen" "seventeen" "eighteen" "nineteen" "twenty"))
      (dolist (j *words*) (attend-word j))
      (let ((goal-2 (new-name "GOAL")))
        (eval `(add-dm (,goal-2 isa recall state recall)))
        (eval `(goal-focus ,goal-2)))
      (loop for j from 1 to 20 do 
        (let ((res (recall-word)))
	 (when (first res) 
	(progn	
	(if (equal (first res) (first *words*)) (setf r1 1))
	(if (equal (first res) (second *words*)) (setf r2 1))
	(if (equal (first res)  (third *words*)) (setf r3 1))
	(if (equal (first res)  (fourth *words*)) (setf r4 1))
	(if (equal (first res)  (fifth *words*)) (setf r5 1))
        (if (equal (first res)  (nth 5 *words*)) (setf r6 1))
	(if (equal (first res)  (nth 6 *words*)) (setf r7 1))
	(if (equal (first res)  (nth 7 *words*)) (setf r8 1))
	(if (equal (first res)  (nth 8 *words*)) (setf r9 1))
	(if (equal (first res)  (nth 9 *words*)) (setf r10 1))
        (if (equal (first res)  (nth 10 *words*)) (setf r11 1))
	(if (equal (first res)  (nth 11 *words*)) (setf r12 1))
	(if (equal (first res)  (nth 12 *words*)) (setf r13 1))
	(if (equal (first res)  (nth 13 *words*)) (setf r14 1))
	(if (equal (first res)  (nth 14 *words*)) (setf r15 1))
        (if (equal (first res)  (nth 15 *words*)) (setf r16 1))
	(if (equal (first res)  (nth 16 *words*)) (setf r17 1))
	(if (equal (first res)  (nth 17 *words*)) (setf r18 1))
	(if (equal (first res)  (nth 18 *words*)) (setf r19 1))
	(if (equal (first res)  (nth 19 *words*)) (setf r20 1)))
	 )	
	)
       )
    (list r1 r2 r3 r4 r5 r6 r7 r8 r9 r10 r11 r12 r13 r14 r15 r16 r17 r18 r19 r20)
  )
)

(defun attend-word (w) ; w is a particular word
;  (format t "~6,1F ~%" w)
   (let* ((window (open-exp-window "Attend word" :visible nil)))
   (if *actr-enabled-p*
        (progn
          (install-device window)
          (proc-display)))
   (display-stimulus w)
   (run 3 :real-time nil)
   )
)

(defun recall-word () 
;  (format t "~6,1F ~%" *response*)
  (display-stimulus "bla bla bla")
  (setf *response* "")
  (run 1 :real-time nil)
  (list *response*)
)


(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.  Currently there's no way to get the default computed value in the hook.

Ideally, I think the hooks should be run _after_ the default values are computed, and be given an opportunity to override the value using the default value as a starting point.  How 'bout it, Dan?"
  (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 FreeRecallFinst

(sgp-fct (list :bl-hook (make-finst-decay-bl-hook)))

(sgp :esc t :trace-detail low :v nil
:ACT nil
:lf                         .1 ; was .1
:bll                        .5 ; was .5 
:egs                        .5 ;
:ans                        .5 ;  
:rt                          0 ;   
: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           0 ;   default: 0          : source spread for the VISUAL buffer
:VISUAL-NUM-FINSTS           2 ;   default: 4          : Number of visual finsts.
:sts-ACTIVATION            0.7 ;   default: 2          : source spread for the sts buffer
:sts1-ACTIVATION           0.5 ;   default: 1          : source spread for the sts1 buffer
:sts2-ACTIVATION           0.4 ;   default: 0.5          : 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    100 ;  default: 4          : Number of declarative finst markers
:DECLARATIVE-FINST-SPAN    100 ;  default: 3.0        : Duration of declarative finst markers in seconds
:SOUND-DECAY-TIME          9.0 ; default: 3.0        : The amount of time after a sound has finished it takes for the sound to be deleted from the audicon
)

(chunk-type choose-color color color-name word caution state)
(chunk-type color-concept value name)
(chunk-type color-name text value)
(chunk-type attend state)
(chunk-type recall state)
(chunk-type previous-stimuli color word)

(add-dm (read isa chunk))
(add-dm (attend isa chunk))
(add-dm (encode isa chunk))
(add-dm (rehearse isa chunk))
(add-dm (done isa chunk))
(add-dm (recall isa chunk))
(add-dm (harvest isa chunk))

;;;;;;;;;;;;;;;;;;; this is the attending phase
(P attend-word
   =goal>
      ISA         attend
   =visual-location>
      ISA         visual-location
   ?visual>
      state       free
      buffer      empty 
==>
   +visual>
      ISA         move-attention
      screen-pos  =visual-location
   =goal>
)

(P subvocalize-seen-item-first-time
   =goal>
      ISA         attend
   =visual>
      isa         text
      value       =letter
   ?vocal>
      state       free
   ?sts>
      buffer      empty
==>
   +vocal>
      isa         subvocalize 
      string      =letter
   +sts>
      isa         text
      value       =visual
   =goal>
)

(P subvocalize-seen-item-second-time
   =goal>
      ISA         attend
   =visual>
      isa         text
      value       =letter
   =sts>
      isa         text
      value       =text
   ?vocal>
      state       free
   ?sts1>
      buffer      empty
==>
   +vocal>
      isa         subvocalize 
      string      =letter
   +sts>
      isa         text
      value       =visual
   +sts1>
      isa         text
      value       =sts
   =goal>
)

(P subvocalize-seen-item-third-time
   =goal>
      ISA         attend
   =visual>
      isa         text
      value       =letter
   =sts>
      isa         text
   =sts1>
      isa         text
   ?vocal>
      state       free
==>
   +vocal>
      isa         subvocalize 
      string      =letter
   +sts>
      isa         text
      value       =visual
   +sts1>
      isa         text
      value       =sts
   +sts2>
      isa         text
      value       =sts1
   =goal>
)


(P attend-sound-location
   =goal>
      ISA         attend
   =aural-location>
      ISA         audio-event
==>
)

(P rehearse-by-retrieval-of-texts-with-finsts
   =goal>
      ISA         attend
   ?retrieval>
      state       free
==>
   +retrieval>
      ISA         text
)


;;; here starts the recall ;;;;;;;;;;;;;;;;;;;;; recall ;;;;;;;;;;;;;;;;;;;;;;;;;;;

(P retrieve-text 
   =goal>
      ISA         recall
      state       recall
   ?retrieval>
      state       free
!eval! (equal *response* "")
==>
   +retrieval>
      ISA         text
   =goal>
      state       harvest
)

(P retrieve-text-after-error
   =goal>
      ISA         recall
      state       recall
   ?retrieval>
      state       free
!eval! (equal *response* "error")
==>
   +retrieval>
      ISA         text
   =goal>
      state       harvest
)

(P harvest-retrieved-text 
   =goal>
      ISA         recall
      state       harvest
   =retrieval>
      isa         text
      value       =text
==>
   -visual-location>   
   =goal>
      state       recall
!eval! (setf *response* =text)
)

(P retrieve-sound 
   =goal>
      ISA         recall
      state       recall
   ?retrieval>
      state       free
!eval! (or (equal *response* "") (equal *response* "error"))
==>
   +retrieval>
      ISA         sound
   =goal>
      state       harvest
)

(P harvest-retrieved-sound 
   =goal>
      ISA         recall
      state       harvest
   =retrieval>
      isa         sound
      content     =text
==>
   -visual-location>   
   =goal>
      state       recall
!eval! (setf *response* =text)
)

(P failure-to-retrieve
   =goal>
      ISA         recall
      state       harvest
   ?retrieval>
      state       error  
==>
   -visual-location>   
   =goal>
      state       recall
!eval! (setf *response* "error")
)

(P retrieve-sound-from-audicon 
   =goal>
      ISA         recall
      state       attend
   =aural>
      isa         sound
      content     =text
   =aural-location>
      ISA         audio-event
   ?aural-location>
      state       free
!eval! (equal *response* "")
==>
   -visual-location>   
   +aural-location>
      ISA         audio-event
      :attended   nil
   +aural>
      ISA         sound
      event       =aural-location
   =goal>
      state       recall
!eval! (setf *response* =text)
)

(P delete-sound-from-audicon 
   =goal>
      ISA         recall
      state       attend
   =aural>
      isa         sound
      content     =text
   =aural-location>
      ISA         audio-event
   ?aural-location>
      state       free
!eval! (equal *response* "")
==>
   -visual-location>   
   +aural-location>
      ISA         audio-event
      :attended   nil
   +aural>
      ISA         sound
      event       =aural-location
   =goal>
      state       recall
!eval! (setf *response* "eror")
)

(P attend-location
   =goal>
      ISA         recall
   ?aural-location>
      state       free 
      - state     error 
      buffer      empty
!eval! (equal *response* "")
==>
   +aural-location>
      ISA         audio-event
      onset       highest
      :attended   nil
)

(P attend-sound
   =goal>
      ISA         recall
      state       recall
   =aural-location>
      ISA         audio-event
!eval! (equal *response* "")
==>
   +aural>
      ISA         sound
      event       =aural-location
   +aural-location>
      ISA         audio-event
      onset       highest
      :attended   nil
   =goal>
      state       attend
)

(P audicon-empty
   =goal>
      ISA         recall
      state       attend
   ?aural-location>
      state       error
!eval! (equal *response* "")
==>
   =goal>
      state       recall
)


(spp :u 100)

(spp attend-word :u 150)
(spp attend-location :u 145)
(spp attend-sound :u 150)
(spp retrieve-text :u 150)
(spp retrieve-sound-from-audicon :u 100)
 
(setf *actr-enabled-p* t)
)