[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.

\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)

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