;;; Copyright (C) 1991 Christopher J. Love
;;;
;;; This file is for use with Epoch, a modified version of GNU Emacs.
;;; Requires Epoch 4.0 or later.
;;;
;;; This code is distributed in the hope that it will be useful,
;;; bute WITHOUT ANY WARRANTY. No author or distributor accepts
;;; responsibility to anyone for the consequences of using this code
;;; or for whether it serves any particular purpose or works at all,
;;; unless explicitly stated in a written agreement.
;;;
;;; Everyone is granted permission to copy, modify and redistribute
;;; this code, but only under the conditions described in the
;;; GNU Emacs General Public License, except the original author nor his
;;; agents are bound by the License in their use of this code.
;;; (These special rights for the author in no way restrict the rights of
;;;  others given in the License or this prologue)
;;; A copy of this license is supposed to have been given to you along
;;; with Epoch so you can know your rights and responsibilities. 
;;; It should be in a file named COPYING.  Among other things, the
;;; copyright notice and this notice must be preserved on all copies. 
;;;
;;; $Revision: 1.2 $
;;; $Source: /home/user5/ht/emacs/shared/RCS/motion4.el,v $
;;; $Date: 1992/03/18 21:44:10 $
;;; $Author: ht $
;;;
;;; motion.el - provide draggin/hi-lighting of primary selection
;;;
;;; Original version by Alan Carroll
;;; Epoch 4.0 modifications by Chris Love
;;; Abort-isearch and other ideas from Ken Laprade and others.
;;;
(provide 'motion)
(redisplay-screen) ; fix epoch4.0a race bug?
(require 'zone)
(require 'mouse)

;;; ------------------------------------------------------------------------
;;; Interface values
(defvar horizontal-drag-inc 5
  "Number of columns to scroll when the pointer is to the left or right of the window")
(defvar vertical-drag-inc 2
  "Number of lines to scroll when the pointer is above or below the edge of the window")

(defvar mouse::downp nil "State variable for mouse dragging internals")
(defvar mouse::last-point -1 "Last location of a motion event")

(setq epoch::zones-modify-buffer nil)
(defvar motion::style nil "style used by drag zones")

(defvar drag-zone nil
  "Epoch zone to be used for hilighting selected text region."
)
(setq-default drag-zone nil)
(setq-default mouse-down-marker nil)

;;; ------------------------------------------------------------------------
;;; Set window-setup-hook to call motion::init(), which sets default
;;; style for zone dragging.  Default style is underlining; can be changed
;;; in .emacs file.
(epoch-add-setup-hook 'motion::init)

(defun motion::init ()
  (and (not motion::style) (setq motion::style (make-style)))
  (set-style-foreground motion::style (foreground))
  (set-style-background motion::style (background))
  (set-style-underline motion::style (foreground))
  ;; enable the handler
  (push-event 'motion 'motion::handler)
  ;; set up hints on all the current screens
  (dolist (s (screen-list t)) (epoch::set-motion-hints t s))
  ;; enable hints on future screens
  (push '(motion-hints t) epoch::screen-properties)
  )

;;; ------------------------------------------------------------------------
(defun set-mouse-marker (&optional location)
  (if (null mouse-down-marker)
    (setq mouse-down-marker (make-marker))
  )
  (set-marker mouse-down-marker (or location (point)))
)

;;; --------------------------------------------------------------------------
;;; Functions to provide dragging & hilighting.
;;; arg is a list of ( POINT BUFFER WINDOW SCREEN )
(defun end-mouse-drag (arg)
  (setq mouse::last-point -1)		;always do this cleanup
  (when mouse::downp
    (setq mouse::downp nil)
    (mouse::copy-zone drag-zone)
    (let (
	(s (and drag-zone (zone-start drag-zone)))
	(e (and drag-zone (zone-end drag-zone)))
      )
      (if (null s) (setq s 1))
      (if (null e) (setq e 1))
      (if (zonep drag-zone)
	(if (<= (point) s)
	  (progn
	    (push-mark e t)
	    (goto-char s)
	  )
	;; ELSE point is past drag zone start
	  (progn
	    (push-mark s t)
	    (goto-char e)
	  )
	)
      )
    )
  )
)

(defun start-mouse-drag (arg)
  (when arg
    (setq mouse::downp 'start)
;    (message "%s" arg)
    (mouse::set-point arg)
    (abort-isearch)
    (set-mouse-marker)
    (setq mouse::last-point (point))
    (if drag-zone
      (progn
	(message "ddz")
	(delete-zone drag-zone)
	(setq drag-zone nil)
	(redisplay-screen)
      )
    )
  )
)

(defun extend-mouse-drag (arg)
  (setq mouse::downp 'extend)
  (let
    (
      (m1 (and drag-zone (zone-start drag-zone)))
      (m2 (and drag-zone (zone-end drag-zone)))
      (spot (car arg))			;point of the mouse click.
    )
    (if (null m1) (setq m1 0))
    (if (null m2) (setq m2 0))
    (cond
      ((or (null drag-zone) (null mouse-down-marker))
	(setq drag-zone (add-zone (point) spot motion::style) )
	(set-zone-transient drag-zone t)
	(set-mouse-marker)
      )
      ((<= spot m1)
	(setq drag-zone (move-zone drag-zone spot m2) )
	(set-mouse-marker m2)
      )
      ((>= spot m2)
	(setq drag-zone (move-zone drag-zone m1 spot) )
	(set-mouse-marker m1)
      )
      ((<= mouse-down-marker spot)
	(setq drag-zone (move-zone drag-zone m1 spot) )
	(set-mouse-marker m1)
      )
      (t
	(setq drag-zone (move-zone drag-zone spot m2) )
	(set-mouse-marker m2)
      )
    )
    (epoch::redisplay-screen)
    (setq mouse::last-point (point))
  )
)

;;; ------------------------------------------------------------------------
;;; Define the handler for dragging, etc.
(defun motion::handler (type value scr)
  (if (null mouse-down-marker) (set-mouse-marker))
  (if (and (boundp 'mouse::downp) mouse::downp)
    (mouse-sweep-update)
  )
)

;;;
(defun mouse-sweep-update()
  (let*
    (
      drag-m1
      drag-m2
      pnt
      pos
      x
      y
      (w (selected-window))      
      (out-of-bounds t)
      (epoch::event-handler-abort nil)
      (w-edges (window-pixedges w))
      (left (car w-edges))
      (top (elt w-edges 1))
      (right (- (elt w-edges 2) left 1))
      (bottom (- (elt w-edges 4) top 1))
    )
    (while
      (and
	out-of-bounds
	(setq pos (query-pointer))
	(/= 0 (logand mouse-any-mask (elt pos 2)))
      )
      ;;convert to window relative co-ordinates
      (setq x (- (car pos) left))
      (setq y (- (elt pos 1) top))
      (setq out-of-bounds
	(not (and (<= 0 y) (<= y bottom) (<= 0 x) (<= x right)))
      )
      ;; scrolling conditions
      (condition-case errno
	(progn
	  (if (< y 0) (scroll-down vertical-drag-inc))
	  (if (> y bottom) (scroll-up vertical-drag-inc))
	)
	(error )			;nothing, just catch it
      )
;; Disable horizontal scrolling.
;      (if (< x left) (scroll-right horizontal-drag-inc))
;      (if (> x right) (scroll-left horizontal-drag-inc))
      (setq y (max 1 (min bottom y)))
      (setq x (max 0 (min right x)))
      (setq pnt (car (epoch::coords-to-point (+ x left) (+ y top))))
      (when (/= mouse::last-point pnt)
	    (if (> mouse-down-marker pnt)
		(progn
		  (setq drag-m1 pnt)
		  (setq drag-m2 (marker-position mouse-down-marker))
		  )
	      (progn
		(setq drag-m1 (marker-position mouse-down-marker))
		(setq drag-m2 (1+ pnt))
		)
	      )
	    ;; moved this in here so that zone won't get made if
	    ;; only motion is jitter within a single character
	    ;; this fixes a bunch of bogus (often empty)
	    ;; entries in the kill ring
	    (if drag-zone
		(move-zone drag-zone drag-m1 drag-m2)
	      (progn (setq drag-zone
			   (add-zone drag-m1 drag-m2 motion::style )
			   )
		     (set-zone-transient drag-zone t)
		     )
	      )
	    (redisplay-screen)
	    )
      (setq mouse::last-point pnt)
    )
  )
)
    
;;; ------------------------------------------------------------------------
;;; Code for selecting lines using motion events. Assumes that the line is
;;; left unmarked on zone up
(defvar mouse::line-zone nil "Zone for selected line")
;;;
(defun mouse-select-line-start (arg)
  (mouse::set-point arg)		;go there
  (setq mouse::last-point (point))
  (let ( bol )
    (save-excursion
      (beginning-of-line)
      (setq bol (point))
      (end-of-line)
      (setq mouse::line-zone (add-zone bol (point) motion::style))
    )
  )
  (push-event 'motion 'mouse-select-line-update)
)
;;;
(defun mouse-select-line-end (arg)
  (setq mouse::last-point -1)
  (when mouse::line-zone (delete-zone mouse::line-zone))
  (pop-event 'motion)
)
;;;
(defun mouse-select-line-update (type value scr)
  (let*
    (
      y
      pos
      bol
      (out-of-bounds t)
      (epoch::event-handler-abort nil)
      (w-edges (window-pixedges (selected-window)))
      (top (elt w-edges 1))
      (bottom (- (elt w-edges 4) top 1))
      max-vscroll
    )
    (while
      (and
	out-of-bounds
	(setq pos (query-pointer))
	(/= 0 (logand mouse-any-mask (elt pos 2)))
      )
      ;;convert to window relative co-ordinates
      (setq y (- (elt pos 1) top))
      (setq out-of-bounds (not (and (<= 0 y) (<= y bottom))))

      ;; Scrolling hard, because of possibly shrink-wrapped windows.
      ;; set max-vscroll to be the most we could scroll down and not have
      ;; empty lines at the bottom
      (save-excursion
	(move-to-window-line bottom)	;go to the last line in the window
	(setq max-vscroll
	  (- vertical-drag-inc (forward-line vertical-drag-inc))
	)
	(if (and (> max-vscroll 0) (eobp) (= 0 (current-column)))
	  (decf max-vscroll)
	)
      )
      (condition-case errno
	(progn
	  (if (< y 0) (scroll-down vertical-drag-inc))
	  (if (> y bottom) (scroll-up (min max-vscroll vertical-drag-inc)))
	)
	;; CONDITIONS
	(error)				;nothing, just want to catch it
      )
      (setq y (max 0 (min bottom y)))

      ;;move to the new point
      (move-to-window-line y)
      (beginning-of-line) (setq bol (point))
      (end-of-line)
      (when (/= mouse::last-point (point))
	(move-zone mouse::line-zone bol (point))
	(epoch::redisplay-screen)
      )
      (setq mouse::last-point (point))
    )
  )
)
;;; --------------------------------------------------------------------------
;; Stolen from AMC
(defun mouse::buffer-line (marg)
  "Show the line number and buffer of the mouse EVENT"
  ;; marg is (point buffer window screen)
  ;; Pop over to the clicked buffer
  (save-excursion (set-buffer (cadr marg))
    ;; Figure out how far down the mouse point is
    (let ((n (count-lines (point-min) (car marg))))
      ;; display it. Include the buffer name for good measure.
      (message (format "Line %d in %s" n (buffer-name (cadr marg))))
)))

;; Blow out of any current isearch
(defun abort-isearch () "Abort any isearch in progress."
  (condition-case err
      (throw 'search-done t)
    (no-catch nil)))
;;; --------------------------------------------------------------------------
;;; install all our various handlers
(global-set-mouse mouse-left mouse-down 'start-mouse-drag)
(global-set-mouse mouse-left mouse-shift 'mouse::buffer-line)
(global-set-mouse mouse-left mouse-up 'end-mouse-drag)
(global-set-mouse mouse-right mouse-down 'extend-mouse-drag)
(global-set-mouse mouse-right mouse-up 'end-mouse-drag)
(global-set-mouse mouse-middle mouse-down 'mouse::paste-cut-buffer)


(defun mouse-set-spot (arg)
  "Set point at mouse.  With double-click, set mark there as well.
Blinks matching paren if sitting after one.  Intended to be bound
to a window down button."
  (start-mouse-drag arg)
  (let ((buf (current-buffer))
        (p (point)))
    (mouse::set-point arg)
    (if (and (equal p (point))
             (equal buf (current-buffer)))
        (if (and (= mouse::clicks 1)
                 (not (eq (mark) (point))))
            (push-mark))
      (setq mouse::clicks 0))
    (if (eq (char-syntax (preceding-char)) ?\))
          (blink-matching-open)))
  (abort-isearch))