;;; my-vertico-touch.el ---                          -*- lexical-binding: t; -*-

;; 使い方:
;; (with-eval-after-load 'vertico
;;   (require 'my-vertico-touch)
;;   (my-vertico-touch-setup)

(require 'vertico)
(require 'vertico-mouse)

(defconst my-vertico-touch-tap-threshold 4)

(defun my-vertico-touchscreen-begin (begin-event)
  (interactive "e")
  (let* ((begin-posn (cdadr begin-event))
         (begin-xy (posn-x-y begin-posn))
         (begin-window (posn-window begin-posn))
         (moved nil))
    (with-selected-window begin-window
      (let ((begin-scroll-pos vertico--scroll))
        (while
            (let ((ev (read-event)))
              (pcase (car-safe ev)
                ('touchscreen-update
                 (let* ((update-xy (touch-screen-relative-xy (cdaadr ev)
                                                             begin-window))
                        (dx (- (car update-xy) (car begin-xy)))
                        (dy (- (cdr update-xy) (cdr begin-xy))))
                   (when (and (not moved)
                              (>= (+ (* dx dx) (* dy dy))
                                  (* my-vertico-touch-tap-threshold
                                     my-vertico-touch-tap-threshold)))
                     (setq moved t))
                   (when moved
                     (let* ((dline (/ dy (default-line-height)))
                            (new-scroll-pos (- begin-scroll-pos dline)))
                       (cond
                        ((< new-scroll-pos vertico--scroll)
                         (vertico--goto (+ new-scroll-pos vertico-scroll-margin)))
                        ((> new-scroll-pos vertico--scroll)
                         (vertico--goto (+ new-scroll-pos vertico-count
                                           (- vertico-scroll-margin))))))
                     (vertico--exhibit)))
                 t)
                ('touchscreen-end
                 (unless moved
                   (vertico--goto (vertico-mouse--index begin-event))
                   (vertico-exit))
                 nil))))))))

(defun my-vertico-touch-setup ()
  (interactive)
  (vertico-mouse-mode)
  (define-key vertico-mouse-map (kbd "<touchscreen-begin>")
              #'my-vertico-touchscreen-begin))

(defun my-vertico-touch-teardown ()
  (interactive)
  (define-key vertico-mouse-map (kbd "<touchscreen-begin>")
              #'my-vertico-touchscreen-begin
              t))

(provide 'my-vertico-touch)

;;; my-corfu-touch.el ---                            -*- lexical-binding: t; -*-

;; 使い方:
;; (with-eval-after-load "corfu"
;;   (require 'my-corfu-touch)
;;   (my-corfu-touch-setup))

(require 'corfu)

;;;; Frame Handling

(defun my-corfu-defocus-child-frame ()
  "corfu用の子フレームからフォーカスを外す。"
  (when (eq (selected-frame) corfu--frame)
    (when-let* ((parent (frame-parent)))
      (select-frame parent))))

(defun my-corfu-handle-switch-frame-p ()
  "フレームの変更処理中なら非nilを返す。
`this-command'と`last-input-event'によって判定される。

`this-command'が`handle-switch-frame'であり、かつ、`last-input-event'が
corfu用の子フレームに対する`switch-frame'イベントであれば、非nilを返し、
そうでなければnilを返す。"
  (and (eq this-command 'handle-switch-frame)
       (eq (car-safe last-input-event) 'switch-frame)
       (eq (cadr last-input-event) corfu--frame)))

;; 子フレームがクリック/タップされたとき、`switch-frame'イベントが発生
;; し`handle-switch-frame'コマンドが実行される。また、その前後でwindow
;; 変更を通知するフックも呼び出される(クリックかタップかによって微妙に
;; 順番は変わる?)。
;;
;; それらのタイミングのどこかでフォーカスの変更が行われるので、
;; `my-corfu-defocus-child-frame'を呼び出して元の親フレームがフォーカス
;; されている状態を維持する必要がある(`switch-frame'の効果を打ち消す)。
;;
;; また、`handle-switch-frame'コマンドによってcorfuが終了してしまうこ
;; とがあるので、それも防止する必要がある。基本的にcorfuの候補表示フレー
;; ム(`corfu--frame')に対する`handle-switch-frame'は無視した方が良い。

(defun my-corfu--post-command:around (old-fun &rest args)
  (my-corfu-defocus-child-frame)

  (unless (my-corfu-handle-switch-frame-p)
    (apply old-fun args)))

(defun my-corfu--prepare:around (old-fun &rest args) ;; pre-command-hook
  (unless (my-corfu-handle-switch-frame-p)
    (apply old-fun args)))

(defun my-corfu--window-change:around (old-fun &rest args)
  ;; 注意: タッチイベントの時はhandle-switch-frameよりも先にここに来る。
  ;;       クリックの時は先にhandle-switch-frameが発生するのでこれは不要。
  (my-corfu-defocus-child-frame)
  (apply old-fun args))

;;;; Candidate List

(defun my-corfu-select (index)
  (corfu--goto index)
  (corfu-insert))

(defun my-corfu-posn-line-number (posn)
  (with-current-buffer (window-buffer (posn-window posn))
    (line-number-at-pos (posn-point posn) t)))

(defun my-corfu-posn-index (posn)
  (+ corfu--scroll (my-corfu-posn-line-number posn) -1))

(defun my-corfu-select-clicked (event)
  (interactive "e")
  (my-corfu-select (my-corfu-posn-index (event-start event))))

(defun my-corfu-set-scroll-pos (new-scroll-pos)
  (cond
   ((< new-scroll-pos corfu--scroll)
    (corfu--goto (+ new-scroll-pos corfu-scroll-margin)))
   ((> new-scroll-pos corfu--scroll)
    (corfu--goto (+ new-scroll-pos corfu-count
                    (- corfu-scroll-margin))))))

;;;; Mouse / Touch Event Handlers

(defun my-corfu-on-mouse-1 (event)
  (interactive "e")
  (my-corfu-select-clicked event))

(defconst my-corfu-touch-tap-threshold 4)

(defun my-corfu-on-touchscreen-begin (begin-event)
  (interactive "e")
  (let* ((begin-posn (cdadr begin-event))
         (begin-window (posn-window begin-posn))
         (begin-xy (posn-x-y begin-posn))
         (moved nil))
    (with-selected-window begin-window
      (let ((begin-scroll-pos corfu--scroll)
            (echo-keystrokes 0))
        (while
            (let ((ev (read-event)))
              (pcase (car-safe ev)
                ('touchscreen-update
                 (let* ((update-xy (touch-screen-relative-xy (cdaadr ev) begin-window))
                        (dx (- (car update-xy) (car begin-xy)))
                        (dy (- (cdr update-xy) (cdr begin-xy))))
                   (when (and (not moved)
                              (>= (+ (* dx dx) (* dy dy))
                                  (* my-corfu-touch-tap-threshold
                                     my-corfu-touch-tap-threshold)))
                     (setq moved t))
                   (when moved
                     (let* ((dline (/ dy (default-line-height)))
                            (new-scroll-pos (- begin-scroll-pos dline)))
                       (my-corfu-set-scroll-pos new-scroll-pos))
                     (corfu--exhibit)))
                 t)
                ('touchscreen-end
                 (unless moved
                   (my-corfu-select (my-corfu-posn-index (cdadr begin-event))))
                 nil))))))))

;;;; Setup

(defun my-corfu-touch-setup ()
  (interactive)

  ;; pre-command-hook、post-command-hook、ウィンドウ切り替え時の処理を修正する。
  (advice-add 'corfu--post-command :around 'my-corfu--post-command:around)
  (advice-add 'corfu--prepare :around 'my-corfu--prepare:around)
  (advice-add 'corfu--window-change :around 'my-corfu--window-change:around)

  ;; マウスを無視するためのキーマップにマウスやタッチのイベントハンドラを
  ;; 登録してしまう。
  (push 'my-corfu-on-mouse-1 corfu-continue-commands)
  (push 'my-corfu-on-touchscreen-begin corfu-continue-commands)
  (define-key corfu--mouse-ignore-map
              [mouse-1] #'my-corfu-on-mouse-1)
  (define-key corfu--mouse-ignore-map
              [touchscreen-begin] #'my-corfu-on-touchscreen-begin)

  ;; 子フレームにフォーカスが当たるようにする。
  ;; そうしないとイベントが起きないので。
  (setf (alist-get 'no-accept-focus corfu--frame-parameters) nil))

(provide 'my-corfu-touch)