;;; -*- 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
;;;
;;;  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
;;;
;;;   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.
;;;
;;;  Designed and written by Brad Myers
#|
============================================================
Change log:
	 6/4/92  Brad Myers - added input-filter like two-point-interactor
                              added #+garnet-debug switches
	 3/20/92  Ed Pervin - eliminate control chars completely.
	 1/28/92  Ed Pervin - Must have # before '(lambda and
 			 change #\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))

#+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
    ;; user settable slots
    (:selection-function NIL) ; called when have full poly-line
    (:start-event :leftdown)
    (:start-where NIL)
    (:running-where T)
    (:close-enough-value 3)
    (:active-p T)
    (:input-filter NIL) ; described in twopoint-interactor

    ;; return value
    (:value NIL) ; set with final point list

    ;; internal slots
    (:first-point NIL) ; set with the initial point

    (: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))))
	    (: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
			  (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

;;; 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:add-component polyline-creator-agg 
	(create-instance 'Polyline-Creator-Obj Garnet-Gadgets:Polyline-Creator
		 (:start-where `(:in ,polyline-creator-win))
		 (:selection-function
		  #'(lambda (gadget new-points)
		     (declare (ignore gadget))
		     (format T "New points ~s~%" new-points)
		     (opal:add-component polyline-creator-agg
			 (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)))
		     (incf multi-fill-val)
		     (when (>= multi-fill-val 6) (setq multi-fill-val 0))))))
  (create-instance 'stop-abort-multi inter:button-interactor
	 (:continuous NIL)
	 (:start-where `(:in ,polyline-creator-win))
	 (:window polyline-creator-win)
	 (:start-event :any-keyboard)
	 (: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)))))
			     
  (opal:update polyline-creator-win)
  (format T "Press with left button to start a poly-line.  Each press adds a
  segment.  Stop by pressing with a button other than left or by pressing near the
  start point.  Typing ^g aborts the current object, and typing f stops it.")
  polyline-creator-win)

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