diff options
Diffstat (limited to 'lisp/pixel-scroll.el')
| -rw-r--r-- | lisp/pixel-scroll.el | 405 |
1 files changed, 392 insertions, 13 deletions
diff --git a/lisp/pixel-scroll.el b/lisp/pixel-scroll.el index 249484cf581..fa0185b16e9 100644 --- a/lisp/pixel-scroll.el +++ b/lisp/pixel-scroll.el @@ -67,6 +67,8 @@ ;;; Code: (require 'mwheel) +(require 'subr-x) +(require 'ring) (defvar pixel-wait 0 "Idle time on each step of pixel scroll specified in second. @@ -90,6 +92,73 @@ 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) + 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.25 + "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") + (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 +392,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 +439,299 @@ 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))) + (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))) + +(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))) + (if (<= delta current-vscroll) + (set-window-vscroll nil (- current-vscroll delta) t) + (setq delta (- delta current-vscroll)) + (set-window-vscroll nil 0 t) + (while (> delta 0) + (let ((position (pixel-point-and-height-at-unseen-line))) + (unless (cdr position) + (signal 'beginning-of-buffer nil)) + (set-window-start nil (car 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 (> (cdr position) usable-height) + (goto-char (car position))) + (setq delta (- delta (cdr position))))) + (when (< delta 0) + (set-window-vscroll nil (- delta) t)))))) + +(defun pixel-scroll-precision-interpolate (delta) + "Interpolate a scroll of DELTA pixels. +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) + (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))) + (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 (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 10)) + (aset kin-state 1 nil)) + (pixel-scroll-precision-interpolate delta)) + (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 () + "Return the kinetic scroll state of the current window. +It is a vector of the form [ VELOCITY TIME ]." + (or (window-parameter nil 'kinetic-state) + (set-window-parameter nil 'kinetic-state + (vector (make-ring 10) 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) + (< (cdr (ring-ref ring 0)) + 0))))) + (aset state 0 (make-ring 10))) + (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 elts)) + 100)))) + +(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)) + (with-selected-window window + (setq state (pixel-scroll-kinetic-state)) + (when (and (aref state 1) + (listp (aref state 0))) + (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) + pixel-scroll-precision-initial-velocity-factor)) + (original-velocity velocity) + (time-spent 0)) + (if (> velocity 0) + (while (and (> velocity 0) + (<= time-spent + pixel-scroll-precision-momentum-seconds)) + (when (> (round velocity) 0) + (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) + (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 10)) + (aset state 1 nil)))))))) + +;;;###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 |