1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
| | ;;; 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.
|