;; -*- Mode: LISP; Syntax: Common-Lisp; Package: (USER); -*-
;**************************************************************
;*
;*  TURN-TAKING DESCRIPTORS AND SENSORS
;*
;*  HISTORY: 1994
;*           March 4: rudimentary descriptors and sensors (for User-has-turn)
;*           April 8: changed post and update to use a black-board w/time stamps.
;*           August : changed update mechanism to use values between 0 and 1.
;*                    now use a slot to indicate if a node should be updated.
;*           Oct-Dec: empower "update" to update the sensors from body stream.
;*                    
;*
;**************************************************************
;*
;* Explanation
;* 
;*   two classes: sensors (get raw data, hold computational directions)
;*    and descriptors (hold which sensors have to be true to be self
;*    posted as true). The descriptors have two lists; a positive list
;*    and a negative list depending on whether conditions should be
;*    true or false to make the node true.
;*   The UPDATE method will check to see if conditions are such that either
;*    a sensor or descriptor should be set to true. 
;*   The POST method will post a sensor or descriptor in a list called
;*    *turn-history* when their value changes.
;*


(in-package 'USER)

;****************************************
; DESCRIPTORS (INTEGRATORS)
;****************************************

(defun prepare-descriptors (node-list)
  (loop for (name slot2 slot3 slot4 slot5) 
        in node-list
        collect `(defparameter ,name
                    (make-instance 'turn-descriptor
                      :name ',name
                      :msgs ',name
                      :pos-cond ',slot2
                      :neg-cond ',slot3
                      :thresh ',slot4
                      :state ',slot5))))

(defmacro make-descriptors (node-list)
  (let ((forms (prepare-descriptors (symbol-value node-list))))
    `(progn ,@forms))
  )



;****************************************
; SENSORS
;****************************************

(defun prepare-sensors (node-list)
  (loop for (name type data1 data2 index1 index2 func state) 
	in node-list
        collect `(defparameter ,name
                     (make-instance ',type
                     :name   ',name
                     :msgs   ',name
		     :data1  ',data1
		     :data2  ',data2
		     :index1 ',index1
		     :index2 ',index2
                     :func   ',func
		     :state  ',state))))

(defmacro make-sensors (node-list)
  (let ((forms (prepare-sensors (symbol-value node-list))))
    `(progn ,@forms))
  )


;*****************************
;* UPDATE FUNCTIONS
;*****************************

(defmethod update ((list-of-nodes list)) 
  ;Top-level function, called with all nodes.
  "Receives a list of all nodes and updates the true ones."
 ; (print 'hello)
  (Unless (null list-of-nodes)
 ;   (print 'hello2)
    (dolist (node-x list-of-nodes)
 ;     (print 'num)(princ (name node-x))
      (update node-x)))
  )

(defmethod update ((node turn-descriptor))
 ; (if (equal (name node) 'addressing-me)
 ;     (describe node))
  (if (active node)    
   ;Only go through this if the node is allowed to be updated.
    (let ((old (state node))
          (new nil)
          (sum 0))
 ;     (print 'updating>)(princ (name node))
      (dolist (pair-x (pos-cond node))
        (let ((cond (first pair-x))
              (weight (second pair-x)))
          (if (call-BB cond)
            (setf sum (+ sum weight)))))
      (dolist (pair-x (neg-cond node))
        (let ((cond (first pair-x))
              (weight (second pair-x)))
          (if (not (call-BB cond))
            (setf sum (+ sum weight)))))
      (if (>= sum (thresh node))
        (setf new T))
      (if (has-changed? old new)
        (progn
    ;      (terpri)(princ "has changed>")(print (name node))
          (setf (state node) new)
          (post node)))
      ))
  (state node))

;Skip the "equal-v" check. 3/29 '95
(defmethod update ((node bs-fix-ref))
  (setf (data1 node) (eval (index1 node)))
  (setf (state node)
	(eval (list (func node) (data1 node) (eval (data2 node)))))
  (if (has-changed? (call-BB (name node)) (state node))
      (post node))
  (state node))

(defmethod update ((node bs-var-ref))
;  (princ "updating body-sensor w/variable reference.")
  (let ((New-Data1 (eval (index1 node)))
	(New-Data2 (eval (index2 node))))
    (setf (data1 node) New-Data1
	  (data2 node) New-Data2)
    (setf (state node) ;set the node state to what the eval returns.
	  (funcall (func node)(data1 node)(data2 node)))
    )
  (if (has-changed? (call-BB (name node)) (state node))
      (post node))
  (state node)
  )

(defmethod update ((node speech-sensor))
; Commands for data update omitted...
  (let ((curr-state node))
    (setf (state node)
          (funcall (func node) (data1 node)))
  ;  (unless (equal curr-state (state node))
    (if (has-changed? (call-BB (name node)) (state node)) ;saves time!
        (post node))
    (state node)
    ))

(defmethod update ((node socket-sensor))
; Commands for data update omitted...
  (setf (state node)
        (eval (list (func node) (data1 node))))
  (if (has-changed? (call-BB (name node)) (state node))
      (post node))
  (state node))

(defmethod update ((node inton-sensor))
;  (princ "intonation-sensor")
  (let ((New-Data (get-inton-data (index1 node))))
;    (unless (equal-v1 New-Data (data1 node)) ;Skip the "equal-v" check. 3/29 '95
;	    (progn
    (setf (data1 node) New-Data)
    (setf (state node) 
	  (eval (list (func node)(data1 node))))
;    )))
    )
  (if (has-changed? (call-BB (name node)) (state node))
    (post node))
  (state node)
  )

(defmethod update ((node spatio-temporal-sensor))
;  (princ "spatio-temporal")
  (if (has-changed? (call-BB (name node)) (state node))
    (post node))
  (state node)
  )

(defun has-changed? (old new)
  "Returns T if old and new are different."
  (not (eq old new)))

(defmethod equal-v1 (first second) ;A catch-all method
  (terpri)(princ "equal-v1 received non LINE values:")
  (princ first)(princ "  ")(print second))

(defmethod equal-v1 ((first array)(second array))
  (if (and (equalp first second))
      T
    nil))

(defmethod equal-v1 ((first Line)(second Line))
  "Tests if two obj of the class 'Line' are the same."
  (if (and (equalp (direction first)(direction second))
           (equalp (offset first)(offset second)))
      T
    nil))

(defmethod equal-v2 ((first Line)(second Line)(obj BS-var-ref))
  "Tests if two obj of the class 'Line' are the same."
  (let ((dir1 (direction (data1 obj)))
        (off1 (offset (data1 obj)))
        (dir2 (direction (data2 obj)))
        (off2 (offset (data2 obj))))
  (if (and (equalp (direction first) dir1)
           (equalp (offset first) off1)
           (equalp (direction second) dir2)
           (equalp (offset second) off2))
      T
    nil)))

(defmethod equal-v2 ((first Line)(second array)(obj BS-var-ref))
  "Tests if two obj--of the class 'Line'--are the same."
  (let ((dir1 (direction (data1 obj)))
        (off1 (offset (data1 obj)))
        (pos (data2 obj)))
  (if (and (equalp (direction first) dir1)
           (equalp (offset first) off1)
           (equalp second pos))
      T
    nil)))


(defmethod call-BB ((cond symbol))
  "Checks for the symbol in the turn-history buffer."
  (setf *temp-BB* *turn-history*)
  (do () ((or
            (eq cond (first (first *temp-BB*)))
            (null *temp-BB*))
            foo)
    (progn
      (pop *temp-BB*)))
;      (print *temp-BB*)))
  (second (first *temp-BB*)))

(defmethod call-BB ((cond turn-system-node))
  "Search BB and find newest posted state of cond. 
   Returns the state of the cond."
  (let ((*temp-BB* *turn-history*))
    (do () ((or
             (eq (name cond) (first (first *temp-BB*)))
             (null *temp-BB*))
            foo)
      (progn
        (pop *temp-BB*)))
;      (print *temp-BB*)))
    (second (first *temp-BB*))))

(defmethod call-BB ((a-function list))
  "If call-BB is called with e.g. (time-since), this method receives it."
;  (debug-print "this is probably a function call.")
  (eval a-function))

#| this is repeated below
(defmethod call-BB-stamp ((node turn-system-node))
  "Search BB and return time of last posting of node."
  (let ((*temp-BB* *turn-history*))
    (do () ((or (eq (name node) (first (first *temp-BB*)))
                (null *temp-BB*))
            foo)
      (progn
        (pop *temp-BB*)))
;      (print *temp-BB*)))
    (if (null (third (first *temp-BB*)))
        0
      (third (first *temp-BB*)))))
|#

;(defmethod call-BB-stamp ((node turn-system-node)) ;this would work if they had stamps!!
;  "Return the node's time-stamp for christssake."
;  (stamp node))

(defmethod call-bb-stamp-t ((node symbol))
  "Search BB and return time of last posting node as T."
  (let ((*temp-BB* *turn-history*))
    (do () ((or
	     (and (equal node (first (first *temp-BB*)))
		  (second (first *temp-BB*)))
	     foo))
      (pop *temp-BB*)
      )
    (if (null (third *temp-BB*))
	0
      (third (first *temp-BB*)))
    ))

(defmethod call-BB-stamp ((node turn-system-node))
  "Search BB and return time of last posting of node."
  (let ((*temp-BB* *turn-history*))
    (do () ((or
             (eq (name node) (first (first *temp-BB*)))
             (null *temp-BB*))
            foo)
      (progn
        (pop *temp-BB*)))
;      (print *temp-BB*)))
    (if (null (third (first *temp-BB*)))
        0
      (third (first *temp-BB*)))))

(defmethod call-BB-stamp (node)
  "Search BB and return time of last posting of node."
  (let ((*temp-BB* *turn-history*))
    (do () ((or
             (eq node (first (first *temp-BB*)))
             (null *temp-BB*))
            foo)
      (progn
        (pop *temp-BB*)))
;      (print *temp-BB*)))
    (if (null (third (first *temp-BB*)))
        0
      (third (first *temp-BB*)))))

(defmethod call-BB-stamp ((node turn-state-beh))
  "Return the node's timestamp."
  (stamp node))

(defmethod call-BB-stamp ((node symbol))
  "This is here to allow one to use 
   call-bb-stamp on kb-msgs-types."
  (if (kb-msgs-type node)
      (call-kb-stamp node)
    (call-next-method node))
  )


;**
;* April 8: Post now posts when a node changes, adds time
;* Oct. 10: Display function added to post.
;**

(defvar *turn-history* nil) ;This is the blackboard for posting changes.
;The format for posting is: "(node-name state time)".

(defmethod post ((node turn-descriptor))
  "Posts the node and it's state in *turn-history*."
  (if *display-on* (redraw-obj node))
  (push (list (name node) (state node) (time-stamp)) *turn-history*)
;  (print (list (name node)(state node)(time-stamp)))
  )

(defmethod post ((node sensor))
  "Posts the node and it's state in *turn-history*."
  (if *display-on* (redraw-obj node))
  (push (list (name node) (state node) (time-stamp)) *turn-history*)
;  (print (list (name node)(state node)(time-stamp)))
  )

(defmethod post ((node symbol))
  "Posts the node and it's state in *turn-history*."
  (post (eval node)))