correction things

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

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]))}))

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]]

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])

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])]]))

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)))))

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})))))