;;; -*- 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. ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;  Polyline-Creator - a gadget to let the user enter a poly-line
;;;
;;;  User Interface:
;;;     1) User presses a button to start the interaction.  Each subsequent
;;;        button press causes a new segment to be added to the line.
;;;     2) Feedback is provided to the user.
;;;     3) Poly-Line stops when either:
;;; 		- the new point is close enough to the first point of the
;;;               polyline (in which case the polyline is closed)
;;; 		- the button pressed is different from the start event
;;;     4) The application might arrange that some other action (e.g. changing
;;;        the drawing mode using a palette) will stop or abort the polyline
;;;     5) Polylines can be edited by calling the (toggle-polyline-handles)
;;;        function.
;;;
;;;  Programmer Interface:
;;;     Customizable slots:
;;;       1) :selection-function - put a function here to be called with the
;;;          final point-list.  This function will typically create a new
;;;          poly-line using a COPY of the point-list (do not use the
;;;          point-list directly).  It is called with:
;;; 	       (lambda (gadget new-point-list)
;;; 	  2) :start-event - the event to start the whole process on,
;;; 	     default=:leftdown)
;;;       3) :start-where - where the mouse should be when the start-event
;;;          happens
;;;       4) :running-where - where run.  Default = T
;;;       5) :close-enough-value - how close (in pixels) the event needs to be
;;;          to	the first event to close the poly-line.  Default=3
;;;       6) :value - set by the gadget with the final point-list (do not set
;;;          this)
;;;       7) :active-p - whether you can use it or not
;;;
;;;       The following slots are for using the editor
;;;       8) :mover-start-event - which event starts moving a point
;;;       9) :mover-stop-event - which event stops moving a point
;;;      10) :adder-start-event - which event adds a point
;;;      11) :deleter-start-event - which event deletes a point
;;;      12) :threshold - how close to a line you have to click to add a point
;;;
;;;   Functions:
;;;      (Stop-Polyline-Creator gadget) - causes the gadget to create the
;;;          current object.  Ignores the current mouse position.
;;;          Useful if some other gadget (such as a palette changing
;;;          the drawing mode) wants to stop the gadget.  You can call
;;;          this even if the gadget is not operating. 
;;;      (Abort-Polyline-Creator gadget) - aborts the gadget without creating
;;;          the polyline.
;;;      (Toggle-Polyline-Handles gadget a-polyline) - turns on/off handles that
;;;          allow a-polyline to be edited.
;;;
;;;  Designed and written by Brad Myers
#|
============================================================
Change log:
        10/18/93  Andrew Mickish - Moved export list here from
                  polyline-functions.lisp
         7/13/93  Andrew Mickish - Show-Polyline-Handles ---> Toggle-P-H;
                  Printed out name of new polyline when created; Clarified
                  instructions.
         6/30/93  Rajan Parthasarathy - Renamed a function, added some comments
         6/17/93  Rajan Parthasarathy - Added polyline editing
        12/14/92  Andrew Mickish - Added type and parameter declarations
	  6/4/92  Brad Myers - Added input-filter like two-point-interactor;
                               Added #+garnet-debug switches.
	 3/20/92  Ed Pervin - Eliminated control chars completely.
	 1/28/92  Ed Pervin - Must have # before '(lambda and changed
 			      #\control-\g to :control-\g for CMUCL
        11/21/91  Andrew Mickish - Added :active-p
	 8/01/90  Brad Myers - created
============================================================
|#

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

(export '(Polyline-Creator Stop-Polyline-Creator Abort-Polyline-Creator
          Toggle-Polyline-Handles Destroy-Polyline-Handles
          Hide-Polyline-Handles))

#+garnet-debug
(export '(Polyline-Creator-demo-go Polyline-Creator-demo-stop))

(defun close-enough (point1 point2 close-enough-value)
  (and (<= (abs (- (car point1)(car point2))) close-enough-value)
       (<= (abs (- (cadr point1)(cadr point2))) close-enough-value)))

;;;You can call this to stop a running Polyline-Creator gadget and to use the points
;;; accumulated so far (but not the current cursor point) 
(defun Stop-Polyline-Creator (polyline-creator-gadget)
  (let ((feed-poly (g-value polyline-creator-gadget :feedback-polyline)))
    (inter:abort-interactor (g-value polyline-creator-gadget :first-inter))
    (when (g-value feed-poly :visible)
      ; then is running
      (s-value polyline-creator-gadget :value (g-value feed-poly :point-list))
      (kr-send polyline-creator-gadget :selection-function polyline-creator-gadget
	       (g-value feed-poly :point-list))
      (s-value feed-poly :visible NIL)
      (inter:abort-interactor (g-value polyline-creator-gadget :other-inter)))))

;; throw away the points so far
(defun Abort-Polyline-Creator (polyline-creator-gadget)
  (s-value (g-value polyline-creator-gadget :feedback-polyline) :visible NIL)
  (inter:abort-interactor (g-value polyline-creator-gadget :first-inter))
  (inter:abort-interactor (g-value polyline-creator-gadget :other-inter)))

    
(create-instance 'Polyline-Creator opal:aggregadget
  :declare ((:parameters :start-where :start-event :running-where
			 :close-enough-value :input-filter :selection-function)
	    (:type ((or list (member T)) :start-where :running-where)
		   ((or keyword character list) :start-event)
		   ((integer 0) :close-enough-value)
		   ((or list integer function symbol) :input-filter)
		   ((or null function symbol) :selection-function)))
  
  ;; user settable slots
  (:selection-function NIL) ; called when have full poly-line
  (:modify-function NIL) ; called when a polyline point is modified
  (:start-event :leftdown)
  (:start-where NIL)
  (:running-where T)
  (:close-enough-value 3)
  (:active-p T)
  (:input-filter NIL) ; described in twopoint-interactor
  
  ;; The following are slots to edit the polyline.
  
  (:mover-start-event :leftdown)         ; event to start mover
  (:mover-stop-event :leftup)            ; event to stop mover
  (:adder-start-event :leftdown)         ; event to start adder
  (:deleter-start-event :middledown)     ; event to start deleter
  (:threshold 3)                         ; how close to line to add a point
   
  ;; return value
  (:value NIL) ; set with final point list
  
  ;; internal slots
  (:first-point NIL) ; set with the initial point

  ;; this slot keeps track of polyline handles.  in order not to recreate
  ;; handles for each polyline, we keep only one set of handles.  when you
  ;; start editing a polyline, the handles are taken from storage, the :left
  ;; and :top slots are set appropriately, and the handles are put in the
  ;; :polyline-handles-being-used slot.
  ;;
  ;; when you are done editing a polyline, the handles from :p-h-b-used
  ;; will be copied back into the :stored-polyline-handles.  
  (:stored-polyline-handles NIL)
  (:polyline-handles-being-used NIL)

  ;; this contains the polyline that's being edited NOW, if any.
  (:polyline-being-edited NIL)

  ;; this is the destroy method
  (:destroy-me #'destroy-polyline-handles)
  (:parts `((:feedback-polyline ,opal:polyline
	     (:visible NIL)
	     (:point-list NIL)
	     (:draw-function :xor)
	     (:fast-redraw-p T)
	     (:line-style ,opal:dashed-line))
	    (:feedback-line ,opal:line
	     (:points '(0 0 0 0))
	     (:x1 ,(o-formula (first (gvl :points))))
	     (:y1 ,(o-formula (second (gvl :points))))
	     (:x2 ,(o-formula (third (gvl :points))))
	     (:y2 ,(o-formula (fourth (gvl :points))))
	     (:visible NIL)
	     (:draw-function :xor)
	     (:fast-redraw-p T)
	     (:line-style ,opal:dashed-line))))
  (:interactors
   `((:first-inter ,inter:two-point-interactor
      (:window ,(o-formula (gv-local :self :operates-on :window)))
      (:active ,(o-formula (and (gvl :window)
				(gvl :operates-on :active-p)
				(NOT (gvl :operates-on :polyline-being-edited)))))
      (:continuous T)
      (:start-event ,(o-formula (gvl :operates-on :start-event)))
      (:stop-event :any-mousedown)
      (:start-where ,(o-formula (gvl :operates-on :start-where)))
      (:running-where ,(o-formula (gvl :operates-on :running-where)))
      (:input-filter ,(o-formula (gvl :operates-on :input-filter)))
      (:line-p T)
      (:feedback-obj ,(o-formula (gvl :operates-on :feedback-line)))
      (:final-function 
       ,#'(lambda (inter point-list)
	    (let ((feed-poly (g-value inter :operates-on :feedback-polyline)))
	      (s-value feed-poly :point-list (copy-list point-list))
	      (s-value feed-poly :visible T)
	      (s-value (g-value inter :operates-on) :first-point
		       (list (car point-list) (cadr point-list)))
	      (s-value feed-poly :visible T)
	      (inter:start-interactor (g-value inter :operates-on
					       :other-inter))))))
     (:other-inter ,inter:two-point-interactor
      (:window ,(o-formula (gv-local :self :operates-on :window)))
      (:start-where T)
      (:continuous T)
      (:line-p T)
      (:feedback-obj ,(o-formula (gvl :operates-on :feedback-line)))
      (:input-filter ,(o-formula (gvl :operates-on :input-filter)))
      (:start-event NIL)
      (:running-where ,(o-formula (gvl :operates-on :running-where)))
      (:stop-event :any-mousedown)
      (:final-function 
       ,#'(lambda (inter point-list)
	    (let* ((obj (g-value inter :operates-on))
		   (feed-poly (g-value obj :feedback-polyline))
		   (first-point (g-value obj :first-point))
		   (new-point (list (third point-list)(fourth point-list)))
		   (close-enough-p (close-enough first-point new-point
						 (g-value obj :close-enough-value))))
	      ;; add in this point to object
	      (when close-enough-p ; use first-point instead of new point
		(setq new-point (copy-list first-point)))
	      (s-value feed-poly :point-list 
		       (nconc (g-value feed-poly :point-list) new-point))
	      (mark-as-changed feed-poly :point-list)
	      
	      ;; check whether quit or not
	      (if (or (not (eq (inter:event-char inter:*Current-event*)
			       (g-value obj :start-event)))
		      close-enough-p)
					; then stop
		  (progn
		    ;; if double click, make sure last two pts are not
		    ;; same!
		    (let* ((pts (copy-list (g-value feed-poly :point-list)))
			   (last (1- (length pts))))
		      (when (AND (eq (nth last pts)
				     (nth (- last 2) pts))
				 (eq (nth (1- last) pts)
				     (nth (- last 3) pts)))
			(s-value feed-poly :point-list
				 (subseq pts 0 (1- last)))))

				 
		    (s-value obj :value (g-value feed-poly :point-list))
		    (kr-send obj :selection-function obj
			     (g-value feed-poly :point-list))
		    (s-value feed-poly :visible NIL))
					; else go on
		  (inter:start-interactor inter))))))  ; restart me

     ;; This is the inter that turns editing off if there's a click outside
     (:outside-click-inter ,inter:button-interactor
      (:polyline-creator ,(o-formula (gvl :operates-on)))
      (:start-where ,(o-formula (list :in (gvl :polyline-creator :window))))
      (:start-event :any-mousedown)
      (:window ,(o-formula (gvl :operates-on :window)))
      (:continuous NIL)
      (:final-function ,#'(lambda(inter obj)
			    (declare (ignore obj))
			    (when (g-value inter :operates-on :polyline-being-edited)
			      (gg::hide-polyline-handles (g-value inter :operates-on))
			      (when (eq
				     (inter:event-char inter:*current-event*)
				     (g-value inter :operates-on :first-inter :start-event))
				(inter:start-interactor
				 (g-value inter :operates-on :first-inter)))))))
     
     ;; This is the interactor that MOVES the polyline stuff
     (:mover-feedback-obj ,polyline-mover-feedback)
     (:polyline-point-mover ,polyline-point-moving-inter
      (:active ,(o-formula (gvl :operates-on :polyline-being-edited)))
      (:input-filter ,(o-formula (gvl :operates-on :input-filter)))
      (:polyline-creator ,(o-formula (gvl :operates-on)))
      (:start-event ,(o-formula (gvl :operates-on :mover-start-event)))
      (:stop-event ,(o-formula (gvl :operates-on :mover-stop-event)))
      (:feedback-obj ,(o-formula (gvl :operates-on :mover-feedback-obj))))

     ;; This is the interactor that DELETES the points
     (:polyline-point-deleter ,polyline-point-deleting-inter
      (:active ,(o-formula (gvl :operates-on :polyline-being-edited)))
      (:start-event ,(o-formula (gvl :operates-on :deleter-start-event)))
      (:polyline-creator ,(o-formula (gvl :operates-on))))
     
     ;; This is the interactor that ADDS points
     (:polyline-point-adder ,polyline-point-adding-inter
      (:active ,(o-formula (gvl :operates-on :polyline-being-edited)))
      (:start-event ,(o-formula (gvl :operates-on :adder-start-event)))
      (:threshold ,(o-formula (gvl :operates-on :threshold)))
      (:polyline-creator ,(o-formula (gvl :operates-on))))
     
     )))

;;; from here down is the test program.

#+garnet-debug
(defparameter multi-fill-val 3)

#+garnet-debug
(defun Polyline-Creator-Demo-go ()
  (create-instance 'polyline-creator-win inter:interactor-window
	   (:aggregate (create-instance 'polyline-creator-agg opal:aggregate)))
				       
  (opal:update polyline-creator-win)

  (opal:add-component polyline-creator-agg 
	(create-instance 'Polyline-Creator-Obj Garnet-Gadgets:Polyline-Creator
		 (:start-where `(:in ,polyline-creator-win))
		 (:deleter-start-event :double-leftdown)
		 (:selection-function
		  #'(lambda (gadget new-points)
		     (declare (ignore gadget))
		     (let ((new-polyline
			    (create-instance NIL opal:polyline
				  (:point-list (copy-list new-points))
				  (:filling-style (case multi-fill-val
						    (0 opal:no-fill)
						    (1 opal:black-fill)
						    (2 opal:white-fill)
						    (3 opal:light-gray-fill)
						    (4 opal:gray-fill)
						    (T opal:dark-gray-fill)))
				  (:line-style opal:line-2))))
		       (opal:add-component polyline-creator-agg new-polyline)
		       (incf multi-fill-val)
		       (when (>= multi-fill-val 6) (setq multi-fill-val 0))
		       (format T "Created new polyline ~S~%" new-polyline)
		       )))))
  ;; This is the interactor that STARTS editing the polyline
  (create-instance 'edit-polyline-inter inter:button-interactor
    (:operates-on polyline-creator-obj)
    (:active T)
    (:start-where (list :element-of polyline-creator-agg))
    (:window polyline-creator-win)
    (:start-event :control-\r)
    (:continuous NIL)
    (:final-function #'(lambda(inter obj)
			 (toggle-polyline-handles (g-value inter :operates-on) obj))))
    
    

  (create-instance 'stop-abort-multi inter:button-interactor
	 (:continuous NIL)
	 (:start-where `(:in ,polyline-creator-win))
	 (:window polyline-creator-win)
	 (:start-event :any-keyboard :except :control-\r)
	 (:waiting-priority inter:running-priority-level)
	 (:final-function
	  #'(lambda (inter obj)
	     (declare (ignore obj))
	     (if (eq (g-value inter :start-char) :control-\g)
	       (Garnet-Gadgets:Abort-Polyline-Creator Polyline-Creator-Obj))
	     (if (eq (g-value inter :start-char) #\f)
	       (Garnet-Gadgets:Stop-Polyline-Creator Polyline-Creator-Obj)))))

  
  (format T "~%   Press with the left mouse button to start creating a polyline.~%")
  (format T "Each press adds a segment.  Pressing with a different mouse button~%")
  (format T "immediately finishes the polyline.  You can also finish the polyline~%")
  (format T "by clicking the left mouse button near the start point.  ^G aborts~%")
  (format T "the current object, and typing f finishes the polyline from the last~%")
  (format T "point clicked with the mouse.~%~%")

  (format T "   To edit a new polyline, put the pointer over the polyline and~%")
  (format T "type ^R.  Selection handles will appear, which you can drag.  Pressing~%")
  (format T "the left mouse button on a line segment will create a new point.~%~%")

  polyline-creator-win)

#+garnet-debug
(defun Polyline-Creator-Demo-Stop ()
  (opal:destroy polyline-creator-win))
