;;########################################################################
;; tourplot.lsp 
;; copyright (c) 1991-98 by Forrest W. Young
;; Contains code for the ViSta tourplot to create a guided tour object
;;########################################################################

(require "vista")

(defmeth mv-data-object-proto :visualize-tour-plot ()
  (let* ((vars 
          (column-list (send current-data :active-data-matrix '(numeric))))
         (num-unique 
          (length (remove-duplicates (round (mapcar #'variance vars)))))
         (pt-labs (send current-data :active-labels))
         (var-labs (send current-data :active-variables '(numeric))))
    (if (= 1 num-unique)
        (visuals vars pt-labs var-labs nil :scale-type nil)
        (error-message "You must equate variances and means of all variables before using the Guided Tour."))))

;;########################################################################
;;define guided tour constructor function
;;########################################################################

(defun tour-plot (data &rest args)
  (let* ((graph (apply #'send tour-proto :new (length data) args))
        )
    (send graph :visuals-tour t)
    (send graph :tour nil)
    (send graph :min-degrees -1)
    (send graph :deg (list (send graph :min-degrees) 
                           (send graph :min-degrees) 0))
    (send graph :radians (mapcar #'radians (send graph :deg)))
    (send graph :add-points data)
    (send graph :margin 0 38 0 18)
    (send graph :tour-variables (iseq 6))
    (send graph :incremental-rotation
          (let ((deg (send graph :deg))
                )  
            (send graph :six-dim-rotate 
                  (select deg 0) (select deg 1) (select deg 2)
                            (send graph :num-variables))
            ))
    graph))

;;########################################################################
;; define guided tour prototype based on visuals guided tour algorithm
;;########################################################################

(defproto tour-proto 
  '(visuals-tour tour tour-variables min-degrees deg rok radians 
                 incremental-rotation model-p spreadplot) 
   () spin-proto)

(defmeth tour-proto :visuals-tour (&optional (arg nil set))
"Determines type of tour algorithm:  t for visuals tour, nil for screen tour."
  (if set (setf (slot-value 'visuals-tour) arg))
  (slot-value 'visuals-tour))

(defmeth tour-proto :tour (&optional (arg nil set))
"Determines type of do-idle action:  t for HDtour, nil for 3D spin."
  (if set (setf (slot-value 'tour) arg))
  (slot-value 'tour))

(defmeth tour-proto :tour-variables (&optional (arg nil set))
"A six element vector of the variable indices for 6D rotation."
  (if set (setf (slot-value 'tour-variables) arg))
  (slot-value 'tour-variables))

(defmeth tour-proto :min-degrees (&optional (arg nil set))
"Minimum rotation increment in degrees for tour algorithm."
  (if set (setf (slot-value 'min-degrees) arg))
  (slot-value 'min-degrees))
  
(defmeth tour-proto :deg (&optional (arg nil set))
"Current rotation increment of tour algorithm on each of three axes, in degrees."
  (if set (setf (slot-value 'deg) arg))
  (slot-value 'deg))

(defmeth tour-proto :rok (&optional (arg nil set))
"Used to reverse rotation direction for rocking capability."
  (if set (setf (slot-value 'rok) arg))
  (slot-value 'rok))

(defmeth tour-proto :radians (&optional (arg nil set))
"Current rotation increment of tour algorithm on each of three axes, in radians."
  (if set (setf (slot-value 'radians) arg))
  (slot-value 'radians))

(defmeth tour-proto :incremental-rotation (&optional (arg nil set))
"Current incremental rotation matrix.  Specifies one rotation step of the tour algorithm."
  (if set (setf (slot-value 'incremental-rotation) arg))
  (slot-value 'incremental-rotation))

(defmeth tour-proto :model-p (&optional (arg nil set))
"Model-p is t if model being visualized, nil if data being visualized."
  (if set (setf (slot-value 'model-p) arg))
  (slot-value 'model-p))

(defmeth tour-proto :spreadplot (&optional (arg nil set))
"Obj-ID of associated spreadplot."
  (if set (setf (slot-value 'spreadplot) arg))
  (slot-value 'spreadplot))

;;########################################################################
;;define touring methods for tour-proto (to be activated by buttons)
;;########################################################################

(defmeth tour-proto :six-dim-rotate (a b c ndim)
  (let ((tv (send self :tour-variables))
        (i-mat (identity-matrix ndim)))
    (matmult (make-rotation (row i-mat (select tv 0)) 
                            (row i-mat (select tv 3)) (radians a))
             (make-rotation (row i-mat (select tv 1)) 
                            (row i-mat (select tv 4)) (radians b))
             (make-rotation (row i-mat (select tv 2)) 
                            (row i-mat (select tv 5)) (radians c))))) 
 
(defmeth tour-proto :do-idle ()
"Method for guided tour to perform one step in the tour while system is 
otherwise idle."
  (cond 
    ((send self :tour)
     (let* ((tv (send self :tour-variables))
            (trans (send self :transformation))
            (radians (send self :radians)))
       (cond
         ((not (send self :visuals-tour))
          (send self :rotate-2 
                (select tv 0) (select tv 3) (select radians 0) :draw nil)
          (send self :rotate-2 
                (select tv 1) (select tv 4) (select radians 1)))
;This is the original Visuals method.  It doesn't work right and the
;menu item to activate it is commented out of the code below.
         ( t
           (if trans (send self :transformation 
                           (matmult trans (send self :incremental-rotation)))
               (send self :transformation 
                     (send self :incremental-rotation)))))))
    (t (call-next-method))))

(defmeth tour-proto :hd-rock ()
      "Method to rock the tour plot by reversing rotation direction."
      (let ((deg (send self :deg (- (send self :deg))))
            )
        (send self :rok (not (send self :rok)))
        (send self :radians (mapcar #'radians deg))
        (send self :incremental-rotation 
              (send self :six-dim-rotate 
                     (select deg 0) (select deg 1) (select deg 2)
                     (send self :num-variables)))))

(defmeth tour-proto :tour-alg ()
"Method for guided tour to toggle between the two available tour algorithms by toggeling value of visuals-tour.  When visuals-tour is true, the algorithm is the original visuals algorithm.  When visuals-tour is nil,  the algorithm is a new algorithm based on screen horizontal and vertical that is faster than the visuals algorithm.  Both are equivalent until 3D rotations (the pitch, roll and yaw buttons) are used."
  (send self :visuals-tour (not (send self :visuals-tour)))
  (send self :redraw)
  )

(defmeth tour-proto :tour-speed (axis dir)
"Method for guided tour to control tour speed on each tour dimension."
  (let* ((min-degrees (send self :min-degrees))
         (deg (send self :deg))
         (degnow (select deg axis))
         (rok (send self :rok))
         (change 1.025)
         )
    (if (= degnow 0)
        (if dir 
            (if rok (setf (select deg axis) min-degrees)
                (setf (select deg axis) (* -1 min-degrees)))))
    (if (/= degnow 0)
        (if dir (setf (select deg axis) (* (select deg axis) change)) 
            (setf (select deg axis) (/ (select deg axis) change))))
    (if (> (select deg axis) 360) (setf (select deg axis) 360))
    (if (<  min-degrees (select deg axis) (- min-degrees))
        (setf (select deg axis) 0))
    (send self :incremental-rotation 
          (send self :six-dim-rotate 
                (select deg 0) (select deg 1) (select deg 2)
                          (send self :num-variables)))
    (send self :radians (mapcar #'radians deg))
    (send self :deg deg)
  ))

(defmeth tour-proto :home ()
"Method to return the tour plot to its home orientation.  The method also stops rotation and resets rotation increments to their default values and directions."
  (let* ((min-degrees (send self :min-degrees))
         (deg (send self :deg))
         (point-state (send self :point-state (iseq (send self :num-points))))
         )
    (send self :idle-on nil)
    (send self :rok     nil)
    (send self :deg     (list min-degrees min-degrees min-degrees))
    (send self :radians (mapcar #'radians (send self :deg)))
    (send self :transformation nil)
    (send target1 :transformation nil)
    (send target2 :transformation nil)
    (when (send self :model-p) 
          (send ingram1 :transformation nil)
          (send ingram2 :transformation nil))
    (send tour-plot :point-state 
          (iseq (send tour-plot :num-points)) point-state)
    ))

(defmeth tour-proto :stop-go ()
"Method to stop or start guided tour."
  (let ((npts (send self :num-points))
        )
    (send self :idle-on (not (send self :idle-on)))
    (send self :point-state (iseq npts) (send self :point-state (iseq npts)))
    ))

(defmeth tour-proto :old-tour ()
"Method for guided tour to perform residualization."
  (let* ((nobs (send self :num-points))
         (nvar (send self :num-variables))
         (nvar-1 (- nvar 1))
         (transf (send self :transformation))
         (point-state (send self :point-state (iseq nobs)))
         (svd-struct nil)
         )
    (when transf
          (setf svd-struct 
               (sv-decomp (select transf (iseq nvar) (iseq 3 nvar-1))))
          (setf transf 
               (bind-rows 
                (select transf (iseq 3) (iseq nvar)) 
                (transpose (matmult (select svd-struct 0)
                                    (diagonal (select svd-struct 1))))))
          (send self :transformation transf)
          (when (send self :spreadplot)
                (send (second (send (send self :spreadplot) :plot-objs))
                      :transformation transf)
                (send (third (send (send self :spreadplot) :plot-objs))
                      :transformation transf))
          (when (send self :model-p) 
                (send ingram1 :transformation transf)
                (send ingram2 :transformation transf)))
    (send self :point-state (iseq nobs) point-state)
    ))

(defmeth tour-proto :new-tour ()
"Method for guided tour to perform residualization."
  (let* ((nobs (send self :num-points))
         (nvar (send self :num-variables))
         (nvar-1 (- nvar 1))
         (transf (send self :transformation))
         (point-state (send self :point-state (iseq nobs)))
         (tv (send self :tour-variables))
         (svd-struct nil)
         )
    (when transf
          (setf svd-struct 
               (sv-decomp (select transf (iseq nvar) (iseq 3 nvar-1))))
          (setf transf 
               (bind-rows 
                (select transf (iseq 3) (iseq nvar)) 
                (transpose (matmult (select svd-struct 0)
                                    (diagonal (select svd-struct 1))))))
          (send self :transformation transf)
          (when (send self :spreadplot)
                (send (second (send (send self :spreadplot) :plot-objs))
                      :transformation transf)
                (send (third (send (send self :spreadplot) :plot-objs))
                      :transformation transf))
          (when (send self :model-p) 
                (send ingram1 :transformation transf)
                (send ingram2 :transformation transf)))
    (send self :point-state (iseq nobs) point-state)
    ))

(defmeth tour-proto :isnew (&rest args)
  (apply #'call-next-method args)
  (send self :add-overlay (send tour-control-overlay-proto :new))
  )

(defmeth tour-proto :make-menu-item (item)
  (if (symbolp item)
      (case item
        (tour-method (send menu-item-proto :new "Tour Method"
            :action #'(lambda () (send self :tour-alg))))
        (show-targets 
         (setf *show-targets-menu-item* 
               (send menu-item-proto :new "Show Targets"
                     :action #'(lambda () (send self :show-targets)))))
        (t (call-next-method item)))
      item))

(send tour-proto :menu-template (append (send spin-proto :menu-template)
                                        '(tour-method show-targets)))

(defmeth tour-proto :show-targets ()
  (send *show-targets-menu-item* :mark 
        (not (send *show-targets-menu-item* :mark)))
  (refresh-spreadplot))

;;########################################################################
;;define overlay to contain buttons for tour-proto
;;########################################################################

(defproto tour-control-overlay-proto '() () spin-control-overlay-proto)

(defmeth tour-control-overlay-proto :isnew ()
  (call-next-method)
  (let ((gap (slot-value 'gap))
        (side (slot-value 'side))
        (ascent (slot-value 'ascent))
        )
    (send self :slot-value 'downs 
          (combine (send self :slot-value 'downs)
                   (list 
                    (+ (* 5 (+ gap side gap ascent gap))) ; Tour
                    (+ (* 6 (+ gap side gap ascent gap))) ; h speed -
                    (+ (* 6 (+ gap side gap ascent gap))) ; h speed +
                    (+ (* 7 (+ gap side gap ascent gap))) ; v speed -
                    (+ (* 7 (+ gap side gap ascent gap))) ; v speed +
                    (+ (* 8 (+ gap side gap ascent gap)))))) ;New
    ))

(defmeth tour-control-overlay-proto :redraw ()
  (let* ((downs (slot-value 'downs))
         (gap (slot-value 'gap))
         (side (slot-value 'side))
         (graph (send self :graph))
         (top-margin (second (send graph :margin)))
         (draw-color (send graph :draw-color))
         (ascent (slot-value 'ascent))
         (left-margin (slot-value 'left-margin))
         (wbd nil)
         )
    (setf downs (+ downs (- top-margin 12)))
    (if (and (send graph :use-color) (send *vista* :background-color)) 
        (send graph :draw-color 'toolbar-background)
        (send graph :draw-color 'white))
    (send graph :paint-rect 
          2 (select (+ downs (* 4 gap) side) 6)
          (- left-margin gap 1) (- (first (last downs)) (select downs 5)))
    (if (send *vista* :background-color)
        (send graph :draw-color draw-color)
        (send graph :draw-color 'black))
    (send graph :frame-rect 
          2 (select (+ downs (* 4 gap) side) 6)
          (- left-margin gap 1) (- (first (last downs)) (select downs 5)))
    (send self :draw-button nil (* 2 gap)  
          (select (+ downs (* 6 gap) side ascent) 6) side side) 
    (mapcar #'(lambda (x y pm) 
                (send self :draw-button nil x y side side wbd pm)) 
            (list (* 2 gap) (+ 3 (* 2 gap) side) 
                  (* 2 gap) (+ 3 (* 2 gap) side) (* 2 gap))
            (select (+ downs (* 6 gap) side ascent) (iseq 7 10))
            (list nil t nil t)
            ) 
    (send self :draw-button nil (* 2 gap)  
          (select (+ downs (* 6 gap) side ascent) 11) side side) 
    (mapcar #'(lambda (s x y) (send graph :draw-string s x y))
            '("Tour" "HSpd" "VSpd" "New")
            (repeat (* 2 gap) 4)
            (select (+ downs (* 5 gap) side ascent) (list 6 7 9 11)))
    ))

(defmeth tour-control-overlay-proto :do-click (x y m1 m2)
  (let* ((graph (slot-value 'graph))
         (left-margin (slot-value 'left-margin))
         (top-margin (second (send graph :margin)))
         (spin-downs (+ 17 top-margin (select (slot-value 'downs) 0)))
         (rock-downs (+ 17 top-margin (select (slot-value 'downs) 2)))
         (downs (select (slot-value 'downs) (iseq 6 11)))
         (gap (slot-value 'gap))
         (side (slot-value 'side))
         (top (select (+ downs (* 4 gap) side) 0))
         (text-base (+ 3 (slot-value 'text-base)))
         (box-top (+ 3 (slot-value 'box-top)))
         (big-small t)
         (ascent (slot-value 'ascent))
         (downs (+ downs (* 6 gap) side ascent))
         (nv (send graph :num-variables))
         (idling (send graph :idle-on))
         (i nil)
         (button-x nil)
         (pm nil)
         )
    (setf downs (+ downs (- top-margin 12)))
    (when (and (< (* 2 gap) x (+ (* 2 gap) side))
               (< spin-downs y (+ spin-downs side)))
          (when (send graph :tour)
                (send graph :tour nil)
                (send graph :idle-on nil))
          (send self :draw-button t (* 2 gap) spin-downs side side)
          (send self :draw-button nil (* 2 gap) (select downs 0) side side))
    (when (and (< (* 2 gap) x (+ (* 2 gap) side))
               (< rock-downs y (+ rock-downs side)))
          (send self :draw-button t (* 2 gap) rock-downs side side t)
          (send graph :hd-rock))
    (when (and (< x left-margin) (< top y))
       (when (< (* 2 gap) x (+ (* 2 gap) side))
             (setf button-x (* 2 gap))
             (setf pm nil)
             (cond
               ((< (first downs)  y (+ (first downs) side))
                (when (not (send graph :tour)) 
                      (send graph :tour t)
                      (send graph :idle-on nil))
                (send graph :idle-on (not (send graph :idle-on)))
                (send self :draw-button 
                      (send graph :idle-on) button-x (select downs 0)
                      side side)
                (send self :draw-button nil (* 2 gap) spin-downs side side))
               ((< (sixth downs)  y (+ (sixth downs) side))
                (send self :draw-button t button-x 
                      (sixth downs) side side t)
                (send graph :new-tour))
               ((< (second downs) y (+ (second downs) side)) (setf i 1))
               ((< (fourth downs) y (+ (fourth downs) side)) (setf i 3))))
          (when (< (+ (* 3 gap) side) x (+ (* 3 gap) (* 2 side)))
                (setf button-x (+ (* 3 gap) side))
                (setf pm t)
                (cond
                  ((< (third downs) y (+ (third downs) side)) (setf i 2))
                  ((< (fifth downs) y (+ (fifth downs) side)) (setf i 4))))
          (when i
                (send self :draw-button t button-x (select downs i) 
                      side side )
                (send graph :while-button-down
                      #'(lambda (x y)
                          (send graph :tour-speed (if (> i 2) 1 0) pm)
                          (send graph :do-idle)
                          ) nil)
                (send self :draw-button nil button-x (select downs i) 
                      side side nil pm))
          )))
