;;; iscroll.el --- Smooth scrolling over images      -*- lexical-binding: t; -*-

;; Author: Yuan Fu <casouri@gmail.com>
;; Maintainer: Yuan Fu <casouri@gmail.com>
;; URL: https://github.com/casouri/iscroll
;; Package-Version: 20210128.1938
;; Package-Commit: d6e11066169d232fe23c2867d44c012722ddfc5a
;; Version: 1.0.0
;; Keywords: convenience, image
;; Package-Requires: ((emacs "26.0"))

;; This file is not part of GNU Emacs.

;; This program 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.

;; This program 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 this program.  If not, see <https://www.gnu.org/licenses/>.

;;; Commentary:
;;
;; Gone are the days when images jumps in and out of the window when
;; scrolling! This package makes scrolling over images as if the image
;; is made of many lines, instead of a single line. (Indeed, sliced
;; image with default scrolling has the similar behavior as what this
;; package provides.)
;;
;; To use this package:
;;
;;     M-x iscroll-mode RET
;;
;; This mode remaps mouse scrolling functions and `next/previous-line'.
;; If you use other commands, you need to adapt them accordingly. See
;; `iscroll-mode-map' and `iscroll-mode' for some inspiration.
;;
;; You probably don't want to enable this in programming modes because
;; it is slower than normal scrolling commands.
;;
;; If a line is taller than double the default line height, smooth
;; scrolling is triggered and Emacs will reveal one line’s height each
;; time.
;;
;; Commands provided:
;;
;; - iscroll-up
;; - iscroll-down
;; - iscroll-next-line
;; - iscroll-previous-line
;;

;;; Code:
;;

(require 'cl-lib)

(defvar iscroll-preserve-screen-position
  scroll-preserve-screen-position
  "Whether to preserve screen position when scrolling.
\(I want to control this behavior for iscroll separately.)")

(defun iscroll-up (&optional arg)
  "Scroll up ARG lines.
Normally just calls `scroll-up'. But if the top of the window is
an image, scroll inside the image. Return the number of logical
lines scrolled."
  (interactive "p")
  (let ((arg (or arg 1))
        (display-lines-scrolled 0)
        (original-point (point))
        (scroll-amount nil)
        (need-to-recalculate-img-height t)
        (preserve-screen-pos iscroll-preserve-screen-position)
        img-height
        hit-end-of-buffer)
    ;; 1) We first do a dry-run: not actually scrolling, just moving
    ;; point and modifying SCROLL-AMOUNT.
    (goto-char (window-start))
    (while (> arg 0)
      ;; Initialize SCROLL-AMOUNT when we arrived at a new line or
      ;; first entered the command.
      (when (null scroll-amount)
        (setq scroll-amount (window-vscroll nil t)))
      ;; `line-pixel-height' is expensive so we try to call it as less
      ;; as possible.
      (when need-to-recalculate-img-height
        (setq img-height (line-pixel-height)
              need-to-recalculate-img-height nil))
      ;; Scroll.
      (if (and (>= img-height (* 2 (default-line-height)))
               (< scroll-amount img-height))
          ;; If we are in the middle of scrolling an image, scroll
          ;; that image.
          (setq scroll-amount
                (min (+ scroll-amount (default-line-height))
                     img-height))
        ;; If we are not on an image or the image is scrolled over,
        ;; scroll display line.
        (cl-incf display-lines-scrolled)
        (setq need-to-recalculate-img-height t)
        ;; We hit the end of buffer, stop.
        (when (not (eq (vertical-motion 1) 1))
          (setq hit-end-of-buffer t)
          (setq arg 0))
        (setq scroll-amount nil))
      (cl-decf arg))
    ;; 2) Finally, we’ve finished the dry-run, apply the result.
    ;;
    ;; The third argument `t' tells redisplay that (point) doesn't
    ;; have to be the window start and completely visible. That
    ;; allows our vscroll value to survive.
    (set-window-start nil (point) t)
    (if scroll-amount
        (set-window-vscroll nil scroll-amount t)
      (set-window-vscroll nil 0 t))
    ;; 3) Misc stuff.
    ;;
    ;; If the original point is after window-start, it is in the
    ;; visible portion of the window, and is safe to go back to.
    (if (> original-point (window-start))
        (goto-char original-point)
      ;; If not, we just stay at current position, i.e. window-start.
      (setq preserve-screen-pos nil))
    ;; (Maybe) move point to preserve screen position.
    (when preserve-screen-pos
      (vertical-motion display-lines-scrolled))
    ;; Show “error message”.
    (when hit-end-of-buffer
      (message "%s" (error-message-string '(end-of-buffer))))
    display-lines-scrolled))

(defun iscroll-down (&optional arg)
  "Scroll down ARG lines.
Normally just calls `scroll-down'. But if the top of the window is
an image, scroll inside the image. Return the number of logical
lines scrolled. If PRESERVE-SCREEN-POS non-nil, try to preserve
screen position."
  (interactive "p")
  (let ((arg (or arg 1))
        (display-lines-scrolled 0)
        (original-point (point))
        ;; Nil means this needs to re-measured.
        (scroll-amount nil)
        (preserve-screen-pos iscroll-preserve-screen-position)
        hit-beginning-of-buffer)
    ;; 1) Dry-run.
    (goto-char (window-start))
    (while (> arg 0)
      (when (null scroll-amount)
        (setq scroll-amount (window-vscroll nil t)))
      (let ((img-height (line-pixel-height)))
        (if (and (>= img-height (* 2 (default-line-height)))
                 (> scroll-amount 0))
            ;; Scroll image.
            (setq scroll-amount
                  (- scroll-amount (default-line-height)))
          ;; Scroll display line.
          (when (not (eq (vertical-motion -1) -1))
            ;; If we hit the beginning of buffer, stop.
            (setq hit-beginning-of-buffer t
                  arg 0))
          (cl-incf display-lines-scrolled)
          ;; If the line we stopped at is an image, we don't want to
          ;; show it completely, instead, modify vscroll and only
          ;; show a bottom strip of it. If we are at the beginning
          ;; of the buffer and `vertical-motion' returns 0, we don't
          ;; want to do this.
          (let ((img-height (line-pixel-height)))
            (if (>= img-height (* 2 (default-line-height)))
                (setq scroll-amount (- img-height (default-line-height)))
              (setq scroll-amount nil)))))
      (cl-decf arg))
    ;; 2) Apply result.
    (set-window-start nil (point) t)
    (if scroll-amount
        (set-window-vscroll nil scroll-amount t)
      (set-window-vscroll nil 0 t))
    ;; 3) Misc
    ;;
    ;; HACK: There is no fast and reliable way to get the last visible
    ;; point, hence this hack: move point up until it is visible.
    (goto-char original-point)
    ;; Checking point > window-start is important, otherwise we could
    ;; fall into infinite loop. E.g., when point = window-start and
    ;; under the point is an image that is not completely visible.
    (while (and (> (point) (window-start))
                (not (pos-visible-in-window-p (point))))
      (setq preserve-screen-pos nil)
      (vertical-motion -2))
    (when (and preserve-screen-pos (not hit-beginning-of-buffer))
      (vertical-motion (- display-lines-scrolled)))
    (when hit-beginning-of-buffer
      (message "%s" (error-message-string '(beginning-of-buffer))))
    display-lines-scrolled))

(defvar iscroll--goal-column nil
  "Goal column when scrolling.")

(defun iscroll--current-column ()
  "Return the current column of point in current screen line.
‘current-column’ counts columns from logical line beginning, this
function counts from visual line beginning."
  (save-excursion
    (let ((col (current-column)))
      ;; Go to visual line beginning.
      (vertical-motion 0)
      (- col (current-column)))))

(defun iscroll-forward-line (&optional arg)
  "Smooth `forward-line'.
ARG is the number of lines to move."
  (interactive "p")
  (let* ((arg (or arg 1))
         (abs-arg (abs arg))
         (step (if (> arg 0) 1 -1))
         (scroll-fn (if (> arg 0)
                        #'iscroll-up
                      #'iscroll-down))
         (old-point (point))
         (first-command-p (not (memq last-command
                                     '(iscroll-next-line
                                       iscroll-previous-line))))
         ;; Calculate the goal column. The goal column is either
         ;; inherited from previous calls to this command, or
         ;; calculated by visual column.
         (goal-column (if (or first-command-p (not iscroll--goal-column))
                          (setq iscroll--goal-column
                                (iscroll--current-column))
                        (or iscroll--goal-column 0)))
         ;; We don't want to preserve screen position when moving point.
         (iscroll-preserve-screen-position nil)
         hit-boundary)
    ;; Because in most cases we move into visible portions, we move
    ;; first and check after, this should be faster than check first
    ;; and move after.
    (while (> abs-arg 0)
      ;; Move point. `move-to-column' counts columns from logical line
      ;; beginnings and `vertical-motion' counts columns from visual
      ;; beginnings. So `vertical-motion' works with line-wrapping but
      ;; `move-to-column' does not.
      (when (not (eq (vertical-motion (cons iscroll--goal-column step))
                     step))
        ;; If we hit beginning or end of buffer, stop.
        (setq hit-boundary t
              abs-arg 0))
      (when (not (pos-visible-in-window-p (point)))
        ;; The new point is not fully visible! Scroll up/down one line
        ;; to try to accommodate that line.
        (funcall scroll-fn 1))
      ;; We scrolled one line but that line is still not fully
      ;; visible, move the point back so that redisplay doesn’t force
      ;; the whole line into visible region. Partially visible is ok,
      ;; completely invisible is not ok.
      (when (and (not (pos-visible-in-window-p (point)))
                 ;; If the image is taller than the window and is the
                 ;; first row of the window, it is ok to leave point
                 ;; on it.
                 (<= (line-pixel-height) (window-text-height nil t)))
        (goto-char old-point)
        (setq hit-boundary nil))
      (cl-decf abs-arg))
    ;; If we hit buffer boundary and didn’t back off, show “error
    ;; message”.
    (when hit-boundary
      (message "%s" (error-message-string
                     (list (if (> arg 0)
                               'end-of-buffer
                             'beginning-of-buffer)))))))

(defun iscroll-next-line (&optional arg _)
  "Smooth `next-line'.
ARG is the number of lines to move."
  (interactive "p")
  (iscroll-forward-line arg))

(defun iscroll-previous-line (&optional arg _)
  "Smooth `previous-line'.
ARG is the number of lines to move."
  (interactive "p")
  (iscroll-forward-line (- (or arg 1))))

(defvar iscroll-mode-map (make-sparse-keymap)
  "Minor mode map for `iscroll-mode'.")

;;;###autoload
(define-minor-mode iscroll-mode
  "Smooth scrolling over images."
  :lighter " IS"
  :keymap iscroll-mode-map
  :group 'scrolling
  (if iscroll-mode
      (progn
        (setq-local mwheel-scroll-up-function #'iscroll-up
                    mwheel-scroll-down-function #'iscroll-down)
        ;; We don’t remap next/previous-line in the minor mode map
        ;; because that shallows ivy’s binding.
        (local-set-key [remap next-line] #'iscroll-next-line)
        (local-set-key [remap previous-line] #'iscroll-previous-line))
    (kill-local-variable 'mwheel-scroll-up-function)
    (kill-local-variable 'mwheel-scroll-down-function)
    (local-set-key [remap next-line] nil)
    (local-set-key [remap previous-line] nil)))

(provide 'iscroll)

;;; iscroll.el ends here