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

Author corrections without baking them into motion

Browse source 
Constant, ramp, and return offsets now append ordinary channel layers to a lane or cel in explicit owner frames. The inspector exposes the commands as one undoable transaction, shows conflicts, and offers removal or retry while preserving generated bases through regeneration.

Ordered-stack compatibility is shared by validation, conflict reporting, and regeneration, including adjacent replacement coverage. Cel-sheet gaps and headers select their lane, so commands cannot fall through to another column's stale selection.

437 tests, 5,804 assertions; both browser flows; 56 Django tests; optimized frontend build.
This commit is contained in:
Your Name 2026-09-30 22:00:48 -04:00
parent 3dbbe285fc
commit 815ce449ea
14 changed files with 806 additions and 60 deletions
Download patch file Download diff file Expand all files Collapse all files

82
frontend/src/arthur/domain/channel.cljs
View file

@ -178,27 +178,61 @@
(when (= :offset (:op l))
(shape-conflict (value-shape base) (value-shape (:values l)))))
(defn- stack-conflict
"Why layer `i` can encounter a value of the wrong shape after the layers
before it. A replace covering all of this layer's support becomes the only
possible input; a partly overlapping replace adds another possible input."
[ch i l]
(when (and (= :offset (:op l))
(vector? (:support l)) (= 2 (count (:support l))))
(let [[a b] (:support l)
shapes (reduce
(fn [possible prior]
(let [[c d] (when (and (vector? (:support prior))
(= 2 (count (:support prior))))
(:support prior))]
(if (and c d (not (:conflict prior)) (= :replace (:op prior))
(< a d) (< c b))
(let [s (value-shape (:values prior))]
(if (and (<= c a) (<= b d)) #{s} (conj possible s)))
possible)))
#{(value-shape ch)} (take i (:over ch)))
v (value-shape (:values l))]
(some #(shape-conflict % v) shapes))))
(defn- support-of [l]
(let [s (:support l)]
(when (and (vector? s) (= 2 (count s))
(every? number? s) (< (first s) (second s)))
s)))
(defn stack-conflict
"Why layer `i` can encounter a value of the wrong shape after the active
layers before it, or nil.
Replacement coverage is considered at every interval boundary. This matters
when adjacent replacements jointly cover an offset: neither covers its whole
support, but the base can never reach it. A conflicted replacement is skipped,
exactly as the evaluator skips it."
[ch i]
(let [l (nth (:over ch) i nil)]
(when (and (= :offset (:op l)) (support-of l))
(let [[a b] (support-of l)
prior (take i (:over ch))
cuts (->> prior
(keep support-of)
(mapcat identity)
(filter #(< a % b))
(into [a b])
distinct sort)
;; Shape at a point is the last active, nonempty replacement's
;; shape, or the base shape when no replacement supplies a value.
at (fn [f]
(or (last (keep (fn [p]
(let [s (support-of p)
v (value-shape (:values p))]
(when (and (= :replace (:op p))
(not (:conflict p)) v s
(covers? s f))
v)))
prior))
(value-shape ch)))
shapes (into #{} (map (fn [[x y]] (at (/ (+ x y) 2))))
(partition 2 1 cuts))
v (value-shape (:values l))]
(some #(shape-conflict % v) shapes)))))
(defn reconcile
"Recheck an ordered layer stack against this channel's base.
Old conflict marks are findings from an earlier base, so they are cleared and
recomputed in order. A newly conflicted replacement is then invisible to the
layers after it, matching evaluation. Nothing is dropped or reordered."
[ch]
(let [layers (mapv #(dissoc % :conflict) (:over ch))]
(reduce (fn [out l]
(let [candidate (assoc ch :over (conj out l))
why (stack-conflict candidate (count out))]
(conj out (cond-> l why (assoc :conflict why)))))
[] layers)))
(defn conflicts
"Corrections on `ch` that cannot apply to its base, as `[{:id :why}]`.
@ -209,8 +243,8 @@
not load. `flow/regenerate` records one on the layer, a conflicted layer is not
applied, and this is how a view finds them to offer."
[ch]
(vec (for [l (:over ch)
:let [why (or (:conflict l) (conflict-with ch l))]
(vec (for [[i l] (map-indexed vector (:over ch))
:let [why (or (:conflict l) (stack-conflict ch i))]
:when why]
{:id (:id l) :why why})))
@ -558,7 +592,7 @@
(and (map? ch) (vector? (:over ch)))
(into (for [[i l] (map-indexed vector (:over ch))
:when (not (:conflict l))
:let [why (stack-conflict ch i l)]
:let [why (stack-conflict ch i)]
:when why]
(str "correction " (pr-str (:id l)) " " why)))

114
frontend/src/arthur/domain/correction.cljs Normal file
View file

@ -0,0 +1,114 @@
(ns arthur.domain.correction
"Pure commands that author and resolve correction layers.
Evaluation belongs to `channel`; this namespace only constructs a layer,
places it on its owning node, and refuses a document that would not be valid."
(:require [arthur.domain.channel :as ch]
[arthur.domain.clip :as clip]
[arthur.domain.node :as node]))
(def ^:private supported-paths #{[:xform :rot] [:xform :pos]})
(def ^:private motions #{:constant :ramp :return})
(defn- finite? [x] (and (number? x) (js/Number.isFinite x)))
(defn- numeric-value? [v]
(or (finite? v)
(and (vector? v) (pos? (count v)) (every? finite? v))))
(defn- same-shape? [a b]
(or (and (number? a) (number? b))
(and (vector? a) (vector? b) (= (count a) (count b)))))
(defn- expected-value? [path v]
(case path
[:xform :rot] (finite? v)
[:xform :pos] (and (vector? v) (= 2 (count v)) (every? finite? v))
false))
(defn- values-channel
[{:keys [motion support delta start end peak peak-frame]}]
(let [[a b] support]
(case motion
:constant (ch/framed delta)
:ramp (ch/keyed {a start, (dec b) end} :linear)
:return (ch/keyed {a start, peak-frame peak, (dec b) start} :linear)
nil)))
(defn- invalid
[path {:keys [id support motion delta start end peak peak-frame]} existing]
(let [[a b] (when (and (vector? support) (= 2 (count support))) support)
samples (case motion :constant [delta] :ramp [start end]
:return [start peak] [])]
(cond
(nil? id) "a correction needs an ID"
(some #(= id (:id %)) existing) "the correction ID is already used on this channel"
(not (contains? supported-paths path)) "that property does not support correction authoring"
(not (contains? motions motion)) "choose constant, ramp, or return motion"
(not (and (integer? a) (integer? b) (< a b)))
"support must be an increasing [in out) of whole owner frames"
(not-every? numeric-value? samples) "correction values must be finite numbers"
(not-every? #(expected-value? path %) samples)
"correction values do not have the property's shape"
(and (= :ramp motion) (< (- b a) 2)) "a ramp needs at least two samples"
(and (= :return motion) (< (- b a) 3)) "return motion needs at least three samples"
(and (= :return motion)
(not (and (integer? peak-frame) (< a peak-frame (dec b)))))
"the return peak must be a whole owner frame inside both endpoints"
(and (#{:ramp :return} motion) (not (same-shape? start (if (= :ramp motion) end peak))))
"motion endpoints must have the same shape")))
(defn- finish [candidate selection]
(if-let [why (first (clip/problems candidate))]
{:refused why}
{:clip candidate :selection selection}))
(defn add
"Append one offset correction to a node channel.
Support and value keys are in the selected node's own frames. Defaults are
materialized through `node/channels`, so correcting an unkeyed transform does
not need a special representation."
[document sid node-id path spec]
(let [n (get-in document [:symbols sid :nodes node-id])
base (when n (get (node/channels n) path))
existing (:over base)
why (cond
(nil? (clip/symbol document sid)) "the owning symbol does not exist"
(nil? n) "the correction target does not exist"
(nil? base) "the correction target has no such channel"
:else (invalid path spec existing))]
(if why
{:refused why}
(let [layer (ch/layer (:id spec) (:support spec) :offset (values-channel spec))
corrected (update base :over (fnil conj []) layer)
candidate (assoc-in document [:symbols sid :nodes node-id :channels path] corrected)]
(finish candidate node-id)))))
(defn remove-layer
"Remove one named layer, refusing when a later layer depended on its shape."
[document sid node-id path layer-id]
(let [at [:symbols sid :nodes node-id :channels path]
c (get-in document at)
layers (:over c)]
(cond
(nil? c) {:refused "the correction channel does not exist"}
(not-any? #(= layer-id (:id %)) layers) {:refused "the correction does not exist"}
:else (finish (assoc-in document at
(assoc c :over (vec (remove #(= layer-id (:id %)) layers))))
node-id))))
(defn retry-layer
"Clear one recorded conflict when the complete resulting stack is valid."
[document sid node-id path layer-id]
(let [at [:symbols sid :nodes node-id :channels path]
c (get-in document at)
found (some #(when (= layer-id (:id %)) %) (:over c))]
(cond
(nil? found) {:refused "the correction does not exist"}
(nil? (:conflict found)) {:refused "the correction has no recorded conflict"}
:else
(finish (update-in document (conj at :over)
(fn [layers]
(mapv #(if (= layer-id (:id %)) (dissoc % :conflict) %) layers)))
node-id))))

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

@ -6,6 +6,7 @@
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]
@ -58,6 +59,37 @@
(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 _]

7
frontend/src/arthur/flow/regenerate.cljs
View file

@ -45,12 +45,7 @@
topology has resolved it."
[old fresh]
(if-let [over (seq (:over old))]
(assoc fresh :over
(mapv (fn [l]
(if-let [why (ch/conflict-with fresh l)]
(assoc l :conflict why)
(dissoc l :conflict)))
over))
(assoc fresh :over (ch/reconcile (assoc fresh :over (vec over))))
fresh))
(defn- bases

135
frontend/src/arthur/ui/params.cljs
View file

@ -235,6 +235,139 @@
[channel-control sid id path ch frame]
[:dd (channel-state ch)])]))])]))
;; ---------------------------------------------------------------------------
;; corrections
(defn- correction-initial [clip sid id]
(let [n (get-in clip [:symbols sid :nodes id])
[a b] (or (:span n) [0 3])
a (if (integer? a) a 0)
through (max a (min (dec (if (integer? b) b 3)) (+ a 2)))]
{:target id :path [:xform :rot] :motion :constant
:from a :through through :peak-frame (min (dec through) (inc a))
:delta 0 :delta-x 0 :delta-y 0
:start 0 :start-x 0 :start-y 0
:end 0 :end-x 0 :end-y 0
:peak 0 :peak-x 0 :peak-y 0}))
(defn- draft-number [draft key label integer?]
[:label.inspector-field label
[:input {:type "number" :step (if integer? 1 "any")
:value (or (get @draft key) "")
:on-change (fn [e]
(let [s (.. e -target -value)
n ((if integer? js/parseInt js/parseFloat) s 10)]
(swap! draft assoc key (when-not (js/isNaN n) n))))}]])
(defn- value-inputs [draft prefix label]
(if (= [:xform :rot] (:path @draft))
[draft-number draft prefix (str label " (degrees)") false]
[:<>
[draft-number draft (keyword (str (name prefix) "-x")) (str label " x") false]
[draft-number draft (keyword (str (name prefix) "-y")) (str label " y") false]]))
(defn- correction-value [d prefix]
(if (= [:xform :rot] (:path d))
(some-> (get d prefix) (* (/ js/Math.PI 180)))
[(get d (keyword (str (name prefix) "-x")))
(get d (keyword (str (name prefix) "-y")))]))
(defn- correction-spec [d]
(let [base {:support [(:from d) (when (number? (:through d)) (inc (:through d)))]
:motion (:motion d)}]
(case (:motion d)
:constant (assoc base :delta (correction-value d :delta))
:ramp (assoc base :start (correction-value d :start)
:end (correction-value d :end))
:return (assoc base :start (correction-value d :start)
:peak (correction-value d :peak)
:peak-frame (:peak-frame d))
base)))
(defn- correction-layers [clip sid id]
(for [[path c] (get-in clip [:symbols sid :nodes id :channels])
l (:over c)]
{:path path :layer l}))
(defn- correction-section [[sid selected-id selected]]
(let [clip @(rf/subscribe [::render/clip])
parent (get-in clip [:symbols sid :nodes (:parent selected)])
targets (cond
(node/lane? selected) [selected-id]
(node/lane? parent) [selected-id (:id parent)]
:else [])]
(when (seq targets)
(r/with-let [draft (r/atom (correction-initial clip sid selected-id))]
(let [target (:target @draft)
motion (:motion @draft)
conflicts (clip-domain/conflicts clip)
layers (correction-layers clip sid target)]
[section "corrections"
[:div.correction-grid
[:label.inspector-field "owner"
[:select {:value (or (first (keep-indexed #(when (= %2 target) %1) targets)) 0)
:on-change (fn [e]
(let [i (js/parseInt (.. e -target -value) 10)
id (nth targets i)]
(reset! draft (correction-initial clip sid id))))}
(doall (for [[i id] (map-indexed vector targets)]
^{:key (str id)}
[:option {:value i}
(str (if (= id selected-id) "selected · " "lane · ") (brief id))]))]]
[:label.inspector-field "property"
[:select {:value (if (= [:xform :rot] (:path @draft)) "rotation" "position")
:on-change #(swap! draft assoc :path
(if (= "rotation" (.. % -target -value))
[:xform :rot] [:xform :pos]))}
[:option {:value "rotation"} "rotation offset"]
[:option {:value "position"} "position offset"]]]
[:label.inspector-field "motion"
[:select {:value (name motion)
:on-change #(swap! draft assoc :motion (keyword (.. % -target -value)))}
[:option {:value "constant"} "constant"]
[:option {:value "ramp"} "ramp"]
[:option {:value "return"} "return"]]]
[:div]
[draft-number draft :from "from owner frame" true]
[draft-number draft :through "through owner frame" true]
(case motion
:constant [value-inputs draft :delta "offset"]
:ramp [:<> [value-inputs draft :start "start offset"]
[value-inputs draft :end "end offset"]]
:return [:<> [value-inputs draft :start "start offset"]
[value-inputs draft :peak "peak offset"]
[draft-number draft :peak-frame "peak owner frame" true]]
nil)]
[:div.row {:style {:margin-top "6px"}}
[:button {:on-click #(rf/dispatch [::ui/add-correction sid target
(:path @draft) (correction-spec @draft)])}
"apply correction"]]
(when (seq layers)
[:div.correction-list
(doall
(for [{:keys [path layer]} layers]
^{:key (str path (:id layer))}
[:div.correction-item
[:span {:title (pr-str (:id layer))}
(str (str/join " " (map name path)) " · "
(pr-str (:support layer))
(when (:conflict layer) " · conflict"))]
(when (:conflict layer)
[:button {:on-click #(rf/dispatch [::ui/retry-correction
sid target path (:id layer)])}
"retry"])
[:button {:on-click #(rf/dispatch [::ui/remove-correction
sid target path (:id layer)])}
"remove"]]))])
(when (seq conflicts)
[:div.correction-conflicts
[:div.dim "document conflicts"]
(doall
(for [{:keys [symbol node channel id why]} conflicts]
^{:key (str symbol node channel id)}
[:div {:title why} (str (brief node) " · "
(str/join " " (map name channel)) " · " why)]))])])))))
;; ---------------------------------------------------------------------------
;; tracing a face
;;
@ -455,6 +588,8 @@
[:div {:style {:min-height 0}}
[clip-section]
(when node [node-section node])
(when node ^{:key (str (first node) "/" (second node))}
[correction-section node])
(when (and face (or (trace/traceable? clip face) (seq faces)))
[tracing-section face faces path])
(when (= :symbol (first selection)) [symbol-section (second selection)])

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

@ -682,14 +682,16 @@
It reuses `rows`, so its spans and selection addresses are exactly the ones
the timeline presents rather than a second interpretation of the document."
[clip sid frames]
(mapv (fn [{:keys [path label cels]}]
(mapv (fn [{:keys [path label cels select]}]
{:id (peek path)
:path path
:select select
:label label
:cells (mapv (fn [f]
(let [cel (some (fn [{[in out] :span :as cel}]
(when (and (<= in f) (< f out)) cel))
cels)]
{:frame f :lane (peek path) :cel cel}))
{:frame f :lane (peek path) :lane-select select :cel cel}))
(range frames))})
(filter :cels (rows clip sid #{}))))
@ -704,8 +706,11 @@
(str "52px repeat(" (max 1 (count columns)) ", minmax(110px, 1fr))")}]
[:div.cel-sheet {:style style}
[:div.cs-head.cs-frame "frame"]
(doall (for [{:keys [id label]} columns]
^{:key (str "head-" id)} [:div.cs-head label]))
(doall (for [{:keys [path label select]} columns]
^{:key (str "head-" path)}
[:button.cs-head {:class (when (= select selection) "selected")
:on-click #(rf/dispatch [::ui/select select])}
label]))
(doall
(for [f (range frames)
item (cons {:frame-label? true}
@ -714,7 +719,8 @@
^{:key (str "frame-" f)}
[:button.cs-frame {:class (when (= f frame) "on")
:on-click #(rf/dispatch [::pb/seek f])} f]
(let [{:keys [id label select]} (:cel item)]
(let [{:keys [id label select]} (:cel item)
target (or select (:lane-select item))]
^{:key (str f "-" (:lane item) "-" (or id "gap"))}
[:button.cs-cell
{:class (str (when (= f frame) " current")
@ -722,7 +728,7 @@
:title (if id (str label " · frame " f) (str "gap · frame " f))
:on-click (fn []
(rf/dispatch [::pb/seek f])
(when select (rf/dispatch [::ui/select select])))}
(rf/dispatch [::ui/select target]))}
(or label "—")]))))]))
(defn view []

24
frontend/test/arthur/domain/channel_test.cljs
View file

@ -287,6 +287,30 @@
"a covering replacement establishes the shape seen by later layers")
(is (= [2 3 4] (ch/value-at (corrected base put3 add3) 0 nil)))))
(deftest stack-compatibility-follows-adjacent-replacements-and-skips-conflicts
(let [base (ch/framed [0 0])
left (ch/layer :left [0 2] :replace (ch/framed [1 2 3]))
right (ch/layer :right [2 4] :replace (ch/framed [4 5 6]))
add3 (ch/layer :add [0 4] :offset (ch/framed [1 1 1]))
valid (corrected base left right add3)
broken (corrected base (assoc left :conflict "skip it") right add3)]
(is (empty? (ch/problems valid))
"adjacent replacements jointly prevent the base shape reaching the offset")
(is (seq (ch/problems broken))
"a conflicted replacement is absent from the effective stack")
(is (empty? (ch/conflicts valid)))
(is (= [:left :add] (mapv :id (ch/conflicts broken))))))
(deftest reconciliation-recomputes-the-complete-stack-in-order
(let [old (assoc (ch/framed [0 0]) :over
[(assoc (ch/layer :put [0 3] :replace (ch/framed [1 2 3]))
:conflict "old")
(ch/layer :add [0 3] :offset (ch/framed [1 1 1]))])
layers (ch/reconcile old)]
(is (nil? (:conflict (first layers))) "a stale mark is cleared")
(is (nil? (:conflict (second layers))) "the later offset sees that replacement")
(is (= [2 3 4] (ch/value-at (assoc old :over layers) 1 nil)))))
(deftest generated-base-time-and-authored-correction-time-can-differ
(let [c (corrected (ch/keyed {0 0, 2 20} :hold)
(ch/layer :nudge [1 2] :offset (ch/framed 3)))

86
frontend/test/arthur/domain/correction_test.cljs Normal file
View file

@ -0,0 +1,86 @@
(ns arthur.domain.correction-test
(:require [cljs.test :refer [deftest is testing]]
[arthur.domain.channel :as ch]
[arthur.domain.clip :as clip]
[arthur.domain.correction :as correction]
[arthur.domain.leaf :as leaf]
[arthur.domain.lane-test :as fixture]))
(defn- channel [doc id path]
(get-in doc [:symbols :main :nodes id :channels path]))
(deftest authors-the-three-motions-as-ordinary-layer-channels
(let [doc (fixture/document)
constant (correction/add doc :main :girl [:xform :rot]
{:id :flat :support [2 5] :motion :constant :delta 1})
ramp (correction/add (:clip constant) :main :girl [:xform :rot]
{:id :ramp :support [6 9] :motion :ramp :start 0 :end 2})
returned (correction/add (:clip ramp) :main :girl [:xform :rot]
{:id :return :support [9 12] :motion :return
:start 0 :peak 3 :peak-frame 10})
c (channel (:clip returned) :girl [:xform :rot])]
(is (= :girl (:selection returned)))
(is (= [:flat :ramp :return] (mapv :id (:over c))))
(is (= [0 0 1 1 1 0 0 1 2 0 3 0]
(mapv #(ch/value-at c % nil) (range 12))))
(is (empty? (clip/problems (:clip returned))))))
(deftest materializes-defaults-and-refuses-incomplete-intent
(let [doc (fixture/document)
result (correction/add doc :main :a [:xform :rot]
{:id :nudge :support [0 3] :motion :return
:start 0 :peak 0.5 :peak-frame 1})]
(is (= 0.5 (ch/value-at (channel (:clip result) :a [:xform :rot]) 1 nil)))
(is (= (dissoc (get-in doc [:symbols :main :nodes :a]) :channels)
(dissoc (get-in (:clip result) [:symbols :main :nodes :a]) :channels)))
(doseq [spec [{:id :x :support [0 1] :motion :ramp :start 0 :end 1}
{:id :x :support [0 2] :motion :return :start 0 :peak 1 :peak-frame 1}
{:id :x :support [0 3] :motion :constant :delta js/NaN}
{:id :x :support [0 3] :motion :constant :delta [1 2]}]]
(let [r (correction/add doc :main :a [:xform :rot] spec)]
(is (:refused r))
(is (not (contains? r :clip)))))))
(deftest removal-and-retry-never-leave-an-invalid-stack
(let [doc (fixture/document)
base (ch/framed [0 0])
put3 (ch/layer :put3 [0 2] :replace (ch/framed [1 2 3]))
add3 (ch/layer :add3 [0 2] :offset (ch/framed [1 1 1]))
stacked (assoc base :over [put3 add3])
doc (assoc-in doc [:symbols :main :nodes :girl :channels [:xform :pos]] stacked)]
(is (:refused (correction/remove-layer doc :main :girl [:xform :pos] :put3))
"removing the replacement would expose a wrong-shaped base")
(let [conflicted (assoc-in doc [:symbols :main :nodes :girl :channels [:xform :pos] :over 1 :conflict]
"old topology")
retried (correction/retry-layer conflicted :main :girl [:xform :pos] :add3)]
(is (:clip retried))
(is (nil? (get-in (:clip retried)
[:symbols :main :nodes :girl :channels [:xform :pos] :over 1 :conflict]))))
(let [without-replacement (-> doc
(assoc-in [:symbols :main :nodes :girl :channels [:xform :pos] :over]
[(assoc add3 :conflict "old topology")]))]
(is (:refused (correction/retry-layer without-replacement :main :girl
[:xform :pos] :add3))
"retry refuses when the current effective base still has the wrong shape"))))
(deftest a-cel-correction-travels-with-its-owner
(let [doc (fixture/document)
result (correction/add doc :main :b [:xform :pos]
{:id :nudge :support [1 3] :motion :constant :delta [4 0]})
c (channel (:clip result) :b [:xform :pos])]
(is (= [6 0] (ch/value-at c 1 nil)))
(is (= [0 0] (ch/value-at c 0 nil)))
(is (= [2 0] (ch/value-at c 3 nil)))))
(deftest corrections-round-trip-with-identity-support-and-order
(let [doc (fixture/document)
one (:clip (correction/add doc :main :girl [:xform :rot]
{:id :one :support [0 3] :motion :constant :delta 1}))
two (:clip (correction/add one :main :girl [:xform :rot]
{:id :two :support [3 6] :motion :ramp
:start 0 :end 2}))
back (leaf/clip "u" (leaf/leaves "u" two))]
(is (= two back))
(is (= [:one :two]
(mapv :id (get-in back [:symbols :main :nodes :girl
:channels [:xform :rot] :over]))))))

23
frontend/test/arthur/events/lane_test.cljs
View file

@ -1,6 +1,7 @@
(ns arthur.events.lane-test
(:require [cljs.test :refer [deftest is]]
[arthur.domain.lane-test :as fixture]
[arthur.domain.correction :as correction]
[arthur.domain.lane :as lane]
[arthur.events.ui :as ui]
[arthur.domain.history :as history]
@ -24,6 +25,8 @@
column (first (timeline/cel-sheet doc :main 12))
cells (:cells column)]
(is (= :girl (:id column)))
(is (= [:node :main :girl [:girl]] (:select column)))
(is (every? #(= (:select column) (:lane-select %)) cells))
(is (= [:a :b :insert] (mapv #(get-in cells [% :cel :id]) [0 4 8])))
(is (= [[:node :main :a [:a]]
[:node :main :b [:b]]
@ -65,3 +68,23 @@
(is (= (:clip r1) (leaf/clip "u" (:leaves undo))))
(is (= doc (leaf/clip "u" (:leaves undo2))))
(is (= [:node :main :a [:a]] (get-in db2 [:ui :selection]))))))
(deftest a-correction-is-one-step-and-keeps-the-full-selection-address
(let [doc (fixture/document)
id (store/install! {:clip doc :store {}} "correction-event-test")
selection [:node :main :a [:outer :a]]
db {:clip/current id :paint/revision 0
:ui {:open :outer :selection selection}}
result (correction/add doc :main :a [:xform :rot]
{:id :nudge :support [0 3] :motion :return
:start 0 :peak 0.5 :peak-frame 1})
after (ui/apply-correction-command db result)
entry (store/entry id)]
(is (= selection (get-in after [:ui :selection])))
(is (= 1 (count (get-in entry [:history :done]))))
(is (= 0.5 (get-in (:clip entry)
[:symbols :main :nodes :a :channels [:xform :rot]
:over 0 :values :keys 1])))
(let [refused (ui/apply-correction-command after {:refused "nope"})]
(is (= "nope" (get-in refused [:project :status])))
(is (= 1 (count (get-in (store/entry id) [:history :done])))))))

46
frontend/test/browser/lane.mjs
View file

@ -255,10 +255,54 @@ try {
assert.deepEqual(placed(s), [[0, 3], [3, 4], [6, 7], [7, 8], [8, 9]],
'a command selected in the sheet has the timeline command semantics');
assert.equal(s.history.done.length, before.history.done.length + 9);
// Correction authoring is reachable from the same selection. The range is
// in this cel's own frames and Apply is one isolated history transaction.
assert(await evaluate(`(() => {
const section = [...document.querySelectorAll('.section')]
.find(s => s.querySelector('h2')?.textContent.trim() === 'corrections');
const label = [...section.querySelectorAll('label')]
.find(l => l.textContent.trim().startsWith('offset (degrees)'));
const input = label?.querySelector('input');
if (!input) return false;
const set = Object.getOwnPropertyDescriptor(HTMLInputElement.prototype, 'value').set;
set.call(input, '15');
input.dispatchEvent(new Event('input', {bubbles: true}));
input.dispatchEvent(new Event('change', {bubbles: true}));
return true;
})()`), 'rotation correction value is editable');
await sleep(100);
await click('apply correction');
s = await shot();
const selectedCel = instances(s).find(n => n.time.at === 0);
const rot = Object.values(selectedCel.channels).find(c => c.over?.length);
assert.equal(rot.over.length, 1);
assert(Math.abs(rot.over[0].values.value - Math.PI / 12) < 1e-9,
'the inspector converts the authored degree offset to radians');
assert.equal(s.history.done.length, before.history.done.length + 10);
// A gap targets its column's lane. This catches the stale-selection bug that
// only appears once a sheet has more than one lane.
await click('timeline');
assert.equal(await evaluate('document.querySelectorAll(".tl-cel").length'), 5);
await click('+ lane');
await click('cel sheet');
assert.equal(await evaluate('document.querySelectorAll(".cs-head:not(.cs-frame)").length'), 2);
await evaluate(`([...document.querySelectorAll('.cs-cell')].slice(0, 2)
.find(c => c.textContent.trim() !== '—')).click()`);
await sleep(100);
await evaluate(`([...document.querySelectorAll('.cs-cell')].slice(0, 2)
.find(c => c.textContent.trim() === '—')).click()`);
await sleep(100);
await click('overwrite');
s = await shot();
assert(Object.values(s.clip.symbols.main.nodes)
.some(n => n.kind === 'instance' && n.parent !== 'girl' && n.time.at === 0),
'clicking a gap selects that column before overwrite');
assert.equal(s.history.done.length, before.history.done.length + 12,
'correction, lane creation, and overwrite are separate undo steps');
assert.equal(errors.length, 0, JSON.stringify(errors));
console.log('PASS: lane commands agree from timeline and cel sheet; no server writes');
console.log('PASS: lane commands and corrections agree from timeline and cel sheet; no server writes');
} finally {
if (ws?.readyState === WebSocket.OPEN) {
ws.send(JSON.stringify({ id: 999999, method: 'Browser.close' }));