procyberian/emacs
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

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
Show stats 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)
(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.