;;; -*- mode:lisp; package: tv; base:10.; -*- ;;;

;;; TRACKING

;;;  This file contains code to implement TRACKING windows.
;;;
;;;  These are windows that move when the mouse moves out-of-bounds.
;;; Similar to following mixin, but nicer-looking.



;;;  ****************************************************************
;;;  Necessary Loads, Constants, Declarations.
;;;  ****************************************************************





;;;  ****************************************************************
;;;  Internal Macros, Structure Definitions, FLAVOR definitions.
;;;  ****************************************************************

(defflavor tracking-mixin
	((time-out 30)				;half a second
	 (dont-bother nil)
	 (tracking-blinker nil))
	(hysteretic-window-mixin)
  :gettable-instance-variables
  :initable-instance-variables
  :settable-instance-variables
  (:required-flavors window))


;;;  When making such a window, initialize the tracking blinker so we don't
;;; have to make new ones each time.
(defmethod (tracking-mixin :after :init)
	   (&rest ignore)
  (setq hysteresis 30.)
  (setq tracking-blinker (tv:make-blinker tv:main-screen 'box-blinker
					  ':x-pos x-offset ':y-pos y-offset
					  ':width width ':height height
					  ':visibility nil)))



;;;  ****************************************************************
;;;  Internal Code
;;;  ****************************************************************

(defmethod (tracking-mixin :before :select)
	   (&optional ignore)
  (setq dont-bother nil))

(defmethod (tracking-mixin :before :bury)
	   (&rest ignore)
  (setq dont-bother t))
(defmethod (tracking-mixin :before :deactivate)
	   (&rest ignore)
  (setq dont-bother t))
(defmethod (tracking-mixin :before :kill)
	   (&rest ignore)
  (setq dont-bother t))
(defmethod (tracking-mixin :before :deexpose)
	   (&rest ignore)
  (setq dont-bother t))
(defmethod (tracking-mixin :before :deselect)
	   (&rest ignore)
  (setq dont-bother t))

;;; This runs in the mouse process.
(defmethod (tracking-mixin :after :handle-mouse)
	   ()
  ;; Largely stolen from tv:basic-momentary-menu
  (or window-owning-mouse
      dont-bother
      (not exposed-p)
      (and mouse-reconsider (eq self (window-owning-mouse)))
      (process-run-function '(:name "Moving around" :priority 20.)
			     self ':track-mouse))
  )


;;;  Here is where we do the real work.  What basically happens is that once
;;; the mouse goes outside of the window, we want to let the user move the window.
;;; We pop-up a blinker the size of the window, and let it follow the mouse.  As
;;; soon as the mouse "settles down", we move the window.
(defmethod (tracking-mixin :track-mouse)
	   (&aux (OLD-MOUSE-SHEET MOUSE-SHEET) window-edge-alist)
  (UNWIND-PROTECT
    (*CATCH 'EXIT-SCREEN-EDITOR
      (LET-GLOBALLY ((WHO-LINE-PROCESS CURRENT-PROCESS))
	(MOUSE-SET-SHEET MAIN-SCREEN)
	(let ((NEW-ALIST 'FIRST))
	  (DELAYING-SCREEN-MANAGEMENT
	    ;; Now, just before executing the command, pick up the state of the screen
	    ;; We defer it until now so that we see the results of screen management
	    ;; and of things done to the screen by other processes.
	    ;; Also save the state before the previous command for Undo
	    (SETQ WINDOW-EDGE-ALIST (GET-WINDOW-EDGE-ALIST MAIN-SCREEN))
	    (setq new-alist (let* ((window (loop for w in window-edge-alist
						 if (eq (car w) self)
						 return w)))
			      (MULTIPLE-VALUE-BIND (X Y)
				  (MOUSE-SET-WINDOW-POSITION (CAR WINDOW) t)
				(IF X (SETQ WINDOW-EDGE-ALIST
					    (SUBSTQ (LIST (CAR WINDOW) (CADR WINDOW) X Y
							  (+ X (SHEET-WIDTH (CAR WINDOW)))
							  (+ Y (SHEET-HEIGHT (CAR WINDOW))))
						    WINDOW WINDOW-EDGE-ALIST))
				    'ABORT))))
	    
	    (COND ((NEQ NEW-ALIST 'ABORT)	;Don't change history if command aborted
		   (DOLIST (NEW NEW-ALIST)
		     (LET ((OLD (ASSQ (CAR NEW) WINDOW-EDGE-ALIST)))
		       (OR (EQUAL (CDDR OLD) (CDDR NEW))	;Edges not the same?
			   (MULTIPLE-VALUE-BIND (WIN LOSE)
			       (FUNCALL (FIRST NEW) ':SET-EDGES (THIRD NEW) (FOURTH NEW)
					(FIFTH NEW) (SIXTH NEW) ':VERIFY)
			     (IF WIN (LEXPR-FUNCALL (CAR NEW) ':SET-EDGES (CDDR NEW))
				 (BEEP)
				 (POP-UP-FORMAT "Illegal edges for ~S:~%~A"
						(CAR NEW) LOSE))))
		       ;; Try to fix exposure and ordering of de-exposed sheets.
		       ;; This may not be quite right, e.g. if undoing an expose
		       ;; because the window will go in the wrong place in the
		       ;; de-exposed sheets, and Undo twice will not be a no-op.
		       ;; It will just have to do for now though.
		       (COND ((EQ (CADR NEW) T)
			      (OR (CADR OLD) (FUNCALL (CAR NEW) ':EXPOSE)))
			     ((EQ (CADR NEW) ':BURY)
			      (FUNCALL (CAR NEW) ':BURY)))))
		   ;; Doing the buries in a second pass makes the
		   ;; above-mentioned inaccuracy less
		   (DOLIST (NEW NEW-ALIST)
		     (AND (NOT (CADR NEW)) (SHEET-EXPOSED-P (CAR NEW))
			  (FUNCALL (CAR NEW) ':BURY))))))
	  )))
  (MOUSE-SET-SHEET OLD-MOUSE-SHEET)))