;;; Copyright (C) 1990  Alan M. Carroll
;;;
;;; This file is for use with Epoch, a modified version of GNU Emacs.
;;; Requires Epoch 3.2 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. 
;;;
(provide 'mouse)
(require 'mini-cl)
(require 'button)
;;;
;;; 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.
;;;
(defconst mouse::button-size 16)
(defconst mouse::table-size (* 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-left 0)
(defconst mouse-middle 1)
(defconst mouse-right 2)

(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-right))
    (error "Button specifier out of range")
  )
  (when (or (< modstate 0) (>= modstate mouse::button-size))
    (error "Button modifier out of range")
  )
)
;;; --------------------------------------------------------------------------
;;;
(defvar mouse::down-buffer nil "Buffer where the mouse last was pressed")
(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
    )
    (setq 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 ( - number 1 ))
      )
    )
    ;; find the handler list and try to dispatch
    (let*
      (
	(arg (epoch::coords-to-point (nth 1 value) (nth 2 value) scr))
	(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 (nth 1 arg)))
	  )
	)
	(handler
	  (or
	    (and (vectorp map) (aref map index))
	    (aref mouse::global-map index)
	  )
	)
      )
      (setq mouse::down-buffer (and edge arg (nth 1 arg)))
      (when (and handler (functionp handler))
	(funcall handler arg)
      )
    )
  )
)
;;; --------------------------------------------------------------------------
(defmacro mouse::index (button modstate)
  (`
    (+ (, modstate) (* (, button) (, mouse::button-size)))
  )
)
;;;
(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 (&option buffer)
"Remove the local mouse map for the option 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))
  (select-window (nth 2 arg))
  (goto-char (car arg))
)
;;;
(defun mouse::copy-button (button &optional kill)
  "Copy the text in the BUTTON into the X cut buffer and into the Epoch kill ring."
  (if button
    (let
      (
        (beg (epoch::button-start button))
	(end (epoch::button-end button))
      )
      (if (null beg) (setq beg 0))
      (if (null end) (setq edn 0))
      (epoch::store-cut-buffer (buffer-substring beg end))
      (if kill
	(delete-region beg end)
	(copy-region-as-kill beg end)
      )
    )
  )
)
;;;
(defun mouse::paste-cut-buffer (arg)
    (let ( (buff (nth 1 arg)) )
      (when (and buff (bufferp buff))
      (save-excursion
	(set-buffer (nth 1 arg))
	(goto-char (car arg))
	(insert (epoch::get-cut-buffer))
	(undo-boundary)
      )
    )
  )
)
;;; --------------------------------------------------------------------------
;;;
;;; Install things
;;;
(push-event 'button 'mouse::handler)
(setq epoch::mouse-events t)
;;;
