;; -*- Mode: LISP; Syntax: Common-Lisp; Package: (USER); -*-
;***************************************************************
;*
;*  BEHAVIOR MODULES FOR TURN-TAKING
;*
;*  HISTORY: April '94; basic behaviors such as ask and execute
;*           Jan   '96: added spatial behaviors
;*
;*
;***************************************************************
;*
;* Explanation
;*    There are now behaviors for changing the internal states
;*    between give-turn, take-turn (and later should be dialogue-not-started
;*    and dialogue-concluding). The general behaviors related to turn-taking
;*    are show-give-turn and show-take-turn. 
;*    Turn-related behaviors should be executed first, if pending, then
;*    dialogue-related behaviors, and last action-related behaviors.
;*    Future object structures should reflect this hierarchy. (Might be done
;*    by assiging priorities to the behaviors).
;*
;*

(in-package 'USER)

(proclaim '(optimize (speed 3)))

(defvar *pending-behaviors* nil)
(setf   *pending-behaviors* nil)  ;This stores the pending turn-related behaviors.

;***********************************
;* Turn Behaviors
;***********************************

;************ make the internal turn behaviors **************
(defun prepare-turn-state-behaviors (node-list)
  (loop for (name msgs next-state pos-c neg-c active-d thre stat) in node-list
        collect `(defparameter ,name
                    (make-instance 'turn-state-beh
                      :msgs     ',msgs   ;what state to post into turn-history.
                      :next     ',next-state
                      :pos-cond ',pos-c
                      :neg-cond ',neg-c
                      :active-descr ',active-d
                      :thresh   ',thre
                      :state    ',stat))))
 
(defmacro make-turn-state-behaviors (node-list)
  (let ((forms (prepare-turn-state-behaviors (symbol-value node-list))))
    `(progn ,@forms)))

;Executable-behaviors are now the behaviors that should be executed at the earliest convenience.

;************ define the internal turn behaviors **************
; Behaviors (*turn-state-beh* parameter) now defined in [P] (prototype) file...


;***********************************
;*   Internal REActive Behaviors
;***********************************

;************ make the internal reactive behaviors **************

(defun prepare-int-rea-behaviors (node-list)
  (loop for (name ext type pos-c neg-c pos-restr neg-restr msgs init-state) in node-list
        collect `(defparameter ,name
                    (make-instance ',type
                         :extent   ',ext
                         :msgs     ',msgs
                         :pos-cond ',pos-c
                         :neg-cond ',neg-c
                         :pos-restr-cond ',pos-restr
                         :neg-restr-cond ',neg-restr                         
                         :state    ',init-state))))      ;added 2/19/96
 
(defmacro make-int-rea-behaviors (node-list)
  (let ((forms (prepare-int-rea-behaviors (symbol-value node-list))))
    `(progn ,@forms)))


;******************************
;*     EXTERNAL BEHAVIORS
;******************************

(setf *behavior-list* nil) ;A list with all executable behaviors.
;Currently go for a single list with all the executable actions in it. A method checks to see
;which ones are turn-related (exectute them immediately), dialog related (execute next),
;and action related (execute last). Right now there are only turn-related behaviors.

;************ make external turn behaviors **************
(defun prepare-ext-rea-behaviors (node-list)
  (loop for (name ext type pos-c neg-c pos-restr neg-restr msgs init-state) in node-list
        collect `(defparameter ,name
                    (make-instance ',type
                      :msgs ',msgs
                      :extent     ',ext
;                      :turn-state ',turn-sta
                      :pos-restr-cond ',pos-restr
                      :neg-restr-cond ',neg-restr
                      :pos-cond   ',pos-c
                      :neg-cond   ',neg-c
;                      :actions   ',acts ;use the msgs slot instead!!
                      :stamp nil
                      :state ',init-state))))  

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


;************ define external turn behaviors **************
; *ext-rea-beh* now defined in [P] (prototype) files...

;Maybe the behavior modules shouldn't be represented as objects? Question is, do we need a 
;separate name for each "replacement" behavior (behaviors that kick in when the others fail)?
;Question is, are there any behaviors that kick in when the others "fail"? Why would they fail?
;Because they cannot be executed within the time frame of dialogue units allowed. A history
;list would solve this. Here, all executed behaviors are posted, along with the duration they
;were executed over. So a behavior that has the activation pattern ((time-since give-turn > X) &
;not(show-giving-turn)) can kick in and ask "are you going to do something?"


;************* EXTERNAL CONTINUOUS REACTIVE BEHAVIORS *****************

(defun prepare-ext-cont-rea-behaviors (node-list)
  (loop for (name ext type pos-c neg-c acts init-state period) in node-list
        collect `(defparameter ,name
                    (make-instance ',type
                      :extent      ',ext
                      :pos-cond    ',pos-c
                      :neg-cond    ',neg-c
                      :msgs        ',acts
                      :stamp       0   
                      :state       ',init-state
                      :period      ',period))))

(defmacro make-ext-cont-rea-behaviors (node-list)
  (let ((forms (prepare-ext-cont-rea-behaviors (symbol-value node-list))))
    `(progn ,@forms)))


; 2/23/96: Instead of using continuous behaviors, there should be
; sensors for things like moisture in the eyes, that get updated
; along with other sensors; the reactive-behaviors that have a
; specific moisture value as a trigger get activated according
; to how fast the moisture in the eyes evaporates.

(defmethod update ((beh ext-cont-rea-beh))      ;For things like blink, self-adjustors, ticks
;  (debug-print "updating -> ")(print (msgs beh))
   (unless (equal 'T (first (pos-cond blink)))  ;in which case it should execute eternally
     (let ((count 0)                            ;else, it should cycle during a situation
	   (num-conds (total-conds beh)))       ;Check if it should be activated/de-activated
       (progn
	 (if (pos-cond beh)
	     (dolist (cond-x (pos-cond beh))
	       (if (call-BB cond-x) (setf count (1+ count)))))
	 (if (neg-cond beh)
	     (dolist (cond-x (neg-cond beh))
	       (unless (call-BB cond-x) (setf count (1+ count)))))
	 (if (= num-conds count)   ;Means we should restore...
	     (activate beh)
	   (de-activate beh))
	 )))
   (if (active beh)   
       (let ((stmp (time-stamp)))
	 (if (< (+ (period beh) (stamp beh)) stmp) 
	     (post beh)
	   ))
     )
   )
;;Extra close paran (6/19
;)

(defmethod post ((beh ext-cont-rea-beh)) ;2/19/96: debugged?
;  (terpri)(princ "posting: ") 
  (setf (stamp beh) (time-stamp))
  (push beh *pending-behaviors*)
;  (print (list (msgs beh) (stamp beh)))
  (if *display-on* (redraw-obj beh))
  )

(defmethod activate ((beh ext-cont-rea-beh))
  (setf (active beh) T)
  (if *display-on* (redraw-obj beh)))

(defmethod de-activate ((beh ext-cont-rea-beh))
  (setf (active beh) nil)
  (if *display-on* (redraw-obj beh)))


;*********** EXTERNAL BEHAVIORS - COMMON FUNCTIONS *************

(defmethod post ((beh ext-beh))
  (unless (pending beh) ;unless already posted.
    (progn
 ;     (debug-print "posting: ") (princ (msgs beh))(princ (time-stamp))
      (setf (stamp beh) (time-stamp))
      (push beh *pending-behaviors*)
      (setf (done beh) T) ;This should be done later by receiving a 'success' msgs from motor sys.
      (if *display-on* (redraw-obj beh))
      )))


(defmethod pending ((beh ext-beh))
  "Return T if the behavior is already pending for execution."
  (if (member beh *pending-behaviors*) 
      T
    nil))


(defun time-since (node TIME)  
  ;3/6/96 this works- just add to the conditions whether
  ;you want the node to be true or false..
  "Returns T if behavior/node was posted longer ago than (current-time - TIME)."
  (if (> (rtb) (+ (call-BB-stamp node) TIME))
      T
    nil))


#| created and discarded 3/9/96
(defmethod time-since (msgs (duration integer)) ;if its an object
  (time-since (msgs msgs) duration))

(defmethod time-since ((msgs symbol)(duration integer))
  (let ((temp-BB *turn-history*)
        (found-node nil)
        (node-name nil)
        (time-now (time-stamp)))
    (loop until (or (equal node-name msgs)(null temp-BB)) do
          (setf a-node (pop temp-BB))
          (setf node-name (first a-node)))
    (if (second a-node) ;the node is true and state is ongoing...
        NIL
      ;otherwise, check to see how long ago the state became nil:
      (< (+ duration (third a-node)) time-now))
    ))
|#  

(defmethod update ((list-of-behaves list)) ;Top-level function, called with a list of behavior objects.
  "Receives a list of all nodes and updates the true ones."
  (unless (null list-of-behaves)
    (dolist (beh-x list-of-behaves)
        (update beh-x)))
  )


;*********** EXTERNAL ONE-SHOT TURN BEHAVIORS *************


(defmethod update ((beh ext-one-shot-rea-beh))  ;For things like turn to screen, snore, etc.
;  (debug-print "updating> ")(print (msgs beh))
   (if (done beh)     ;Means we are looking for restore conditions.
       (let ((num-restore-conds (total-restore-conds beh))
             (count 0))
	 (progn 
	   (unless (null (pos-restr-cond beh))
	     (dolist (cond-x (pos-restr-cond beh))
	       (if (call-BB cond-x)
		   (setf count (1+ count)))))
	   (unless (null (neg-restr-cond beh))
	     (dolist (cond-x (neg-restr-cond beh))
	       (if (not (call-BB cond-x))
		   (setf count (1+ count)))))
	   (if (= num-restore-conds count)   ;Means we should restore...
	       (activate beh))
	   ))
     ;else not done
     (let ((num-fire-conds (total-conds beh))
	   (count 0))
       (unless (null (pos-cond beh))
	 (dolist (cond-x (pos-cond beh))
	   (if (call-BB cond-x)
	       (setf count (+ count 1)))))
       (unless (null (neg-cond beh))
	 (dolist (cond-x (neg-cond beh))
	   (if (not (call-BB cond-x))
	       (setf count (+ count 1)))))
       (if (= count num-fire-conds)               ;All conds are necessary.
	   (post beh))) ;The post method for beh sends them to the motor execution module
     ))

(defmethod activate ((beh ext-one-shot-rea-beh))
;  (setf (active beh) T)
  (setf (done beh) nil)               ;it's NOT done if active
  (if *display-on* (redraw-obj beh)))


;*************INTERNAL TURN BEHAVIORS*****************

;should also work for PCL state behaviors? 2/25/96
(defmethod update ((beh state))  ;[turn] state behaviors are executed immediately.
  "This method called with ALL turn changing behaviors and returns the behavior's state."
 ; (princ "updating> ")(print (msgs beh))
  (let ((count 0)
        (result 0)
        (old-state (state beh))
        (num-conds (total-conds beh)))
    (if (active beh)  ;do nothing unless it is active.
        (progn
          (if (pos-cond beh)
	      (dolist (cond-x (pos-cond beh))
                (if (BB-msgs-type cond-x)
	            (if (call-BB cond-x)
		        (setf count (1+ count)))
	          (if (call-KB-msgs cond-x)
		      (setf count (1+ count))))
                )
	    )
	  (if (neg-cond beh)
	      (dolist (cond-x (neg-cond beh))
                (if (BB-msgs-type cond-x)
	            (if (not (call-BB cond-x))
		        (setf count (1+ count)))
	          (if (not (call-KB-msgs cond-x))
		      (setf count (1+ count)))
	          ))
            )
;          (unless (null (pos-cond beh))     ;changed to handle kb-msgs-types 4/12/96
;            (dolist (cond-x (pos-cond beh))
;              (if (call-BB cond-x)
;                  (setf count (+ count 1)))))
;          (unless (null (neg-cond beh))
;            (dolist (cond-x (neg-cond beh))
;              (if (not (call-BB cond-x))
;                  (setf count (+ count 1)))))
          (if (= count num-conds)               ;All conds are necessary (FOR NOW!).
              (progn (print (next beh))(princ count)(princ " ")(princ num-conds)
	        (de-activate beh)))
	  )
      )
    (active beh)
    ))

(defmethod de-activate ((beh state))
  (let ((inactive-state-objs nil)
        (next-state-objs nil)
        (inactive-descrs nil)
        (active-descrs nil))
 ;1. FIND ALL RELEVANT THINGS
    ;All next state objects:
    (dolist (next (next beh))
      (setf next-state-objs
            (append next-state-objs (find-objs-w-state-name next))))

    ;All next state descriptors:
    (dolist (next-state next-state-objs)
      (setf active-descrs 
            (append active-descrs (active-descr next-state))))
    (setf active-descrs (remove-duplicates active-descrs))

    ;All state objs that should be active:
    (setf inactive-state-objs (set-difference *state-beh* next-state-objs))

    ;All inactive state descriptors:
    (dolist (inactive-state inactive-state-objs)
      (setf inactive-descrs
            (append inactive-descrs (active-descr inactive-state))))
    (setf inactive-descrs (remove-duplicates inactive-descrs))

;    (print inactive-state-objs)
;    (print inactive-descrs)
;    (print next-state-objs)
;    (print active-descrs)

 ;2. DE-ACTIVATE ALL INACTIVE-STATE OBJECTS
    (dolist (inactive-state-obj inactive-state-objs)
      (setf (active inactive-state-obj) nil))
 ;3. DE-ACTIVATE ALL INACTIVE-STATE DESCRIPTORS
    (de-activate inactive-descrs)
 ;4. ACTIVATE ALL NEXT-STATE OBJECTS
    (dolist (next-state next-state-objs)
      (activate next-state))
 ;5. ACTIVATE ALL NEXT-STATE DESCRIPTORS
    (activate active-descrs)
 ;6. POST STATES
    (dolist (state-node *state-beh*)
;      (print (msgs state-node))(princ (active state-node))
      (post state-node))
;   (print "Fired: ")(princ (msgs beh))
    (setf (stamp beh) (time-stamp)) ;added 3/9/96
    (if *display-on* (redraw-obj *state-beh*))
    ))


(defmethod activate ((state-obj state))
  (let ((stamp (time-stamp)))
;    (princ 'activating-)(print state-obj)
    (setf (active state-obj) T)
    (setf (stamp state-obj) stamp)
    ))

;(defmethod activate ((state-name symbol))
;  (dolist (state-obj (find-objs-w-state-name state-name))
;    (activate state-obj)))

#| 3/2/96
(defmethod activate ((state-name symbol))
;NOTICE: Cannot call this activate with any other symbol except state names!!!
  (let ((next-states nil)
        (others nil)
        (timestamp (time-stamp)))
    (push (list state-name T (time-stamp)) *turn-history*) ; equv. to an 'object-free' post
    (setf next-states (find-objs-w-state-name state-name))
    (setf others (set-difference *state-beh* next-states))
;    (print others)(print next-states)
    (dolist (node others)        ;all that are not the current state set to nil
      (setf (active node) nil)
      (de-activate (active-descr node)))
    (dolist (node next-states)             ;Make them all active.
      (setf (active node) T)
      (setf (stamp node) time-stamp)
      (activate (active-descr node)))
    (if *display-on* (redraw-obj *state-beh*))
    ))
|#

;(defmethod activate ((beh state))
;  (activate (msgs beh)))

;(defmethod activate ((beh state))
;  (dolist (posting-name (next beh))  ;first loop for items next-list
;    (print posting-name)
;    (dolist (state (find-objs-w-state-name posting-name))  ;second loop for all next states.
;      (activate state)
;      ))
;  )

(defun find-objs-w-state-name (next-state-name)
  (let ((next-objs nil))
    (dolist (node *state-beh*)            ;Find all nodes that should be active.
      (if (equal next-state-name (msgs node))
	  (push node next-objs)))
    next-objs))

(defmethod activate ((a-list list))
  "Activates all descriptors in active-descr, returns the active descr."
  (let ((name-list nil))
    (dolist (node-name a-list)
      (activate (symbol-value node-name))
      (if *display-on* (redraw-obj (symbol-value node-name)))
      )
;    (princ "activating:")(print a-list)
    a-list
    ))

(defmethod activate ((descr turn-descriptor))
  (unless (active descr) ;unless already active
    (setf (active descr) T)
    (if *display-on* (redraw-obj descr))))

(defmethod de-activate ((a-list list))
  "De-activates all items in list." 
  (dolist (item a-list)
    (de-activate (symbol-value item))
    )
  )

(defmethod de-activate ((descr turn-descriptor))
  (if (active descr) ;don't waste time if already non-active
      (progn
        (setf (active descr) nil)
        (setf (stamp  descr) (time-stamp)) ;added 3/9/96
        (if *display-on* (redraw-obj descr)))
    )
  )

(defmethod post ((beh state))
  ;What's posted is not the state slot value but active slot value
  (unless (state-already-posted (msgs beh) (active beh))
    (let ((tim-stmp (time-stamp)))
      (push  (list (msgs beh)(active beh) tim-stmp) *turn-history*)
 ;     (print (list (msgs beh)(active beh) tim-stmp))
      ))
  (if *display-on* (redraw-obj beh))
  )
  
(defmethod state-already-posted ((beh symbol) cond)
;  (state-already-posted (first (find-objs-w-state-name beh)) cond))
  (let* ((temp-list *turn-history*)
         (temp-item (pop temp-list))
         (return nil))
    (loop until (or (null temp-list) (equal (first temp-item) beh)) do
          (setf temp-item (pop temp-list)))
    (if temp-list ;means we found the item
        (setf return (equal cond (second temp-item)))
      )
    return
    ))

#|
(defmethod state-already-posted ((beh state) cond)
  (let ((return nil))
    (if (equal cond (call-BB (msgs beh)))
        (setf return T))
    return))
|#

(defun last-turn-state ()
  "Returns the last turn-state posted."
  (setf return 'give-turn)    ; The default state is give-turn!
  (setf give (call-BB-stamp 'give-turn)
        take (call-BB-stamp 'take-turn))
  (unless (or (null give) (null take))           ;In case turn states haven't been posted.
    (if (and (> give take) (call-BB 'give-turn)) ;give-turn also has to be true.
      (setf return 'give-turn)   ;else...
      (if (call-BB 'take-turn) 
        (setf return 'take-turn)))
    )
  return)


;*************INTERNAL REACTIVE BEHAVIORS*****************

(defmethod update ((beh int-one-shot-rea-beh))  ;For things like start speech recognition
;  (debug-print "updating> ")(print (msgs beh))
   (if (done beh)     ;Means we are looking for restore conditions.
       (let ((num-restore-conds (total-restore-conds beh))
             (count 0))
	 (progn 
	   (unless (null (pos-restr-cond beh))
	     (dolist (cond-x (pos-restr-cond beh))
	       (if (call-BB cond-x)
		   (setf count (1+ count)))))
	   (unless (null (neg-restr-cond beh))
	     (dolist (cond-x (neg-restr-cond beh))
	       (if (not (call-BB cond-x))
		   (setf count (1+ count)))))
	   (if (>= count 1)  ;(eq num-restore-conds count)   ;Means we should restore...
	       (activate beh))
	   ))
     ;else not done
     (progn           
       (let ((num-fire-conds (total-conds beh))
             (count 0))
	 (unless (null (pos-cond beh))
	   (dolist (cond-x (pos-cond beh))
	     (if (call-BB cond-x)
		 (setf count (+ count 1)))))
	 (unless (null (neg-cond beh))
	   (dolist (cond-x (neg-cond beh))
	     (if (not (call-BB cond-x))
		 (setf count (+ count 1)))))
	 (if (= count num-fire-conds)               ;All conds are necessary.
	     (progn 
	       (post beh))) ;The post method for beh sends them to the motor execution module
	 ))
     ))


(defmethod post ((beh int-one-shot-rea-beh))
;  (push (list (msgs beh) (active beh) (time-stamp)) *turn-history*)
  (eval (msgs beh))
;  (print (list (msgs beh) (time-stamp)))
  (setf (done beh) T)
  )

(defmethod activate ((beh int-one-shot-rea-beh))
  (setf (done beh) nil))



;**************

(defun debug-print (message)
  (princ #\newline)
  (princ message))

(defmethod total-conds ((beh basic-behavior))
  (+ (length (pos-cond beh))
     (length (neg-cond beh))))

(defmethod total-restore-conds ((beh one-shot))
  (+ (length (pos-restr-cond beh))
     (length (neg-restr-cond beh))))