lisp/pixel-scroll.el

   1 ;;; pixel-scroll.el --- Scroll a line smoothly
   2
   3 ;; Copyright (C) 2017-2018 Free Software Foundation, Inc.
   4 ;; Author: Tak Kunihiro <tkk@misasa.okayama-u.ac.jp>
   5 ;; Keywords: mouse
   6 ;; Package: emacs
   7
   8 ;; This file is part of GNU Emacs.
   9
  10 ;; GNU Emacs is free software: you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation, either version 3 of the License, or
  13 ;; (at your option) any later version.
  14
  15 ;; GNU Emacs is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.
  22
  23 ;; Usage:
  24 ;;
  25 ;; To interactively toggle the mode:
  26 ;;
  27 ;;   M-x pixel-scroll-mode RET
  28 ;;
  29 ;; To make the mode permanent, put these in your init file:
  30 ;;
  31 ;;   (require 'pixel-scroll)
  32 ;;   (pixel-scroll-mode 1)
  33
  34 ;;; Commentary:
  35
  36 ;; This package offers a global minor mode which makes mouse-wheel
  37 ;; scroll a line smoothly.
  38 ;;
  39 ;; Scrolling a line up by `set-window-vscroll' and that by `scroll-up'
  40 ;; give similar display as shown below.
  41 ;;
  42 ;;  A: (scroll-up 1)
  43 ;;  B: (set-window-vscroll nil (frame-char-height) t)
  44 ;;
  45 ;; Also scrolling a pixel up by `set-window-vscroll' and that by
  46 ;; `scroll-up' give similar display, when vscroll is the last pixel of
  47 ;; the line, as shown below.
  48 ;;
  49 ;;  A: (scroll-up 1)
  50 ;;  B: (set-window-vscroll nil (1- (frame-char-height) t)) (scroll-up 1)
  51 ;;
  52 ;; When point reaches to the top of a window on scroll by
  53 ;; `set-window-vscroll', vscroll is set to zero.  To scroll a line
  54 ;; smoothly and continuously, this package scrolls a line by following
  55 ;; sequences.
  56 ;;
  57 ;;  (vertical-motion 1)
  58 ;;  (dolist (vs (number-sequence 1 (1- (frame-char-height))))
  59 ;;    (set-window-vscroll nil vs t) (sit-for 0))
  60 ;;  (scroll-up 1)
  61
  62 ;;; Todo:
  63 ;;
  64 ;; Allowing pixel-level scrolling in Emacs requires a thorough review
  65 ;; of the related functionalities, to make sure none of them zeroes
  66 ;; out vscroll where users won't want that.
  67
  68 ;;; Code:
  69
  70 (require 'mwheel)
  71
  72 (defvar pixel-wait 0
  73   "Idle time on each step of pixel scroll specified in second.
  74 More wait will result in slow and gentle scroll.")
  75
  76 (defvar pixel-resolution-fine-flag nil
  77   "Set scrolling resolution to pixels instead of a line.
  78 When it is t, scrolling resolution is number of pixels obtained
  79 by `frame-char-height' instead of a line.  When it is number,
  80 scrolling resolution is set to number of pixels specified.  In
  81 case you need scrolling resolution of a pixel, set to 1.  After a
  82 pixel scroll, typing \\[next-line] or \\[previous-line] scrolls the window to make it
  83 fully visible, and undoes the effect of the pixel-level scroll.")
  84
  85 (defvar pixel-dead-time 0.1
  86   "Minimal interval in seconds before next smooth scrolling.
  87 If another scrolling request arrives within this period, scrolling
  88 will be carried out without pixel resolution.  If zero, scrolling
  89 is always with pixel resolution.")
  90
  91 (defvar pixel-last-scroll-time 0
  92   "Time when the last scrolling was made, in second since the epoch.")
  93
  94 (defun pixel-scroll-in-rush-p ()
  95   "Return non-nil if next scroll should be non-smooth.
  96 When scrolling request is delivered soon after the previous one,
  97 user is in hurry.  When the time since last scroll is larger than
  98 `pixel-dead-time', we are ready for another smooth scroll, and this
  99 function returns nil."
 100   (let* ((current-time (float-time))
 101          (scroll-in-rush-p (< (- current-time pixel-last-scroll-time)
 102                               pixel-dead-time)))
 103     (setq pixel-last-scroll-time current-time)
 104     scroll-in-rush-p))
 105
 106 ;;;###autoload
 107 (define-minor-mode pixel-scroll-mode
 108   "A minor mode to scroll text pixel-by-pixel.
 109 With a prefix argument ARG, enable Pixel Scroll mode if ARG is positive,
 110 and disable it otherwise.  If called from Lisp, enable Pixel Scroll mode
 111 if ARG is omitted or nil."
 112   :init-value nil
 113   :group 'scrolling
 114   :global t
 115   :version "26.1"
 116
 117   (if pixel-scroll-mode
 118       (setq mwheel-scroll-up-function 'pixel-scroll-up
 119             mwheel-scroll-down-function 'pixel-scroll-down)
 120     (setq mwheel-scroll-up-function 'scroll-up
 121           mwheel-scroll-down-function 'scroll-down)))
 122
 123 (defun pixel-scroll-up (&optional arg)
 124   "Scroll text of selected window up ARG lines.
 125 This is an alternative of `scroll-up'.  Scope moves downward."
 126   (interactive)
 127   (or arg (setq arg 1))
 128   (if (pixel-scroll-in-rush-p)
 129       (scroll-up arg)
 130     (dotimes (ii arg)                    ; move scope downward
 131       (let ((amt (if pixel-resolution-fine-flag
 132                      (if (integerp pixel-resolution-fine-flag)
 133                          pixel-resolution-fine-flag
 134                        (frame-char-height))
 135                    (pixel-line-height))))
 136         (if (pixel-eob-at-top-p)      ; when end-of-the-buffer is close
 137             (scroll-up 1)             ; relay on robust method
 138           (while (pixel-point-at-top-p amt) ; prevent too late (multi tries)
 139             (vertical-motion 1))            ; move point downward
 140           (pixel-scroll-pixel-up amt))))))  ; move scope downward
 141
 142 (defun pixel-scroll-down (&optional arg)
 143   "Scroll text of selected window down ARG lines.
 144 This is and alternative of `scroll-down'.  Scope moves upward."
 145   (interactive)
 146   (or arg (setq arg 1))
 147   (if (pixel-scroll-in-rush-p)
 148       (scroll-down arg)
 149     (dotimes (ii arg)
 150       (let ((amt (if pixel-resolution-fine-flag
 151                      (if (integerp pixel-resolution-fine-flag)
 152                          pixel-resolution-fine-flag
 153                        (frame-char-height))
 154                    (pixel-line-height -1))))
 155         (while (pixel-point-at-bottom-p amt) ; prevent too late (multi tries)
 156           (vertical-motion -1))              ; move point upward
 157         (if (or (pixel-bob-at-top-p amt) ; when beginning-of-the-buffer is seen
 158                 (pixel-eob-at-top-p))    ; for file with a long line
 159             (scroll-down 1)              ; relay on robust method
 160           (pixel-scroll-pixel-down amt))))))
 161
 162 (defun pixel-bob-at-top-p (amt)
 163   "Return non-nil if window-start is at beginning of the current buffer.
 164 Window must be vertically scrolled by not more than AMT pixels."
 165   (and (equal (window-start) (point-min))
 166        (< (window-vscroll nil t) amt)))
 167
 168 (defun pixel-eob-at-top-p ()
 169   "Return non-nil if end of buffer is at top of window."
 170   (<= (count-lines (window-start) (window-end)) 2)) ; count-screen-lines
 171
 172 (defun pixel-posn-y-at-point ()
 173   "Return y coordinates of point in pixels of current window.
 174 This returns nil when horizontally scrolled."
 175   (when (equal (window-hscroll) 0)
 176     (save-excursion
 177       ;; When there's an overlay string on a line, move
 178       ;; point by (beginning-of-visual-line).
 179       (beginning-of-visual-line)
 180       ;; (- (cadr (pos-visible-in-window-p (point) nil t))
 181       ;;    (line-pixel-height))
 182       (cdr (posn-x-y (posn-at-point))))))
 183
 184 (defun pixel-point-at-top-p (amt)
 185   "Return if point is located at top of a window on coming scroll of AMT pixels.
 186 When location of point was not obtained, this returns if point is at top
 187 of window."
 188   (let ((y (pixel-posn-y-at-point))
 189         top-margin)
 190     (cond
 191      (y
 192       (setq top-margin y)
 193       (< top-margin amt))
 194      (t
 195       (<= (count-lines (window-start) (point)) 1)))))
 196
 197 (defun pixel-point-at-bottom-p (amt)
 198   "Return if point is located at bottom of window on coming scroll of AMT pixels.
 199 When location of point was not obtained, this returns nil."
 200   (let* ((edges (window-inside-pixel-edges))
 201          (height (- (nth 3 edges) (nth 1 edges))) ; (- bottom top)
 202          (y (pixel-posn-y-at-point))
 203          bottom-margin)
 204     (when y
 205       (setq bottom-margin (- height (+ y (pixel-visual-line-height))))
 206       (< bottom-margin amt)))) ; coming unseen line
 207
 208 (defun pixel-scroll-pixel-up (amt)
 209   "Scroll text of selected windows up AMT pixels.
 210 Scope moves downward."
 211   (while (>= (+ (window-vscroll nil t) amt)
 212              (pixel-line-height))
 213     (setq amt (- amt (pixel--whistlestop-line-up)))) ; major scroll
 214   (pixel--whistlestop-pixel-up amt)) ; minor scroll
 215
 216 (defun pixel-scroll-pixel-down (amt)
 217   "Scroll text of selected windows down AMT pixels.
 218 Scope moves upward."
 219   (while (> amt 0)
 220     (let ((vs (window-vscroll nil t)))
 221       (if (equal vs 0)
 222           (progn
 223             ;; On horizontal scrolling, move cursor.
 224             (when (> (window-hscroll) 0)
 225               (vertical-motion -1))
 226             (pixel-scroll-down-and-set-window-vscroll
 227              (1- (pixel-line-height -1))))
 228         (set-window-vscroll nil (1- vs) t))
 229       (setq amt (1- amt))
 230       (sit-for pixel-wait))))
 231
 232 (defun pixel--whistlestop-line-up ()
 233   "Scroll text upward a line with each pixel whistlestopped.
 234 When `vscroll' is non-zero, complete scrolling a line.  When
 235 `vscroll' is larger than height of multiple lines, for example
 236 88, this flushes multiple lines.  At the end, `vscroll' will be
 237 zero.  This assumes that the lines are with the same height.
 238 Scope moves downward.  This function returns number of pixels
 239 that was scrolled."
 240   (let* ((src (window-vscroll nil t))  ; EXAMPLE (initial)      @0   @8  @88
 241          (height (pixel-line-height))  ;                        25   25   23
 242          (line (1+ (/ src height)))    ; catch up + one line     1    1    4
 243          (dst (* line height))         ; goal                  @25  @25  @92
 244          (delta (- dst src)))          ; pixels to be scrolled  25   17    4
 245     (pixel--whistlestop-pixel-up (1- delta)) ; until one less  @24  @24  @91
 246     (dotimes (ii line)
 247       ;; On horizontal scrolling, move cursor.
 248       (when (> (window-hscroll) 0)
 249         (vertical-motion 1))
 250       (scroll-up 1))
 251     (sit-for pixel-wait)               ; scroll 1 pixel         @0   @0   @0
 252     delta))
 253
 254 (defun pixel--whistlestop-pixel-up (n)
 255   "Scroll text upward by N pixels with each pixel whistlestopped.
 256 Scope moves downward."
 257   (when (> n 0)
 258     (let ((vs0 (window-vscroll nil t)))
 259       (dolist (vs (number-sequence (1+ vs0) (+ vs0 n)))
 260         (set-window-vscroll nil vs t) (sit-for pixel-wait)))))
 261
 262 (defun pixel-line-height (&optional pos)
 263   "Return height in pixels of text line at POS in the selected window.
 264 When POS is nil or negative, height of the first line or the coming
 265 unseen line above the first line, respectively, is provided."
 266   (or pos (setq pos (window-start)))
 267   (when (< pos 0)
 268     (setq pos (pixel-point-at-unseen-line)))
 269   (let ((vs1 (window-vscroll nil t))
 270         height)
 271     (set-window-vscroll nil 0 t)
 272     (save-excursion
 273       (goto-char pos)
 274       (setq height (pixel-visual-line-height))) ; line-pixel-height, frame-char-height
 275     (set-window-vscroll nil vs1 t)
 276     height))
 277
 278 (defun pixel-visual-line-height ()
 279   "Return height in pixels of text line where cursor is in the selected window."
 280   (let ((pos (pixel-visible-pos-in-window)))
 281     (cond
 282      ;; When a char of line is shown, obtain height by
 283      ;; (line-pixel-height).
 284      (pos (save-excursion (goto-char pos) (line-pixel-height)))
 285      ;; When no char of line is shown but the line is at the top,
 286      ;; obtain height by (line-pixel-height).  This is based on
 287      ;; expected response from display engine.  See following
 288      ;; discussion.
 289      ;; https://lists.gnu.org/r/emacs-devel/2017-10/msg00621.html
 290      ((equal (count-lines (window-start) (point)) 1)
 291       (line-pixel-height))
 292      ;; No char of line is shown and the line is not at the top,
 293      ;; obtain height by (frame-char-height).
 294      (t (frame-char-height)))))
 295
 296 (defun pixel-visible-pos-in-window ()
 297   "Return position shown on text line where cursor is in the selected window.
 298 This will look for positions of point and end-of-visual-line,
 299 then positions from beginning-of-visual-line to
 300 end-of-visual-line.  When no char in a line is shown, this
 301 returns nil."
 302   (let* ((beginning-of-visual-line-pos (save-excursion (beginning-of-visual-line) (point)))
 303          (end-of-visual-line-pos (save-excursion (end-of-visual-line) (point)))
 304          (pos-list (number-sequence beginning-of-visual-line-pos end-of-visual-line-pos))
 305          (edges (window-inside-pixel-edges))
 306          (width (- (nth 2 edges) (nth 0 edges)))
 307          posn-x
 308          visible-pos)
 309     ;; Optimize list of position to be surveyed.
 310     (push end-of-visual-line-pos pos-list)
 311     (push (point) pos-list)
 312     (delete-dups pos-list)
 313     ;; Find out a char with position X that is more than zero and less
 314     ;; than width of screen.
 315     (while (and (not visible-pos)
 316                 pos-list)
 317       (setq posn-x (car (pos-visible-in-window-p (car pos-list) nil t)))
 318       (if (and posn-x
 319                (<= 0 posn-x)
 320                (< posn-x width))
 321           (setq visible-pos (car pos-list))
 322         (setq pos-list (cdr pos-list))))
 323     visible-pos))
 324
 325 (defun pixel-point-at-unseen-line ()
 326   "Return the character position of line above the selected window.
 327 The returned value is the position of the first character on the
 328 unseen line just above the scope of current window."
 329   (let* ((pos0 (window-start))
 330          (vscroll0 (window-vscroll nil t))
 331          (pos
 332           (save-excursion
 333             (goto-char pos0)
 334             (if (bobp)
 335                 (point-min)
 336               ;; When there's an overlay string at window-start,
 337               ;; (beginning-of-visual-line 0) stays put.
 338               (let ((ppos (point))
 339                     (tem (beginning-of-visual-line 0)))
 340                 (if (eq tem ppos)
 341                     (vertical-motion -1))
 342                 (point))))))
 343     ;; restore initial position
 344     (set-window-start nil pos0 t)
 345     (set-window-vscroll nil vscroll0 t)
 346     pos))
 347
 348 (defun pixel-scroll-down-and-set-window-vscroll (vscroll)
 349   "Scroll down a line and set VSCROLL in pixels.
 350 It is important to call `set-window-start' to force the display
 351 engine use that particular position as the window-start point.
 352 Otherwise, redisplay will reset the window's vscroll."
 353   (set-window-start nil (pixel-point-at-unseen-line) t)
 354   (set-window-vscroll nil vscroll t))
 355
 356 (provide 'pixel-scroll)
 357 ;;; pixel-scroll.el ends here