bug#18923: Alternative scrolling model

[E Sabof]

I've made a prototype for an alternative way to scroll. Essentially scrolling 
is done pixelwise irrespective of content. Whole lines are scrolled "normally", 
and the remainder is vscrolled. If the end result is close to a line boundary 
it gets "snapped" to it.

This prevents unpleasant jumping when encountering an image. It doesn't handle 
the "image taller than window" case, but it would if `st-height' could measure 
more accurately.

Evgeni

;; Any vscroll adjustements will be reset by line-move
(require 'cl-lib)
(defun st-message (&rest args)
  ;; (apply 'message args)
  )

(defvar st-ov nil)
(defun st-height (&optional pos)
  "Won't report accurately, if the line is higher than window."
  (cl-flet (( posn-y ()
              (cdr (posn-x-y (or (posn-at-point)
                                 (progn
                                   (vertical-motion 0)
                                   (set-window-start nil (point))
                                   (posn-at-point)))))))
    (save-excursion
      (save-window-excursion
        (let* ((ws (window-vscroll nil t))
               a b)
          (when (cl-plusp ws)
            (set-window-vscroll nil 0 t))
          (setq a (posn-y))
          (vertical-motion 1)
          (setq b (posn-y))
          (when (cl-plusp ws)
            (set-window-vscroll nil ws t))
          (- b a)
          )))))

(cl-defun st-get-lines (ammount)
  "Provide the information required to scroll by AMMOUNT.

AMMOUNT can be positive, if scrolling towards the end of the
buffer, or negative otherwise.

Returns \(list vscroll \(list lines\)\), where \"vscroll\" is the
current \(window-vscroll\) and \"lines\" are the lines are enogh
or more lines required for to scroll."

  (let* (( direction (if (cl-plusp ammount) 1 -1))
         ( vscroll (window-vscroll nil t))
         rows)
    (save-excursion
      (goto-char (window-start))
      (cl-incf ammount vscroll)
      (when (cl-minusp direction)
        (unless (cl-minusp ammount)
          (cl-return-from st-get-lines
            (list vscroll nil)))
        (vertical-motion -1))
      (cl-loop do (push (st-height) rows)
               until (or (zerop (vertical-motion direction))
                         ;; >= ?
                         (>= (cl-reduce '+ rows)
                             (abs ammount))))
      (list vscroll (nreverse rows)))))

(cl-defun st-move (lines vscroll)
  ;; vscroll changes aren't always displayed. Haven't found a work-around for 
this.
  (let (( ori-point (point))
        ( new-ws
          (save-excursion
            (goto-char (window-start))
            (vertical-motion lines)
            (point))))
    (progn
      (set-window-start nil new-ws)

      ;; If I don't do this, vscroll might get reset to 0

      ;; (point) might change after this

      ;; (window-start) might change after this, if the cursor is positioned on
      ;; that image, and scrolling down. This always happends if image would be
      ;; split at the bottom, but sometimes it happens earlier. What follows is
      ;; a work-around.

      (redisplay t)
      (when (/= (window-start) new-ws)
        ;; (message "HIT")
        (vertical-motion -1)
        (set-window-start nil new-ws)
        (redisplay t)
        )
      )
    (set-window-vscroll nil vscroll t)

    ;; Prevents flashes of incorrectly positioned images

    ;; (window-start) might change after this, if the cursor is on an image and
    ;; it might get divided on the upper edge

    (redisplay t)

    (when (/= (window-start) new-ws)
      ;; (message "HIT2")
      (vertical-motion 1)
      (set-window-start nil new-ws)
      (redisplay t)
      )

    ))

(cl-defun scroll--backtick (&optional (arg 1) pixelwise snap)
  (interactive)

  (let* (( default-height (default-line-height))
         ( pixels-to-move (if pixelwise
                              arg
                            (* arg default-height)))
         ( snap (or snap (/ default-height 2)))
         ( line-info (st-get-lines (- pixels-to-move)))
         ( heights (cadr line-info))
         ( initial-vscroll (car line-info))
         ( excess 0)
         enough-or-too-many-heights
         too-few-heights)

    (if (<= pixels-to-move initial-vscroll)
        (progn
          (setq heights nil
                excess (- initial-vscroll pixels-to-move)))

      (cl-decf pixels-to-move initial-vscroll)

      (setq enough-or-too-many-heights (cl-reduce '+ heights)
            too-few-heights (cl-reduce '+ (butlast heights) :initial-value 0))

      (cond ( (= enough-or-too-many-heights pixels-to-move)
              (st-message "Exact %s" heights)
              )
            ( (> pixels-to-move enough-or-too-many-heights)
              (st-message "Near edge %s > %s"
                          pixels-to-move
                          enough-or-too-many-heights)
              (setq excess 0))

            ( (<= (- enough-or-too-many-heights snap)
                  pixels-to-move)
              (st-message "Snap out")
              (setq excess 0))

            ( (and (cl-plusp too-few-heights)
                   (>= (+ too-few-heights snap)
                       pixels-to-move))
              (st-message "Snap in %s" heights)
              (setq excess 0)
              (setq heights (butlast heights))
              )

            ( t
              (st-message "Default")
              (setq excess (- enough-or-too-many-heights
                              pixels-to-move))
              )))

    (st-move (- (length heights)) excess)

    ))

(cl-defun scroll-tick (&optional (arg 1) pixelwise snap)
  (interactive)
  (cond ( (zerop arg)
          (cl-return-from scroll-tick))
        ( (< arg 0)
          (cl-return-from scroll-tick
            (scroll--backtick (- arg) pixelwise snap))))
  (when st-ov (delete-overlay st-ov))

  (let* (( default-height (default-line-height))
         ( pixels-to-move (if pixelwise
                              arg
                            (* arg default-height)))
         ( snap (or snap (/ default-height 2)))
         ( line-info (st-get-lines pixels-to-move))
         ( heights (cadr line-info))
         ( initial-vscroll (car line-info))
         excess
         enough-or-too-many-heights
         too-few-heights)

    (cl-incf pixels-to-move initial-vscroll)

    (setq enough-or-too-many-heights (cl-reduce '+ heights)
          too-few-heights (cl-reduce '+ (butlast heights) :initial-value 0)
          excess (if (= enough-or-too-many-heights pixels-to-move)
                     0
                   (- pixels-to-move too-few-heights)))
    (cond ( (= enough-or-too-many-heights pixels-to-move)
            (st-message "Exact %s" heights)
            )
          ( (> pixels-to-move enough-or-too-many-heights)
            (st-message "Near edge")
            (setq excess 0))

          ( (<= (- enough-or-too-many-heights snap)
                pixels-to-move)
            (st-message "Snap out")
            (setq excess 0))

          ( (and (cl-plusp too-few-heights)
                 (>= (+ too-few-heights snap)
                     pixels-to-move))
            (st-message "Snap in %s" heights)
            (setq excess 0)
            (setq heights (butlast heights))
            )
          ( t
            (st-message "Default")
            (setq heights (butlast heights))
            ))

    (st-move (length heights) excess)

    ))

;; (global-set-key (kbd "<next>") (lambda () (interactive) (scroll-tick 10)))
;; (global-set-key (kbd "<prior>") (lambda () (interactive) (scroll-tick -10)))

;; TESTS

;; (require 'noflet)

;; (ert-deftest scroll-tick ()
;;   (noflet (( st-move (&rest args) args))
;;     (noflet (( st-get-lines (arg)
;;                '(0 (30))))
;;       ;; Simple V-scroll
;;       (should (equal (scroll-tick 5 t 0)
;;                 '(0 5)))
;;       ;; Simple exact
;;       (should (equal (scroll-tick 30 t 0)
;;                 '(1 0)))

;;       )

;;     (noflet (( st-get-lines (arg)
;;                '(0 (5 30))))
;;       ;; Complete line + vscroll
;;       (should (equal (scroll-tick 15 t 0)
;;                 '(1 10)))
;;       ;; Complete 2 lines
;;       (should (equal (scroll-tick 35 t 0)
;;                 '(2 0)))
;;       )

;;     (noflet (( st-get-lines (arg)
;;                '(5 (10 20))))
;;       ;;
;;       (should (equal (scroll-tick 20 t 0)
;;                 '(1 15)))
;;       ;; Complete 2 lines
;;       (should (equal (scroll-tick 25 t 0)
;;                 '(2 0)))
;;       ))
;;   )

;; (ert-deftest scroll-backtick ()
;;   (noflet (( st-move (&rest args) args))
;;     (noflet (( st-get-lines (arg)
;;                '(0 (30))))
;;       ;; Simple V-scroll
;;       (should (equal (scroll-tick -5 t 0)
;;                 '(-1 25)))
;;       ;; Simple exact
;;       (should (equal (scroll-tick -30 t 0)
;;                 '(-1 0))))

;;     (noflet (( st-get-lines (arg)
;;                '(0 (5 30))))
;;       ;; Complete line + vscroll
;;       (should (equal (scroll-tick -15 t 0)
;;                 '(-2 20)))
;;       ;; Complete 2 lines
;;       (should (equal (scroll-tick -35 t 0)
;;                 '(-2 0)))
;;       )

;;     (noflet (( st-get-lines (arg)
;;                '(5 (10))))

;;       ;; Scroll across existing vscroll + a bit
;;       (should (equal (scroll-tick -10 t 0)
;;                 '(-1 5)))
;;       )

;;     (noflet (( st-get-lines (arg)
;;                '(5 (10 20))))
;;       ;; Scroll up a bit
;;       (should (equal (scroll-tick -1 t 0)
;;                 '(0 4)))
;;       ;; Remove vscroll
;;       (should (equal (scroll-tick -5 t 0)
;;                 '(0 0)))

;;       ;;
;;       (should (equal (scroll-tick -20 t 0)
;;                 '(-2 15)))

;;       )

;;     )
;;   )