From eca1a96b82caa2171faa26e40ef70290bf101ffc Mon Sep 17 00:00:00 2001 From: Olive Vaughn Date: Sun, 4 Oct 2026 02:47:29 -0400 Subject: [PATCH] correction things --- frontend/src/arthur/domain/channel.cljs | 34 +++++- frontend/src/arthur/domain/correction.cljs | 79 ++++++++++++++ frontend/src/arthur/events/ui.cljs | 28 +++++ frontend/src/arthur/flow/regenerate.cljs | 7 +- frontend/src/arthur/ui/params.cljs | 102 ++++++++++++++++-- frontend/test/arthur/domain/channel_test.cljs | 34 ++++++ .../test/arthur/flow/regenerate_test.cljs | 59 ++++++++++ 7 files changed, 329 insertions(+), 14 deletions(-) diff --git a/frontend/src/arthur/domain/channel.cljs b/frontend/src/arthur/domain/channel.cljs index 6ce70f8..b4841b0 100644 --- a/frontend/src/arthur/domain/channel.cljs +++ b/frontend/src/arthur/domain/channel.cljs @@ -261,6 +261,14 @@ (throw (ex-info "a correction cannot offset a value of a different shape" {:base wb :correction wv :channel (dissoc ch :dense)}))))) +(defn- eye-opening-onto [points amount] + (let [n (width points) + ys (map #(component points %) (range 1 n 2)) + center (/ (+ (reduce min ys) (reduce max ys)) 2)] + (mapv (fn [i] (let [v (component points i)] + (if (odd? i) (+ center (* amount (- v center))) v))) + (range n)))) + (defn- over-at "Fold `ch`'s layers onto `base` at frame f. `read` samples one layer's values and is the only thing that differs between the specification and the cursor." @@ -279,6 +287,7 @@ ;; `replace` can supply a value over an absent base; `offset` has ;; nothing to add to and says so rather than inventing a pose. (nothing? v) absent + (= :eye-opening op) (eye-opening-onto v x) :else (offset-onto v x ch))))) base (vec (:over ch)))) @@ -389,6 +398,14 @@ right (first (drop-while #(<= % f) fr))] (interpolate ch f left right))) +(defn repair-frame + "Map a damaged frame to a donor in the current base. Latest interval wins; + donors are sampled directly, never recursively through other repairs." + [ch f] + (reduce (fn [frame {:keys [from through donor]}] + (if (<= from f through) donor frame)) + f (:repairs ch))) + (defn value-at "Sample a channel at frame f. THE SPECIFICATION — correct, allocating, and O(n) in the keys. `cursor`/`sample!` is what playback uses. @@ -401,7 +418,8 @@ says `nil` and means it." ([ch f store] (value-at ch f f store)) ([ch base-f correction-f store] - (let [base (cond + (let [base-f (repair-frame ch base-f) + base (cond (not (:animated? ch)) (:value ch) (:dense ch) (dense-at (:dense ch) base-f store nil) (:keys ch) (let [ks (:keys ch)] @@ -502,7 +520,7 @@ ([cur f] (sample! cur f f)) ([^Cursor cur base-f correction-f] (let [ch (.-ch cur) - base (base-sample! cur ch (.-ks cur) base-f)] + base (base-sample! cur ch (.-ks cur) (repair-frame ch base-f))] (if (seq (:over ch)) (over-at ch correction-f base (fn [i _ f] (sample! (nth (.-overs cur) i) f))) @@ -534,6 +552,14 @@ linear? (or (= :linear (:interp ch)) (some #{:linear} (vals (:segments ch))))] (cond-> [] + (and (contains? ch :repairs) + (not (and (vector? (:repairs ch)) + (every? (fn [{:keys [id from through donor]}] + (and id (every? integer? [from through donor]) + (<= 0 from through) (<= 0 donor))) + (:repairs ch))))) + (conj "repairs require an ID and nonnegative whole donor and interval frames") + (not (map? ch)) (conj "not a map") @@ -582,8 +608,8 @@ (conj (str ":support " (pr-str support) " must be a finite, increasing [in out)")) - (not (#{:offset :replace} op)) - (conj (str ":op " (pr-str op) " is not :offset or :replace")) + (not (#{:offset :replace :eye-opening} op)) + (conj (str ":op " (pr-str op) " is not :offset, :replace or :eye-opening")) ;; One level. A layer over a layer is an ordering mechanism ;; the stack already is, and it would make the read diff --git a/frontend/src/arthur/domain/correction.cljs b/frontend/src/arthur/domain/correction.cljs index ba99948..d4a9b39 100644 --- a/frontend/src/arthur/domain/correction.cljs +++ b/frontend/src/arthur/domain/correction.cljs @@ -112,3 +112,82 @@ (fn [layers] (mapv #(if (= layer-id (:id %)) (dissoc % :conflict) %) layers))) node-id)))) + +(defn borrow-pose [document sid {:keys [from through donor head?] :as spec} store] + (let [frames (get-in document [:symbols sid :frames]) + ids (into #{} (mapcat :nodes) + (filter #(= sid (:symbol %)) (vals (:features document)))) + ids (cond-> ids head? (conj :head)) + paths (for [id ids [path c] (get-in document [:symbols sid :nodes id :channels])] + [id path c])] + (cond + (not (and (integer? frames) (every? integer? [from through donor]) + (<= 0 from through (dec frames)) (<= 0 donor (dec frames)))) + {:refused "choose whole face frames within this symbol"} + (<= from donor through) {:refused "choose a clean donor outside the repair interval"} + (empty? paths) {:refused "this symbol has no tracked face features"} + (not-any? (fn [[_ path c]] + (and (= path [:geom :pts]) + (not (ch/nothing? (ch/value-at (dissoc c :repairs :over) donor store))))) + paths) + {:refused "the donor has no face pose; choose another frame"} + :else + (finish (reduce (fn [doc [node path _]] + (update-in doc [:symbols sid :nodes node :channels path :repairs] + (fnil conj []) (select-keys spec [:id :from :through :donor]))) + document paths) nil)))) + +(declare remove-eye-keys) + +(defn remove-repair [document sid repair-id] + {:clip (reduce (fn [doc [id path]] + (update-in doc [:symbols sid :nodes id :channels path :repairs] + #(vec (remove (fn [r] (= repair-id (:id r))) %)))) + (-> document + (remove-eye-keys sid repair-id :l) :clip + (remove-eye-keys sid repair-id :r) :clip) + (for [[id n] (get-in document [:symbols sid :nodes]) + [path c] (:channels n) :when (:repairs c)] [id path]))}) + +(defn eye-key + "Key a procedural lid adjustment and gaze offset over one repair interval." + [document sid repair-id side frame {:keys [opening gaze-x gaze-y]}] + (let [outer (keyword (str "eye-" (name side))) + inner (keyword (str "eye-" (name side) "-in")) + iris (keyword (str "iris-" (name side))) + repair (some #(when (= repair-id (:id %)) %) + (get-in document [:symbols sid :nodes outer :channels [:geom :pts] :repairs])) + {:keys [from through]} repair + layer-id (str repair-id "/eye/" (name side)) + edits [[outer [:geom :pts] :eye-opening opening 1] + [inner [:geom :pts] :eye-opening opening 1] + [iris [:xform :pos] :offset [gaze-x gaze-y] [0 0]]]] + (cond + (nil? repair) {:refused "this eye has no such repair interval"} + (not (and (integer? frame) (<= from frame through))) + {:refused "move the playhead inside this repair interval"} + (not (and (every? finite? [opening gaze-x gaze-y]) (<= 0 opening 3))) + {:refused "eye opening must be between 0 and 3; gaze offsets must be finite"} + :else + (finish + (reduce + (fn [doc [id path op value neutral]] + (update-in doc [:symbols sid :nodes id :channels path :over] + (fn [layers] + (let [existing (some #(when (= layer-id (:id %)) %) layers) + values (or (:values existing) + (ch/keyed {from neutral through neutral} :linear)) + layer (ch/layer layer-id [from (inc through)] op + (assoc-in values [:keys frame] value))] + (conj (vec (remove #(= layer-id (:id %)) layers)) layer))))) + document edits) + nil)))) + +(defn remove-eye-keys [document sid repair-id side] + (let [layer-id (str repair-id "/eye/" (name side))] + {:clip (reduce (fn [doc [id path]] + (update-in doc [:symbols sid :nodes id :channels path :over] + #(vec (remove (fn [l] (= layer-id (:id l))) %)))) + document + (for [[id n] (get-in document [:symbols sid :nodes]) + [path c] (:channels n) :when (:over c)] [id path]))})) diff --git a/frontend/src/arthur/events/ui.cljs b/frontend/src/arthur/events/ui.cljs index 7e148f1..9a7b107 100644 --- a/frontend/src/arthur/events/ui.cljs +++ b/frontend/src/arthur/events/ui.cljs @@ -135,6 +135,34 @@ (edit/transaction (constantly (:clip result))) (update :project merge {:status "edited · unsaved"})))) +(rf/reg-event-db + ::eye-key + (fn [db [_ sid repair-id side frame values]] + (apply-correction-command + db (correction/eye-key (:clip (store/entry (:clip/current db))) + sid repair-id side frame values)))) + +(rf/reg-event-db + ::remove-eye-keys + (fn [db [_ sid repair-id side]] + (apply-correction-command + db (correction/remove-eye-keys (:clip (store/entry (:clip/current db))) + sid repair-id side)))) + +(rf/reg-event-db + ::borrow-pose + (fn [db [_ sid spec]] + (let [entry (store/entry (:clip/current db))] + (apply-correction-command + db (correction/borrow-pose (:clip entry) sid + (assoc spec :id (random-uuid)) (:store entry)))))) + +(rf/reg-event-db + ::remove-repair + (fn [db [_ sid id]] + (apply-correction-command + db (correction/remove-repair (:clip (store/entry (:clip/current db))) sid id)))) + (rf/reg-event-db ::add-correction (fn [db [_ sid id path spec]] diff --git a/frontend/src/arthur/flow/regenerate.cljs b/frontend/src/arthur/flow/regenerate.cljs index 9a33497..5c199b5 100644 --- a/frontend/src/arthur/flow/regenerate.cljs +++ b/frontend/src/arthur/flow/regenerate.cljs @@ -46,9 +46,10 @@ that fits again has its mark cleared, because a regeneration that restores the topology has resolved it." [old fresh] - (if-let [over (seq (:over old))] + (let [fresh (cond-> fresh (:repairs old) (assoc :repairs (:repairs old)))] + (if-let [over (seq (:over old))] (assoc fresh :over (ch/reconcile (assoc fresh :over (vec over)))) - fresh)) + fresh))) (defn- bases "A node's channels without their corrections. @@ -58,7 +59,7 @@ re-measurement, or the first correction anyone makes would freeze the part it was meant to adjust." [channels] - (into {} (map (fn [[p c]] [p (dissoc c :over)])) channels)) + (into {} (map (fn [[p c]] [p (dissoc c :over :repairs)])) channels)) (defn- replace-feature [entry fragment fid] (let [paths (for [id (get-in entry [:clip :features fid :nodes]) diff --git a/frontend/src/arthur/ui/params.cljs b/frontend/src/arthur/ui/params.cljs index 054c837..780abbb 100644 --- a/frontend/src/arthur/ui/params.cljs +++ b/frontend/src/arthur/ui/params.cljs @@ -10,6 +10,7 @@ [arthur.domain.channel :as channel] [arthur.domain.feature :as feature] [arthur.domain.node :as node] + [arthur.domain.nest :as nest] [arthur.domain.palette :as pal] [arthur.domain.paint :as paint] [arthur.domain.params :as params] @@ -781,10 +782,97 @@ ;; --------------------------------------------------------------------------- +(defn- eye-repair-controls [sid {:keys [id from through]} current] + (let [clip @(rf/subscribe [::render/clip]) + in-range? (and (integer? current) (<= from current through))] + (r/with-let [draft (r/atom {:side :l :opening 1 :gaze-x 0 :gaze-y 0})] + (let [side (:side @draft) + layer-id (str id "/eye/" (name side)) + eye (keyword (str "eye-" (name side))) + iris (keyword (str "iris-" (name side))) + find-layer (fn [node path] + (some #(when (= layer-id (:id %)) %) + (get-in clip [:symbols sid :nodes node :channels path :over]))) + lids (find-layer eye [:geom :pts]) + gaze (find-layer iris [:xform :pos]) + load! (fn [] + (when in-range? + (let [opening (if lids (channel/value-at (:values lids) current nil) 1) + offset (if gaze (channel/value-at (:values gaze) current nil) [0 0])] + (swap! draft assoc :opening opening + :gaze-x (* 100 (first offset)) :gaze-y (* 100 (second offset))))))] + [:div {:style {:margin-top "8px"}} + [:div.dim "Eye adjustments · key a pose, then scrub and key another. Adjustments tween within this interval."] + [:label.inspector-field "eye" + [:select {:value (name side) + :on-change #(swap! draft assoc :side (keyword (.. % -target -value)))} + [:option {:value "l"} "left eye"] + [:option {:value "r"} "right eye"]]] + [draft-number draft :opening "lid opening (1 = donor, 0 = closed)" false] + [draft-number draft :gaze-x "gaze x (% of image height)" false] + [draft-number draft :gaze-y "gaze y (% of image height)" false] + [:div.row + [:button {:disabled (not in-range?) :on-click load!} "load current adjustment"] + [:button {:disabled (not in-range?) + :on-click #(rf/dispatch + [::ui/eye-key sid id side current + {:opening (:opening @draft) + :gaze-x (when (number? (:gaze-x @draft)) (/ (:gaze-x @draft) 100)) + :gaze-y (when (number? (:gaze-y @draft)) (/ (:gaze-y @draft) 100))}])} + (if in-range? (str "key eye at frame " current) "scrub inside interval to key eye")]] + (when lids + [:div.row + [:span.dim (str "eye keys: " (str/join ", " (sort (keys (get-in lids [:values :keys])))))] + [:button {:on-click #(rf/dispatch [::ui/remove-eye-keys sid id side])} "reset eye adjustments"]])])))) + +(defn- repair-section [sid path] + (let [status (:status @(rf/subscribe [::playback/project])) + clip @(rf/subscribe [::render/clip]) + store @(rf/subscribe [::render/store]) + open @(rf/subscribe [::render/open]) + frame @(rf/subscribe [::render/open-frame]) + inside (nest/inside clip store open path frame) + current (when (= sid (:sid inside)) (:frame inside)) + usable? (and (integer? current) + (<= 0 current (dec (get-in clip [:symbols sid :frames])))) + repairs (distinct (for [[_ n] (get-in clip [:symbols sid :nodes]) + [_ c] (:channels n) r (:repairs c)] r))] + (r/with-let [draft (r/atom {:from 0 :through 1 :donor 2 :head? false})] + [section "repair intervals" + [:div.dim "Hold a clean pose across damaged frames. Face settings still apply. Frame numbers are local to this face, starting at 0."] + (for [[field label] [[:from "from face frame"] + [:through "through face frame"] + [:donor "clean donor frame"]]] + ^{:key field} + [:div.row + [draft-number draft field label true] + [:button {:disabled (not usable?) + :title (if usable? (str "use face frame " current) + "move the playhead over this face") + :on-click #(swap! draft assoc field current)} + "use current frame"]]) + [:div.dim (if usable? (str "current face frame: " current) + "Move the playhead over this face to pick its current frame.")] + [:label [:input {:type "checkbox" :checked (:head? @draft) + :on-change #(swap! draft assoc :head? (.. % -target -checked))}] + " borrow head movement too"] + [:button {:on-click #(rf/dispatch [::ui/borrow-pose sid @draft])} "borrow pose"] + (when status [:div.dim {:role "status"} status]) + (for [{:keys [id from through donor] :as repair} repairs] + ^{:key (str id)} + [:div {:style {:margin-top "10px"}} + [:div.row + [:span (str from "–" through " ← frame " donor)] + [:button {:on-click #(rf/dispatch [::ui/remove-repair sid id])} "remove"]] + [eye-repair-controls sid repair current]])]))) + (defn view [] (let [clip @(rf/subscribe [::render/clip]) open @(rf/subscribe [::render/open]) selection @(rf/subscribe [::sub/selection]) + ;; Nothing selected inspects the symbol that is open, as clicking its + ;; tab would. + inspected (or selection [:symbol open]) node @(rf/subscribe [::sub/selected-node]) ;; The face the tracing section is about: the SELECTED PLACEMENT's symbol, ;; or, when the selection is not an instance or there is none, the OPEN @@ -800,8 +888,8 @@ palette-placement? (and node (= :palette-track (get-in clip [:symbols (first node) :type]))) - palette-symbol? (and (= :symbol (first selection)) - (= :palette (get-in clip [:symbols (second selection) :type]))) + palette-symbol? (and (= :symbol (first inspected)) + (= :palette (get-in clip [:symbols (second inspected) :type]))) face (or placed (when (face? clip open) open)) layer? (and placed (clip-domain/trace? (clip-domain/symbol clip placed))) ;; Where that face or layer sits, as a row path from the open symbol. A @@ -812,8 +900,7 @@ [:div.pane-head "inspector"] [:div {:style {:min-height 0}} (when palette-placement? [palette-placement-section node]) - (when (and (= :main open) - (or (nil? selection) (= [:symbol :main] selection))) + (when (= [:symbol (clip-domain/opens-on clip)] inspected) [clip-section]) (when (and node (not palette-placement?)) [node-section node]) (when (and placed (not palette-placement?)) [instance-playback node]) @@ -826,9 +913,10 @@ (first node) (second node) path]) (when (get-in clip [:symbols face :nodes :plate]) [face-section face path]) + (when (and face (face? clip face) (not layer?)) ^{:key (str "repair/" face)} [repair-section face path]) (when (and face (not layer?)) ^{:key (str "perf/" face)} [performance-section face]) - (when palette-symbol? [palette-symbol-section (second selection)]) - (when (and (= :symbol (first selection)) (not palette-symbol?)) - [symbol-section (second selection)]) + (when palette-symbol? [palette-symbol-section (second inspected)]) + (when (and (= :symbol (first inspected)) (not palette-symbol?)) + [symbol-section (second inspected)]) (when (and (seq tracking-owners) (not palette-placement?) (not palette-symbol?)) [tracking-section tracking-owners])]])) diff --git a/frontend/test/arthur/domain/channel_test.cljs b/frontend/test/arthur/domain/channel_test.cljs index fd3fc9d..8951aac 100644 --- a/frontend/test/arthur/domain/channel_test.cljs +++ b/frontend/test/arthur/domain/channel_test.cljs @@ -474,3 +474,37 @@ (is (= 2 (ch/value-shape (ch/keyed {0 [1 2], 4 [3 4]} :linear)))) (is (= :opaque (ch/value-shape (ch/keyed {0 :a} :hold)))) (is (nil? (ch/value-shape (ch/keyed {} :hold))) "nothing to read it off")) + +(deftest repair-borrows-current-base-and-keeps-target-corrections + (let [c (assoc (ch/keyed {0 10, 2 20, 4 40} :hold) + :repairs [{:id :repair :from 2 :through 3 :donor 0}] + :over [(ch/layer :nudge [2 4] :offset (ch/framed 5))]) + cursor (ch/cursor c nil)] + (is (= [10 15 15 40 15] + (mapv #(ch/value-at c % nil) [0 2 3 4 2]))) + (is (= [10 15 15 40 15] + (mapv #(ch/sample! cursor %) [0 2 3 4 2]))) + (is (= 35 (ch/value-at (assoc c :keys {0 30, 2 20, 4 40}) 2 nil))))) + +(deftest repair-fills-absent-base-without-recursing + (let [c (assoc (ch/keyed {0 10, 2 ch/absent, 4 40} :hold) + :repairs [{:from 2 :through 3 :donor 0} + {:from 0 :through 0 :donor 4}])] + (is (= 10 (ch/value-at c 2 nil))) + (is (= 40 (ch/value-at c 0 nil))) + (is (= 10 (ch/sample! (ch/cursor c nil) 3))))) + +(deftest lid-adjustment-is-procedural-and-does-not-mutate-dense-geometry + (let [points [0 0, 2 2, 4 0, 2 -2] + c (assoc (ch/framed points) + :over [(ch/layer :lids [2 5] :eye-opening + (ch/keyed {2 1, 4 0} :linear))]) + cur (ch/cursor c nil)] + (is (empty? (ch/problems c))) + (is (= points (ch/value-at c 1 nil))) + (is (= [0 0, 2 1, 4 0, 2 -1] (ch/value-at c 3 nil))) + (is (= [0 0, 2 0, 4 0, 2 0] (ch/sample! cur 4))) + (is (= [0 0, 2 1, 4 0, 2 -1] (ch/sample! cur 3))) + (is (= points (:value c))) + (is (= [0 0, 1 1, 2 0, 3 -1, 4 0] + (ch/value-at (assoc c :value [0 0, 1 2, 2 0, 3 -2, 4 0]) 3 nil))))) diff --git a/frontend/test/arthur/flow/regenerate_test.cljs b/frontend/test/arthur/flow/regenerate_test.cljs index 12b9ab0..e2ed875 100644 --- a/frontend/test/arthur/flow/regenerate_test.cljs +++ b/frontend/test/arthur/flow/regenerate_test.cljs @@ -4,6 +4,7 @@ [arthur.demo.stage :as stage] [arthur.domain.bring :as bring] [arthur.domain.channel :as ch] + [arthur.domain.correction :as correction] [arthur.domain.clip :as clip] [arthur.domain.params :as params] [arthur.domain.project :as project] @@ -381,3 +382,61 @@ (is (empty? (ch/conflicts (channel fine :mouth path)))) (is (empty? (clip/conflicts (:clip fine)))) (is (empty? (clip/problems (:clip fine))))))) + + +(deftest borrowed-pose-survives-parameter-regeneration + (let [result (correction/borrow-pose (:clip @initial) :face-1 + {:id :repair :from 10 :through 15 :donor 5 :head? true} + (:store @initial)) + repaired (assoc @initial :clip (:clip result)) + changed (regenerate/change repaired + {:scope :subject :id :face-1 :knob :anchor-avg :value 3}) + c (channel changed :head [:xform :pos]) + base (dissoc c :repairs :over)] + (is (nil? (:refused result))) + (is (= 1 (count (:repairs c)))) + (is (= (vec (ch/value-at base 5 (:store changed))) + (vec (ch/value-at c 12 (:store changed))))) + (is (empty? (:repairs (channel + (assoc changed :clip (-> (correction/remove-repair (:clip changed) :face-1 :repair) :clip)) + :head [:xform :pos])))))) + +(deftest borrow-allows-a-donor-with-no-teeth-contour + (let [doc (assoc-in (:clip @initial) + [:symbols :face-1 :nodes :teeth] + {:id :teeth :kind :poly :z "a9" + :channels {[:geom :pts] (ch/keyed {} :hold)}}) + doc (assoc-in doc [:features :test-teeth] + {:id :test-teeth :subject :face-1 :symbol :face-1 + :area :teeth :nodes [:teeth] :params {}}) + result (correction/borrow-pose doc :face-1 + {:id :repair :from 10 :through 15 :donor 5} + (:store @initial))] + (is (nil? (:refused result))) + (is (= 1 (count (get-in (:clip result) + [:symbols :face-1 :nodes :teeth :channels [:geom :pts] :repairs])))))) + +(deftest eye-keys-tween-over-borrowed-pose-and-survive-regeneration + (let [repair (correction/borrow-pose (:clip @initial) :face-1 + {:id :repair :from 10 :through 20 :donor 5} + (:store @initial)) + key1 (correction/eye-key (:clip repair) :face-1 :repair :l 10 + {:opening 1 :gaze-x 0 :gaze-y 0}) + key2 (correction/eye-key (:clip key1) :face-1 :repair :l 20 + {:opening 0 :gaze-x 0.02 :gaze-y -0.01}) + entry (assoc @initial :clip (:clip key2)) + changed (regenerate/change entry + {:scope :subject :id :face-1 :knob :contour-avg :value 3}) + lids (channel changed :eye-l [:geom :pts]) + iris (channel changed :iris-l [:xform :pos]) + removed (:clip (correction/remove-repair (:clip changed) :face-1 :repair))] + (is (nil? (:refused key1))) + (is (nil? (:refused key2))) + (is (= 1 (count (:over lids)))) + (is (= 0.5 (ch/value-at (:values (first (:over lids))) 15 nil))) + (is (= [0.01 -0.005] (ch/value-at (:values (first (:over iris))) 15 nil))) + (is (= (vec (ch/value-at lids 15 (:store changed))) + (vec (ch/sample! (ch/cursor lids (:store changed)) 15)))) + (is (empty? (get-in removed [:symbols :face-1 :nodes :eye-l :channels [:geom :pts] :over]))) + (is (:refused (correction/eye-key (:clip repair) :face-1 :repair :l 9 + {:opening 1 :gaze-x 0 :gaze-y 0})))))