;;;  -*- mode: LISP; Package: CL-USER; Syntax: COMMON-LISP;  Base: 10 -*-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 
;;; Author      : Mike Byrne
;;; Copyright   : (c)2006 Rice U./Mike Byrne, All Rights Reserved
;;; Availability: public domain
;;; Address     : Rice University
;;;             : Psychology Department
;;;             : Houston,TX 77251-1892
;;;             : byrne@acm.org
;;; 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 
;;; Filename    : visual-salience.lisp
;;; Version     : 1.0b1
;;; 
;;; Description : Modifies ACT-R's vision module to use salience computation
;;;             : to drive the results of +visual-location> requests.
;;; 
;;; Bugs        : Probably many.
;;; 
;;; Todo        : * Add switch to limit salience to things near CLOF.
;;;             : * Generate new vision module class with parameters which
;;;             :   can be set via SGP.  [later]
;;;             : * Probably some weird interaction with buffer stuffing.
;;; 
;;; ----- History -----
;;; 2006.07.19 mdb [b1]
;;;             : * Misc cleanup for public release.
;;; 2006.07.18 mdb [a2]
;;;             : * Added support for hook functions for Sji computation.
;;;             : * Removed library dependencies.
;;; 06.07.07 mdb [a1]
;;;             :  Started to bother with version numbering.
;;; 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

#+: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)


;(require :seq-math)
;(require :stats)


;;; All these parameters really should be stored in a slot in the vision module
(defparameter *sval-caches* nil)

(defparameter *salience-slot-gammas* 
  '((size . 0.30) (color . 0.40) (val . 0.30)))

(defparameter *salience-noise* 0.2)
(defparameter *salience-thresh* 0)
(defparameter *salience-source-act* 1)
(defparameter *max-salience-sji* 1)
(defparameter *salience-sji-hook* nil)


(defclass icon-feature ()
  ((screen-x :accessor screen-x :initarg :x :initform nil)
   (screen-y :accessor screen-y :initarg :y :initform nil)
   (distance :accessor distance :initarg :distance 
             :initform (when (current-device-interface) 
                         (viewing-distance (current-device-interface))))   
   (attended-p :accessor attended-p :initarg :attended-p :initform 'NEW)
   (kind :accessor kind :initarg :kind :initform 'visual-object)
   (val :accessor val :initarg :value :initform nil)
   (color :accessor color :initarg :color :initform 'black)
   (dmo-id :accessor dmo-id :initarg :dmo-id :initform nil)     	
   (screen-obj :accessor screen-obj :initarg :screen-obj :initform nil) 
   (height :accessor height :initarg :height :initform nil)
   (width :accessor width :initarg :width :initform nil)
   (size :accessor size :initarg :size :initform nil)
   (tstamp :accessor tstamp :initarg :tstamp :initform nil) 
   (obj-freq :accessor obj-freq :initarg :obj-freq :initform 0.01)
   (userprop1 :accessor userprop1 :initarg :userprop1 :initform nil)
   (userprop2 :accessor userprop2 :initarg :userprop2 :initform nil)
   (userprop3 :accessor userprop3 :initarg :userprop3 :initform nil)
   (userprop4 :accessor userprop4 :initarg :userprop4 :initform nil)
   ;; new salience stuff is here
   (bu-salience :accessor bu-salience :initarg :bu-salience :initform 0)
   (td-salience :accessor td-salience :initarg :td-salience :initform 0)
   (tot-salience :accessor tot-salience :initarg :tot-salience :initform 0)
   ))


(defun reset-bu-salience (lst)
  "Set all bottom-up salience values to zero."
  (mapc #'(lambda (i) (setf (bu-salience i) 0)) lst))

(defun reset-td-salience (lst)
  "Set all top-down salience values to zero."
  (mapc #'(lambda (i) (setf (td-salience i) 0)) lst))

(defmethod pre-noise-salience ((feat icon-feature))
  (+ (bu-salience feat) (td-salience feat)))

(defmethod effective-salience ((feat icon-feature))
  (if (< (tot-salience feat) (bu-salience feat))
    (bu-salience feat) 
    (tot-salience feat)))

;;;; ---------------------------------------------------------------------- ;;;;
;;;; Bottom-up salience
;;;; ---------------------------------------------------------------------- ;;;;

(defun compute-bottom-up-salience (feat-lst)
  "Compute bottom-up salience for a list of features."
  (setf *sval-caches* nil)
  (reset-bu-salience feat-lst)
  (let ((nfeats (length feat-lst)))
    (dolist (slotname (mapcar #'car *salience-slot-gammas*) feat-lst)
      ;; if we're going to clip to range of POG, do it here
      (let ((val-lst (mapcar #'(lambda (f) (slot-value f slotname)) feat-lst)))
        (if (not (every #'numberp val-lst))
          (process-symbolic-slot feat-lst slotname nfeats)
          (process-numeric-slot feat-lst slotname nfeats))))))


(defun process-numeric-slot (feat-lst slotname nfeats)
  "Increment bottum-up salience for a slot with all numeric values."
  (let ((z-scores (z-trans feat-lst 
                             :key #'(lambda (f) (slot-value f slotname)))))
    ;(print z-scores)
    (when z-scores
      (dotimes (i nfeats feat-lst)
        (incf (bu-salience (nth i feat-lst))
              (* (rest (assoc slotname *salience-slot-gammas*))
                 (prob->bits (z->prob (nth i z-scores)))))))))


(defun process-symbolic-slot (feat-lst slotname nfeats)
  "Increment bottum-up salience for a slot with not all numeric values."
  (let ((val-alst nil) featval)
    (dolist (feat feat-lst)
      (setf featval (slot-value feat slotname))
      ;; treat all strings as :TEXT
      (when (stringp featval) (setf featval :text))
      (aif (assoc featval val-alst)
        (push feat (rest it))
        (push (cons featval (list feat)) 
              val-alst)))
    (push (cons slotname val-alst) *sval-caches*)
    ;(print val-alst)
    (dolist (fval val-alst)
      (let ((prob (/ (1- (length fval)) nfeats)))
        (mapc #'(lambda (f) 
                  (incf (bu-salience f) 
                        (* (rest (assoc slotname *salience-slot-gammas*)) 
                           (prob->bits prob))))
              (rest fval))))))



(defmethod visicon-update :after ((vis-mod vision-module))
  ;; again, restrict to some area of CLOF?
  (compute-bottom-up-salience (visicon vis-mod))
  (stuff-visloc-buffer vis-mod))


;;;; ---------------------------------------------------------------------- ;;;;
;;;; Top-down salience
;;;; ---------------------------------------------------------------------- ;;;;

(defmethod find-location ((vis-mod vision-module) 
                             &key (kind :IGNORE) (attended :IGNORE) 
                             (value :IGNORE) (color :IGNORE) (size :IGNORE)
                             (userprop1 :IGNORE) (userprop2 :IGNORE)
                             (userprop3 :IGNORE) (userprop4 :IGNORE)
                             screen-x screen-y distance nearest)
  (reset-td-salience (visicon vis-mod))
  ;; Q:  Do we want to restrict to some area around CLOF?  Not too hard
  ;; to parameterize here.
  
  ;; update based on absolute matches, then relational matches
  (update-relational-matches vis-mod 
                             (update-abs-matches vis-mod screen-x screen-y 
                                                 distance) 
                             screen-x screen-y distance nearest)
  ;; now update those which match value constraints
  (update-feature-matches vis-mod kind value color size userprop1 userprop2
                          userprop3 userprop4)
  ;; filter on the attended slot--or should this be done before we do any 
  ;; salience computation?  Hmm.
  (let* ((attspec (make-instance 'feature-spec :attended-p attended))
         (feat-lst (remove-if-not #'(lambda (f) (test-attended attspec f))
                                    (visicon vis-mod))))
    ;; if anything's left, add noise and find highest-salience items
    (when feat-lst
      (mapc #'(lambda (feat) (setf (tot-salience feat)
                                    (+ (bu-salience feat) (td-salience feat)
                                       (act-r-noise *salience-noise*))))
            feat-lst)
      (setf feat-lst (objs-max-slotval feat-lst 'tot-salience))
      (when (> (tot-salience (first feat-lst)) *salience-thresh*)
        (construct-location 
         vis-mod 
         (random-item (objs-max-slotval feat-lst 'tstamp))
         (construct-findloc-spec 
          :kind kind :attended attended :value value :color color 
          :size size :screen-x screen-x :screen-y screen-y 
          :userprop1 userprop1 :userprop2 userprop2 :userprop3 userprop3
          :userprop4 userprop4 :distance distance :nearest nearest))))))
                       

(defmethod update-abs-matches ((vis-mod vision-module) screen-x screen-y
                                  distance)
  (let ((fspec (construct-findloc-spec :screen-x screen-x
                                        :screen-y screen-y :distance distance))
        match-lst fprob)
    (setf fspec (remap-spec-to-current vis-mod fspec))
    (setf match-lst (objs-match-spec (visicon vis-mod) fspec))
    (when match-lst
      (setf fprob (/ (length match-lst) (length (visicon vis-mod))))
      (mapc #'(lambda (f)
                (incf (td-salience f) (prob->bits fprob))) match-lst))))


(defmethod update-relational-matches ((vis-mod vision-module) feat-lst
                                           screen-x screen-y distance
                                           nearest)
  (when feat-lst
    (let (match-lst fprob)
      (case screen-x
        (lowest (push (objs-min-slotval feat-lst 'screen-x) match-lst))
        (highest (push (objs-max-slotval feat-lst 'screen-x) match-lst)))
      (case screen-y
        (lowest (push (objs-min-slotval feat-lst 'screen-y) match-lst))
        (highest (push (objs-max-slotval feat-lst 'screen-y) match-lst)))
      (case distance
        (lowest (push (objs-min-slotval feat-lst 'distance) match-lst))
        (highest (push (objs-max-slotval feat-lst 'distance) match-lst)))
      ;; handle the NEAREST flag
      (when (and nearest (not (eq nearest :IGNORE)))
        (push (case nearest
                (CURRENT (nearest-feat feat-lst (current-lof vis-mod)))
                (CURRENT-X (objs-nearest-slotval feat-lst 'screen-x 
                                                 (px (current-lof vis-mod))))
                (CURRENT-Y (objs-nearest-slotval feat-lst 'screen-y
                                                 (py (current-lof vis-mod))))
                (otherwise 
                 (nearest-feat feat-lst
                               (dmo-to-xy 
                                (psdme-to-dmo
                                 ;DAN (get-safe-wme (nearest base-spec)))))))))
                                 nearest)))))
              match-lst))
      ;; now, we have the list of relational matches.
      (setf match-lst (remove-duplicates (flatten match-lst)))
      (when match-lst
        (setf fprob (/ (length match-lst) (length feat-lst)))
        (mapc #'(lambda (f)
                  (incf (td-salience f) (prob->bits fprob))) match-lst)))))





(defmethod update-feature-matches ((vis-mod vision-module)
                                       kind value color size userprop1 
                                       userprop2 userprop3 userprop4)
  (let ((nslots (length (remove :ignore 
                                 (list kind value color size userprop1
                                       userprop2 userprop3 userprop4))))
        slotact)
    (when (> nslots 0)
      (setf slotact (/ *salience-source-act* nslots))
      (unless (eq kind :IGNORE)
        (proc-slot-matches (visicon vis-mod) 'kind kind slotact))
      (unless (eq color :IGNORE)
        (proc-slot-matches (visicon vis-mod) 'color color slotact))
      (unless (eq value :IGNORE)
        (proc-slot-matches (visicon vis-mod) 'val value slotact))
      (unless (eq size :IGNORE)
        (proc-slot-matches (visicon vis-mod) 'size size slotact))
      
      (unless (eq userprop1 :IGNORE)
        (proc-slot-matches (visicon vis-mod) 'userprop1 userprop1 slotact))
      (unless (eq userprop2 :IGNORE)
        (proc-slot-matches (visicon vis-mod) 'userprop2 userprop2 slotact))
      (unless (eq userprop3 :IGNORE)
        (proc-slot-matches (visicon vis-mod) 'userprop3 userprop3 slotact))
      (unless (eq userprop4 :IGNORE)
        (proc-slot-matches (visicon vis-mod) 'userprop4 userprop4 slotact))))
  ;; wow, this is pretty hideous code.  Clean it up sometime.
  )
   
   
(defun proc-slot-matches (feat-lst slotname criterion activ)
  "Process salience for features which match a criterion on a particular slot."
  ;; if there's a hook function, use that
  (aif *salience-sji-hook*
    (dolist (feat feat-lst feat-lst)
      (incf (td-salience feat) 
            (* activ (funcall *salience-sji-hook* slotname criterion 
                              (slot-value feat slotname)))))
    ;; there's no hook function.  Try fast symbol matching using the stored
    ;; value caches
    (progn
      (when (symbolp criterion)
        (awhen (assoc slotname *sval-caches*)
          (awhen (assoc criterion (rest it))
            (mapc #'(lambda (f) (incf (td-salience f) activ)) (rest it))
            (return-from proc-slot-matches feat-lst))))
      ;; ok so no dice there, do it the slow way by walking through the entire 
      ;; list and matching stuff
      (dolist (feat feat-lst feat-lst)
        (incf (td-salience feat) 
              (* activ (default-l-sji criterion (slot-value feat slotname))))))
    ))


(defun default-l-sji (criterion value)
  "If the value matches the criterion, return the max Sji, otherwise 0."
  (if (slotval-match? criterion value) *max-salience-sji* 0))






;;;; ---------------------------------------------------------------------- ;;;;
;;;; Printing with salience values
;;;; ---------------------------------------------------------------------- ;;;;

(defun print-visicon ()
  "Print the Vision Module's visicon. For debugging."
  (awhen (get-module :vision)  ;; Test that there is a vision module
    (format t "~%Loc        Att   Kind           Value             Color           ID		BU-L	TD-L")
    (format t "~%---------  ---   -------------  ----------------  --------------  ----------	----	----")
    (dolist (feat (visicon it))
      (print-icon-feature feat))))



(defmethod enter-into-visicon ((feat icon-feature) (time number))
  (unless (dmo-id feat)
    (setf (dmo-id feat) 
          (new-name-fct (if (eq (kind feat) 'visual-object)
                          'VISOBJ
                          (kind feat)))))
  (setf (tstamp feat) time)
  feat)


(defmethod print-icon-feature ((feat icon-feature))
  (format t "~%(~3D ~3D)~11T~A~17T~A~32T~S~50T~A~66T~A~79T~5,2F~87T~5,2F"
          (screen-x feat) (screen-y feat) 
          (feat-attended feat ;(vis-m *mp*))
                         (get-module :vision))
          (kind feat)  
          (val feat)
          (color feat)
          (dmo-id feat)
          (bu-salience feat)
          (td-salience feat)
          ))




;;;; ---------------------------------------------------------------------- ;;;;
;;;; Math utilities
;;;; ---------------------------------------------------------------------- ;;;;


(defun prob->bits (p)
  "Convert a probability to a bit value via Hick-Hyman computation."
  (if (or (> p 1) (< p 0))
    (error "Illegal probability ~S passed to PROB->BITS." p)
    (log (/ 1 p) 2)))


(defun z->prob (z)
  "Convert a z-score to absolute value and compute the appropriate probability."
  (setf z (abs z))
  (* 2 (- 1 (normal-cumulative z))))


(defun z-trans (seq &key key)
  "Returns a sequence of z-scores based on input sequence."
  (multiple-value-bind (mean stdev)
                       (seq-mean-stdev seq :key key)
    (if (zerop stdev)
      nil
      (map (type-of seq) #'(lambda (n) (/ (- 
                                            (if key (funcall key n)
                                                n)
                                            mean) stdev)) seq))))

(defgeneric seq-mean-stdev (seq &key key)
  (:documentation "Returns the mean and the standard deviation of a sequence of numbers.  Returns nil when passed an empty sequence."))


(defmethod seq-mean-stdev ((seq vector) &key key)
  (let ((accum 0) (len (length seq)) (sumsq 0) tmp mean)
    (unless (zerop len)
      (dotimes (i len)
        (setf tmp (if key (funcall key (svref seq i)) (svref seq i)))
        (incf accum tmp)
        (incf sumsq (* tmp tmp)))
      (setf mean (float (/ accum len)))
      (values mean
              (when (> len 1)
                (sqrt (/ (- sumsq (* len (* mean mean))) (- len 1))))))))


(defmethod seq-mean-stdev ((seq list) &key key)
  (unless (null seq)
    (let ((accum 0) (len 0) (sumsq 0) mean)
      (dolist (item seq)
        (when key (setf item (funcall key item)))
        (incf accum item)
        (incf sumsq (* item item))
        (incf len))
      (setf mean (float (/ accum len)))
      (values mean
              (when (> len 1) 
                (sqrt (/ (- sumsq (* len (* mean mean))) (- len 1))))))))



(defun normal-density (x)
  (/ (exp (* -0.5 x x)) (sqrt (* 2.0 (float pi 1.0)))))


(defmacro horner-m (c e)   `(cons ,c ,e))
(defmacro horner-c (coeff) `(car ,coeff))
(defmacro horner-e (coeff) `(cdr ,coeff))


;;; take a list of coefficients (a0 a1 a2 a3 a4)
;;; and turn it into the horner form ((a0 0) (a1 1) ... )
;;;
(defun horner-coef-list-1 (as e)
  (if (null as)
    nil
    (cons (horner-m (car as) e)
          (horner-coef-list-1 (cdr as) (1+ e)))))

(defun horner-coef-list (as)
  (horner-coef-list-1 as 0))

;;; lookup a variable name in the dictionary
;;;   if it is not there, then add it
;;;
(defun horner-lookup (e dict)
  (if (assoc e (cdr dict) :test #'equal)
    (cdr (assoc e (cdr dict) :test #'equal))
    (let ((var (gensym (1- e))))
      (setf (cdr dict)
            (cons (cons e var) (cdr dict)))
      var)))

(defmacro horner-polynomial (exp . coeffs)
  (let* ((c-list (horner-knock-out (horner-coef-list coeffs)))
	 (diffs  (horner-deltas 0 c-list '()))
	 (dict   (list 'dict))
	 (maker  (horner-var-maker exp diffs '() dict)))
    `(let* ,maker
       ;; (DECLARE (FLOAT ,@(horner-dict-vars dict)))
       ,(horner-body 0 c-list dict))))

;;; take a horner list of coefficients and
;;; knock all terms with zero coefficients
;;;
(defun horner-knock-out (horner-list)
  (cond ((null horner-list) nil)
	((zerop (horner-c (car horner-list)))
	 (horner-knock-out (cdr horner-list)))
	(t
	 (cons (car horner-list)
	       (horner-knock-out (cdr horner-list))))))

;;; find a list of all the differences in exponents
;;;
(defun horner-deltas (e horner-list acc)
  (cond ((null horner-list) acc)		; no coefficients, no work
        ((= e (horner-e (car horner-list)))	; no difference, so no delta
         (horner-deltas e (cdr horner-list) acc))
        (t					; we have a delta
         (let ((en (horner-e (car horner-list))))
           (horner-deltas en
                          (cdr horner-list)
                          (horner-adjoin (- en e) acc)
                          )))))

(defun horner-adjoin (x set)
  (if (member x set :test #'equal)
    set
    (sort (cons x set) #'>)))


;;;; Construct LET* Variable List and the LET* Body

;;; make a variable list for a LET* form
;;;
(defun horner-var-maker (exp d-list v-list dict)
  (if (null d-list)				; if all done
    v-list					; return the variable and dictionary
    (let ((d (car d-list)))
      (if (= d 1)
        (horner-var-maker exp
                          (cdr d-list)
                          (cons `(,(horner-lookup 1 dict) ,exp) v-list)
                          dict)
        (let* ((d0 (floor d 2))
               (d1 (- d d0)))
          (horner-var-maker exp
                            (horner-adjoin d1 (horner-adjoin d0 (cdr d-list)))
                            (cons `(,(horner-lookup d dict)
                                    (* ,(horner-lookup d1 dict)
                                       ,(horner-lookup d0 dict)))
                                  v-list)
                            dict))))
    ))

;;; return an expression that when multiplied by x^e
;;;   evaluates the polynomial specified by coeffs
;;;
(defun horner-body (e coeffs dict)
  (if (null coeffs)
    0.0					; empty expression
    (let ((coef (car coeffs)))
      (if (= (horner-e coef) e)		; time to add in a term?
        (if (null (cdr coeffs))		; eg, 7x^12 and e=12
          `,(horner-c coef)
          `(+ ,(horner-c coef)
              ,(horner-body e (cdr coeffs) dict)))
        `(* ,(horner-lookup (- (horner-e coef) e) dict)
            ,(horner-body (horner-e coef) coeffs dict)))
      )))


(defun normal-cumulative (x)
  (flet ((nctail (x)				; eps < 7.5e-8
	   (declare (ftype (function (float) float) nctail))
	   (let ((z (/ 1.0 (1+ (* 0.2316419 x)))))
	     (declare (float z))
	     (* (NORMAL-DENSITY x)
		(horner-polynomial z
				   0.0
				   0.319381530
				   -.356563782
				   1.781477937
				   -1.821255978
				   1.330274429)))))
    (if (< x 0.0)
	(nctail (- x))
	(- 1.0 (nctail x)))))