bug#27932: 26.0.50; Feature request: prevent scroll commands from changing the buffer location of point

[Tak Kunihiro]

> The proposed feature is that any _scrolling_command_ (e.g. C-v, M-v,
> mouse-wheel, ...) should perform its scrolling without altering the
> location of point (wrt its buffer).

I propose targeting mouse-wheel and scroll-bar-toolkit-scroll only, and
having a pseudo point.

This is in a middle, but I think building blocks are there.


;;; touchpad.el --- Scroll two dimensionally by touchpad

;; Copyright (C) 2017 Tak Kunihiro

;; Author: Tak Kunihiro <tkk@misasa.okayama-u.ac.jp>
;; Package-Requires: ((emacs "26"))
;; Keywords: mouse
;; Version: 1.0

;; 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 <http://www.gnu.org/licenses/>.

;; Usage:
;;
;; To interactively toggle the mode:
;;
;;   M-x touchpad-mode RET
;;
;; To make the mode permanent, put these in your init file:
;;
;;   (require 'touchpad)
;;   (touchpad-mode 1)

;;; Commentary:

;; Touchpad mode is a global minor mode which makes swiping touchpad
;; scroll smoothly.  This package disables `auto-hscroll-mode' during
;; scroll by the touchpad because of following two aspects.

;; (1) It should be off during vertical scroll.  Let’s consider a
;;     buffer with empty and long alternative lines and when point is
;;     at the end of a long line at the top of window.  After
;;     `scroll-up 1', point jumps to the beginning of the next empty
;;     line and you see scope shifts suddenly leftward.  This behavior
;;     is sometimes unexpected one.

;; (2) It should be off during horizontal scroll.  During horizontal
;;     scroll, you may scroll a little in vertical direction without
;;     intention.  The horizontal scroll should be tolerance against
;;     such perturbation.

;; After scroll by the touchpad, you want to set `auto-hscroll-mode'
;; back again otherwise too inconvenient for edition by the keyboard.
;;
;; Approach of this package is to turn on another minor-mode
;; `touchpad--view-mode' with `auto-hscroll-mode' nil, at the beginning
;; of `mwheel-scroll'.  The minor mode is turned off upon key input
;; from the keyboard that moves point.
;;
;; This package also converts point and region to
;; `mouse-secondary-start' and `mouse-secondary-overlay'.  When
;; `touchpad-restore-point-flag' is non-nil, point will be moved to
;; `mouse-secondary-start' when `touchpad--view-mode' is turned off.

;;; Code:

(require 'mwheel)

(defvar touchpad-restore-point-flag t
  "Restore point when `touchpad--view-mode' is turned off.")

(defvar touchpad--cursor-type cursor-type
  "Cursor used by user.
This variable is used internally to restore original `cursor-type'.")

(defvar touchpad--auto-hscroll-mode nil
  "Value of auto-hscroll-mode specified by user.
This variable is used internally to restore original `auto-hscroll-mode'.")

;;;###autoload
(define-minor-mode touchpad-mode
  "A minor mode to scroll text two dimensionally.
With a prefix argument ARG, enable Touchpad Mode if ARG is
positive, and disable it otherwise.  If called from Lisp, enable
Touchpad Mode if ARG is omitted or nil."
  :init-value nil
  :group 'scrolling
  :global t
  :version "26.1"
  :keymap (let ((map (make-sparse-keymap)))
            ;; Extend primary by shift click
            (define-key map [S-down-mouse-1] 'ignore)
            (define-key map [S-mouse-1] 'mouse-save-then-kill)
            (if (not (eq system-type 'ms-dos))
                (global-set-key [C-S-down-mouse-1] 'mouse-appearance-menu))
            ;; Change size of font ize by wheel up and down
            (define-key map (kbd "<C-wheel-up>") 'touchpad-text-scale-increase)
            (define-key map (kbd "<C-wheel-down>") 
'touchpad-text-scale-decrease)
            map)

  (if touchpad-mode
      (progn
        (advice-add 'mwheel-scroll :before 'touchpad-enable--view-mode)
        ;; http://lists.gnu.org/archive/html/bug-gnu-emacs/2017-04/msg00700.html
        ;; (add-hook 'mwheel-pre-scroll-hook 'touchpad-enable--view-mode)
        (advice-add 'ns-handle-scroll-bar-event :before 
'touchpad-enable--view-mode)
        (advice-add 'scroll-bar-toolkit-scroll :before 
'touchpad-enable--view-mode)
        (setq mwheel-tilt-scroll-p t))
    (advice-remove 'mwheel-scroll #'touchpad-enable--view-mode)
    ;; (remove-hook 'mwheel-pre-scroll-hook 'touchpad-enable--view-mode)
    (advice-remove 'ns-handle-scroll-bar-event #'touchpad-enable--view-mode)
    (advice-remove 'scroll-bar-toolkit-scroll #'touchpad-enable--view-mode)
    (dolist (var '(mwheel-tilt-scroll-p))
      (custom-reevaluate-setting var))))


;;; To enable Enable minor mode by hook instead of advice, patch shown
;;; by following URL should be accepted.
;;; http://lists.gnu.org/archive/html/bug-gnu-emacs/2017-04/msg00700.html

;; (defun touchpad-enable--view-mode ()
;;   "Enable minor mode `touchpad--view-mode' to disable `auto-hscroll-mode'.
;; This is supposed to be called before actual scrolling."
;;   (let ((buffer (window-buffer (mwheel-event-window last-input-event))))
;;     (with-current-buffer buffer
;;       (touchpad--view-mode 1)))) ; Turn on minor-mode.


(defun touchpad-enable--view-mode (func &rest args)
  "Enable minor mode `touchpad--view-mode' to disable `auto-hscroll-mode'.
This is supposed to be adviced before `mwheel-scroll'."
  (let ((buffer (window-buffer (mwheel-event-window last-input-event)))
        (point (point)))
    (when auto-hscroll-mode
      (setq touchpad--auto-hscroll-mode auto-hscroll-mode)) ; 26.1
    (unless touchpad--view-mode ; Switch from off to on.
      (when (fboundp 'mouse-set-secondary-from-primary)
        (mouse-set-secondary-from-primary))
      (when touchpad-restore-point-flag
        (touchpad-set-point point))
      (with-current-buffer buffer
        (touchpad--view-mode 1)))))


(copy-face 'cursor 'touchpad-point-face) ; 'cursor, 'region, 
'secondary-selection, 'mode-line
;; (set-face-foreground 'touchpad-point-face "white")


(defun touchpad-point-overlay ()
  "Return an overlay which records the current point in the visiting buffer."
  (let ((overlays (overlays-in (point-min) (point-max)))
        ol)
    (while overlays
      (let ((overlay (car overlays)))
        (if (eq (overlay-get overlay 'face) 'touchpad-point-face)
            (progn (setq ol overlay)
                   (setq overlays nil))
          (setq overlays (cdr overlays)))))
    (unless ol
      ;; create a new overlay.
      ;; (info "(elisp) Overlay Properties")
      (setq ol (make-overlay (point-min) (point-min) nil t t))
      (delete-overlay ol)
      ;; (overlay-put ol 'priority 100)
      (overlay-put ol 'face 'touchpad-point-face))
    ol))


(defun touchpad-set-point (pos)
  "Move `touchpad-point-overlay' to the current point."
  (if (eolp)
      (let ((string (propertize "|" 'face 'touchpad-point-face))) ; "|", " "
        (move-overlay (touchpad-point-overlay) pos pos) ; empty overlay cursor 
char
        (overlay-put (touchpad-point-overlay) 'after-string string))
    (when (overlay-get (touchpad-point-overlay) 'after-string)
      (overlay-put (touchpad-point-overlay) 'after-string nil)) ; remove cursor 
char
    (move-overlay (touchpad-point-overlay) pos (1+ pos))))


(defun touchpad-remove-point ()
  "Remove `touchpad-point-overlay' in the visiting buffer."
  (when (overlay-get (touchpad-point-overlay) 'after-string)
    (overlay-put (touchpad-point-overlay) 'after-string nil)) ; remove cursor 
char
  (delete-overlay (touchpad-point-overlay))) ; remove overlay


(defun touchpad-point ()
  "Return point from `touchpad-point-overlay'."
  (overlay-start (touchpad-point-overlay)))


;;; Following definition is necessary until the patch is accepted by
;;; bug-gnu-emacs.  The code should be located on `mouse.el'.
;;; http://lists.gnu.org/archive/html/bug-gnu-emacs/2017-06/msg00938.html
(unless (fboundp 'mouse-set-secondary-from-primary)
  (defun mouse-set-secondary-from-primary ()
    "Set the secondary selection to text in the region.
When region does not exists, set mouse-secondary-start to the point.
When point is in the secondary selection, do nothing."
    (interactive)
    (cond
     ((region-active-p) ; Create mouse-secondary-overlay from region.
      (delete-overlay mouse-secondary-overlay)
      (move-overlay mouse-secondary-overlay (region-beginning) (region-end)))
     ((member 'secondary-selection ; Do nothing.
              (mapcar (lambda (xxx) (overlay-get xxx 'face))
                      (overlays-at (point)))))
     (t (delete-overlay mouse-secondary-overlay) ; Create mouse-secondary-start 
from point.
        (push-mark (point))
        (setq mouse-secondary-start (make-marker))
        (move-marker mouse-secondary-start (point))))))


(defun touchpad-disable--view-mode ()
  "Disable minor mode `touchpad--view-mode' to enable `auto-hscroll-mode' back.
Then invoke command that is bound to the original key."
  (interactive)
  (touchpad--view-mode 0) ; Turn off minor-mode.
  (when touchpad-restore-point-flag
    (touchpad-remove-point))
  (call-interactively (key-binding (this-command-keys))))


(defun touchpad-disable--view-mode-1 ()
  "Restore point then call `touchpad-disable--view-mode'."
  (interactive)
  (when touchpad-restore-point-flag
    (goto-char (touchpad-point))
    (touchpad-remove-point))
  (touchpad-disable--view-mode))


(define-minor-mode touchpad--view-mode
  "A minor-mode with `auto-hscroll-mode' off.
This minor mode is used internally."
  :init-value nil
  :lighter " view"
  :keymap (let ((map (make-sparse-keymap)))
            ;; Extend secondary instead of primary by shift click.
            (define-key map [remap mouse-save-then-kill] 
'mouse-secondary-save-then-kill)

            ;; Turn off touchpad--view-mode and do what is supposed to do.
            ;; * do not restore point
            (define-key map [remap mouse-set-region] 
'touchpad-disable--view-mode)
            ;; (define-key map [remap mouse-drag-region] 
'touchpad-disable--view-mode) ; Lisp nesting exceeds ‘max-lisp-eval-depth’
            (define-key map [remap keyboard-quit] 'touchpad-disable--view-mode)
            (define-key map [remap mouse-set-point] 
'touchpad-disable--view-mode)
            (define-key map [remap mark-whole-buffer] 
'touchpad-disable--view-mode)
            (define-key map [remap mark-page] 'touchpad-disable--view-mode)
            (define-key map [remap mark-paragraph] 'touchpad-disable--view-mode)
            (define-key map [remap mark-word] 'touchpad-disable--view-mode)
            (define-key map [remap goto-char] 'touchpad-disable--view-mode)
            (define-key map [remap goto-line] 'touchpad-disable--view-mode)
            (define-key map [remap move-to-column] 'touchpad-disable--view-mode)
            (define-key map [remap isearch-forward] 
'touchpad-disable--view-mode)
            (define-key map [remap isearch-backward] 
'touchpad-disable--view-mode)
            ;; (define-key map [remap scroll-up-command] 
'touchpad-disable--view-mode)
            ;; (define-key map [remap scroll-down-command] 
'touchpad-disable--view-mode)
            ;; (define-key map [remap beginning-of-buffer] 
'touchpad-disable--view-mode)
            ;; (define-key map [remap end-of-buffer] 
'touchpad-disable--view-mode)
            ;; * restore point
            (define-key map [remap recenter-top-bottom] 
'touchpad-disable--view-mode-1) ; restore point
            (define-key map [remap right-char] 'touchpad-disable--view-mode-1) 
; restore point
            (define-key map [remap forward-char] 
'touchpad-disable--view-mode-1) ; restore point
            (define-key map [remap forward-word] 
'touchpad-disable--view-mode-1) ; restore point
            (define-key map [remap forward-sentence] 
'touchpad-disable--view-mode-1) ; restore point
            (define-key map [remap forward-paragraph] 
'touchpad-disable--view-mode-1) ; restore point
            (define-key map [remap forward-page] 
'touchpad-disable--view-mode-1) ; restore point
            (define-key map [remap left-char] 'touchpad-disable--view-mode-1) ; 
restore point
            (define-key map [remap backward-char] 
'touchpad-disable--view-mode-1) ; restore point
            (define-key map [remap backward-word] 
'touchpad-disable--view-mode-1) ; restore point
            (define-key map [remap backward-sentence] 
'touchpad-disable--view-mode-1) ; restore point
            (define-key map [remap backward-paragraph] 
'touchpad-disable--view-mode-1) ; restore point
            (define-key map [remap backward-page] 
'touchpad-disable--view-mode-1) ; restore point
            (define-key map [remap move-beginning-of-line] 
'touchpad-disable--view-mode-1) ; restore point
            (define-key map [remap beginning-of-visual-line] 
'touchpad-disable--view-mode-1) ; restore point
            (define-key map [remap move-end-of-line] 
'touchpad-disable--view-mode-1) ; restore point
            (define-key map [remap end-of-visual-line] 
'touchpad-disable--view-mode-1) ; restore point
            (define-key map [remap next-line] 'touchpad-disable--view-mode-1) ; 
restore point
            (define-key map [remap next-error] 'touchpad-disable--view-mode-1) 
; restore point
            (define-key map [remap previous-line] 
'touchpad-disable--view-mode-1) ; restore point
            (define-key map [remap previous-error] 
'touchpad-disable--view-mode-1) ; restore point
            (define-key map [remap beginning-of-defun] 
'touchpad-disable--view-mode-1) ; restore point
            (define-key map [remap end-of-defun] 
'touchpad-disable--view-mode-1) ; restore point
            ;; * restore point and revise buffer
            (define-key map [remap self-insert-command] 
'touchpad-disable--view-mode-1) ; restore point
            (define-key map [remap delete-char] 'touchpad-disable--view-mode-1) 
; restore point
            (define-key map [remap kill-word] 'touchpad-disable--view-mode-1) ; 
restore point
            (define-key map [remap kill-line] 'touchpad-disable--view-mode-1) ; 
restore point
            (define-key map [remap quoted-insert] 
'touchpad-disable--view-mode-1) ; restore point
            (define-key map [remap transpose-chars] 
'touchpad-disable--view-mode-1) ; restore point
            (define-key map [remap transpose-words] 
'touchpad-disable--view-mode-1) ; restore point
            (define-key map [remap yank] 'touchpad-disable--view-mode-1) ; 
restore point
            (define-key map [remap toggle-input-method] 
'touchpad-disable--view-mode-1) ; restore point
            (define-key map [remap delete-backward-char] 
'touchpad-disable--view-mode-1) ; restore point
            (define-key map [remap just-one-space] 
'touchpad-disable--view-mode-1) ; restore point
            (define-key map [remap dabbrev-expand] 
'touchpad-disable--view-mode-1) ; restore point
            (define-key map [remap mark-sexp] 'touchpad-disable--view-mode-1) ; 
restore point
            (define-key map [remap delete-indentation] 
'touchpad-disable--view-mode-1) ; restore point
            (define-key map [remap helm-command-prefix] 
'touchpad-disable--view-mode-1) ; restore point
            (define-key map [remap paredit-backward-slurp-sexp] 
'touchpad-disable--view-mode-1) ; restore point
            (define-key map [remap paredit-splice-sexp-killing-backward] 
'touchpad-disable--view-mode-1) ; restore point
            (define-key map [remap mark-sexp] 'touchpad-disable--view-mode-1) ; 
restore point
            ;; * local setup
            (define-key map [remap mew-summary-previous-line] 
'touchpad-disable--view-mode-1) ; restore point
            (define-key map [remap mew-summary-next-line] 
'touchpad-disable--view-mode-1) ; restore point
            (define-key map [remap skk-insert] 'touchpad-disable--view-mode-1) 
; restore point
            map)
  :group 'scrolling

  (if touchpad--view-mode
      (progn
        (setq-local auto-hscroll-mode nil)
        (setq-local cursor-type 'hollow))
    (setq-local auto-hscroll-mode touchpad--auto-hscroll-mode)
    (setq-local cursor-type touchpad--cursor-type)))

(defun touchpad-text-scale-increase (event)
  "Increase the height of the default face in the current buffer by 1 step."
  (interactive "e")
  (save-excursion
    (mouse-set-point event)
    (text-scale-increase 1)))

(defun touchpad-text-scale-decrease (event)
  "Decrease the height of the default face in the current buffer by 1 step."
  (interactive "e")
  (save-excursion
    (mouse-set-point event)
    (text-scale-decrease 1)))

;;;; ChangeLog:

;; 2017-08-07  Tak Kunihiro <tkk@misasa.okayama-u.ac.jp>
;;
;;      touchpad-mode: version 1.0
;;
;;      * touchpad.el: New package.

(provide 'touchpad)
;;; touchpad.el ends here