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