From 5d89602e290770d699d2dba860e4b5119fe0a30c Mon Sep 17 00:00:00 2001 From: Po Lu Date: Fri, 21 Jul 2023 14:22:54 +0800 Subject: [PATCH] Improve touch screen scrolling support * 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. --- lisp/touch-screen.el | 491 +++++++++++++++++++++++++------------------ 1 file changed, 291 insertions(+), 200 deletions(-) diff --git a/lisp/touch-screen.el b/lisp/touch-screen.el index f9611e269f4..4f930704869 100644 --- a/lisp/touch-screen.el +++ b/lisp/touch-screen.el @@ -405,114 +405,110 @@ right most column of the window using `posn-at-x-y'." (long-line-optimizations-p) (let ((window-line-height (window-line-height)) (maximum-height (* 2 (frame-char-height)))) - (or (and window-line-height - (> (car window-line-height) - maximum-height)) - ;; `window-line-height' isn't available. - ;; Redisplay first and try to ascertain the height - ;; of the line again. - (prog1 nil (redisplay t)) - ;; Likewise if the line height still isn't - ;; available. - (not (setq window-line-height - (window-line-height))) - ;; Actually check the height now. - (> (car window-line-height) - maximum-height)))) - (if (catch 'hscrolled-away - (let ((beg nil) end string y) - ;; Detect whether or not the window is hscrolled. If it - ;; is, set beg to the location of the first column - ;; instead. - (when (> (window-hscroll) 0) - (setq y (+ (or (cdr (posn-x-y (posn-at-point))) - (throw 'hscrolled-away t)) - (window-header-line-height) - (window-tab-line-height))) - (let* ((posn (posn-at-x-y 0 y)) - (point (posn-point posn))) - (setq beg point))) - ;; Check if lines are being truncated; if so, use the - ;; character at the end of the window as the end of the - ;; text to be displayed, as the visual line may extend - ;; past the window. - (when (or truncate-lines beg) ; truncate-lines or hscroll. - (setq y (or y (+ (or (cdr (posn-x-y (posn-at-point))) - (throw 'hscrolled-away t)) - (window-header-line-height) - (window-tab-line-height)))) - (let* ((posn (posn-at-x-y (1- (window-width nil t)) y)) - (point (posn-point posn))) - (setq end point))) - ;; Now find the rest of the visual line. - (save-excursion - (unless beg - (beginning-of-visual-line) - (setq beg (point))) - (unless end - (end-of-visual-line) - (setq end (point)))) - ;; Obtain a substring containing the beginning of the - ;; visual line and the end. - (setq string (buffer-substring beg end)) - ;; Hack `invisible' properties within the new string. - ;; Look for each change of the property that is a variable - ;; name and replace it with its actual value according to - ;; `buffer-invisibility-spec'. - (when (listp buffer-invisibility-spec) - (let ((index 0) - (property (get-text-property 0 - 'invisible - string)) - index1 invisible) - (while index - ;; Find the end of this text property. - (setq index1 (next-single-property-change index - 'invisible - string)) - ;; Replace the property with whether or not it is - ;; non-nil. - (when property - (setq invisible nil) - (catch 'invisible - (dolist (spec buffer-invisibility-spec) - ;; Process one element of the buffer - ;; invisibility specification. - (if (consp spec) - (when (eq (cdr spec) 't) - ;; (ATOM . t) makes N invisible if N is - ;; equal to ATOM or a list containing - ;; ATOM. - (when (or (eq (car spec) property) - (and (listp spec) - (memq (car spec) invisible))) - (throw 'invisible (setq invisible t)))) - ;; Otherwise, N is invisible if SPEC is - ;; equal to N. - (when (eq spec property) - (throw 'invisible (setq invisible t)))))) - (put-text-property index (or index1 - (- end beg)) - 'invisible invisible string)) - ;; Set index to that of the next text property and - ;; continue. - (setq index index1 - property (and index1 - (get-text-property index1 - 'invisible - string)))))) - (let ((resize-mini-windows t) difference width - (message-log-max nil)) - ;; Find the offset of point from beg and display a cursor - ;; below. - (setq difference (- (point) beg) - width (string-pixel-width - (substring string 0 difference))) - (message "%s\n%s^" string - (propertize " " - 'display (list 'space - :width (list width))))) - nil))))) + (unless window-line-height + ;; `window-line-height' isn't available. + ;; Redisplay first and try to ascertain the height + ;; of the line again. + (redisplay t) + (setq window-line-height (window-line-height))) + ;; `window-line-height' might still be unavailable. + (and window-line-height + (> (car window-line-height) + maximum-height)))) + (catch 'hscrolled-away + (let ((beg nil) end string y) + ;; Detect whether or not the window is hscrolled. If it + ;; is, set beg to the location of the first column + ;; instead. + (when (> (window-hscroll) 0) + (setq y (+ (or (cdr (posn-x-y (posn-at-point))) + (throw 'hscrolled-away t)) + (window-header-line-height) + (window-tab-line-height))) + (let* ((posn (posn-at-x-y 0 y)) + (point (posn-point posn))) + (setq beg point))) + ;; Check if lines are being truncated; if so, use the + ;; character at the end of the window as the end of the + ;; text to be displayed, as the visual line may extend + ;; past the window. + (when (or truncate-lines beg) ; truncate-lines or hscroll. + (setq y (or y (+ (or (cdr (posn-x-y (posn-at-point))) + (throw 'hscrolled-away t)) + (window-header-line-height) + (window-tab-line-height)))) + (let* ((posn (posn-at-x-y (1- (window-width nil t)) y)) + (point (posn-point posn))) + (setq end point))) + ;; Now find the rest of the visual line. + (save-excursion + (unless beg + (beginning-of-visual-line) + (setq beg (point))) + (unless end + (end-of-visual-line) + (setq end (point)))) + ;; Obtain a substring containing the beginning of the + ;; visual line and the end. + (setq string (buffer-substring beg end)) + ;; Hack `invisible' properties within the new string. + ;; Look for each change of the property that is a variable + ;; name and replace it with its actual value according to + ;; `buffer-invisibility-spec'. + (when (listp buffer-invisibility-spec) + (let ((index 0) + (property (get-text-property 0 + 'invisible + string)) + index1 invisible) + (while index + ;; Find the end of this text property. + (setq index1 (next-single-property-change index + 'invisible + string)) + ;; Replace the property with whether or not it is + ;; non-nil. + (when property + (setq invisible nil) + (catch 'invisible + (dolist (spec buffer-invisibility-spec) + ;; Process one element of the buffer + ;; invisibility specification. + (if (consp spec) + (when (eq (cdr spec) 't) + ;; (ATOM . t) makes N invisible if N is + ;; equal to ATOM or a list containing + ;; ATOM. + (when (or (eq (car spec) property) + (and (listp spec) + (memq (car spec) invisible))) + (throw 'invisible (setq invisible t)))) + ;; Otherwise, N is invisible if SPEC is + ;; equal to N. + (when (eq spec property) + (throw 'invisible (setq invisible t)))))) + (put-text-property index (or index1 + (- end beg)) + 'invisible invisible string)) + ;; Set index to that of the next text property and + ;; continue. + (setq index index1 + property (and index1 + (get-text-property index1 + 'invisible + string)))))) + (let ((resize-mini-windows t) difference width + (message-log-max nil)) + ;; Find the offset of point from beg and display a cursor + ;; below. + (setq difference (- (point) beg) + width (string-pixel-width + (substring string 0 difference))) + (message "%s\n%s^" string + (propertize " " + 'display (list 'space + :width (list width))))) + nil)))) (defun touch-screen-drag (event) "Handle a drag EVENT by setting the region to its new point. @@ -523,113 +519,208 @@ area." (interactive "e") (let* ((posn (cadr event)) ; Position of the tool. (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)) + ;; The currently selected window. Used to redisplay within + ;; the correct window while scrolling. + (old-window (selected-window)) initial-point) ;; Keep dragging. (with-selected-window window - ;; Figure out what character to go to. If this posn is - ;; in the window, go to (posn-point posn). If not, - ;; then go to the line before either window start or - ;; window end. + ;; Figure out what character to go to. If this posn is in the + ;; window, go to (posn-point posn). If not, then go to the line + ;; before either window start or window end. (setq initial-point (point)) - (if (and (eq (posn-window posn) window) - point (not (eq point initial-point))) - (let* ((bounds touch-screen-word-select-bounds) - (initial touch-screen-word-select-initial-word) - (maybe-select-word (or (not touch-screen-word-select) - (or (not bounds) - (> point (cdr bounds)) - (< point (car bounds)))))) - (if (and touch-screen-word-select - ;; point is now outside the last word selected. - maybe-select-word - (not (posn-object posn)) - (when-let* ((char (char-after point)) - (class (char-syntax char))) - ;; Don't select words if point isn't inside a - ;; word constituent or similar. - (or (eq class ?w) (eq class ?_)))) - ;; Determine the confines of the word containing - ;; POINT. - (let (word-start word-end) - (save-excursion - (goto-char point) - (forward-word-strictly) - ;; Set word-end to ZV if there is no word after - ;; this one. - (setq word-end (point)) - ;; Now try to move backwards. Set word-start to - ;; BEGV if this word is there. - (backward-word-strictly) - (setq word-start (point))) - (let ((mark (mark))) - ;; Extend the region to cover either word-end or - ;; word-start; whether to goto word-end or - ;; word-start is subject to the position of the - ;; mark relative to point. - (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)) + (when (or (not point) + (not (eq point initial-point))) + (if (and (eq (posn-window posn) window) + point + ;; point must be visible in the window. If it isn't, + ;; the window must be scrolled. + (pos-visible-in-window-p point)) + (let* ((bounds touch-screen-word-select-bounds) + (initial touch-screen-word-select-initial-word) + (maybe-select-word (or (not touch-screen-word-select) + (or (not bounds) + (> point (cdr bounds)) + (< point (car bounds)))))) + (if (and touch-screen-word-select + ;; point is now outside the last word selected. + maybe-select-word + (not (posn-object posn)) + (when-let* ((char (char-after point)) + (class (char-syntax char))) + ;; Don't select words if point isn't inside a + ;; word constituent or similar. + (or (eq class ?w) (eq class ?_)))) + ;; Determine the confines of the word containing + ;; POINT. + (let (word-start word-end) + (save-excursion + (goto-char point) + (forward-word-strictly) + ;; Set word-end to ZV if there is no word after + ;; this one. + (setq word-end (point)) + ;; Now try to move backwards. Set word-start to + ;; BEGV if this word is there. + (backward-word-strictly) + (setq word-start (point))) + (let ((mark (mark))) + ;; Extend the region to cover either word-end or + ;; word-start; whether to goto word-end or + ;; word-start is subject to the position of the + ;; mark relative to point. + (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 ;; 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))) + (when (and (<= (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))) + (when (and (>= (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 than - ;; the end of the word that was originally selected, - ;; try to keep it selected by moving mark there. - (when (and (<= (point) (mark)) - (< (mark) (cdr initial))) - (set-mark (cdr initial))) - ;; Do the opposite when the converse is true. - (when (and (>= (point) (mark)) - (> (mark) (car initial))) - (set-mark (car initial)))) - (setq touch-screen-word-select-bounds nil))) - ;; Finally, display a preview of the line around point if - ;; 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)) + (setq touch-screen-word-select-bounds nil))) + ;; Finally, display a preview of the line around point + ;; if 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)) + (xy (posn-x-y posn)) + ;; The height of the window's text area. + (body-height (window-body-height nil t)) + ;; This is used to find the character closest to + ;; POSN's column at the bottom of the window. + (height (- body-height + ;; Use the last row of the window, not its + ;; last pixel. + (frame-char-height))) + (midpoint (/ body-height 2)) + (scroll-conservatively 101)) (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 - (goto-char (1- (window-start))) - (setq touch-screen-word-select-bounds nil)) - (redisplay)) - ((> (cdr relative-xy) - (let ((edges (window-inside-pixel-edges))) - (- (nth 3 edges) (cadr edges)))) + ;; Scroll down by a single line. + (scroll-down 1) + ;; 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)) + ;; 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 - (goto-char (1+ (window-end nil t))) - (setq touch-screen-word-select-bounds nil)) - (redisplay))) - ;; Finally, display a preview of the line now around point - ;; if requested by the user. - (when touch-screen-preview-select - (touch-screen-preview-select)))))))) + ;; Scroll up by a single line. + (scroll-up 1) + ;; 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)) + ;; 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) "Restart dragging to select text. -- 2.39.5