;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;                                                                     ;;;
;;;  Model of PRP task as described in Fagot & Pashler (1992), JEP-HPP  ;;;
;;;  Experiment 7 - Stroop & Aural-Manual                               ;;;
;;;                                                                     ;;;
;;;  Jelmer Borst & Leendert van Maanen                                 ;;;
;;;  University of Groningen                                            ;;;
;;;  jpborst@ai.rug.nl / leendert@ai.rug.nl                             ;;;
;;;                                                                     ;;;
;;;  080116                                                             ;;;
;;;                                                                     ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(clear-all)

(setf *act-r-enabled-p* t)


(defvar *perceive* t)
(defvar *concept-rt* nil)
(defvar *lemma-rt* nil)
(defvar *lexeme-rt* nil)
(defvar *retrieval-onset* nil)

(defparameter *RT1Con* nil)
(defparameter *RT1Rel* nil)
(defparameter *RT1Unrel* nil)
(defparameter *RT2Con* nil)
(defparameter *RT2Rel* nil)
(defparameter *RT2Unrel* nil)

(defparameter *RT1ConTotal* nil)
(defparameter *RT1RelTotal* nil)
(defparameter *RT1UnrelTotal* nil)
(defparameter *RT2ConTotal* nil)
(defparameter *RT2RelTotal* nil)
(defparameter *RT2UnrelTotal* nil)

(defparameter *act* nil)

(defparameter *am-start* nil)
(defparameter *condition* nil)
(defparameter *done-am* nil)
(defparameter *done-stroop* nil)
(defparameter *done* nil)

(defparameter *response-time* nil)
(defparameter *response* nil)
(defparameter *responses* nil)

(defparameter *name-stimuli* '(("rood" red "rood" "C")
                         ("groen" red "rood" "R")
                         ("XXXXX" red "rood" "U")))

(defparameter *output-pathname* (current-pathname))

(defun do-trial (soa trial window)
  (reset)
  (setf *perceive* t)
  (setf *done* nil)
  (setf *done-am* nil)
  (setf *done-stroop* nil)
  (goal-focus am)
  ;(goal-focus naming)
  (setf *condition* (fourth trial))
  
  ;(format t "~%~%~%")
 ; (print *condition*)
  
  (let ((tone (act-r-random 2))
        (start-time nil))
   
    (cond
     ((> soa 0)
      (new-tone-sound (case tone (0 300) (1 800)) .3 0)
      (setf *am-start* (get-time))

      (schedule-event-relative (/ soa 1000) 'add-exp-txt :params trial)
      (setf start-time (+ (get-time) soa)))
   
     ((< soa 0)      
      (new-tone-sound (case tone (0 300) (1 800)) .3 (/ (abs soa) 1000))
      (setf *am-start* (+ (get-time) (abs soa)))
     ; (format t "start: ~a" *am-start*)))    
      (setf start-time (get-time))
      (add-text-to-exp-window :text (first trial) :x 130 :y 110 :width 60 :color (second trial))))
        
    (when *actr-enabled-p* 
      (proc-display)
      ;(schedule-periodic-event 0.05 'store-act :priority :max)
      (run 30))
    (while (null *done*) 
      (allow-event-manager window))
    (clear-exp-window)
    (proc-display)
    (if *response-time*
      (cond ((equalp (fourth trial) "C")
          (push (- *response-time* start-time) *RT2Con*))
            ((equalp (fourth trial) "U")
             (push  (- *response-time* start-time) *RT2Unrel*))
            (t
             (push  (- *response-time* start-time) *RT2Rel*))))
    (push *response* *responses*)))

(defun add-exp-txt (text color na na2)
  (declare (ignore na))
  (declare (ignore na2))
  (add-text-to-exp-window :text text :x 130 :y 110 :width 60 :color color)
  (proc-display)  
)

(defun do-1-trial (soa cond)
  (setf *responses* nil)
  (setf *activations* nil)

  
  (let ((window (open-exp-window "PRP Stroop"                                      
                                 :visible nil
                                 :width 300
                                 :height 300))) 
    (if *act-r-enabled-p* (install-device window))
    
    (setf *RT1Con* nil)
    (setf *RT1Rel* nil)
    (setf *RT1Unrel* nil)
    (setf *RT2Con* nil)
    (setf *RT2Rel* nil)
    (setf *RT2Unrel* nil)
    (do-trial 
     soa 
     (cond ((equalp cond "C") '("rood" red "rood" "C"))
           ((equalp cond "R") '("groen" red "rood" "R"))
           (t '("XXXXX" red "rood" "U")))
     window)
    (print-tabbed (format nil "RT1 Con: ~$ ~$~%RT1 Rel ~$ ~$~%RT1 Unrel ~$ ~$~%RT2 Con: ~$ ~$~%RT2 Rel ~$ ~$~%RT2 Unrel ~$ ~$~%"
              (myavg *RT1Con*) (stddev *RT1Con*)
              (myavg *RT1Rel*) (stddev *RT1Rel*)
              (myavg *RT1Unrel*) (stddev *RT1Unrel*)
              (myavg *RT2Con*) (stddev *RT2Con*)
              (myavg *RT2Rel*) (stddev *RT2Rel*)
              (myavg *RT2Unrel*) (stddev *RT2Unrel*)))))
  

(defun do-experiment (&optional (trials 100) (filename nil))
  (setf *responses* nil)
  (setf *RT1ConTotal* nil)
  (setf *RT1RelTotal* nil)  
  (setf *RT1UnrelTotal* nil)
  (setf *RT2ConTotal* nil)
  (setf *RT2RelTotal* nil)
  (setf *RT2UnrelTotal* nil)
  
  (let ((window (open-exp-window "PRP Stroop"                                      
                                 :visible nil
                                 :width 300
                                 :height 300))) 
    (if *act-r-enabled-p* (install-device window))
    (dolist (soa '(100 349 800))
      (setf *RT1Con* nil)
      (setf *RT1Rel* nil)
      (setf *RT1Unrel* nil)
      (setf *RT2Con* nil)
      (setf *RT2Rel* nil)
      (setf *RT2Unrel* nil)
      (dotimes (i trials)
        (dolist (x (permute-list *name-stimuli*))
          (do-trial soa x window)))
  
      (format t "~%~%SOA ~a:~%---------------~%" soa)
      (print-tabbed (format nil "RT1 Con: ~$ ~$~%RT1 Rel ~$ ~$~%RT1 Unrel ~$ ~$~%RT2 Con: ~$ ~$~%RT2 Rel ~$ ~$~%RT2 Unrel ~$ ~$~%"
              (myavg *RT1Con*) (stddev *RT1Con*)
              (myavg *RT1Rel*) (stddev *RT1Rel*)
              (myavg *RT1Unrel*) (stddev *RT1Unrel*)
              (myavg *RT2Con*) (stddev *RT2Con*)
              (myavg *RT2Rel*) (stddev *RT2Rel*)
              (myavg *RT2Unrel*) (stddev *RT2Unrel*)))
      (push (list soa *RT1Con*) *RT1ConTotal*)
      (push (list soa *RT1Rel*) *RT1RelTotal*)
      (push (list soa *RT1Unrel*) *RT1UnrelTotal*)
      (push (list soa *RT2Con*) *RT2ConTotal*)
      (push (list soa *RT2Rel*) *RT2RelTotal*)
      (push (list soa *RT2Unrel*) *RT2UnrelTotal*)))
      (if filename (write-data filename)))


(defun store-act ()
  (let ((dm (get-module declarative)))
    (push (list (mp-time) (query-buffer 'retrieval '((state . busy))) (all-dm-chunks dm) (mapcar 'chunk-accumulated-activation (all-dm-chunks dm))) *activations*)
))

;;devices

(defmethod device-speak-string ((win rpm-window) text)
  (setf *response-time* (get-time))
  (setf *response* text)
  (setf *done-stroop* t)
  (if (and *done-am* *done-stroop*) (setf *done* t)))

(defmethod rpm-window-key-event-handler ((win rpm-window) key)
 ; (format t "~%Key press: gettime: ~a, *start: ~a~%key: ~a~%" (get-time) *am-start* key)
  (cond ((equalp *condition* "C")
      (push (- (get-time) *am-start*) *RT1Con*))
        ((equalp *condition* "R")
         (push (- (get-time) *am-start*) *RT1Rel*))
        (t
         (push (- (get-time) *am-start*) *RT1Unrel*)))
  (setf *done-am* t)
  (if (and *done-am* *done-stroop*) (setf *done* t)))

(defmethod queue-output-events ((spch-mod speech-module) (mvmt speak))
;  (new-word-sound (text mvmt) (+ (mp-time) (exec-time mvmt)))
  (queue-command
   :time (exec-time mvmt) :where :DEVICE :command 'output-speech
   :params (text mvmt)
   ;;; Dan
   :from :speech))

;;; help functions for stats: ;;;;
(defmacro my/ (x y) `(if (zerop ,y) 0 (/ ,x ,y)))

(defun stddev (lst)
  (let* ((lst (remove nil lst))
	 (avg (average lst)))
    (sqrt (my/ (let ((sum 0))
		 (dolist (x lst) (incf sum (* (- x avg) (- x avg))))
		 sum)
	       (- (length lst) 1)))))

(defun stderr (lst)
  (let ((lst (remove nil lst)))
    (my/ (stddev lst) (sqrt (length lst)))))

(defun average (lst)
  (let ((lst (remove nil lst)))
    (if (null lst)
	nil
	(let ((sum 0))
	  (dolist (x lst) (incf sum x))
	  (my/ sum (length lst))))))

(defun myavg (lst)
  (let ((total 0)
        (j 0))
    (dolist (i lst)
     ; (format t "~a" (second i))
      (when (and (not (null i)) (> i 0))
        (incf total i)
        (incf j)))
    (if (not (equalp (length lst) 0)) (/ total j) 0)));"division by zero")))

(defun print-tabbed (string &rest args)
  (apply #'format (append (list t (substitute #\Tab #\Space string)) args)))

(defun print-table (rows &optional (fs "~a") (line t))
  (let ((fs (format nil " ~a" fs)))
    (let ((row (first rows)))
      (print-tabbed "~a" (first row))
      (dolist (x (rest row)) (print-tabbed fs x))
      (print-tabbed "~%")
      (when line
	(dotimes (i (length row))
	  (let ((slen (length (format nil (nth i row)))))
	    (dotimes (j (ceiling slen 8))
	      (print-tabbed "--------"))))
	(print-tabbed "~%")))
    (dolist (row (rest rows))
      (print-tabbed "~a" (first row))
      (dolist (x (rest row)) (print-tabbed fs x))
      (print-tabbed "~%"))))

(defun bipartite (list1 list2)
  (if (equalp (length list1) 1)
      (cons (list (car list1) (car list2)) nil)
      (cons (list (car list1) (car list2)) (bipartite (cdr list1) (cdr list2)))
      ))

;; write to file

(defun write-act (filename)
  (setf *output-pathname* (make-pathname :name (format nil "~a" filename) :type "txt" :defaults *output-pathname*))
  (with-open-file (stream *output-pathname* 
			  :direction :output 
			  :if-does-not-exist :create 
			  :if-exists :supersede)
    (dolist (times *activations*)
      (mapcar #'(lambda (x) (format stream "~a ~a ~a ~a~%" (first times) (second times) (first x) (second x))) (bipartite (third times) (fourth times))))))


(defun write-data (filename)
  (with-open-file (stream (format nil "~a.txt" filename) :direction :output :if-exists :supersede :if-does-not-exist :create)
    (dolist (trials *RT1ConTotal*)
      (mapcar #'(lambda (x) (format stream "RT1 Con ~a ~a~%" (car trials) x)) (cadr trials)))
    (dolist (trials *RT1RelTotal*)
      (mapcar #'(lambda (x) (format stream "RT1 Rel ~a ~a~%" (car trials) x)) (cadr trials)))
    (dolist (trials *RT1UnrelTotal*)
      (mapcar #'(lambda (x) (format stream "RT1 Unrel ~a ~a~%" (car trials) x)) (cadr trials)))
    (dolist (trials *RT2ConTotal*)
      (mapcar #'(lambda (x) (format stream "RT2 Con ~a ~a~%" (car trials) x)) (cadr trials)))
    (dolist (trials *RT2RelTotal*)
      (mapcar #'(lambda (x) (format stream "RT2 Rel ~a ~a~%" (car trials) x)) (cadr trials)))
    (dolist (trials *RT2UnrelTotal*)
      (mapcar #'(lambda (x) (format stream "RT2 Unrel ~a ~a~%" (car trials) x)) (cadr trials)))
))

(defun set-rt-params ()
  (setf *concept-rt* nil)
  (setf *lemma-rt* nil)
  (setf *lexeme-rt* nil)
  (setf *retrieval-onset* nil)
)

(defun do-rt (trials filename)
  (set-rt-params)
  (dotimes (i trials t) (do-one-naming (second *name-stimuli*)))
  (write-rt filename))

(defun log-rt (stack)
  (let ((rm (get-module race)))
    (push (- (race-last-rt rm) *retrieval-onset*) stack)))

(defun write-rt (filename)
  (with-open-file (stream filename :direction :output :if-exists :supersede :if-does-not-exist :create)
      (format stream "concept," *lemma-rt*)
      (mapcar #'(lambda (x) (format stream "~a," x)) *concept-rt*)
      (format stream "~%lemma," *lemma-rt*)
      (mapcar #'(lambda (x) (format stream "~a," x)) *lemma-rt*)
      (format stream "~%lexeme," *lemma-rt*)
      (mapcar #'(lambda (x) (format stream "~a," x)) *lexeme-rt*)))


(defparameter *wordpopout* 3)

(define-model PRP-PWI

(sgp
 :v nil
 :trace-detail low
 :act nil
 :tone-detect-delay 0.049;.049 ;.349
 :tone-recode-delay 0.385 :alpha 0.05 :egs 0.04 ; :VISUAL-ATTENTION-LATENCY 0.05 ;.285
 :MOTOR-FEATURE-PREP-TIME .04 ;.01
 :MOTOR-INITIATION-TIME .04 ;.01

 :bll nil
 :esc nil
 :ol nil
 :rt -2
 :lf 5
 :ans .3
 :pas nil
 :race-enabled t
 :race-ratio .95
 :race-freq 200
 :race-a .85
 :race-b .7
 :race-saliency .55;.7 voor stroop:1.5 voor pwi: ?
 :race-default-acc 0
 :race-trace nil

 :save-buffer-trace t
 :traced-buffers (visual aural retrieval manual vocal production)
)


;;aural manual declarations

(chunk-type stimresp tone key)
(chunk-type aural-vocal expect state)

(add-dm
 (s-r1 isa stimresp tone 300 key "f")
 (s-r2 isa stimresp tone 800 key "j")

 (am isa aural-vocal expect concept state "start")
 (concept isa chunk)
)

(set-base-levels
 (s-r1 4)
 (s-r2 4)
)

(add-sji
 (s-r1 s-r2 0)
 (s-r2 s-r1 0)
)

;;stroop declarations
(chunk-type lemma value concept)
(chunk-type concept value)
(chunk-type wordform value)
(chunk-type naming expect state)
(chunk-type reading expect state)

(add-dm
 (red-lemma isa lemma value "rood" concept red)
 (green-lemma isa lemma value "groen" concept green)
 ;(black-lemma isa lemma value "zwart" concept black)
 (xxxxx-lemma isa lemma value "xxxxx" concept "nil")
 (red-concept isa concept value red)
 (green-concept isa concept value green)
 (black-concept isa concept value black)
 (red-wordform isa wordform value "rood")
 (green-wordform isa wordform value "groen")
 (black-wordform isa wordform value "zwart")

 (naming isa naming expect concept state "start")
 (reading isa reading expect lemma state "start")
 (lemma isa chunk)
)

(set-base-levels
 (red-lemma .01)
 (green-lemma .01)
 ;(black-lemma .01)
 (xxxxx-lemma -1000000000)
 (red-concept .01)
 (green-concept .01)
 (black-concept -1000000000)
 (red-wordform .01)
 (green-wordform .01)
 (black-wordform .01)
)

(add-sji
 (red-wordform red-lemma .02)
 (green-wordform green-lemma .02)

 (red-lemma red-concept .02)
 (green-lemma green-concept .02)

 (red-concept red-lemma .03); .8)
 (green-concept green-lemma .03);.8)

 (red-concept green-concept .03)
 (green-concept red-concept .03)
)

;;; Aural Manual task

(p detect-tone
  =goal>
   isa aural-vocal
  =aural-location>
    isa audio-event
  ?aural>
    state free
==>
  +aural>
    isa sound
    event =aural-location
)

(p attend-tone
  =goal>
    isa aural-vocal
  =aural>
    isa sound
    content =snd
  ?retrieval>
    state free
    buffer empty
==>
  +retrieval>
    isa stimresp
    tone =snd
)

(p respond
  =goal>
     isa aural-vocal
  =retrieval>
    isa stimresp
    key =key
  ?manual>
    state free
==>
  +manual>
   isa press-key
   key =key
  +goal>
    isa naming
    expect concept
    state "busy"

)

;;; Stroop naming task



(p perceive-stimulus-naming
   =visual-location>
      isa visual-location
   ?visual>
      state free
      buffer empty
   ;=goal>
    ;  isa naming
   !eval! *perceive*
   ==>
   +visual>               
      isa      move-attention
      screen-pos =visual-location
   =visual-location>
   !eval! (setf *perceive* nil)
   !eval! (setf *retrieval-onset* (mp-time))
)

#|
(p retrieve-concept
   =visual>
      isa text
   =goal>
      isa naming
      task "naming"
      - state "stop"
   ?retrieval>
      state free
      buffer empty
==>
   +retrieval>
      isa concept
   =visual>
)
|#

(p retrieve-lemma
   =visual>
      isa concept
      value =color
   =goal>
      isa naming
      - state "stop"
    ?retrieval>
      state free
      buffer empty
   !eval! (setf *concept-rt* (log-rt *concept-rt*))
   ==>
   +retrieval>
      isa lemma
      concept =color
      :recently-retrieved nil
   =visual>
   !eval! (setf *retrieval-onset* (mp-time))
)


(p reject-lemma-naming
   =retrieval>
      isa lemma
      concept =color
   =visual-location>
      isa visual-location
      - color =color
   =goal>
      isa naming
      - state "stop"
    ?retrieval>
      state free
   !eval! (setf *lemma-rt* (log-rt *lemma-rt*))
   ==>
   +retrieval>
      isa lemma
      :recently-retrieved nil
   =visual>
   =visual-location>
   !eval! (setf *retrieval-onset* (mp-time))
)

(p encode-response-naming
   =retrieval>
      isa lemma
      concept =color
      value =val
   =visual-location>
      isa visual-location
      color =color
   =goal>
      isa naming
      - state "stop"
    ?retrieval>
      state free
   !eval! (setf *lemma-rt* (log-rt *lemma-rt*))
   ==>
   +retrieval>
      isa wordform
      value =val
   !eval! (setf *retrieval-onset* (mp-time))
)



(p respond-stroop
   =retrieval>
      isa wordform
      value =val
   ?vocal>
      state free
   =goal>
      isa naming
      - state "stop"
   !eval! (setf *lexeme-rt* (log-rt *lexeme-rt*))
   ==>
   +vocal>
      isa speak
      string =val
   =goal>
      state "stop"
   -visual>
)

)