noe/arthur
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Pan with trackpad scrolling and zoom with pinch gestures

Browse source
This commit is contained in:
Olive Vaughn 2026-10-04 00:44:47 -04:00
parent 484b4f1698
commit 6df315b73d
1 changed files with 40 additions and 12 deletions
Download patch file Download diff file Expand all files Collapse all files

52
frontend/src/arthur/ui/stage.cljs
View file

@ -648,24 +648,52 @@
(.addEventListener js/window "keyup" #(when (= "Space" (.-code %)) (reset! space-held? false)))
(.addEventListener js/window "blur" #(do (reset! space-held? false) (reset! pan nil)))))
(defonce pinch-start-zoom (atom nil))
(defn- zoom-at! [el client-x client-y scale]
(let [z @(rf/subscribe [::layout/zoom :stage])
wrap (.querySelector el ".stage-wrap")
wb (.getBoundingClientRect wrap)
x (- client-x (.-left wb)) y (- client-y (.-top wb))
next (max 0.1 (min 16 scale))]
(rf/dispatch-sync [::layout/set :stage next])
(js/requestAnimationFrame
(fn []
(let [nb (.getBoundingClientRect wrap)]
(set! (.-scrollLeft el) (+ (.-scrollLeft el) (- (+ (.-left nb) (* x (/ next z))) client-x)))
(set! (.-scrollTop el) (+ (.-scrollTop el) (- (+ (.-top nb) (* y (/ next z))) client-y))))))))
(defn- navigation []
{:title "Wheel to zoom · Space-drag or middle-drag to pan"
{:title "Two-finger scroll to pan · Pinch or ⌘/Ctrl-wheel to zoom · Space-drag or middle-drag to pan"
:ref (fn [el]
(when el
(set! (.-onwheel el)
(fn [e]
(.preventDefault e)
(let [z @(rf/subscribe [::layout/zoom :stage])
wrap (.querySelector el ".stage-wrap")
wb (.getBoundingClientRect wrap)
x (- (.-clientX e) (.-left wb)) y (- (.-clientY e) (.-top wb))
next (max 0.1 (min 16 (* z (js/Math.exp (* -0.002 (.-deltaY e))))))]
(rf/dispatch-sync [::layout/set :stage next])
(js/requestAnimationFrame
(fn []
(let [nb (.getBoundingClientRect wrap)]
(set! (.-scrollLeft el) (+ (.-scrollLeft el) (- (+ (.-left nb) (* x (/ next z))) (.-clientX e))))
(set! (.-scrollTop el) (+ (.-scrollTop el) (- (+ (.-top nb) (* y (/ next z))) (.-clientY e)))))))))))
;; Chromium and Firefox deliver trackpad pinch as Ctrl-wheel.
;; Ordinary scrolling pans without guessing the input device.
(when-not @pinch-start-zoom
(let [unit (case (.-deltaMode e) 1 16 2 (.-clientHeight el) 1)
dx (* unit (.-deltaX e)) dy (* unit (.-deltaY e))]
(if (or (.-ctrlKey e) (.-metaKey e))
(zoom-at! el (.-clientX e) (.-clientY e)
(* @(rf/subscribe [::layout/zoom :stage])
(js/Math.exp (* (if (.-ctrlKey e) -0.01 -0.002) dy))))
(do
(set! (.-scrollLeft el) (+ (.-scrollLeft el) dx))
(set! (.-scrollTop el) (+ (.-scrollTop el) dy))))))))
;; Safari exposes pinch as GestureEvents, with cumulative scale.
(set! (.-ongesturestart el)
(fn [e]
(.preventDefault e)
(reset! pinch-start-zoom @(rf/subscribe [::layout/zoom :stage]))))
(set! (.-ongesturechange el)
(fn [e]
(.preventDefault e)
(when-let [z @pinch-start-zoom]
(zoom-at! el (.-clientX e) (.-clientY e) (* z (.-scale e))))))
(set! (.-ongestureend el)
(fn [e] (.preventDefault e) (reset! pinch-start-zoom nil))))
nil)
:on-pointer-down-capture
(fn [e] (when (or (= 1 (.-button e)) (and (= 0 (.-button e)) @space-held?))