From db8bf63b949ab65e7ed7ff6b9dfbcd5428cc11c4 Mon Sep 17 00:00:00 2001 From: Po Lu Date: Fri, 26 Nov 2021 14:51:27 +0800 Subject: [PATCH] Move the precise pixel scrolling feature to pixel-scroll.el * etc/NEWS: Update NEWS entry for 'pixel-scroll-precise-mode' * lisp/better-pixel-scroll.el: Remove file. * src/pixel-scroll.el (x-coalesce-scroll-events): New variable declaration. (pixel-scroll-precise-mode-map): New variable. (pixel-scroll-precise-scroll-down): (pixel-scroll-precise-scroll-up): (pixel-scroll-precise): New functions. (pixel-scroll-precise-mode): New minor mode. --- etc/NEWS | 2 +- lisp/better-pixel-scroll.el | 147 ------------------------------------ lisp/pixel-scroll.el | 115 ++++++++++++++++++++++++++++ 3 files changed, 116 insertions(+), 148 deletions(-) delete mode 100644 lisp/better-pixel-scroll.el diff --git a/etc/NEWS b/etc/NEWS index 329de2f811..af8689ab83 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -94,7 +94,7 @@ This controls the thickness of the external borders of the menu bars and pop-up menus. --- -** New minor mode 'better-pixel-scroll-mode'. +** New minor mode 'pixel-scroll-precise-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. diff --git a/lisp/better-pixel-scroll.el b/lisp/better-pixel-scroll.el deleted file mode 100644 index c1469108e0..0000000000 --- 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 . - -;;; 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 249484cf58..9ea92fe903 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 @@ pixel-dead-time (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-precise-mode-map + (let ((map (make-sparse-keymap))) + (define-key map [wheel-down] #'pixel-scroll-precise) + (define-key map [wheel-up] #'pixel-scroll-precise) + map) + "The key map used by `pixel-scroll-precise-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,110 @@ pixel-scroll-down-and-set-window-vscroll (set-window-start nil (pixel-point-at-unseen-line) t) (set-window-vscroll nil vscroll t)) +(defun pixel-scroll-precise-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 pixel-scroll-precise-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 pixel-scroll-precise (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) + (pixel-scroll-precise-scroll-down (- delta)) + (pixel-scroll-precise-scroll-up delta))))) + (mwheel-scroll event arg)))) + +;;;###autoload +(define-minor-mode pixel-scroll-precise-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-precise-mode-map + (setq x-coalesce-scroll-events + (not pixel-scroll-precise-mode))) + (provide 'pixel-scroll) ;;; pixel-scroll.el ends here -- 2.33.1