mirror of
https://git.savannah.gnu.org/git/emacs.git
synced 2024-12-14 09:39:42 +00:00
dc1ed3dbfa
* lisp/touch-screen.el (touch-screen-handle-point-up) <held>: Treat `held' as `drag' as well. * src/android.c (android_is_special_directory): Return bool rather than a pointer to the remainder of the file name, given that said pointer is never used. * src/android.h (android_is_special_directory): Modify correspondingly.
1622 lines
76 KiB
EmacsLisp
1622 lines
76 KiB
EmacsLisp
;;; touch-screen.el --- touch screen support for X and Android -*- lexical-binding: t; -*-
|
||
|
||
;; Copyright (C) 2023 Free Software Foundation, Inc.
|
||
|
||
;; Maintainer: emacs-devel@gnu.org
|
||
;; Package: emacs
|
||
|
||
;; This file is part of GNU Emacs.
|
||
|
||
;; GNU Emacs 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.
|
||
|
||
;; GNU Emacs 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 GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
|
||
|
||
;;; Commentary:
|
||
|
||
;; This file provides code to recognize simple touch screen gestures.
|
||
;; It is used on X and Android, currently the only systems where Emacs
|
||
;; supports touch input.
|
||
;;
|
||
;; See (elisp)Touchscreen Events for a description of the details of
|
||
;; touch events.
|
||
|
||
;;; Code:
|
||
|
||
(defvar touch-screen-current-tool nil
|
||
"The touch point currently being tracked, or nil.
|
||
If non-nil, this is a list of nine elements: the ID of the touch
|
||
point being tracked, the window where the touch began, a cons
|
||
containing the last known position of the touch point, relative
|
||
to that window, a field used to store data while tracking the
|
||
touch point, the initial position of the touchpoint, and another
|
||
four fields to used store data while tracking the touch point.
|
||
See `touch-screen-handle-point-update' and
|
||
`touch-screen-handle-point-up' for the meanings of the fourth
|
||
element.")
|
||
|
||
(defvar touch-screen-set-point-commands '(mouse-set-point)
|
||
"List of commands known to set the point.
|
||
This is used to determine whether or not to display the on-screen
|
||
keyboard after a mouse command is executed in response to a
|
||
`touchscreen-end' event.")
|
||
|
||
(defvar touch-screen-current-timer nil
|
||
"Timer used to track long-presses.
|
||
This is always cleared upon any significant state change.")
|
||
|
||
(defvar touch-screen-translate-prompt nil
|
||
"Prompt given to the touch screen translation function.
|
||
If non-nil, the touch screen key event translation machinery
|
||
is being called from `read-sequence' or some similar function.")
|
||
|
||
(defcustom touch-screen-display-keyboard nil
|
||
"If non-nil, always display the on screen keyboard.
|
||
A buffer local value means to always display the on screen
|
||
keyboard when the buffer is selected."
|
||
:type 'boolean
|
||
:group 'mouse
|
||
:version "30.1")
|
||
|
||
(defcustom touch-screen-delay 0.7
|
||
"Delay in seconds before Emacs considers a touch to be a long-press."
|
||
:type 'number
|
||
:group 'mouse
|
||
:version "30.1")
|
||
|
||
(defcustom touch-screen-precision-scroll nil
|
||
"Whether or not to use precision scrolling for touch screens.
|
||
See `pixel-scroll-precision-mode' for more details."
|
||
:type 'boolean
|
||
:group 'mouse
|
||
:version "30.1")
|
||
|
||
(defcustom touch-screen-word-select nil
|
||
"Whether or not to select whole words while dragging to select.
|
||
If non-nil, long-press events (see `touch-screen-delay') followed
|
||
by dragging will try to select entire words."
|
||
:type 'boolean
|
||
:group 'mouse
|
||
:version "30.1")
|
||
|
||
(defcustom touch-screen-extend-selection nil
|
||
"If non-nil, restart drag-to-select upon a tap on point or mark.
|
||
When enabled, tapping on the character containing the point or
|
||
mark will resume dragging where it left off while the region is
|
||
active."
|
||
:type 'boolean
|
||
:group 'mouse
|
||
:version "30.1")
|
||
|
||
(defcustom touch-screen-preview-select nil
|
||
"If non-nil, display a preview while selecting text.
|
||
When enabled, a preview of the visible line within the window
|
||
will be displayed in the echo area while dragging combined with
|
||
an indication of the position of point within that line."
|
||
:type 'boolean
|
||
:group 'mouse
|
||
:version "30.1")
|
||
|
||
(defvar-local touch-screen-word-select-bounds nil
|
||
"The start and end positions of the word last selected.
|
||
Normally a cons of those two positions or nil if no word was
|
||
selected.")
|
||
|
||
(defvar-local touch-screen-word-select-initial-word nil
|
||
"The start and end positions of the first word to be selected.
|
||
Used in an attempt to keep this word selected during later
|
||
dragging.")
|
||
|
||
|
||
|
||
;;; Scroll gesture.
|
||
|
||
(defun touch-screen-relative-xy (posn window)
|
||
"Return the coordinates of POSN, a mouse position list.
|
||
However, return the coordinates relative to WINDOW.
|
||
|
||
If (posn-window posn) is the same as window, simply return the
|
||
coordinates in POSN. Otherwise, convert them to the frame, and
|
||
then back again.
|
||
|
||
If WINDOW is the symbol `frame', simply convert the coordinates
|
||
to the frame that they belong in."
|
||
(if (or (eq (posn-window posn) window)
|
||
(and (eq window 'frame)
|
||
(framep (posn-window posn))))
|
||
(posn-x-y posn)
|
||
(let ((xy (posn-x-y posn))
|
||
(edges (and (windowp window)
|
||
(window-inside-pixel-edges window))))
|
||
;; Make the X and Y positions frame relative.
|
||
(when (windowp (posn-window posn))
|
||
(let ((edges (window-inside-pixel-edges
|
||
(posn-window posn))))
|
||
(setq xy (cons (+ (car xy) (car edges))
|
||
(+ (cdr xy) (cadr edges))))))
|
||
(if (eq window 'frame)
|
||
xy
|
||
;; Make the X and Y positions window relative again.
|
||
(cons (- (car xy) (car edges))
|
||
(- (cdr xy) (cadr edges)))))))
|
||
|
||
(defun touch-screen-handle-scroll (dx dy)
|
||
"Scroll the display assuming that a touch point has moved by DX and DY.
|
||
Perform vertical scrolling by DY, using `pixel-scroll-precision'
|
||
if `touch-screen-precision-scroll' is enabled. Next, perform
|
||
horizontal scrolling according to the movement in DX."
|
||
;; Perform vertical scrolling first. Do not ding at buffer limits.
|
||
;; Show a message instead.
|
||
(condition-case nil
|
||
(if touch-screen-precision-scroll
|
||
(progn
|
||
(if (> dy 0)
|
||
(pixel-scroll-precision-scroll-down-page dy)
|
||
(pixel-scroll-precision-scroll-up-page (- dy)))
|
||
;; Now set `lines-vscrolled' to an value that will result
|
||
;; in hscroll being disabled if dy looks as if a
|
||
;; significant amount of scrolling is about to take
|
||
;; Otherwise, horizontal scrolling may then interfere with
|
||
;; precision scrolling.
|
||
(when (> (abs dy) 10)
|
||
(setcar (nthcdr 7 touch-screen-current-tool) 10)))
|
||
;; Start conventional scrolling. First, determine the
|
||
;; direction in which the scrolling is taking place. Load the
|
||
;; accumulator value.
|
||
(let ((accumulator (or (nth 5 touch-screen-current-tool) 0))
|
||
(window (cadr touch-screen-current-tool))
|
||
(lines-vscrolled (or (nth 7 touch-screen-current-tool) 0)))
|
||
(setq accumulator (+ accumulator dy)) ; Add dy.
|
||
;; Figure out how much it has scrolled and how much remains
|
||
;; on the top or bottom of the window.
|
||
(while (catch 'again
|
||
(let* ((line-height (window-default-line-height window)))
|
||
(if (and (< accumulator 0)
|
||
(>= (- accumulator) line-height))
|
||
(progn
|
||
(setq accumulator (+ accumulator line-height))
|
||
(scroll-down 1)
|
||
(setq lines-vscrolled (1+ lines-vscrolled))
|
||
(when (not (zerop accumulator))
|
||
;; If there is still an outstanding
|
||
;; amount to scroll, do this again.
|
||
(throw 'again t)))
|
||
(when (and (> accumulator 0)
|
||
(>= accumulator line-height))
|
||
(setq accumulator (- accumulator line-height))
|
||
(scroll-up 1)
|
||
(setq lines-vscrolled (1+ lines-vscrolled))
|
||
(when (not (zerop accumulator))
|
||
;; If there is still an outstanding amount
|
||
;; to scroll, do this again.
|
||
(throw 'again t)))))
|
||
;; Scrolling is done. Move the accumulator back to
|
||
;; touch-screen-current-tool and break out of the
|
||
;; loop.
|
||
(setcar (nthcdr 5 touch-screen-current-tool) accumulator)
|
||
(setcar (nthcdr 7 touch-screen-current-tool)
|
||
lines-vscrolled)
|
||
nil))))
|
||
(beginning-of-buffer
|
||
(message (error-message-string '(beginning-of-buffer))))
|
||
(end-of-buffer
|
||
(message (error-message-string '(end-of-buffer)))))
|
||
|
||
;; Perform horizontal scrolling by DX, as this does not signal at
|
||
;; the beginning of the buffer.
|
||
(let ((accumulator (or (nth 6 touch-screen-current-tool) 0))
|
||
(window (cadr touch-screen-current-tool))
|
||
(lines-vscrolled (or (nth 7 touch-screen-current-tool) 0))
|
||
(lines-hscrolled (or (nth 8 touch-screen-current-tool) 0)))
|
||
(setq accumulator (+ accumulator dx)) ; Add dx;
|
||
;; Figure out how much it has scrolled and how much remains on the
|
||
;; left or right of the window. If a line has already been
|
||
;; vscrolled but no hscrolling has happened, don't hscroll, as
|
||
;; otherwise it is too easy to hscroll by accident.
|
||
(if (or (> lines-hscrolled 0)
|
||
(< lines-vscrolled 1))
|
||
(while (catch 'again
|
||
(let* ((column-width (frame-char-width (window-frame window))))
|
||
(if (and (< accumulator 0)
|
||
(>= (- accumulator) column-width))
|
||
(progn
|
||
(setq accumulator (+ accumulator column-width))
|
||
(scroll-right 1)
|
||
(setq lines-hscrolled (1+ lines-hscrolled))
|
||
(when (not (zerop accumulator))
|
||
;; If there is still an outstanding amount
|
||
;; to scroll, do this again.
|
||
(throw 'again t)))
|
||
(when (and (> accumulator 0)
|
||
(>= accumulator column-width))
|
||
(setq accumulator (- accumulator column-width))
|
||
(scroll-left 1)
|
||
(setq lines-hscrolled (1+ lines-hscrolled))
|
||
(when (not (zerop accumulator))
|
||
;; If there is still an outstanding amount to
|
||
;; scroll, do this again.
|
||
(throw 'again t)))))
|
||
;; Scrolling is done. Move the accumulator back to
|
||
;; touch-screen-current-tool and break out of the
|
||
;; loop.
|
||
(setcar (nthcdr 6 touch-screen-current-tool) accumulator)
|
||
(setcar (nthcdr 8 touch-screen-current-tool) lines-hscrolled)
|
||
nil)))))
|
||
|
||
(defun touch-screen-scroll (event)
|
||
"Scroll the window within EVENT, a `touchscreen-scroll' event.
|
||
If `touch-screen-precision-scroll', scroll the window vertically
|
||
by the number of pixels specified within that event. Else,
|
||
scroll the window by one line for every
|
||
`window-default-line-height' pixels worth of movement.
|
||
|
||
If EVENT also specifies horizontal motion and no significant
|
||
amount of vertical scrolling has taken place, also scroll the
|
||
window horizontally in conjunction with the number of pixels in
|
||
the event."
|
||
(interactive "e")
|
||
(let ((window (nth 1 event))
|
||
(dx (nth 2 event))
|
||
(dy (nth 3 event)))
|
||
(with-selected-window window
|
||
(touch-screen-handle-scroll dx dy))))
|
||
|
||
(global-set-key [touchscreen-scroll] #'touch-screen-scroll)
|
||
|
||
|
||
|
||
;;; Drag-to-select gesture.
|
||
|
||
(defun touch-screen-hold (event)
|
||
"Handle a long press EVENT.
|
||
Ding and select the window at EVENT, then activate the mark. If
|
||
`touch-screen-word-select' is enabled, try to select the whole
|
||
word around EVENT; otherwise, set point to the location of EVENT."
|
||
(interactive "e")
|
||
(let* ((posn (cadr event))
|
||
(point (posn-point posn))
|
||
(window (posn-window posn)))
|
||
(when (and point
|
||
;; Make sure WINDOW is not an inactive minibuffer
|
||
;; window.
|
||
(or (not (eq window
|
||
(minibuffer-window
|
||
(window-frame window))))
|
||
(minibuffer-window-active-p window)))
|
||
(beep)
|
||
(select-window window)
|
||
(if (or (not touch-screen-word-select)
|
||
(when-let* ((char (char-after point))
|
||
(class (char-syntax char)))
|
||
;; Don't select words if point isn't inside a word
|
||
;; constituent or similar.
|
||
(not (or (eq class ?w) (eq class ?_)))))
|
||
(progn
|
||
;; Set the mark and activate it.
|
||
(setq touch-screen-word-select-initial-word nil
|
||
touch-screen-word-select-bounds nil)
|
||
(push-mark point)
|
||
(goto-char point)
|
||
(activate-mark))
|
||
;; Start word selection by trying to obtain the position
|
||
;; around point.
|
||
(let ((word-start nil)
|
||
(word-end nil))
|
||
(unless (posn-object posn)
|
||
;; If there's an object under POSN avoid trying to
|
||
;; ascertain the bounds of the word surrounding it.
|
||
(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))))
|
||
;; Check if word-start and word-end are identical, if there
|
||
;; is an object under POSN, or if point is looking at or
|
||
;; outside a word.
|
||
(if (or (eq word-start word-end)
|
||
(>= word-start point))
|
||
(progn
|
||
;; If so, clear the bounds and set and activate the
|
||
;; mark.
|
||
(setq touch-screen-word-select-bounds nil
|
||
touch-screen-word-select-initial-word nil)
|
||
(push-mark point)
|
||
(goto-char point)
|
||
(activate-mark))
|
||
;; Otherwise, select the word. Move point to either the
|
||
;; end or the start of the word, depending on which is
|
||
;; closer to EVENT.
|
||
(let ((diff-beg (- point word-start))
|
||
(diff-end (- word-end point))
|
||
use-end)
|
||
(if (> diff-beg diff-end)
|
||
;; Set the point to the end of the word.
|
||
(setq use-end t)
|
||
(if (< diff-end diff-beg)
|
||
(setq use-end nil)
|
||
;; POINT is in the middle of the word. Use its
|
||
;; window coordinates to establish whether or not it
|
||
;; is closer to the start of the word or to the end
|
||
;; of the word.
|
||
(let ((posn-beg (posn-at-point word-start))
|
||
(posn-end (posn-at-point word-end)))
|
||
;; Give up if there's an object at either of those
|
||
;; positions, or they're not on the same row.
|
||
;; If one of the positions isn't visible, use the
|
||
;; window end.
|
||
(if (and posn-beg posn-end
|
||
(not (posn-object posn-beg))
|
||
(not (posn-object posn-end))
|
||
(eq (cdr (posn-col-row posn-beg))
|
||
(cdr (posn-col-row posn-end))))
|
||
(setq use-end nil)
|
||
;; Compare the pixel positions.
|
||
(setq point (car (posn-x-y posn))
|
||
diff-beg (- point (car (posn-x-y posn-beg)))
|
||
diff-end (- (car (posn-x-y posn-end)) point))
|
||
;; Now determine whether or not point should be
|
||
;; moved to the end.
|
||
(setq use-end (>= diff-beg diff-end))))))
|
||
(if use-end
|
||
(progn
|
||
(push-mark word-start)
|
||
(activate-mark)
|
||
(goto-char word-end))
|
||
(progn
|
||
(push-mark word-end)
|
||
(activate-mark)
|
||
(goto-char word-start)))
|
||
;; Record the bounds of the selected word.
|
||
(setq touch-screen-word-select-bounds
|
||
(cons word-start word-end)
|
||
;; Save this for the benefit of touch-screen-drag.
|
||
touch-screen-word-select-initial-word
|
||
(cons word-start word-end)))))))))
|
||
|
||
(defun touch-screen-preview-select ()
|
||
"Display a preview of the line around point in the echo area.
|
||
Unless the minibuffer is an active or the current line is
|
||
excessively tall, display an indication of the position of point
|
||
and the contents of the visible line around it within the echo
|
||
area.
|
||
|
||
If the selected window is hscrolled or lines may be truncated,
|
||
attempt to find the extents of the text between column 0 and the
|
||
right most column of the window using `posn-at-x-y'."
|
||
(interactive)
|
||
;; First, establish that the minibuffer isn't active and the line
|
||
;; isn't taller than two times the frame character height.
|
||
(unless (or (> (minibuffer-depth) 0)
|
||
;; The code below doesn't adapt well to buffers
|
||
;; containing long lines.
|
||
(long-line-optimizations-p)
|
||
(let ((window-line-height (window-line-height))
|
||
(maximum-height (* 2 (frame-char-height))))
|
||
(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.
|
||
If `touch-screen-word-select' and EVENT lies outside the last
|
||
word that was selected, select the word that now contains POINT.
|
||
Scroll the window if EVENT's coordinates are outside its text
|
||
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 (nth 1 touch-screen-current-tool))
|
||
;; The currently selected window. Used to redisplay within
|
||
;; the correct window while scrolling.
|
||
(old-window (selected-window))
|
||
;; Whether or not text should be selected word-by-word.
|
||
(word-select touch-screen-word-select)
|
||
;; Cons containing the confines of the word initially
|
||
;; selected when the touchpoint was first held down.
|
||
(initial touch-screen-word-select-initial-word)
|
||
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.
|
||
(setq initial-point (point))
|
||
(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)
|
||
(maybe-select-word (or (not touch-screen-word-select)
|
||
(or (not bounds)
|
||
(> point (cdr bounds))
|
||
(< point (car bounds))))))
|
||
(if (and 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 (<= (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))
|
||
(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) midpoint)
|
||
;; POSN is before half the window, yet POINT does not
|
||
;; exist or is not completely visible within. Scroll
|
||
;; downwards.
|
||
(ignore-errors
|
||
;; 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)))
|
||
;; If word selection is enabled, now try to keep the
|
||
;; initially selected word within the active region.
|
||
(when word-select
|
||
(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))
|
||
;; 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)))
|
||
;; If word selection is enabled, now try to keep
|
||
;; the initially selected word within the active
|
||
;; region.
|
||
(when word-select
|
||
(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))
|
||
;; 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
|
||
;; 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)))
|
||
;; If word selection is enabled, now try to keep
|
||
;; the initially selected word within the active
|
||
;; region.
|
||
(when word-select
|
||
(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))
|
||
;; 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)))
|
||
;; If word selection is enabled, now try to keep
|
||
;; the initially selected word within the active
|
||
;; region.
|
||
(when word-select
|
||
(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))
|
||
;; 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.
|
||
Set point to the location of EVENT within its window while
|
||
keeping the bounds of the region intact, and set up state for
|
||
`touch-screen-drag'."
|
||
(interactive "e")
|
||
(let* ((posn (event-start event))
|
||
(window (posn-window posn))
|
||
(point (posn-point posn)))
|
||
(with-selected-window window
|
||
(let ((current-point (point))
|
||
(current-mark (mark)))
|
||
;; Ensure that mark and point haven't changed since EVENT was
|
||
;; generated, and the region is still active.
|
||
(when (or (eq point current-point)
|
||
(eq point current-mark)
|
||
(region-active-p))
|
||
(when (eq point current-mark)
|
||
;; Exchange point and mark.
|
||
(exchange-point-and-mark))
|
||
;; Clear the state necessary to set up dragging. Don't try
|
||
;; to select entire words immediately after dragging starts,
|
||
;; to allow for fine grained selection inside a word.
|
||
(setq touch-screen-word-select-bounds nil
|
||
touch-screen-word-select-initial-word nil))))))
|
||
|
||
(global-set-key [touchscreen-hold] #'touch-screen-hold)
|
||
(global-set-key [touchscreen-drag] #'touch-screen-drag)
|
||
(global-set-key [touchscreen-restart-drag] #'touch-screen-restart-drag)
|
||
|
||
|
||
|
||
;; Touch screen event translation. The code here translates raw touch
|
||
;; screen events into `touchscreen-scroll' events and mouse events in
|
||
;; a ``DWIM'' fashion, consulting the keymaps at the position of the
|
||
;; mouse event to determine the best course of action, while also
|
||
;; recognizing drag-to-select and other gestures.
|
||
|
||
(defun touch-screen-handle-timeout (arg)
|
||
"Start the touch screen timeout or handle it depending on ARG.
|
||
When ARG is nil, start the `touch-screen-current-timer' to go off
|
||
in `touch-screen-delay' seconds, and call this function with ARG
|
||
t.
|
||
|
||
When ARG is t, set the fourth element of
|
||
`touch-screen-current-tool' to `held', and generate a
|
||
`touchscreen-hold' event at the original position of that tool."
|
||
(if (not arg)
|
||
;; Cancel the touch screen long-press timer, if it is still
|
||
;; there by any chance.
|
||
(progn
|
||
(when touch-screen-current-timer
|
||
(cancel-timer touch-screen-current-timer))
|
||
(setq touch-screen-current-timer
|
||
(run-at-time touch-screen-delay nil
|
||
#'touch-screen-handle-timeout
|
||
t)))
|
||
;; Set touch-screen-current-timer to nil.
|
||
(setq touch-screen-current-timer nil)
|
||
(when touch-screen-current-tool
|
||
;; Set the state to `held'.
|
||
(setcar (nthcdr 3 touch-screen-current-tool) 'held)
|
||
;; Generate an input event at the original position of the mark.
|
||
;; This assumes that the timer is running within
|
||
;; `touch-screen-translate-touch'.
|
||
(let ((posn (nth 4 touch-screen-current-tool)))
|
||
(throw 'input-event (list 'touchscreen-hold posn))))))
|
||
|
||
(defun touch-screen-handle-point-update (point)
|
||
"Notice that the touch point POINT has changed position.
|
||
Perform the editing operations or throw to the input translation
|
||
function with an input event tied to any gesture that is
|
||
recognized.
|
||
|
||
POINT must be the touch point currently being tracked as
|
||
`touch-screen-current-tool'.
|
||
|
||
If the fourth element of `touch-screen-current-tool' is nil, then
|
||
the touch has just begun. Determine how much POINT has moved.
|
||
If POINT has moved upwards or downwards by a significant amount,
|
||
then set the fourth element to `scroll'. Then, generate a
|
||
`touchscreen-scroll' event with the window that POINT was
|
||
initially placed upon, and pixel deltas describing how much point
|
||
has moved relative to its previous position in the X and Y axes.
|
||
|
||
If the fourth element of `touchscreen-current-tool' is `scroll',
|
||
then generate a `touchscreen-scroll' event with the window that
|
||
qPOINT was initially placed upon, and pixel deltas describing how
|
||
much point has moved relative to its previous position in the X
|
||
and Y axes.
|
||
|
||
If the fourth element of `touch-screen-current-tool' is
|
||
`mouse-drag' and `track-mouse' is non-nil, then generate a
|
||
`mouse-movement' event with the position of POINT.
|
||
|
||
If the fourth element of `touch-screen-current-tool' is `held',
|
||
then the touch has been held down for some time. If motion
|
||
happens, set the field to `drag'. Then, generate a
|
||
`touchscreen-drag' event.
|
||
|
||
If the fourth element of `touch-screen-current-tool' is
|
||
`restart-drag', set the field to `drag' and generate a
|
||
`touchscreen-drag'.
|
||
|
||
If the fourth element of `touch-screen-current-tool' is `drag',
|
||
then move point to the position of POINT."
|
||
(let ((window (nth 1 touch-screen-current-tool))
|
||
(what (nth 3 touch-screen-current-tool)))
|
||
(cond ((null what)
|
||
(let* ((posn (cdr point))
|
||
(last-posn (nth 2 touch-screen-current-tool))
|
||
(original-posn (nth 4 touch-screen-current-tool))
|
||
;; Now get the position of X and Y relative to
|
||
;; WINDOW.
|
||
(relative-xy
|
||
(touch-screen-relative-xy posn window))
|
||
(col (and (not (posn-area original-posn))
|
||
(car (posn-col-row original-posn
|
||
(posn-window posn)))))
|
||
;; Don't start horizontal scrolling if the touch
|
||
;; point originated within two columns of the window
|
||
;; edges, as systems like Android use those two
|
||
;; columns to implement gesture navigation.
|
||
(diff-x-eligible
|
||
(and col (> col 2)
|
||
(< col (- (window-width window) 2))))
|
||
(diff-x (- (car last-posn) (car relative-xy)))
|
||
(diff-y (- (cdr last-posn) (cdr relative-xy))))
|
||
(when (or (> diff-y 10)
|
||
(and diff-x-eligible
|
||
(> diff-x (frame-char-width)))
|
||
(< diff-y -10)
|
||
(and diff-x-eligible
|
||
(< diff-x (- (frame-char-width)))))
|
||
(setcar (nthcdr 3 touch-screen-current-tool)
|
||
'scroll)
|
||
(setcar (nthcdr 2 touch-screen-current-tool)
|
||
relative-xy)
|
||
;; Cancel the touch screen long-press timer, if it is
|
||
;; still there by any chance.
|
||
(when touch-screen-current-timer
|
||
(cancel-timer touch-screen-current-timer)
|
||
(setq touch-screen-current-timer nil))
|
||
;; Generate a `touchscreen-scroll' event with `diff-x'
|
||
;; and `diff-y'.
|
||
(throw 'input-event
|
||
(list 'touchscreen-scroll
|
||
window diff-x diff-y)))))
|
||
((eq what 'scroll)
|
||
;; Cancel the touch screen long-press timer, if it is still
|
||
;; there by any chance.
|
||
(when touch-screen-current-timer
|
||
(cancel-timer touch-screen-current-timer)
|
||
(setq touch-screen-current-timer nil))
|
||
(let* ((posn (cdr point))
|
||
(last-posn (nth 2 touch-screen-current-tool))
|
||
;; Now get the position of X and Y relative to
|
||
;; WINDOW.
|
||
(relative-xy
|
||
(touch-screen-relative-xy posn window))
|
||
(diff-x (- (car last-posn) (car relative-xy)))
|
||
(diff-y (- (cdr last-posn) (cdr relative-xy))))
|
||
(setcar (nthcdr 3 touch-screen-current-tool)
|
||
'scroll)
|
||
(setcar (nthcdr 2 touch-screen-current-tool)
|
||
relative-xy)
|
||
(unless (and (zerop diff-x) (zerop diff-y))
|
||
(throw 'input-event
|
||
;; Generate a `touchscreen-scroll' event with
|
||
;; `diff-x' and `diff-y'.
|
||
(list 'touchscreen-scroll
|
||
window diff-x diff-y)))))
|
||
((eq what 'mouse-drag)
|
||
;; There was a `down-mouse-1' event bound at the starting
|
||
;; point of the event. Generate a mouse-motion event if
|
||
;; mouse movement is being tracked.
|
||
(when track-mouse
|
||
(throw 'input-event (list 'mouse-movement
|
||
(cdr point)))))
|
||
((eq what 'held)
|
||
(let* ((posn (cdr point)))
|
||
;; Now start dragging.
|
||
(setcar (nthcdr 3 touch-screen-current-tool)
|
||
'drag)
|
||
;; Generate a (touchscreen-drag POSN) event.
|
||
;; `touchscreen-hold' was generated when the timeout
|
||
;; fired.
|
||
(throw 'input-event (list 'touchscreen-drag posn))))
|
||
((eq what 'restart-drag)
|
||
(let* ((posn (cdr point)))
|
||
;; Now start dragging.
|
||
(setcar (nthcdr 3 touch-screen-current-tool)
|
||
'drag)
|
||
;; Generate a (touchscreen-drag POSN) event.
|
||
;; `touchscreen-restart-drag' was generated when the
|
||
;; timeout fired.
|
||
(throw 'input-event (list 'touchscreen-drag posn))))
|
||
((eq what 'drag)
|
||
(let* ((posn (cdr point)))
|
||
;; Generate a (touchscreen-drag POSN) event.
|
||
(throw 'input-event (list 'touchscreen-drag posn)))))))
|
||
|
||
(defun touch-screen-window-selection-changed (frame)
|
||
"Notice that FRAME's selected window has changed.
|
||
Cancel any timer that is supposed to hide the keyboard in
|
||
response to the minibuffer being closed."
|
||
(with-selected-frame frame
|
||
(unless (and (or buffer-read-only
|
||
(get-text-property (point) 'read-only))
|
||
;; Don't hide the on-screen keyboard if it's always
|
||
;; supposed to be displayed.
|
||
(not touch-screen-display-keyboard))
|
||
;; Prevent hiding the minibuffer from hiding the on screen
|
||
;; keyboard.
|
||
(when minibuffer-on-screen-keyboard-timer
|
||
(cancel-timer minibuffer-on-screen-keyboard-timer)
|
||
(setq minibuffer-on-screen-keyboard-timer nil)))))
|
||
|
||
(defun touch-screen-handle-point-up (point prefix)
|
||
"Notice that POINT has been removed from the screen.
|
||
POINT should be the point currently tracked as
|
||
`touch-screen-current-tool'.
|
||
PREFIX should be a virtual function key used to look up key
|
||
bindings.
|
||
|
||
If the fourth element of `touch-screen-current-tool' is nil or
|
||
`restart-drag', move point to the position of POINT, selecting
|
||
the window under POINT as well, and deactivate the mark; if there
|
||
is a button or link at POINT, call the command bound to `mouse-2'
|
||
there. Otherwise, call the command bound to `mouse-1'.
|
||
|
||
If the fourth element of `touch-screen-current-tool' is
|
||
`mouse-drag', then generate either a `mouse-1' or a
|
||
`drag-mouse-1' event depending on how far the position of POINT
|
||
is from the starting point of the touch.
|
||
|
||
If the fourth element of `touch-screen-current-tool' is
|
||
`mouse-1-menu', then generate a `down-mouse-1' event at the
|
||
original position of the tool to display its bound keymap as a
|
||
menu.
|
||
|
||
If the fourth element of `touch-screen-current-tool' is `drag' or
|
||
`held', the region is active, and the tool's initial window's
|
||
selected buffer isn't read-only, display the on screen keyboard.
|
||
|
||
If the command being executed is listed in
|
||
`touch-screen-set-point-commands' also display the on-screen
|
||
keyboard if the current buffer and the character at the new point
|
||
is not read-only."
|
||
(let ((what (nth 3 touch-screen-current-tool))
|
||
(posn (cdr point)) window point)
|
||
(cond ((or (null what)
|
||
;; If dragging has been restarted but the touch point
|
||
;; hasn't been moved, translate the sequence into a
|
||
;; regular mouse click.
|
||
(eq what 'restart-drag))
|
||
(when (windowp (posn-window posn))
|
||
(setq point (posn-point posn)
|
||
window (posn-window posn))
|
||
;; Select the window that was tapped given that it isn't
|
||
;; an inactive minibuffer window.
|
||
(when (or (not (eq window
|
||
(minibuffer-window
|
||
(window-frame window))))
|
||
(minibuffer-window-active-p window))
|
||
(select-window window))
|
||
;; Now simulate a mouse click there. If there is a link
|
||
;; or a button, use mouse-2 to push it.
|
||
(let* ((event (list (if (or (mouse-on-link-p posn)
|
||
(and point (button-at point)))
|
||
'mouse-2
|
||
'mouse-1)
|
||
posn))
|
||
;; Look for the command bound to this event.
|
||
(command (key-binding (if prefix
|
||
(vector prefix
|
||
(car event))
|
||
(vector (car event)))
|
||
t nil posn)))
|
||
(deactivate-mark)
|
||
(when point
|
||
;; This is necessary for following links.
|
||
(goto-char point))
|
||
;; Figure out if the on screen keyboard needs to be
|
||
;; displayed.
|
||
(when command
|
||
(if (memq command touch-screen-set-point-commands)
|
||
(if touch-screen-translate-prompt
|
||
;; When a `mouse-set-point' command is
|
||
;; encountered and
|
||
;; `touch-screen-handle-touch' is being
|
||
;; called from the keyboard command loop,
|
||
;; call it immediately so that point is set
|
||
;; prior to the on screen keyboard being
|
||
;; displayed.
|
||
(call-interactively command nil
|
||
(vector event))
|
||
(if (and (or (not buffer-read-only)
|
||
touch-screen-display-keyboard)
|
||
;; Detect the splash screen and avoid
|
||
;; displaying the on screen keyboard
|
||
;; there.
|
||
(not (equal (buffer-name) "*GNU Emacs*")))
|
||
;; Once the on-screen keyboard has been
|
||
;; opened, add
|
||
;; `touch-screen-window-selection-changed'
|
||
;; as a window selection change function
|
||
;; This then prevents it from being hidden
|
||
;; after exiting the minibuffer.
|
||
(progn
|
||
(add-hook 'window-selection-change-functions
|
||
#'touch-screen-window-selection-changed)
|
||
(frame-toggle-on-screen-keyboard (selected-frame)
|
||
nil))
|
||
;; Otherwise, hide the on screen keyboard
|
||
;; now.
|
||
(frame-toggle-on-screen-keyboard (selected-frame) t))
|
||
;; But if it's being called from `describe-key'
|
||
;; or some such, return it as a key sequence.
|
||
(throw 'input-event event)))
|
||
;; If not, return the event.
|
||
(throw 'input-event event)))))
|
||
((eq what 'mouse-drag)
|
||
;; Generate a corresponding `mouse-1' event.
|
||
(let* ((new-window (posn-window posn))
|
||
(new-point (posn-point posn))
|
||
(old-posn (nth 4 touch-screen-current-tool))
|
||
(old-window (posn-window posn))
|
||
(old-point (posn-point posn)))
|
||
(throw 'input-event
|
||
;; If the position of the touch point hasn't
|
||
;; changed, or it doesn't start or end on a
|
||
;; window...
|
||
(if (and (not old-point) (not new-point))
|
||
;; Should old-point and new-point both equal
|
||
;; nil, compare the posn areas and nominal
|
||
;; column position. If either are different,
|
||
;; generate a drag event.
|
||
(let ((new-col-row (posn-col-row posn))
|
||
(new-area (posn-area posn))
|
||
(old-col-row (posn-col-row old-posn))
|
||
(old-area (posn-area old-posn)))
|
||
(if (and (equal new-col-row old-col-row)
|
||
(eq new-area old-area))
|
||
;; ... generate a mouse-1 event...
|
||
(list 'mouse-1 posn)
|
||
;; ... otherwise, generate a drag-mouse-1 event.
|
||
(list 'drag-mouse-1 (cons old-window
|
||
old-posn)
|
||
(cons new-window posn))))
|
||
(if (and (eq new-window old-window)
|
||
(eq new-point old-point)
|
||
(windowp new-window)
|
||
(windowp old-window))
|
||
;; ... generate a mouse-1 event...
|
||
(list 'mouse-1 posn)
|
||
;; ... otherwise, generate a drag-mouse-1 event.
|
||
(list 'drag-mouse-1 (cons old-window
|
||
old-posn)
|
||
(cons new-window posn)))))))
|
||
((eq what 'mouse-1-menu)
|
||
;; Generate a `down-mouse-1' event at the position the tap
|
||
;; took place.
|
||
(throw 'input-event
|
||
(list 'down-mouse-1
|
||
(nth 4 touch-screen-current-tool))))
|
||
((or (eq what 'drag)
|
||
;; Merely initiating a drag is sufficient to select a
|
||
;; word if word selection is enabled.
|
||
(eq what 'held))
|
||
;; Display the on screen keyboard if the region is now
|
||
;; active. Check this within the window where the tool was
|
||
;; first place.
|
||
(setq window (nth 1 touch-screen-current-tool))
|
||
(when window
|
||
(with-selected-window window
|
||
(when (and (region-active-p)
|
||
(not buffer-read-only))
|
||
;; Once the on-screen keyboard has been opened, add
|
||
;; `touch-screen-window-selection-changed' as a window
|
||
;; selection change function This then prevents it from
|
||
;; being hidden after exiting the minibuffer.
|
||
(progn
|
||
(add-hook 'window-selection-change-functions
|
||
#'touch-screen-window-selection-changed)
|
||
(frame-toggle-on-screen-keyboard (selected-frame)
|
||
nil)))))))))
|
||
|
||
(defun touch-screen-handle-touch (event prefix &optional interactive)
|
||
"Handle a single touch EVENT, and perform associated actions.
|
||
EVENT can either be a `touchscreen-begin', `touchscreen-update' or
|
||
`touchscreen-end' event.
|
||
PREFIX is either nil, or a symbol specifying a virtual function
|
||
key to apply to EVENT.
|
||
|
||
If INTERACTIVE, execute the command associated with any event
|
||
generated instead of throwing `input-event'. Otherwise, throw
|
||
`input-event' with a single input event if that event should take
|
||
the place of EVENT within the key sequence being translated, or
|
||
`nil' if all tools have been released."
|
||
(interactive "e\ni\np")
|
||
(if interactive
|
||
;; Called interactively (probably from wid-edit.el.)
|
||
;; Add any event generated to `unread-command-events'.
|
||
(let ((event1
|
||
(let ((current-key-remap-sequence (vector event)))
|
||
(touch-screen-translate-touch nil))))
|
||
(when (vectorp event1)
|
||
(setq unread-command-events
|
||
(nconc unread-command-events
|
||
(nreverse (append event1 nil))))))
|
||
(cond
|
||
((eq (car event) 'touchscreen-begin)
|
||
;; A tool was just pressed against the screen. Figure out the
|
||
;; window where it is and make it the tool being tracked on the
|
||
;; window.
|
||
(let* ((touchpoint (caadr event))
|
||
(position (cdadr event))
|
||
(window (posn-window position))
|
||
(point (posn-point position))
|
||
binding tool-list)
|
||
;; Cancel the touch screen timer, if it is still there by any
|
||
;; chance.
|
||
(when touch-screen-current-timer
|
||
(cancel-timer touch-screen-current-timer)
|
||
(setq touch-screen-current-timer nil))
|
||
;; Replace any previously ongoing gesture. If POSITION has no
|
||
;; window or position, make it nil instead.
|
||
(setq tool-list (and (windowp window)
|
||
(list touchpoint window
|
||
(posn-x-y position)
|
||
nil position
|
||
nil nil nil nil))
|
||
touch-screen-current-tool tool-list)
|
||
|
||
;; Select the window underneath the event as the checks below
|
||
;; will look up keymaps and markers inside its buffer.
|
||
(save-selected-window
|
||
;; Check if `touch-screen-extend-selection' is enabled, the
|
||
;; tap lies on the point or the mark, and the region is
|
||
;; active. If that's the case, set the fourth element of
|
||
;; `touch-screen-current-tool' to `restart-drag', then
|
||
;; generate a `touchscreen-restart-drag' event.
|
||
(when tool-list
|
||
;; tool-list is always non-nil where the selected window
|
||
;; matters.
|
||
(select-window window)
|
||
(when (and touch-screen-extend-selection
|
||
(or (eq point (point))
|
||
(eq point (mark)))
|
||
(region-active-p)
|
||
;; Only restart drag-to-select if the tap falls
|
||
;; on the same row as the selection. This
|
||
;; prevents dragging from starting if the tap
|
||
;; is below the last window line with text and
|
||
;; `point' is at ZV, as the user most likely
|
||
;; meant to scroll the window instead.
|
||
(when-let* ((posn-point (posn-at-point point))
|
||
(posn-row (cdr (posn-col-row posn-point))))
|
||
(eq (cdr (posn-col-row position)) posn-row)))
|
||
;; Indicate that a drag is about to restart.
|
||
(setcar (nthcdr 3 tool-list) 'restart-drag)
|
||
;; Generate the `restart-drag' event.
|
||
(throw 'input-event (list 'touchscreen-restart-drag
|
||
position))))
|
||
;; Determine if there is a command bound to `down-mouse-1'
|
||
;; at the position of the tap and that command is not a
|
||
;; command whose functionality is replaced by the long-press
|
||
;; mechanism. If so, set the fourth element of
|
||
;; `touch-screen-current-tool' to `mouse-drag' and generate
|
||
;; an emulated `mouse-1' event.
|
||
;;
|
||
;; If the command in question is a keymap, set that element
|
||
;; to `mouse-1-menu' instead of `mouse-drag', and don't
|
||
;; generate a `down-mouse-1' event immediately. Instead,
|
||
;; wait for the touch point to be released.
|
||
(if (and tool-list
|
||
(and (setq binding
|
||
(key-binding (if prefix
|
||
(vector prefix
|
||
'down-mouse-1)
|
||
[down-mouse-1])
|
||
t nil position))
|
||
(not (and (symbolp binding)
|
||
(get binding 'ignored-mouse-command)))))
|
||
(if (or (keymapp binding)
|
||
(and (symbolp binding)
|
||
(get binding 'mouse-1-menu-command)))
|
||
;; binding is a keymap, or a command that does
|
||
;; almost the same thing. If a `mouse-1' event is
|
||
;; generated after the keyboard command loop
|
||
;; displays it as a menu, that event could cause
|
||
;; unwanted commands to be run. Set what to
|
||
;; `mouse-1-menu' instead and wait for the up event
|
||
;; to display the menu.
|
||
(setcar (nthcdr 3 tool-list) 'mouse-1-menu)
|
||
(progn (setcar (nthcdr 3 tool-list) 'mouse-drag)
|
||
(throw 'input-event (list 'down-mouse-1 position))))
|
||
(and point
|
||
;; Start the long-press timer.
|
||
(touch-screen-handle-timeout nil))))))
|
||
((eq (car event) 'touchscreen-update)
|
||
(unless touch-screen-current-tool
|
||
;; If a stray touchscreen-update event arrives (most likely
|
||
;; from the menu bar), stop translating this sequence.
|
||
(throw 'input-event nil))
|
||
;; The positions of tools currently pressed against the screen
|
||
;; have changed. If there is a tool being tracked as part of a
|
||
;; gesture, look it up in the list of tools.
|
||
(let ((new-point (assq (car touch-screen-current-tool)
|
||
(cadr event))))
|
||
(when new-point
|
||
(touch-screen-handle-point-update new-point))))
|
||
((eq (car event) 'touchscreen-end)
|
||
;; A tool has been removed from the screen. If it is the tool
|
||
;; currently being tracked, clear `touch-screen-current-tool'.
|
||
(when (eq (caadr event) (car touch-screen-current-tool))
|
||
;; Cancel the touch screen long-press timer, if it is still
|
||
;; there by any chance.
|
||
(when touch-screen-current-timer
|
||
(cancel-timer touch-screen-current-timer)
|
||
(setq touch-screen-current-timer nil))
|
||
(unwind-protect
|
||
;; Don't perform any actions associated with releasing the
|
||
;; tool if the touch sequence was intercepted by another
|
||
;; program.
|
||
(unless (caddr event)
|
||
(touch-screen-handle-point-up (cadr event) prefix))
|
||
;; Make sure the tool list is cleared even if
|
||
;; `touch-screen-handle-point-up' throws.
|
||
(setq touch-screen-current-tool nil)))
|
||
;; Throw to the key translation function.
|
||
(throw 'input-event nil)))))
|
||
|
||
;; Mark `mouse-drag-region' as ignored for the purposes of mouse click
|
||
;; emulation.
|
||
|
||
(put 'mouse-drag-region 'ignored-mouse-command t)
|
||
|
||
(defun touch-screen-translate-touch (prompt)
|
||
"Translate touch screen events into a sequence of mouse events.
|
||
PROMPT is the prompt string given to `read-key-sequence', or nil
|
||
if this function is being called from the keyboard command loop.
|
||
Value is a new key sequence.
|
||
|
||
Read the touch screen event within `current-key-remap-sequence'
|
||
and give it to `touch-screen-handle-touch'. Return any key
|
||
sequence signaled.
|
||
|
||
If `touch-screen-handle-touch' does not signal for an event to be
|
||
returned after the last element of the key sequence is read,
|
||
continue reading touch screen events until
|
||
`touch-screen-handle-touch' signals. Return a sequence
|
||
consisting of the first event encountered that is not a touch
|
||
screen event.
|
||
|
||
In addition to non-touchscreen events read, key sequences
|
||
returned may contain any one of the following events:
|
||
|
||
(touchscreen-scroll WINDOW DX DY)
|
||
|
||
where WINDOW specifies a window to scroll, and DX and DY are
|
||
integers describing how many pixels to be scrolled horizontally
|
||
and vertically,
|
||
|
||
(touchscreen-hold POSN)
|
||
(touchscreen-drag POSN)
|
||
|
||
where POSN is the position of the long-press or touchpoint
|
||
motion,
|
||
|
||
(touchscreen-restart-drag POSN)
|
||
|
||
where POSN is the position of the tap,
|
||
|
||
(down-mouse-1 POSN)
|
||
(drag-mouse-1 POSN)
|
||
|
||
where POSN is the position of the mouse button press or click,
|
||
|
||
(mouse-1 POSN)
|
||
(mouse-2 POSN)
|
||
|
||
where POSN is the position of the mouse click, either `mouse-2'
|
||
if POSN is on a link or a button, or `mouse-1' otherwise."
|
||
(unwind-protect
|
||
;; Save the virtual function key if this is a mode line event.
|
||
(let* ((prefix-specified
|
||
;; Virtual prefix keys can be nil for events that fall
|
||
;; outside a frame or within its internal border.
|
||
(> (length current-key-remap-sequence) 1))
|
||
(prefix (and prefix-specified
|
||
(aref current-key-remap-sequence 0)))
|
||
(touch-screen-translate-prompt prompt)
|
||
(event (catch 'input-event
|
||
;; First, process the one event already within
|
||
;; `current-key-remap-sequence'.
|
||
(touch-screen-handle-touch
|
||
(aref current-key-remap-sequence
|
||
(if prefix-specified 1 0))
|
||
prefix)
|
||
;; Next, continue reading input events.
|
||
(while t
|
||
(let ((event1 (read-event)))
|
||
;; If event1 is a virtual function key, make
|
||
;; it the new prefix.
|
||
(if (memq event1 '(mode-line tab-line nil
|
||
vertical-line
|
||
header-line tool-bar tab-bar
|
||
left-fringe right-fringe
|
||
left-margin right-margin
|
||
right-divider bottom-divider))
|
||
(setq prefix event1)
|
||
;; If event1 is not a touch screen event,
|
||
;; return it.
|
||
(if (not (memq (car-safe event1)
|
||
'(touchscreen-begin
|
||
touchscreen-end
|
||
touchscreen-update)))
|
||
(throw 'input-event event1)
|
||
;; Process this event as well.
|
||
(touch-screen-handle-touch event1 prefix))))))))
|
||
;; Return a key sequence consisting of event
|
||
;; or an empty vector if it is nil, meaning that
|
||
;; no key events have been translated.
|
||
(if event (or (and prefix (consp event)
|
||
;; Only generate virtual function keys for
|
||
;; mouse events.
|
||
(memq (car event)
|
||
'(down-mouse-1 mouse-1
|
||
mouse-2 mouse-movement))
|
||
;; If this is a mode line event, then
|
||
;; generate the appropriate function key.
|
||
(vector prefix event))
|
||
(vector event))
|
||
""))
|
||
;; Cancel the touch screen long-press timer, if it is still there
|
||
;; by any chance. If the timer is to operate correctly, it must
|
||
;; fire within the catch block above.
|
||
(when touch-screen-current-timer
|
||
(cancel-timer touch-screen-current-timer)
|
||
(setq touch-screen-current-timer nil))))
|
||
|
||
(define-key function-key-map [touchscreen-begin]
|
||
#'touch-screen-translate-touch)
|
||
(define-key function-key-map [touchscreen-update]
|
||
#'touch-screen-translate-touch)
|
||
(define-key function-key-map [touchscreen-end]
|
||
#'touch-screen-translate-touch)
|
||
|
||
(define-key function-key-map [mode-line touchscreen-begin]
|
||
#'touch-screen-translate-touch)
|
||
(define-key function-key-map [mode-line touchscreen-end]
|
||
#'touch-screen-translate-touch)
|
||
|
||
;; These are used to translate events sent from the internal border or
|
||
;; from outside the frame.
|
||
|
||
(define-key function-key-map [nil touchscreen-begin]
|
||
#'touch-screen-translate-touch)
|
||
(define-key function-key-map [nil touchscreen-end]
|
||
#'touch-screen-translate-touch)
|
||
|
||
(define-key function-key-map [header-line touchscreen-begin]
|
||
#'touch-screen-translate-touch)
|
||
(define-key function-key-map [header-line touchscreen-end]
|
||
#'touch-screen-translate-touch)
|
||
|
||
(define-key function-key-map [bottom-divider touchscreen-begin]
|
||
#'touch-screen-translate-touch)
|
||
(define-key function-key-map [bottom-divider touchscreen-end]
|
||
#'touch-screen-translate-touch)
|
||
|
||
(define-key function-key-map [right-divider touchscreen-begin]
|
||
#'touch-screen-translate-touch)
|
||
(define-key function-key-map [right-divider touchscreen-end]
|
||
#'touch-screen-translate-touch)
|
||
|
||
(define-key function-key-map [right-divider touchscreen-begin]
|
||
#'touch-screen-translate-touch)
|
||
(define-key function-key-map [right-divider touchscreen-end]
|
||
#'touch-screen-translate-touch)
|
||
|
||
(define-key function-key-map [left-fringe touchscreen-begin]
|
||
#'touch-screen-translate-touch)
|
||
(define-key function-key-map [left-fringe touchscreen-end]
|
||
#'touch-screen-translate-touch)
|
||
|
||
(define-key function-key-map [right-fringe touchscreen-begin]
|
||
#'touch-screen-translate-touch)
|
||
(define-key function-key-map [right-fringe touchscreen-end]
|
||
#'touch-screen-translate-touch)
|
||
|
||
(define-key function-key-map [left-margin touchscreen-begin]
|
||
#'touch-screen-translate-touch)
|
||
(define-key function-key-map [left-margin touchscreen-end]
|
||
#'touch-screen-translate-touch)
|
||
|
||
(define-key function-key-map [right-margin touchscreen-begin]
|
||
#'touch-screen-translate-touch)
|
||
(define-key function-key-map [right-margin touchscreen-end]
|
||
#'touch-screen-translate-touch)
|
||
|
||
(define-key function-key-map [tool-bar touchscreen-begin]
|
||
#'touch-screen-translate-touch)
|
||
(define-key function-key-map [tool-bar touchscreen-end]
|
||
#'touch-screen-translate-touch)
|
||
|
||
(define-key function-key-map [tab-bar touchscreen-begin]
|
||
#'touch-screen-translate-touch)
|
||
(define-key function-key-map [tab-bar touchscreen-end]
|
||
#'touch-screen-translate-touch)
|
||
|
||
(define-key function-key-map [tab-line touchscreen-begin]
|
||
#'touch-screen-translate-touch)
|
||
(define-key function-key-map [tab-line touchscreen-end]
|
||
#'touch-screen-translate-touch)
|
||
|
||
(define-key function-key-map [vertical-line touchscreen-begin]
|
||
#'touch-screen-translate-touch)
|
||
(define-key function-key-map [vertical-line touchscreen-end]
|
||
#'touch-screen-translate-touch)
|
||
|
||
(define-key function-key-map [nil touchscreen-begin]
|
||
#'touch-screen-translate-touch)
|
||
(define-key function-key-map [nil touchscreen-end]
|
||
#'touch-screen-translate-touch)
|
||
|
||
|
||
;; Exports. These functions are intended for use externally.
|
||
|
||
(defun touch-screen-track-tap (event &optional update data)
|
||
"Track a single tap starting from EVENT.
|
||
EVENT should be a `touchscreen-begin' event.
|
||
|
||
Read touch screen events until a `touchscreen-end' event is
|
||
received with the same ID as in EVENT. If UPDATE is non-nil and
|
||
a `touchscreen-update' event is received in the mean time and
|
||
contains a touch point with the same ID as in EVENT, call UPDATE
|
||
with that event and DATA.
|
||
|
||
Return nil immediately if any other kind of event is received;
|
||
otherwise, return t once the `touchscreen-end' event arrives."
|
||
(let ((disable-inhibit-text-conversion t))
|
||
(catch 'finish
|
||
(while t
|
||
(let ((new-event (read-event nil)))
|
||
(cond
|
||
((eq (car-safe new-event) 'touchscreen-update)
|
||
(when (and update (assq (caadr event) (cadr new-event)))
|
||
(funcall update new-event data)))
|
||
((eq (car-safe new-event) 'touchscreen-end)
|
||
(throw 'finish
|
||
;; Now determine whether or not the `touchscreen-end'
|
||
;; event has the same ID as EVENT. If it doesn't,
|
||
;; then this is another touch, so return nil.
|
||
(eq (caadr event) (caadr new-event))))
|
||
(t (throw 'finish nil))))))))
|
||
|
||
(defun touch-screen-track-drag (event update &optional data)
|
||
"Track a single drag starting from EVENT.
|
||
EVENT should be a `touchscreen-begin' event.
|
||
|
||
Read touch screen events until a `touchscreen-end' event is
|
||
received with the same ID as in EVENT. For each
|
||
`touchscreen-update' event received in the mean time containing a
|
||
touch point with the same ID as in EVENT, call UPDATE with the
|
||
touch point in event and DATA, once the touch point has moved
|
||
significantly by at least 5 pixels from where it was in EVENT.
|
||
|
||
Return nil immediately if any other kind of event is received;
|
||
otherwise, return either t or `no-drag' once the
|
||
`touchscreen-end' event arrives; return `no-drag' returned if the
|
||
touch point in EVENT did not move significantly, and t otherwise."
|
||
(let ((return-value 'no-drag)
|
||
(start-xy (touch-screen-relative-xy (cdadr event)
|
||
'frame))
|
||
(disable-inhibit-text-conversion t))
|
||
(catch 'finish
|
||
(while t
|
||
(let ((new-event (read-event nil)))
|
||
(cond
|
||
((eq (car-safe new-event) 'touchscreen-update)
|
||
(when-let* ((tool (assq (caadr event) (nth 1 new-event)))
|
||
(xy (touch-screen-relative-xy (cdr tool) 'frame)))
|
||
(when (or (> (- (car xy) (car start-xy)) 5)
|
||
(< (- (car xy) (car start-xy)) -5)
|
||
(> (- (cdr xy) (cdr start-xy)) 5)
|
||
(< (- (cdr xy) (cdr start-xy)) -5))
|
||
(setq return-value t))
|
||
(when (and update tool (eq return-value t))
|
||
(funcall update new-event data))))
|
||
((eq (car-safe new-event) 'touchscreen-end)
|
||
(throw 'finish
|
||
;; Now determine whether or not the `touchscreen-end'
|
||
;; event has the same ID as EVENT. If it doesn't,
|
||
;; then this is another touch, so return nil.
|
||
(and (eq (caadr event) (caadr new-event))
|
||
return-value)))
|
||
(t (throw 'finish nil))))))))
|
||
|
||
|
||
|
||
;;; Event handling exports. These functions are intended for use by
|
||
;;; Lisp commands bound to touch screen gesture events.
|
||
|
||
(defun touch-screen-inhibit-drag ()
|
||
"Inhibit subsequent `touchscreen-drag' events from being sent.
|
||
Prevent `touchscreen-drag' and translated mouse events from being
|
||
sent until the touch sequence currently being translated ends.
|
||
Must be called from a command bound to a `touchscreen-hold' or
|
||
`touchscreen-drag' event."
|
||
(let* ((tool touch-screen-current-tool)
|
||
(current-what (nth 4 tool)))
|
||
;; Signal an error if no hold or drag is in progress.
|
||
(when (and (not (eq current-what 'hold)
|
||
(eq current-what 'drag)))
|
||
(error "Calling `touch-screen-inhibit-drag' outside hold or drag"))
|
||
;; Now set the fourth element of tool to `command-inhibit'.
|
||
(setcar (nthcdr 3 tool) 'command-inhibit)))
|
||
|
||
|
||
|
||
(provide 'touch-screen)
|
||
|
||
;;; touch-screen ends here
|