lisp/avoid.el

   1 ;;; avoid.el -- make mouse pointer stay out of the way of editing.
   2
   3 ;;; Copyright (C) 1993, 1994 Free Software Foundation, Inc.
   4
   5 ;; Author: Boris Goldowsky <boris@cs.rochester.edu>
   6 ;; Keywords: mouse
   7 ;; Version: 1.10
   8
   9 ;; This file is part of GNU Emacs.
  10
  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
  13 ;; the Free Software Foundation; either version 2, or (at your option)
  14 ;; any later version.
  15
  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.
  20
  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.
  24
  25 ;;; Commentary:
  26 ;;;
  27 ;;; For those who are annoyed by the mouse pointer obscuring text,
  28 ;;; this mode moves the mouse pointer - either just a little out of
  29 ;;; the way, or all the way to the corner of the frame.
  30 ;;; To use, load or evaluate this file and type M-x mouse-avoidance-mode .
  31 ;;; To set up permanently, put this file on your load-path and put the
  32 ;;; following in your .emacs:
  33 ;;;
  34 ;;; (cond (window-system
  35 ;;;        (require 'avoid)
  36 ;;;        (mouse-avoidance-mode 'cat-and-mouse)))
  37 ;;;
  38 ;;; The 'cat-and-mouse can be
  39 ;;; 'banish or 'jump or 'animate or 'proteus if you prefer.
  40 ;;; See the documentation for function `mouse-avoidance-mode' for
  41 ;;; details of the different modes.
  42 ;;;
  43 ;;; For added silliness, make the animatee animate...
  44 ;;; put something similar to the following into your .emacs:
  45 ;;;
  46 ;;; (cond (window-system
  47 ;;;       (setq x-pointer-shape
  48 ;;;          (eval (nth (random 4)
  49 ;;;                     '(x-pointer-man x-pointer-spider
  50 ;;;                       x-pointer-gobbler x-pointer-gumby))))
  51 ;;;       (set-mouse-color (cdr (assoc 'mouse-color (frame-parameters))))))
  52 ;;;
  53 ;;; For completely random pointer shape, replace the setq above with:
  54 ;;; (setq x-pointer-shape (mouse-avoidance-random-shape))
  55 ;;;
  56 ;;; Bugs & Warnings:
  57 ;;;
  58 ;;; - Due to a bug in (mouse-position), this code can cause emacs
  59 ;;;   19.22 to crash when deleting a frame if the mouse has not moved
  60 ;;;   since creating the frame.  Versions earlier than 19.21 will
  61 ;;;   crash more easily; this program should not be used with them.
  62 ;;;
  63 ;;; - Using this code does slow emacs down.  "banish" mode shouldn't
  64 ;;;   ever be too bad though, and on my workstation even "animate" doesn't
  65 ;;;   seem to have a noticable effect.
  66 ;;;
  67 ;;; - There are some situations where it doesn't do what you expect,
  68 ;;;   notably when there are long wrapped lines in the buffer.  Since
  69 ;;;   there is no low-level command for finding point's position
  70 ;;;   on the screen, it can fail to move the pointer when on such a line.
  71
  72 ;;; Credits:
  73 ;;; This code was helped by all those who contributed suggestions, fixes, and
  74 ;;; additions:
  75 ;;; Joe Harrington (and his advisor), for the original inspiration
  76 ;;; Ken Manheimer, for dreaming up the Protean mode
  77 ;;; Richard Stallman, for the awful cat-and-mouse pun, among other things
  78 ;;; Mike Williams, Denis Howe, Bill Benedetto, Chris Moore, Don Morris,
  79 ;;; Simon Marshall, and M.S. Ashton, for their feedback.
  80 ;;;
  81 ;;; Code:
  82
  83 (provide 'avoid)
  84
  85 (defvar mouse-avoidance-mode nil
  86   "Value is t or a symbol if the mouse pointer should avoid the cursor.
  87 See function mouse-avoidance-mode for possible values.  Changing this
  88 variable is NOT the recommended way to change modes; use the function
  89 instead.")
  90
  91 (defvar mouse-avoidance-nudge-dist 4
  92   "*Average distance that mouse will be moved when approached by cursor.
  93 Only applies in mode-avoidance-modes `animate' and `jump'.")
  94
  95 (defvar mouse-avoidance-nudge-var 3
  96   "*Variability of mouse-avoidance-nudge-dist (which see).")
  97
  98 (defvar mouse-avoidance-animation-delay .01
  99   "Delay between animation steps, in seconds.")
 100
 101 (defvar mouse-avoidance-threshhold 5
 102   "*Mouse-pointer's flight distance.
 103 If the cursor gets closer than this, the mouse pointer will move away.
 104 Only applies in mouse-avoidance-modes `animate' and `jump'.")
 105
 106 ;; Internal variables for mouse-avoidance-random-shape
 107 (defvar mouse-avoidance-pointer-shapes nil)
 108 (defvar mouse-avoidance-n-pointer-shapes 0)
 109
 110 ;;; Functions:
 111
 112 (defun mouse-avoidance-too-close-p ()
 113   ;;  Return t if mouse pointer and point cursor are too close.
 114   ;; Acceptable distance is defined by mouse-avoidance-threshhold.
 115   (let ((mouse (mouse-position)))
 116     (and (car (cdr mouse))
 117          (< (abs (- (car (cdr mouse)) (current-column)))
 118             mouse-avoidance-threshhold)
 119          (< (abs (- (cdr (cdr mouse))
 120                     (+ (car (cdr (window-edges)))
 121                        (count-lines (window-start) (point)))))
 122             mouse-avoidance-threshhold))))
 123
 124 (defun mouse-avoidance-banish-mouse ()
 125   ;; Put the mouse pointer in the upper-right corner of the current frame.
 126   (set-mouse-position (selected-frame) (1- (frame-width)) 0))
 127
 128 (defun mouse-avoidance-nudge-mouse ()
 129   ;; Push the mouse a little way away, possibly animating the move
 130   (let* ((cur (mouse-position))
 131          (deltax (* (+ mouse-avoidance-nudge-dist
 132                        (random mouse-avoidance-nudge-var))
 133                     (if (zerop (random 2)) 1 -1)))
 134          (deltay (* (+ mouse-avoidance-nudge-dist
 135                        (random mouse-avoidance-nudge-var))
 136                     (if (zerop (random 2)) 1 -1))))
 137     (if (or (eq mouse-avoidance-mode 'animate)
 138             (eq mouse-avoidance-mode 'proteus))
 139         (let ((i 0.0)
 140               (color (cdr (assoc 'mouse-color (frame-parameters)))))
 141           (while (<= i 1)
 142             (set-mouse-position
 143              (car cur)
 144              (mod (+ (car (cdr cur)) (round (* i deltax))) (frame-width))
 145              (mod (+ (cdr (cdr cur)) (round (* i deltay))) (frame-height)))
 146             (setq i (+ i (/ 1.0 mouse-avoidance-nudge-dist)))
 147             (if (eq mouse-avoidance-mode 'proteus)
 148                 (progn
 149                   (setq x-pointer-shape (mouse-avoidance-random-shape))
 150                   (set-mouse-color color)))
 151             (sit-for mouse-avoidance-animation-delay)))
 152       (set-mouse-position
 153        (car cur)
 154        (mod (+ (car (cdr cur)) deltax) (window-width))
 155        (mod (+ (cdr (cdr cur)) deltay) (window-height))))))
 156
 157 (defun mouse-avoidance-random-shape ()
 158   "Return a random cursor shape.
 159 This assumes that any variable whose name begins with x-pointer- and
 160 has an integer value is a valid cursor shape.  You might want to
 161 redefine this function to suit your own tastes."
 162   (if (null mouse-avoidance-pointer-shapes)
 163       (progn
 164         (setq mouse-avoidance-pointer-shapes
 165               (mapcar '(lambda (x) (symbol-value (intern x)))
 166                       (all-completions "x-pointer-" obarray
 167                                        '(lambda (x)
 168                                           (and (boundp x)
 169                                                (integerp (symbol-value x)))))))
 170         (setq mouse-avoidance-n-pointer-shapes
 171               (length mouse-avoidance-pointer-shapes))))
 172   (nth (random mouse-avoidance-n-pointer-shapes)
 173        mouse-avoidance-pointer-shapes))
 174
 175 (defun mouse-avoidance-simple-hook ()
 176   (if (and (mouse-avoidance-keyboard-command (this-command-keys)))
 177       (progn
 178         (raise-frame (selected-frame))
 179         (mouse-avoidance-banish-mouse))))
 180
 181 (defun mouse-avoidance-fancy-hook ()
 182   (if (and (mouse-avoidance-keyboard-command (this-command-keys))
 183            (mouse-avoidance-too-close-p))
 184       (let ((old-pos (mouse-position)))
 185         (mouse-avoidance-nudge-mouse)
 186         (if (not (eq (selected-frame) (car old-pos)))
 187             (apply 'set-mouse-position old-pos)))))
 188
 189 (defun mouse-avoidance-keyboard-command (key)
 190   "Return t if the KEYSEQENCE is composed of keyboard events only.
 191 Returns nil if there are any lists in the key sequence."
 192   (cond ((null key) nil)                ; Null event seems to be
 193                                         ; returned occasionally.
 194         ((not (vectorp key)) t)         ; Strings are keyboard events.
 195         ((catch 'done
 196            (let ((i 0)
 197                  (l (length key)))
 198              (while (< i l)
 199                (if (listp (aref key i))
 200                    (throw 'done nil))
 201                (setq i (1+ i))))
 202            t))))
 203
 204 (defun mouse-avoidance-mode (&optional mode)
 205   "Set cursor avoidance mode to MODE.
 206 MODE should be one of the symbols `banish', `jump', `animate',
 207 `cat-and-mouse', `proteus', or `none'.
 208
 209 If MODE is nil, toggle mouse avoidance between `none' and `banish'
 210 modes.  Positive numbers and symbols other than the above are treated
 211 as equivalent to `banish'; negative numbers and `-' are equivalent to `none'.
 212
 213 Effects of the different modes:
 214  * BANISH: Move the mouse to the upper-right corner on any keypress.
 215            Also raises the frame.
 216  * JUMP: If the cursor gets too close to the mouse, displace the mouse
 217          a random distance & direction.  If this would put it in another,
 218          overlapping frame, it is put back \(until the next keypress).
 219  * ANIMATE: As `jump', but shows steps along the way for illusion of motion.
 220  * CAT-AND-MOUSE: Same as `animate'.
 221  * PROTEUS: As `animate', but changes the shape of the mouse pointer too.
 222
 223 \(see `mouse-avoidance-threshhold' for definition of \"too close\",
 224 and `mouse-avoidance-nudge-dist' and `mouse-avoidance-nudge-var' for
 225 definition of \"random distance\".)"
 226   (interactive
 227    (list (intern (completing-read
 228                   "Select cursor avoidance technique (SPACE for list): "
 229                   '(("banish") ("jump") ("animate") ("cat-and-mouse")
 230                     ("proteus") ("none"))
 231                   nil t))))
 232   (if (eq mode 'cat-and-mouse)
 233       (setq mode 'animate))
 234   (setq post-command-hook
 235         (delete 'mouse-avoidance-simple-hook (append post-command-hook nil)))
 236   (setq post-command-hook
 237         (delete 'mouse-avoidance-fancy-hook (append post-command-hook nil)))
 238   (cond ((eq mode 'none)
 239          (setq mouse-avoidance-mode nil))
 240         ((or (eq mode 'jump)
 241              (eq mode 'animate)
 242              (eq mode 'proteus))
 243          (add-hook 'post-command-hook 'mouse-avoidance-fancy-hook)
 244          (setq mouse-avoidance-mode mode))
 245         ((or (eq mode 'banish)
 246              (eq mode t)
 247              (and (null mode) (null mouse-avoidance-mode))
 248              (and mode (> (prefix-numeric-value mode) 0)))
 249          (add-hook 'post-command-hook 'mouse-avoidance-simple-hook)
 250          (setq mouse-avoidance-mode 'banish))
 251         (t (setq mouse-avoidance-mode nil))))
 252
 253 (or (assq 'mouse-avoidance-mode minor-mode-alist)
 254     (setq minor-mode-alist (cons '(mouse-avoidance-mode " Avoid")
 255                                  minor-mode-alist)))
 256
 257 ;;; End of avoid.el
 258