kinstrey@wsqtba.crd.ge.com (M. A. Kinstrey) (01/22/91)
;;; Copyright (C) 1990 General Electric Company.
;;; Written by Michael A. Kinstrey, for the
;;; DICE (DARPA Initiative in Concurrent Engineering) project.
;;;
;;; This file is for use with GNU Emacs 18.55 or later,
;;; or 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,
;;; but 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. Refer to the
;;; GNU Emacs General Public License for full details.
;;;
;;; Everyone is granted permission to copy, modify and redistribute
;;; this code, but only under the conditions described in the
;;; GNU Emacs General Public License.
;;; Among other things, the copyright notice and this notice
;;; must be preserved on all copies.
(provide 'mouse-double-click-functions)
(defvar single-mouse-map nil "*Xemacs mouse-map for single-click functions.")
(defvar double-mouse-map nil "*Mouse-map for double-click functions.")
(defvar double-clicks-allowed nil "*Flag indicating whether double-clicks are 'allowed' in this buffer")
(defvar current_click_time nil "Click time that JUST occurred.")
(defvar prev_click_time nil "Click time of previous click.")
(defvar prev_click_list nil "Previous click's event list containing position, screen, etc")
(defvar prev_screen nil "Screen which previous event occurred in.")
(defvar double_button_click nil "Non-nil if a double-click has been determined.")
(defvar prev_local_mouse_map nil "Copy of buffer's mouse-map before event double-click occurred." )
;; hook variables: used for executing functions before/after the
;; mouse-map's call-back function is executed.
;; Each hook variable is a list of functions to be executed in order
;; Functions are called with args:
;; if epoch- epoch::coords-to-point
;; if xemacs- event-point and button.
(defvar single-mouse-map-before-hooks nil "*list of funcs to run BEFORE the mouse-map callback is executed.")
(defvar single-mouse-map-after-hooks nil "*list of funcs to run AFTER the mouse-map callback is executed.")
(defvar double-mouse-map-before-hooks nil "*list of funcs to run BEFORE the mouse-map callback is executed.")
(defvar double-mouse-map-after-hooks nil "*list of funcs to run AFTER the mouse-map callback is executed.")
;; execute hooks on up or down events- t: down, nil: up
(defvar run-hooks-on-mouse-down-event nil
"*Execute hooks on mouse-up or mouse-down event.
Not applicable under Xemacs - always execute on button-down.")
;;; -----------------------------------------------------------------------------
;;; Double-click event handler - structure taken from mouse::handler in mouse.el
;;; -----------------------------------------------------------------------------
(defun mouse::double-click-handler (type value scr)
"Special event handler for mouse button usage. This handler
is capable of determining double-clicks from single-clicks, and
offers the user the ability to run pre and post hooks to the event's callback
routine. See the end of this file for examples of the callback and run-hooks
configurations."
;; first, grab the timestamp and button for later comparison
(if (and double-clicks-allowed (down-button-p value)) ;; check for double-click on button-down events
(progn
(setq current_click_time (current-time-string))
(cond ((double-click-p prev_click_time current_click_time
(list (x-coord prev_click_list) (y-coord prev_click_list))
(list (x-coord value) (y-coord value))
prev_screen scr)
(setq double_button_click t)
(setq prev_click_time nil)
(setq prev_local_mouse_map mouse::local-map))
(t (setq prev_click_time current_click_time)
(setq prev_click_list value)
(setq prev_screen scr)
(setq double_button_click nil)))))
;; 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 ))
)
)
;; use double-click mouse map?
(if (and double-clicks-allowed double_button_click)
(progn
(setq prev_local_mouse_map mouse::local-map)
(use-local-mouse-map double-mouse-map
(nth 1 (epoch::coords-to-point (nth 1 value)
(nth 2 value)
scr)))))
;; 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))
(if (or (and (down-button-p value) run-hooks-on-mouse-down-event)
(and (up-button-p value) (not run-hooks-on-mouse-down-event)))
(if (and double-clicks-allowed double_button_click)
(funcall-list double-mouse-map-before-hooks arg)
(funcall-list single-mouse-map-before-hooks arg)))
(funcall handler arg) ;; DO ACTUAL CALL-BACK!
(if (or (and (down-button-p value) run-hooks-on-mouse-down-event)
(and (up-button-p value) (not run-hooks-on-mouse-down-event)))
(if (and double-clicks-allowed double_button_click)
(funcall-list double-mouse-map-after-hooks arg)
(funcall-list single-mouse-map-after-hooks arg)))
)
)
(if (and double-clicks-allowed double_button_click)
(if prev_local_mouse_map ;; kludge to get around inability to pass nil argument
(progn
(use-local-mouse-map prev_local_mouse_map)
(setq prev_local_mouse_map nil))
(setq mouse::local-map nil)))
)
)
;;; --------------------------------------------------------------------------
(defun x-double-click (xy-pos-list)
"Function begins execution when first mouse-click occurs.
Function then grabs the next mouse-click event, and checks for
a double click condition. If single click is determined, the
single-click mouse-map function is executed. If double click
is determined, the double-click mouse-map function is executed.
This function MUST be wired into mouse-map.
Use the maps: single-mouse-map and double-mouse-map to set the
single and double click callbacks."
(interactive)
(if (not double-clicks-allowed) ;; use mouse-map, single-mouse-map not defined
(funcall 'x-mouse-set-point x-mouse-pos)
(setq current_click_time (current-time-string))
(if (equal prev_click_time nil)
(progn (setq prev_click_time current_click_time)
(setq prev_click_list x-mouse-pos)
(funcall-list single-mouse-map-before-hooks x-mouse-pos (char-to-string x-mouse-item))
(do-single-click-function x-mouse-pos (char-to-string x-mouse-item))
(funcall-list single-mouse-map-after-hooks x-mouse-pos (char-to-string x-mouse-item)))
(if (and double-clicks-allowed (double-click-p prev_click_time current_click_time prev_click_list x-mouse-pos))
(progn (setq prev_click_time nil)
(funcall-list double-mouse-map-before-hooks x-mouse-pos (char-to-string x-mouse-item))
(do-double-click-function x-mouse-pos (char-to-string x-mouse-item))
(funcall-list double-mouse-map-after-hooks x-mouse-pos (char-to-string x-mouse-item)))
(progn (setq prev_click_time current_click_time)
(setq prev_click_list x-mouse-pos)
(funcall-list single-mouse-map-before-hooks x-mouse-pos (char-to-string x-mouse-item))
(do-single-click-function x-mouse-pos (char-to-string x-mouse-item))
(funcall-list single-mouse-map-after-hooks x-mouse-pos (char-to-string x-mouse-item)))))))
;;----------------------------------;;
;; ev-list is the epoch 5-tuple list;;
;;----------------------------------;;
(defun down-button-p (ev-list) ;;
(interactive) ;;
(car ev-list)) ;;
;;
(defun up-button-p (ev-list) ;;
(interactive) ;;
(not (down-button-p ev-list))) ;;
;;
(defun x-coord (ev-list) ;;
(interactive) ;;
(nth 1 ev-list)) ;;
;;
(defun y-coord (ev-list) ;;
(interactive) ;;
(nth 2 ev-list)) ;;
;;
(defun get-button (ev-list) ;;
(interactive) ;;
(- (nth 3 ev-list) 1)) ;;
;;
(defun button-mod-state (ev-list) ;;
(interactive) ;;
(nth 4 ev-list)) ;;
;;
(defun left-button-p (ev-list) ;;
(interactive) ;;
(equal (get-button ev-list) ;;
mouse-left)) ;;
;;
(defun middle-button-p (ev-list) ;;
(interactive) ;;
(equal (get-button ev-list) ;;
mouse-middle)) ;;
;;
(defun right-button-p (ev-list) ;;
(interactive) ;;
(equal (get-button ev-list) ;;
mouse-right)) ;;
;;
;;----------------------------------;;
(defun funcall-list (func-list &optional arg button)
"Execute each function with arg, in order in func-list."
(cond ((null func-list) nil)
(running-epoch (funcall (car func-list) arg)
(funcall-list (cdr func-list) arg))
(t (funcall (car func-list) x-mouse-pos x-mouse-item)
(funcall-list (cdr func-list) arg button))))
(defun get-time-list (time-str)
"Function's argument is a time-string in the format
which current-time-string returns. Function returns a
list of: (hour minute second)."
(list (string-to-int (substring time-str 11 13))
(string-to-int (substring time-str 14 16))
(string-to-int (substring time-str 17 19))))
(defun same-second-p (time1 time2)
"Function returns t if time1 is the same as time2, nil otherwise.
The time list format: (hour minute second)"
(equal time1 time2))
(defun one-second-p (time1 time2)
"Function returns t if time1 is the same as time2, or if time2 is
within 1 second after time1. Nil returned otherwise.
The time list format: (hour minute second)"
(setq hour1 (car time1))
(setq hour2 (car time2))
(setq minute1 (car (cdr time1)))
(setq minute2 (car (cdr time2)))
(setq second1 (car (cdr (cdr time1))))
(setq second2 (car (cdr (cdr time2))))
(cond ((>= second2 second1) (if (<= (- second2 second1) 1) t nil))
((>= minute2 minute1) (if (<= (- minute2 minute1) 1) t nil))
((>= hour2 hour1 ) (if (<= (- hour2 hour1 ) 1) t nil))
((and (= hour1 12) (= hour2 1) (= minute1 59) (= minute2 0) (= second1 59) (= second2 0)) t)
(t nil)))
(defun double-click-p (time1 time2 pos-list1 pos-list2 &optional screen1 screen2)
"Function returns t if a double mouse click occurred. Criteria
for a double click to be valid is 2 clicks within one second,
and the X and Y positions for both clicks to be identical pairs.
For epoch, identical screens are tested also."
(and time1 time2
(equal (car pos-list1) (car pos-list2))
(equal (car (cdr pos-list1)) (car (cdr pos-list2)))
(if running-epoch (equal screen1 screen2) t)
(one-second-p (get-time-list time1) (get-time-list time2))))
(defun do-single-click-function (xy-pos-list button-clicked)
"Executes the function bound to button-clicked in the mouse-map."
(if (not (numberp (lookup-key single-mouse-map button-clicked)))
(funcall (lookup-key single-mouse-map button-clicked) xy-pos-list)))
(defun do-double-click-function (xy-pos-list button-clicked)
"Executes the function bound to button-clicked in the double-click map."
(if (not (numberp (lookup-key double-mouse-map button-clicked)))
(funcall (lookup-key double-mouse-map button-clicked) xy-pos-list)))
;; ------------------------------------------------------------------
;; ------------ END OF EVENT-HANDLER FUNCTION DECLARATIONS ----------
;; ------------------------------------------------------------------
-----------------------------------------------------------------------------
kinstrey@wsqtba.crd.ge.com | Sattinger's Law:
uunet!crdgw1!wsqtba!kinstrey| It works better if you plug it in.
____________________________|________________________________________________