;;; 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.12 $
;;; $Source: /import/kaplan/stable/distrib/epoch-4.2/epoch-lisp/RCS/mouse.el,v $
;;; $Date: 92/06/30 01:21:08 $
;;; $Author: marca $
;;;
;;; mouse.el - event handler for mouse events.
;;;
;;; Original version by Alan Carroll
;;; Subsequent modifications by Ken Laprade
;;; Multiple click detection based on code by Brian L. Kahn
;;; Epoch 4.0 modifications by Chris Love
;;;
(provide 'mouse)
(provide 'multi-click)
(require 'mini-cl)
(require 'zone)
(require 'selection)

;;; --------------------------------------------------------------------------
;;; Mouse data available at elisp level.
(defvar mouse::selection-atom nil
  "Property to use for cut/paste - defaults to PRIMARY"
)
(defvar mouse::down-buffer nil "Buffer where the mouse last was pressed")
(defvar mouse::down-number-offset 0
  "Where the mouse last was pressed (window, mode, minibuf).")

(defvar mouse::event-data nil
  "Raw data value mouse::handler was called with (press/release x y button mod-state).")

(defvar mouse::x 0 "X screen position of mouse, in pixels.")
(defvar mouse::y 0 "Y screen position of mouse, in pixels.")
(defvar mouse::last-spot nil
  "Mouse data value of last event (point buffer window screen).")
(defvar mouse::clicks 0
  "Number of times mouse was pressed and released in the same place.")

(defconst mouse::interval 200
  "The number of milliseconds allowed between multi-clicks
   - interval is clocked between down-click and previous up-click"
)
(defvar mouse::time-stamp 0
  "The millisecond time of last upclick"
)
;;; --------------------------------------------------------------------------
;;; Install/initialize some things at runtime.
(epoch-add-setup-hook 'mouse::init)
(defun mouse::init()
  (setq mouse::selection-atom (intern-atom "PRIMARY"))
  ;; Install handler for selection-clear on this selection
  (push-selection mouse::selection-atom 'mouse-clear)
)

;;; --------------------------------------------------------------------------
;;; Mouse event handler. 
;;; Mouse events are set to come in on the event Q, and are then dispatched.
;;; For each button, there is a 16-element table, each entry being a list of
;;; handler functions. The table is indexed by the modifier&transistion state.
;;;
;;; One table is used for button presses in the mode line and the other for
;;; presses in the window proper.
;;;
;;; There are also tables for mouse presses in the minibuffer when it is
;;; not active.  Functions in this map are always called with a nil argument.
;;;
(defconst mouse::button-size 16)
(defconst mouse::table-size (* 3 3 mouse::button-size))
(defvar mouse::global-map (make-vector mouse::table-size nil))
(defvar mouse::local-map nil)
(make-variable-buffer-local 'mouse::local-map)

;;; --------------------------------------------------------------------------
;;; define the button states
(defvar shift-mod-mask 1 "Mask for Shift modifier down")
(defvar shift-lock-mod-mask 2 "Mask for Shift Lock modifier down")
(defvar control-mod-mask 4 "Mask for Control modifier down")
(defvar meta-mod-mask 8 "Mask for Meta (mod1) modifier down")
(defvar keyboard-mod-mask
  (+ shift-mod-mask control-mod-mask meta-mod-mask)
  "Mask for any of the keyboard modifiers"
)

(defvar mouse1-mask 256 "Mask for mouse button 1 down")
(defvar mouse2-mask 512 "Mask for mouse button 2 down")
(defvar mouse3-mask 1024 "Mask for mouse button 3 down")
(defvar mouse4-mask 2048 "Mask for mouse button 4 down")
(defvar mouse5-mask 4096 "Mask for mouse button 5 down")
(defvar mouse-any-mask (logior mouse1-mask mouse2-mask mouse3-mask mouse4-mask mouse5-mask)
"Mask for any of the mouse buttons")
;;;
;;; the button/mod constant definitions
;;;
(defconst mouse-window 1)
(defconst mouse-left 1)
(defconst mouse-middle 2)
(defconst mouse-right 3)
(defconst mouse-mode 4)
(defconst mouse-mode-left 4)
(defconst mouse-mode-middle 5)
(defconst mouse-mode-right 6)
(defconst mouse-minibuf 7)
(defconst mouse-minibuf-left 7)
(defconst mouse-minibuf-middle 8)
(defconst mouse-minibuf-right 9)

(defconst mouse-down 0)
(defconst mouse-up 1)

(defconst mouse-shift 2)
(defconst mouse-shift-up (+ mouse-shift mouse-up))
(defconst mouse-control 4)
(defconst mouse-control-up (+ mouse-control mouse-up))
(defconst mouse-control-shift (+ mouse-shift mouse-control))
(defconst mouse-control-shift-up (+ mouse-control-shift mouse-up))
(defconst mouse-meta 8)
(defconst mouse-meta-up (+ mouse-meta mouse-up))
(defconst mouse-meta-shift (+ mouse-shift mouse-meta))
(defconst mouse-meta-shift-up (+ mouse-meta-shift mouse-up))
(defconst mouse-meta-control (+ mouse-meta mouse-control))
(defconst mouse-meta-control-up (+ mouse-meta-control mouse-up))
(defconst mouse-meta-control-shift (+ mouse-shift mouse-control mouse-meta))
(defconst mouse-meta-control-shift-up (+ mouse-meta-control-shift mouse-up))

;;; --------------------------------------------------------------------------
;;; handler installation, etc.
(defun mouse::verify-arguments (button modstate)
  (when (or (< button mouse-left) (> button mouse-minibuf-right))
    (error "Button specifier out of range")
  )
  (when (or (< modstate 0) (>= modstate mouse::button-size))
    (error "Button modifier out of range")
  )
)

;;; --------------------------------------------------------------------------
;;; Handler to dispatch mouse events
(defun mouse::handler (type value scr)
  ;; first, calculate the index
  (let*
    (
      (number (nth 3 value))
      (edge (nth 0 value))
      (modstate (nth 4 value))
      index
      (epoch::event-handler-abort nil)	;prevent lossage
      (arg (epoch::coords-to-point (nth 1 value) (nth 2 value) scr))
      (buffer (and arg (nth 1 arg)))
      ;; Find which button table.  We want to stay in the same set of tables
      ;; (window, mode, minibuf) as any down press.
      (number-offset (if mouse::down-buffer
			 mouse::down-number-offset
		       (if (and (eq (nth 2 arg) (minibuffer-window))
				(= (minibuffer-depth) 0))
			   mouse-minibuf
			 (if (null (car arg))
			     mouse-mode
			   1)))) 
    )
    ;; Minibuf presses get no args.
    (if (= number-offset mouse-minibuf)
	(setq arg nil))

    ;; Count clicks as a convenience for some functions.
    (if (car value)
      ;; down-click - do timing check
      (let ((elapsed (- (aref epoch::event 3) mouse::time-stamp)))
	(if (< elapsed mouse::interval) ; multi-click
	  (setq mouse::clicks (1+ mouse::clicks))
	  (setq mouse::clicks 1)
	)
      )
      ;; up-click - update time stamp
      (setq mouse::time-stamp (aref epoch::event 3))
    )

    (setq mouse::event-data value)
    (setq mouse::x (nth 1 value))
    (setq mouse::y (nth 2 value))

    (setq number (+ number (1- number-offset)))
    ;; find the handler list and try to dispatch
    (let*
      (
        (index
	  (+
	    (if edge mouse-down mouse-up)
	    (if (/= 0 (logand modstate shift-mod-mask)) mouse-shift 0)
	    (if (/= 0 (logand modstate control-mod-mask)) mouse-control 0)
	    (if (/= 0 (logand modstate meta-mod-mask)) mouse-meta 0)
	    (* mouse::button-size (1- number))
	  )
	)
  	(map
  	  (if (and mouse::down-buffer (not edge))
              ;; force release into press buffer, for simulated grab
	      (symbol-buffer-value 'mouse::local-map mouse::down-buffer)
  	    ;; ELSE if there's an arg, use the arg buffer
	    (and arg (symbol-buffer-value 'mouse::local-map buffer))
	  )
	)

	(handler
	  (or
	    (and (vectorp map) (aref map index))
	    (aref mouse::global-map index)
	  )
	)
      )
      ;; Record down circumstances for next event.
      (setq mouse::down-buffer (and edge buffer))
      (if edge
	  (setq mouse::down-number-offset number-offset))

      ;; Do it.
      (when (and handler (functionp handler))
	(setq this-command handler)
        (funcall handler arg)
	(setq last-command this-command)
      )
    )
    (setq mouse::last-spot arg)
  )
)
;;; --------------------------------------------------------------------------
;;; Do lookup into mouse map based on button, etc.
(defmacro mouse::index (button modstate)
  (`
    (+ (, modstate) (* (1- (, button)) (, mouse::button-size)))
  )
)

;;; --------------------------------------------------------------------------
;;; Functions to do various operations on mouse maps
(defun copy-mouse-map (from to)
  (when (null to) (setq to (make-vector mouse::table-size nil)))
  (let ( (i 0) )
    (while (< i mouse::table-size)
      (aset to i (aref from i))
      (incf i)
    )
  )
  to					; return value
)

;;;
(defun create-mouse-map (&optional source-map)
  (if (vectorp source-map)
    (copy-mouse-map source-map nil)
    (make-vector mouse::table-size nil)
  )
)

;;;
(defun local-set-mouse (button modstate function)
  (mouse::verify-arguments button modstate)
  (when (null mouse::local-map)
    (setq mouse::local-map (create-mouse-map mouse::global-map))
  )
  (aset mouse::local-map (mouse::index button modstate) function)
)

;;;
(defun global-set-mouse (button modstate function)
"Set the global mouse map to have BUTTON with MODIFIER call FUNCTION"
  (mouse::verify-arguments button modstate)
  (aset mouse::global-map (mouse::index button modstate) function)
)

;;;
(defun define-mouse (map button modstate function)
"Set an entry in the MAP for BUTTON and MODIFIER to FUNCTION"
  (when (not (vectorp map)) (error "Map must be a vector"))
  (aset map (mouse::index button modstate) function)
)

;;;
(defun use-local-mouse-map (map &optional buffer)
"Use MAP as the local mouse map in BUFFER (current buffer if omitted"
  (when (not (and map (vectorp map))) (error "Invalid mouse map"))
  (if (bufferp buffer)
    (save-excursion
      (set-buffer buffer)
      (setq mouse::local-map map)
    )
    (setq mouse::local-map map)
  )
)

;;;
(defun kill-local-mouse-map (&optional buffer)
"Remove the local mouse map for the optional BUFFER (if nil, current buffer)"
  (if (bufferp buffer)
    (save-excursion
      (set-buffer buffer)
      (kill-local-variable 'mouse::local-map)
    )
    (kill-local-variable 'mouse::local-map)
  )
)

;;; --------------------------------------------------------------------------
(defun mouse::set-point (arg)
  "Select Epoch window mouse is on, and move point to mouse position."
  (select-screen (nth 3 arg))
  (if (nth 2 arg) (select-window (nth 2 arg)))
  (if (car arg) (goto-char (min (car arg) (point-max))))
)

;;; --------------------------------------------------------------------------
;; Variable added by marca to allow regression to pre-4.0p2 behavior;
;; this may go away unless someone out there wants it to remain.
(defvar mouse::set-point-clears-cut-buffer nil
  "*T if setting point with left mouse button clears cut buffer; NIL otherwise.")

;;; --------------------------------------------------------------------------
;;; Cut & Paste functions based on an Epoch button.  
(defun mouse::copy-zone (zone &optional kill)
  "Copy the text in the ZONE to the appropriate selection atom and to X cut-buffer"
  (if (zonep zone)
    (let
      (
        (beg (min (epoch::zone-start zone) (point-max)))
	(end (min (epoch::zone-end zone) (point-max)))
	(buf (epoch::zone-buffer zone))
	text
      )
      (if (null beg) (setq beg 1))
      (if (null end) (setq end 1))
      (if (bufferp buf)
	(save-excursion
	  (set-buffer buf)
	  (setq text (buffer-substring beg end))
	)
	(setq text "")
      )
      (epoch::store-cut-buffer text)
      ; assert ownership of PRIMARY selection
      (epoch::acquire-selection mouse::selection-atom)
      ; store data so we people can paste from Epoch to other clients.
      (setq epoch::selection-alist
	(alist-delete mouse::selection-atom epoch::selection-alist))
      (setq epoch::selection-alist
	(cons
	  (cons
	    mouse::selection-atom text
	  )
	  epoch::selection-alist
	)
      )
      (if (/= beg end)
	(if (bufferp buf)
	  (save-excursion
	    (set-buffer buf)
	    (if kill
	      (delete-region beg end)
	      (copy-region-as-kill beg end)
              ;; Eliminate replication on kill.
              (setq this-command nil)
	    )
	  )
	)
      )
    )
    ;; Don't clear out the cut buffer if we don't explicitly want it
    ;; cleared out; this means that the cut buffer contains a string
    ;; until that string is replaced.
    (if mouse::set-point-clears-cut-buffer
        (epoch::store-cut-buffer ""))
    (setq epoch::selection-alist
          (cons
           (cons
            mouse::selection-atom ""
            )
           (alist-delete mouse::selection-atom epoch::selection-alist)
           ))
    )
)

;;;
(defun mouse::paste-cut-buffer (arg)
  "Retrieve text from appropriate selection, or X cut-buffer if none"
  (let ( (buff (nth 1 arg)) )
    (when (and buff (bufferp buff))
      (save-excursion
        (set-buffer buff)
        (undo-boundary)
        (goto-char (min (car arg) (point-max)))
	; get text from selection PRIMARY
	; insert text once it's there.
	(let
	  (
	    (text
	      (epoch::convert-selection mouse::selection-atom
		"STRING" "PROPERTY"))
	  )
	  ; Make sure string isn't ""
	  (if (and (stringp text) (> (length text) 0))
	    (insert text)	; selection is owned and has a value
	    (insert (get-cut-buffer))	; grab cut-buffer instead
	  )
	)
))))


;;; --------------------------------------------------------------------------
;;; Install things
(push-event 'button 'mouse::handler)
(setq epoch::mouse-events t)