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