summaryrefslogtreecommitdiff
path: root/lisp/avoid.el
blob: 4490d0b6dd0c582afbfd2d9002645bdf1d8c498f (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
;;; avoid.el -- make mouse pointer stay out of the way of editing.

;;; Copyright (C) 1993, 1994 Free Software Foundation, Inc.

;; Author: Boris Goldowsky <boris@cs.rochester.edu>
;; Keywords: mouse
;; Version: 1.10

;; 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 2, 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.

;;; Commentary:
;;;
;;; For those who are annoyed by the mouse pointer obscuring text,
;;; this mode moves the mouse pointer - either just a little out of
;;; the way, or all the way to the corner of the frame. 
;;; To use, load or evaluate this file and type M-x mouse-avoidance-mode .
;;; To set up permanently, put this file on your load-path and put the
;;; following in your .emacs: 
;;;
;;; (cond (window-system
;;;        (require 'avoid)
;;;        (mouse-avoidance-mode 'cat-and-mouse)))
;;;
;;; The 'cat-and-mouse can be
;;; 'banish or 'jump or 'animate or 'proteus if you prefer.
;;; See the documentation for function `mouse-avoidance-mode' for
;;; details of the different modes.
;;;
;;; For added silliness, make the animatee animate...
;;; put something similar to the following into your .emacs:
;;;
;;; (cond (window-system
;;;       (setq x-pointer-shape 
;;;	     (eval (nth (random 4)
;;;			'(x-pointer-man x-pointer-spider
;;;			  x-pointer-gobbler x-pointer-gumby))))
;;;       (set-mouse-color (cdr (assoc 'mouse-color (frame-parameters))))))
;;;
;;; For completely random pointer shape, replace the setq above with:
;;; (setq x-pointer-shape (mouse-avoidance-random-shape))
;;; 
;;; Bugs & Warnings:
;;;
;;; - Due to a bug in (mouse-position), this code can cause emacs
;;;   19.22 to crash when deleting a frame if the mouse has not moved
;;;   since creating the frame.  Versions earlier than 19.21 will
;;;   crash more easily; this program should not be used with them.
;;;
;;; - Using this code does slow emacs down.  "banish" mode shouldn't
;;;   ever be too bad though, and on my workstation even "animate" doesn't
;;;   seem to have a noticable effect.
;;;
;;; - There are some situations where it doesn't do what you expect,
;;;   notably when there are long wrapped lines in the buffer.  Since
;;;   there is no low-level command for finding point's position
;;;   on the screen, it can fail to move the pointer when on such a line.

;;; Credits:
;;; This code was helped by all those who contributed suggestions, fixes, and 
;;; additions:
;;; Joe Harrington (and his advisor), for the original inspiration
;;; Ken Manheimer, for dreaming up the Protean mode
;;; Richard Stallman, for the awful cat-and-mouse pun, among other things
;;; Mike Williams, Denis Howe, Bill Benedetto, Chris Moore, Don Morris,
;;; Simon Marshall, and M.S. Ashton, for their feedback.
;;;
;;; Code:

(provide 'avoid)

(defvar mouse-avoidance-mode nil
  "Value is t or a symbol if the mouse pointer should avoid the cursor.
See function mouse-avoidance-mode for possible values.  Changing this
variable is NOT the recommended way to change modes; use the function 
instead.")

(defvar mouse-avoidance-nudge-dist 4
  "*Average distance that mouse will be moved when approached by cursor.
Only applies in mode-avoidance-modes `animate' and `jump'.")

(defvar mouse-avoidance-nudge-var 3
  "*Variability of mouse-avoidance-nudge-dist (which see).")

(defvar mouse-avoidance-animation-delay .01
  "Delay between animation steps, in seconds.")

(defvar mouse-avoidance-threshhold 5
  "*Mouse-pointer's flight distance.
If the cursor gets closer than this, the mouse pointer will move away.
Only applies in mouse-avoidance-modes `animate' and `jump'.")

;; Internal variables for mouse-avoidance-random-shape
(defvar mouse-avoidance-pointer-shapes nil)
(defvar mouse-avoidance-n-pointer-shapes 0)

;;; Functions:

(defun mouse-avoidance-too-close-p ()
  ;;  Return t if mouse pointer and point cursor are too close.
  ;; Acceptable distance is defined by mouse-avoidance-threshhold.
  (let ((mouse (mouse-position)))
    (and (car (cdr mouse))
	 (< (abs (- (car (cdr mouse)) (current-column)))
	    mouse-avoidance-threshhold)
	 (< (abs (- (cdr (cdr mouse)) 
		    (+ (car (cdr (window-edges)))
		       (count-lines (window-start) (point)))))
	    mouse-avoidance-threshhold))))

(defun mouse-avoidance-banish-mouse ()
  ;; Put the mouse pointer in the upper-right corner of the current frame.
  (set-mouse-position (selected-frame) (1- (frame-width)) 0))

(defun mouse-avoidance-nudge-mouse () 
  ;; Push the mouse a little way away, possibly animating the move
  (let* ((cur (mouse-position))
	 (deltax (* (+ mouse-avoidance-nudge-dist 
		       (random mouse-avoidance-nudge-var))
		    (if (zerop (random 2)) 1 -1)))
	 (deltay (* (+ mouse-avoidance-nudge-dist
		       (random mouse-avoidance-nudge-var))
		    (if (zerop (random 2)) 1 -1))))
    (if (or (eq mouse-avoidance-mode 'animate) 
	    (eq mouse-avoidance-mode 'proteus))
	(let ((i 0.0)
	      (color (cdr (assoc 'mouse-color (frame-parameters)))))
	  (while (<= i 1)
	    (set-mouse-position 
	     (car cur) 
	     (mod (+ (car (cdr cur)) (round (* i deltax))) (frame-width))
	     (mod (+ (cdr (cdr cur)) (round (* i deltay))) (frame-height)))
	    (setq i (+ i (/ 1.0 mouse-avoidance-nudge-dist)))
	    (if (eq mouse-avoidance-mode 'proteus)
		(progn
		  (setq x-pointer-shape (mouse-avoidance-random-shape))
		  (set-mouse-color color)))
	    (sit-for mouse-avoidance-animation-delay)))
      (set-mouse-position 
       (car cur)
       (mod (+ (car (cdr cur)) deltax) (window-width))
       (mod (+ (cdr (cdr cur)) deltay) (window-height))))))

(defun mouse-avoidance-random-shape ()
  "Return a random cursor shape.
This assumes that any variable whose name begins with x-pointer- and
has an integer value is a valid cursor shape.  You might want to
redefine this function to suit your own tastes."
  (if (null mouse-avoidance-pointer-shapes)
      (progn
	(setq mouse-avoidance-pointer-shapes
	      (mapcar '(lambda (x) (symbol-value (intern x)))
		      (all-completions "x-pointer-" obarray
				       '(lambda (x) 
					  (and (boundp x)
					       (integerp (symbol-value x)))))))
	(setq mouse-avoidance-n-pointer-shapes 
	      (length mouse-avoidance-pointer-shapes))))
  (nth (random mouse-avoidance-n-pointer-shapes)
       mouse-avoidance-pointer-shapes))

(defun mouse-avoidance-simple-hook ()
  (if (and (mouse-avoidance-keyboard-command (this-command-keys)))
      (progn
	(raise-frame (selected-frame))
	(mouse-avoidance-banish-mouse))))

(defun mouse-avoidance-fancy-hook ()
  (if (and (mouse-avoidance-keyboard-command (this-command-keys))
	   (mouse-avoidance-too-close-p))
      (let ((old-pos (mouse-position)))
	(mouse-avoidance-nudge-mouse)
	(if (not (eq (selected-frame) (car old-pos)))
	    (apply 'set-mouse-position old-pos)))))

(defun mouse-avoidance-keyboard-command (key)
  "Return t if the KEYSEQENCE is composed of keyboard events only.
Returns nil if there are any lists in the key sequence."
  (cond ((null key) nil)		; Null event seems to be
					; returned occasionally.
	((not (vectorp key)) t)		; Strings are keyboard events.
	((catch 'done
	   (let ((i 0)
		 (l (length key)))
	     (while (< i l)
	       (if (listp (aref key i))
		   (throw 'done nil))
	       (setq i (1+ i))))
	   t))))

(defun mouse-avoidance-mode (&optional mode)
  "Set cursor avoidance mode to MODE.
MODE should be one of the symbols `banish', `jump', `animate',
`cat-and-mouse', `proteus', or `none'.

If MODE is nil, toggle mouse avoidance between `none' and `banish'
modes.  Positive numbers and symbols other than the above are treated
as equivalent to `banish'; negative numbers and `-' are equivalent to `none'.

Effects of the different modes: 
 * BANISH: Move the mouse to the upper-right corner on any keypress.
           Also raises the frame.
 * JUMP: If the cursor gets too close to the mouse, displace the mouse
         a random distance & direction.  If this would put it in another,
         overlapping frame, it is put back \(until the next keypress).
 * ANIMATE: As `jump', but shows steps along the way for illusion of motion.
 * CAT-AND-MOUSE: Same as `animate'.
 * PROTEUS: As `animate', but changes the shape of the mouse pointer too.

\(see `mouse-avoidance-threshhold' for definition of \"too close\",
and `mouse-avoidance-nudge-dist' and `mouse-avoidance-nudge-var' for
definition of \"random distance\".)"
  (interactive
   (list (intern (completing-read
		  "Select cursor avoidance technique (SPACE for list): "
		  '(("banish") ("jump") ("animate") ("cat-and-mouse") 
		    ("proteus") ("none"))
		  nil t))))
  (if (eq mode 'cat-and-mouse)
      (setq mode 'animate))
  (setq post-command-hook
	(delete 'mouse-avoidance-simple-hook (append post-command-hook nil)))
  (setq post-command-hook
	(delete 'mouse-avoidance-fancy-hook (append post-command-hook nil)))
  (cond	((eq mode 'none)
	 (setq mouse-avoidance-mode nil))
	((or (eq mode 'jump)
	     (eq mode 'animate)
	     (eq mode 'proteus))
	 (add-hook 'post-command-hook 'mouse-avoidance-fancy-hook)
	 (setq mouse-avoidance-mode mode))
	((or (eq mode 'banish) 
	     (eq mode t)
	     (and (null mode) (null mouse-avoidance-mode))
	     (and mode (> (prefix-numeric-value mode) 0)))
	 (add-hook 'post-command-hook 'mouse-avoidance-simple-hook)
	 (setq mouse-avoidance-mode 'banish))
	(t (setq mouse-avoidance-mode nil))))

(or (assq 'mouse-avoidance-mode minor-mode-alist)
    (setq minor-mode-alist (cons '(mouse-avoidance-mode " Avoid")
				 minor-mode-alist)))

;;; End of avoid.el