(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 (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)
(cond
((< (current-column) (window-hscroll))
(move-to-column (window-hscroll))) ((> (- (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
(= (car start-col-row) (car end-col-row))
(= (cdr start-col-row) (cdr end-col-row)))))
(defvar mouse-drag-electric-col-scrolling t
"If non-nil, mouse-drag on a long line enables truncate-lines.")
(defun mouse-drag-should-do-col-scrolling ()
"Determine if it's wise to enable col-scrolling for the current window.
Basically, we check for existing horizontal scrolling."
(or truncate-lines
(> (window-hscroll (selected-window)) 0)
(< (window-width) (screen-width))
(and
mouse-drag-electric-col-scrolling
(save-excursion (let
((beg (progn (beginning-of-line) (point)))
(end (progn (end-of-line) (point))))
(if (> (- end beg) (window-width))
(setq truncate-lines t)
nil))))))
(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")
(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
(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))))) (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)))))
(select-window old-selected-window)
(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")
(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)
(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)))
(cond
((not (eq start-window (posn-window end)))
t) ((<= 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 (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)))))
(select-window old-selected-window)
(if point-event-p
(call-interactively old-binding))))
(provide 'mouse-drag)