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

Unify clip placement across symbol modes

Browse source
This commit is contained in:
Your Name 2026-10-01 20:09:35 -04:00
parent e459307a4a
commit 93f5112bb3
5 changed files with 136 additions and 117 deletions
Download patch file Download diff file Expand all files Collapse all files

98
frontend/src/arthur/domain/span.cljs
View file

@ -474,9 +474,45 @@
nodes later)] nodes later)]
(finish clip sid nodes id extent))))) (finish clip sid nodes id extent)))))
(defn place-node
"Place the already-materialized, direct child `n` into symbol `sid` at `at`.
THIS IS THE PLACEMENT RULE. Materializing a symbol instance, an audio node, or
imported content is deliberately somebody else's job; once it is a node, its
origin no longer matters. The destination alone decides the edit:
- an ordinary symbol attaches it and permits overlap;
- a lane symbol first clears the interval it claims.
The caller hands this function a node not currently present in the destination.
Its duration, channels, source clock and identity are preserved; only its
parent-space start changes. Returns the ordinary command result shape."
[clip sid n at {:keys [extent remainder-id] :or {extent :keep}}]
(let [sym (clip/symbol clip sid)
nodes (:nodes sym)
id (:id n)
[lo hi] (when n (node/placed-span n))
duration (when (and lo hi) (- hi lo))]
(cond
(nil? sym) {:refused "there is no destination symbol"}
(nil? n) {:refused "there is no clip to place"}
(contains? nodes id) {:refused "the destination already uses that clip ID"}
(some? (:parent n)) {:refused "only a direct child can be placed in a symbol"}
(not (and (integer? at) (not (neg? at))))
{:refused "a position is a nonnegative whole frame"}
(not (pos? duration)) {:refused "the clip has no frames to place"}
(and remainder-id (contains? nodes remainder-id))
{:refused "the remainder clip needs a free ID"}
:else
(let [room (cleared clip sid at duration remainder-id)]
(if (:refused room)
room
(let [placed (update-in n [:time :at] (fnil + 0) (- at lo))
nodes (assoc (get-in (:clip room) [:symbols sid :nodes]) id placed)]
(finish (:clip room) sid nodes id extent)))))))
(defn place-symbol (defn place-symbol
"Place arbitrary symbol `source-id` into `sid` as a naturally playing clip at "Materialize an instance of `source-id`, then place it into `sid` at `at`.
frame `at`.
IN A LANE the new clip claims its interval: existing clips under it are IN A LANE the new clip claims its interval: existing clips under it are
trimmed, removed, or split, so the sequence stays a partition rather than trimmed, removed, or split, so the sequence stays a partition rather than
@ -488,25 +524,13 @@
{:keys [extent point remainder-id] :or {extent :keep}}] {:keys [extent point remainder-id] :or {extent :keep}}]
(let [nodes (get-in clip [:symbols sid :nodes]) (let [nodes (get-in clip [:symbols sid :nodes])
seeded (clip/place-symbol clip store sid source-id 0 id point) seeded (clip/place-symbol clip store sid source-id 0 id point)
n (get-in seeded [:symbols sid :nodes id]) n (get-in seeded [:symbols sid :nodes id])]
duration (when n (- (second (node/placed-span n))
(first (node/placed-span n))))]
(cond (cond
(contains? nodes id) {:refused "the new clip ID is already used"} (contains? nodes id) {:refused "the new clip ID is already used"}
(not (and (integer? at) (not (neg? at))))
{:refused "a position is a nonnegative whole frame"}
(nil? (clip/symbol clip source-id)) {:refused "there is no such symbol to place"} (nil? (clip/symbol clip source-id)) {:refused "there is no such symbol to place"}
(nil? n) {:refused "a symbol cannot go inside itself"} (nil? n) {:refused "a symbol cannot go inside itself"}
(not (pos? duration)) {:refused "the symbol has no frames to place"}
(and remainder-id (contains? nodes remainder-id))
{:refused "the remainder clip needs a free ID"}
:else :else
(let [room (cleared clip sid at duration remainder-id)] (place-node clip sid n at {:extent extent :remainder-id remainder-id}))))
(if (:refused room)
room
(let [nodes (assoc (get-in (:clip room) [:symbols sid :nodes]) id
(assoc-in n [:time :at] at))]
(finish (:clip room) sid nodes id extent)))))))
(defn adopt (defn adopt
"Move an existing clip of `sid` to frame `at`, CLAIMING the time it lands on. "Move an existing clip of `sid` to frame `at`, CLAIMING the time it lands on.
@ -516,28 +540,36 @@
is what a body drag does, and it is why `move` and this are two commands: is what a body drag does, and it is why `move` and this are two commands:
`move` refuses to disturb a neighbour, and a drag onto occupied time has `move` refuses to disturb a neighbour, and a drag onto occupied time has
already said it means to." already said it means to."
[clip sid id at {:keys [extent remainder-id] :or {extent :keep}}] [clip sid id at opts]
(let [nodes (get-in clip [:symbols sid :nodes]) (let [nodes (get-in clip [:symbols sid :nodes])
n (get nodes id) n (get nodes id)]
[lo hi] (when n (node/placed-span n))
duration (when (and lo hi) (- hi lo))]
(cond (cond
(nil? n) {:refused "select a clip to move"} (nil? n) {:refused "select a clip to move"}
(some? (:parent n)) {:refused "only a clip of the symbol itself is placed in its sequence"} (some? (:parent n)) {:refused "only a clip of the symbol itself is placed in its sequence"}
(not (and (integer? at) (not (neg? at))))
{:refused "a position is a nonnegative whole frame"}
(not (pos? duration)) {:refused "the clip has no frames to place"}
(and remainder-id (contains? nodes remainder-id))
{:refused "the remainder clip needs a free ID"}
:else :else
(let [room (cleared (assoc-in clip [:symbols sid :nodes] (place-node (assoc-in clip [:symbols sid :nodes] (dissoc nodes id))
(dissoc nodes id)) sid n at opts))))
sid at duration remainder-id)]
(if (:refused room) (defn transfer
room "Move direct child `id` from `from-sid` into `to-sid` at `at`.
(let [moved (update-in n [:time :at] (fnil + 0) (- at lo))
nodes (assoc (get-in (:clip room) [:symbols sid :nodes]) id moved)] Cross-symbol and same-symbol moves are deliberately the same composition:
(finish (:clip room) sid nodes id extent))))))) detach, then `place-node`. The destination's mode—not the gesture, source, or
payload kind—decides whether occupied time is claimed."
[clip from-sid id to-sid at opts]
(let [from-nodes (get-in clip [:symbols from-sid :nodes])
n (get from-nodes id)]
(cond
(nil? n) {:refused "select a clip to move"}
(some? (:parent n)) {:refused "only a direct child can move between symbols"}
:else
(let [detached (assoc-in clip [:symbols from-sid :nodes] (dissoc from-nodes id))
result (place-node detached to-sid n at opts)]
(if-let [made (:clip result)]
(if-let [why (first (clip/problems made))]
{:refused why}
result)
result)))))
;; --------------------------------------------------------------------------- ;; ---------------------------------------------------------------------------
;; putting drawings in a sequence ;; putting drawings in a sequence

16
frontend/src/arthur/domain/symbol.cljs
View file

@ -122,10 +122,10 @@
`{:at a :rate r}`, meaning symbol frame `p` is frame `r·(p − a)` of `id`. `{:at a :rate r}`, meaning symbol frame `p` is frame `r·(p − a)` of `id`.
Identity for `nil`, which is a node sitting directly in the symbol. Identity for `nil`, which is a node sitting directly in the symbol.
THE FRAME SPACE A COMMAND IS GIVEN ITS COORDINATE IN. A cel's parent is its THE FRAME SPACE A COMMAND IS GIVEN ITS COORDINATE IN. A direct child reads
lane, so a lane command composing this for the lane reads lane time; a node the symbol's own frames. A node grouped beneath another composes through that
with no parent reads the symbol's own frames. One rule either way, so a caller parent chain. One rule either way, so a caller holding a node does not have to
holding a node does not have to ask what it is sitting in. ask what it is sitting in or how the timeline happens to draw the symbol.
Refuses floors and loops rather than pretend an affine map preserves them: Refuses floors and loops rather than pretend an affine map preserves them:
through either, one frame of the symbol is not one frame of `id` and a command through either, one frame of the symbol is not one frame of `id` and a command
@ -141,8 +141,8 @@
(recur (:parent n) (conj seen id) (conj chain n))))))) (recur (:parent n) (conj seen id) (conj chain n)))))))
(defn lane? (defn lane?
"Whether symbol `sym` is DRAWN as a lane: its clips as blocks on one row, "Whether symbol `sym` is EDITED AND DRAWN as a lane: its clips as blocks on
following one another in time and claiming it from each other. one row, following one another in time and claiming it from each other.
A DISPLAY HINT AND NOT A TYPE. Nothing in evaluation reads it, `problems` does A DISPLAY HINT AND NOT A TYPE. Nothing in evaluation reads it, `problems` does
not check it, and a symbol carrying it behaves identically on the stage — it not check it, and a symbol carrying it behaves identically on the stage — it
@ -153,8 +153,8 @@
from \"the clips do not currently overlap\" because a symbol must not stop being from \"the clips do not currently overlap\" because a symbol must not stop being
a lane the moment something overlaps — that is when the rules are needed. a lane the moment something overlaps — that is when the rules are needed.
The only things allowed to read it are the timeline and `span/finish`'s Editing and presentation may read it; evaluation may not. See
overlap check. See `docs/lane-is-a-view-plan.md`." `docs/lane-is-a-view-plan.md`."
[sym] [sym]
(= :lane (:display sym))) (= :lane (:display sym)))

77
frontend/src/arthur/events/ui.cljs
View file

@ -728,36 +728,19 @@
(rf/reg-event-db (rf/reg-event-db
::drop-clip ::drop-clip
;; A CLIP BODY DRAGGED ONTO A ROW. Within its own symbol this is `span/adopt`, ;; A clip body is already materialized, so its whole drop is: resolve the
;; which claims the time it lands on — a drop onto occupied frames has already ;; destination, then transfer it. `span/transfer` asks the destination whether
;; said it means to. Onto a row leading into ANOTHER symbol it is that, after ;; it claims time; this event does not know or care whether that is a lane.
;; `nest/move-node` carries the clip across keeping its world transform; the two (fn [db [_ [_ from-sid id _] target frame]]
;; commit as one transaction, so it is still one undo step.
(fn [db [_ [_ from-sid id from-path] target-path frame]]
(let [{document :clip st :store} (store/entry (:clip/current db)) (let [{document :clip st :store} (store/entry (:clip/current db))
open (get-in db [:ui :open]) where (drop-destination db document st frame target)
into (nest/inside document st open (vec target-path) frame) result (when-not (:refused where)
crossing? (not= from-sid (:sid into)) (span/transfer document from-sid id (:sid where) (:at where)
carried (when (and (:sid into) crossing?)
(nest/move-node document st open (vec from-path) (vec target-path) frame))
doc (if crossing? (:clip carried) document)
landed-id (if crossing? (:id carried) id)
result (cond
(nil? (:sid into))
{:refused "what you are dropping into is not on screen at this frame"}
(not (integer? (:frame into)))
{:refused "the drop is not on one frame of that symbol"}
(and crossing? (:refused carried)) carried
:else (span/adopt doc (:sid into) landed-id (:frame into)
{:extent :grow-symbol {:extent :grow-symbol
:remainder-id (random-uuid)}))] :remainder-id (random-uuid)}))]
(if-let [why (:refused result)] (if-let [why (or (:refused where) (:refused result))]
(update db :project merge {:status why}) (update db :project merge {:status why})
(-> db (landed db where id result)))))
(edit/transaction (constantly (:clip result)))
(assoc-in [:ui :selection]
[:node (:sid into) landed-id
(conj (vec target-path) landed-id)]))))))
;; --------------------------------------------------------------------------- ;; ---------------------------------------------------------------------------
;; moving rows between symbols ;; moving rows between symbols
@ -769,48 +752,6 @@
(defn- refused [db why] (defn- refused [db why]
(update db :project merge {:status (str "can't: " why)})) (update db :project merge {:status (str "can't: " why)}))
(rf/reg-event-db
::adopt-in-lane
;; Plain body-drag is temporal. The destination row names either an instance
;; of an explicit lane symbol, or the open lane symbol itself. Moving between
;; two lane symbols transfers the clip before `span/adopt` claims its new time;
;; Shift-drag remains the separate structural `::move-node` operation below.
(fn [db [_ [_ from-sid id _] [_ target-sid target-id target-path :as target]
frame]]
(let [{document :clip st :store} (store/entry (:clip/current db))
open (get-in db [:ui :open])
target-node (get-in document [:symbols target-sid :nodes target-id])
dest-sid (if target-id (node/source target-node) target-sid)
dest (clip/symbol document dest-sid)
local-frame (if (seq target-path)
(:frame (nest/inside document st open target-path frame))
(:frame (nest/inside document st open [] frame)))
n (get-in document [:symbols from-sid :nodes id])
seeded (when (and n dest-sid)
(if (= from-sid dest-sid)
document
(-> document
(update-in [:symbols from-sid :nodes] dissoc id)
(assoc-in [:symbols dest-sid :nodes id]
(dissoc n :parent)))))
result (cond
(nil? n) {:refused "select a clip to move"}
(not (symbol/lane? dest)) {:refused "drop onto an explicit lane"}
(and (not= from-sid dest-sid)
(contains? (get-in document [:symbols dest-sid :nodes]) id))
{:refused "the destination already has a clip with that ID"}
(not (integer? local-frame))
{:refused "the drop is not on one frame of this lane"}
:else (span/adopt seeded dest-sid id local-frame
{:extent :grow-symbol
:remainder-id (random-uuid)}))]
(if-let [why (:refused result)]
(refused db why)
(-> db
(edit/transaction (constantly (:clip result)))
(assoc-in [:ui :selection]
[:node dest-sid id (conj (vec target-path) id)]))))))
(rf/reg-event-db (rf/reg-event-db
::move-node ::move-node
(fn [db [_ from to]] (fn [db [_ from to]]

11
frontend/src/arthur/ui/timeline.cljs
View file

@ -686,8 +686,8 @@
(not= (:select under) (:selection drag))) (not= (:select under) (:selection drag)))
under) under)
[target-el target] (when (and drag (not shift?)) (lane-under e)) [target-el target] (when (and drag (not shift?)) (lane-under e))
crossing? (and target (not= target (:source-lane drag))) landing? (some? target)
target-frame (when crossing? target-frame (when landing?
(max 0 (- (frame-at-element e frames target-el) (max 0 (- (frame-at-element e frames target-el)
(:grab drag))))] (:grab drag))))]
(when (and drag hint) (when (and drag hint)
@ -706,7 +706,7 @@
(swap! sliding #(-> % (assoc :nest nest) (swap! sliding #(-> % (assoc :nest nest)
(dissoc :target-lane :target-frame))) (dissoc :target-lane :target-frame)))
(rf/dispatch [::ui/sliding nil])) (rf/dispatch [::ui/sliding nil]))
crossing? landing?
(do (do
(swap! sliding #(-> % (assoc :target-lane target (swap! sliding #(-> % (assoc :target-lane target
:target-frame target-frame) :target-frame target-frame)
@ -735,7 +735,7 @@
(nth (:select nest) 3)])) (nth (:select nest) 3)]))
(and commit? target-lane drag) (and commit? target-lane drag)
(do (rf/dispatch [::ui/sliding nil]) (do (rf/dispatch [::ui/sliding nil])
(rf/dispatch [::ui/adopt-in-lane (:selection drag) (rf/dispatch [::ui/drop-clip (:selection drag)
target-lane target-frame])) target-lane target-frame]))
commit? commit?
;; A press that moved nothing is a click, and a drag ;; A press that moved nothing is a click, and a drag
@ -760,7 +760,6 @@
:on-click actual-select :on-click actual-select
:drag (when drag :drag (when drag
(assoc drag (assoc drag
:source-lane select
:grab (- (frame-at-element e frames track) :grab (- (frame-at-element e frames track)
(:in drag)))) (:in drag))))
:ripple? (and (= :out gesture-kind) (.-shiftKey e)) :ripple? (and (= :out gesture-kind) (.-shiftKey e))
@ -804,7 +803,7 @@
(.stopPropagation e) (.stopPropagation e)
(if-let [from (drag/row-selection)] (if-let [from (drag/row-selection)]
(do (drag/done!) (do (drag/done!)
(rf/dispatch [::ui/adopt-in-lane from select (rf/dispatch [::ui/drop-clip from select
(frame-at e frames)])) (frame-at e frames)]))
(drag/land! (frame-at e frames) nil select))))} (drag/land! (frame-at e frames) nil select))))}
;; Clipped to the ruler: an instance longer than the room left in its ;; Clipped to the ruler: an instance longer than the room left in its

47
frontend/test/arthur/domain/sequence_test.cljs
View file

@ -394,6 +394,53 @@
(mapv node/placed-span (symbol/children (get-in after [:symbols :main :nodes])))) (mapv node/placed-span (symbol/children (get-in after [:symbols :main :nodes]))))
"it is simply placed, on screen with what was already there")))) "it is simply placed, on screen with what was already there"))))
(deftest repeated-symbol-drops-keep-the-symbols-natural-duration
(let [empty-lane (assoc-in (document) [:symbols :main]
{:id :main :frames 40 :display :lane :nodes {}})
once (:clip (span/place-symbol empty-lane nil :main :one :wave 0
{:extent :grow-symbol :remainder-id :r1}))
twice (:clip (span/place-symbol once nil :main :two :wave 10
{:extent :grow-symbol :remainder-id :r2}))
thrice (:clip (span/place-symbol twice nil :main :three :wave 20
{:extent :grow-symbol :remainder-id :r3}))]
(is (= [[:one [0 10]] [:two [10 20]] [:three [20 30]]]
(mapv (juxt :id node/placed-span)
(symbol/children (get-in thrice [:symbols :main :nodes]))))
"materializing the same source repeatedly does not collapse later instances")
(is (every? #(= [0 10] (:span %))
(symbol/children (get-in thrice [:symbols :main :nodes]))))
(let [resolve (clip/resolver thrice :main nil pal/index-of nil)]
(doseq [[id at] [[:one 0] [:two 10] [:three 20]]]
(is (= [0 300 600 900]
(mapv (fn [f]
(let [op (first (filter #(= [id :mark] (:node %))
(resolve (+ at f))))]
(js/Math.round (:cx op))))
[0 3 6 9]))
(str id " gets its own complete source clock"))))
(is (empty? (clip/problems thrice)))))
(deftest transfer-is-one-placement-rule-with-two-destination-modes
(let [doc (document)
moved (:clip (span/transfer doc :main :insert :main 2
{:extent :grow-symbol :remainder-id :rest}))
clips (symbol/children (get-in moved [:symbols :main :nodes]))]
(is (= [[0 2] [2 6] [6 8]] (mapv node/placed-span clips))
"moving within a lane claims the landing interval from both neighbours")
(is (= :insert (:id (second clips))))
(is (empty? (symbol/overlaps (get-in moved [:symbols :main]))))
;; The identical transfer into an ordinary symbol simply composites.
(let [ordinary (assoc-in doc [:symbols :other]
{:id :other :frames 12
:nodes {:existing (cel :existing :drawing-a 0 4 0)}})
free (:clip (span/transfer ordinary :main :b :other 1
{:extent :grow-symbol :remainder-id :rest}))]
(is (= #{:existing :b} (set (keys (get-in free [:symbols :other :nodes])))))
(is (= 1 (count (symbol/overlaps (get-in free [:symbols :other]))))
"overlap is ordinary composition outside lane mode")
(is (nil? (get-in free [:symbols :main :nodes :b])))
(is (empty? (clip/problems free))))))
(deftest an-existing-clip-can-be-moved-and-claim-where-it-lands (deftest an-existing-clip-can-be-moved-and-claim-where-it-lands
(let [doc (assoc-in (document) [:symbols :main :nodes :badge] (let [doc (assoc-in (document) [:symbols :main :nodes :badge]
{:id :badge :kind :instance :z "z" {:id :badge :kind :instance :z "z"