view lisp/mouse-drag.el @ 16842:72276b334084 before-thomas-posix1996 glibc-2_0_2 libc-970108 libc-970109 libc-970110 libc-970111 libc-970112 libc-970113 libc-970114 libc-970115 libc-970116 libc-970117 libc-970118 libc-970119 libc-970120 libc-970121 libc-970122 libc-970123 libc-970124 libc-970125 libc-970126 libc-970127 libc-970128 libc-970129 libc-970130 libc-970131 libc-970201 libc-970202 libc-970203 libc-970204 libc-970205 libc-970206 libc-970207 libc-970208 libc-970209 libc-970210 libc-970211 libc-970212 libc-970213 libc-970214 libc-970215 libc-970216 libc-970217 libc-970218 libc-970219 libc-970220 libc-970221 libc-970222 libc-970223 libc-970224 libc-970225 libc-970226 libc-970227 libc-970228 libc-970301 libc-970302 libc-970303 libc-970304 libc-970305 libc-970306 libc-970307 libc-970308 libc-970309 libc-970310 libc-970311 libc-970312 libc-970313 libc-970314 libc-970315 libc-970316 libc-970317 libc-970318 libc-970319 libc-970320 libc-970321 libc-970322 libc-970323 libc-970324 libc20x-970306 libc20x-97031 libc20x-970316 libc20x-970318 libc20x-970319 libc20x-970404 root-libc-2_0_x-branch

Add hppa1.1-hitachi-hiuxmpp support, passed along by rms.

;;; mouse-drag.el -- use mouse-2 to do a new style of scrolling
;; Copyright (C) 1996 Free Software Foundation, Inc.

;; Author: John Heidemann <[e-mail]>
;; Keywords: mouse

;; 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, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.

;;; 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]
;;;
;;;
;;; 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
;;; <[e-mail]> 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
;;; <[e-mail]> for reporting bugs, to
;;; Tom Wurgler <[e-mail]> for reporting bugs and
;;; suggesting fixes, and to Joel Graber <[e-mail]> for
;;; prompting me to do drag-scrolling and for an initial
;;; implementation of horizontal drag-scrolling.
;;;
;;;    [e-mail], 11-Jul-96
;;;
;;;
;;; Old changes, for reference:
;;;
;;; What's new with mouse-extras 2.21?
;;;
;;; - support for emacs-19.{29,30}
;;; - point now stays on the visible screen during horizontal scrolling
;;;   (bug identified and fix suggested by Tom Wurgler <[e-mail]>)
;;; - better work-around for lost-mouse-events bug (supports double/triple
;;;   clicks), see \\[mouse-extras-work-around-drag-bug] for details.
;;; - work-around for lost-mouse-events bug now is OFF by default;
;;;   enable it if you have problems
;;;



;;; Code:

;;
;; scrolling code
;;

(defun mouse-drag-safe-scroll (row-delta &optional col-delta)
  "* Scroll down ROW-DELTA lines and right COL-DELTA, ignoring buffer edge errors.
Keep the cursor on the screen as needed."
  (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)))))))

(defun mouse-drag-repeatedly-safe-scroll (row-delta &optional col-delta)
  "* Scroll ROW-DELTA rows and COL-DELTA cols until an event happens."
  (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)
  "* Determine if START-POSN and END-POSN are \"close\"."
  (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)))))

(defun mouse-drag-should-do-col-scrolling ()
  "* Determine if it's wise to enable col-scrolling for the current window."
  (or truncate-lines
      (> (window-hscroll (selected-window)) 0)
      (< (window-width) (screen-width))))

(defvar mouse-throw-with-scroll-bar nil
  "* Set direction of mouse-throwing.
If nil, the text moves in the direction the mouse moves.
If t, the scroll bar moves in the direction the mouse moves.")
(defconst mouse-throw-magnifier-with-scroll-bar 
      [-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
	 have-scrolled point-event-p old-binding
	 window-last-row
	 col mouse-col-delta window-last-col
	 (scroll-col-delta 0)
	 adjusted-mouse-col-delta
	 adjusted-mouse-delta
	 ;; 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.
    ;; Note:  We must determine the pass-through event before restoring
    ;; the window, but invoke it after.  Sigh.
    (if (and (not have-scrolled)
	     (mouse-drag-events-are-point-events-p start-posn end))
	(setq point-event-p t
	      old-binding (key-binding
			   (vector (event-basic-type start-event)))))
    ;; Now restore the old window.
    (select-window old-selected-window)
    ;; For clicks, call the old function.
    (if point-event-p
	(call-interactively old-binding))))

(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
	 have-scrolled point-event-p old-binding
	 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.
    ;; Note:  We must determine the pass-through event before restoring
    ;; the window, but invoke it after.  Sigh.
    (if (and (not have-scrolled)
	     (mouse-drag-events-are-point-events-p start-posn end))
	(setq point-event-p t
	      old-binding (key-binding
			   (vector (event-basic-type start-event)))))
    ;; Now restore the old window.
    (select-window old-selected-window)
    ;; For clicks, call the old function.
    (if point-event-p
	(call-interactively old-binding))))

(provide 'mouse-drag)

;;; mouse-drag.el ends here