604 lines
24 KiB
Clojure
604 lines
24 KiB
Clojure
(ns arthur.events.ui
|
|
"Selection, the active tone, the polygon being drawn, and which timeline rows
|
|
are open.
|
|
|
|
All of it is `assoc-in` under `:ui`. There is no effect in this namespace and
|
|
there should not be one: an editor's own state is the cheapest thing in the
|
|
app to change and the most expensive to have two copies of."
|
|
(:require [arthur.domain.clip :as clip]
|
|
[arthur.domain.correction :as correction]
|
|
[arthur.domain.gesture :as gesture]
|
|
[arthur.domain.nest :as nest]
|
|
[arthur.domain.node :as node]
|
|
[arthur.domain.lane :as lane]
|
|
[arthur.events.edit :as edit]
|
|
[arthur.events.paint :as paint]
|
|
[arthur.events.playback :as playback]
|
|
[arthur.footage.store :as store]
|
|
[re-frame.core :as rf]))
|
|
|
|
(rf/reg-event-db
|
|
::select
|
|
;; The rows above a selection are opened, so one made deep on the stage is
|
|
;; seen in the timeline. Not a sound's: its row is always in the audio section,
|
|
;; and opening the placement it is heard through would bury it.
|
|
(fn [db [_ selection]]
|
|
(let [[kind sid id path] selection
|
|
sound? (= :audio (get-in (store/entry (:clip/current db))
|
|
[:clip :symbols sid :nodes id :kind]))]
|
|
(cond-> (-> db
|
|
(assoc-in [:ui :selection] selection)
|
|
(update :ui dissoc :points :lane-retry))
|
|
(and (= :node kind) path (not sound?))
|
|
(update-in [:ui :expanded] (fnil into #{}) (rest (reductions conj [] (pop path))))))))
|
|
|
|
(rf/reg-event-db
|
|
::set-tone
|
|
(fn [db [_ tone]] (assoc-in db [:ui :tone] tone)))
|
|
|
|
(rf/reg-event-db
|
|
::set-time-view
|
|
(fn [db [_ view]]
|
|
(if (#{:timeline :cel-sheet} view)
|
|
(assoc-in db [:ui :time-view] view)
|
|
db)))
|
|
|
|
(defn apply-lane-command
|
|
"Commit a successful domain command as one history step. A refused command
|
|
leaves the document and history untouched; an overflow offers an explicit retry."
|
|
[db sid result retry]
|
|
(if-let [why (:refused result)]
|
|
(-> db
|
|
(assoc-in [:project :status] why)
|
|
(assoc-in [:ui :lane-retry]
|
|
(when (:required-frames result) retry)))
|
|
(let [[_ selected-sid _ path] (get-in db [:ui :selection])
|
|
prefix (if (and (= sid selected-sid) (seq path)) (pop path) [])]
|
|
(-> db
|
|
(edit/transaction (constantly (:clip result)))
|
|
(assoc-in [:ui :selection] [:node sid (:selection result) (conj prefix (:selection result))])
|
|
(update :ui dissoc :lane-retry)))))
|
|
|
|
(defn apply-correction-command
|
|
"Commit one correction command while keeping the complete row address that
|
|
selected its owner. A refusal changes only the visible status."
|
|
[db result]
|
|
(if-let [why (:refused result)]
|
|
(assoc-in db [:project :status] why)
|
|
(-> db
|
|
(edit/transaction (constantly (:clip result)))
|
|
(update :project merge {:status "edited · unsaved"}))))
|
|
|
|
(rf/reg-event-db
|
|
::add-correction
|
|
(fn [db [_ sid id path spec]]
|
|
(let [clip (:clip (store/entry (:clip/current db)))]
|
|
(apply-correction-command
|
|
db (correction/add clip sid id path (assoc spec :id (random-uuid)))))))
|
|
|
|
(rf/reg-event-db
|
|
::remove-correction
|
|
(fn [db [_ sid id path layer-id]]
|
|
(let [clip (:clip (store/entry (:clip/current db)))]
|
|
(apply-correction-command
|
|
db (correction/remove-layer clip sid id path layer-id)))))
|
|
|
|
(rf/reg-event-db
|
|
::retry-correction
|
|
(fn [db [_ sid id path layer-id]]
|
|
(let [clip (:clip (store/entry (:clip/current db)))]
|
|
(apply-correction-command
|
|
db (correction/retry-layer clip sid id path layer-id)))))
|
|
|
|
(rf/reg-event-db
|
|
::new-lane
|
|
(fn [db _]
|
|
(let [clip (:clip (store/entry (:clip/current db)))
|
|
sid (get-in db [:ui :open])]
|
|
(apply-lane-command db sid (lane/add-lane clip sid (random-uuid)) nil))))
|
|
|
|
(defn- committed
|
|
"One appending command, as effects: commit it, and look at what it made.
|
|
|
|
Seeking is the whole reason these are `-fx` events. An appended cel lands
|
|
past the end of the lane, off the playhead, and a drawing you cannot see is not
|
|
one you can draw in. An inserted one is already under the playhead and the
|
|
seek is a no-op, which is the same rule and not a second one."
|
|
[db sid result retry]
|
|
(let [{clip :clip st :store} (store/entry (:clip/current db))
|
|
path (nth (get-in db [:ui :selection]) 3 nil)
|
|
{:keys [at rate]} (:time (nest/inside clip st (get-in db [:ui :open])
|
|
(if (seq path) (pop path) [])
|
|
(get-in db [:playback :frame])))]
|
|
(cond-> {:db (apply-lane-command db sid result retry)}
|
|
(and (:clip result) (:frame result) rate)
|
|
(assoc :dispatch [::playback/seek (+ at (/ (:frame result) rate))]))))
|
|
|
|
(defn- selected-lane
|
|
"The lane a command should act in: the selected lane itself, or the one
|
|
holding the selected cel."
|
|
[clip sid id]
|
|
(let [n (get-in clip [:symbols sid :nodes id])]
|
|
(if (node/lane? n) id (:parent n))))
|
|
|
|
(defn selection-frame
|
|
"The playhead as a frame of the symbol that owns `selection`.
|
|
|
|
A timeline selection carries its path from the open symbol. Walking to the
|
|
parent of the selected node crosses every enclosing instance clock before a
|
|
lane command converts that owning-symbol frame into lane time."
|
|
[clip st open selection frame]
|
|
(let [[_ sid _ path] selection]
|
|
(if (or (= sid open) (not (seq path)))
|
|
frame
|
|
(:frame (nest/inside clip st open (pop path) frame)))))
|
|
|
|
(rf/reg-event-fx
|
|
::append-drawing
|
|
(fn [{:keys [db]} [_ extent]]
|
|
(let [clip (:clip (store/entry (:clip/current db)))
|
|
[_ sid id] (get-in db [:ui :selection])
|
|
result (lane/append-drawing clip sid (selected-lane clip sid id)
|
|
(random-uuid) (clip/fresh-id clip)
|
|
{:extent (or extent :keep)})]
|
|
(committed db sid result [::append-drawing :grow-symbol]))))
|
|
|
|
(rf/reg-event-fx
|
|
::reuse-drawing
|
|
(fn [{:keys [db]} [_ extent]]
|
|
(let [clip (:clip (store/entry (:clip/current db)))
|
|
[_ sid id] (get-in db [:ui :selection])
|
|
result (lane/reuse-drawing clip sid (selected-lane clip sid id) (random-uuid)
|
|
(node/source (get-in clip [:symbols sid :nodes id]))
|
|
{:extent (or extent :keep)})]
|
|
(committed db sid result [::reuse-drawing :grow-symbol]))))
|
|
|
|
(rf/reg-event-fx
|
|
::duplicate-drawing
|
|
(fn [{:keys [db]} [_ extent deep?]]
|
|
(let [clip (:clip (store/entry (:clip/current db)))
|
|
[_ sid id] (get-in db [:ui :selection])
|
|
result (lane/duplicate-drawing clip sid id (random-uuid)
|
|
{:extent (or extent :keep) :deep? deep?})]
|
|
(committed db sid result [::duplicate-drawing :grow-symbol deep?]))))
|
|
|
|
(rf/reg-event-fx
|
|
::insert-drawing
|
|
;; The playhead is the position: you scrub to where the drawing goes. A lane
|
|
;; that is stepped or retimed off whole frames has no single lane frame for a
|
|
;; symbol frame, and `lane-frame` says so rather than snapping to one.
|
|
(fn [{:keys [db]} [_ extent]]
|
|
(let [{clip :clip st :store} (store/entry (:clip/current db))
|
|
selection (get-in db [:ui :selection])
|
|
[_ sid id] selection
|
|
lane (selected-lane clip sid id)
|
|
owner-frame (selection-frame clip st (get-in db [:ui :open]) selection
|
|
(get-in db [:playback :frame]))
|
|
at (when (number? owner-frame) (lane/lane-frame clip sid lane owner-frame))
|
|
result (if at
|
|
(lane/append-drawing clip sid lane (random-uuid) (clip/fresh-id clip)
|
|
{:at at :extent (or extent :keep)})
|
|
{:refused "this lane's frames are not the open symbol's"})]
|
|
(committed db sid result [::insert-drawing :grow-symbol]))))
|
|
|
|
(rf/reg-event-db
|
|
::split-cel
|
|
(fn [db _]
|
|
(let [{clip :clip st :store} (store/entry (:clip/current db))
|
|
selection (get-in db [:ui :selection])
|
|
[_ sid id] selection
|
|
owner-frame (selection-frame clip st (get-in db [:ui :open]) selection
|
|
(get-in db [:playback :frame]))
|
|
cut (when (number? owner-frame)
|
|
(lane/lane-frame clip sid (:parent (get-in clip [:symbols sid :nodes id]))
|
|
owner-frame))]
|
|
(apply-lane-command
|
|
db sid (if cut
|
|
(lane/split clip sid id cut (random-uuid))
|
|
{:refused "this lane's frames are not the open symbol's"})
|
|
nil))))
|
|
|
|
(defn- at-playhead
|
|
"The selected cel, its lane, and the playhead as a frame of that lane's
|
|
own time — or a refusal in place of the frame where there is no single one."
|
|
[db]
|
|
(let [{clip :clip st :store} (store/entry (:clip/current db))
|
|
selection (get-in db [:ui :selection])
|
|
[_ sid id] selection
|
|
n (get-in clip [:symbols sid :nodes id])]
|
|
{:clip clip :sid sid :id id :node n
|
|
:at (when-let [owner-frame (selection-frame clip st (get-in db [:ui :open]) selection
|
|
(get-in db [:playback :frame]))]
|
|
(lane/lane-frame clip sid (:parent n) owner-frame))}))
|
|
|
|
(rf/reg-event-fx
|
|
::overwrite-drawing
|
|
(fn [{:keys [db]} [_ extent]]
|
|
(let [{clip :clip st :store} (store/entry (:clip/current db))
|
|
selection (get-in db [:ui :selection])
|
|
[_ sid id] selection
|
|
lane-id (selected-lane clip sid id)
|
|
owner-frame (selection-frame clip st (get-in db [:ui :open]) selection
|
|
(get-in db [:playback :frame]))
|
|
at (when (number? owner-frame) (lane/lane-frame clip sid lane-id owner-frame))
|
|
result (if (integer? at)
|
|
(lane/overwrite-drawing clip sid lane-id (random-uuid) (clip/fresh-id clip) at
|
|
{:extent (or extent :keep)
|
|
:remainder-id (random-uuid)})
|
|
{:refused "this lane's frames are not the open symbol's"})]
|
|
(committed db sid result [::overwrite-drawing :grow-symbol]))))
|
|
|
|
(rf/reg-event-db
|
|
::trim-cel
|
|
(fn [db [_ edge]]
|
|
(let [{:keys [clip sid id at]} (at-playhead db)]
|
|
(apply-lane-command
|
|
db sid (if at
|
|
(lane/trim clip sid id edge at)
|
|
{:refused "this lane's frames are not the open symbol's"})
|
|
nil))))
|
|
|
|
(rf/reg-event-db
|
|
::move-cel
|
|
(fn [db _]
|
|
(let [{:keys [clip sid id at]} (at-playhead db)]
|
|
(apply-lane-command
|
|
db sid (if at
|
|
(lane/move clip sid id at)
|
|
{:refused "this lane's frames are not the open symbol's"})
|
|
nil))))
|
|
|
|
(rf/reg-event-db
|
|
::blank-cel
|
|
;; The selected cel's own frames, so the range needs no second gesture and
|
|
;; the case that would split a cel cannot arise.
|
|
(fn [db _]
|
|
(let [{:keys [clip sid node]} (at-playhead db)
|
|
span (node/placed-span node)]
|
|
(apply-lane-command
|
|
db sid (if (and span (every? integer? span))
|
|
(lane/blank clip sid (:parent node) span {})
|
|
{:refused "select a cel that starts and ends on whole lane frames"})
|
|
nil))))
|
|
|
|
(rf/reg-event-db
|
|
::make-unique
|
|
(fn [db [_ deep?]]
|
|
(let [clip (:clip (store/entry (:clip/current db)))
|
|
[_ sid id] (get-in db [:ui :selection])]
|
|
(apply-lane-command db sid (lane/make-unique clip sid id {:deep? deep?}) nil))))
|
|
|
|
(rf/reg-event-db
|
|
::extend-hold
|
|
(fn [db [_ delta extent]]
|
|
(let [clip (:clip (store/entry (:clip/current db)))
|
|
[_ sid id] (get-in db [:ui :selection])
|
|
result (lane/extend-hold clip sid id delta {:extent (or extent :keep)})]
|
|
(apply-lane-command db sid result [::extend-hold delta :grow-symbol]))))
|
|
|
|
(rf/reg-event-fx
|
|
::lane-retry
|
|
(fn [{:keys [db]} _]
|
|
(if-let [event (get-in db [:ui :lane-retry])]
|
|
{:db (update db :ui dissoc :lane-retry) :dispatch event}
|
|
{})))
|
|
|
|
(rf/reg-event-db
|
|
::sheet-paste
|
|
(fn [db [_ sid lanes at payload]]
|
|
(let [clip (:clip (store/entry (:clip/current db)))]
|
|
(apply-lane-command db sid
|
|
(lane/paste-range clip sid lanes at payload random-uuid) nil))))
|
|
|
|
(rf/reg-event-db
|
|
::sheet-hold
|
|
(fn [db [_ sid id end extent]]
|
|
(let [clip (:clip (store/entry (:clip/current db)))
|
|
n (get-in clip [:symbols sid :nodes id])
|
|
at (lane/lane-frame clip sid (:parent n) end)
|
|
delta (when at (- at (second (node/placed-span n))))]
|
|
(if (= 0 delta) db
|
|
(apply-lane-command db sid
|
|
(if delta
|
|
(lane/extend-hold clip sid id delta {:extent (or extent :keep)})
|
|
{:refused "this lane's frames are not the open symbol's"})
|
|
[::sheet-hold sid id end :grow-symbol])))))
|
|
|
|
(rf/reg-event-db
|
|
::toggle-row
|
|
(fn [db [_ path]]
|
|
(update-in db [:ui :expanded] #(if (contains? % path) (disj % path) (conj % path)))))
|
|
|
|
(rf/reg-event-db
|
|
::solo
|
|
(fn [db [_ path more?]]
|
|
;; Per open symbol, because a row path only means something from the symbol
|
|
;; it was walked from. A click solos that row alone, or un-solos it if it
|
|
;; already was; a shift-click adds it to or takes it out of the ones soloed.
|
|
(update-in db [:ui :solo (get-in db [:ui :open])]
|
|
(fn [on]
|
|
(cond more? (if (contains? on path) (disj on path) (conj (set on) path))
|
|
(= on #{path}) #{}
|
|
:else #{path})))))
|
|
|
|
(rf/reg-event-db
|
|
::trace-face
|
|
;; Showing the footage under a face is a viewing aid, like solo: editor state
|
|
;; rather than the document, so it is not an undo step, does not travel to a
|
|
;; collaborator and cannot reach an export. Per FACE and not per placement — a
|
|
;; face is the same face wherever it is placed, and it is the face being traced
|
|
;; — so one switch shows it in the take and in its own tab both.
|
|
(fn [db [_ face]]
|
|
(update-in db [:ui :trace :faces]
|
|
#(if (contains? % face) (disj % face) (conj (set %) face)))))
|
|
|
|
(rf/reg-event-db
|
|
::trace-faces
|
|
;; Every face the open symbol has, from the bar above the stage: switched on
|
|
;; unless they all already are, which is the one gesture a person wants when
|
|
;; there is exactly one face and when there are five.
|
|
(fn [db [_ faces]]
|
|
(let [faces (set faces)
|
|
on (set (get-in db [:ui :trace :faces]))]
|
|
(assoc-in db [:ui :trace :faces]
|
|
(if (every? on faces) (reduce disj on faces) (into on faces))))))
|
|
|
|
(rf/reg-event-db
|
|
::trace-opacity
|
|
(fn [db [_ opacity]] (assoc-in db [:ui :trace :opacity] opacity)))
|
|
|
|
(defn- where-new-goes
|
|
"The row path, from the open symbol down, of the symbol a new thing goes into:
|
|
INSIDE the selected instance, or BESIDE any other selected node, or at the top
|
|
of the open symbol when nothing is selected.
|
|
|
|
A selection from a timeline row carries that row's path, because one symbol
|
|
placed twice is two rows and only the path says which was clicked. One made on
|
|
the stage does not, and names a node directly in the open symbol."
|
|
[clip db]
|
|
(let [[kind sid id path] (get-in db [:ui :selection])
|
|
path (when (= :node kind) (or path [id]))]
|
|
(cond
|
|
(nil? path) []
|
|
(= :instance (get-in clip [:symbols sid :nodes id :kind])) path
|
|
:else (pop path))))
|
|
|
|
;; ---------------------------------------------------------------------------
|
|
;; drawing a polygon
|
|
;;
|
|
;; Three events and a vector of numbers. The draft is in app-db rather than in a
|
|
;; ratom because the stage draws it, the palette colours it and the params pane
|
|
;; reports its vertex count — and because a half-drawn shape surviving a hot
|
|
;; reload is worth more than the handful of dispatches it costs. Clicks are rare;
|
|
;; this is not the drag path.
|
|
|
|
(rf/reg-event-db
|
|
::begin-polygon
|
|
;; The selection is KEPT: a selected instance is where the new shape will go.
|
|
(fn [db _] (update db :ui merge {:tool :polygon :draft []})))
|
|
|
|
(rf/reg-event-db
|
|
::cancel-polygon
|
|
(fn [db _] (update db :ui merge {:tool nil :draft []})))
|
|
|
|
(rf/reg-event-db
|
|
::add-draft-point
|
|
(fn [db [_ x y]]
|
|
(if (= :polygon (get-in db [:ui :tool]))
|
|
(update-in db [:ui :draft] into [x y])
|
|
db)))
|
|
|
|
(rf/reg-event-fx
|
|
::finish-polygon
|
|
(fn [{:keys [db]} _]
|
|
(let [draft (get-in db [:ui :draft])
|
|
open (get-in db [:ui :open])
|
|
{clip :clip st :store} (store/entry (:clip/current db))
|
|
down (where-new-goes clip db)
|
|
;; Drawn on the stage, stored where it goes: inside the selected
|
|
;; instance, re-expressed in that symbol's coordinates and frame so it
|
|
;; lands exactly where it was drawn.
|
|
{:keys [sid frame pts]} (nest/drawn-inside clip st open down
|
|
(get-in db [:playback :frame]) draft)]
|
|
(cond
|
|
(< (count draft) 6) {}
|
|
(nil? sid) {:db (update db :project merge
|
|
{:status "the selected instance is not on screen at this frame"})}
|
|
;; `random-uuid` is the one impurity in this namespace, and it is here
|
|
;; rather than in `domain/paint` for the reason `clip/place-symbol` spells
|
|
;; out: a node's id is its identity in the saved document, so the pure
|
|
;; layer must be handed one rather than invent one. If replaying the event
|
|
;; log ever has to reproduce a document exactly, this becomes a cofx.
|
|
:else
|
|
(let [id (keyword (str "paint-" (random-uuid)))]
|
|
{:db (-> db
|
|
(update :ui merge {:tool nil :draft []
|
|
:selection [:node sid id (conj down id)]})
|
|
(update-in [:ui :expanded] into (rest (reductions conj [] down))))
|
|
:dispatch [::paint/new-shape sid id frame pts (get-in db [:ui :tone])]})))))
|
|
|
|
(rf/reg-event-db
|
|
::set-knob
|
|
(fn [db [_ scope id knob value]]
|
|
(assoc-in db [:ui :knobs [scope id knob]] value)))
|
|
|
|
;; ---------------------------------------------------------------------------
|
|
;; a new symbol
|
|
|
|
(rf/reg-event-db
|
|
::new-symbol
|
|
(fn [db _]
|
|
(let [{clip :clip st :store} (store/entry (:clip/current db))
|
|
down (where-new-goes clip db)
|
|
{host :sid frame :frame} (nest/inside clip st (get-in db [:ui :open]) down
|
|
(get-in db [:playback :frame]))
|
|
sid (clip/fresh-id clip)
|
|
uuid (random-uuid)]
|
|
(if-not host
|
|
(update db :project merge
|
|
{:status "the selected instance is not on screen at this frame"})
|
|
(-> db
|
|
(edit/edit #(clip/new-symbol % host sid frame uuid))
|
|
(assoc-in [:ui :selection] [:node host uuid (conj down uuid)])
|
|
;; Open every row down to it, or the new row is inside a closed one
|
|
;; and the button looks like it did nothing.
|
|
(update-in [:ui :expanded] into (rest (reductions conj [] down))))))))
|
|
|
|
;; ---------------------------------------------------------------------------
|
|
;; a drop in flight
|
|
;;
|
|
;; `[:ui :drop]` is where a drag out of the pool would land: `:where` is :stage or
|
|
;; :timeline, `:frame` the frame of the open symbol it would start on, and
|
|
;; `:point` the stage pixel under the pointer when that is the stage. `:label`
|
|
;; and `:frames` ride along so the timeline can draw the preview row without
|
|
;; reaching into the drag. Only written when it CHANGES — dragover fires every few
|
|
;; milliseconds whether the pointer moved or not.
|
|
|
|
(rf/reg-event-db
|
|
::drop-hover
|
|
(fn [db [_ hover]]
|
|
(if (= hover (get-in db [:ui :drop])) db (assoc-in db [:ui :drop] hover))))
|
|
|
|
(rf/reg-event-db
|
|
::drop-clear
|
|
(fn [db _] (update db :ui dissoc :drop)))
|
|
|
|
(rf/reg-event-db
|
|
::drop-symbol
|
|
;; `point` is the stage pixel it was dropped on, or nil from the timeline.
|
|
(fn [db [_ sid frame point]]
|
|
(let [uuid (random-uuid)
|
|
host (get-in db [:ui :open])]
|
|
(-> db
|
|
(update :ui dissoc :drop)
|
|
(edit/edit-entry #(update % :clip clip/place-symbol (:store %)
|
|
host sid frame uuid point))
|
|
(assoc-in [:ui :selection] [:node host uuid [uuid]])))))
|
|
|
|
(rf/reg-event-db
|
|
::drop-sound
|
|
(fn [db [_ {:keys [source label length rate]} frame]]
|
|
(let [uuid (random-uuid)
|
|
host (get-in db [:ui :open])]
|
|
(-> db
|
|
(update :ui dissoc :drop)
|
|
(edit/edit #(clip/place-sound % host source label length rate frame uuid))
|
|
(assoc-in [:ui :selection] [:node host uuid [uuid]])))))
|
|
|
|
;; ---------------------------------------------------------------------------
|
|
;; moving rows between symbols
|
|
;;
|
|
;; Both are `nest/move-node` and `nest/group`, which keep the picture and the
|
|
;; timing as they are; what these add is where the selection goes and the reason
|
|
;; when a move is refused, which is the only feedback a refused drop has.
|
|
|
|
(defn- refused [db why]
|
|
(update db :project merge {:status (str "can't: " why)}))
|
|
|
|
(rf/reg-event-db
|
|
::move-node
|
|
(fn [db [_ from to]]
|
|
(let [{clip :clip st :store} (store/entry (:clip/current db))
|
|
r (nest/move-node clip st (get-in db [:ui :open]) from to
|
|
(get-in db [:playback :frame]))]
|
|
(if-let [why (:refused r)]
|
|
(refused db why)
|
|
(-> db
|
|
(edit/edit (constantly (:clip r)))
|
|
(assoc-in [:ui :selection] [:node (:sid r) (:id r) (conj to (:id r))])
|
|
(cond-> (not= :audio (get-in r [:clip :symbols (:sid r) :nodes (:id r) :kind]))
|
|
(update-in [:ui :expanded] into (rest (reductions conj [] to)))))))))
|
|
|
|
(rf/reg-event-db
|
|
::sliding
|
|
;; A bar in the middle of a slide, drawn by `::render/clip`; nil path when the
|
|
;; drag is abandoned.
|
|
(fn [db [_ path df]]
|
|
(if path
|
|
(assoc-in db [:ui :sliding] {:path path :df df})
|
|
(update db :ui dissoc :sliding))))
|
|
|
|
(rf/reg-event-db
|
|
::slide
|
|
(fn [db [_ path df]]
|
|
(let [db (update db :ui dissoc :sliding)
|
|
r (nest/slide (:clip (store/entry (:clip/current db))) (get-in db [:ui :open]) path df)]
|
|
(cond
|
|
(zero? df) db
|
|
(:refused r) (refused db (:refused r))
|
|
:else (edit/edit db (constantly (:clip r)))))))
|
|
|
|
(rf/reg-event-db
|
|
::points
|
|
;; Editing the selected shape's points rather than transforming it — a
|
|
;; double-click on the shape, as Figma's, which is one level further in. Any
|
|
;; new selection leaves it.
|
|
(fn [db [_ on?]]
|
|
(if on? (assoc-in db [:ui :points] true) (update db :ui dissoc :points))))
|
|
|
|
(rf/reg-event-db
|
|
::refuse
|
|
(fn [db [_ why]] (refused db why)))
|
|
|
|
(rf/reg-event-db
|
|
::gesture
|
|
;; A transform in the middle of a drag on the stage, `{:sid :id :frame
|
|
;; :values}`, drawn by `::render/clip` as `::sliding` is; nil when abandoned.
|
|
(fn [db [_ g]]
|
|
(if g (assoc-in db [:ui :gesture] g) (update db :ui dissoc :gesture))))
|
|
|
|
(rf/reg-event-db
|
|
::transform
|
|
;; The drag let go: one edit, so one undo step and one write to collaborators.
|
|
(fn [db [_ {:keys [sid id frame values]}]]
|
|
(cond-> (update db :ui dissoc :gesture)
|
|
(seq values) (edit/edit #(gesture/apply-values % sid id frame values)))))
|
|
|
|
(rf/reg-event-db
|
|
::delete-selected
|
|
(fn [db _]
|
|
(let [[kind sid id] (get-in db [:ui :selection])]
|
|
(if (= :node kind)
|
|
(-> db
|
|
(edit/edit #(nest/delete-node % sid id))
|
|
(assoc-in [:ui :selection] nil))
|
|
db))))
|
|
|
|
(rf/reg-event-db
|
|
::restack
|
|
;; Onto the edge of a row in another symbol, it goes into that symbol first:
|
|
;; one gesture, as in a layers panel, for where it lives and where in the stack.
|
|
(fn [db [_ from to front?]]
|
|
(let [{clip :clip st :store} (store/entry (:clip/current db))
|
|
open (get-in db [:ui :open])
|
|
f (get-in db [:playback :frame])
|
|
host (pop to)
|
|
moved (if (= host (pop from))
|
|
{:clip clip :id (peek from)}
|
|
(nest/move-node clip st open from host f))
|
|
r (if (:refused moved)
|
|
moved
|
|
(nest/restack (:clip moved) open (conj host (:id moved)) to front?))]
|
|
(if-let [why (:refused r)]
|
|
(refused db why)
|
|
(-> db
|
|
(edit/edit (constantly (:clip r)))
|
|
(assoc-in [:ui :selection] [:node (:sid r) (:id r) (conj host (:id r))])
|
|
(update-in [:ui :expanded] into (rest (reductions conj [] host))))))))
|
|
|
|
(rf/reg-event-db
|
|
::group
|
|
(fn [db [_ froms]]
|
|
(let [{clip :clip st :store} (store/entry (:clip/current db))
|
|
open (get-in db [:ui :open])
|
|
f (get-in db [:playback :frame])
|
|
host (pop (first froms))
|
|
uuid (random-uuid)
|
|
r (nest/group clip st open froms (clip/fresh-id clip) uuid f)]
|
|
(if-let [why (:refused r)]
|
|
(refused db why)
|
|
(-> db
|
|
(edit/edit (constantly (:clip r)))
|
|
(assoc-in [:ui :selection] [:node (:sid (nest/inside clip st open host f))
|
|
uuid (conj host uuid)])
|
|
(update-in [:ui :expanded] conj (conj host uuid)))))))
|