diff --git a/frontend/src/arthur/domain/span.cljs b/frontend/src/arthur/domain/span.cljs index bdaf252..735f2e8 100644 --- a/frontend/src/arthur/domain/span.cljs +++ b/frontend/src/arthur/domain/span.cljs @@ -474,9 +474,45 @@ nodes later)] (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 - "Place arbitrary symbol `source-id` into `sid` as a naturally playing clip at - frame `at`. + "Materialize an instance of `source-id`, then place it into `sid` at `at`. 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 @@ -488,25 +524,13 @@ {:keys [extent point remainder-id] :or {extent :keep}}] (let [nodes (get-in clip [:symbols sid :nodes]) seeded (clip/place-symbol clip store sid source-id 0 id point) - n (get-in seeded [:symbols sid :nodes id]) - duration (when n (- (second (node/placed-span n)) - (first (node/placed-span n))))] + n (get-in seeded [:symbols sid :nodes id])] (cond (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? 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 - (let [room (cleared clip sid at duration 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))))))) + (place-node clip sid n at {:extent extent :remainder-id remainder-id})))) (defn adopt "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: `move` refuses to disturb a neighbour, and a drag onto occupied time has 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]) - n (get nodes id) - [lo hi] (when n (node/placed-span n)) - duration (when (and lo hi) (- hi lo))] + n (get nodes id)] (cond (nil? n) {:refused "select a clip to move"} (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 - (let [room (cleared (assoc-in clip [:symbols sid :nodes] - (dissoc nodes id)) - sid at duration remainder-id)] - (if (:refused room) - room - (let [moved (update-in n [:time :at] (fnil + 0) (- at lo)) - nodes (assoc (get-in (:clip room) [:symbols sid :nodes]) id moved)] - (finish (:clip room) sid nodes id extent))))))) + (place-node (assoc-in clip [:symbols sid :nodes] (dissoc nodes id)) + sid n at opts)))) + +(defn transfer + "Move direct child `id` from `from-sid` into `to-sid` at `at`. + + Cross-symbol and same-symbol moves are deliberately the same composition: + 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 diff --git a/frontend/src/arthur/domain/symbol.cljs b/frontend/src/arthur/domain/symbol.cljs index 9bf97e1..d0c1a31 100644 --- a/frontend/src/arthur/domain/symbol.cljs +++ b/frontend/src/arthur/domain/symbol.cljs @@ -122,10 +122,10 @@ `{: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. - THE FRAME SPACE A COMMAND IS GIVEN ITS COORDINATE IN. A cel's parent is its - lane, so a lane command composing this for the lane reads lane time; a node - with no parent reads the symbol's own frames. One rule either way, so a caller - holding a node does not have to ask what it is sitting in. + THE FRAME SPACE A COMMAND IS GIVEN ITS COORDINATE IN. A direct child reads + the symbol's own frames. A node grouped beneath another composes through that + parent chain. One rule either way, so a caller holding a node does not have to + 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: 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))))))) (defn lane? - "Whether symbol `sym` is DRAWN as a lane: its clips as blocks on one row, - following one another in time and claiming it from each other. + "Whether symbol `sym` is EDITED AND DRAWN as a lane: its clips as blocks on + 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 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 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 - overlap check. See `docs/lane-is-a-view-plan.md`." + Editing and presentation may read it; evaluation may not. See + `docs/lane-is-a-view-plan.md`." [sym] (= :lane (:display sym))) diff --git a/frontend/src/arthur/events/ui.cljs b/frontend/src/arthur/events/ui.cljs index 357a882..14516ce 100644 --- a/frontend/src/arthur/events/ui.cljs +++ b/frontend/src/arthur/events/ui.cljs @@ -728,36 +728,19 @@ (rf/reg-event-db ::drop-clip - ;; A CLIP BODY DRAGGED ONTO A ROW. Within its own symbol this is `span/adopt`, - ;; which claims the time it lands on — a drop onto occupied frames has already - ;; said it means to. Onto a row leading into ANOTHER symbol it is that, after - ;; `nest/move-node` carries the clip across keeping its world transform; the two - ;; commit as one transaction, so it is still one undo step. - (fn [db [_ [_ from-sid id from-path] target-path frame]] + ;; A clip body is already materialized, so its whole drop is: resolve the + ;; destination, then transfer it. `span/transfer` asks the destination whether + ;; it claims time; this event does not know or care whether that is a lane. + (fn [db [_ [_ from-sid id _] target frame]] (let [{document :clip st :store} (store/entry (:clip/current db)) - open (get-in db [:ui :open]) - into (nest/inside document st open (vec target-path) frame) - crossing? (not= from-sid (:sid into)) - 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 - :remainder-id (random-uuid)}))] - (if-let [why (:refused result)] + where (drop-destination db document st frame target) + result (when-not (:refused where) + (span/transfer document from-sid id (:sid where) (:at where) + {:extent :grow-symbol + :remainder-id (random-uuid)}))] + (if-let [why (or (:refused where) (:refused result))] (update db :project merge {:status why}) - (-> db - (edit/transaction (constantly (:clip result))) - (assoc-in [:ui :selection] - [:node (:sid into) landed-id - (conj (vec target-path) landed-id)])))))) + (landed db where id result))))) ;; --------------------------------------------------------------------------- ;; moving rows between symbols @@ -769,48 +752,6 @@ (defn- refused [db 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 ::move-node (fn [db [_ from to]] diff --git a/frontend/src/arthur/ui/timeline.cljs b/frontend/src/arthur/ui/timeline.cljs index 6f1cd20..867d8a2 100644 --- a/frontend/src/arthur/ui/timeline.cljs +++ b/frontend/src/arthur/ui/timeline.cljs @@ -686,8 +686,8 @@ (not= (:select under) (:selection drag))) under) [target-el target] (when (and drag (not shift?)) (lane-under e)) - crossing? (and target (not= target (:source-lane drag))) - target-frame (when crossing? + landing? (some? target) + target-frame (when landing? (max 0 (- (frame-at-element e frames target-el) (:grab drag))))] (when (and drag hint) @@ -706,7 +706,7 @@ (swap! sliding #(-> % (assoc :nest nest) (dissoc :target-lane :target-frame))) (rf/dispatch [::ui/sliding nil])) - crossing? + landing? (do (swap! sliding #(-> % (assoc :target-lane target :target-frame target-frame) @@ -735,7 +735,7 @@ (nth (:select nest) 3)])) (and commit? target-lane drag) (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])) commit? ;; A press that moved nothing is a click, and a drag @@ -760,7 +760,6 @@ :on-click actual-select :drag (when drag (assoc drag - :source-lane select :grab (- (frame-at-element e frames track) (:in drag)))) :ripple? (and (= :out gesture-kind) (.-shiftKey e)) @@ -804,7 +803,7 @@ (.stopPropagation e) (if-let [from (drag/row-selection)] (do (drag/done!) - (rf/dispatch [::ui/adopt-in-lane from select + (rf/dispatch [::ui/drop-clip from select (frame-at e frames)])) (drag/land! (frame-at e frames) nil select))))} ;; Clipped to the ruler: an instance longer than the room left in its diff --git a/frontend/test/arthur/domain/sequence_test.cljs b/frontend/test/arthur/domain/sequence_test.cljs index bedfc3b..8a9160e 100644 --- a/frontend/test/arthur/domain/sequence_test.cljs +++ b/frontend/test/arthur/domain/sequence_test.cljs @@ -394,6 +394,53 @@ (mapv node/placed-span (symbol/children (get-in after [:symbols :main :nodes])))) "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 (let [doc (assoc-in (document) [:symbols :main :nodes :badge] {:id :badge :kind :instance :z "z"