diff options
Diffstat (limited to 'lisp/pixel-scroll.el')
| -rw-r--r-- | lisp/pixel-scroll.el | 512 |
1 files changed, 497 insertions, 15 deletions
diff --git a/lisp/pixel-scroll.el b/lisp/pixel-scroll.el index 934812b0508..fc7e680c262 100644 --- a/lisp/pixel-scroll.el +++ b/lisp/pixel-scroll.el @@ -32,8 +32,10 @@ ;;; Commentary: -;; This package offers a global minor mode which makes mouse-wheel -;; scroll a line smoothly. +;; This file contains two somewhat related features. + +;; The first is a global minor mode which makes Emacs try to scroll +;; each line smoothly. ;; ;; Scrolling a line up by `set-window-vscroll' and that by `scroll-up' ;; give similar display as shown below. @@ -58,6 +60,25 @@ ;; (set-window-vscroll nil vs t) (sit-for 0)) ;; (scroll-up 1) +;; The second is another global minor mode that redefines `wheel-up' +;; and `wheel-down' to a command that tries to scroll the display +;; according to the precise movement of a trackpad or mouse. + +;; But it operates in a much more intelligent manner than simply +;; setting the vscroll. It will set window start to the position +;; closest to the position at the top-left corner of the window if +;; vscroll were set accordingly, in a smart and fast manner, and only +;; set vscroll the rest of the way. There is no visible difference, +;; but it is much faster, and doesn't move the display by a huge +;; portion if vscroll is reset for some reason. + +;; It also tries to move point out of the way, so redisplay will not +;; recenter the display as it scrolls. This works well almost all of +;; the time, but is impossible to get right with images larger than +;; the window they're displayed in. A feature that will allow +;; redisplay to skip recentering is in the works, and will completely +;; resolve this problem. + ;;; Todo: ;; ;; Allowing pixel-level scrolling in Emacs requires a thorough review @@ -67,6 +88,9 @@ ;;; Code: (require 'mwheel) +(require 'subr-x) +(require 'ring) +(require 'cua-base) (defvar pixel-wait 0 "Idle time on each step of pixel scroll specified in second. @@ -90,6 +114,114 @@ is always with pixel resolution.") (defvar pixel-last-scroll-time 0 "Time when the last scrolling was made, in second since the epoch.") +(defvar mwheel-coalesce-scroll-events) + +(defvar pixel-scroll-precision-mode-map + (let ((map (make-sparse-keymap))) + (define-key map [wheel-down] 'pixel-scroll-precision) + (define-key map [wheel-up] 'pixel-scroll-precision) + (define-key map [touch-end] 'pixel-scroll-start-momentum) + (define-key map [mode-line wheel-down] 'pixel-scroll-precision) + (define-key map [mode-line wheel-up] 'pixel-scroll-precision) + (define-key map [mode-line touch-end] 'pixel-scroll-start-momentum) + (define-key map [header-line wheel-down] 'pixel-scroll-precision) + (define-key map [header-line wheel-up] 'pixel-scroll-precision) + (define-key map [header-line touch-end] 'pixel-scroll-start-momentum) + (define-key map [vertical-scroll-bar wheel-down] 'pixel-scroll-precision) + (define-key map [vertical-scroll-bar wheel-up] 'pixel-scroll-precision) + (define-key map [vertical-scroll-bar touch-end] 'pixel-scroll-start-momentum) + (define-key map [tool-bar wheel-down] 'pixel-scroll-precision) + (define-key map [tool-bar wheel-up] 'pixel-scroll-precision) + (define-key map [tool-bar touch-end] 'pixel-scroll-start-momentum) + (define-key map [left-margin wheel-down] 'pixel-scroll-precision) + (define-key map [left-margin wheel-up] 'pixel-scroll-precision) + (define-key map [left-margin touch-end] 'pixel-scroll-start-momentum) + (define-key map [right-margin wheel-down] 'pixel-scroll-precision) + (define-key map [right-margin wheel-up] 'pixel-scroll-precision) + (define-key map [right-margin touch-end] 'pixel-scroll-start-momentum) + (define-key map [left-fringe wheel-down] 'pixel-scroll-precision) + (define-key map [left-fringe wheel-up] 'pixel-scroll-precision) + (define-key map [left-fringe touch-end] 'pixel-scroll-start-momentum) + (define-key map [right-fringe wheel-down] 'pixel-scroll-precision) + (define-key map [right-fringe wheel-up] 'pixel-scroll-precision) + (define-key map [right-fringe touch-end] 'pixel-scroll-start-momentum) + (define-key map [next] 'pixel-scroll-interpolate-down) + (define-key map [prior] 'pixel-scroll-interpolate-up) + map) + "The key map used by `pixel-scroll-precision-mode'.") + +(defcustom pixel-scroll-precision-use-momentum nil + "If non-nil, continue to scroll the display after wheel movement stops. +This is only effective if supported by your mouse or touchpad." + :group 'mouse + :type 'boolean + :version "29.1") + +(defcustom pixel-scroll-precision-momentum-tick 0.01 + "Number of seconds between each momentum scroll." + :group 'mouse + :type 'float + :version "29.1") + +(defcustom pixel-scroll-precision-momentum-seconds 1.75 + "The maximum duration in seconds of momentum scrolling." + :group 'mouse + :type 'float + :version "29.1") + +(defcustom pixel-scroll-precision-momentum-min-velocity 10.0 + "The minimum scrolled pixels per second before momentum scrolling starts." + :group 'mouse + :type 'float + :version "29.1") + +(defcustom pixel-scroll-precision-initial-velocity-factor (/ 0.0335 4) + "Factor applied to the initial velocity before momentum scrolling begins." + :group 'mouse + :type 'float + :version "29.1") + +(defcustom pixel-scroll-precision-large-scroll-height nil + "Pixels that must be scrolled before an animation is performed. +Nil means to not interpolate such scrolls." + :group 'mouse + :type '(choice (const :tag "Do not interpolate large scrolls" nil) + number) + :version "29.1") + +(defcustom pixel-scroll-precision-interpolation-total-time 0.1 + "The total time in seconds to spend interpolating a large scroll." + :group 'mouse + :type 'float + :version "29.1") + +(defcustom pixel-scroll-precision-interpolation-factor 4.0 + "A factor to apply to the distance of an interpolated scroll." + :group 'mouse + :type 'float + :version "29.1") + +(defcustom pixel-scroll-precision-interpolation-between-scroll 0.001 + "The number of seconds between each step of an interpolated scroll." + :group 'mouse + :type 'float + :version "29.1") + +(defcustom pixel-scroll-precision-interpolate-page nil + "Whether or not to interpolate scrolling via the Page Down and Page Up keys. +This is only effective when `pixel-scroll-precision-mode' is enabled." + :group 'scrolling + :type 'boolean + :version "29.1") + +(defcustom pixel-scroll-precision-interpolate-mice t + "Whether or not to interpolate scrolling from a mouse. +If non-nil, scrolling from the mouse wheel of an actual mouse (as +opposed to a touchpad) will cause Emacs to interpolate the scroll." + :group 'scrolling + :type 'boolean + :version "29.1") + (defun pixel-scroll-in-rush-p () "Return non-nil if next scroll should be non-smooth. When scrolling request is delivered soon after the previous one, @@ -323,28 +455,44 @@ returns nil." (setq pos-list (cdr pos-list)))) visible-pos)) -(defun pixel-point-at-unseen-line () - "Return the character position of line above the selected window. -The returned value is the position of the first character on the -unseen line just above the scope of current window." - (let* ((pos0 (window-start)) +(defun pixel-point-and-height-at-unseen-line () + "Return the position and pixel height of line above the selected window. +The returned value is a cons of the position of the first +character on the unseen line just above the scope of current +window, and the pixel height of that line." + (let* ((pos0 (save-excursion + (goto-char (window-start)) + (unless (bobp) + (beginning-of-visual-line)) + (point))) (vscroll0 (window-vscroll nil t)) + (line-height nil) (pos (save-excursion (goto-char pos0) (if (bobp) (point-min) - ;; When there's an overlay string at window-start, - ;; (beginning-of-visual-line 0) stays put. - (let ((ppos (point)) - (tem (beginning-of-visual-line 0))) - (if (eq tem ppos) - (vertical-motion -1)) - (point)))))) + (vertical-motion -1) + (setq line-height + (cdr (window-text-pixel-size nil (point) pos0))) + (point))))) ;; restore initial position (set-window-start nil pos0 t) (set-window-vscroll nil vscroll0 t) - pos)) + (when (and line-height + (> (car (posn-x-y (posn-at-point pos0))) + (line-number-display-width t))) + (setq line-height (- line-height + (save-excursion + (goto-char pos0) + (line-pixel-height))))) + (cons pos line-height))) + +(defun pixel-point-at-unseen-line () + "Return the character position of line above the selected window. +The returned value is the position of the first character on the +unseen line just above the scope of current window." + (car (pixel-point-and-height-at-unseen-line))) (defun pixel-scroll-down-and-set-window-vscroll (vscroll) "Scroll down a line and set VSCROLL in pixels. @@ -354,5 +502,339 @@ Otherwise, redisplay will reset the window's vscroll." (set-window-start nil (pixel-point-at-unseen-line) t) (set-window-vscroll nil vscroll t)) +(defun pixel-scroll-precision-scroll-down-page (delta) + "Scroll the current window down by DELTA pixels. +Note that this function doesn't work if DELTA is larger than +the height of the current window." + (let* ((desired-pos (posn-at-x-y 0 (+ delta + (window-tab-line-height) + (window-header-line-height)))) + (desired-start (posn-point desired-pos)) + (current-vs (window-vscroll nil t)) + (start-posn (unless (eq desired-start (window-start)) + (posn-at-point desired-start))) + (desired-vscroll (if start-posn + (- delta (cdr (posn-x-y start-posn))) + (+ current-vs delta))) + (edges (window-edges nil t)) + (usable-height (- (nth 3 edges) + (nth 1 edges))) + (next-pos (save-excursion + (goto-char desired-start) + (when (zerop (vertical-motion (1+ scroll-margin))) + (set-window-start nil desired-start) + (signal 'end-of-buffer nil)) + (while (when-let ((posn (posn-at-point))) + (< (cdr (posn-x-y posn)) delta)) + (when (zerop (vertical-motion 1)) + (set-window-start nil desired-start) + (signal 'end-of-buffer nil))) + (point))) + (scroll-preserve-screen-position nil) + (auto-window-vscroll nil)) + (when (and (or (< (point) next-pos)) + (let ((pos-visibility (pos-visible-in-window-p next-pos nil t))) + (and pos-visibility + (or (eq (length pos-visibility) 2) + (when-let* ((posn (posn-at-point next-pos))) + (> (cdr (posn-object-width-height posn)) + usable-height)))))) + (goto-char next-pos)) + (set-window-start nil (if (zerop (window-hscroll)) + desired-start + (save-excursion + (goto-char desired-start) + (beginning-of-visual-line) + (point))) + t) + (set-window-vscroll nil desired-vscroll t t))) + +(defun pixel-scroll-precision-scroll-down (delta) + "Scroll the current window down by DELTA pixels." + (let ((max-height (- (window-text-height nil t) + (frame-char-height)))) + (while (> delta max-height) + (pixel-scroll-precision-scroll-down-page max-height) + (setq delta (- delta max-height))) + (pixel-scroll-precision-scroll-down-page delta))) + +(defun pixel-scroll-precision-scroll-up-page (delta) + "Scroll the current window up by DELTA pixels. +Note that this function doesn't work if DELTA is larger than +the height of the current window." + (let* ((edges (window-edges nil t nil t)) + (max-y (- (nth 3 edges) + (nth 1 edges))) + (usable-height max-y) + (posn (posn-at-x-y 0 (+ (window-tab-line-height) + (window-header-line-height) + (- max-y delta)))) + (point (posn-point posn)) + (up-point (save-excursion + (goto-char point) + (vertical-motion (- (1+ scroll-margin))) + (point)))) + (when (> (point) up-point) + (when (let ((pos-visible (pos-visible-in-window-p up-point nil t))) + (or (eq (length pos-visible) 2) + (when-let* ((posn (posn-at-point up-point)) + (edges (window-edges nil t)) + (usable-height (- (nth 3 edges) + (nth 1 edges)))) + (> (cdr (posn-object-width-height posn)) + usable-height)))) + (goto-char up-point))) + (let ((current-vscroll (window-vscroll nil t))) + (setq delta (- delta current-vscroll)) + (set-window-vscroll nil 0 t t) + (when (> delta 0) + (let* ((start (window-start)) + (dims (window-text-pixel-size nil (cons start (- delta)) + start nil nil nil t)) + (height (nth 1 dims)) + (position (nth 2 dims))) + (set-window-start nil position t) + ;; If the line above is taller than the window height (i.e. there's + ;; a very tall image), keep point on it. + (when (> height usable-height) + (goto-char position)) + (when (or (not position) (eq position start)) + (signal 'beginning-of-buffer nil)) + (setq delta (- delta height)))) + (when (< delta 0) + (set-window-vscroll nil (- delta) t t))))) + +(defun pixel-scroll-precision-interpolate (delta &optional old-window) + "Interpolate a scroll of DELTA pixels. +OLD-WINDOW is the window which will be selected when redisplay +takes place, or nil for the current window. This results in the +window being scrolled by DELTA pixels with an animation." + (let ((percentage 0) + (total-time pixel-scroll-precision-interpolation-total-time) + (factor pixel-scroll-precision-interpolation-factor) + (last-time (float-time)) + (time-elapsed 0.0) + (between-scroll pixel-scroll-precision-interpolation-between-scroll) + (rem (window-parameter nil 'interpolated-scroll-remainder)) + (time (window-parameter nil 'interpolated-scroll-remainder-time))) + (when (and rem time + (< (- (float-time) time) 1.0) + (eq (< delta 0) (< rem 0))) + (setq delta (+ delta rem))) + (if (or (null rem) + (eq (< delta 0) (< rem 0))) + (while-no-input + (unwind-protect + (while (< percentage 1) + (with-selected-window (or old-window + (selected-window)) + (redisplay t)) + (sleep-for between-scroll) + (setq time-elapsed (+ time-elapsed + (- (float-time) last-time)) + percentage (/ time-elapsed total-time)) + (let ((throw-on-input nil)) + (if (< delta 0) + (pixel-scroll-precision-scroll-down + (ceiling (abs (* (* delta factor) + (/ between-scroll total-time))))) + (pixel-scroll-precision-scroll-up + (ceiling (* (* delta factor) + (/ between-scroll total-time)))))) + (setq last-time (float-time))) + (if (< percentage 1) + (progn + (set-window-parameter nil 'interpolated-scroll-remainder + (* delta (- 1 percentage))) + (set-window-parameter nil 'interpolated-scroll-remainder-time + (float-time))) + (set-window-parameter nil + 'interpolated-scroll-remainder + nil) + (set-window-parameter nil + 'interpolated-scroll-remainder-time + nil)))) + (set-window-parameter nil + 'interpolated-scroll-remainder + nil) + (set-window-parameter nil + 'interpolated-scroll-remainder-time + nil)))) + +(defun pixel-scroll-precision-scroll-up (delta) + "Scroll the current window up by DELTA pixels." + (let ((max-height (- (window-text-height nil t) + (frame-char-height)))) + (while (> delta max-height) + (pixel-scroll-precision-scroll-up-page max-height) + (setq delta (- delta max-height))) + (pixel-scroll-precision-scroll-up-page delta))) + +;; FIXME: This doesn't _always_ work when there's an image above the +;; current line that is taller than the window, and scrolling can +;; sometimes be jumpy in that case. +(defun pixel-scroll-precision (event) + "Scroll the display vertically by pixels according to EVENT. +Move the display up or down by the pixel deltas in EVENT to +scroll the display according to the user's turning the mouse +wheel." + (interactive "e") + (let ((window (mwheel-event-window event)) + (current-window (selected-window))) + (when (framep window) + (setq window (frame-selected-window window))) + (if (and (nth 4 event)) + (let ((delta (round (cdr (nth 4 event))))) + (unless (zerop delta) + (if (> (abs delta) (window-text-height window t)) + (mwheel-scroll event nil) + (with-selected-window window + (if (or (and pixel-scroll-precision-interpolate-mice + (eq (device-class last-event-frame + last-event-device) + 'mouse)) + (and pixel-scroll-precision-large-scroll-height + (> (abs delta) + pixel-scroll-precision-large-scroll-height) + (let* ((kin-state (pixel-scroll-kinetic-state)) + (ring (aref kin-state 0)) + (time (aref kin-state 1))) + (or (null time) + (> (- (float-time) time) 1.0) + (and (consp ring) + (ring-empty-p ring)))))) + (progn + (let ((kin-state (pixel-scroll-kinetic-state))) + (aset kin-state 0 (make-ring 30)) + (aset kin-state 1 nil)) + (pixel-scroll-precision-interpolate delta current-window)) + (condition-case nil + (progn + (if (< delta 0) + (pixel-scroll-precision-scroll-down (- delta)) + (pixel-scroll-precision-scroll-up delta)) + (pixel-scroll-accumulate-velocity delta)) + ;; Do not ding at buffer limits. Show a message instead. + (beginning-of-buffer + (message (error-message-string '(beginning-of-buffer)))) + (end-of-buffer + (message (error-message-string '(end-of-buffer)))))))))) + (mwheel-scroll event nil)))) + +(defun pixel-scroll-kinetic-state (&optional window) + "Return the kinetic scroll state of WINDOW. +If WINDOW is nil, return the state of the current window. +It is a vector of the form [ VELOCITY TIME SIGN ]." + (or (window-parameter window 'kinetic-state) + (set-window-parameter window 'kinetic-state + (vector (make-ring 30) nil nil)))) + +(defun pixel-scroll-accumulate-velocity (delta) + "Accumulate DELTA into the current window's kinetic scroll state." + (let* ((state (pixel-scroll-kinetic-state)) + (ring (aref state 0)) + (time (aref state 1))) + (when (or (and time (> (- (float-time) time) 0.5)) + (and (not (ring-empty-p ring)) + (not (eq (< delta 0) + (aref state 2))))) + (aset state 0 (make-ring 30))) + (aset state 2 (< delta 0)) + (ring-insert (aref state 0) + (cons (aset state 1 (float-time)) + delta)))) + +(defun pixel-scroll-calculate-velocity (state) + "Calculate velocity from the kinetic state vector STATE." + (let* ((ring (aref state 0)) + (elts (ring-elements ring)) + (total 0)) + (dolist (tem elts) + (setq total (+ total (cdr tem)))) + (* (/ total (- (float-time) (caar (last elts)))) + pixel-scroll-precision-initial-velocity-factor))) + +(defun pixel-scroll-start-momentum (event) + "Start kinetic scrolling for the touch event EVENT." + (interactive "e") + (when pixel-scroll-precision-use-momentum + (let ((window (mwheel-event-window event)) + (state nil)) + (when (framep window) + (setq window (frame-selected-window window))) + (setq state (pixel-scroll-kinetic-state window)) + (when (and (aref state 1) + (listp (aref state 0))) + (condition-case nil + (while-no-input + (unwind-protect (progn + (aset state 0 (pixel-scroll-calculate-velocity state)) + (when (> (abs (aref state 0)) + pixel-scroll-precision-momentum-min-velocity) + (let* ((velocity (aref state 0)) + (original-velocity velocity) + (time-spent 0)) + (if (> velocity 0) + (while (and (> velocity 0) + (<= time-spent + pixel-scroll-precision-momentum-seconds)) + (when (> (round velocity) 0) + (with-selected-window window + (pixel-scroll-precision-scroll-up (round velocity)))) + (setq velocity (- velocity + (/ original-velocity + (/ pixel-scroll-precision-momentum-seconds + pixel-scroll-precision-momentum-tick)))) + (redisplay t) + (sit-for pixel-scroll-precision-momentum-tick) + (setq time-spent (+ time-spent + pixel-scroll-precision-momentum-tick)))) + (while (and (< velocity 0) + (<= time-spent + pixel-scroll-precision-momentum-seconds)) + (when (> (round (abs velocity)) 0) + (with-selected-window window + (pixel-scroll-precision-scroll-down (round + (abs velocity))))) + (setq velocity (+ velocity + (/ (abs original-velocity) + (/ pixel-scroll-precision-momentum-seconds + pixel-scroll-precision-momentum-tick)))) + (redisplay t) + (sit-for pixel-scroll-precision-momentum-tick) + (setq time-spent (+ time-spent + pixel-scroll-precision-momentum-tick)))))) + (aset state 0 (make-ring 30)) + (aset state 1 nil))) + (beginning-of-buffer + (message (error-message-string '(beginning-of-buffer)))) + (end-of-buffer + (message (error-message-string '(end-of-buffer))))))))) + +(defun pixel-scroll-interpolate-down () + "Interpolate a scroll downwards by one page." + (interactive) + (if pixel-scroll-precision-interpolate-page + (pixel-scroll-precision-interpolate (- (window-text-height nil t))) + (cua-scroll-up))) + +(defun pixel-scroll-interpolate-up () + "Interpolate a scroll upwards by one page." + (interactive) + (if pixel-scroll-precision-interpolate-page + (pixel-scroll-precision-interpolate (window-text-height nil t)) + (cua-scroll-down))) + +;;;###autoload +(define-minor-mode pixel-scroll-precision-mode + "Toggle pixel scrolling. +When enabled, this minor mode allows to scroll the display +precisely, according to the turning of the mouse wheel." + :global t + :group 'mouse + :keymap pixel-scroll-precision-mode-map + (setq mwheel-coalesce-scroll-events + (not pixel-scroll-precision-mode))) + (provide 'pixel-scroll) ;;; pixel-scroll.el ends here |