;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 
;;; Author      : Leendert van Maanen
;;; Address     : Artificial Intelligence department 
;;;             : University of Groningen
;;;             : Grote Kruissstraat 2/1 9712 TS Groningen
;;;             : leendert@airug.nl
;;; 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 
;;; Filename    : race.lisp
;;; Version     : 2.0
;;; 
;;; Description : This package contains the hook-functions to adapt the declarative
;;; retrieval process of ACT-R to RACE (Van Maanen & Van Rijn, 2007).
;;;
;;; Bugs        : not yet
;;;
;;; To do (x = done)      : 
;;; x 1. loop with a prespecified frequency (200 Hz?)
;;; x 2. add spreading activation. Note that this should include *all* chunks, 
;;; not only the chunk-set (LvM221007 - currently only chunk-set)
;;; x 3. return winner chunk
;;; x 4. store parameters in local variables (or global?): solutoin: I created a module
;;; x 5. perceptual input
;;; x 6. add sji-hook to calculate prior strengths based on all chunks present in
;;; dm. (In other words, set the number of slots for the newliy created chunk)
;;; I rewrote proc-display and added the hook-call there (create-new-sjis, not really a hook)
;;; 7. perceptual influence before retrieval
;;; 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Design Choices: 
;;; 1. Followed functional design from Van Maanen & Van Rijn (2007).
;;; 2. What to do with chunks that are added to dm? It seems to me that these
;;; are necessarily associated with other, already present, chunks. For instance, new
;;; chunks are necessarily associated with buffer chunks at creation time. This 
;;; means that we have to add a sim-hook. Following prior strength equation
;;;  (Anderson & Lebiere 1998).
;;; 3. Which chunks should be part of retrieval set? I think chunks that are comparable
;;; in one critical stimulus dimension, cf., response congruency
;;; 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 
;;; The code
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

#+:packaged-actr (in-package :act-r)
#+(and :clean-actr (not :packaged-actr) :ALLEGRO-IDE) (in-package :cg-user)
#-(or (not :clean-actr) :packaged-actr :ALLEGRO-IDE) (in-package :cl-user)

(extend-chunks accumulated-activation :default-value 0) ;; this is the sum of accumulated activation
(extend-chunks last-accumulated-activation :default-value 0) ;; this is the activation at the previous time step

(defstruct race
  enabled
  ratio   ; retrieval ratio
  freq    ; update frequency (Hz)
  a       ; alpha scaling param
  b       ; beta scaling param
  trace   ; race trace 
  saliency; perceptual influence
  default-acc ; default accumulation starting value
  last-rt ; time stamp of last retrieval
)

;; redefine proc-display to call create-new-sjijs
(defun proc-display (&key clear)
  "Processes the current display."
  (verify-current-mp  
   "proc-display called with no current meta-process."
   (verify-current-model
    "proc-display called with no current model."
    (if (current-device-interface)
      (progn (process-display (current-device-interface) (get-module :vision) clear)
       (when (race-enabled (get-module race)) 
	 (create-new-sjis)))
      (print-warning "No device interface available to process")))))

;;; visual-race  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun create-new-sjis ()
  "creates associations between chunks in the visicon and chunks that relate to it in dm"
  ;; note: add-dm is called for debugging purposes. define-chunks should be 
  ;; enough since add-sji only checks if something is a chunk.
  ;; Also, this function is kinda illegal, since a 'copy' of this chunk is
  ;; created after the visicon item is cleared from the visual buffer - LvM241007

  ;; BUT: all-dm-chunks is what is being used to get the sources of activation
  ;; so, add-dm should be it for now. - LvM261007

  ;; What is missing now is some srt of clean-up to get rid of the old dm chunks that are
  ;; temporarilly created to create the sjis. Maybe check for each dm chunk if a visicon chunk
  ;; exists with its features, if not, than delete - LvM280508

  (let ((vis (visicon (get-module :vision)))
	(rm (get-module race)))
    (dolist (i vis)
      (let ((chunk-in-vis (first (add-dm-fct `((isa visual-location 
							kind ,(kind i)
							value ,(val i)
							color ,(color i)))))))
	(dolist (x (find-matching-chunks 
		    (define-chunk-spec-fct
			(append (list 'isa 'concept)
				(list 'value (color i))))))
	  (add-sji-fct `((,x ,chunk-in-vis ,(race-saliency rm)))))
	(dolist (x (find-matching-chunks 
		    (define-chunk-spec-fct
			(append (list 'isa 'lemma)
				(list 'value (val i))))))
  	  (add-sji-fct `((,x ,chunk-in-vis ,(* *wordpopout* (race-saliency rm)))))
	  (setf (chunk-base-level chunk-in-vis) 1.0)
	  (if (race-trace rm) 
	      (model-output "new chunk: ~a" chunk-in-vis))
	  )))))

(defmethod move-attention ((vis-mod vision-module) &key location scale)
  "This function is redefined as part of the RACE module - LvM280508"
  
  (declare (symbol scale))
  (if (eq (exec-s vis-mod) 'BUSY)
    (pm-warning "Attention shift requested at ~S while one was already in progress."
                (mp-time))
    (progn
      (when (tracked-obj vis-mod) (remove-tracking vis-mod))
      ;(setf (input-q vis-mod) nil)      ; gone, right?
      (setf (moving-attention vis-mod) t)
      (clear-attended vis-mod)
      (setf (last-scale vis-mod) scale)
      

      ;;; DAN save the chunk's name for the trace 
      
      (let ((chunk-name location))
        (setf location (psdme-to-dmo location))
        
        ;;; DAN
        ;;; clear the failure indicator
        
        (setf (attend-failure vis-mod) nil)

        ;;; Dan
          ;(queue-command
          ; :time (move-attn-latency vis-mod) :where :VISION :command 'encoding-complete
          ; :randomize t :params `(,location ,scale))

	;; LVM do a visual race to determine when a chunk is attendend (and which chunk):
        (when (race-enabled (get-module race)) (race-visual))
      
        (schedule-event-relative 
         (randomize-time (move-attn-latency vis-mod))
         'encoding-complete
         :destination :vision
         :module :vision
         :params (list location scale)
         :details ;(format nil "~S ~S ~S" 'encoding-complete chunk-name scale)
         ;; For speed don't use format on the fly
         (concatenate 'string "Encoding-complete "
           (symbol-name chunk-name)
           " "
           (symbol-name scale))
         :output 'medium))
      
      
      (setf (current-marker vis-mod) location)
      (set-clof vis-mod (dmo-to-xy location))
      (change-state vis-mod :exec 'BUSY :proc 'BUSY))))

(defun race-visual ()
;; computes spreading activation from perceptual features as well as retrieval of percepts
  (let ((chunktype (chunk-slot-value-fct (buffer-read 'goal) 'expect)))
    (let ((chunk (race-retrieval (find-matching-chunks
				 (define-chunk-spec-fct
				     (list 'isa chunktype))
                                 :chunks (all-dm-chunks (get-module declarative)))))
          (vis-mod (get-module :vision)))
    (when (listp chunk)
	(schedule-overwrite-buffer-chunk 'visual (car chunk) (cdr chunk) :module :vision :priority :min)
	(setf (move-attn-latency vis-mod) (cdr chunk))))))

;;; The retrieval-set hook  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun race-retrieval (chunk-set)
  ;; important values:
  ;; chunk-activation:                   Ai(t)
  ;; chunk-last-accumulated-activation:  Ai(t-1) (only for spreading activation)
  ;; chunk-accumulated-activation:       Ci(t)
  ;; base-level-activation:              Bi(t)

  (let ((dm (get-module declarative))
	(rm (get-module race)) 
	(rt 0.0))
    (cond (chunk-set
	   
	   (if (race-trace rm) (model-output "Current retrieval set: ~a" chunk-set))

	   ;; set all 'starting' values for RACE accumulation at current activation levels:
	   (if (race-last-rt rm)
	       (mapcar #'(lambda (x)
			   (setf (chunk-accumulated-activation x)
				 (racedecay rm x)
				 )
                           (if (race-trace rm) (model-output "Activation of ~a at retrieval start ~a" x (chunk-accumulated-activation x))))
                       (all-dm-chunks dm))
             (mapcar #'(lambda (x)
                         (setf (chunk-accumulated-activation x) (race-default-acc rm)))
                     (all-dm-chunks dm)))

	   ;; loop until ratio reached:
	   (loop until (>= (max-list (get-ratio dm chunk-set)) (race-ratio rm)) do
		(incf rt (/ 1 (race-freq rm)))
		
	      ;;reset all previous accumulated activation values:
		(mapcar #'(lambda (x)
			    (setf (chunk-last-accumulated-activation x) 
				  (chunk-activation x)))
			(all-dm-chunks dm))

	      ;; insert a fail option, e.g. a time limit
		  ;(when (< (max-list(mapcar 'chunk-activation chunk-set)) (dm-rt dm)) 
		  ;  (if (race-trace rm) (model-output "No chunk above the retrieval threshold: ~f" (dm-rt dm)))
;		    (setf (race-last-rt rm) (+ rt (mp-time)))
;		    (return-from race-retrieval rt)
                (let ((time-window (compute-activation-latency dm (dm-rt dm))))
		  (when (> rt time-window)
		  ;  (if (race-trace rm)
		;	(model-output "No declarative conflict resolution within time window of ~f" 
		;		      time-window))
                    (setf (race-last-rt rm) (+ time-window (mp-time)))
                  ;  (schedule-event-relative time-window #'retrieval-failure 
                   ;                          :module 'declarative 
                    ;                         :destination 'declarative)
                    (return-from race-retrieval rt)))
                
                (accumulate dm rm chunk-set)

                (if (race-trace rm) (model-output "Current Luce ratio: ~f" (max-list (get-ratio dm chunk-set))))
                (if (race-trace rm) (model-output "Current retrieval latency: ~f" rt)))
	   
           (if (race-trace rm) (model-output "Current Luce ratio: ~f" (max-list (get-ratio dm chunk-set))))
           (if (race-trace rm) (model-output "Current retrieval latency: ~f" rt))
	   ;; the part which selects the best chunk    
	   (dolist (chunk chunk-set)
	     (when (equalp (max-list (mapcar 'chunk-activation chunk-set))
                           (chunk-activation chunk))
               (if (race-trace rm) (model-output "Chunk to retrieve: ~a ~a" chunk (chunk-activation chunk)))
               (setf (race-last-rt rm) (+ rt (mp-time)))
               (return (cons chunk rt)))))
           (t  
            (if (race-trace rm) (model-output "No competitors!"))
            (setf (race-last-rt rm) (+ rt (mp-time)))
            rt))))

(defun get-ratio (dm chunk-set)
  "returns the Luce ratio for a chunk and a chunk-set's activation."
  (mapcar #'(lambda (x) (/ (exp (chunk-activation x))
			   (+ (sum-list (mapcar #'(lambda (y) 
						    (exp (chunk-activation y))) chunk-set))
			      (exp (dm-rt dm)))))
		    
	  chunk-set))

(defun accumulate (dm rm chunk-set)
  (dolist (chunk (all-dm-chunks dm))


    ;; summate all components of activation, but keeping a minimum of the baselevel activiation:
    (setf (chunk-activation chunk)
	  (max (base-level-activation dm chunk)
	       (+ (base-level-activation dm chunk)
		  (chunk-accumulated-activation chunk)
		  (activation-noise dm chunk)
		  )))

    ;; calculate new ones:
    (accumulate-activation dm rm chunk)

  ;(if (race-trace rm) (model-output "Chunk ~s has an activation of: ~a" chunk (chunk-activation chunk)))
    ))

(defun accumulate-activation (dm rm chunk)
  "calculates RACE decay and RACE evidence"
  (setf (chunk-accumulated-activation chunk)
	(+ (* (race-a rm) (chunk-accumulated-activation chunk))
	   (* (race-b rm) (spreading-activation-race dm chunk))))
)

(defun max-list (list)
  (cond ((atom list) list)
	((null (cdr list)) (max-list (car list)))
	(t (max (max-list (car list)) (max-list (cdr list))))))

(defun spreading-activation-race (dm chunk)
  (let ((sa 0.0))
    (cond ((remove chunk (all-dm-chunks dm))
	   ;;LvM221007 - Note here an interesting theoretical issue: what to do if there 
	   ;;are no competitors? Where does the SA comes from then? Idea: other 'layer' 
	   ;;of activation (or ultimately perception).
	   (dolist (source (remove chunk (all-dm-chunks dm)))

	     (let ((sji (compute-sji dm chunk source)))
	       (if (numberp sji)
		   (incf sa (* (chunk-last-accumulated-activation source) sji))
		   sa)
	       )))
	  (t 0.0))
    sa))

(defun racedecay (rm chunk)
  "calculates the activation value after an inter-retrieval interval. i.e., 
how much activation is left since the previous retrieval attempt? The minimum
is Bi."
  ;; Note that this does not take into account that Bi also decays, so 
  ;; theoretically the decay should be faster. However, this effect probably gets 
  ;; absorbed in te noise component. - LvM191207
  (* (expt (race-a rm) 
	   (* (race-freq rm)
	      (- (mp-time)
		 (race-last-rt rm))))
     (chunk-accumulated-activation chunk))
)


(defun set-init-baselevel (dm chunk)
  (setf (chunk-activation chunk) (base-level-activation dm chunk)))

(defun race-params (module param)
  (cond ((consp param)
         (case (car param)
           (:race-enabled (setf (race-enabled module) (cdr param))
			 (no-output 
			  (when (and (cdr param) 
				     (not (equal (sgp :retrieval-set-hook) 'race-retrieval)))
			    (sgp :retrieval-set-hook race-retrieval)))
			 (cdr param))

	   (:race-ratio (setf (race-ratio module) (cdr param)))
           (:race-freq (setf (race-freq module) (cdr param)))
           (:race-a (setf (race-a module) (cdr param)))
           (:race-b (setf (race-b module) (cdr param)))
           (:race-saliency (setf (race-saliency module) (cdr param)))
	   (:race-default-acc (setf (race-default-acc module) (cdr param)))
           (:race-trace (setf (race-trace module) (cdr param)))
	   (:race-last-rt (setf (race-last-rt module) (cdr param)))
	   ))
  
  (t 
   (case param
     
     (:race-enabled (race-enabled module))
     (:race-ratio (race-ratio module))
     (:race-freq (race-freq module))
     (:race-a (race-a module))
     (:race-b (race-b module))
     (:race-saliency (race-saliency module))
     (:race-default-acc (race-default-acc module))
     (:race-trace (race-trace module))
     (:race-last-rt (race-last-rt module))
     ))))



(define-module-fct 'race 
    nil
  (list (define-parameter :race-enabled :owner t :default-value nil :valid-test #'tornil
			  :documentation "Enable the race module - turning this on introduces a retrieval set hook and enables spreading activation from perceptual features"
			  :warning "T or nil")
        (define-parameter :race-ratio :owner t :default-value .95 :valid-test #'numberp
			  :warning "a number"
			  :documentation "Retrieval ratio (theta)")
        (define-parameter :race-freq :owner t :default-value 200 :valid-test #'nonneg
			  :warning "a positive number"
			  :documentation "Activation update frequency used by RACE (in Hz)")
        (define-parameter :race-a :owner t :default-value .7 :valid-test #'numberp
			  :warning "a number"
			  :documentation "RACE decay parameter")
        (define-parameter :race-b :owner t :default-value .7 :valid-test #'numberp
			  :warning "a number"
			  :documentation "RACE scaling parameter of spreading activation")
        (define-parameter :race-saliency :owner t :default-value 1.5 :valid-test #'numberp
			  :warning "a number"
			  :documentation "RACE parameter governing the perceptual influence")
        (define-parameter :race-default-acc :owner t :default-value 0 :valid-test #'numberp
			  :warning "a number"
			  :documentation "RACE parameter determining where accumulation should start")
        (define-parameter :race-trace :owner t :default-value nil :valid-test #'tornil
			  :warning "T or nil"
			  :documentation "Enable trace information on RACE")
        (define-parameter :retrieval-set-hook :owner nil)
	(define-parameter :race-last-rt :owner t :default-value nil :valid-test #'posnumornil
			  :warning "a positive number or nil"
			  :documentation "time stamp of last retrieval")
	)
  
  :creation (lambda (name) (declare (ignore name)) (make-race))
  :params #'race-params
  :version "1.1" 
  :documentation 
  "Module to enable the use of RACE retrievals (e.g., Van Maanen & Van Rijn (2007) Cognitive 
Systems Research (8))"
  )