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
+++ /dev/null
-;;; 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.
;;; Code:
(require 'mwheel)
+(require 'subr-x)
(defvar pixel-wait 0
"Idle time on each step of pixel scroll specified in second.
(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,
(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
projects / emacs.git / commitdiff