mouse-drag.el 13 KB
Newer Older
Richard M. Stallman's avatar
Richard M. Stallman committed
1 2
;;; mouse-drag.el --- use mouse-2 to do a new style of scrolling

3
;; Copyright (C) 1996, 1997, 2001, 2002, 2003, 2004,
Glenn Morris's avatar
Glenn Morris committed
4
;;   2005, 2006, 2007, 2008 Free Software Foundation, Inc.
Richard M. Stallman's avatar
Richard M. Stallman committed
5

Richard M. Stallman's avatar
Richard M. Stallman committed
6 7
;; Author: John Heidemann <johnh@ISI.EDU>
;; Keywords: mouse
Richard M. Stallman's avatar
Richard M. Stallman committed
8 9 10 11 12

;; 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
13
;; the Free Software Foundation; either version 3, or (at your option)
Richard M. Stallman's avatar
Richard M. Stallman committed
14 15 16 17 18 19 20 21 22
;; 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
Lute Kamstra's avatar
Lute Kamstra committed
23 24
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
Richard M. Stallman's avatar
Richard M. Stallman committed
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

;;; Commentary:

;;; What is ``mouse-drag.el''?
;;;
;;; Doesn't that scroll bar seem far away when you want to scroll?
;;; This module overloads mouse-2 to do ``throw'' scrolling.  You
;;; click and drag.  The distance you move from your original click
;;; turns into a scroll amount.  The scroll amount is scaled
;;; exponentially to make both large moves and short adjustments easy.
;;; What this boils down to is that you can easily scroll around the
;;; buffer without much mouse movement.  Finally, clicks which aren't
;;; drags are passed off to the old mouse-2 binding, so old mouse-2
;;; operations (find-file in dired-mode, yanking in most other modes)
;;; still work.
;;;
;;; There is an alternative way to scroll, ``drag'' scrolling.  You
;;; can click on a character and then drag it around, scrolling the
;;; buffer with you.  The character always stays under the mouse.
;;; Compared to throw-scrolling, this approach provides direct
;;; manipulation (nice) but requires more mouse movement
;;; (unfortunate).  It is offered as an alternative for those who
;;; prefer it.
;;;
;;; If you like mouse-drag, you should also check out mouse-copy
;;; for ``one-click text copy and move''.
;;;
;;; To use mouse-drag, place the following in your .emacs file:
;;;	(require 'mouse-drag)
;;; -and either-
;;;     (global-set-key [down-mouse-2] 'mouse-drag-throw)
;;; -or-
;;;     (global-set-key [down-mouse-2] 'mouse-drag-drag)
;;;
;;;
;;;
;;; Options:
;;;
;;; - reverse the throw-scroll direction with \\[mouse-throw-with-scroll-bar]
;;; - work around a bug with \\[mouse-extras-work-around-drag-bug]
65 66
;;; - auto-enable horizontal scrolling with
;;;   \\[mouse-drag-electric-col-scrolling]
Richard M. Stallman's avatar
Richard M. Stallman committed
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
;;;
;;;
;;; History and related work:
;;;
;;; One-click copying and moving was inspired by lemacs-19.8.
;;; Throw-scrolling was inspired by MacPaint's ``hand'' and by Tk's
;;; mouse-2 scrolling.  The package mouse-scroll.el by Tom Wurgler
;;; <twurgler@goodyear.com> is similar to mouse-drag-throw, but
;;; doesn't pass clicks through.
;;;
;;; These functions have been tested in emacs version 19.30,
;;; and this package has run in the past on 19.25-19.29.
;;;
;;; Originally mouse-drag was part of a larger package.
;;; As of 11 July 96 the scrolling functions were split out
;;; in preparation for incorporation into (the future) emacs-19.32.
;;;
;;;
;;; Thanks:
;;;
;;; Thanks to Kai Grossjohann
;;; <grossjoh@dusty.informatik.uni-dortmund.de> for reporting bugs, to
;;; Tom Wurgler <twurgler@goodyear.com> for reporting bugs and
;;; suggesting fixes, and to Joel Graber <jgraber@ti.com> for
;;; prompting me to do drag-scrolling and for an initial
;;; implementation of horizontal drag-scrolling.
;;;
;;;    -johnh@isi.edu, 11-Jul-96
;;;
;;;
97
;;; What's new with mouse-drag 2.24?
Richard M. Stallman's avatar
Richard M. Stallman committed
98
;;;
99 100 101
;;; - mouse-drag-electric-col-scrolling (default: on)
;;;   auto-enables horizontal scrolling when clicks on wrapped
;;;   lines occur
Richard M. Stallman's avatar
Richard M. Stallman committed
102 103 104 105 106 107 108 109

;;; Code:

;;
;; scrolling code
;;

(defun mouse-drag-safe-scroll (row-delta &optional col-delta)
110
  "Scroll down ROW-DELTA lines and right COL-DELTA, ignoring buffer edge errors.
Richard M. Stallman's avatar
Richard M. Stallman committed
111
Keep the cursor on the screen as needed."
112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132
  (let ((scroll-preserve-screen-position nil))
    (if (and row-delta
	     (/= 0 row-delta))
	(condition-case nil ;; catch and ignore movement errors
	    (scroll-down row-delta)
	  (beginning-of-buffer (message "Beginning of buffer"))
	  (end-of-buffer (message "End of buffer"))))
    (if (and col-delta
	     (/= 0 col-delta))
	(progn
	  (scroll-right col-delta)
	  ;; Make sure that the point stays on the visible screen
	  ;; (if truncation-lines in set).
	  ;; This code mimics the behavior we automatically get
	  ;; when doing vertical scrolling.
	  ;; Problem identified and a fix suggested by Tom Wurgler.
	  (cond
	   ((< (current-column) (window-hscroll))
	    (move-to-column (window-hscroll))) ; make on left column
	   ((> (- (current-column) (window-hscroll) (window-width) -2) 0)
	    (move-to-column (+ (window-width) (window-hscroll) -3))))))))
Richard M. Stallman's avatar
Richard M. Stallman committed
133 134

(defun mouse-drag-repeatedly-safe-scroll (row-delta &optional col-delta)
135
  "Scroll ROW-DELTA rows and COL-DELTA cols until an event happens."
Richard M. Stallman's avatar
Richard M. Stallman committed
136 137 138 139
  (while (sit-for mouse-scroll-delay)
    (mouse-drag-safe-scroll row-delta col-delta)))

(defun mouse-drag-events-are-point-events-p (start-posn end-posn)
140
  "Determine if START-POSN and END-POSN are \"close\"."
Richard M. Stallman's avatar
Richard M. Stallman committed
141 142 143 144 145 146 147 148 149 150 151 152
  (let*
      ((start-col-row (posn-col-row start-posn))
       (end-col-row (posn-col-row end-posn)))
    (and
;; We no longer exclude things by time.
;;     (< (- (posn-timestamp end-posn) (posn-timestamp start-posn))
;;	(if (numberp double-click-time)
;;	    (* 2 double-click-time)   ;; stretch it a little
;;	  999999)) ;; non-numeric => check by position alone
     (= (car start-col-row) (car end-col-row))
     (= (cdr start-col-row) (cdr end-col-row)))))

153 154 155
(defvar mouse-drag-electric-col-scrolling t
  "If non-nil, mouse-drag on a long line enables truncate-lines.")

Richard M. Stallman's avatar
Richard M. Stallman committed
156
(defun mouse-drag-should-do-col-scrolling ()
157
  "Determine if it's wise to enable col-scrolling for the current window.
158
Basically, we check for existing horizontal scrolling."
Richard M. Stallman's avatar
Richard M. Stallman committed
159 160
  (or truncate-lines
      (> (window-hscroll (selected-window)) 0)
161
      (not (window-full-width-p))
162 163 164 165 166 167 168 169 170
      (and
       mouse-drag-electric-col-scrolling
       (save-excursion  ;; on a long line?
	 (let
	     ((beg (progn (beginning-of-line) (point)))
	      (end (progn (end-of-line) (point))))
	   (if (> (- end beg) (window-width))
	       (setq truncate-lines t)
	     nil))))))
Richard M. Stallman's avatar
Richard M. Stallman committed
171 172

(defvar mouse-throw-with-scroll-bar nil
173
  "*Set direction of mouse-throwing.
Richard M. Stallman's avatar
Richard M. Stallman committed
174 175
If nil, the text moves in the direction the mouse moves.
If t, the scroll bar moves in the direction the mouse moves.")
176
(defconst mouse-throw-magnifier-with-scroll-bar
Richard M. Stallman's avatar
Richard M. Stallman committed
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
      [-16 -8 -4 -2 -1 0 0 0  1  2  4  8  16])
(defconst mouse-throw-magnifier-with-mouse-movement
      [ 16  8  4  2  1 0 0 0 -1 -2 -4 -8 -16])
(defconst mouse-throw-magnifier-min -6)
(defconst mouse-throw-magnifier-max 6)

(defun mouse-drag-throw (start-event)
  "\"Throw\" the page according to a mouse drag.

A \"throw\" is scrolling the page at a speed relative to the distance
from the original mouse click to the current mouse location.  Try it;
you'll like it.  It's easier to observe than to explain.

If the mouse is clicked and released in the same place of time we
assume that the user didn't want to scdebugroll but wanted to whatever
mouse-2 used to do, so we pass it through.

Throw scrolling was inspired (but is not identical to) the \"hand\"
option in MacPaint, or the middle button in Tk text widgets.

If `mouse-throw-with-scroll-bar' is non-nil, then this command scrolls
in the opposite direction.  (Different people have different ideas
about which direction is natural.  Perhaps it has to do with which
hemisphere you're in.)

To test this function, evaluate:
    (global-set-key [down-mouse-2] 'mouse-drag-throw)"
  (interactive "e")
  ;; we want to do save-selected-window, but that requires 19.29
  (let* ((start-posn (event-start start-event))
	 (start-window (posn-window start-posn))
	 (start-row (cdr (posn-col-row start-posn)))
	 (start-col (car (posn-col-row start-posn)))
	 (old-selected-window (selected-window))
	 event end row mouse-delta scroll-delta
212
	 have-scrolled
Richard M. Stallman's avatar
Richard M. Stallman committed
213 214 215 216
	 window-last-row
	 col mouse-col-delta window-last-col
	 (scroll-col-delta 0)
	 adjusted-mouse-col-delta
217
	 adjusted-mouse-delta
Richard M. Stallman's avatar
Richard M. Stallman committed
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 259 260 261 262 263 264
	 ;; be conservative about allowing horizontal scrolling
	 (col-scrolling-p (mouse-drag-should-do-col-scrolling)))
    (select-window start-window)
    (track-mouse
      (while (progn
	       (setq event (read-event)
		     end (event-end event)
		     row (cdr (posn-col-row end))
		     col (car (posn-col-row end)))
	       (or (mouse-movement-p event)
		   (eq (car-safe event) 'switch-frame)))
	(if (eq start-window (posn-window end))
	    (progn
	      (setq mouse-delta (- start-row row)
		    adjusted-mouse-delta
		    (- (cond
			((<= mouse-delta mouse-throw-magnifier-min)
			 mouse-throw-magnifier-min)
			((>= mouse-delta mouse-throw-magnifier-max)
			 mouse-throw-magnifier-max)
			(t mouse-delta))
		       mouse-throw-magnifier-min)
		    scroll-delta (aref (if mouse-throw-with-scroll-bar
					   mouse-throw-magnifier-with-scroll-bar
					 mouse-throw-magnifier-with-mouse-movement)
				       adjusted-mouse-delta))
	      (if col-scrolling-p
		  (setq mouse-col-delta (- start-col col)
			adjusted-mouse-col-delta
			(- (cond
			    ((<= mouse-col-delta mouse-throw-magnifier-min)
			     mouse-throw-magnifier-min)
			    ((>= mouse-col-delta mouse-throw-magnifier-max)
			     mouse-throw-magnifier-max)
			    (t mouse-col-delta))
			   mouse-throw-magnifier-min)
			scroll-col-delta (aref (if mouse-throw-with-scroll-bar
						   mouse-throw-magnifier-with-scroll-bar
						 mouse-throw-magnifier-with-mouse-movement)
					       adjusted-mouse-col-delta)))))
	(if (or (/= 0 scroll-delta)
		(/= 0 scroll-col-delta))
	    (progn
	      (setq have-scrolled t)
	      (mouse-drag-safe-scroll scroll-delta scroll-col-delta)
	      (mouse-drag-repeatedly-safe-scroll scroll-delta scroll-col-delta))))) ;xxx
    ;; If it was a click and not a drag, prepare to pass the event on.
265
    ;; Is there a more correct way to reconstruct the event?
Richard M. Stallman's avatar
Richard M. Stallman committed
266 267
    (if (and (not have-scrolled)
	     (mouse-drag-events-are-point-events-p start-posn end))
268 269
	(push (cons (event-basic-type start-event) (cdr start-event))
	      unread-command-events))
Richard M. Stallman's avatar
Richard M. Stallman committed
270
    ;; Now restore the old window.
271
    (select-window old-selected-window)))
Richard M. Stallman's avatar
Richard M. Stallman committed
272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295

(defun mouse-drag-drag (start-event)
  "\"Drag\" the page according to a mouse drag.

Drag scrolling moves the page according to the movement of the mouse.
You \"grab\" the character under the mouse and move it around.

If the mouse is clicked and released in the same place of time we
assume that the user didn't want to scroll but wanted to whatever
mouse-2 used to do, so we pass it through.

Drag scrolling is identical to the \"hand\" option in MacPaint, or the
middle button in Tk text widgets.

To test this function, evaluate:
    (global-set-key [down-mouse-2] 'mouse-drag-drag)"
  (interactive "e")
  ;; we want to do save-selected-window, but that requires 19.29
  (let* ((start-posn (event-start start-event))
	 (start-window (posn-window start-posn))
	 (start-row (cdr (posn-col-row start-posn)))
	 (start-col (car (posn-col-row start-posn)))
	 (old-selected-window (selected-window))
	 event end row mouse-delta scroll-delta
296
	 have-scrolled
Richard M. Stallman's avatar
Richard M. Stallman committed
297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333
	 window-last-row
	 col mouse-col-delta window-last-col
	 (scroll-col-delta 0)
	 ;; be conservative about allowing horizontal scrolling
	 (col-scrolling-p (mouse-drag-should-do-col-scrolling)))
    (select-window start-window)
    (setq window-last-row (- (window-height) 2)
	  window-last-col (- (window-width) 2))
    (track-mouse
      (while (progn
	       (setq event (read-event)
		     end (event-end event)
		     row (cdr (posn-col-row end))
		     col (car (posn-col-row end)))
	       (or (mouse-movement-p event)
		   (eq (car-safe event) 'switch-frame)))
	;; Scroll if see if we're on the edge.
	;; NEEDSWORK: should handle mouse-in-other window.
	(cond
	 ((not (eq start-window (posn-window end)))
	  t) ; wait for return to original window
	 ((<= row 0) (mouse-drag-repeatedly-safe-scroll -1 0))
	 ((>= row window-last-row) (mouse-drag-repeatedly-safe-scroll 1 0))
	 ((and col-scrolling-p (<= col 1)) (mouse-drag-repeatedly-safe-scroll 0 -1))
	 ((and col-scrolling-p (>= col window-last-col)) (mouse-drag-repeatedly-safe-scroll 0 1))
	 (t
	  (setq scroll-delta (- row start-row)
		start-row row)
	  (if col-scrolling-p
	      (setq scroll-col-delta (- col start-col)
		    start-col col))
	  (if (or (/= 0 scroll-delta)
		  (/= 0 scroll-col-delta))
	      (progn
		(setq have-scrolled t)
		(mouse-drag-safe-scroll scroll-delta scroll-col-delta)))))))
    ;; If it was a click and not a drag, prepare to pass the event on.
334
    ;; Is there a more correct way to reconstruct the event?
Richard M. Stallman's avatar
Richard M. Stallman committed
335 336
    (if (and (not have-scrolled)
	     (mouse-drag-events-are-point-events-p start-posn end))
337 338
	(push (cons (event-basic-type start-event) (cdr start-event))
	      unread-command-events))
Richard M. Stallman's avatar
Richard M. Stallman committed
339
    ;; Now restore the old window.
340 341
    (select-window old-selected-window)))

Richard M. Stallman's avatar
Richard M. Stallman committed
342 343 344

(provide 'mouse-drag)

345
;; arch-tag: e47354ff-82f5-42c4-b3dc-88dd9c04b770
Richard M. Stallman's avatar
Richard M. Stallman committed
346
;;; mouse-drag.el ends here