;;; -*- Mode: LISP; Syntax: Common-Lisp; Package: GARNET-GADGETS; 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. ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;;  Multi-Graphics-Selection:  Selection squares around graphic objects
;;;
;;;  Features and operation of the Multi Graphics Selection object:
;;;    * This is somewhat like the graphics-selection.  The major
;;;      difference is that multiple objects can be selected and
;;;      manipulated by the user, and that the
;;; 	 programmer must use a function to set the :value slot.
;;;      Another difference
;;; 	 is the way that checks whether move and grow is allowed.
;;;      Of course, the multi-graphics-selection supports lots of additional
;;;      features like selecting in a region, undo-ing the move/grow and
;;;      modifying aggregates and polygons.
;;;    1) Given a list of graphical objects, the Multi-Graphics-Selection
;;;        aggregadget will cause selection squares to appear on the
;;;        bounding box of selected objects.
;;;    2)  One or more than one item may be selected at a time.
;;;    3)  A built-in interactor displays the selection squares around an
;;;        object at the time of a specified event (such as clicking a mouse
;;;        button on the object).
;;;    4)  Each selection square allows the user to move or grow the object
;;;        by dragging the selection square.
;;;    5) When a group of objects is selected, special grow handles
;;;        appear at the corners of the whole group for growing all
;;;        the objects.
;;; 
;;; Programmer Interface
;;; ====================
;;;
;;; Create an instance of a GARNET-GADGETS:multi-Graphics-Selection
;;; and supply the
;;; :start-where slot with a valid list that can be passed to an
;;; interactor.  This :start-where must return the items to be selected.
;;; It should be an ...-or-none form, such as :element-of-or-none.  An
;;; example of the parameter to :start-where is:
;;; 		(list :element-of-or-none myagg)
;;;
;;; The :value slot of the GARNET-GADGETS:Graphics-Selection object supplies
;;; the object(s) the user selects.  If :multiple-select-p is NIL
;;; then it is a single object or NIL.  If :multiple-select-p
;;; is T (the default), then will always be a list or NIL (even if
;;; only one object is selected).   Also, a :selection-function can be
;;; supplied and will be called each time the selection changes.  It takes
;;; these parameters: (Gadget New-Selection), where New-selection is the
;;; new value of :value.
;;;
;;; The user can change the size and/or position of the objects by
;;; pressing on the selection handles (see below).  If the
;;; :check-line slot is non-nil, then the :line-p slot in the object returned
;;; by start-where will be g-valued, and if it is non-nil then the interactor
;;; will change the object as a line.  Note that the programmer must set the
;;; :line-p slots of the objects (since often composite objects like arrowlines
;;; will be used, and just asking (is-a-p obj Opal:line) on these will
;;; return false).  Similarly, for polygons, the gadget will check
;;; :polygon-p and for groups (aggregates) it will check :group-p.
;;; The programmer can supply a :modify-function that will
;;; be called after an object is modified.  It takes these
;;; parameters: (gadget selected-object new-points)
;;; The new-points will be a list of 4 numbers, either
;;; left,top,width,height or x1,y1,x2,y2 (even for polygons).
;;; 
;;; The public slots of the Graphics-Selection objects are:
;;;    :start-where - supply a valid start-where here
;;;    :check-line - if T, the objects are checked for their :line-p slot
;;; 			and if that is non-NIL, then move or grown as a line
;;;    :check-polygon - if T, the objects are checked for their :polygon-p slot
;;; 			and if that is non-NIL, then move or grown as a polygon
;;;    :check-group - if T, the objects are checked for their :group-p slot
;;; 			and if that is non-NIL, then the individual components
;;;                     of the group are modified.
;;;    :multiple-select-p - if T, then multiple objects can be
;;;                     selected. Default=NIL
;;;    :running-where - if supplied, then this is the area in which the
;;; 			objects can move and grow
;;;    :active-p - if T, then operates.  If NIL, then none of the
;;;                interactors will work.  Setting to NIL does NOT
;;;                clear selection, however.
;;;    :selection-function - this is called when the selection changes
;;;    :modify-function - this is called when an object is changed size or
;;;                       position
;;;    :input-filter - filter to pass to move-grow (to do gridding, etc.)
;;;    :check-grow-p - If T, then checks in each object to see if :grow-p is T,
;;; 			   and if so, then will grow, else won't.  If NIL, then
;;; 			   everything can grow.  Default NIL.
;;;    :check-move-p - If T, then checks in each object to see if :move-p is T,
;;; 			   and if so, then will move, else won't.  If NIL, then
;;; 			   everything can move.  Default NIL.
;;;    :move-multiple-p - If T, then if multiple items are selected and you
;;; 			press on a move box, then moves all of the objects.
;;; 			If NIL, then just moves the object you point to.
;;; 			Default=T.
;;;    :grow-multiple-p - If T, then if multiple items are selected then
;;;                     grow boxes appear at the corners of the whole
;;;                     selection, and pressing there will grow all
;;;                     the objects.  If NIL, then those handles don't appear.
;;; 			Default=T.
;;;    :want-undo - If T, then saves information (conses) so that can
;;;                 you can call Undo-Last-Move-Grow.
;;;    :report-function - If non-NIL, then calls the function at each
;;;                       object manipulation or edit, in addition to
;;;                       the selection function. :want-undo MUST be T also.
;;;                       See below.
;;;    :allow-component-select - if T, then pressing with CONTROL will select
;;;                     the component under the selected object (see below)
;;;                     Default=NIL.
;;;    :down-to-component-function - supply with a function to get the appropriate
;;;                     component out of the object under the mouse.  This
;;;                     function might call a method in the selected object.
;;;                     Parameters are (lambda obj x y).  Should return the
;;;                     object to be selected, or NIL.
;;;                     Default: Opal:Point-To-Component
;;;    :move-components-p - whether components are allowed to be moved.  Often,
;;;                     even though top-level objects can move, components can't.
;;;                     Therefore, this can be set to NIL which means components
;;;                     can never be moved.  This only works if :check-move-p is
;;;                     T.  Default=NIL.
;;;    :grow-components-p - whether components are allowed to be grown.  Often,
;;;                     even though top-level objects can grow, components can't.
;;;                     Therefore, this can be set to NIL which means components
;;;                     can never be grown.  This only works if :check-grow-p is
;;;                     T.  Default=NIL.
;;; 
;;; SLOTS that can be accessed:
;;;    :value - set with list of the current selections, in reverse order
;;;            the user selected the objects (first selected object is
;;;            last in the list).
;;;            *DO NOT SET*, use the function Set-Selection (see below).
;;;    :current-selected-object - set with new selection before other
;;;                     slots are set.
;;;
;;; Slots of the objects that can be selected are:
;;;    :line-p - this should be T if the object should be moved as a line,
;;; 		and NIL otherwise.
;;;    :polygon-p - this should be T if the object should be moved as
;;;             a polygon, and NIL otherwise.
;;;    :group-p - this should be T if the object should be moved as a group.
;;;    :points - if :line-p is T, then the :points slot of the object is
;;; 	        changed as the object is moved or grown.
;;;    :box - if :line-p is NIL, then the :box slot of the object is
;;; 	        changed as the object is moved or grown.
;;;    :point-list - if :polygon-p is T, then the :point-list slot of
;;;             the object is changed as the object is moved or grown.
;;;    :grow-p - if this object can be changed size
;;;    :move-p - if this object can be moved
;;;
;;; USEFUL FUNCTIONS:
;;; 
;;;    (Garnet-Gadgets:Set-Selection gadget new-selection)
;;; 
;;;      Gadget should be a Multi-Graphics-Selection gadget, and new-selection
;;;      is a list of objects that should be selected, or a single object to be
;;;      selected, or NIL to turn off all selections.  The list passed
;;;      in is not damaged.
;;;
;;;    (Garnet-Gadgets:Undo-Last-Move-Grow gadget)
;;; 
;;;      Gadget should be a Multi-Graphics-Selection gadget.  This
;;;      un-does the last move or grow operation and restores the
;;;      selection.  You have to be careful not to have deleted any
;;;      objects since they were grown.  Returns NIL if successful or
;;;      else an error string.
;;; 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; REPORT-FUNCTIONS are called as
;;;         (lambda (gadget main-op parameter obj oldval newval)
;;;    where main-op is one of
;;;       :select :move :grow
;;;    and if :select, then parameter is one of
;;;       :become-select :toggle-select :clear-select
;;;       :region-select :region-toggle :downlevel-select :downlevel-toggle
;;;       :explicit-select (due to a call to set-selection)
;;;    and if :move or :grow then the parameter is where-hit
;;;    * For the selection operations, the obj will be the object or objects
;;;    affected, the oldval will be the original full selection value before
;;;    the operation, and the newval will be the value afterwards.
;;;    * For move and grow, the obj will be a list of objects
;;;    changed, and the oldval will be a list of the original :box, :points, or
;;;    :point-list values, and newval will be a list of the new ones.
;;; * The lists passed should not be destructively modified by the
;;;   application, but they can be used directly (and not copied)
;;; NOTE THAT THIS OPERATION CONSES A LOT.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; End User Operation
;;; ==================
;;;
;;; The user can press on any object with the left button, and it will
;;; become selected.  Pressing on the background, causes no object to be
;;; selected (the current object becomes de-selected).  Selecting an object
;;; with the left button causes the previous object to be de-selected.
;;; If the application allows multiple selection, then clicking with
;;; shift-left or middle on an object toggles it in the selection set.
;;; Also pressing and dragging out a rectangle selects everything
;;; entirely enclosed (not the object directly under the mouse when started).
;;;
;;; Once an object is selected, it can be grown by pressing with the left
;;; button on one of the black boxes or moved by pressing on a white box.
;;; While moving and growing, if the mouse goes outside of :running-where
;;; or if the ^G key is pressed, the operation aborts.
;;;
;;; If the programmer has set :allow-component-select to T (it is NIL by
;;; default), then by pressing :CONTROL-LEFT over a selected object, that object
;;; will be deselected, and its component will be selected instead.  Similarly,
;;; if CONTROL-MIDDLE or CONTROL-SHIFT-LEFT is hit over a selected object, then
;;; that object is de-selected, and the object underneath is added to the
;;; selection set.
;;; 
;;; Test and debugging routines are at the end of this module.
;;;
;;;  Designed and written by Brad Myers
;;;
#|
============================================================
Change log:
 10-Mar-93 Brad Myers - set-selection functions calls the :selection-function
  1-Mar-93 Andrew Mickish - Removed superfluous quotes from :slots-to-set
 14-Dec-92 Andrew Mickish - Added type and parameter declarations
 20-Nov-92 Andrew Mickish - Removed s-value of :move-p and :grow-p in
                            down-component select function.
 10-Sep-92 Brad Myers - added reporting of the editing operation (for Marquise)
                        if :report-function
 10-Jul-92 Brad Myers - added growing of multiple objects, thanks to
                            algorithm by Vivek Gupta when :grow-multiple-p
                      - added :active-p slot
                      - added "grouped" objects with :group-p
                      - added selection in region
                      - added support for moving polygons if :polygon-p
                      - Undo-Last-Move-Grow if :want-undo

 20-Mar-92 Ed Pervin - eliminate control chars.
  7-Feb-92 Brad Myers - made work with constant formulas (feedback obj not in
                               aggregate)
                      - use new features of interactors
                      - export grid ability for moving/growing
                      - don't set the :selected fields of objects
 29-Jul-91 Brad Myers - Added ability to select the components of the top object
 20-Mar-91 Brad Myers - Fixed so set-selection will work with multiple objs
 13-Jan-91 Brad Myers - Fixed so newly selected object always put
                        at end of list, selection list order is
                        always the same as the order the user
                        selected objects in.
 15-Nov-90 Brad Myers - support multiple selection, modified from
 			graphics selection
============================================================
|#

(in-package "GARNET-GADGETS" :use '("LISP" "KR"))

(export '(Multi-Graphics-Selection Set-Selection Undo-Last-Move-Grow))

;; These are the size of the selection boxes
(defparameter multi-size 7)  ; should be odd
(defparameter multi-sizeD2 (floor multi-size 2))
(defparameter minus-multi-sizeD2 (- multi-sizeD2))
(defparameter minus-multi-size (- multi-size))

;;Use this for the grow boxes that are used for both lines and rectangles
(defparameter grow-vis 
  (o-formula (and (gvl :parent :obj-over)
		  (gvl :parent :show-grow))))

;;Use this for the move boxes that are used for both lines and rectangles
(defparameter move-vis (o-formula (gvl :parent :obj-over)))

;;Use this for the grow boxes that are used only for rectangles 
(defparameter grow-vis-not-line 
  (o-formula (and (gvl :parent :obj-over)
		  (gvl :parent :show-grow)
		  (not (gvl :parent :line-p)))))

;;Use this for the move boxes that are used only for rectangles 
(defparameter move-vis-not-line 
  (o-formula (and (gvl :parent :obj-over)
		  (not (gvl :parent :line-p)))))

(create-instance 'Multi-Grow-Selection-Box opal:rectangle
  ; This type declaration will allow the current :top formulas to return
  ; NIL when the grow boxes are invisible
  :declare (:type ((or null integer) :top))
      (:visible (formula grow-vis-not-line))
      (:width multi-size)
      (:height multi-size)
      (:draw-function :xor)
      (:fast-redraw-p T)
      (:grow-p T)
      (:filling-style opal:black-fill)
      (:line-style NIL))

(create-instance 'Multi-Move-Selection-Box opal:rectangle
  ; This type declaration will allow the current :top formulas to return
  ; NIL when the move boxes are invisible
  :declare (:type ((or null integer) :top))
      (:visible (formula move-vis-not-line))
      (:width multi-size)
      (:height multi-size)
      (:draw-function :xor)
      (:fast-redraw-p T)
      (:grow-p NIL)
      (:filling-style NIL)
      (:line-style Opal:Thin-Line))

;; This one is only used when multiple objects are selected and they
;; can be grown
(create-instance 'special-multi-feedback Opal:aggregadget
  (:visible (o-formula (gvl :parent :special-multi-feedback-vis)))
  (:box (o-formula
	   (let ((obj (gvl :parent :fake-rect)))
	     (if obj
		 (let ((left (gv obj :left))
		       (top (gv obj :top))
		       (width (gv obj :width))
		       (height (gv obj :height)))
		   (list (- left multi-sizeD2) ;first
			 (- top multi-sizeD2)  ;second
			 (+ left width minus-multi-sizeD2 -1) ;right, third
			 (+ top height minus-multi-sizeD2 -1))) ;bottom, fourth
		 ;; else no obj-over
		 (list 0 0 0 0)))))
  (:parts `((:nw-grow ,Multi-Grow-Selection-Box
	     (:visible ,(o-formula (gvl :parent :visible)))
	     (:left ,(o-formula (first (gv (kr-path 0 :parent) :box))))
	     (:top ,(o-formula (second (gv (kr-path 0 :parent) :box))))
	     (:where-attach :nw))
	    (:ne-grow ,Multi-Grow-Selection-Box
	     (:visible ,(o-formula (gvl :parent :visible)))
	     (:left ,(o-formula (third (gv (kr-path 0 :parent) :box))))
	     (:top ,(o-formula (second (gv (kr-path 0 :parent) :box))))
	     (:where-attach :ne))
	    (:se-grow ,Multi-Grow-Selection-Box
	     (:visible ,(o-formula (gvl :parent :visible)))
	     (:left ,(o-formula (third (gv (kr-path 0 :parent) :box))))
	     (:top ,(o-formula (fourth (gv (kr-path 0 :parent) :box))))
	     (:where-attach :se))
	    (:sw-grow ,Multi-Grow-Selection-Box
	     (:visible ,(o-formula (gvl :parent :visible)))
	     (:left ,(o-formula (first (gv (kr-path 0 :parent) :box))))
	     (:top ,(o-formula (fourth (gv (kr-path 0 :parent) :box))))
	     (:where-attach :sw)))))

(create-instance 'sel-selection-feedback Opal:Aggregadget
    (:obj-over NIL) ; set by interactor
    (:show-grow (o-formula (and (gvl :parent :parent :grow-ok)
				(if (gvl :parent :parent :check-grow-p)
				    ; then do whatever the object says
				    (gvl :obj-over :grow-p)
				    T))))   ; else always show growable
    (:line-p (o-formula (and (gvl :parent :parent :check-line)
			     (gvl :obj-over :line-p))))
    (:box (o-formula 
	   (let ((obj (gvl :obj-over)))
	     (if obj
	       (if (gvl :line-p)
		 (list (- (gv obj :x1) multi-sizeD2)
		       (- (gv obj :y1) multi-sizeD2)
		       (- (gv obj :x2) multi-sizeD2)
		       (- (gv obj :y2) multi-sizeD2))
		 ;; else not a line-p
		 (let ((left (gv obj :left)) ; get M1 and M2 also
		       (top (gv obj :top))
		       (width (gv obj :width))
		       (height (gv obj :height)))
		   (list (- left multi-sizeD2) ;first
			 (- top multi-sizeD2)  ;second
			 (+ width multi-size)  ;third
			 (+ height multi-size) ;fourth
			 
			 (+ left (floor width 3) minus-multi-sizeD2)   ;M1 left, 5
			 (+ left (floor (+ width width) 3)	       ;M2 left, 6
			    minus-multi-sizeD2)
			 (+ left width minus-multi-sizeD2 -1)          ;right,   7
			 (+ top (floor height 3) minus-multi-sizeD2)   ;M1top,   8
			 (+ top (floor (+ height height) 3)	       ;m2 top,  9
			    minus-multi-sizeD2)
			 (+ top height minus-multi-sizeD2 -1))))    ;bottom, 10
	       ;; else no obj-over
	       (list 0 0 0 0)))))
    (:visible (o-formula (gvl :obj-over)))
    (:parts `((:nw-grow ,Multi-Grow-Selection-Box
		  (:left ,(o-formula (first (gv (kr-path 0 :parent) :box))))
		  (:top ,(o-formula (second (gv (kr-path 0 :parent) :box))))
		  (:visible ,(formula grow-vis))
		  (:where-attach ,(o-formula (if (gv (kr-path 0 :parent) :line-p)
						 1 :nw))))
	      (:n-move ,Multi-Move-Selection-Box
		       ;; This box is at the M1 if normal, at the left if not move,
		       ;; or at the center if a line!
		  (:left ,(o-formula
			   (let ((box (gv (kr-path 0 :parent) :box)))
			     (if (gv (kr-path 0 :parent) :line-p) ; then center
				 (+ (first box)
				    (floor (- (third box) (first box)) 2))
				 ; else if grow-p then m1 else left
				 (if (gv (kr-path 0 :parent) :show-grow)
				     (fifth box) (first box))))))
		  (:top ,(o-formula
			  (let ((box (gv (kr-path 0 :parent) :box)))
			    (if (gv (kr-path 0 :parent) :line-p) ; then center
				(+ (second box)
				   (floor (- (fourth box) (second box)) 2))
				; else at top
				(second box)))))
		  (:visible ,(formula move-vis))
		  (:where-attach ,(o-formula
				   (if (gv (kr-path 0 :parent) :line-p) ; then center
				       :center :where-hit))))
	      (:n-grow ,Multi-Grow-Selection-Box
		  (:left ,(o-formula (sixth (gv (kr-path 0 :parent) :box)))) ; m2left
		  (:top ,(o-formula (second (gv (kr-path 0 :parent) :box)))) ;top
		  (:where-attach :n))
	      (:ne-grow ,Multi-Grow-Selection-Box
		  (:left ,(o-formula (seventh (gv (kr-path 0 :parent) :box))))
		  (:top ,(o-formula (second (gv (kr-path 0 :parent) :box))))
		  (:where-attach :ne))
	      (:e-move ,Multi-Move-Selection-Box
		  (:left ,(o-formula (seventh (gv (kr-path 0 :parent) :box))))
		       ;; This box is at the M1 if normal, at the top if not move
		  (:top ,(o-formula
			   (let ((box (gv (kr-path 0 :parent) :box)))
			     (if (gv (kr-path 0 :parent) :show-grow)
				 (eighth box) (second box)))))
		  (:where-attach :where-hit))
	      (:e-grow ,Multi-Grow-Selection-Box
		  (:left ,(o-formula (seventh (gv (kr-path 0 :parent) :box))))
		  (:top ,(o-formula (ninth (gv (kr-path 0 :parent) :box)))) ;m2top
		  (:where-attach :e))
	      (:se-grow ,Multi-Grow-Selection-Box  ; use this one for lines also
		  (:left ,(o-formula (if (gv (kr-path 0 :parent) :line-p)
					 (third (gv (kr-path 0 :parent) :box))
					 (seventh (gv (kr-path 0 :parent) :box)))))
		  (:top ,(o-formula (if (gv (kr-path 0 :parent) :line-p)
					 (fourth (gv (kr-path 0 :parent) :box))
					 (tenth (gv (kr-path 0 :parent) :box)))))
		  (:visible ,(formula grow-vis))
		  (:where-attach ,(o-formula (if (gv (kr-path 0 :parent) :line-p)
						 2 :se))))
	      (:s-grow ,Multi-Grow-Selection-Box
		  (:left ,(o-formula (sixth (gv (kr-path 0 :parent) :box)))) ;m2left
		  (:top ,(o-formula (tenth (gv (kr-path 0 :parent) :box)))) ;bottom
		  (:where-attach :s))
	      (:s-move ,Multi-Move-Selection-Box
		       ;; This box is at the M1 if normal, at the right if not move
		  (:left ,(o-formula
			   (let ((box (gv (kr-path 0 :parent) :box)))
			     (if (gv (kr-path 0 :parent) :show-grow)
				 (fifth box) (seventh box)))))
		  (:top ,(o-formula (tenth (gv (kr-path 0 :parent) :box)))) ;bottom
		  (:where-attach :where-hit))
	      (:sw-grow ,Multi-Grow-Selection-Box
		  (:left ,(o-formula (first (gv (kr-path 0 :parent) :box)))) ;left
		  (:top ,(o-formula (tenth (gv (kr-path 0 :parent) :box)))) ;bottom
		  (:where-attach :sw))
	      (:w-grow ,Multi-Grow-Selection-Box
		  (:left ,(o-formula (first (gv (kr-path 0 :parent) :box)))) ;left
		  (:top ,(o-formula (ninth (gv (kr-path 0 :parent) :box)))) ;m2top
		  (:where-attach :w))
	      (:w-move ,Multi-Move-Selection-Box
		  (:left ,(o-formula (first (gv (kr-path 0 :parent) :box)))) ;left
		       ;; This box is at the M1 if normal, at the bottom if not move
		  (:top ,(o-formula
			   (let ((box (gv (kr-path 0 :parent) :box)))
			     (if (gv (kr-path 0 :parent) :show-grow)
				 (eighth box) (tenth box)))))
		  (:where-attach :where-hit)))))  
  
(create-instance 'multi-sel-line-movegrow-feedback Opal:Line
   (:obj-over NIL)
   (:points (list 0 0 10 10))  ; some initial values (x1 y1 x2 y2)
   (:visible (o-formula (gvl :obj-over)))
   (:x1 (o-formula (first (gvl :points))))
   (:y1 (o-formula (second (gvl :points))))
   (:x2 (o-formula (third (gvl :points))))
   (:y2 (o-formula (fourth (gvl :points))))
   (:draw-function :xor)
   (:fast-redraw-p T)
   (:line-style opal:dashed-line))

(create-instance 'multi-sel-rect-movegrow-feedback opal:rectangle
   (:obj-over NIL)
   (:box '(80 20 100 150))
   (:visible (o-formula (gvl :obj-over)))
   (:left (o-formula (first (gvl :box))))
   (:top (o-formula (second (gvl :box))))
   (:width (o-formula (third (gvl :box))))
   (:height (o-formula (fourth (gvl :box))))
   (:draw-function :xor)
   (:fast-redraw-p T)
   (:line-style opal:dashed-line)
   (:filling-style NIL))

;; The new-selection should be a single object or a list of object that
;; should be selected, or NIL for there to be no selection.
(defun Set-Selection (gadget new-selection)
  "Call this to change which objects are selected."
  (let ((want-report (g-value gadget :report-function)))
    (unless (listp new-selection) ; so can pass in a single object
      (setq new-selection (list new-selection)))
    (when want-report
      (Call-Report-Function-Select want-report NIL :explicit gadget
				   NIL new-selection))
    (Internal-Set-Selection gadget new-selection)
    (kr-send gadget :selection-function gadget new-selection)))

;;; Doesn't call report-function, and new-selection must be a list
(defun Internal-Set-Selection (gadget new-selection)
  (let ((selinter (g-value gadget :select-it))
	(old-selection (g-value gadget :value)))
    (when (g-value gadget :multiple-select-p)
      (s-value selinter :start-char :middle-down)) ;; *HACK to make sure that
					;; how-set set correctly so selectobj
                                        ;; will allow multiple selections
    ;; first remove any objects that should not be selected
    (dolist (oldsel old-selection)
      (unless (member oldsel new-selection)
	(inter:DeSelectObj selinter oldsel)))
    ;; now add any objects that weren't selected
    (dolist (newsel new-selection)
      (unless (member newsel old-selection)
	(inter:SelectObj selinter newsel)))
    (s-value gadget :value new-selection)
    ;; sometimes :value is same list so doesn't notice
    (mark-as-changed gadget :value)
    ;; when multiple objects selected, keep fake rect up to date
    (when (> (length (g-value gadget :value)) 1)
      (Multi-Set-Rect-Multiple gadget))))

;; Find the bounding box of all the selected objects, and set it into the
;; fake rectangle.  Return the rectangle
(defun Multi-Set-Rect-Multiple (gadget)
  (let ((rect (g-value gadget :fake-rect))
	(minleft 9999)
	(mintop 9999)
	(maxright -9999)
	(maxbottom -9999)
	(check-move (g-value gadget :check-move-p))
	(check-grow (and (g-value gadget :grow-multiple-p)
			 (g-value gadget :check-grow-p)))
	one-moveable one-growable left top)
    (dolist (obj (g-value gadget :value))
      (when (and check-move (g-value obj :move-p))
	(setq one-moveable T))
      (when (and check-grow (g-value obj :grow-p))
	(setq one-growable T))
      (setq minleft (MIN minleft (setq left (g-value obj :left))))
      (setq mintop (MIN mintop (setq top (g-value obj :top))))
      (setq maxright (MAX maxright (+ left (g-value obj :width))))
      (setq maxbottom (MAX maxbottom (+ top (g-value obj :height)))))
    (s-value rect :orig-left minleft) ; used to compute the offsets
    (s-value rect :left minleft)
    (s-value rect :orig-top mintop)   ; used to compute the offsets
    (s-value rect :top mintop)
    (s-value rect :orig-width (- maxright minleft))
    (s-value rect :width (- maxright minleft))
    (s-value rect :orig-height (- maxbottom mintop))
    (s-value rect :height (- maxbottom mintop))
    (s-value rect :move-p (if check-move one-moveable T)) ; when check move,
					;  then ok when any can move
    (s-value rect :grow-p one-growable)
    rect))
  
;;; Get the new position from the fake rectangle, and move all the selected
;;; objects by the correct amount
(defun Multi-Adjust-all-objects (gadget)
  (let* ((rect (g-value gadget :fake-rect))
	 (box (g-value rect :box))
	 (offsetx (- (first box) (g-value rect :orig-left)))
	 (offsety (- (second box) (g-value rect :orig-top)))
	 (check-line (g-value gadget :check-line))
	 (check-group (g-value gadget :check-group))
	 (check-polygon (g-value gadget :check-polygon))
	 (check-ok-move (g-value gadget :check-move-p)))
    (dolist (obj (g-value gadget :value))
      (when (or (null check-ok-move) 
		(g-value obj :move-p))
	(cond ((or (and check-group (g-value obj :group-p))
		   (and check-polygon (g-value obj :polygon-p)))
	       (s-value obj :box (List (+ offsetx (g-value obj :left))
				       (+ offsety (g-value obj :top))
				       (g-value obj :width)
				       (g-value obj :height)))
	       (Move-Grow-Adjust-One-Object gadget obj NIL))

	      ((and check-line (g-value obj :line-p))
	       ;; then set both end-points, so will move
	       (incf (first (g-value obj :points)) offsetx)
	       (incf (second (g-value obj :points)) offsety)
	       (incf (third (g-value obj :points)) offsetx)
	       (incf (fourth (g-value obj :points)) offsety)
	       (mark-as-changed obj :points))
	      (T;; else move as a box
	       (incf (first (g-value obj :box)) offsetx)
	       (incf (second (g-value obj :box)) offsety)
	       (mark-as-changed obj :box)))))
    (Multi-Set-Rect-Multiple gadget)))


	
;; opal:point-to-component is a macro, so need to have a function so
;; can funcall it.
(defun point-to-comp (obj x y)
  (opal:point-to-component obj x y))

;; custom WHERE method that returns the component object under the
;; selected object, if any, else returns NIL.  Also sets the currently
;; selected object into the :deselect-this-obj slot of the interactor
(defun Multi-Select-Get-Child (gadget inter event)
  (let ((selected-objs (g-value gadget :value))
	(x (inter:event-x event))
	(y (inter:event-y event))
	in-obj)
    (when (eq (g-value gadget :window) ; first check if windows are equal
	      (inter:event-window event))
      (if (listp selected-objs)
	  (dolist (obj selected-objs)
	    (when (opal:point-in-gob obj x y)
	      (setq in-obj obj)
	      (return)))
	  ; else not a list
	  (when (opal:point-in-gob selected-objs x y)
	      (setq in-obj selected-objs)))
      ;; here have object point is in, or NIL
      (when in-obj
	(let ((method (g-value gadget :down-to-component-function))
	      obj)
	  (setq obj (funcall method in-obj x y))
	  (s-value inter :deselect-this-obj in-obj)
	  obj)))))

(create-instance 'Multi-Graphics-Selection opal:aggregadget
  :declare ((:parameters :active-p :start-where :running-where
			 :check-line :check-polygon :check-group
			 :check-move-p :check-grow-p :move-multiple-p
			 :grow-multiple-p :input-filter :want-undo
			 :multiple-select-p :allow-component-select
			 :down-to-component-function :modify-function
			 :selection-function)
	    (:type (kr-boolean :active-p :check-line :check-polygon
		    :check-group :check-move-p :check-grow-p :move-multiple-p
		    :grow-multiple-p :want-undo :multiple-select-p
		    :allow-component-select)
		   ((or list (member T)) :start-where :running-where)
		   ((or null function symbol)
		    :selection-function :modify-function)
		   ((or function symbol) :down-to-component-function)
		   ((or list integer function symbol) :input-filter)))
		  
     ;; programmer-settable slots
     (:start-where NIL) ;; supply a valid start-where here
     (:running-where T) ;; if supplied, then this is the area in which the
			;; objects can move and grow
     (:selection-function NIL) ;; this is called when the selection changes
     (:modify-function NIL) ;; called when an object is changed size or position
     (:input-filter NIL)   ;; default is no gridding
     (:check-line T)       ;; whether to check for :line-p in objects
     (:check-group T)      ;; where to check for :group-p in objects
     (:check-polygon T)    ;; where to check for :polygon-p in objects
     (:check-grow-p NIL)   ;; whether check for :grow-p in object
     (:check-move-p NIL)   ;; whether check for :move-p in object
     (:move-multiple-p T)  ;; whether move multiple as a group
     (:grow-multiple-p T)  ;; whether grow multiple as a group

     (:want-undo NIL)      ;; whether want to save copies for undo
     (:report-function NIL);; if want to find out what happens,
			   ;; :want-undo must be T for :report-function to work
     
     (:active-p T)         ;; whether this is operational or not

     (:multiple-select-p T) ;;if T, then multiple objects can be selected.

     (:allow-component-select NIL) ; set to T if can "push" selection to a child
     (:down-to-component-function #'Point-To-Comp)
     (:move-components-p NIL) ; whether components are allowed to move
     (:grow-components-p NIL) ; and grow.  Only valid if :check-grow-p
			      ; or :check-move-p

     ;; slots the programmer can access
     (:current-selected-object NIL) ; set with new selection or object to be moved
				    ; or grown before other slots are set.
     (:value NIL)  ;;current object or objects selected **DO NOT SET**

     ;; internal slots

     (:grow-ok (o-formula  ; ok to grow if only one selection
		(if (gvl :multiple-select-p)    
		    (<= (length (gvl :value)) 1)
		    T)))
     (:is-line (o-formula (and (gvl :check-line)
			       (gvl :current-selected-object)
			       (gvl :current-selected-object :line-p))))
     (:cur-movegrow-feedback (o-formula (if (gvl :is-line)
					    (gvl :line-movegrow-feedback)
					    (gvl :rect-movegrow-feedback))))
     (:using-fake-rectangle ; this is T when moving or growing multiple objects
      (o-formula (and (or (gvl :move-multiple-p)(gvl :grow-multiple-p))
		      (> (length (gvl :value)) 1))))
     (:special-multi-feedback-vis (o-formula (and (gvl :using-fake-rectangle)
						  (gvl :fake-rect :grow-p))))

     (:save-list-for-undo NIL) ; maintained if want undo

     ;;; selection-boxes can't be part of the aggregadget since the
     ;;; interactor will make instances of it, so create it in the interactor
     (:parts `((:selection-boxes ,opal:aggregate) ; added explicitly
	       (:special-multi-feedback ,special-multi-feedback)
	       (:line-movegrow-feedback ,multi-sel-line-movegrow-feedback)
	       (:rect-movegrow-feedback ,multi-sel-rect-movegrow-feedback)
	       ;; fake-rect is used to get the bounding box of all the
	       ;; selected objects, so the move-grow interactor will have
	       ;; something to operate on
	       (:fake-rect ,opal:rectangle (:visible NIL)
			   (:grow-p T) 
			   (:move-p T))))
     (:interactors
      `((:select-it ,inter:button-interactor
	 (:window ,(o-formula (gv-local :self :operates-on :window)))
	 (:start-event (:leftdown :shift-leftdown :middledown))
	 (:slots-to-set (:gg-interim-selected :gg-selected :gg-selected))
	 (:continuous T)
	 (:running-where T)
	 (:active ,(o-formula (gvl :operates-on :active-p)))
	 (:start-where ,(o-formula (gvl :operates-on :start-where)))

	 (:how-set ,(o-formula (if (gvl :operates-on :multiple-select-p)
				   (if (eq (gvl :start-char) :leftdown)
				       :set :list-toggle)
				   :set)))
	 (:final-feedback-obj NIL)
	 (:do-start
	  ,#'(lambda(inter obj event)
	       ;;; have to create it explicitly the first time because
	       ;;; if part of aggregadget then complains because not constant!
	       (unless (g-value inter :final-feedback-obj)
		 (let ((gadget (g-value inter :operates-on))
		       sel)
		   (setq sel (create-instance NIL sel-selection-feedback))
		   (opal:add-component (g-value gadget :selection-boxes)
				       sel)
		   (s-value inter :final-feedback-obj sel)))
	       (call-prototype-method inter obj event)))
	 (:final-function
	  ,#'(lambda (inter objUnderMouse)
	       (let* ((oper (g-value inter :operates-on))
		      (newval (g-value inter :main-aggregate :gg-selected))
		      (newval-l (if (listp newval)
				    newval
				    (list newval)))
		      (want-report (g-value oper :report-function)))
		 (s-value oper :current-selected-object objUnderMouse)
		 (when want-report
		   (Call-Report-Function-Select want-report
						(g-value inter :start-char)
						:click oper
						objUnderMouse newval-l))
		 (s-value oper :value newval-l)
		 ;; sometimes :value is same list so doesn't notice
		 (mark-as-changed oper :value)
		 ;; when multiple objects selected, keep fake rect up to date
		 (when (g-value oper :using-fake-rectangle)
		   (Multi-Set-Rect-Multiple oper))
		 (kr-send oper :selection-function oper
			  (g-value oper :value))))))
	;; DESIGN: When the left button goes down, both the :select-it
	;; and :select-in-region interactors start.  If the
	;; :select-in-region interactor gets a large enough area, then
	;; it aborts the :select-it interactor.
	(:select-in-region ,inter:two-point-interactor
	 (:window ,(o-formula (gv-local :self :operates-on :window)))
	 (:start-event (:leftdown :shift-leftdown :middledown))
	 (:continuous T)
	 (:start-where ,(o-formula (list :in (gvl :operates-on :window))))
	 (:abort-if-too-small T)
	 (:active ,(o-formula (gvl :operates-on :active-p)))
	 (:outside NIL)
	 (:running-where T)
	 (:min-width 10)
	 (:min-height 10)
	 (:line-p NIL)
	 (:feedback-obj ,(o-formula (gvl :operates-on
					 :rect-movegrow-feedback)))
	 (:aborted-select-it NIL) ;; set when abort :select-it
	 (:running-action
	  ,#'(lambda (inter new-points)
	       (when (and new-points
			  (null (g-value inter :aborted-select-it)))
		 ;; then got a big enough area, so abort other
		 (s-value inter :aborted-select-it T)
		 (s-value inter :abort-if-too-small NIL) ;going small
					;now doesn't count
		 (inter:abort-interactor
		  (g-value inter :operates-on :select-it)))
	       (call-prototype-method inter new-points)))
	 (:final-function
	  ,#'(lambda (inter final-points)
	       (s-value inter :aborted-select-it NIL)
	       (s-value inter :abort-if-too-small T)
	       (when final-points
		 ;; then was big enough area
		 (let ((oper (g-value inter :operates-on)))
		   (Select-All-Objs-In-Area oper final-points
					    (g-value inter :start-char))
		   (kr-send oper :selection-function oper
			    (g-value oper :value))))))
	 (:abort-action ,#'(lambda (inter)
			     (s-value inter :aborted-select-it NIL)
			     (s-value inter :abort-if-too-small T)
			     (call-prototype-method inter))))
	(:down-level-select-it ,inter:button-interactor
	 (:window ,(o-formula (gv-local :self :operates-on :window)))
	 (:active ,(o-formula (and (gvl :operates-on :active-p)
				   (gv-local :self :operates-on
					     :allow-component-select))))
	 (:start-event (:control-leftdown :control-shift-leftdown
					  :control-middledown))
	 (:continuous NIL)
	 (:slots-to-set (:gg-interim-selected :gg-selected :gg-selected))
	 (:start-where ,(o-formula (list :custom
					 (gvl :operates-on)
					 'Multi-Select-Get-Child)))
	 (:how-set ,(o-formula (if (gvl :operates-on :multiple-select-p)
				   (if (eq (gvl :start-char) :control-leftdown)
				       :set :list-toggle)
				   :set)))
	 (:final-function
	  ,#'(lambda (inter objUnderMouse)
	       (let* ((oper (g-value inter :operates-on))
		      (objToUnSelect (g-value inter :deselect-this-obj))
		      (how-set (g-value inter :how-set))
		      (want-report (g-value oper :report-function))
		      new-selection)
		 (if (eq :set how-set)
		     (setq new-selection (list objUnderMouse))
		     ;; else needs to be a list
		     (setq new-selection
			   (cons objUnderMouse
			      (remove objToUnSelect (g-value oper :value)))))
		 (when want-report
		   (Call-Report-Function-Select want-report
						(g-value inter :start-char)
						:down-level oper objToUnSelect
						new-selection))
;		 (unless (g-value oper :grow-components-p)
;		   (s-value objUnderMouse :grow-p NIL))
;		 (unless (g-value oper :move-components-p)
;		   (s-value objUnderMouse :move-p NIL))
		 (Internal-Set-Selection oper new-selection)
		 ;; when multiple objects selected, keep fake rect up to date
		 (when (g-value oper :using-fake-rectangle)
		   (Multi-Set-Rect-Multiple oper))
		 (kr-send oper :selection-function oper new-selection)))))

	(:move-grow-it ,inter:Move-Grow-Interactor
	 (:window ,(o-formula (gv-local :self :operates-on :window)))
	 (:active ,(o-formula (and (gvl :operates-on :value)
				   (gvl :operates-on :active-p))))
	 (:continuous T)
	 (:waiting-priority ,inter:high-priority-level)
	 (:input-filter ,(o-formula (gvl :operates-on :input-filter)))
	 (:abort-event (:control-g :control-\g))
	 (:start-where ,(o-formula
			 (list :list-leaf-element-of 
			       (gvl :operates-on :select-it)
			       :final-feed-inuse)))
	 (:running-where ,(o-formula (gvl :operates-on :running-where)))
	 (:outside NIL)
	 (:feedback-obj ,(o-formula (gvl :operates-on :cur-movegrow-feedback)))
	 ;; change the object that the selection boxes are attached to
	 (:using-fake-rectangle ; this is T when moving multiple objects
	  ,(o-formula (gvl :operates-on :using-fake-rectangle)))
	 (:obj-to-change 
	  ,(o-formula (let ((oper (gvl :operates-on)))
			(if (gvl :using-fake-rectangle)
			    (gv oper :fake-rect)
			    ;;otherwise use the obj under the selection handles
			    (gvl :first-obj-over :parent :obj-over)))))

	 ;; the various attachpoints are stored in a slot in each selection
	 ;; box and the box is returned set into the :first-obj-over slot of
	 ;; the interactor
	 (:attach-point ,(o-formula (if (gvl :using-fake-rectangle)
					:where-hit ; then always use :where-hit
					(gvl :first-obj-over :where-attach))))
	 (:grow-p ,(o-formula (if (gvl :using-fake-rectangle)
				  NIL ; then always move 
				  (gvl :first-obj-over :grow-p))))
	 (:line-p ,(o-formula (if (gvl :using-fake-rectangle)
				  NIL ; then not a line
				  (gvl :first-obj-over :parent :line-p))))
	 
	 ;; have a special start-action to check to see if it is OK to
	 ;; start, and if not, then beep and abort.  
	 (:start-action
	  ,#'(lambda (inter obj-being-changed first-points)
	       ;; obj-being-changed object underneath
	       (let ((oper (g-value inter :operates-on)))
		 ;; first, make sure have saved info for poly's or groups
		 (Set-Old-In-Poly-or-Group oper (g-value oper :value))
		 (s-value oper :current-selected-object obj-being-changed)
		 (if (if (g-value inter :grow-p)
			 (if (g-value oper :check-grow-p)
			     (g-value obj-being-changed :grow-p)
			     T)
			 (if (g-value oper :check-move-p)
			     (g-value obj-being-changed :move-p)
			     T))
		     ;; then OK to move or grow it
		     (progn
		       (Save-Selection-For-Undo oper)
		       (Save-Selection-For-Report-Before-M-G oper)
		       (call-prototype-method inter obj-being-changed
					      first-points))
		     ;; else not OK, so abort
		     (progn (inter::beep)
			    (Inter:Abort-Interactor inter))))))
	 ;; check if fake-rect, then do all objects,
	 ;; call the modify method, if any.
	 (:final-function
	  ,#'(lambda(inter objUnderMouse newsize)
	       (let* ((oper (g-value inter :operates-on))
		      (want-report (g-value oper :report-function)))
		 (if (eq objUnderMouse (g-value oper :fake-rect))
		     (progn
		       (Multi-Adjust-all-objects oper)
		       (kr-send oper :modify-function
				oper (g-value oper :value)
				newsize))
		     (let ((obj (g-value oper :current-selected-object)))
		       (Move-Grow-Adjust-One-Object oper obj
						    (g-value inter :grow-p))
		       (kr-send oper :modify-function oper obj newsize)))
		 (when want-report
		   (Call-Report-Function-MoveGrow oper (g-value inter :grow-p)
						  (g-value inter :attach-point)
						  want-report))))))
	;;; just used to grow multiple objects
	(:grow-multiple ,inter:Move-Grow-Interactor
	 (:window ,(o-formula (gv-local :self :operates-on :window)))
	 (:active ,(o-formula (and (gvl :operates-on :active-p)
				   (gvl :operates-on
					:special-multi-feedback-vis))))
	 (:continuous T)
	 ;; needs to be higher than "high", since move-grow-it is "high"
	 (:waiting-priority ,inter:running-priority-level)
	 (:input-filter ,(o-formula (gvl :operates-on :input-filter)))
	 (:abort-event (:control-g :control-\g))
	 (:start-where ,(o-formula
			 (list :leaf-element-of 
			       (gvl :operates-on :special-multi-feedback))))
	 (:running-where ,(o-formula (gvl :operates-on :running-where)))
	 (:outside NIL)
	 (:feedback-obj ,(o-formula (gvl :operates-on
					 :rect-movegrow-feedback)))
	 (:obj-to-change ,(o-formula (gvl :operates-on :fake-rect)))
	 ;; the various attachpoints are stored in a slot in each selection
	 ;; box and the box is returned set into the :first-obj-over slot of
	 ;; the interactor
	 (:attach-point ,(o-formula (gvl :first-obj-over :where-attach)))
	 (:grow-p T)
	 (:line-p NIL)
	 ;; check if fake-rect, then do all objects,
	 ;; call the modify method, if any.
	 (:start-action
	  ,#'(lambda (inter obj-being-changed first-points)
	       (let ((oper (g-value inter :operates-on)))
		 (Save-Selection-For-Undo oper)
		 (Save-Selection-For-Report-Before-M-G oper)
		 (call-prototype-method inter obj-being-changed
					first-points))))
	 (:final-function
	  ,#'(lambda(inter objUnderMouse newsize)
	       (declare (ignore objUnderMouse))
	       (let* ((oper (g-value inter :operates-on))
		      (want-report (g-value oper :report-function)))
		 (Multi-Adjust-all-objects-Grow oper)
		 (when want-report
		   (Call-Report-Function-MoveGrow oper T
						  (g-value inter :attach-point)
						  want-report))
		 (kr-send oper :modify-function oper (g-value oper :value)
			  newsize))))))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Report-Function Stuff
;;;   called as (lambda (gadget main-op param obj oldval newval)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; must be called BEFORE the selection gadget is set and ONLY when
;; want a report
(defun Call-Report-Function-Select (report-func button type gadget obj newval)
  (let ((parameter (ecase type
		     (:explicit :explicit-select)
		     (:region (if (eq :leftdown button)
				  :region-select
				  :region-toggle))
		     (:click (if (eq :leftdown button)
				 (if (eq obj :none)
				     :clear-select
				     :become-select)
				 :toggle-select))
		     (:down-level (if (eq :leftdown button)
				      :downlevel-select
				      :downlevel-toggle)))))
    (funcall report-func gadget :select parameter obj
	     (copy-list (g-value gadget :value))
	     (copy-list newval))))


;;; Assign into the gadget's slot :report-func-old-vals a copy of the
;;; selected objects current :box, :points or whatever, so can be
;;; reported after the move.
(defun Save-Selection-For-Report-Before-M-G (gadget)
  (when (g-value gadget :report-function)
    (s-value gadget :report-func-old-vals
	     (Get-Cur-Pos-Desc (g-value gadget :value) gadget))))

(defun Get-Cur-Pos-Desc (obj-list gadget)
  (let (cur-vals box)
    (dolist (obj obj-list)
      (cond ((and (g-value gadget :check-polygon)
		  (g-value obj :polygon-p))
	     (push (copy-list (g-value obj :point-list)) cur-vals))
	    ((and (g-value gadget :check-line)
		  (g-value obj :line-p))
	     (push (copy-list (g-value obj :points)) cur-vals))
	    (T (setq box (g-value obj :box))
	       (if box (setq box (copy-list box))
		   ;; else might be NIL if newly created group
		   (setq box (list (g-value obj :left)
				 (g-value obj :top)
				 (g-value obj :width)
				 (g-value obj :height))))
	       (push box cur-vals))))
    (nreverse cur-vals)))

(defun Call-Report-Function-MoveGrow (gadget grow-p attach-point report-func)
  (let* ((sel-list (g-value gadget :value))
	 (old-vals (g-value gadget :report-func-old-vals))
	 (new-vals (Get-Cur-Pos-Desc sel-list gadget)))
    (funcall report-func gadget (if grow-p :grow :move) attach-point
	     sel-list old-vals new-vals)
    (s-value gadget :report-func-old-vals NIL)))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; If the object is a box or line, it has been handled automatically
;;; by the interactor, but if it is a group or a polygon, then some
;;; extra work is needed. 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;; The :*orig slots are set just before the move or grow starts (as
;; the start action of the move-grow-it interactor).  Not needed for
;; the group interactor, since that one uses the fake rect's box and
;; left and new and old.

(defun Move-Grow-Adjust-One-Object (gadget obj growing)
  (let ((check-group (g-value gadget :check-group))
	(check-polygon (g-value gadget :check-polygon)))
    (cond ((and check-group (g-value obj :group-p))
	   (adjust-all-items-of-group-size obj (g-value obj :box)
					   (g-value obj :*orig-left)
					   (g-value obj :*orig-top)
					   (g-value obj :*orig-width)
					   (g-value obj :*orig-height)
					   (g-value gadget :check-line)
					   check-polygon
					   (and (g-value gadget :check-grow-p)
						growing)))
	  ((and check-polygon (g-value obj :polygon-p))
	   (polyline-correction-fun obj (g-value obj :box)
				    (g-value obj :*orig-left)
				    (g-value obj :*orig-top)
				    (g-value obj :*orig-width)
				    (g-value obj :*orig-height)
				    (and (g-value gadget :check-grow-p)
						growing))))
    (Multi-Set-Rect-Multiple gadget)))

;; For polygons and groups, need to save old :box, so can determine how to
;; modify when moved or grown.  This is called when start growing or moving.
(defun Set-Old-In-Poly-or-Group (gadget sel-list)
  (let ((check-group (g-value gadget :check-group))
	(check-polygon (g-value gadget :check-polygon)))
    (internal-Set-Old-In-Poly-or-Group
     (if (listp sel-list) sel-list (list sel-list))
     check-group check-polygon)))

(defun Internal-Set-Old-In-Poly-or-Group (obj-list check-group check-polygon)
  (let (group-p)
    (dolist (obj obj-list)
      (when (or (setq group-p (and check-group (g-value obj :group-p)))
		(and check-polygon (g-value obj :polygon-p)))
	(s-value obj :*orig-left (g-value obj :left))
	(s-value obj :*orig-top (g-value obj :top))
	(s-value obj :*orig-width (g-value obj :width))
	(s-value obj :*orig-height (g-value obj :height)))
      (when group-p
	(internal-Set-Old-In-Poly-or-Group (g-value obj :components)
					   check-group check-polygon)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; The next set of functions are to allow growing of multiple objects
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;;; grow all the objects that are selected
;;; This should only be called when it is OK to move and grow multiple objects.
(defun Multi-Adjust-all-objects-Grow (gadget)
  (let* ((rect (g-value gadget :fake-rect))
	 (new-points (g-value rect :box))
	 (check-line (g-value gadget :check-line))
	 (check-group (g-value gadget :check-group))
	 (check-polygon (g-value gadget :check-polygon))
	 (check-ok-grow (g-value gadget :check-grow-p))
	 )
    (internal-modifyfun-group (g-value gadget :value)
			      new-points
			      (g-value rect :orig-left)
			      (g-value rect :orig-top)
			      (g-value rect :orig-width)
			      (g-value rect :orig-height)
			      check-line check-group check-polygon
			      check-ok-grow)
    (Multi-Set-Rect-Multiple gadget)))

;;; Main internal function for growing a collection of selected objects
(defun internal-modifyfun-group (selected-objects new-points
				 old-left old-top old-width old-height
				 check-line check-group check-polygon
				 check-ok-grow)

  ;; first, make sure width and height are greater than 2
  (when (< (third new-points) 2)
      (setf (third new-points) 2))
  (when (< (fourth new-points) 2)
      (setf (fourth new-points) 2))
  
  ;; now adjust all objects in group
  (dolist (main-item selected-objects)
    (adjust-one-item-size main-item new-points
			  old-left old-top old-width old-height check-line
			  check-group check-polygon check-ok-grow)))

(defun adjust-one-item-size (one-item new-points
			     old-left old-top old-width old-height
			     check-line check-group check-polygon
			     check-ok-grow)
  (cond ((and check-group (g-value one-item :group-p))
	 (adjust-all-items-of-group-size one-item new-points old-left
					 old-top old-width old-height
					 check-line check-polygon
					 check-ok-grow))
	((and check-line (g-value one-item :line-p))
	 (line-correction-fun one-item new-points old-left old-top
			      old-width old-height check-ok-grow)) 
	((and check-polygon (g-value one-item :polygon-p))
	 (polyline-correction-fun one-item new-points old-left old-top
				  old-width old-height check-ok-grow)) 
	(T (box-correction-fun one-item new-points old-left old-top
			       old-width old-height check-ok-grow)))) 


(defun adjust-all-items-of-group-size (group-item new-points old-left
				       old-top old-width old-height
				       check-line check-polygon check-ok-grow)
  (dolist (one-item (g-value group-item :components))
    (adjust-one-item-size one-item new-points
			  old-left old-top old-width old-height
			  check-line T check-polygon check-ok-grow)))

;;; allocates a new list which is the current points modified by the
;;; difference between the group's new-points and the old-points
(defun calculate-new-box (orig-l orig-t orig-w orig-h new-points
			  old-left old-top old-width old-height ok-grow)
  (list (round (+ (+ (* (/ (third new-points)
			   old-width)
			(- orig-l
			   old-left))
		     old-left)
		  (- (first new-points)
		     old-left)))
	     
	(round (+ (+ (* (/ (fourth new-points)
			   old-height)
			(- orig-t
			   old-top))
		     old-top)
		  (- (second new-points)
		     old-top)))
	     
	(if ok-grow
	    (round (* (/ (third new-points)
			 old-width)
		      orig-w))
	    old-width)
	    
  
	(if ok-grow
	    (round (* (/ (fourth new-points)
			 old-height)
		      orig-h))
	    old-height)))


;; Calculates the new pointlist for a polygon by destructively
;; modifying the current-points list.  Better have an even number of entries!
(defun calculate-new-pointlist (current-points old-left new-left old-top
			        new-top width-ratio height-ratio)
  (let (newx newy)
    (do* ((l current-points (nthcdr 2 l))
	  (old-x (first l)(first l))
	  (old-y (second l)(second l))
	  (cnt 0 (+ 2 cnt)))
	 ((null l))
      (setq newx (round (+ (+ (* (- old-x
				    old-left)
				 width-ratio)
			      old-left)
			   (- new-left old-left))))
      (setq newy (round (+ (+ (* (- old-y
				    old-top)
				 height-ratio)
			      old-top)
			   (- new-top old-top))))
      (setf (first l) newx)
      (setf (second l) newy))
    current-points))
      
(defun polyline-correction-fun (poly-obj new-points old-left old-top
					 old-width old-height check-ok-grow)
  (let* ((growp (if check-ok-grow (g-value poly-obj :grow-p) T))
	 (widthratio (if growp (/ (third new-points) old-width)
			 1))
	 (heightratio (if growp (/ (fourth new-points) old-height)
			 1))
	 (new-pointlist (calculate-new-pointlist
			(g-value poly-obj :point-list)
			old-left
			(first new-points)
			old-top
			(second new-points)
			widthratio
			heightratio)))			
    (s-value poly-obj :point-list new-pointlist)
    (mark-as-changed poly-obj :point-list)))

(defun line-correction-fun (current-line new-points old-left old-top
					 old-width old-height check-ok-grow)
  (let* ((growp (if check-ok-grow (g-value current-line :grow-p) T))
	 (newbox (calculate-new-box (g-value current-line :x1)
				    (g-value current-line :y1)
				     (- (g-value current-line :x2)
					(g-value current-line :x1))
				     (- (g-value current-line :y2)
					(g-value current-line :y1))
				     new-points
				     old-left old-top old-width old-height
				     growp))
	 (newx2 (+ (first newbox) (third newbox)))
	 (newy2 (+ (second newbox) (fourth newbox))))
    (s-value current-line :points
	     (list (first newbox) (second newbox) newx2 newy2))))

(defun box-correction-fun (obj new-points old-left old-top old-width
			       old-height check-ok-grow)
  (let* ((growp (if check-ok-grow (g-value obj :grow-p) T))
	 (newbox (calculate-new-box (g-value obj :left)
				    (g-value obj :top)
				    (g-value obj :width)
				    (g-value obj :height)
				    new-points old-left old-top
				    old-width old-height growp)))
    (s-value obj :box newbox)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Functions to support Undo
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

#|
The :save-list-for-undo slot of the gadget will contain
   (  (list of all selected objects)
     ((obj1 old-vals)
      (obj2 old-vals)
     )
   )
|#

;;; Call this right before each move or grow.
(defun Save-Selection-For-Undo (gadget)
  (when (g-value gadget :want-undo)
    (let ((sel-list (g-value gadget :value))
	  (check-group (g-value gadget :check-group))
	  (check-polygon (g-value gadget :check-polygon))
	  (check-line (g-value gadget :check-line)))
      (s-value gadget :save-list-for-undo
	       (list (copy-list sel-list)
		     (Internal-Save-Selection-For-Undo
		      (if (listp sel-list) sel-list (list sel-list))
		      check-group check-polygon check-line))))))

(defun Internal-Save-Selection-For-Undo (sel-list check-group check-polygon
						  check-line)
  (let (new-undo-list)
    (dolist (obj sel-list)
      (cond ((and check-group (g-value obj :group-p))
	     ;; put all sub objects onto the list.  Add group AFTER its objects
	     (setq new-undo-list (nconc (Internal-Save-Selection-For-Undo
					 (g-value obj :components)
					 check-group check-polygon
					 check-line)
					(list (list obj))
					new-undo-list)))
	    ((and check-polygon (g-value obj :polygon-p))
	     (push (list obj (copy-list (g-value obj :point-list)))
		   new-undo-list))
	    ((and check-line (g-value obj :line-p))
	     (push (list obj (copy-list (g-value obj :points)))
		   new-undo-list))
	    (T (push (list obj (copy-list (g-value obj :box)))
		     new-undo-list))))
    new-undo-list))

;;; First do some error checking, if fails, return a helpful? string,
;;; so NIL means everything was successful.  Call update after this to
;;; see results.
(defun Undo-Last-Move-Grow (gadget)
  (let ((undo-list (g-value gadget :save-list-for-undo)))
    ;; now check and do.
    (cond ((not (g-value gadget :want-undo))
	   "Selection Gadget was not configured to save Undo Information")
	  ((or (null undo-list)
	       (null (car undo-list)))
	   "Nothing saved to undo")
	  ((dolist (o (cadr undo-list))
	     (unless (schema-p (car o))
	       (return (format NIL
			"Object ~s saved on undo list but now not an object"
			(car o))))))
	  (T
	   ;; first, set up to undo the undo (toggle)
	   (let ((sel-list (car undo-list))
		 (check-group (g-value gadget :check-group))
		 (check-polygon (g-value gadget :check-polygon))
		 (check-line (g-value gadget :check-line)))
	     (s-value gadget :save-list-for-undo
		      (list sel-list
			    (Internal-Save-Selection-For-Undo sel-list
				  check-group check-polygon check-line)))
	     (Internal-Restore-Undo-List (cadr undo-list) check-group
					 check-polygon check-line)
	     (Internal-Set-Selection gadget sel-list)
	     (kr-send gadget :selection-function gadget sel-list)
	     NIL)))))

(defun Internal-Restore-Undo-List (undo-list check-group check-polygon
					     check-line)
  (dolist (desc undo-list)
    (let ((obj (car desc))
	  (vals (cadr desc)))
      (cond ((and check-group (g-value obj :group-p))
	     ;; all of its objects should be restored already, so :left
	     ;; etc. should be fine, so can g-value them to get :*orig
	     (s-value obj :*orig-left (g-value obj :left))
	     (s-value obj :*orig-top (g-value obj :top))
	     (s-value obj :*orig-width (g-value obj :width))
	     (s-value obj :*orig-height (g-value obj :height)))

	    ((and check-polygon (g-value obj :polygon-p))
	     (s-value obj :point-list vals)
	     (s-value obj :*orig-left (g-value obj :left))
	     (s-value obj :*orig-top (g-value obj :top))
	     (s-value obj :*orig-width (g-value obj :width))
	     (s-value obj :*orig-height (g-value obj :height)))
	  
	    ((and check-line (g-value obj :line-p))
	     (s-value obj :points vals))

	    (T (s-value obj :box vals))))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Selecting objects in an area
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun Select-All-Objs-In-Area (gadget final-points button)
  (let ((start-where (g-value gadget :start-where))
	(want-report (g-value gadget :report-function))
	objs-in-rect newval)
    (setq objs-in-rect (Returns-objs-in-rect start-where final-points
					     (g-value gadget :window)))
    (if (eq button :leftdown)
	(setq newval objs-in-rect)
	;; else toggle the objects in the rectangle with the selection
	(let ((old-selection (g-value gadget :value)))
	  (setq newval (set-exclusive-or objs-in-rect old-selection))))
    (when want-report
      (Call-Report-Function-Select want-report button :region gadget
				   NIL newval)) 
    (Internal-Set-Selection gadget newval)))

;; used for
;;   :list-element-of
;;   :list-element-of-or-none
;;   :list-check-leaf-but-return-element-or-none
;;   :list-check-leaf-but-return-element
(defun list-element-of-branch (agg slot type win left top right bottom)
  (let ((lst (g-value agg slot))
	objs-inside)
    (dolist (i lst)
      (when (and (inter::checkobjtype i type)
		 (eq (g-value i :window) win)
		 (opal:obj-in-rectangle i top left bottom right :type type
					:INTERSECT NIL)
		 )
	(push i objs-inside)))
    objs-inside))

;; used for
;;   :list-leaf-element-of
;;   :list-leaf-element-of-or-none
(defun list-leaf-element-of-branch (agg slot type win left top right bottom)
  (let ((lst (g-value agg slot))
	objs-inside)
    (dolist (i lst)
      (when
	  (and (eq (g-value i :window) win)
	       (if (is-a-p i opal:aggregate)
		   ;; if aggregate, then if point-to-leaf
		   (setq objs-inside
			 (nconc objs-inside
				(opal:leaf-objects-in-rectangle
				 i top left bottom right :type type
				 :INTERSECT NIL)))
		   ;; if not aggregate, then if inside
		   (when (and (inter::checkobjtype i type)
			      (opal:obj-in-rectangle i top left bottom right
						     :type type
						     :INTERSECT NIL))
		     (push i objs-inside))))))
    objs-inside))

(defun Returns-objs-in-rect (where rect win)
  (let* ((left (first rect))
	 (top (second rect))
	 (right (+ left (third rect) -1))
	 (bottom (+ top (fourth rect) -1))
	 result)
    (setq result
      (cond ((eq t where) NIL)
	    ((null where) NIL)
	    ((listp where)
	     (let ((control (first where))
		   (agg (second where))
		   ;; T as type => everything
		   (type (or (inter::GetNextItem :type where) T))
		   objwin slot)
	       (unless (schema-p agg)
		 (error "obj ~s not valid" agg))
	       (setf objwin (and agg (g-value agg :window)))
	       (if (or (eq control :list-element-of)
		       (eq control :list-leaf-element-of)
		       (eq control :list-check-leaf-but-return-element)
		       (eq control :list-element-of-or-none)
		       (eq control :list-leaf-element-of-or-none)
		       (eq control :list-check-leaf-but-return-element-or-none)
		       )
		; If a list, then objects might be in different
  	        ; windows, so do test inside the case statement.
		; If Custom, let the user's procedure do the test.
		   (setf slot (third where))
		   ;; else check if window of object eq window of event
		   (unless (eq win objwin) ; otherwise test here
		      (return-from Returns-objs-in-rect NIL)))
	       (case control
		 (:custom 
		  (error "Custom not valid start-where for multi-selection"))
		 ((:check-leaf-but-return-element
		   :check-leaf-but-return-element-or-none
		   :element-of
		   :element-of-or-none)
		  (opal:components-in-rectangle agg top left bottom right
						:type type
						:INTERSECT NIL))
		 ((:list-element-of
		   :list-element-of-or-none
		   :list-check-leaf-but-return-element-or-none
		   :list-check-leaf-but-return-element)
		  (list-element-of-branch agg slot type win left top
					  right bottom))
		 ((:list-leaf-element-of
		   :list-leaf-element-of-or-none
		   )
                  (list-leaf-element-of-branch agg slot type win left top
					       right bottom))
		 ((:leaf-element-of-or-none
		   :leaf-element-of)
		  (opal:leaf-objects-in-rectangle agg top left bottom right
						  :type type :INTERSECT NIL))
		 ((:in-box
		   :in
		   :in-but-not-on)
		  (when (opal:obj-in-rectangle agg top left bottom right
					       :type type :INTERSECT NIL)
		    (list agg)))

		 (t (error "** illegal where control: ~s" where)))))
	  (t (error "** illegal where control: ~s" where))))
    result))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Debugging Functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

#+garnet-debug (export '(Multi-Graphics-Selection-Go
			 Multi-Graphics-Selection-Obj
			 Multi-Graphics-Selection-Stop))
#+garnet-debug (defparameter Multi-Graphics-Selection-Win NIL)
#+garnet-debug
(defun Multi-Graphics-Selection-Stop ()
  (opal:destroy Multi-Graphics-Selection-Win))

#+garnet-debug
(defun Multi-Graphics-Selection-Go ()
  (let (agg l l2)
  (setq Multi-Graphics-Selection-Win
	(create-instance NIL inter:interactor-window
	  (:title "Multi Graphics Selection Test")
	  (:aggregate
	   (create-instance 'Multi-Graphics-Selection-Agg opal:aggregate))))
  (setq l (list
	   (create-instance NIL opal:rectangle (:box (list 40 50 60 70))
			    (:grow-p T)
			    (:left (o-formula (first (gvl :box))))
			    (:top (o-formula (second (gvl :box))))
			    (:width (o-formula (third (gvl :box))))
			    (:height (o-formula (fourth (gvl :box)))))
	   (create-instance NIL opal:circle (:box (list 250 20 30 30))
			    (:grow-p T)
			    (:filling-style opal:green-fill)
			    (:left (o-formula (first (gvl :box))))
			    (:top (o-formula (second (gvl :box))))
			    (:width (o-formula (third (gvl :box))))
			    (:height (o-formula (fourth (gvl :box)))))
	   (create-instance NIL opal:text (:box (list 200 150))
			    (:grow-p NIL) (:string "Move me")
			    (:left (o-formula (first (gvl :box))))
			    (:top (o-formula (second (gvl :box)))))
	   (create-instance NIL opal:line (:points (list 10 50 300 200))
			    (:grow-p T)
			    (:line-p T)
			    (:line-style opal:line-2)
			    (:X1 (o-formula (first (gvl :points))))
			    (:y1 (o-formula (second (gvl :points))))
			    (:x2 (o-formula (third (gvl :points))))
			    (:y2 (o-formula (fourth (gvl :points)))))
	   (create-instance NIL opal:polyline
	     (:grow-p T)
	     (:POINT-LIST (list 70 90 70 240 120 170 160 230 160 90 70 90 ))
	     (:polygon-p T)
	     (:line-style opal:blue-line))
	   (setq agg (create-instance NIL opal:aggregate
		       (:grow-p T)
		       (:group-p T)))))
  (setq l2 (list
	   (create-instance NIL opal:rectangle (:box (list 120 120 30 30))
			    (:grow-p T)
			    (:filling-style opal:red-fill)
			    (:left (o-formula (first (gvl :box))))
			    (:top (o-formula (second (gvl :box))))
			    (:width (o-formula (third (gvl :box))))
			    (:height (o-formula (fourth (gvl :box)))))
	   (create-instance NIL opal:text (:box (list 100 150))
			    (:line-style Opal:red-line)
			    (:grow-p NIL) (:string "In Group")
			    (:left (o-formula (first (gvl :box))))
			    (:top (o-formula (second (gvl :box)))))
	   (create-instance NIL opal:circle (:box (list 100 100 10 10))
			    (:grow-p T)
			    (:filling-style opal:red-fill)
			    (:left (o-formula (first (gvl :box))))
			    (:top (o-formula (second (gvl :box))))
			    (:width (o-formula (third (gvl :box))))
			    (:height (o-formula (fourth (gvl :box)))))
	   (create-instance NIL opal:line (:points (list 100 100 160 150))
			    (:grow-p T)
			    (:line-p T)
			    (:line-style opal:red-line)
			    (:X1 (o-formula (first (gvl :points))))
			    (:y1 (o-formula (second (gvl :points))))
			    (:x2 (o-formula (third (gvl :points))))
			    (:y2 (o-formula (fourth (gvl :points)))))
	   (create-instance NIL opal:polyline
	     (:grow-p T)
	     (:POINT-LIST (list 100 100 100 170 120 120 150 170 190 140
			    140 120 200 100 140 110 100 100))
	     (:polygon-p T)
	     (:line-style opal:red-line))))
  (dolist (o l2)
    (opal:add-component agg o))
  (dolist (o l)
    (opal:add-component Multi-Graphics-Selection-Agg o))
  (s-value Multi-Graphics-Selection-Agg :list-of-objs (append l2 l))
  (create-instance 'Multi-Graphics-Selection-Obj Multi-Graphics-Selection
    (:check-line T)
    (:check-group T)
    (:check-polygon T)
    (:check-grow-p T)
    (:want-undo T)
    (:start-where `(:list-element-of-or-none
		    ,Multi-Graphics-Selection-Agg :list-of-objs))
    (:selection-function #'(lambda (gadget new-sel)
			     (declare (ignore gadget))
			     (format T "new selection is ~s~%" new-sel)))
    (:modify-function #'(lambda (gadget obj new-val)
			  (declare (ignore gadget))
			  (format T "* size for ~s now ~s~%" obj new-val)))
    )

  (create-instance 'Multi-Graphics-Selection-Undo-Inter inter:button-interactor
    (:start-where T)
    (:window Multi-Graphics-Selection-Win)
    (:start-event '(#\u :control-\u))
    (:continuous NIL)
    (:final-function #'(lambda (inter val)
			 (declare (ignore inter val))
			 (Undo-Last-Move-Grow Multi-Graphics-Selection-Obj))))
  
  (opal:add-components Multi-Graphics-Selection-Agg
		       Multi-Graphics-Selection-Obj)
  (opal:update Multi-Graphics-Selection-Win)
  (format T "Click with mouse to select.  Point to square to move/grow.
Hit 'u' to undo last move or grow.")
  ))

#|

If s-value the width of one of the objects when multiple selected,
doesn't change multi-grow boxes position

Allow objects in multiple windows and drag among them.
|#
