master 5d6e1c7 2/2: Move the precision pixel scrolling feature to pixel-scroll.el

[Po Lu]

branch: master
commit 5d6e1c749a669d33db2936b106ae41ce59473ea1
Author: Po Lu <luangruo@yahoo.com>
Commit: Po Lu <luangruo@yahoo.com>

    Move the precision pixel scrolling feature to pixel-scroll.el
    
    * etc/NEWS: Update NEWS entry for 'pixel-scroll-precision-mode'
    
    * lisp/better-pixel-scroll.el: Remove file.
    
    * src/pixel-scroll.el (x-coalesce-scroll-events): New variable
    declaration.
    (pixel-scroll-precision-mode-map): New variable.
    (pixel-scroll-precision-scroll-down):
    (pixel-scroll-precision-scroll-up):
    (pixel-scroll-precision): New functions.
    (pixel-scroll-precision-mode): New minor mode.
---
 etc/NEWS                    |  10 +--
 lisp/better-pixel-scroll.el | 147 --------------------------------------------
 lisp/pixel-scroll.el        | 121 ++++++++++++++++++++++++++++++++++++
 3 files changed, 127 insertions(+), 151 deletions(-)

diff --git a/etc/NEWS b/etc/NEWS
index 329de2f..3a0b46d 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -94,10 +94,12 @@ This controls the thickness of the external borders of the 
menu bars
 and pop-up menus.
 
 ---
-** New minor mode 'better-pixel-scroll-mode'.
-When enabled, using this mode with a capable scroll wheel will result
-in the display being scrolled precisely according to the turning of
-that wheel.
+** New minor mode 'pixel-scroll-precision-mode'.
+When enabled, you can scroll the display up or down by individual
+pixels in a way that corresponds with the movement of your mouse
+wheel, if supported by the mouse wheel.  Unlike 'pixel-scroll-mode',
+this mode scrolls the display pixel-by-pixel, as opposed to only
+animating line-by-line scrolls.
 
 ** Terminal Emacs
 
diff --git a/lisp/better-pixel-scroll.el b/lisp/better-pixel-scroll.el
deleted file mode 100644
index c146910..0000000
--- a/lisp/better-pixel-scroll.el
+++ /dev/null
@@ -1,147 +0,0 @@
-;;; better-pixel-scroll.el --- Pixel scrolling support  -*- lexical-binding:t 
-*-
-
-;; Copyright (C) 2021 Free Software Foundation, Inc.
-
-;; 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 3 of the License, 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.  If not, see <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; This enables the use of smooth scroll events provided by XInput 2
-;; or NS to scroll the display according to the user's precise turning
-;; of the mouse wheel.
-
-;;; Code:
-
-(require 'mwheel)
-(require 'subr-x)
-
-(defvar x-coalesce-scroll-events)
-
-(defvar better-pixel-scroll-mode-map
-  (let ((map (make-sparse-keymap)))
-    (define-key map [wheel-down] #'better-pixel-scroll)
-    (define-key map [wheel-up] #'better-pixel-scroll)
-    map)
-  "The key map used by `better-pixel-scroll-mode'.")
-
-(defun better-pixel-scroll-scroll-down (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."
-  (when-let* ((posn (posn-at-point))
-             (current-y (cdr (posn-x-y posn)))
-             (min-y (+ (window-tab-line-height)
-                       (window-header-line-height)))
-              (cursor-height (line-pixel-height))
-              (window-height (window-text-height nil t))
-              (next-height (save-excursion
-                             (vertical-motion 1)
-                             (line-pixel-height))))
-    (if (and (> delta 0)
-             (<= cursor-height window-height))
-       (while (< (- current-y min-y) delta)
-         (vertical-motion 1)
-          (setq current-y (+ current-y
-                             (line-pixel-height)))
-         (when (eobp)
-           (error "End of buffer")))
-      (when (< (- (cdr (posn-object-width-height posn))
-                  (cdr (posn-object-x-y posn)))
-               (- window-height next-height))
-        (vertical-motion 1)
-        (setq posn (posn-at-point)
-              current-y (cdr (posn-x-y posn)))
-        (while (< (- current-y min-y) delta)
-         (vertical-motion 1)
-          (setq current-y (+ current-y
-                             (line-pixel-height)))
-         (when (eobp)
-           (error "End of buffer")))))
-    (let* ((desired-pos (posn-at-x-y 0 (+ delta
-                                         (window-tab-line-height)
-                                         (window-header-line-height))))
-          (desired-start (posn-point desired-pos))
-          (desired-vscroll (cdr (posn-object-x-y desired-pos))))
-      (unless (eq (window-start) desired-start)
-        (set-window-start nil desired-start t))
-      (set-window-vscroll nil desired-vscroll t))))
-
-(defun better-pixel-scroll-scroll-up (delta)
-  "Scroll the current window up by DELTA pixels."
-  (when-let* ((max-y (- (window-text-height nil t)
-                       (window-tab-line-height)
-                       (window-header-line-height)))
-             (posn (posn-at-point))
-             (current-y (+ (cdr (posn-x-y posn))
-                           (cdr (posn-object-width-height posn)))))
-    (while (< (- max-y current-y) delta)
-      (vertical-motion -1)
-      (setq current-y (- current-y (line-pixel-height)))))
-  (let ((current-vscroll (window-vscroll nil t)))
-    (setq delta (- delta current-vscroll))
-    (set-window-vscroll nil 0 t))
-  (while (> delta 0)
-    (set-window-start nil (save-excursion
-                            (goto-char (window-start))
-                            (when (zerop (vertical-motion -1))
-                             (set-window-vscroll nil 0)
-                             (signal 'beginning-of-buffer nil))
-                            (setq delta (- delta (line-pixel-height)))
-                            (point))
-                     t))
-  (when (< delta 0)
-    (when-let* ((desired-pos (posn-at-x-y 0 (+ (- delta)
-                                         (window-tab-line-height)
-                                         (window-header-line-height))))
-               (desired-start (posn-point desired-pos))
-               (desired-vscroll (cdr (posn-object-x-y desired-pos))))
-      (unless (eq (window-start) desired-start)
-        (set-window-start nil desired-start t))
-      (set-window-vscroll nil desired-vscroll t))))
-
-(defun better-pixel-scroll (event &optional arg)
-  "Scroll the display according to EVENT.
-Take into account any pixel deltas in EVENT to scroll the display
-according to the user's turning the mouse wheel.  If EVENT does
-not have precise scrolling deltas, call `mwheel-scroll' instead.
-ARG is passed to `mwheel-scroll', should that be called."
-  (interactive (list last-input-event current-prefix-arg))
-  (let ((window (mwheel-event-window event)))
-    (if (and (nth 4 event)
-             (zerop (window-hscroll window)))
-        (let ((delta (round (cdr (nth 4 event)))))
-          (if (> (abs delta) (window-text-height window t))
-              (mwheel-scroll event arg)
-            (with-selected-window window
-              (if (< delta 0)
-                 (better-pixel-scroll-scroll-down (- delta))
-                (better-pixel-scroll-scroll-up delta)))))
-      (mwheel-scroll event arg))))
-
-;;;###autoload
-(define-minor-mode better-pixel-scroll-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 better-pixel-scroll-mode-map
-  (setq x-coalesce-scroll-events
-        (not better-pixel-scroll-mode)))
-
-(provide 'better-pixel-scroll)
-
-;;; better-pixel-scroll.el ends here.
diff --git a/lisp/pixel-scroll.el b/lisp/pixel-scroll.el
index 249484c..f6d1d0f 100644
--- a/lisp/pixel-scroll.el
+++ b/lisp/pixel-scroll.el
@@ -67,6 +67,7 @@
 ;;; Code:
 
 (require 'mwheel)
+(require 'subr-x)
 
 (defvar pixel-wait 0
   "Idle time on each step of pixel scroll specified in second.
@@ -90,6 +91,15 @@ is always with pixel resolution.")
 (defvar pixel-last-scroll-time 0
   "Time when the last scrolling was made, in second since the epoch.")
 
+(defvar x-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)
+    map)
+  "The key map used by `pixel-scroll-precision-mode'.")
+
 (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,
@@ -354,5 +364,116 @@ Otherwise, redisplay will reset the window's vscroll."
   (set-window-start nil (pixel-point-at-unseen-line) t)
   (set-window-vscroll nil vscroll t))
 
+;; FIXME: This doesn't work when DELTA is larger than the height
+;; of the current window, and someone should probably fix that
+;; at some point.
+(defun pixel-scroll-precision-scroll-down (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."
+  (when-let* ((posn (posn-at-point))
+             (current-y (cdr (posn-x-y posn)))
+             (min-y (+ (frame-char-height)
+                        (window-tab-line-height)
+                       (window-header-line-height)))
+              (cursor-height (line-pixel-height))
+              (window-height (window-text-height nil t))
+              (next-height (save-excursion
+                             (vertical-motion 1)
+                             (line-pixel-height))))
+    (if (and (> delta 0)
+             (<= cursor-height window-height))
+       (while (< (- current-y min-y) delta)
+         (vertical-motion 1)
+          (setq current-y (+ current-y
+                             (line-pixel-height)))
+         (when (eobp)
+           (signal 'end-of-buffer nil)))
+      (when (< (- (cdr (posn-object-width-height posn))
+                  (cdr (posn-object-x-y posn)))
+               (- window-height next-height))
+        (vertical-motion 1)
+        (setq posn (posn-at-point)
+              current-y (cdr (posn-x-y posn)))
+        (while (< (- current-y min-y) delta)
+         (vertical-motion 1)
+          (setq current-y (+ current-y
+                             (line-pixel-height)))
+         (when (eobp)
+           (signal 'end-of-buffer nil)))))
+    (let* ((desired-pos (posn-at-x-y 0 (+ delta
+                                         (window-tab-line-height)
+                                         (window-header-line-height))))
+          (desired-start (posn-point desired-pos))
+          (desired-vscroll (cdr (posn-object-x-y desired-pos))))
+      (unless (eq (window-start) desired-start)
+        (set-window-start nil desired-start t))
+      (set-window-vscroll nil desired-vscroll t))))
+
+(defun pixel-scroll-precision-scroll-up (delta)
+  "Scroll the current window up by DELTA pixels."
+  (when-let* ((max-y (- (window-text-height nil t)
+                        (frame-char-height)
+                       (window-tab-line-height)
+                       (window-header-line-height)))
+             (posn (posn-at-point))
+             (current-y (+ (cdr (posn-x-y posn))
+                           (line-pixel-height))))
+    (while (< (- max-y current-y) delta)
+      (vertical-motion -1)
+      (setq current-y (- current-y (line-pixel-height)))))
+  (let ((current-vscroll (window-vscroll nil t)))
+    (setq delta (- delta current-vscroll))
+    (set-window-vscroll nil 0 t))
+  (while (> delta 0)
+    (set-window-start nil (save-excursion
+                            (goto-char (window-start))
+                            (when (zerop (vertical-motion -1))
+                             (set-window-vscroll nil 0)
+                             (signal 'beginning-of-buffer nil))
+                            (setq delta (- delta (line-pixel-height)))
+                            (point))
+                     t))
+  (when (< delta 0)
+    (when-let* ((desired-pos (posn-at-x-y 0 (+ (- delta)
+                                         (window-tab-line-height)
+                                         (window-header-line-height))))
+               (desired-start (posn-point desired-pos))
+               (desired-vscroll (cdr (posn-object-x-y desired-pos))))
+      (unless (eq (window-start) desired-start)
+        (set-window-start nil desired-start t))
+      (set-window-vscroll nil desired-vscroll t))))
+
+;; FIXME: This doesn't work when there's an image above the current
+;; line that is taller than the window.
+(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)
+             (zerop (window-hscroll window)))
+        (let ((delta (round (cdr (nth 4 event)))))
+          (if (> (abs delta) (window-text-height window t))
+              (mwheel-scroll event nil)
+            (with-selected-window window
+              (if (< delta 0)
+                 (pixel-scroll-precision-scroll-down (- delta))
+                (pixel-scroll-precision-scroll-up delta)))))
+      (mwheel-scroll event 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 x-coalesce-scroll-events
+        (not pixel-scroll-precision-mode)))
+
 (provide 'pixel-scroll)
 ;;; pixel-scroll.el ends here