;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;                                                                        ;;
;;                 DYNAMIC UNCORRELATED 2D VIEWS                          ;;
;;                                                                        ;;
;;               Stat8931, Fall 1997, Prof. D. Cook                       ;;
;;                                                                        ;;
;;  Author: Luca Scrucca                                                  ;;
;;                                                                        ;;
;; (send <plot-name> :uncorrelated-2d)                                    ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(provide "uncorr-2d")

(defmeth graph-proto :cand-summary-plot () (sysbeep)
  (let* ((plot self)
         (n (send plot :num-points))
         (show (send plot :points-showing))
         (reg (if (send plot :has-slot 'owner) (send plot :slot-value 'owner)
                  nil))
         (hcoords (first (send self :screen-coordinates)))
         (hshow   (format nil "~7,4@f ~7,4@f ~a ~7,4@f ~a" 
                     (select hcoords 0) 
                     (select hcoords 1) (car (send self :label 0))
                     (select hcoords 3) (car (send self :label 2))))         
         (h (send plot :point-transformed-coordinate 0 (iseq n)))
         (v (send plot :point-transformed-coordinate 1 (iseq n)))
         (graph (cond (reg (apply #'send reg :plot1
                                  (list (list h v) 
                                        :plot-controls nil 
                                        :title "Candidate Summary Plot"
                                        :show nil)))
                  (t (let ((p (plot-points h v :show nil)))
                       (send p :title "Candidate Summary Plot")
;                       (send p :plot-controls)
                       (send p :linked t)
                       p)))))
    (send graph :points-showing show)
    (send graph :point-masked (iseq n) (send plot :point-masked (iseq n)))
    (send plot :linked t)
    (send graph :adjust-to-data)
    (send graph :x-axis t t 5)
    (send graph :y-axis t t 5)
    (send graph :variable-label '(0 1) (list "Horizontal Direction" "Vertical"))
    (send graph :message-on-plot (list "Summary Plot" 
                                       (format nil "Vertical:   ~a (rescaled)"
                                                             (car (send self :label 1)))
                                       (format nil "Horizontal: ~a" hshow)))
    (send graph :add-slot 'horizontal h)
    (send graph :add-slot 'vertical v)
    (send graph :add-slot 'h-sliced 0)
    (send graph :add-slot 'slice-to-show 0)
    (send graph :add-slot 'slice-j 0)
    (send graph :add-slot 'type-slice nil)
    (send graph :add-slot 'upd-plots nil)
    graph))

(defmeth graph-proto :uncorr-2D-plot () (sysbeep)
  (let* ((plot self)
         (n (send plot :num-points))
         (show (send plot :points-showing))
         (reg (if (send plot :has-slot 'owner) (send plot :slot-value 'owner)
                  nil))
         (lcp (send self :find-overlays 'LABEL-CONTROL-PROTO))
         (h_u (send self :ortho-direction))
         (v   (send plot :point-transformed-coordinate 1 (iseq n)))
         (graph (cond (reg (apply #'send reg :plot1
                                  (list (list h_u v) :plot-controls nil 
                                        :title "Plot in uncorrelated direction")))
                  (t (let ((p (plot-points h_u v :show nil)))
                       (send p :title "Plot in uncorrelated direction")
;                       (send p :plot-controls)
                       (send p :linked t)
                       p)))))
    (send graph :points-showing show)
    (send graph :point-masked (iseq n) (send plot :point-masked (iseq n)))
    (send plot :linked t)
    (send graph :adjust-to-data)
    (send graph :x-axis t t 5)
    (send graph :y-axis t t 5)
    (send graph :variable-label '(0 1) (list "Uncorrelated Direction" "Vertical"))
;;-------------------------------------------------------------------------------;;
;; define slot and menu item for lowess smoother
    (send graph :add-slot 'span 0.5)
    (send (send graph :menu) :append-items 
              (send dash-item-proto :new) 
              (send menu-item-proto :new "Span Lowess slider"
                    :action #'(lambda () (send graph :uncorr2d-lowess-slider))))
;; slider: update slot when action then draw
    (defmeth graph :uncorr2d-lowess-slider ()
      (let* ((slider (interval-slider-dialog (list 0 1)
                    :title "Span of Lowess smoother" :points 20
                    :action #'(lambda (w) 
                       (send graph :slot-value 'span w)
                       (send graph :uncorr2d-lowess-draw)))))
    (send slider :value (send graph :slot-value 'span))
    (send graph :add-subordinate slider)))
;; lowess: draw when slot not nil  
    (defmeth graph :uncorr2d-lowess-draw ()
     (cond ((= (send self :slot-value 'span) 0) (send self :clear-lines))
           (t (let* ((n (send self :num-points))
                     (showing (send self :points-showing))
                     (x (select (send self :point-coordinate 0 (iseq n)) showing))
                     (y (select (send self :point-coordinate 1 (iseq n)) showing))
                     (s (lowess x y :f (send self :slot-value 'span))))
                (send self :clear-lines :draw nil)  
                (send self :add-lines (select s 0) (select s 1) :color 'red)))))
;;-------------------------------------------------------------------------------;;
    graph))


(defmeth graph-proto :chk-uncorr-dir () (sysbeep)
  (let* ((plot self)
         (n (send plot :num-points))
         (show (send plot :points-showing))
         (reg (if (send plot :has-slot 'owner) (send plot :slot-value 'owner)
                  nil))
         (h_u (send self :ortho-direction))
         (h   (send plot :point-transformed-coordinate 0 (iseq n)))
         (graph (cond (reg (apply #'send reg :plot1
                                  (list (list h_u h) 
                                        :plot-controls nil 
                                        :title "Checking plot for uncorrelated direction")))
                  (t (let ((p (plot-points h_u h :show nil)))
                       (send p :title "Checking plot for uncorrelated direction")
;                       (send p :plot-controls)
                       (send p :linked t)
                       p)))))
    (send graph :points-showing show)
    (send graph :point-masked (iseq n) (send plot :point-masked (iseq n)))
    (send plot :linked t)
    (send graph :adjust-to-data)
    (send graph :x-axis t t 5)
    (send graph :y-axis t t 5)
    (send graph :variable-label '(0 1) '("Uncorrelated Direction" "Horizontal Direction"))
;;-------------------------------------------------------------------------------;;
;; define slot and menu item for lowess smoother
    (send graph :add-slot 'span 0.5)
    (send (send graph :menu) :append-items 
              (send dash-item-proto :new) 
              (send menu-item-proto :new "Span Lowess slider"
                    :action #'(lambda () (send graph :uncorr2d-lowess-slider))))
;; slider: update slot when action then draw
    (defmeth graph :uncorr2d-lowess-slider ()
      (let* ((slider (interval-slider-dialog (list 0 1)
                    :title "Span of Lowess smoother" :points 20
                    :action #'(lambda (w) 
                       (send graph :slot-value 'span w)
                       (send graph :uncorr2d-lowess-draw)))))
    (send slider :value (send graph :slot-value 'span))
    (send graph :add-subordinate slider)))
;; lowess: draw when slot not nil  
    (defmeth graph :uncorr2d-lowess-draw ()
     (cond ((= (send self :slot-value 'span) 0) (send self :clear-lines))
           (t (let* ((n (send self :num-points))
                     (showing (send self :points-showing))
                     (x (select (send self :point-coordinate 0 (iseq n)) showing))
                     (y (select (send self :point-coordinate 1 (iseq n)) showing))
                     (s (lowess x y :f (send self :slot-value 'span))))
                (send self :clear-lines :draw nil)  
                (send self :add-lines (select s 0) (select s 1) :color 'red)))))
;;-------------------------------------------------------------------------------;;
    graph))

(defmeth graph-proto :uncorrelated-2D ()
  (let ((graph self))
;; check if vertical axis corresponds to response variable
    (unless (and (= (select (select (send graph :screen-coordinates) 1) 1) 0)
                 (= (select (select (send graph :screen-coordinates) 1) 3) 0))
            (error "Uncorrelated 2D view only works if the vertical axis shows the response variable!!"))
;; draw graphics
    (def plot1-uncorr (send graph :cand-summary-plot))
    (def plot2-uncorr (send graph :uncorr-2D-plot))
    (def plot3-uncorr (send graph :chk-uncorr-dir))
    (send plot1-uncorr :plot-controls)
    (send plot1-uncorr :install-uncorr-slide1)
    (send plot1-uncorr :install-uncorr-slide2)
    (send plot2-uncorr :linked nil)
    (send plot3-uncorr :linked nil)
#-unix (send plot1-uncorr :location 5 104)
#-unix (send plot1-uncorr :size 508 432)
;#+unix (send plot1-uncorr :location 18 302)
;#+unix (send plot1-uncorr :size 562 425)
#-unix (send plot2-uncorr :location 520 291)
#-unix (send plot2-uncorr :size 270 245)
;#+unix (send plot2-uncorr :location 584 393)
;#+unix (send plot2-uncorr :size 390 330)
#-unix (send plot3-uncorr :location 520 20)
#-unix (send plot3-uncorr :size 270 245)
;#+unix (send plot3-uncorr :location 584 61)
;#+unix (send plot3-uncorr :size 390 330)
  (send plot1-uncorr :show-window)
  (send plot2-uncorr :show-window)
  (send plot3-uncorr :show-window)
  (send plot2-uncorr :add-slot 'range-x (send plot2-uncorr :range 0))
  (send plot2-uncorr :add-slot 'range-y (send plot2-uncorr :range 1))
  (defmeth plot1-uncorr :close ()
    (call-next-method)
    (send plot2-uncorr :close)
    (send plot3-uncorr :close)
    (if (send self :has-slot 'owner) 
        (send (send self :slot-value 'owner) :delete-graph self))
    (send graph :show-window))

  (send graph :hide-window)
  t
))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Slider 1:     slices
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defproto uncorr-slide1-proto '() () slider-control-proto)
(defmeth graph-proto :install-uncorr-slide1 ()
  (let ((control 
         (send uncorr-slide1-proto :new (iseq 101)
               :location (send self :locate-next-control :height 2)
               :length (send self :slider-width)
               :display (rseq 0 1 101)
               :index 0
               :title "Slices"
               :graph self
               :popup t
               )))
    control))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;           pupup menu                                         ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defmeth uncorr-slide1-proto :shift-click () 
  (let* ((menu (send self :menu))
         (loc (+ (send (send self :graph) :location) (send self :location)))
         (offset (ms '(-15 52) '(-15 32) '(-15 30))))
    (apply #'send menu :popup (+ offset loc))
    (send self :redrw)))

(defmeth uncorr-slide1-proto :type-slice ()
  (let* ((graph (send self :graph))
         (j (send graph :slot-value 'slice-j))
        )
    (send graph :slot-value 'type-slice
          (null (send graph :slot-value 'type-slice)))
    (send self :do-action j)
  )
)

(defmeth uncorr-slide1-proto :upd-plots ()
  (let ((graph (send self :graph))
       )
    (send graph :slot-value 'upd-plots
          (null (send graph :slot-value 'upd-plots)))
    (send self :update-plots)
  )
)

(defmeth uncorr-slide1-proto :menu (&optional (title "Slider Menu")) 
  (let* ((graph (send self :graph)))
    (when (null (slot-value 'menu)) 
          (let* ((menu (send menu-proto :new title)))
            (apply #'send menu :append-items (send self :get-menu-items))
            (send self :slot-value 'menu menu)))
    (slot-value 'menu)))

(defmeth uncorr-slide1-proto :get-menu-items ()
  (let* ((graph (send self :graph))
         (item0 (send menu-item-proto :new "Overlapping slices..."
                            :action #'(lambda () (send self :type-slice))))
         (item1 (send menu-item-proto :new "Update checking plots..."
                      :action #'(lambda () (send self :upd-plots))))
         )
    (defmeth item0 :update ()
         (send item0 :mark (send graph :slot-value 'type-slice))
         (send item1 :mark (send graph :slot-value 'upd-plots))
      )
    (list item0 item1)))
    
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defmeth uncorr-slide1-proto :do-action (j)
  (let* ((p1 plot1-uncorr)
       	 (h (send p1 :slot-value 'horizontal))
         (slices 0)
         (num-slices 0)
         (type-slice (send p1 :slot-value 'type-slice))
         (h-sliced nil)
        )
    (send p1 :slot-value 'slice-j j)
    (send p1 :point-selected (iseq 0 (length h)) nil)
    (cond 
      ((equal j 0)
       (send p1 :slot-value 'h-sliced 0)
       (send p1 :slot-value 'slice-to-show 0))
      ((and (/= j 0) (equal type-slice t))
       (setf h-sliced
             (do* ((i 0 (1+ i))
                   (h-unique (unique (select h (order h))))
                   (h0 (select h-unique i))
                   (h-sliced nil)
                   (f (/ j 100))
                  ) 
                  ((> i (1- (length h-unique))) h-sliced)
                  (setf h0 (select h-unique i))
                  (setf h-sliced (append h-sliced (list (nn-slices h h0 f))))
             ))
       (send p1 :slot-value 'h-sliced h-sliced)
       (send p1 :slot-value 'slice-to-show 0))
      (t
       (setf num-slices (/ 100 j))
       (setf h-sliced (sir-slices h num-slices))
       (send p1 :slot-value 'h-sliced h-sliced)
       (send p1 :slot-value 'slice-to-show 0))
    )
    (send uncorr-slide1-proto :update-plots)
  )
)


(defmeth uncorr-slide1-proto :update-plots ()
  (let* ((p1 plot1-uncorr) 
         (p2 plot2-uncorr)
	 (p3 plot3-uncorr)
         (h (send p1 :slot-value 'horizontal))
         (h-sliced (send p1 :slot-value 'h-sliced))
         (slice-to-show (send p1 :slot-value 'slice-to-show))
         (edges 0)
         (range-v (send p1 :range 1))
        )
    (cond
;; If slices on the graph is 0, restore the initial plots 
     ((and (equal h-sliced 0) (equal slice-to-show 0))
      (send p1 :clear-lines)
      (send p2 :clear-lines)
      (send p3 :clear-lines)
      (send p1 :point-showing (iseq (length h)) t)
      (send p2 :point-showing (iseq (length h)) t)
      (send p3 :point-showing (iseq (length h)) t)
      (send p2 :adjust-to-data)
      (send p3 :adjust-to-data))
     (t
;; Hilite selected points on the summary plot, while only show them on
;; the two checking plots and adjust-to-data if requested
      (send p1 :point-showing (iseq (length h)) t)
      (send p1 :point-selected (select h-sliced slice-to-show) t)
      (send p2 :point-showing (iseq (length h)) nil)
      (send p2 :point-showing (select h-sliced slice-to-show) t)
      (send p3 :point-showing (iseq (length h)) nil)
      (send p3 :point-showing (select h-sliced slice-to-show) t)
      (send p2 :uncorr2d-lowess-draw)
      (send p3 :uncorr2d-lowess-draw)
      (cond 
        ((send p1 :slot-value 'upd-plots) 
         (send p2 :adjust-to-data)
         (send p3 :adjust-to-data))
        (t
         (send p2 :range 0 (first  (send p2 :slot-value 'range-x))
                           (second (send p2 :slot-value 'range-x)))
         (send p2 :range 1 (first  (send p2 :slot-value 'range-y))
                           (second (send p2 :slot-value 'range-y)))
         (send p3 :range 0 (first  (send p2 :slot-value 'range-x))
                           (second (send p2 :slot-value 'range-x)))
         (send p3 :range 1 (first  (send p2 :slot-value 'range-y))
                           (second (send p2 :slot-value 'range-y))))
      )
;; Draw lines 
      (setf edges (range (select h (select h-sliced slice-to-show))))
      (send p1 :clear-lines)
      (send p1 :add-lines (repeat (first edges) 2) range-v :color 'blue :type 'dashed)
      (send p1 :add-lines (repeat (second edges) 2) range-v :color 'blue :type 'dashed)    
      (send p1 :add-lines edges (repeat (first range-v) 2) :color 'blue :type 'dashed)    
      (send p1 :add-lines edges (repeat (second range-v) 2) :color 'blue :type 'dashed)    

     )
   )
  )
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Slider 2:       moving slice
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
#|
(defproto uncorr-slide2-proto '() () slider-control-proto)
(defmeth graph-proto :install-uncorr-slide2 ()
  (let ((control 
         (send uncorr-slide2-proto :new (iseq 2)
               :location (send self :locate-next-control :height 2)
               :length (send self :slider-width)
               :display '("->" "->")
               :index 0
               :title "<-"
               :graph self
               )))
    control))
|#

(defmeth graph-proto :install-uncorr-slide2 (&key location)
  (setf location (send self :locate-next-control :height 2))
  (setf location (+ location 
                    (list (round (* (send self :slider-width) 0.4)) 0)))
  (send self :add-overlay 
        (send uncorr-slide2-proto :new :title "" :location location))
)

(defproto uncorr-slide2-proto '() () graph-control-proto)

(defmeth uncorr-slide2-proto :isnew (&rest args &key (size 10))
  (apply #'call-next-method args)
  (send self :add-slot 'size size)
  self)

(defmeth uncorr-slide2-proto :size () (slot-value 'size))

(defmeth graph-proto :draw-uncorr-slide2 (loc s space)
  (let* ((s2 (floor (/ s 2)))
         (h (floor (* .5 s (sqrt 3))))
         (p1 (+ loc (list  0 s2)))
         (p2 (+ loc (list  h s)))
         (p3 (+ loc (list  h 0)))
         (p4 (+ loc (list  (+ h space) s)))
         (p5 (+ loc (list  (+ h space) 0)))
         (p6 (+ loc (list (+ h space h) s2))))
;    (send self :draw-line (first p1) (second p1) (first p2) (second p2))
;    (send self :draw-line (first p2) (second p2) (first p3) (second p3))
;    (send self :draw-line (first p3) (second p3) (first p1) (second p1))
;    (send self :draw-line (first p4) (second p4) (first p5) (second p5))
;    (send self :draw-line (first p5) (second p5) (first p6) (second p6))
;    (send self :draw-line (first p6) (second p6) (first p4) (second p4))
    (send self :frame-poly (list p1 p2 p3 p1))
    (send self :frame-poly (list p4 p5 p6 p4))
 )
)

(defmeth uncorr-slide2-proto :redraw ()
  (let* ((graph (send self :graph))
         (loc (send self :location))
         (size (send self :size)))
    (send graph :draw-uncorr-slide2 loc size 3)))


(defmeth uncorr-slide2-proto :do-click (x y a b)
  (let* ((graph (send self :graph))
         (size (send self :size))
         (loc (send self :location))
         (loc-x (first loc))
         (loc-y (second loc))
         (h (floor (* .5 size (sqrt 3))))
         (h2 (ceiling (* .5 size (sqrt 3))))
         (p1 plot1-uncorr) 
         (h-sliced (send p1 :slot-value 'h-sliced))
         (slice-to-show (send p1 :slot-value 'slice-to-show))         
        )
    (cond 
      ((and (<= loc-x x (+ loc-x h))
            (<= loc-y y (+ loc-y size)))
       (send self :do-action 0) t)
      ((and (<= (+ loc-x h2) x (+ loc-x h2 h))
            (<= loc-y y (+ loc-y size)))
       (send self :do-action 1) t)
    )
 )
)

(defmeth uncorr-slide2-proto :do-action (j)
  (let* ((p1 plot1-uncorr)
         (h (send p1 :slot-value 'horizontal))
         (slice-to-show (send p1 :slot-value 'slice-to-show))
         (h-sliced (send p1 :slot-value 'h-sliced))
         (num-slices 0)
        )
    (if (listp h-sliced) (setf num-slices (length h-sliced)))
    (if (equal j 0)
        (setf slice-to-show (- slice-to-show 1))
        (setf slice-to-show (+ slice-to-show 1)))
    (cond 
      ((< slice-to-show 0) (setf slice-to-show 0))
      ((> slice-to-show (- (max num-slices) 1)) 
       (setf slice-to-show (- (max num-slices) 1)))
    )
    (cond 
      ((equal h-sliced 0) 
       (send p1 :point-selected (iseq 0 (length h)) nil))
      (t (send p1 :slot-value 'slice-to-show slice-to-show)
         (send uncorr-slide1-proto :update-plots))
     )
  )
)                                                                               

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; The following code will return the indices of the fraction f observations  ;;
;; closest to x0.                  Received by Sandy Weisberg, Dec. 3rd 1997. ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun nn-slices (x x0 f &key (or (order x)))
"Function args: (x x0 f &key (or (order x)))
x is a vector of length n. x0 is an element of x.  or orders x.  Returns
the indices of the fraction f of observations closest of x0, accounting for
ties and boundaries."
  (let* ((pos (position x0 (select x or) :test #'<=))
         (n (length x))
         (p (max 1 (floor (* .5 f n)))) ;; approximately symmetric intervals
         (lo (max 0 (- pos p)))         ;; stay in 0 to n-1
         (hi (min (- n 1) (+ pos p))))  ;;

   (when (< hi (- n 1))                 ;; check for high-end ties
      (let ((ties (position 0 (- (select (select x or) (iseq (1+ hi) (- n 1)))
                                  (select (select x or) hi))
                          :test #'<)))
        (setf hi (if ties (+ hi ties) (- n 1)))))
   (when (> lo 0)                       ;; check for low-end ties
      (let ((ties (position 0 (- (select (select x or) lo)
                                 (reverse (select (select x or) (iseq lo))))
                          :test #'>)))
;        (setf lo (if ties (- lo ties) 0))))
        (setf lo (if ties (- lo ties) lo))))
   (select or (iseq lo hi))))          ;; return subscripts

(defun unique (x) 
"Arg: (x) list. Returns the unique values of x."
  (remove-duplicates x :test #'equal))



;;----------------------------------------------------------------------;;
;; Add to the SPIN-PROTO menu an item for calling the uncorrelated 2D   ;;
;; views method.                                                        ;;
;;                                                         Apr. 1998    ;;
;;----------------------------------------------------------------------;;
(defmeth SPIN-PROTO :install-item-uncorr2D ()
  (let* ((uncorr2D-item
            (send menu-item-proto
                 :new "Uncorrelated 2D views"
                 :action #'(lambda () (require "uncorr-2d")
                                      (send self :uncorrelated-2D))))
         (dash-item  (send DASH-ITEM-PROTO :new))
         )
    (send (send self :menu) :append-items dash-item)
    (send (send self :menu) :append-items uncorr2D-item)
  )
)
;; modified method from overlay1.lsp in order to add the last item
(defmeth spin-proto :plot-controls ()
  (call-next-method)
  (send self :install-color-symbol-buttons)
  (send self :install-toggle-linear-trend)
  (send self :install-ortho-control)
  (send self :install-scale-control)
  (send self :install-3d-poly-control)
  (send self :install-extract-menu)
  (send self :install-item-uncorr2D)
 t)
;;----------------------------------------------------------------------;;

;; add method to getpic.lsp for drawing the slicing control in a latex picture
;;
(defmeth uncorr-slide2-proto :redraw-latex (output)
 (let* ((location (send self :location-latex))
        (loc-x (first location))
        (loc-y (second location)))
  (format output "\\newcommand{\\putslicingcontrol}{\\put(0,1){\\path(0,5)(0,-5)(-10,0)(0,5)}\\put(0,1){\\path(3,5)(3,-5)(14,0)(3,5)}} ~%")
  (format output "\\put(~a,~a){\\makebox(0,0){\\putslicingcontrol}} % Uncorr-2D slicing control ~%" loc-x (+ loc-y 7))
))


;;-------------------------------------------------------------------;;
;;                                                                   ;;
;;  Draw a message inside a framed box at the bottom of a plot       ;; 
;;  as an overlay                                                    ;;
;;                                                                   ;;
;;                                          Luca Scrucca, Sept 1999  ;;
;;-------------------------------------------------------------------;;

(defproto message-frame-proto '(text title left top width height) () graph-overlay-proto)
(defmeth message-frame-proto :isnew (&optional text title) 
    (when text  (send self :slot-value 'text text)
                (send self :slot-value 'title title)))

(defmeth message-frame-proto :redraw ()
 (when (send self :graph)
  (let* ((graph (send self :graph))
         (text  (send self :slot-value 'text))
         (line-height (+ (send graph :text-ascent) (send graph :text-descent)))
         (bot (* line-height (length text))) 
	     (l   2)
    	 (top (- (send graph :canvas-height) bot line-height))
	     (w   (- (send graph :canvas-width) 4))
	     (h   (+ bot line-height -2))
         (incpos (+ (list 0 (+ (send graph :text-ascent) (send graph :text-descent)))))
	     (pos (+ '(5 2) (list l top)))
        )
    (send self :slot-value 'left l)
    (send self :slot-value 'top top) 
    (send self :slot-value 'width w)
    (send self :slot-value 'height h) 
    (unless (null text)
            (send graph :frame-rect l top w h)
            (setf pos (+ pos incpos))
            (dotimes (i (length text))
                (send graph :draw-text (select text i) (nth 0 pos) (nth 1 pos) 0 0)
                (setf pos (+ pos incpos))))
 ))
)

(defmeth graph-proto :message-on-plot (&optional (text t) (title "message"))
"Args: (&optional text)
Draws the message on TEXT at the bottom of the graph, framed by a rectangle.
TEXT can be a string, or a list of strings. Each string is printed in a new
line. 
If text is t then the actual message is returned, if TEXT is nil both the 
message and the frame are deleted from the plot."

;; when already installed, if text t return the message, if nil remove the message
  (cond ((and (equal text t) (send self :find-overlay 'MESSAGE-FRAME-PROTO)) 
              (return-from :message-on-plot 
                  (send (send self :find-overlay 'MESSAGE-FRAME-PROTO) :slot-value 'text)))
        ((and (null text) (send self :find-overlay 'MESSAGE-FRAME-PROTO)) 
              (send self :delete-overlay (send self :find-overlay 'MESSAGE-FRAME-PROTO))
              (apply #'send self :margin (combine (select (send self :margin) '(0 1 2)) 0))
              (return-from :message-on-plot nil))
  )

;; if already installed remove it
  (when (send self :find-overlay 'MESSAGE-FRAME-PROTO)
        (send self :delete-overlay (send self :find-overlay 'MESSAGE-FRAME-PROTO))
        (apply #'send self :margin (combine (select (send self :margin) '(0 1 2)) 0)))

;; install the new message               
  (let* ((text (if (listp text) text (combine text)))
         (message-overlay (send message-frame-proto :new text title))
         (line-height (+ (send self :text-ascent) (send self :text-descent)))
         (bot (* line-height (length text))) 
	     (h   (+ bot line-height -2))
        )         
    (send self :add-overlay message-overlay)
    (apply #'send self :margin (+ (send self :margin) (list 0 0 0 h)))
    message-overlay
  )
)

(defmeth message-frame-proto :redraw-latex (output)
  (let* ((graph (send self :graph))
         (text  (send self :slot-value 'text))
         (title (send self :slot-value 'title))
         (l     (send self :slot-value 'left))
         (top   (send self :slot-value 'top)) 
         (w     (send self :slot-value 'width))
         (h     (send self :slot-value 'height))
         (line-h (+ (send graph :text-ascent) (send graph :text-descent)))
         (y-coord (- (second (send graph :size)) top (* line-h (iseq 1 (length text))))) 
       )
    (when text
          (mapcar (lambda (y msg)
                   (format output "\\put(~a,~a){\\makebox(0,0)[l]{ ~a}} % message-on-plot ~%"
                                   l y msg))
          y-coord text)
         (format output "\\put(~a,~a){\\framebox(~a,~a){}} % frame for message-on-plot ~%"
                         l (- (second (send graph :size)) top h) w h)
    )
 )
)