;;;  -*- mode: LISP; Package: CL-USER; Syntax: COMMON-LISP;  Base: 10 -*-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 
;;; Author      : Mike Byrne
;;; Copyright   : (c)2000 Rice U./Mike Byrne, All Rights Reserved
;;; Availability: public domain
;;; Address     : Rice University
;;;             : Psychology Department
;;;             : Houston,TX 77251-1892
;;;             : byrne@acm.org
;;; 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 
;;; Filename    : view-line.lisp
;;; Version     : r2 
;;; 
;;; Description : Allows for drawing lines in MCL windows that creates views,
;;;             : and therefore features, for the window.  That way R/PM will see
;;;             : the lines without using rpm-line-to and having to deal with 
;;;             : making sure the lines are redrawn when there is a pm-proc-display.
;;; 
;;; Bugs        : 
;;; 
;;; Todo        :
;;; 
;;; ----- History -----
;;; 00.08.23 Mike Byrne
;;;             :  Incept date.
;;;
;;; 01.01.22 Dan Bothell
;;;             :  Changed the view-draw-contents for the line view so that it 
;;;             :  actually draws on the parent window and not directly on the subview
;;;             :  (I assumed that was kosher, since the original did that the first
;;;             :  time, but not in the view-draw-contents - though I've not done a lot
;;;             :  of Mac interface work, so I may be violating some rule of what a subview
;;;             :  is allowed to do).
;;;             :  Fixed the horizontal (and vertical) line problem by always having 
;;;             :  the view-size be 1 larger in each direction, so the 0 height views
;;;             :  are now 1 high and get updated (the view-draw-contents compensates
;;;             :  for the extra height by subtracting 1).
;;;             :  Added a color option to the line, and put in a function that converts
;;;             :  a default Mac color to a symbol (*red-color* for example to the symbol red)
;;;             :  for use in creating the chunks.  The nondefault colors get converted to
;;;             :  the symbol color-RRRRR-GGGGG-BBBBB where the R's, G's, and B's are the
;;;             :  red, green, and blue components of the color left padded with zeros
;;;             :  to 5 digits.
;;;             :  Added the feat-to-dmo method for a line-feature because R/PM 2.0b4 doesn't 
;;;             :  seem to have one anymore (which caused some problems for rpm-line-to also).
;;;             :  Updated the version from r1 to r2.  (Why is it r? What does that mean?)
;;;             :  Various comments added to help make this clearer.  You don't know how long
;;;             :  it took me to figure out what td and bu meant...
;;;             :
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;;; The base class for the view based lines.  All it adds is a color slot.

(defclass liner (simple-view)
  ((color :accessor color :initarg :color :initform *black-color*)))



(defmethod point-in-click-region-p ((self liner) where)
  "Method needed by R/PM so that if the mouse is clicked on the view it
   doesn't get handled by this view, and is passed on to the next"
  (declare (ignore where))
  nil)


;;;  A view that represents a line which is drawn top-down i.e. from the
;;;  view-position (upper-left) to the [view-size - (1,1)] (lower-right) in the
;;;  container window

(defclass td-liner (liner)
  ()
  )

;;;  A view that represents a line which is drawn bottom-up i.e. from the
;;;  view's lower-left to the view's upper-right in the container window.

(defclass bu-liner (liner)
  ()
  )


(defmethod view-draw-contents ((lnr td-liner))
  "Draws the line on the view-container window using the color specified
   and restoring the previous draw color and pen position"
  (let* ((parent (view-container lnr))
         (old-point (pen-position parent))
         (old-color (get-fore-color parent))
         (other-end (add-points (view-size lnr) (view-position lnr))))
    (set-fore-color parent (color lnr))
    (move-to parent (view-position lnr))
    (line-to parent (make-point (1- (point-h other-end))
                                (1- (point-v other-end))))
    (set-fore-color parent old-color)
    (move-to parent old-point)))



(defmethod view-draw-contents ((lnr bu-liner))
  "Draws the line on the view-container window using the color specified
   and restoring the previous draw color and pen position"
  (let* ((parent (view-container lnr))
         (old-point (pen-position parent))
         (old-color (get-fore-color parent)))
    (set-fore-color parent (color lnr))
    (move-to parent (make-point (point-h (view-position lnr))
                                (1- (point-v (add-points (view-position lnr) (view-size lnr))))))
    (line-to parent (make-point (1- (point-h (add-points (view-size lnr) (view-position lnr))))
                                (point-v (view-position lnr))))
    (set-fore-color parent old-color)
    (move-to parent old-point)))


(defmethod build-features-for ((lnr td-liner) (vis-mod vision-module))
  "Convert the view to a feature to be placed into the visual icon"
  (let ((start-pt (view-position lnr))
        (end-pt (subtract-points (add-points (view-position lnr) (view-size lnr)) 
                                  (make-point 1 1))))
    (make-instance 'line-feature
      :color (mac-color->symbol (color lnr))
      :end1-x (point-h start-pt) 
      :end1-y (point-v start-pt)
      :end2-x (point-h end-pt) 
      :end2-y (point-v end-pt)
      :x (loc-avg (point-h start-pt) (point-h end-pt))
      :y (loc-avg (point-v start-pt) (point-v end-pt))
      :width (abs (- (point-h start-pt) (point-h end-pt)))
      :height (abs (- (point-v start-pt) (point-v end-pt))))))


(defmethod build-features-for ((lnr bu-liner) (vis-mod vision-module))
  "Convert the view to a feature to be placed into the visual icon"
  (let ((start-pt (add-points (view-position lnr)
                                (make-point 0 (1- (point-v (view-size lnr))))))
        
        
        (end-pt (add-points (view-position lnr) 
                             (make-point (1- (point-h (view-size lnr))) 0))))
    (make-instance 'line-feature
      :color (mac-color->symbol (color lnr))
      :end1-x (point-h start-pt) 
      :end1-y (point-v start-pt)
      :end2-x (point-h end-pt) 
      :end2-y (point-v end-pt)
      
      :x (loc-avg (point-h start-pt) (point-h end-pt))
      :y (loc-avg (point-v start-pt) (point-v end-pt))
      :width (abs (- (point-h start-pt) (point-h end-pt)))
      :height (abs (- (point-v start-pt) (point-v end-pt))))))


(defun rpm-view-line (wind start-pt end-pt &optional (color *black-color*))
  "Adds a view in the specified window which draws a line from the start-pt to the end-pt
   using the optional color specified (defaulting to black).  This view will add features 
   to the icon on PM-PROC-DISPLAY."
  (let* ((gx (> (point-h end-pt) (point-h start-pt)))
         (gy (> (point-v end-pt) (point-v start-pt)))
         (vs (subtract-points start-pt end-pt)))
    (setf vs (make-point (+ 1 (abs (point-h vs)))
                         (+ 1 (abs (point-v vs)))))
    (add-subviews wind (cond ((and gx gy)
                              (make-instance 'td-liner
                                :color color
                                :view-position start-pt 
                                :view-size vs))
                             ((and (not gx) (not gy))
                              (make-instance 'td-liner
                                :color color
                                :view-position end-pt 
                                :view-size vs))
                             ((and gx (not gy))
                              (make-instance 'bu-liner
                                :color color
                                :view-position (make-point (point-h start-pt) (point-v end-pt))
                                :view-size vs))
                             (t
                              (make-instance 'bu-liner
                                :color color
                                :view-position (make-point (point-h end-pt) (point-v start-pt))
                                :view-size vs))))))



(defun mac-color->symbol (color)
  "Return a symbol that names the color.  For a default Mac color the symbol 
   is the corresponding name i.e. *red-color* maps to red, but only for the
   'recognized' colors (those that basically map between win and mac).
   Any other color gets mapped to a symbol color-RRRRR-GGGGG-BBBBB where the R's, 
   G's, and B's are the red, green, and blue components of the color left padded 
   with zeros to 5 digits."
  (cond ((equal color *red-color*) 'red)
        ((equal color *blue-color*) 'blue)
        ((equal color *green-color*) 'green)
        ((equal color *black-color*) 'black)
        ((equal color *white-color*) 'white)
        ((equal color *pink-color*) 'pink)
        ((equal color *yellow-color*) 'yellow)
        ((equal color *dark-green-color*) 'dark-green)
        ((equal color *light-blue-color*) 'light-blue)
        ((equal color *purple-color*) 'purple)
        ((equal color *brown-color*) 'brown)
        ((equal color *light-gray-color*) 'light-gray)
        ((equal color *gray-color*) 'gray)
        ((equal color *dark-gray-color*) 'dark-gray)
        (t (intern (format nil "COLOR-~5,'0d-~5,'0d-~5,'0d" 
                           (color-red color) 
                           (color-green color) 
                           (color-blue color))))))

(defun color-symbol->mac-color (color)
  "this may look like it should do the inverse of the above, but right now
   it doesn't exactly.  If the color isn't one of the default ones then
   the black color is returned.  It's only being used by the UWI right now,
   so it's simplified for that purpose.  Only colors that the systems have
   in 'common' are used - with the Mac names being the default, in keeping
   with the usual bias :) "
  (cond ((equal color 'red) *red-color*)
        ((equal color 'blue) *blue-color*)
        ((equal color 'green) *green-color*)
        ((equal color 'black) *black-color*)
        ((equal color 'white) *white-color*)
        ((equal color 'pink)  *pink-color*)
        ((equal color 'yellow) *yellow-color*)
        ((equal color 'dark-green) *dark-green-color*)
        ((equal color 'light-blue) *light-blue-color*)
        ((equal color 'purple) *purple-color*)
        ((equal color 'brown) *brown-color*)
        ((equal color 'light-gray) *light-gray-color*)
        ((equal color 'gray) *gray-color*)
        ((equal color 'dark-gray) *dark-gray-color*)
        (t *black-color*)))