[bpt/emacs.git] / lisp / mouse.el

;;; Window system-independent mouse support.
;;; Copyright (C) 1988 Free Software Foundation, Inc.

;;; This file is part of GNU Emacs.

;;; GNU Emacs is free software; you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 1, or (at your option)
;;; any later version.

;;; GNU Emacs is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.

;;; You should have received a copy of the GNU General Public License
;;; along with GNU Emacs; see the file COPYING.  If not, write to
;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.

(provide 'mouse)

\f
;;; Utility functions.

(defun mouse-movement-p (event)
  (and (consp event)
       (eq (car event) 'mouse-movement)))

(defun event-window (event)	(nth 1 event))
(defun event-point (event)	(nth 2 event))
(defun mouse-coords (event)	(nth 3 event))
(defun mouse-timestamp (event)	(nth 4 event))

;;; Indent track-mouse like progn.
(put 'track-mouse 'lisp-indent-function 0)

\f
(defun mouse-delete-window (click)
  "Delete the window clicked on.
This must be bound to a mouse click."
  (interactive "K")
  (delete-window (event-window click)))

(defun mouse-delete-other-windows (click)
  "Select Emacs window clicked on, then kill all other Emacs windows.
This must be bound to a mouse click."
  (interactive "K")
  (select-window (event-window click))
  (delete-other-windows))

(defun mouse-split-window-vertically (click)
  "Select Emacs window mouse is on, then split it vertically in half.
The window is split at the line clicked on.
This command must be bound to a mouse click."
  (interactive "K")
  (select-window (event-window click))
  (split-window-vertically (1+ (cdr (mouse-coords click)))))

(defun mouse-set-point (click)
  "Move point to the position clicked on with the mouse.
This must be bound to a mouse click."
  (interactive "K")
  (select-window (event-window click))
  (goto-char (event-point click)))

(defun mouse-set-mark (click)
  "Set mark at the position clicked on with the mouse.
Display cursor at that position for a second.
This must be bound to a mouse click."
  (interactive "K")
  (let ((point-save (point)))
    (unwind-protect
	(progn (mouse-set-point click)
	       (push-mark nil t)
	       (sit-for 1))
      (goto-char point-save))))

(defun mouse-kill (click)
  "Kill the region between point and the mouse click.
The text is saved in the kill ring, as with \\[kill-region]."
  (interactive "K")
  (mouse-set-mark click)
  (kill-region))

(defun mouse-kill-ring-save
  "Copy the region between point and the mouse click in the kill ring.
This does not delete the region; it acts like \\[kill-ring-save]."
  (interactive "K")
  (mouse-set-mark click)
  (kill-ring-save))


\f
;; Commands for the scroll bar.

(defun mouse-scroll-down (nlines)
  (interactive "@p")
  (scroll-down nlines))

(defun mouse-scroll-up (nlines)
  (interactive "@p")
  (scroll-up nlines))

(defun mouse-scroll-down-full ()
  (interactive "@")
  (scroll-down nil))

(defun mouse-scroll-up-full ()
  (interactive "@")
  (scroll-up nil))

(defun mouse-scroll-move-cursor (nlines)
  (interactive "@p")
  (move-to-window-line nlines))

(defun mouse-scroll-absolute (event)
  (interactive "@e")
  (let* ((pos (car event))
	 (position (car pos))
	 (length (car (cdr pos))))
    (if (<= length 0) (setq length 1))
    (let* ((scale-factor (max 1 (/ length (/ 8000000 (buffer-size)))))
	   (newpos (* (/ (* (/ (buffer-size) scale-factor)
			    position)
			 length)
		      scale-factor)))
      (goto-char newpos)
      (recenter '(4)))))

(defun mouse-scroll-left (ncolumns)
  (interactive "@p")
  (scroll-left ncolumns))

(defun mouse-scroll-right (ncolumns)
  (interactive "@p")
  (scroll-right ncolumns))

(defun mouse-scroll-left-full ()
  (interactive "@")
  (scroll-left nil))

(defun mouse-scroll-right-full ()
  (interactive "@")
  (scroll-right nil))

(defun mouse-scroll-move-cursor-horizontally (ncolumns)
  (interactive "@p")
  (move-to-column ncolumns))

(defun mouse-scroll-absolute-horizontally (event)
  (interactive "@e")
  (let* ((pos (car event))
	 (position (car pos))
	 (length (car (cdr pos))))
  (set-window-hscroll (selected-window) 33)))

;; Set up these commands, including the prefix keys for the scroll bar.

;;; (fset 'mouse-vertical-scroll-bar-prefix (make-sparse-keymap))
;;; (define-key global-mouse-map mouse-vertical-scroll-bar-prefix
;;;   'mouse-vertical-scroll-bar-prefix)
;;; 
;;; (defun mouse-scroll-motion (event)
;;;   (interactive "e")
;;;   (let ((pos (car (car event)))
;;; 	(length (car (cdr (car event)))))
;;;     (message "[%d %d]" pos length)))
;;; 
;;; (let ((map (function mouse-vertical-scroll-bar-prefix)))
;;;   (define-key map mouse-button-right 'mouse-scroll-down)
;;;   (define-key map mouse-button-left 'mouse-scroll-up)
;;;   (define-key map mouse-button-middle 'mouse-scroll-absolute)
;;;   (define-key map mouse-motion 'x-horizontal-line))
;;; 
;;; ;(fset 'mouse-vertical-slider-prefix (make-sparse-keymap))
;;; ;(define-key global-mouse-map mouse-vertical-slider-prefix
;;; ;  'mouse-vertical-slider-prefix)
;;; 
;;; ;(let ((map (function mouse-vertical-slider-prefix)))
;;; ;  (define-key map mouse-button-right 'mouse-scroll-move-cursor)
;;; ;  (define-key map mouse-button-left 'mouse-scroll-move-cursor)
;;; ;  (define-key map mouse-button-middle 'mouse-scroll-move-cursor))
;;; 
;;; (fset 'mouse-vertical-thumbup-prefix (make-sparse-keymap))
;;; (define-key global-mouse-map mouse-vertical-thumbup-prefix
;;;   'mouse-vertical-thumbup-prefix)
;;; 
;;; (let ((map (function mouse-vertical-thumbup-prefix)))
;;;   (define-key map mouse-button-right 'mouse-scroll-down-full)
;;;   (define-key map mouse-button-left 'mouse-scroll-down-full)
;;;   (define-key map mouse-button-middle 'mouse-scroll-down-full))
;;; 
;;; (fset 'mouse-vertical-thumbdown-prefix (make-sparse-keymap))
;;; (define-key global-mouse-map mouse-vertical-thumbdown-prefix
;;;   'mouse-vertical-thumbdown-prefix)
;;; 
;;; (let ((map (function mouse-vertical-thumbdown-prefix)))
;;;   (define-key map mouse-button-right 'mouse-scroll-up-full)
;;;   (define-key map mouse-button-left 'mouse-scroll-up-full)
;;;   (define-key map mouse-button-middle 'mouse-scroll-up-full))
;;; 
;;; ;; Horizontal bar
;;; 
;;; (fset 'mouse-horizontal-scroll-bar-prefix (make-sparse-keymap))
;;; (define-key global-mouse-map mouse-horizontal-scroll-bar-prefix
;;;   'mouse-horizontal-scroll-bar-prefix)
;;; 
;;; (let ((map (function mouse-horizontal-scroll-bar-prefix)))
;;;   (define-key map mouse-button-right 'mouse-scroll-right)
;;;   (define-key map mouse-button-left 'mouse-scroll-left)
;;;   (define-key map mouse-button-middle 'mouse-scroll-absolute-horizontally))
;;; 
;;; (fset 'mouse-horizontal-thumbleft-prefix (make-sparse-keymap))
;;; (define-key global-mouse-map mouse-horizontal-thumbleft-prefix
;;;   'mouse-horizontal-thumbleft-prefix)
;;; 
;;; (let ((map (function mouse-horizontal-thumbleft-prefix)))
;;;   (define-key map mouse-button-right 'mouse-scroll-left-full)
;;;   (define-key map mouse-button-left 'mouse-scroll-left-full)
;;;   (define-key map mouse-button-middle 'mouse-scroll-left-full))
;;; 
;;; (fset 'mouse-horizontal-thumbright-prefix (make-sparse-keymap))
;;; (define-key global-mouse-map mouse-horizontal-thumbright-prefix
;;;   'mouse-horizontal-thumbright-prefix)
;;; 
;;; (let ((map (function mouse-horizontal-thumbright-prefix)))
;;;   (define-key map mouse-button-right 'mouse-scroll-right-full)
;;;   (define-key map mouse-button-left 'mouse-scroll-right-full)
;;;   (define-key map mouse-button-middle 'mouse-scroll-right-full))


;;;;
;;;; Here are experimental things being tested.  Mouse events
;;;; are of the form:
;;;;	((x y) window screen-part key-sequence timestamp)
;;
;;;;
;;;; Dynamically track mouse coordinates
;;;;
;;
;;(defun track-mouse (event)
;;  "Track the coordinates, absolute and relative, of the mouse."
;;  (interactive "@e")
;;  (while mouse-grabbed
;;    (let* ((pos (read-mouse-position (selected-screen)))
;;	   (abs-x (car pos))
;;	   (abs-y (cdr pos))
;;	   (relative-coordinate (coordinates-in-window-p
;;				 (list (car pos) (cdr pos))
;;				 (selected-window))))
;;      (if (consp relative-coordinate)
;;	  (message "mouse: [%d %d], (%d %d)" abs-x abs-y
;;		   (car relative-coordinate)
;;		   (car (cdr relative-coordinate)))
;;	(message "mouse: [%d %d]" abs-x abs-y)))))

;;
;; Dynamically put a box around the line indicated by point
;;

(require 'backquote)

(defun mouse-select-buffer-line (event)
  (interactive "@e")
  (let ((relative-coordinate
	 (coordinates-in-window-p (car event) (selected-window)))
	(abs-y (car (cdr (car event)))))
    (if (consp relative-coordinate)
	(progn
	  (save-excursion
	    (move-to-window-line (car (cdr relative-coordinate)))
	    (x-draw-rectangle
	     (selected-screen)
	     abs-y 0
	     (save-excursion
		 (move-to-window-line (car (cdr relative-coordinate)))
		 (end-of-line)
		 (push-mark nil t)
		 (beginning-of-line)
		 (- (region-end) (region-beginning))) 1)
	    (setq the-buffer (Buffer-menu-buffer t)))
	  (sit-for 1)
	  (x-erase-rectangle (selected-screen))))))

(defvar last-line-drawn nil)
(defvar begin-delim "[^ \t]")
(defvar end-delim   "[^ \t]")

(defun mouse-boxing (event)
  (interactive "@e")
  (save-excursion
    (let ((screen (selected-screen)))
      (while (= (x-mouse-events) 0)
	(let* ((pos (read-mouse-position screen))
	       (abs-x (car pos))
	       (abs-y (cdr pos))
	       (relative-coordinate
		(coordinates-in-window-p (` ((, abs-x) (, abs-y)))
					 (selected-window)))
	       (begin-reg nil)
	       (end-reg nil)
	       (end-column nil)
	       (begin-column nil))
	  (if (and (consp relative-coordinate)
		   (or (not last-line-drawn)
		       (not (= last-line-drawn abs-y))))
	      (progn
		(move-to-window-line (car (cdr relative-coordinate)))
		(if (= (following-char) 10)
		    ()
		  (progn
		    (setq begin-reg (1- (re-search-forward end-delim)))
		    (setq begin-column (1- (current-column)))
		    (end-of-line)
		    (setq end-reg (1+ (re-search-backward begin-delim)))
		    (setq end-column (1+ (current-column)))
		    (message "%s" (buffer-substring begin-reg end-reg))
		    (x-draw-rectangle screen
				      (setq last-line-drawn abs-y)
				      begin-column
				      (- end-column begin-column) 1))))))))))

(defun mouse-erase-box ()
  (interactive)
  (if last-line-drawn
      (progn
	(x-erase-rectangle (selected-screen))
	(setq last-line-drawn nil))))

;;; (defun test-x-rectangle ()
;;;   (use-local-mouse-map (setq rectangle-test-map (make-sparse-keymap)))
;;;   (define-key rectangle-test-map mouse-motion-button-left 'mouse-boxing)
;;;   (define-key rectangle-test-map mouse-button-left-up 'mouse-erase-box))

;;
;; Here is how to do double clicking in lisp.  About to change.
;;

(defvar double-start nil)
(defconst double-click-interval 300
  "Max ticks between clicks")

(defun double-down (event)
  (interactive "@e")
  (if double-start
      (let ((interval (- (nth 4 event) double-start)))
	(if (< interval double-click-interval)
	    (progn
	      (backward-up-list 1)
	      ;;      (message "Interval %d" interval)
	      (sleep-for 1)))
	(setq double-start nil))
    (setq double-start (nth 4 event))))
    
(defun double-up (event)
  (interactive "@e")
  (and double-start
       (> (- (nth 4 event ) double-start) double-click-interval)
       (setq double-start nil)))

;;; (defun x-test-doubleclick ()
;;;   (use-local-mouse-map (setq doubleclick-test-map (make-sparse-keymap)))
;;;   (define-key doubleclick-test-map mouse-button-left 'double-down)
;;;   (define-key doubleclick-test-map mouse-button-left-up 'double-up))

;;
;; This scrolls while button is depressed.  Use preferable in scrollbar.
;;

(defvar scrolled-lines 0)
(defconst scroll-speed 1)

(defun incr-scroll-down (event)
  (interactive "@e")
  (setq scrolled-lines 0)
  (incremental-scroll scroll-speed))

(defun incr-scroll-up (event)
  (interactive "@e")
  (setq scrolled-lines 0)
  (incremental-scroll (- scroll-speed)))

(defun incremental-scroll (n)
  (while (= (x-mouse-events) 0)
    (setq scrolled-lines (1+ (* scroll-speed scrolled-lines)))
    (scroll-down n)
    (sit-for 300 t)))

(defun incr-scroll-stop (event)
  (interactive "@e")
  (message "Scrolled %d lines" scrolled-lines)
  (setq scrolled-lines 0)
  (sleep-for 1))

;;; (defun x-testing-scroll ()
;;;   (let ((scrolling-map (function mouse-vertical-scroll-bar-prefix)))
;;;     (define-key scrolling-map mouse-button-left 'incr-scroll-down)
;;;     (define-key scrolling-map mouse-button-right 'incr-scroll-up)
;;;     (define-key scrolling-map mouse-button-left-up 'incr-scroll-stop)
;;;     (define-key scrolling-map mouse-button-right-up 'incr-scroll-stop)))

;;
;; Some playthings suitable for picture mode?  They need work.
;;

(defun mouse-kill-rectangle (event)
  "Kill the rectangle between point and the mouse cursor."
  (interactive "@e")
  (let ((point-save (point)))
    (save-excursion
      (mouse-set-point event)
      (push-mark nil t)
      (if (> point-save (point))
	  (kill-rectangle (point) point-save)
	(kill-rectangle point-save (point))))))

(defun mouse-open-rectangle (event)
  "Kill the rectangle between point and the mouse cursor."
  (interactive "@e")
  (let ((point-save (point)))
    (save-excursion
      (mouse-set-point event)
      (push-mark nil t)
      (if (> point-save (point))
	  (open-rectangle (point) point-save)
	(open-rectangle point-save (point))))))

;; Must be a better way to do this.

(defun mouse-multiple-insert (n char)
  (while (> n 0)
    (insert char)
    (setq n (1- n))))

;; What this could do is not finalize until button was released.

(defun mouse-move-text (event)
  "Move text from point to cursor position, inserting spaces."
  (interactive "@e")
  (let* ((relative-coordinate
	  (coordinates-in-window-p (car event) (selected-window))))
    (if (consp relative-coordinate)
	(cond ((> (current-column) (car relative-coordinate))
	       (delete-char
		(- (car relative-coordinate) (current-column))))
	      ((< (current-column) (car relative-coordinate))
	       (mouse-multiple-insert
		(- (car relative-coordinate) (current-column)) " "))
	      ((= (current-column) (car relative-coordinate)) (ding))))))

\f
;;; Bindings for mouse commands.

(global-set-key   [mouse-1]	'mouse-set-point)
(global-set-key [S-mouse-1]	'mouse-set-mark)
(global-set-key   [mouse-3]	'mouse-delete-other-windows)
Commit	Line	Data
cc0a8174 JB	1	;;; Window system-independent mouse support.
cc0a8174 JB	2	;;; Copyright (C) 1988 Free Software Foundation, Inc.
72ea54a4	3
cc0a8174	4	;;; This file is part of GNU Emacs.
72ea54a4	5
cc0a8174 JB	6	;;; GNU Emacs is free software; you can redistribute it and/or modify
	7	;;; it under the terms of the GNU General Public License as published by
	8	;;; the Free Software Foundation; either version 1, or (at your option)
	9	;;; any later version.
72ea54a4	10
cc0a8174 JB	11	;;; GNU Emacs is distributed in the hope that it will be useful,
	12	;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
	13	;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	14	;;; GNU General Public License for more details.
72ea54a4	15
cc0a8174 JB	16	;;; You should have received a copy of the GNU General Public License
	17	;;; along with GNU Emacs; see the file COPYING. If not, write to
	18	;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
72ea54a4 RS	19
	20	(provide 'mouse)
	21
	22	\f
cc0a8174	23	;;; Utility functions.
72ea54a4	24
cc0a8174 JB	25	(defun mouse-movement-p (event)
	26	(and (consp event)
	27	(eq (car event) 'mouse-movement)))
72ea54a4	28
cc0a8174 JB	29	(defun event-window (event) (nth 1 event))
	30	(defun event-point (event) (nth 2 event))
	31	(defun mouse-coords (event) (nth 3 event))
	32	(defun mouse-timestamp (event) (nth 4 event))
72ea54a4	33
cc0a8174 JB	34	;;; Indent track-mouse like progn.
cc0a8174 JB	35	(put 'track-mouse 'lisp-indent-function 0)
72ea54a4	36
cc0a8174 JB	37	\f
	38	(defun mouse-delete-window (click)
	39	"Delete the window clicked on.
	40	This must be bound to a mouse click."
	41	(interactive "K")
	42	(delete-window (event-window click)))
	43
	44	(defun mouse-delete-other-windows (click)
	45	"Select Emacs window clicked on, then kill all other Emacs windows.
	46	This must be bound to a mouse click."
	47	(interactive "K")
	48	(select-window (event-window click))
	49	(delete-other-windows))
72ea54a4	50
cc0a8174 JB	51	(defun mouse-split-window-vertically (click)
	52	"Select Emacs window mouse is on, then split it vertically in half.
	53	The window is split at the line clicked on.
	54	This command must be bound to a mouse click."
	55	(interactive "K")
	56	(select-window (event-window click))
	57	(split-window-vertically (1+ (cdr (mouse-coords click)))))
	58
	59	(defun mouse-set-point (click)
	60	"Move point to the position clicked on with the mouse.
	61	This must be bound to a mouse click."
	62	(interactive "K")
	63	(select-window (event-window click))
	64	(goto-char (event-point click)))
	65
	66	(defun mouse-set-mark (click)
	67	"Set mark at the position clicked on with the mouse.
	68	Display cursor at that position for a second.
	69	This must be bound to a mouse click."
	70	(interactive "K")
72ea54a4 RS	71	(let ((point-save (point)))
72ea54a4 RS	72	(unwind-protect
cc0a8174	73	(progn (mouse-set-point click)
72ea54a4	74	(push-mark nil t)
fe79ff61	75	(sit-for 1))
72ea54a4 RS	76	(goto-char point-save))))
72ea54a4 RS	77
cc0a8174 JB	78	(defun mouse-kill (click)
	79	"Kill the region between point and the mouse click.
	80	The text is saved in the kill ring, as with \\[kill-region]."
	81	(interactive "K")
	82	(mouse-set-mark click)
	83	(kill-region))
72ea54a4	84
cc0a8174 JB	85	(defun mouse-kill-ring-save
	86	"Copy the region between point and the mouse click in the kill ring.
	87	This does not delete the region; it acts like \\[kill-ring-save]."
	88	(interactive "K")
	89	(mouse-set-mark click)
	90	(kill-ring-save))
72ea54a4	91
72ea54a4	92
72ea54a4 RS	93	\f
	94	;; Commands for the scroll bar.
	95
	96	(defun mouse-scroll-down (nlines)
	97	(interactive "@p")
	98	(scroll-down nlines))
	99
	100	(defun mouse-scroll-up (nlines)
	101	(interactive "@p")
	102	(scroll-up nlines))
	103
	104	(defun mouse-scroll-down-full ()
	105	(interactive "@")
	106	(scroll-down nil))
	107
	108	(defun mouse-scroll-up-full ()
	109	(interactive "@")
	110	(scroll-up nil))
	111
	112	(defun mouse-scroll-move-cursor (nlines)
	113	(interactive "@p")
	114	(move-to-window-line nlines))
	115
	116	(defun mouse-scroll-absolute (event)
	117	(interactive "@e")
	118	(let* ((pos (car event))
	119	(position (car pos))
	120	(length (car (cdr pos))))
	121	(if (<= length 0) (setq length 1))
	122	(let* ((scale-factor (max 1 (/ length (/ 8000000 (buffer-size)))))
	123	(newpos (* (/ (* (/ (buffer-size) scale-factor)
	124	position)
	125	length)
	126	scale-factor)))
	127	(goto-char newpos)
	128	(recenter '(4)))))
	129
	130	(defun mouse-scroll-left (ncolumns)
	131	(interactive "@p")
	132	(scroll-left ncolumns))
	133
	134	(defun mouse-scroll-right (ncolumns)
	135	(interactive "@p")
	136	(scroll-right ncolumns))
	137
	138	(defun mouse-scroll-left-full ()
	139	(interactive "@")
	140	(scroll-left nil))
	141
	142	(defun mouse-scroll-right-full ()
	143	(interactive "@")
	144	(scroll-right nil))
	145
	146	(defun mouse-scroll-move-cursor-horizontally (ncolumns)
	147	(interactive "@p")
	148	(move-to-column ncolumns))
	149
	150	(defun mouse-scroll-absolute-horizontally (event)
	151	(interactive "@e")
	152	(let* ((pos (car event))
	153	(position (car pos))
	154	(length (car (cdr pos))))
	155	(set-window-hscroll (selected-window) 33)))
	156
157	;; Set up these commands, including the prefix keys for the scroll bar.
158
cc0a8174 JB	159	;;; (fset 'mouse-vertical-scroll-bar-prefix (make-sparse-keymap))
	160	;;; (define-key global-mouse-map mouse-vertical-scroll-bar-prefix
	161	;;; 'mouse-vertical-scroll-bar-prefix)
	162	;;;
	163	;;; (defun mouse-scroll-motion (event)
	164	;;; (interactive "e")
	165	;;; (let ((pos (car (car event)))
	166	;;; (length (car (cdr (car event)))))
	167	;;; (message "[%d %d]" pos length)))
	168	;;;
	169	;;; (let ((map (function mouse-vertical-scroll-bar-prefix)))
	170	;;; (define-key map mouse-button-right 'mouse-scroll-down)
	171	;;; (define-key map mouse-button-left 'mouse-scroll-up)
	172	;;; (define-key map mouse-button-middle 'mouse-scroll-absolute)
	173	;;; (define-key map mouse-motion 'x-horizontal-line))
	174	;;;
	175	;;; ;(fset 'mouse-vertical-slider-prefix (make-sparse-keymap))
	176	;;; ;(define-key global-mouse-map mouse-vertical-slider-prefix
	177	;;; ; 'mouse-vertical-slider-prefix)
	178	;;;
	179	;;; ;(let ((map (function mouse-vertical-slider-prefix)))
	180	;;; ; (define-key map mouse-button-right 'mouse-scroll-move-cursor)
	181	;;; ; (define-key map mouse-button-left 'mouse-scroll-move-cursor)
	182	;;; ; (define-key map mouse-button-middle 'mouse-scroll-move-cursor))
	183	;;;
	184	;;; (fset 'mouse-vertical-thumbup-prefix (make-sparse-keymap))
	185	;;; (define-key global-mouse-map mouse-vertical-thumbup-prefix
	186	;;; 'mouse-vertical-thumbup-prefix)
	187	;;;
	188	;;; (let ((map (function mouse-vertical-thumbup-prefix)))
	189	;;; (define-key map mouse-button-right 'mouse-scroll-down-full)
	190	;;; (define-key map mouse-button-left 'mouse-scroll-down-full)
	191	;;; (define-key map mouse-button-middle 'mouse-scroll-down-full))
	192	;;;
	193	;;; (fset 'mouse-vertical-thumbdown-prefix (make-sparse-keymap))
	194	;;; (define-key global-mouse-map mouse-vertical-thumbdown-prefix
	195	;;; 'mouse-vertical-thumbdown-prefix)
	196	;;;
	197	;;; (let ((map (function mouse-vertical-thumbdown-prefix)))
	198	;;; (define-key map mouse-button-right 'mouse-scroll-up-full)
	199	;;; (define-key map mouse-button-left 'mouse-scroll-up-full)
	200	;;; (define-key map mouse-button-middle 'mouse-scroll-up-full))
	201	;;;
	202	;;; ;; Horizontal bar
	203	;;;
	204	;;; (fset 'mouse-horizontal-scroll-bar-prefix (make-sparse-keymap))
	205	;;; (define-key global-mouse-map mouse-horizontal-scroll-bar-prefix
	206	;;; 'mouse-horizontal-scroll-bar-prefix)
	207	;;;
	208	;;; (let ((map (function mouse-horizontal-scroll-bar-prefix)))
	209	;;; (define-key map mouse-button-right 'mouse-scroll-right)
	210	;;; (define-key map mouse-button-left 'mouse-scroll-left)
	211	;;; (define-key map mouse-button-middle 'mouse-scroll-absolute-horizontally))
	212	;;;
	213	;;; (fset 'mouse-horizontal-thumbleft-prefix (make-sparse-keymap))
	214	;;; (define-key global-mouse-map mouse-horizontal-thumbleft-prefix
	215	;;; 'mouse-horizontal-thumbleft-prefix)
	216	;;;
	217	;;; (let ((map (function mouse-horizontal-thumbleft-prefix)))
	218	;;; (define-key map mouse-button-right 'mouse-scroll-left-full)
	219	;;; (define-key map mouse-button-left 'mouse-scroll-left-full)
	220	;;; (define-key map mouse-button-middle 'mouse-scroll-left-full))
	221	;;;
	222	;;; (fset 'mouse-horizontal-thumbright-prefix (make-sparse-keymap))
223	;;; (define-key global-mouse-map mouse-horizontal-thumbright-prefix
224	;;; 'mouse-horizontal-thumbright-prefix)
225	;;;
226	;;; (let ((map (function mouse-horizontal-thumbright-prefix)))
227	;;; (define-key map mouse-button-right 'mouse-scroll-right-full)
228	;;; (define-key map mouse-button-left 'mouse-scroll-right-full)
229	;;; (define-key map mouse-button-middle 'mouse-scroll-right-full))
72ea54a4 RS	230
72ea54a4 RS	231
84545e78 JB	232	;;;;
	233	;;;; Here are experimental things being tested. Mouse events
	234	;;;; are of the form:
	235	;;;; ((x y) window screen-part key-sequence timestamp)
72ea54a4	236	;;
84545e78 JB	237	;;;;
	238	;;;; Dynamically track mouse coordinates
	239	;;;;
72ea54a4	240	;;
84545e78 JB	241	;;(defun track-mouse (event)
	242	;; "Track the coordinates, absolute and relative, of the mouse."
	243	;; (interactive "@e")
	244	;; (while mouse-grabbed
	245	;; (let* ((pos (read-mouse-position (selected-screen)))
	246	;; (abs-x (car pos))
	247	;; (abs-y (cdr pos))
	248	;; (relative-coordinate (coordinates-in-window-p
	249	;; (list (car pos) (cdr pos))
	250	;; (selected-window))))
	251	;; (if (consp relative-coordinate)
	252	;; (message "mouse: [%d %d], (%d %d)" abs-x abs-y
	253	;; (car relative-coordinate)
	254	;; (car (cdr relative-coordinate)))
	255	;; (message "mouse: [%d %d]" abs-x abs-y)))))
72ea54a4 RS	256
	257	;;
	258	;; Dynamically put a box around the line indicated by point
	259	;;
	260
	261	(require 'backquote)
	262
	263	(defun mouse-select-buffer-line (event)
	264	(interactive "@e")
	265	(let ((relative-coordinate
	266	(coordinates-in-window-p (car event) (selected-window)))
	267	(abs-y (car (cdr (car event)))))
	268	(if (consp relative-coordinate)
	269	(progn
	270	(save-excursion
	271	(move-to-window-line (car (cdr relative-coordinate)))
	272	(x-draw-rectangle
	273	(selected-screen)
	274	abs-y 0
	275	(save-excursion
	276	(move-to-window-line (car (cdr relative-coordinate)))
	277	(end-of-line)
	278	(push-mark nil t)
	279	(beginning-of-line)
	280	(- (region-end) (region-beginning))) 1)
	281	(setq the-buffer (Buffer-menu-buffer t)))
	282	(sit-for 1)
	283	(x-erase-rectangle (selected-screen))))))
	284
	285	(defvar last-line-drawn nil)
	286	(defvar begin-delim "[^ \t]")
	287	(defvar end-delim "[^ \t]")
	288
	289	(defun mouse-boxing (event)
	290	(interactive "@e")
	291	(save-excursion
	292	(let ((screen (selected-screen)))
	293	(while (= (x-mouse-events) 0)
	294	(let* ((pos (read-mouse-position screen))
	295	(abs-x (car pos))
	296	(abs-y (cdr pos))
	297	(relative-coordinate
	298	(coordinates-in-window-p (` ((, abs-x) (, abs-y)))
	299	(selected-window)))
	300	(begin-reg nil)
	301	(end-reg nil)
	302	(end-column nil)
	303	(begin-column nil))
	304	(if (and (consp relative-coordinate)
	305	(or (not last-line-drawn)
	306	(not (= last-line-drawn abs-y))))
	307	(progn
	308	(move-to-window-line (car (cdr relative-coordinate)))
	309	(if (= (following-char) 10)
	310	()
	311	(progn
	312	(setq begin-reg (1- (re-search-forward end-delim)))
	313	(setq begin-column (1- (current-column)))
	314	(end-of-line)
	315	(setq end-reg (1+ (re-search-backward begin-delim)))
	316	(setq end-column (1+ (current-column)))
	317	(message "%s" (buffer-substring begin-reg end-reg))
	318	(x-draw-rectangle screen
	319	(setq last-line-drawn abs-y)
320	begin-column
321	(- end-column begin-column) 1))))))))))
322
323	(defun mouse-erase-box ()
324	(interactive)
325	(if last-line-drawn
326	(progn
327	(x-erase-rectangle (selected-screen))
328	(setq last-line-drawn nil))))
329
cc0a8174 JB	330	;;; (defun test-x-rectangle ()
	331	;;; (use-local-mouse-map (setq rectangle-test-map (make-sparse-keymap)))
	332	;;; (define-key rectangle-test-map mouse-motion-button-left 'mouse-boxing)
	333	;;; (define-key rectangle-test-map mouse-button-left-up 'mouse-erase-box))
72ea54a4 RS	334
	335	;;
	336	;; Here is how to do double clicking in lisp. About to change.
	337	;;
	338
	339	(defvar double-start nil)
	340	(defconst double-click-interval 300
	341	"Max ticks between clicks")
	342
	343	(defun double-down (event)
	344	(interactive "@e")
	345	(if double-start
	346	(let ((interval (- (nth 4 event) double-start)))
	347	(if (< interval double-click-interval)
	348	(progn
	349	(backward-up-list 1)
	350	;; (message "Interval %d" interval)
	351	(sleep-for 1)))
	352	(setq double-start nil))
	353	(setq double-start (nth 4 event))))
	354
	355	(defun double-up (event)
	356	(interactive "@e")
	357	(and double-start
	358	(> (- (nth 4 event ) double-start) double-click-interval)
	359	(setq double-start nil)))
	360
cc0a8174 JB	361	;;; (defun x-test-doubleclick ()
	362	;;; (use-local-mouse-map (setq doubleclick-test-map (make-sparse-keymap)))
	363	;;; (define-key doubleclick-test-map mouse-button-left 'double-down)
	364	;;; (define-key doubleclick-test-map mouse-button-left-up 'double-up))
72ea54a4 RS	365
	366	;;
	367	;; This scrolls while button is depressed. Use preferable in scrollbar.
	368	;;
	369
	370	(defvar scrolled-lines 0)
	371	(defconst scroll-speed 1)
	372
	373	(defun incr-scroll-down (event)
	374	(interactive "@e")
	375	(setq scrolled-lines 0)
	376	(incremental-scroll scroll-speed))
	377
	378	(defun incr-scroll-up (event)
	379	(interactive "@e")
	380	(setq scrolled-lines 0)
	381	(incremental-scroll (- scroll-speed)))
	382
	383	(defun incremental-scroll (n)
	384	(while (= (x-mouse-events) 0)
	385	(setq scrolled-lines (1+ (* scroll-speed scrolled-lines)))
	386	(scroll-down n)
	387	(sit-for 300 t)))
	388
	389	(defun incr-scroll-stop (event)
	390	(interactive "@e")
	391	(message "Scrolled %d lines" scrolled-lines)
	392	(setq scrolled-lines 0)
	393	(sleep-for 1))
	394
cc0a8174 JB	395	;;; (defun x-testing-scroll ()
	396	;;; (let ((scrolling-map (function mouse-vertical-scroll-bar-prefix)))
	397	;;; (define-key scrolling-map mouse-button-left 'incr-scroll-down)
	398	;;; (define-key scrolling-map mouse-button-right 'incr-scroll-up)
	399	;;; (define-key scrolling-map mouse-button-left-up 'incr-scroll-stop)
	400	;;; (define-key scrolling-map mouse-button-right-up 'incr-scroll-stop)))
72ea54a4 RS	401
	402	;;
	403	;; Some playthings suitable for picture mode? They need work.
	404	;;
	405
	406	(defun mouse-kill-rectangle (event)
	407	"Kill the rectangle between point and the mouse cursor."
	408	(interactive "@e")
	409	(let ((point-save (point)))
	410	(save-excursion
	411	(mouse-set-point event)
	412	(push-mark nil t)
	413	(if (> point-save (point))
	414	(kill-rectangle (point) point-save)
	415	(kill-rectangle point-save (point))))))
	416
	417	(defun mouse-open-rectangle (event)
	418	"Kill the rectangle between point and the mouse cursor."
	419	(interactive "@e")
	420	(let ((point-save (point)))
	421	(save-excursion
	422	(mouse-set-point event)
	423	(push-mark nil t)
	424	(if (> point-save (point))
	425	(open-rectangle (point) point-save)
	426	(open-rectangle point-save (point))))))
	427
	428	;; Must be a better way to do this.
	429
	430	(defun mouse-multiple-insert (n char)
	431	(while (> n 0)
	432	(insert char)
	433	(setq n (1- n))))
	434
	435	;; What this could do is not finalize until button was released.
	436
	437	(defun mouse-move-text (event)
	438	"Move text from point to cursor position, inserting spaces."
	439	(interactive "@e")
	440	(let* ((relative-coordinate
	441	(coordinates-in-window-p (car event) (selected-window))))
	442	(if (consp relative-coordinate)
	443	(cond ((> (current-column) (car relative-coordinate))
	444	(delete-char
	445	(- (car relative-coordinate) (current-column))))
	446	((< (current-column) (car relative-coordinate))
	447	(mouse-multiple-insert
	448	(- (car relative-coordinate) (current-column)) " "))
	449	((= (current-column) (car relative-coordinate)) (ding))))))
cc0a8174 JB	450
	451	\f
	452	;;; Bindings for mouse commands.
	453
	454	(global-set-key [mouse-1] 'mouse-set-point)
	455	(global-set-key [S-mouse-1] 'mouse-set-mark)
	456	(global-set-key [mouse-3] 'mouse-delete-other-windows)