;;; -*- Mode: LISP; Syntax: Common-Lisp; Package: AGATE; 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. ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; agate.lisp 
;;;
;;; This is AGATE: The Garnet Gesture Trainer application. It is used 
;;; for training gestures that are passed to the Garnet gesture 
;;; interactor.
;;;
;;; Designed and implemented by James A. Landay 

#|
==================================================================
Change log:
     04/08/92 James Landay - use Motif error and query dialogs.
     04/05/92 James Landay - made a query dialog for quit without 
                  saving.
     03/25/92 Andrew Mickish - Added instructions, replaced 
                  motif-background with :background-color of window, 
                  added constants.
     02/25/92 James Landay   - started 
==================================================================
|#

(in-package "AGATE" :use '("KR" "LISP"))

(export '(do-go do-stop))


;; Load motif stuff, unless already loaded
(defvar TRAIN-APP-INIT
    (progn
        (dolist (gadget '("motif-text-buttons-loader"
                          "motif-scrolling-labeled-box-loader"
                          "motif-radio-buttons-loader"
                          "motif-error-gadget-loader"))
            (load (merge-pathnames gadget
                      #+cmu "gadgets:"
                      #+(not cmu) user::Garnet-Gadgets-PathName)))

        ;; load gesture-loader
        (load (merge-pathnames "gesture-loader"
                  #+cmu "gesture:"
                  #-cmu user::Garnet-Gesture-PathName))

        ;; load training code
        (load (merge-pathnames "train"
                  #+cmu "gesture:"
                  #-cmu user::Garnet-Gesture-PathName))
    )
)


;; global variables definitions

;; objects created in do-go
(proclaim '(special TOP-WIN))
(proclaim '(special WORK-WIN)) 
(proclaim '(special MAIN-MENU)) 
(proclaim '(special GESTURE-INTER))
(proclaim '(special FILENAME-BOX))
(proclaim '(special GESTURE-NAME-BOX))
(proclaim '(special ERROR-DIALOG))
(proclaim '(special QUIT-DIALOG))
(proclaim '(special MODE-TOGGLE))


;; the current classifier being trained 
(defparameter *cur-classifier* NIL) 
(defparameter *trained* NIL)    ;; has *cur-classifier* been trained
                                ;; since the last example?
(defparameter *saved* T)        ;; has current classifier been saved
                                ;; since last change? (not dirty yet)



;; do-clear sets sets the *cur-classifier* to a new classifier.
;;
;; Parameters:
;;     gadgets-object (ignored)
;;     item-string (ignored)
;;
(defun do-clear (gadgets-object item-string)
    (declare (ignore gadgets-object item-string))
    (setf *cur-classifier* (inter:gest-new-classifier))
    (setf *trained* NIL)
    (setf *saved* T)
    (s-value GESTURE-INTER :classifier NIL) 
    (s-value MODE-TOGGLE :value "Train")        ;; switch back to train
)


;; do-error displays the ERROR-DIALOG with the given string displayed.
;; Does not continue until the user presses the OK button.
;;
;; Parameters:
;;     string - message to display
;;
(defun do-error (string)
    (garnet-gadgets:display-error-and-wait ERROR-DIALOG string)
)


;; do-load loads an existing classifier from a file.
;; Puts up an error dialog if the file doesn't exist.
;;
;; Parameters:
;;     gadgets-object (ignored)
;;     item-string (ignored)
;;
(defun do-load (gadgets-object item-string)
    (declare (ignore gadgets-object item-string))
    (let ((file (string-trim '(#\Space) (g-value FILENAME-BOX :value))))
        (if (or (null (probe-file file)) 
                (equal file ""))            ;; file doesn't exist
            
            (do-error 
                (format NIL "ERROR: File ~s does not exist.~%~a"
                        file "Press OK to continue."))
            (progn                          ;; file exists
                (setf *cur-classifier* 
                      (inter:gest-classifier-read file)) 
                (when (equal (g-value MODE-TOGGLE :value) "Test")
                    (s-value GESTURE-INTER :classifier 
                             *cur-classifier*) 
                )
                (setf *trained* T)
                (setf *saved* T)
                (when (null *cur-classifier*)
                    (do-error 
                        (format NIL "ERROR: NIL classifier!~%~a"
                                "Press OK to continue."))
                    (do-clear nil nil)
                )
            )
        )
    )
)


;; do-save saves the current classifier to a file. Trains it
;; first if necessary. Returns 'ERROR if there was an error
;; while trying to save (either file related or if unable to train.)
;; Returns NIL otherwise.
;;
;; Parameters:
;;     gadgets-object (ignored)
;;     item-string (ignored)
;;
(defun do-save (gadgets-object item-string)
    (declare (ignore gadgets-object item-string))

    ;; if the classifier hasn't been trained, do it!
    (unless *trained*
        (if (null (inter:gest-done-adding *cur-classifier*))
            (progn 
                (do-error 
                    (format NIL "ERROR: Can not train classifier.~%~a~%~a"
                            "Try adding more examples." 
                            "Press OK to continue."))
                (return-from do-save 'ERROR)
            )
            (setf *trained* T)              ;; worked
        )
    )

    ;; make sure the directory exists
    (let ((file (string-trim '(#\Space) (g-value FILENAME-BOX :value))))
        (cond
            ((null (probe-directory (directory-namestring file)))
                (do-error (format NIL       ;; bad directory
                                  "ERROR: Directory ~s does not exist.~%~a"
                                  (directory-namestring file)
                                  "Press OK to continue."))
                (return-from do-save 'ERROR)
            )
            ((equal file "")                ;; blank filename 
                (do-error (format NIL 
                                  "ERROR: Filename is blank.~%~a"
                                  "Press OK to continue."))
                (return-from do-save 'ERROR)
            )
            (t 
                (inter:gest-classifier-write *cur-classifier* file)
                (setf *saved* T)
            )
        )
    )
    NIL                             ;; no errors 
)


;; do-test-classify sets the gesture interactor classifier slot to the 
;; currently trained classifier. If the classifier hasn't been trained,
;; it will train it.
;; 
;; Parameters:
;;     gadgets-object (ignored)
;;     item-string (ignored)
;;
(defun do-test-classify (gadgets-object item-string)
    (declare (ignore gadgets-object item-string))
    (if (not *trained*)
        (if (null (inter:gest-done-adding *cur-classifier*))
            (progn 
                (do-error (format NIL 
                                  "ERROR: Can not train classifier.~%~a~%~a"
                                  "Try adding more examples."
                                  "Press OK to continue."))
                (s-value MODE-TOGGLE :value "Train") 
            )
            (progn
                (setf *trained* T)      ;; we were able to train it 
                (s-value GESTURE-INTER :classifier *cur-classifier*) 
            )
        )
        (s-value GESTURE-INTER :classifier *cur-classifier*) ;; trained
    )
)


;; do-train sets the gesture interactor classifier slot to NIL, so that
;; handle-gesture will allow adding examples to the current classifier
;; without trying to classify them.
;; 
;; Parameters:
;;     gadgets-object 
;;     item-string
;;
(defun do-train (gadgets-object item-string)
    (declare (ignore gadgets-object item-string))
    (s-value GESTURE-INTER :classifier NIL) 
    (setf *trained* NIL)
)


;; handle-gesture is called by the gesture interactor after it
;; classifies a gesture. If we are currently training, then
;; handle-gesture will add the example to the trainer. If we are
;; testing then handle-gesture will print the name of the gesture
;; that was identified.
(defun handle-gesture (inter first-obj-over class-name attribs
                       points nap dist)
    (declare (ignore inter first-obj-over attribs))

    (cond
        ((equal (g-value MODE-TOGGLE :value) "Train")   ;; in training mode
            (if (equal "" (string-trim '(#\Space) 
                              (g-value GESTURE-NAME-BOX :value)))
                (do-error (format NIL "ERROR: Gesture Name is blank.~%~a"
                                      "Press OK to continue."))
                (progn 
                    (format T "adding example to ~s~%~%"
                            (string-trim '(#\Space) 
                                (g-value GESTURE-NAME-BOX :value)))
                    (inter:gest-add-example points 
                        (intern (string-upcase 
                                    (string-trim '(#\Space) 
                                        (g-value GESTURE-NAME-BOX :value)))
                                'keyword)
                        *cur-classifier*)
                    (setf *saved* NIL)
                )
            )
        )
        
        ((equal (g-value MODE-TOGGLE :value) "Test")    ;; in test mode 
            (if (null class-name)
                (s-value GESTURE-NAME-BOX :value "Unrecognized gesture...")
                (progn
                    (s-value GESTURE-NAME-BOX :value 
                             (write-to-string class-name :escape nil))
                    (format T 
                        "~s with probability of ~s and distance of ~s~%~%" 
                        class-name nap dist)
                )
            )
        )
    )
)


;; do-go creates the necessary windows and Garnet objects, and 
;; then starts the application.
;;
;; Parmeters:
;;      
(defun do-go (&key dont-enter-main-event-loop double-buffered-p)
    ;; initialize globals
    (setf *cur-classifier* (inter:gest-new-classifier))
    (setf *trained* NIL)    
    (setf *saved* T) 

    ;; create top-level window
    (create-instance 'TOP-WIN inter:interactor-window
        (:left 280) (:top 120)
        (:double-buffered-p double-buffered-p)
        (:width 520) (:height 400)
        (:title "AGATE: Garnet Gesture Trainer (v. 1.0)")
        (:icon-title "AGATE")
        (:background-color opal:motif-gray)
    )

    ;; create the top level aggregate in the window
    (s-value TOP-WIN :aggregate
        (create-instance 'TOP-AGG opal:aggregate
            (:left 0) (:top -2)
            (:width (o-formula (gvl :window :width)))
            (:height (o-formula (gvl :window :height)))))

    ;; create window for the work area
    (create-instance 'WORK-WIN inter:interactor-window
        (:left 0) (:top 110) 
        (:width (o-formula (gvl :parent :width) 150))
        (:height (o-formula (- (gvl :parent :height)
                               (gvl :top))))
        (:double-buffered-p double-buffered-p)
        (:border-width 2)
        (:visible t)
        (:parent TOP-WIN)
    )

    ;; create menu 
    (create-instance 'MAIN-MENU garnet-gadgets:motif-text-button-panel
        (:constant T)
        (:items '(
            ("Clear Classifier" do-clear)
            ("Load Classifier" do-load)
            ("Save Classifier" do-save)
            ("Quit" do-quit)))
        (:left (o-formula (ceiling (- (/ (gvl :parent :window :width) 2)
                                      (/ (gvl :width) 2)))))
        (:top 5)
        (:direction :horizontal)
        (:h-align :center)
    )

    ;; create the filename input boxes 
    (create-instance 'FILENAME-BOX 
        garnet-gadgets:motif-scrolling-labeled-box
        (:constant T)
        (:left 2) (:top 35)
        (:width (o-formula (gvl :parent :window :width)))
        (:label-string "Classifier Filename:")
        (:value " ")
        (:field-offset 5)
    )

    ;; create the train and test mode toggles
    (create-instance 'MODE-TOGGLE garnet-gadgets:motif-radio-button-panel
        (:constant T)
        (:left (o-formula (ceiling (- (/ (gvl :parent :window :width) 2)
                                      (/ (gvl :width) 2)))))
        (:top 60)
        (:items '(
            ("Train" do-train)
            ("Test" do-test-classify)))
        (:direction :horizontal)
        (:text-offset 10)
    )

    ;; select Train mode to start...
    (g-value MODE-TOGGLE :value)
    (s-value MODE-TOGGLE :value "Train") 

    ;; create the gesture name input boxes 
    (create-instance 'GESTURE-NAME-BOX gg:motif-scrolling-labeled-box
        (:constant T)
        (:left 2) (:top 85)
        (:width (o-formula (gvl :parent :window :width)))
        (:label-string "Gesture Name:")
        (:value " ")
    )

    (opal:add-components TOP-AGG
             MAIN-MENU FILENAME-BOX MODE-TOGGLE GESTURE-NAME-BOX)
    (opal:update TOP-WIN)  ;; will also update work-win

    ;; create an error dialog
    (create-instance 'ERROR-DIALOG garnet-gadgets:motif-error-gadget
        (:parent-window TOP-WIN)
    )

    ;; create a query dialog for quiting before save
    (create-instance 'QUIT-DIALOG garnet-gadgets:motif-query-gadget
        (:parent-window TOP-WIN)
        (:button-names '("YES" "NO" "CANCEL"))
    )

    ;; create a gesture interactor that uses a nil classifier to get
    ;; back the mouse trace.
    (create-instance 'GESTURE-INTER inter:gesture-interactor
        (:window WORK-WIN)
        (:start-where (list :in WORK-WIN)) 
        (:running-where (list :in WORK-WIN))
        (:start-event :any-mousedown)
        (:classifier NIL) 
        (:final-function #'handle-gesture)
        (:min-non-ambig-prob 0)
        (:max-dist-to-mean 10000)
    )

    (format t "     To use AGATE, the Garnet gesture trainer, type the name of a new file~%")
    (format t "to hold the gestures into the top field: Classifier Filename.  Then, for~%")
    (format t "each gesture you want to recognize, type its name into the Gesture Name field,~%")
    (format t "and then give about 15 examples of the gesture in the work window.  You~%")
    (format t "can then type a new gesture name, and give examples for it.  At any point,~%")
    (format t "you can try out the gestures trained so far, by switching to \"Test\" mode.~%")
    (format t "After you give a gesture in test mode, AGATE will print the name into the~%")
    (format t "Gesture Name field.~%")

    (unless dont-enter-main-event-loop #-cmu (inter:main-event-loop))
)


;; do-query displays the QUERY-DIALOG with the given string displayed.
;; do-query does not return until a button is pressed and will return
;; the label selected by the user.
;;
;; Parameters:
;;     string - message to display
;;
(defun do-query (string)
    (garnet-gadgets:display-query-and-wait QUIT-DIALOG string)
)


;; do-quit calls do-stop when the user hits the quit button. 
;; If the classifier is dirty and hasn't been saved asks the
;; user if they would like to save it first.
;;
;; Parmeters:
;;     gadgets-object -
;;     item-string    -
;;
(defun do-quit (gadgets-object item-string)
    (if *saved*
        (do-stop)                   ;; quit, classifier is not dirty
        (let ((button (do-query     ;; classifier is dirty and not saved 
                          (format NIL 
                              "WARNING: Classifier has not been saved~%~a"
                              "Save changes before quiting?"))))
            
            (if (equal button "YES")
                (if (not (do-save gadgets-object item-string)) 
                    (do-stop)       ;; no errors in do-save
                )
            )
            (if (equal button "NO")
                (do-stop)           ;; quit if they insist 
            )
        )
    )
)


;; do-stop destroys the application window and everything beneath it.
;;
;; Parmeters:
;;     none
;;
(defun do-stop ()
    (opal:destroy TOP-WIN)
    #-cmu (inter:exit-main-event-loop)
)


(format t "Type (agate:do-go) to begin.~%")
