mirrors/emacs
1
Fork 0
mirror of git://git.sv.gnu.org/emacs.git synced 2025-12-06 14:30:50 -08:00
Code Issues Projects Releases Wiki Activity

Improve touch screen scrolling support

Browse source 
* lisp/touch-screen.el (touch-screen-preview-select): Avoid
unnecessary redisplays.
(touch-screen-drag): Scroll at window margins using window
scrolling functions instead of relying on redisplay to recenter
the window around point.
This commit is contained in:
Po Lu 2023-07-21 14:22:54 +08:00
parent e1761019a9
commit 5d89602e29
1 changed files with 291 additions and 200 deletions
Download patch file Download diff file Expand all files Collapse all files

491
lisp/touch-screen.el
View file

@ -405,114 +405,110 @@ right most column of the window using `posn-at-x-y'."
(long-line-optimizations-p) (long-line-optimizations-p)
(let ((window-line-height (window-line-height)) (let ((window-line-height (window-line-height))
(maximum-height (* 2 (frame-char-height)))) (maximum-height (* 2 (frame-char-height))))
(or (and window-line-height (unless window-line-height
(> (car window-line-height) ;; `window-line-height' isn't available.
maximum-height)) ;; Redisplay first and try to ascertain the height
;; `window-line-height' isn't available. ;; of the line again.
;; Redisplay first and try to ascertain the height (redisplay t)
;; of the line again. (setq window-line-height (window-line-height)))
(prog1 nil (redisplay t)) ;; `window-line-height' might still be unavailable.
;; Likewise if the line height still isn't (and window-line-height
;; available. (> (car window-line-height)
(not (setq window-line-height maximum-height))))
(window-line-height))) (catch 'hscrolled-away
;; Actually check the height now. (let ((beg nil) end string y)
(> (car window-line-height) ;; Detect whether or not the window is hscrolled. If it
maximum-height)))) ;; is, set beg to the location of the first column
(if (catch 'hscrolled-away ;; instead.
(let ((beg nil) end string y) (when (> (window-hscroll) 0)
;; Detect whether or not the window is hscrolled. If it (setq y (+ (or (cdr (posn-x-y (posn-at-point)))
;; is, set beg to the location of the first column (throw 'hscrolled-away t))
;; instead. (window-header-line-height)
(when (> (window-hscroll) 0) (window-tab-line-height)))
(setq y (+ (or (cdr (posn-x-y (posn-at-point))) (let* ((posn (posn-at-x-y 0 y))
(throw 'hscrolled-away t)) (point (posn-point posn)))
(window-header-line-height) (setq beg point)))
(window-tab-line-height))) ;; Check if lines are being truncated; if so, use the
(let* ((posn (posn-at-x-y 0 y)) ;; character at the end of the window as the end of the
(point (posn-point posn))) ;; text to be displayed, as the visual line may extend
(setq beg point))) ;; past the window.
;; Check if lines are being truncated; if so, use the (when (or truncate-lines beg) ; truncate-lines or hscroll.
;; character at the end of the window as the end of the (setq y (or y (+ (or (cdr (posn-x-y (posn-at-point)))
;; text to be displayed, as the visual line may extend (throw 'hscrolled-away t))
;; past the window. (window-header-line-height)
(when (or truncate-lines beg) ; truncate-lines or hscroll. (window-tab-line-height))))
(setq y (or y (+ (or (cdr (posn-x-y (posn-at-point))) (let* ((posn (posn-at-x-y (1- (window-width nil t)) y))
(throw 'hscrolled-away t)) (point (posn-point posn)))
(window-header-line-height) (setq end point)))
(window-tab-line-height)))) ;; Now find the rest of the visual line.
(let* ((posn (posn-at-x-y (1- (window-width nil t)) y)) (save-excursion
(point (posn-point posn))) (unless beg
(setq end point))) (beginning-of-visual-line)
;; Now find the rest of the visual line. (setq beg (point)))
(save-excursion (unless end
(unless beg (end-of-visual-line)
(beginning-of-visual-line) (setq end (point))))
(setq beg (point))) ;; Obtain a substring containing the beginning of the
(unless end ;; visual line and the end.
(end-of-visual-line) (setq string (buffer-substring beg end))
(setq end (point)))) ;; Hack `invisible' properties within the new string.
;; Obtain a substring containing the beginning of the ;; Look for each change of the property that is a variable
;; visual line and the end. ;; name and replace it with its actual value according to
(setq string (buffer-substring beg end)) ;; `buffer-invisibility-spec'.
;; Hack `invisible' properties within the new string. (when (listp buffer-invisibility-spec)
;; Look for each change of the property that is a variable (let ((index 0)
;; name and replace it with its actual value according to (property (get-text-property 0
;; `buffer-invisibility-spec'. 'invisible
(when (listp buffer-invisibility-spec) string))
(let ((index 0) index1 invisible)
(property (get-text-property 0 (while index
'invisible ;; Find the end of this text property.
string)) (setq index1 (next-single-property-change index
index1 invisible) 'invisible
(while index string))
;; Find the end of this text property. ;; Replace the property with whether or not it is
(setq index1 (next-single-property-change index ;; non-nil.
'invisible (when property
string)) (setq invisible nil)
;; Replace the property with whether or not it is (catch 'invisible
;; non-nil. (dolist (spec buffer-invisibility-spec)
(when property ;; Process one element of the buffer
(setq invisible nil) ;; invisibility specification.
(catch 'invisible (if (consp spec)
(dolist (spec buffer-invisibility-spec) (when (eq (cdr spec) 't)
;; Process one element of the buffer ;; (ATOM . t) makes N invisible if N is
;; invisibility specification. ;; equal to ATOM or a list containing
(if (consp spec) ;; ATOM.
(when (eq (cdr spec) 't) (when (or (eq (car spec) property)
;; (ATOM . t) makes N invisible if N is (and (listp spec)
;; equal to ATOM or a list containing (memq (car spec) invisible)))
;; ATOM. (throw 'invisible (setq invisible t))))
(when (or (eq (car spec) property) ;; Otherwise, N is invisible if SPEC is
(and (listp spec) ;; equal to N.
(memq (car spec) invisible))) (when (eq spec property)
(throw 'invisible (setq invisible t)))) (throw 'invisible (setq invisible t))))))
;; Otherwise, N is invisible if SPEC is (put-text-property index (or index1
;; equal to N. (- end beg))
(when (eq spec property) 'invisible invisible string))
(throw 'invisible (setq invisible t)))))) ;; Set index to that of the next text property and
(put-text-property index (or index1 ;; continue.
(- end beg)) (setq index index1
'invisible invisible string)) property (and index1
;; Set index to that of the next text property and (get-text-property index1
;; continue. 'invisible
(setq index index1 string))))))
property (and index1 (let ((resize-mini-windows t) difference width
(get-text-property index1 (message-log-max nil))
'invisible ;; Find the offset of point from beg and display a cursor
string)))))) ;; below.
(let ((resize-mini-windows t) difference width (setq difference (- (point) beg)
(message-log-max nil)) width (string-pixel-width
;; Find the offset of point from beg and display a cursor (substring string 0 difference)))
;; below. (message "%s\n%s^" string
(setq difference (- (point) beg) (propertize " "
width (string-pixel-width 'display (list 'space
(substring string 0 difference))) :width (list width)))))
(message "%s\n%s^" string nil))))
(propertize " "
'display (list 'space
:width (list width)))))
nil)))))
(defun touch-screen-drag (event) (defun touch-screen-drag (event)
"Handle a drag EVENT by setting the region to its new point. "Handle a drag EVENT by setting the region to its new point.
@ -523,113 +519,208 @@ area."
(interactive "e") (interactive "e")
(let* ((posn (cadr event)) ; Position of the tool. (let* ((posn (cadr event)) ; Position of the tool.
(point (posn-point posn)) ; Point of the event. (point (posn-point posn)) ; Point of the event.
; Window where the tap originated. ;; Window where the tap originated.
(window (nth 1 touch-screen-current-tool)) (window (nth 1 touch-screen-current-tool))
;; The currently selected window. Used to redisplay within
;; the correct window while scrolling.
(old-window (selected-window))
initial-point) initial-point)
;; Keep dragging. ;; Keep dragging.
(with-selected-window window (with-selected-window window
;; Figure out what character to go to. If this posn is ;; Figure out what character to go to. If this posn is in the
;; in the window, go to (posn-point posn). If not, ;; window, go to (posn-point posn). If not, then go to the line
;; then go to the line before either window start or ;; before either window start or window end.
;; window end.
(setq initial-point (point)) (setq initial-point (point))
(if (and (eq (posn-window posn) window) (when (or (not point)
point (not (eq point initial-point))) (not (eq point initial-point)))
(let* ((bounds touch-screen-word-select-bounds) (if (and (eq (posn-window posn) window)
(initial touch-screen-word-select-initial-word) point
(maybe-select-word (or (not touch-screen-word-select) ;; point must be visible in the window. If it isn't,
(or (not bounds) ;; the window must be scrolled.
(> point (cdr bounds)) (pos-visible-in-window-p point))
(< point (car bounds)))))) (let* ((bounds touch-screen-word-select-bounds)
(if (and touch-screen-word-select (initial touch-screen-word-select-initial-word)
;; point is now outside the last word selected. (maybe-select-word (or (not touch-screen-word-select)
maybe-select-word (or (not bounds)
(not (posn-object posn)) (> point (cdr bounds))
(when-let* ((char (char-after point)) (< point (car bounds))))))
(class (char-syntax char))) (if (and touch-screen-word-select
;; Don't select words if point isn't inside a ;; point is now outside the last word selected.
;; word constituent or similar. maybe-select-word
(or (eq class ?w) (eq class ?_)))) (not (posn-object posn))
;; Determine the confines of the word containing (when-let* ((char (char-after point))
;; POINT. (class (char-syntax char)))
(let (word-start word-end) ;; Don't select words if point isn't inside a
(save-excursion ;; word constituent or similar.
(goto-char point) (or (eq class ?w) (eq class ?_))))
(forward-word-strictly) ;; Determine the confines of the word containing
;; Set word-end to ZV if there is no word after ;; POINT.
;; this one. (let (word-start word-end)
(setq word-end (point)) (save-excursion
;; Now try to move backwards. Set word-start to (goto-char point)
;; BEGV if this word is there. (forward-word-strictly)
(backward-word-strictly) ;; Set word-end to ZV if there is no word after
(setq word-start (point))) ;; this one.
(let ((mark (mark))) (setq word-end (point))
;; Extend the region to cover either word-end or ;; Now try to move backwards. Set word-start to
;; word-start; whether to goto word-end or ;; BEGV if this word is there.
;; word-start is subject to the position of the (backward-word-strictly)
;; mark relative to point. (setq word-start (point)))
(if (< word-start mark) (let ((mark (mark)))
;; The start of the word is behind mark. ;; Extend the region to cover either word-end or
;; Extend the region towards the start. ;; word-start; whether to goto word-end or
(goto-char word-start) ;; word-start is subject to the position of the
;; Else, go to the end of the word. ;; mark relative to point.
(goto-char word-end)) (if (< word-start mark)
;; The start of the word is behind mark.
;; Extend the region towards the start.
(goto-char word-start)
;; Else, go to the end of the word.
(goto-char word-end))
;; If point is less than mark, which is is less
;; than the end of the word that was originally
;; selected, try to keep it selected by moving
;; mark there.
(when (and initial (<= (point) mark)
(< mark (cdr initial)))
(set-mark (cdr initial)))
;; Do the opposite when the converse is true.
(when (and initial (>= (point) mark)
(> mark (car initial)))
(set-mark (car initial))))
(if bounds
(progn (setcar bounds word-start)
(setcdr bounds word-end))
(setq touch-screen-word-select-bounds
(cons word-start word-end))))
(when maybe-select-word
(goto-char (posn-point posn))
(when initial
;; If point is less than mark, which is is less ;; If point is less than mark, which is is less
;; than the end of the word that was originally ;; than the end of the word that was originally
;; selected, try to keep it selected by moving ;; selected, try to keep it selected by moving
;; mark there. ;; mark there.
(when (and initial (<= (point) mark) (when (and (<= (point) (mark))
(< mark (cdr initial))) (< (mark) (cdr initial)))
(set-mark (cdr initial))) (set-mark (cdr initial)))
;; Do the opposite when the converse is true. ;; Do the opposite when the converse is true.
(when (and initial (>= (point) mark) (when (and (>= (point) (mark))
(> mark (car initial))) (> (mark) (car initial)))
(set-mark (car initial)))) (set-mark (car initial))))
(if bounds (setq touch-screen-word-select-bounds nil)))
(progn (setcar bounds word-start) ;; Finally, display a preview of the line around point
(setcdr bounds word-end)) ;; if requested by the user.
(setq touch-screen-word-select-bounds (when (and touch-screen-preview-select
(cons word-start word-end)))) (not (eq (point) initial-point)))
(when maybe-select-word (touch-screen-preview-select)))
(goto-char (posn-point posn)) ;; POSN is outside the window. Scroll accordingly.
(when initial (let* ((relative-xy
;; If point is less than mark, which is is less than (touch-screen-relative-xy posn window))
;; the end of the word that was originally selected, (xy (posn-x-y posn))
;; try to keep it selected by moving mark there. ;; The height of the window's text area.
(when (and (<= (point) (mark)) (body-height (window-body-height nil t))
(< (mark) (cdr initial))) ;; This is used to find the character closest to
(set-mark (cdr initial))) ;; POSN's column at the bottom of the window.
;; Do the opposite when the converse is true. (height (- body-height
(when (and (>= (point) (mark)) ;; Use the last row of the window, not its
(> (mark) (car initial))) ;; last pixel.
(set-mark (car initial)))) (frame-char-height)))
(setq touch-screen-word-select-bounds nil))) (midpoint (/ body-height 2))
;; Finally, display a preview of the line around point if (scroll-conservatively 101))
;; requested by the user.
(when (and touch-screen-preview-select
(not (eq (point) initial-point)))
(touch-screen-preview-select)))
;; POSN is outside the window. Scroll accordingly.
(let ((relative-xy
(touch-screen-relative-xy posn window)))
(let ((scroll-conservatively 101))
(cond (cond
((< (cdr relative-xy) 0) ((< (cdr relative-xy) midpoint)
;; POSN is before half the window, yet POINT does not
;; exist or is not completely visible within. Scroll
;; downwards.
(ignore-errors (ignore-errors
(goto-char (1- (window-start))) ;; Scroll down by a single line.
(setq touch-screen-word-select-bounds nil)) (scroll-down 1)
(redisplay)) ;; After scrolling, look up the new posn at EVENT's
((> (cdr relative-xy) ;; column and go there.
(let ((edges (window-inside-pixel-edges))) (setq posn (posn-at-x-y (car xy) 0)
(- (nth 3 edges) (cadr edges)))) point (posn-point posn))
(if point
(goto-char point)
;; If there's no buffer position at that column, go
;; to the window start.
(goto-char (window-start)))
;; Display a preview of the line now around point if
;; requested by the user.
(when touch-screen-preview-select
(touch-screen-preview-select))
;; Select old-window, so that redisplay doesn't
;; display WINDOW as selected if it isn't already.
(with-selected-window old-window
;; Now repeat this every `mouse-scroll-delay' until
;; input becomes available, but scroll down a few
;; more lines.
(while (sit-for mouse-scroll-delay)
;; Select WINDOW again.
(with-selected-window window
;; Keep scrolling down until input becomes
;; available.
(scroll-down 4)
;; After scrolling, look up the new posn at
;; EVENT's column and go there.
(setq posn (posn-at-x-y (car xy) 0)
point (posn-point posn))
(if point
(goto-char point)
;; If there's no buffer position at that
;; column, go to the window start.
(goto-char (window-start)))
;; Display a preview of the line now around
;; point if requested by the user.
(when touch-screen-preview-select
(touch-screen-preview-select))))))
(setq touch-screen-word-select-bounds nil))
((>= (cdr relative-xy) midpoint)
;; Default to scrolling upwards even if POSN is still
;; within the confines of the window. If POINT is
;; partially visible, and the branch above hasn't been
;; taken it must be somewhere at the bottom of the
;; window, so scroll downwards.
(ignore-errors (ignore-errors
(goto-char (1+ (window-end nil t))) ;; Scroll up by a single line.
(setq touch-screen-word-select-bounds nil)) (scroll-up 1)
(redisplay))) ;; After scrolling, look up the new posn at EVENT's
;; Finally, display a preview of the line now around point ;; column and go there.
;; if requested by the user. (setq posn (posn-at-x-y (car xy) height)
(when touch-screen-preview-select point (posn-point posn))
(touch-screen-preview-select)))))))) (if point
(goto-char point)
;; If there's no buffer position at that column, go
;; to the window start.
(goto-char (window-end nil t)))
;; Display a preview of the line now around point if
;; requested by the user.
(when touch-screen-preview-select
(touch-screen-preview-select))
;; Select old-window, so that redisplay doesn't
;; display WINDOW as selected if it isn't already.
(with-selected-window old-window
;; Now repeat this every `mouse-scroll-delay' until
;; input becomes available, but scroll down a few
;; more lines.
(while (sit-for mouse-scroll-delay)
;; Select WINDOW again.
(with-selected-window window
;; Keep scrolling down until input becomes
;; available.
(scroll-up 4)
;; After scrolling, look up the new posn at
;; EVENT's column and go there.
(setq posn (posn-at-x-y (car xy) height)
point (posn-point posn))
(if point
(goto-char point)
;; If there's no buffer position at that
;; column, go to the window start.
(goto-char (window-end nil t)))
;; Display a preview of the line now around
;; point if requested by the user.
(when touch-screen-preview-select
(touch-screen-preview-select))))))))))))))
(defun touch-screen-restart-drag (event) (defun touch-screen-restart-drag (event)
"Restart dragging to select text. "Restart dragging to select text.