;;; -*- Mode: LISP; Syntax: Common-Lisp; Package: INTERACTORS; Base: 10 -*-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;         The Garnet User Interface Development Environment.      ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; This code was written as part of the Garnet project at          ;;;
;;; Carnegie Mellon University, and has been placed in the public   ;;;
;;; domain.  If you are using this code or any part of Garnet,      ;;;
;;; please contact garnet@cs.cmu.edu to be put on the mailing list. ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; gestureinter.lisp
;;;
;;; This file contains the mouse interactors to handle gestures.
;;; It should be loaded after Interactor.lisp
;;;
;;; Designed and implemented by James A. Landay 

#|
========================================================================
Change log:
    06/15/93 James Landay - use HP-XOR-Hack instead of explicit xor handling
    04/03/92 James Landay - don't erase a point passed to stop-action,
                            since we never draw this point.
    02/19/92 James Landay - added gesture-fix-gc () to the 
                            opal::*auxilliary-reconnect-routines* so
                            that if user switches monitors, get a new gc
    02/13/92 James Landay - special case for color monitors
                            to make xor drawing work properly
    01/31/92 James Landay - moved all export declarations
                            for gestures here.
    12/21/91 James Landay - started

========================================================================
|#

(in-package "INTERACTORS" :use '("LISP" "KR") :nicknames '("INTER"))

(export '(gesture-interactor

          gest-classify                 ;; functions in classify.lisp
          gest-new-classifier
	  make-gest-class
	  gest-class-name
	  gest-class-examples

          gest-attributes-minx          ;; functions in features.lisp 
          gest-attributes-maxx
          gest-attributes-miny
          gest-attributes-maxy
          gest-attributes-initial-sin    
          gest-attributes-initial-cos
          gest-attributes-startx     
          gest-attributes-starty
          gest-attributes-endx       
          gest-attributes-endy
          gest-attributes-dx2           
          gest-attributes-dy2          
          gest-attributes-magsq2      
          gest-attributes-path-r
          gest-attributes-path-th
          gest-attributes-abs-th
          gest-attributes-sharpness

          gest-classifier-read          ;; functions in fileio.lisp
          gest-classifier-write
          gest-classifier-convert))

;;;============================================================
;;;============================================================
;;;============================================================


;;;============================================================
;;; Utility Procedures 
;;;============================================================

(defconstant POINT-ARRAY-SIZE 80)   ; initial size of point array
(defconstant EXTENTION-SIZE 30)     ; amount to extend by when full

;; global variables definitions
                                    ; the points gestured....
(defvar *points* (make-array POINT-ARRAY-SIZE :adjustable t 
                             :fill-pointer 0 :element-type 'integer))
(defvar *last-point* (list 0 0))    ; use these to avoid cons-ing
(defvar *cur-point*  (list 0 0))


;; make-gc returns a graphics context that is used to draw gesture traces
;; using xor mode.  Want background to be black normally and foreground 
;; to be white.  If this monitor has white-pixel = 0, then draw 
;; black on white instead to make xor work.
(defun make-gc ()
    (xlib:create-gcontext :drawable opal::*default-x-root* 
                          :background 
			      (opal::HP-XOR-Hack boole-xor opal::*white*)
                          :foreground 
			      (opal::HP-XOR-Hack boole-xor opal::*black*)
#|;; HP-XOR-Hack replaces this...
                          :background (if (zerop opal::*white*)
                                          opal::*white*
                                          opal::*black*           
                                      )
                          :foreground (if (zerop opal::*white*)
                                          opal::*black*           
                                          opal::*white*           
                                      )
|#
                          :line-width 1
                          :fill-style :solid 
                          :line-style :solid
                          :cap-style :not-last
                          :function boole-xor)
)


;; make a global graphics context that is shared by all gesture
;; interactors and windows
(defvar *gesture-gc* (make-gc))


;; Causes a new gc to be created when the user switches monitors.
;; Need to do this since they may switch to a monitor where *black* and 
;; *white* are defined to be different than their currenty values. 
(defun gesture-fix-gc ()
    (setf *gesture-gc* (make-gc))
)

(Pushnew #'gesture-fix-gc opal::*auxilliary-reconnect-routines*)


;; erase-path uses xlib to erase the lines drawn between the given
;; points in the given X window and with the global graphics context.
(defun erase-path (points window)
    (do* ((index 0 (+ index 2))
          (size (- (fill-pointer points) 2)))
        ((>= index size))       ;; exit condition
        ; only execute if points has > 1 point (i.e. at least 4 elements)

        (xlib:draw-line window *gesture-gc*
                        (aref points index) (aref points (1+ index))
                        (aref points (+ index 2)) (aref points (+ index 3)))
    )
)


;;;============================================================
;;; Gesture-Interactor
;;;============================================================


;;;============================================================
;;; Default Procedures to go into the slots
;;;============================================================


(proclaim '(special Gesture-Interactor))



(defun Gesture-Interactor-Initialize (new-Gesture-schema)
    (if-debug new-Gesture-schema 
              (format T "Gesture initialize ~s~%" new-Gesture-schema))

    (Check-Interactor-Type new-Gesture-schema inter:gesture-interactor)
    (Check-Required-Slots new-Gesture-schema)
    (Set-Up-Defaults new-Gesture-schema)
) ;end initialize procedure


;; Draws the latest point in the path
;; NOTE: single points won't be drawn since draw-line will draw a line
;; from one point to the same point using XOR, therefore single
;; point gestures do NOT need to be erased.
(defun Gesture-Int-Running-Action (an-interactor new-obj-over point)
    (if-debug an-interactor 
              (format T "Gesture int-running, new-obj-over= ~s, point= ~s~%"
                      new-obj-over point))

    ;; draw the new point if trace is true and if didn't go outside 
    (when (and (g-value an-interactor :show-trace)
               (not (g-value an-interactor :went-outside)))
        (xlib:draw-line (g-value an-interactor :xwindow) *gesture-gc* 
                        (first *last-point*) (second *last-point*)
                        (first point) (second point))
    )

    ;; set the new last point without cons-ing 
    (setf (first *last-point*) (first point)) 
    (setf (second *last-point*) (second point)) 

    ;; add point to array of points
    (vector-push-extend (first point) *points* EXTENTION-SIZE) 
    (vector-push-extend (second point) *points*  EXTENTION-SIZE)
)


;; Executes the running action for the first point
(defun Gesture-Int-Start-Action (an-interactor obj-under-mouse point)
    (if-debug an-interactor 
              (format T "Gesture int-start over ~s~%, point = ~s~%" 
               obj-under-mouse point))

    ;; set the initial object that we started over
    (s-value an-interactor :first-obj-over obj-under-mouse) 

    ;; not outside...
    (s-value an-interactor :went-outside NIL)

    ;; get the x-window so we can use xlib calls...
    (s-value an-interactor :xwindow  
        (g-value (g-value an-interactor :current-window) :drawable))

    ;; set the initial last-point and make the set of points empty
    (setf (first *last-point*) (first point)) 
    (setf (second *last-point*) (second point)) 
    (setf (fill-pointer *points*) 0)

    ;; do the running action
    (kr-send an-interactor :running-action 
             an-interactor obj-under-mouse point) 
)


;; Try to recognize the gesture and then erase the path
(defun Gesture-Int-Stop-Action (an-interactor final-obj-over point)
    (if-debug an-interactor 
              (format T "Gesture int-stop over ~s~%" final-obj-over))

    ;; don't call final function or erase (already erased) if went outside
    (unless (g-value an-interactor :went-outside)

        ;; erase the line if :show-trace is true
        (when (g-value an-interactor :show-trace)
            (erase-path *points* (g-value an-interactor :xwindow))
        )

        ;; add the latest point (if there is one) to the array 
        (when point
            (vector-push-extend (first point) *points* EXTENTION-SIZE) 
            (vector-push-extend (second point) *points*  EXTENTION-SIZE)
        )

        ;; send the points to the classifier
        (let ((class-name nil)
              (attributes nil)
              (nap nil)
              (dist nil))

            (multiple-value-setq 
                (class-name attributes nap dist)
                (gest-classify *points* 
                               (g-value an-interactor :classifier)
                               (g-value an-interactor :min-non-ambig-prob)
                               (g-value an-interactor :max-dist-to-mean)))

            (if-debug an-interactor
                      (format T "Gesture classified as ~s~%" class-name))
            (if-debug an-interactor
                      (format T "with probability ~s and distance ~s~%" 
                              nap dist))

            (kr-send an-interactor :final-function an-interactor 
                     (g-value an-interactor :first-obj-over) 
                     class-name attributes *points* nap dist)
        )
    )
)


;; don't do anything.... we want to wait for mouse up
(defun Gesture-Int-Back-Inside-Action (an-interactor new-obj-over)
    (if-debug an-interactor
              (format T "Gesture int-back-inside, obj= ~s~%" new-obj-over))
)


;; beep and erase the line if :show-trace is true
(defun Gesture-Int-Outside-Action (an-interactor prev-obj-over)
    (if-debug an-interactor 
              (format T "Gesture int-outside, old = ~s~%" prev-obj-over))
    (inter:beep)
    (when (g-value an-interactor :show-trace)
        (erase-path *points* (g-value an-interactor :xwindow))
    )
    (s-value an-interactor :went-outside T)
)


;; erase the gesture if it was visible and haven't been outside 
(defun Gesture-Int-Abort-Action (an-interactor)
    (if-debug an-interactor (format T "Gesture int-abort over ~%"))
    (when (and (g-value an-interactor :show-trace)
               (not (g-value an-interactor :went-outside)))
        (erase-path *points* (g-value an-interactor :xwindow))
    )
)


;;;============================================================
;;; Go procedure utilities
;;;============================================================


;;; if continuous: (remove from start level, add to stop and abort
;;;             levels, change state to running
;;;             *ALSO* fix running where to be the object started over)
;;; save object over, call start procedure.
(defun gesture-do-start (an-interactor new-obj-over event)
    (if-debug an-interactor 
              (format T "Gesture starting over ~s~%" new-obj-over))
        
    (setf (first *cur-point*) (event-x event))
    (setf (second *cur-point*) (event-y event)) 

    (if (g-value an-interactor :continuous)  ;then go to running state
        (progn
            (Fix-Running-Where an-interactor new-obj-over)
            (GoToRunningState an-interactor T)
            (kr-send an-interactor :start-action an-interactor 
                     new-obj-over *cur-point*)
        )
        ;; else call stop-action
        (progn
            (kr-send an-interactor :stop-action an-interactor 
                     new-obj-over *cur-point*)
            (GoToStartState an-interactor NIL)
        )
    )
)


(defun gesture-do-abort (an-interactor become-inactive event)
    (declare (ignore event become-inactive))
    (if-debug an-interactor (format T "Gesture aborting~%"))

    (GoToStartState an-interactor T)
    (kr-send an-interactor :abort-action an-interactor)
)


(defun gesture-do-outside (an-interactor)
    (if-debug an-interactor (format T "Gesture outside~%"))

    (s-value an-interactor :current-state :outside)
    (kr-send an-interactor :outside-action an-interactor
             (g-value an-interactor :outside))
)


; call abort
(defun gesture-do-outside-stop (an-interactor event)
    (if-debug an-interactor (format T "Gesture stop outside~%"))
    (gesture-do-abort an-interactor NIL event)
)


; call back-inside procedure, change state to running
(defun gesture-do-back-inside (an-interactor new-obj-over event)
    (declare (ignore event))
    (if-debug an-interactor 
              (format T "Gesture back-inside over ~s~%" new-obj-over))

    (s-value an-interactor :current-state :running)
    (kr-send an-interactor :back-inside-action an-interactor new-obj-over)
)


; get the new point and pass it to the running-action
(defun gesture-do-running (an-interactor new-obj-over event)
    (if-debug an-interactor 
              (format T "Gesture running over ~s~%" new-obj-over))

    (setf (first *cur-point*) (event-x event))
    (setf (second *cur-point*) (event-y event)) 
    (kr-send an-interactor :running-action an-interactor 
             new-obj-over *cur-point*)
)


;;; Will be inside
;;; Remove from running level, add to start level
;;; unless :self-deactivate, change state to start, call stop procedure
(defun gesture-do-stop (an-interactor new-obj-over event)
    (if-debug an-interactor 
              (format T "Gesture stop over ~s~%" new-obj-over))

    (setf (first *cur-point*) (event-x event))
    (setf (second *cur-point*) (event-y event)) 
    (GoToStartState an-interactor T)
    (kr-send an-interactor :stop-action an-interactor 
             new-obj-over *cur-point*)
)


;;; This is used if explicitly call Stop-Interactor.  
(defun gesture-explicit-stop (an-interactor)
    (if-debug an-interactor (format T "Gesture explicit stop~%"))

    (GoToStartState an-interactor T)
    (kr-send an-interactor :stop-action an-interactor NIL NIL)
)


;;;============================================================
;;; Gesture schema
;;;============================================================

(Create-Schema 'inter:gesture-interactor
        (:is-a inter:interactor)
        (:name :First-Gesture-interactor)
        (:start-action 'Gesture-Int-Start-Action)
        (:running-action 'Gesture-Int-Running-Action)
        (:stop-action 'Gesture-Int-Stop-Action)
        (:abort-action 'Gesture-Int-Abort-Action)
        (:outside-action 'Gesture-Int-Outside-Action)
        (:back-inside-action 'Gesture-Int-Back-Inside-Action)
        (:abort-event '(:control-g :control-\g))
        (:running-where T)             
        (:classifier NIL)              ; classifier to use
        (:show-trace T)                ; show trace of gesture?
        (:min-non-ambig-prob nil)      ; non-ambiguity probability
        (:max-dist-to-mean nil)        ; distance to class mean 
        (:xwindow NIL)                 ; x-window gesturing in
        (:went-outside NIL)            ; set in outside action  
        (:first-obj-over NIL)          ; object started on
        (:Go 'General-Go)  ; proc executed when events happen
        (:Do-Start 'Gesture-Do-Start)     ; these are
        (:Do-Running 'Gesture-Do-Running) ;   called by GO
        (:Do-Explicit-Stop 'Gesture-Explicit-Stop) ;for stop-interactor
        (:Do-Stop 'Gesture-Do-Stop)       ;   to do
        (:Do-Abort 'Gesture-Do-Abort)     ;   the real work.
        (:Do-Outside 'Gesture-Do-Outside) ;   They call the
        (:Do-Back-Inside 'Gesture-Do-Back-Inside)  ; appropriate
        (:Do-Outside-Stop 'Gesture-Do-Outside-Stop); -action procedures
        (:initialize 'Gesture-Interactor-Initialize)) ;proc to call
                                               ; when created
