diff options
Diffstat (limited to 'lisp/ultra-scroll.el')
| -rw-r--r-- | lisp/ultra-scroll.el | 302 |
1 files changed, 302 insertions, 0 deletions
diff --git a/lisp/ultra-scroll.el b/lisp/ultra-scroll.el new file mode 100644 index 0000000..1df5ddb --- /dev/null +++ b/lisp/ultra-scroll.el @@ -0,0 +1,302 @@ +;;; ultra-scroll.el --- Fast and smooth scrolling -*- lexical-binding: t; -*- +;; Copyright (C) 2023-2025 J.D. Smith + +;; Author: J.D. Smith +;; Homepage: https://github.com/jdtsmith/ultra-scroll +;; Package-Requires: ((emacs "29.1")) +;; Version: 0.2.1 +;; Keywords: convenience +;; Prefix: ultra-scroll +;; Separator: - + +;; ultra-scroll 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 3 of +;; the License, or (at your option) any later version. + +;; ultra-scroll 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 this program. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: +;; ultra-scroll enables fast, smooth, jump-free scrolling for Emacs. +;; On emacs-mac it retains the swipe-to-scroll and pinch-out for tab +;; overview capabilities of that port. On all ports, it can scroll +;; past images taller than the window without problem. +;; +;; The strongly recommended scroll settings are: +;; scroll-margin=0 +;; scroll-conservatively=101 +;; +;; See also pixel-scroll-precision-mode in pixel-scroll.el. + +;;; Code: +;;;; Requires +(require 'mac-win nil 'noerror) +(require 'pixel-scroll) +(require 'mwheel) +(require 'timer) + +;;;; Customize +(defcustom ultra-scroll-mac-multiplier 1. + "Multiplier for smooth scroll step for wheeled mice on emacs-mac. +This multiplies the fractional delta-y values generated by +regular mouse wheels by the value returned by +`frame-char-height'. Increase it to increase scrolling speed on +such mice. Note that some mice drivers emulate trackpads, and so +will not be affected by this setting. Adjust scrolling speed +directly with those drivers instead." + :group 'scrolling + :type 'float) + +(defcustom ultra-scroll-gc-percentage 0.67 + "Value to temporarily set `gc-cons-percentage'. +This is set on initial scrolling, and restored during idle +time (see `ultra-scroll-gc-idle-time')." + :type '(choice (const :tag "Disable" nil) float) + :group 'scrolling) + +(defcustom ultra-scroll-gc-idle-time 0.5 + "Idle time in sec after which to restore `gc-cons-percentage'. +Operates only if `ultra-scroll-gc-percentage' is non-nil." + :type 'float + :group 'scrolling) + +;;;; Event callback/scroll +(defun ultra-scroll-down (delta) + "Scroll the current window down by DELTA pixels. +DELTA should not be larger than the height of the current window." + (let* ((initial (point)) + (edges (window-edges nil t nil t)) + (current-vs (window-vscroll nil t)) + (off (+ (window-tab-line-height) (window-header-line-height))) + (new-start (or (posn-point (posn-at-x-y 0 (+ delta off))) (window-start)))) + (goto-char new-start) + (unless (zerop (window-hscroll)) + (setq new-start (beginning-of-visual-line))) + (if (>= (line-pixel-height) (- (nth 3 edges) (nth 1 edges))) + ;; Jumbo line at top: just stay on it and increment vscroll + (set-window-vscroll nil (+ current-vs delta) t t) + (if (eq new-start (window-start)) ; same start: just vscroll a bit more + (setq delta (+ current-vs delta)) + (setq delta (- delta (cdr (posn-x-y (posn-at-point new-start))))) + (set-window-start nil new-start (not (zerop delta)))) + (set-window-vscroll nil delta t t) + ;; Avoid recentering + (goto-char (posn-point (posn-at-x-y 0 off))) ; window-start may be above + (if (zerop (vertical-motion 1)) ; move down 1 line from top + (signal 'end-of-buffer nil)) + (if (> initial (point)) (goto-char initial))))) + +(defun ultra-scroll-up (delta) + "Scroll the current window up by DELTA pixels. +DELTA should be less than the window's height." + (let* ((initial (point)) + (edges (window-edges nil t nil t)) + (win-height (- (nth 3 edges) (nth 1 edges))) + (win-start (window-start)) + (current-vs (window-vscroll nil t)) + (start win-start)) + (if (<= delta current-vs) ; simple case: just reduce vscroll + (setq delta (- current-vs delta)) + ; Not enough vscroll: measure size above window-start + (let* ((dims (window-text-pixel-size nil (cons start (- current-vs delta)) + start nil nil nil t)) + (pos (nth 2 dims)) + (height (nth 1 dims))) + (when (or (not pos) (eq pos (point-min))) + (signal 'beginning-of-buffer nil)) + (setq start (nth 2 dims) + delta (- (+ height current-vs) delta))) ; should be >= 0 + (unless (eq start win-start) + (set-window-start nil start (not (zerop delta))))) + (when (>= delta 0) (set-window-vscroll nil delta t t)) + + ;; Position point to avoid recentering, moving up one line from + ;; the bottom, if necessary. "Jumbo" lines (taller than the + ;; window height, usually due to images) must be handled + ;; carefully. Once they are within the window, point should stay + ;; on the first tall object on the line until the top of the jumbo + ;; line clears the top of the window, then immediately moved off + ;; (above), via the full height character. The is the only way to + ;; avoid unwanted re-centering/motion trapping. + (if (> (line-pixel-height) win-height) ; a jumbo on the line! + (let ((end (max (point) + (save-excursion + (end-of-visual-line) + (1- (point)))))) ; don't fall off + (when-let ((pv (pos-visible-in-window-p end nil t)) + ((and (> (length pv) 2) ; falls outside window + (zerop (nth 2 pv))))) ; but not at the top + (goto-char end) ; eol is usually full height + (goto-char start))) ; now move up + (when-let ((p (posn-at-x-y 0 (1- win-height)))) + (goto-char (posn-point p)) + (vertical-motion -1) + (if (< initial (point)) (goto-char initial)))))) + +(defvar ultra-scroll--gc-percentage-orig nil) +(defvar ultra-scroll--gc-timer nil) +(defun ultra-scroll--restore-gc () + "Reset GC variable during idle time." + (setq gc-cons-percentage + (or ultra-scroll--gc-percentage-orig 0.1) + ultra-scroll--gc-timer nil)) + +(defsubst ultra-scroll--scroll (delta window) + "Scroll by WINDOW by DELTA (positive or negative)." + (let (ignore) + (unless (or (zerop delta) + (and (setq ignore (window-parameter window 'ultra-scroll--ignore)) + (or (and (eq (point) (car ignore)) ; ignoring this window this direction + (eq (cdr ignore) (< delta 0))) + (set-window-parameter window 'ultra-scroll--ignore nil)))) + (with-selected-window window + (condition-case err + (if (< delta 0) + (ultra-scroll-down (- delta)) + (ultra-scroll-up delta)) + ;; Do not ding at buffer limits. Show a message instead (once!). + ((beginning-of-buffer end-of-buffer) + (let* ((end (eq (car err) 'end-of-buffer)) + (p (if end (point-max) (point-min)))) + (goto-char p) + (set-window-start window p) + (set-window-vscroll window 0 t t) + (set-window-parameter window 'ultra-scroll--ignore + (cons (point) end)) + (message (error-message-string + (if end '(end-of-buffer) '(beginning-of-buffer))))))))))) + +(defsubst ultra-scroll--maybe-relax-gc () + "Lift the GC threshold percentage to avoid GC during scroll. +See `ultra-scroll-gc-percentage' to configuring whether this +occurs and the `gc-cons-percentage' level to set temporarily." + (when (and ultra-scroll-gc-percentage (not ultra-scroll--gc-timer)) + (setq gc-cons-percentage ; reduce GC's during scroll + (max gc-cons-percentage ultra-scroll-gc-percentage) + ultra-scroll--gc-timer + (run-with-idle-timer ultra-scroll-gc-idle-time nil + #'ultra-scroll--restore-gc)))) + +(defun ultra-scroll (event &optional arg) + "Smooth scroll EVENT. +EVENT and optional ARG are passed to `mwheel-scroll', unless +EVENT is a scrolling event." + (interactive "e") + (let ((delta (nth 4 event))) + (if (not delta) + (mwheel-scroll event arg) + (ultra-scroll--maybe-relax-gc) + (ultra-scroll--scroll (round (cdr delta)) (mwheel-event-window event))))) + +(declare-function mac-forward-wheel-event "mac-win") +(defun ultra-scroll-mac (event &optional arg) + "Smooth scroll EVENT for emacs-mac. +EVENT and optional ARG are passed on to `mwheel-scroll', for any +events not handled here. If swipe-tracking is enabled for +swipe-between-pages at the OS level, left-/right-swipe events +will be replayed for left/right touch ends." + (interactive "e") + (let ((ev-type (event-basic-type event)) + (plist (nth 3 event))) + (if (not (memq ev-type '(wheel-up wheel-down))) + (when (memq ev-type '(wheel-left wheel-right)) + (if mouse-wheel-tilt-scroll + (mac-forward-wheel-event t 'mwheel-scroll event arg) + (when (and ;; "Swipe between pages" enabled. + (plist-get plist :swipe-tracking-from-scroll-events-enabled-p) + (eq (plist-get plist :momentum-phase) 'began)) + ;; Post a swipe event when left/right momentum phase begins + (push (cons (event-convert-list + (nconc (delq 'click + (delq 'double + (delq 'triple + (event-modifiers event)))) + (if (eq (event-basic-type event) 'wheel-left) + '(swipe-left) '(swipe-right)))) + (cdr event)) + unread-command-events)))) + ;; Note: emacs-mac encodes all scrolling information in the PLIST, as follows: + ;; trackpads: + ;; - `:scrolling-delta-x' and `:scrolling-delta-y' are set + ;; to pixel scroll amounts. + ;; - `:phase' is set to `began' on first scroll, then `changed'. + ;; - During momentum scroll, `:momentum-phase' is set to + ;; `began' then `changed', while `:phase' is `none'. + ;; some regular wheeled mice: + ;; - `:delta-x' and `:delta-y' are set to floating + ;; fractional line scroll amounts. + ;; - `:phase' is set to `began' on first scroll, then `changed'. + ;; - `:momentum-phase' is always `none'. + (when (eq (plist-get plist :phase) 'began) + (ultra-scroll--maybe-relax-gc)) + (let* ((scroll-delta (plist-get plist :scrolling-delta-y)) + (delta (or scroll-delta + ;; regular non-touch scroll: fraction of a line + (* (plist-get plist :delta-y) (frame-char-height) + ultra-scroll-mac-multiplier)))) + (ultra-scroll--scroll (round delta) (mwheel-event-window event)))))) + +; scroll-isearch support +(put 'ultra-scroll 'scroll-command t) +(put 'ultra-scroll-mac 'scroll-command t) + +(defun ultra-scroll-check () + "Check and report on the scrolling event data your system provides." + (interactive) + (message "ultra-scroll: checking scroll data -- scroll your mouse wheel or track-pad!") + (let* ((nc (string-match "\\bNATIVE_COMP\\b" system-configuration-features)) + ev) + (while (and (setq ev (read-event)) + (not (memq (event-basic-type ev) + '(wheel-up wheel-down))))) + (display-warning + :debug + (format "ultra-scroll-check: %s detected, found %s pixel scroll data%s" + (event-basic-type ev) + (if (featurep 'mac-win) + (let ((plist (nth 3 ev))) + (cond ((null plist) "NO") + ((plist-get plist :scrolling-delta-y) "FULL") + ((plist-get plist :delta-y) "BASIC") + (t "MISSING"))) + (if (nth 4 ev) "FULL" "MISSING")) + (if nc "" " [NO NATIVE COMPILATION!]"))))) + +;;;; Mode +;;;###autoload +(define-minor-mode ultra-scroll-mode + "Toggle pixel precision scrolling for mac. +When enabled, this minor mode scrolls the display precisely using +full mac trackpad capabilities (and simulating them for regular +mouse). Makes use of the underlying pixel-scrolling capabilities +of `ultra-scroll-mode', which see." + :global t + :group 'scrolling + :keymap pixel-scroll-precision-mode-map ; reuse + (cond + (ultra-scroll-mode + (unless (> scroll-conservatively 0) + (warn "ultra-scroll: scroll-conservatively > 0 is required for smooth scrolling of large images; 101 recommended")) + (unless (= scroll-margin 0) + (warn "ultra-scroll: scroll-margin = 0 is required for glitch-free smooth scrolling")) + (define-key pixel-scroll-precision-mode-map [remap pixel-scroll-precision] + (if (featurep 'mac-win) #'ultra-scroll-mac #'ultra-scroll)) + (setf (get 'pixel-scroll-precision-use-momentum 'us-orig-value) + pixel-scroll-precision-use-momentum) + (setq pixel-scroll-precision-use-momentum nil) + (setq ultra-scroll--gc-percentage-orig gc-cons-percentage)) + (t + (define-key pixel-scroll-precision-mode-map [remap pixel-scroll-precision] nil) + (setq pixel-scroll-precision-use-momentum + (get 'pixel-scroll-precision-use-momentum 'us-orig-value)))) + (setq mwheel-coalesce-scroll-events (not ultra-scroll-mode))) + +(provide 'ultra-scroll) +;;; ultra-scroll.el ends here + |