Add polygon painting with per-gap drawing keys

frontend/src/arthur/core.cljs

@@ -6,6 +6,7 @@
   (:require [arthur.db :as db]
             [arthur.events.footage :as footage]
             [arthur.events.playback]
+            [arthur.events.paint]
             [arthur.events.project]
             [arthur.subs.playback]
             [arthur.subs.render]

frontend/src/arthur/db.cljs

@@ -55,6 +55,7 @@
 (def default
   {;; --- the document ---
    :clip/current :take
+   :paint/revision 0
    :palette :arthur/default          ; a NAME; the ramp itself is project data
 
    ;; --- the clip ---

frontend/src/arthur/domain/channel.cljs

@@ -169,9 +169,15 @@
 ;; ---------------------------------------------------------------------------
 ;; the specification
 
+(defn segment-interp
+  "How the key at `left` leads to the next key. A channel default remains useful
+  for uniform tracks; :segments overrides only the gaps an artist chose."
+  [ch left]
+  (get (:segments ch) left (:interp ch)))
+
 (defn- interpolate [ch f left right]
   (let [a (get (:keys ch) left)]
-    (if (and (= :linear (:interp ch)) right (>= f left) (> right left))
+    (if (and (= :linear (segment-interp ch left)) right (>= f left) (> right left))
       (let [b (get (:keys ch) right)
             t (/ (- f left) (- right left))]
         (if (vector? a)
@@ -302,7 +308,9 @@
                                 (every? (fn [v] (and (vector? v)
                                                      (= (count v) (count first-value))
                                                      (every? number? v)))
-                                        values)))]
+                                        values)))
+        linear? (or (= :linear (:interp ch))
+                    (some #{:linear} (vals (:segments ch))))]
    (cond-> []
     (not (map? ch))
     (conj "not a map")
@@ -326,7 +334,14 @@
     (and (map? ch) (:animated? ch) (not (#{:hold :linear nil} (:interp ch))))
     (conj (str ":interp " (:interp ch) " is not implemented"))
 
-    (and (map? ch) (= :linear (:interp ch))
+    (and (map? ch) (contains? ch :segments)
+         (or (not (map? (:segments ch)))
+             (not (:keys ch))
+             (not (every? (set (keys (:keys ch))) (keys (:segments ch))))
+             (not (every? #{:hold :linear} (vals (:segments ch))))))
+    (conj ":segments must map existing key frames to :hold or :linear")
+
+    (and (map? ch) linear?
          (or (:dense ch) (not linear-values?)))
     (conj ":linear interpolation needs numeric keys of one shape")
 

frontend/src/arthur/domain/paint.cljs

@@ -0,0 +1,57 @@
+(ns arthur.domain.paint
+  "Small authored polygon operations. Paint nodes read timeline frames directly;
+  the roto root's exposure and picture sampling must not quantise a hand edit."
+  (:require [arthur.domain.channel :as channel]))
+
+(def geometry [:geom :pts])
+
+(defn shapes [clip]
+  (->> (get-in clip [:timelines :main :nodes])
+       (filter (fn [[_ node]] (:paint? node)))
+       (sort-by (comp :z val))
+       vec))
+
+(defn active-frame [ch frame]
+  (let [frames (sort (keys (:keys ch)))]
+    (or (last (take-while #(<= % frame) frames)) (first frames))))
+
+(defn new-shape [clip id frame points color]
+  (let [end (get-in clip [:timelines :main :frames])
+        z (str "z" (js/Date.now) "-" (name id))]
+    (if (and (<= 0 frame) (< frame end) (>= (count points) 6)
+             (even? (count points)))
+      (assoc-in clip [:timelines :main :nodes id]
+                {:id id :name (str "shape " (inc (count (shapes clip))))
+                 :kind :poly :paint? true :parent nil :z z
+                 :span [frame end]
+                 :channels {geometry (channel/keyed {frame points})
+                            [:style :color] (channel/framed color)}})
+      clip)))
+
+(defn add-key [clip id frame]
+  (let [path [:timelines :main :nodes id]
+        node (get-in clip path)
+        ch (get-in node [:channels geometry])
+        [start end] (:span node)]
+    (if (and (:paint? node) (<= start frame) (< frame end) ch)
+      (assoc-in clip (into path [:channels geometry :keys frame])
+                (vec (channel/value-at ch frame)))
+      clip)))
+
+(defn set-vertex [clip id key-frame vertex [x y]]
+  (let [path [:timelines :main :nodes id :channels geometry :keys key-frame]
+        points (get-in clip path)
+        i (* 2 vertex)]
+    (if (and points (< (inc i) (count points)))
+      (assoc-in clip path (-> points (assoc i x) (assoc (inc i) y)))
+      clip)))
+
+(defn set-segment-interp [clip id key-frame interp]
+  (let [node (get-in clip [:timelines :main :nodes id])
+        keys (get-in node [:channels geometry :keys])]
+    (if (and (:paint? node) (contains? keys key-frame)
+             (some #(< key-frame %) (clojure.core/keys keys))
+             (#{:hold :linear} interp))
+      (assoc-in clip [:timelines :main :nodes id :channels geometry
+                      :segments key-frame] interp)
+      clip)))

frontend/src/arthur/events/paint.cljs

@@ -0,0 +1,33 @@
+(ns arthur.events.paint
+  (:require [arthur.domain.paint :as paint]
+            [arthur.footage.store :as store]
+            [re-frame.core :as rf]))
+
+(defn- edit [db f]
+  (let [id (store/edit-clip! (:clip/current db) f)]
+    (if id
+      (-> db
+          (assoc :clip/current id)
+          (update :paint/revision (fnil inc 0))
+          (update :project merge {:status "paint edited · unsaved"}))
+      db)))
+
+(rf/reg-event-db
+ ::new-shape
+ (fn [db [_ id points color]]
+   (edit db #(paint/new-shape % id (get-in db [:playback :frame]) points color))))
+
+(rf/reg-event-db
+ ::add-key
+ (fn [db [_ id]]
+   (edit db #(paint/add-key % id (get-in db [:playback :frame])))))
+
+(rf/reg-event-db
+ ::set-vertex
+ (fn [db [_ id key-frame vertex point]]
+   (edit db #(paint/set-vertex % id key-frame vertex point))))
+
+(rf/reg-event-db
+ ::set-segment-interp
+ (fn [db [_ id key-frame interp]]
+   (edit db #(paint/set-segment-interp % id key-frame interp))))

frontend/src/arthur/footage/store.cljs

@@ -31,3 +31,13 @@
   (if (= id (:id @loaded))
     @loaded
     (db/clip-entry id)))
+
+(defn edit-clip!
+  "Edit the loaded document. Built-in clips are copied into the runtime store
+  on first edit, so their delayed source values remain reusable."
+  [id f]
+  (if (= id (:id @loaded))
+    (do (swap! loaded update :clip f) id)
+    (let [entry (entry id)]
+      (when entry
+        (install! (update entry :clip f) "paint")))))

frontend/src/arthur/subs/render.cljs

@@ -15,11 +15,13 @@
             [re-frame.core :as rf]))
 
 (rf/reg-sub ::clip-id (fn [db _] (:clip/current db)))
+(rf/reg-sub ::paint-revision (fn [db _] (:paint/revision db)))
 
 (rf/reg-sub
  ::clip
  :<- [::clip-id]
- (fn [id _] (:clip (footage/entry id))))
+ :<- [::paint-revision]
+ (fn [[id _] _] (:clip (footage/entry id))))
 
 (rf/reg-sub
  ::timeline

frontend/src/arthur/ui/paint.cljs

@@ -0,0 +1,149 @@
+(ns arthur.ui.paint
+  "Polygon authoring overlay. The raster canvas remains the playback sink; SVG
+  supplies only editor handles and an unfinished outline."
+  (:require [arthur.domain.channel :as channel]
+            [arthur.domain.paint :as paint]
+            [arthur.domain.palette :as palette]
+            [arthur.events.paint :as events]
+            [arthur.events.playback :as pb]
+            [arthur.subs.playback :as playback]
+            [arthur.subs.render :as render]
+            [re-frame.core :as rf]
+            [reagent.core :as r]))
+
+(defonce ^:private selected (r/atom nil))
+(defonce ^:private drawing? (r/atom false))
+(defonce ^:private draft (r/atom []))
+(defonce ^:private tone (r/atom :skin-base))
+(defonce ^:private dragging (atom nil))
+
+(defn- point [event w h]
+  (let [box (.getBoundingClientRect (.-currentTarget event))]
+    [(-> (/ (* (- (.-clientX event) (.-left box)) w) (.-width box))
+         js/Math.round (max 0) (min (dec w)))
+     (-> (/ (* (- (.-clientY event) (.-top box)) h) (.-height box))
+         js/Math.round (max 0) (min (dec h)))]))
+
+(defn- pairs [pts]
+  (mapv vec (partition 2 pts)))
+
+(defn- points-text [pts]
+  (apply str (interpose " " (map (fn [[x y]] (str x "," y)) (pairs pts)))))
+
+(defn- begin! []
+  (reset! selected nil)
+  (reset! draft [])
+  (reset! drawing? true))
+
+(defn- finish! []
+  (when (>= (count @draft) 6)
+    (let [id (keyword (str "paint-" (random-uuid)))]
+      (rf/dispatch [::events/new-shape id @draft @tone])
+      (reset! selected id)
+      (reset! draft [])
+      (reset! drawing? false))))
+
+(defn toolbar []
+  (let [clip @(rf/subscribe [::render/clip])
+        frame @(rf/subscribe [::playback/frame])
+        shapes (paint/shapes clip)
+        ids (set (map first shapes))
+        id (when (contains? ids @selected) @selected)
+        shape (get-in clip [:timelines :main :nodes id])
+        geom (get-in shape [:channels paint/geometry])
+        active (when geom (paint/active-frame geom frame))
+        keys (when geom (sort (keys (:keys geom))))
+        next-key (first (filter #(> % active) keys))
+        tween? (= :linear (channel/segment-interp geom active))]
+    [:div.paint-tools
+     [:div.row
+      [:strong "paint"]
+      [:button {:class (when @drawing? "on") :on-click begin!} "new polygon"]
+      (when @drawing?
+        [:button {:disabled (< (count @draft) 6) :on-click finish!} "finish shape"])
+      (when @drawing?
+        [:button {:on-click #(do (reset! drawing? false) (reset! draft []))} "cancel"])
+      [:label "colour "
+       [:select {:value (name @tone)
+                 :on-change #(reset! tone (keyword (.. % -target -value)))}
+        (for [{:keys [name hex]} (rest palette/entries)]
+          ^{:key name} [:option {:value (clojure.core/name name)}
+                        (str (clojure.core/name name) " " hex)])]]]
+     [:div.row
+      [:label "shape "
+       [:select {:value (if id (name id) "")
+                 :on-change #(reset! selected (when-not (= "" (.. % -target -value))
+                                                (keyword (.. % -target -value))))}
+        [:option {:value ""} "select"]
+        (for [[shape-id node] shapes]
+          ^{:key shape-id} [:option {:value (name shape-id)} (:name node)])]]
+      (when id
+        [:button {:disabled (or (< frame (first (:span shape)))
+                                (contains? (:keys geom) frame))
+                  :on-click #(rf/dispatch [::events/add-key id])}
+         "new drawing key"])
+      (when (and id next-key)
+        [:label (str "key " active " → " next-key " ")
+         [:select {:value (name (or (channel/segment-interp geom active) :hold))
+                   :on-change #(rf/dispatch [::events/set-segment-interp id active
+                                              (keyword (.. % -target -value))])}
+          [:option {:value "hold"} "hold"]
+          [:option {:value "linear"} "tween shape"]]])]
+     (when (seq keys)
+       [:div.row
+        [:span "drawing keys "]
+        (for [f keys]
+          ^{:key f}
+          [:button {:class (when (= frame f) "on")
+                    :on-click #(rf/dispatch [::pb/seek f])}
+           (str f)])])
+     [:div.hint
+      (cond
+        @drawing? (str "Click vertices on the stage, then Finish shape. "
+                       (quot (count @draft) 2) " points")
+        (and id tween? (not (contains? (:keys geom) frame)))
+        "Tweening between drawings. Add a drawing key here, or jump to a key to edit its vertices."
+        id (str "Drag vertices to edit drawing key " active
+                ". New drawing key copies the visible shape at this frame. The transition control changes only the selected gap.")
+        :else "Create a polygon, or select one to edit its drawing keys.")]]))
+
+(defn overlay [w h zoom]
+  (let [clip @(rf/subscribe [::render/clip])
+        frame @(rf/subscribe [::playback/frame])
+        shape (get-in clip [:timelines :main :nodes @selected])
+        geom (get-in shape [:channels paint/geometry])
+        active (when geom (paint/active-frame geom frame))
+        visible? (and shape (let [[start end] (:span shape)] (<= start frame) (< frame end)))
+        pts (when visible? (channel/value-at geom frame))
+        editable? (or (not= :linear (channel/segment-interp geom active))
+                      (contains? (:keys geom) frame))]
+    [:svg.paint-overlay
+     {:width (* zoom w) :height (* zoom h)
+      :view-box (str "0 0 " w " " h)
+      :on-pointer-down (fn [event]
+                         (when @drawing?
+                           (let [[x y] (point event w h)]
+                             (swap! draft into [x y]))))
+      :on-pointer-move (fn [event]
+                         (when-let [[id key-frame vertex] @dragging]
+                           (rf/dispatch [::events/set-vertex id key-frame vertex
+                                         (point event w h)])))
+      :on-pointer-up (fn [_] (reset! dragging nil))
+      :on-pointer-cancel (fn [_] (reset! dragging nil))}
+     (when (seq @draft)
+       [:polyline {:points (points-text @draft) :fill "none"
+                   :stroke "#d0ba86" :stroke-width 1}])
+     (when (and visible? (not @drawing?) pts)
+       [:g
+        [:polygon {:points (points-text pts) :fill "none"
+                   :stroke "#e6ca8b" :stroke-width 1}]
+        (for [[i [x y]] (map-indexed vector (pairs (when editable? pts)))]
+          ^{:key i}
+          [:circle {:cx x :cy y :r 2.6 :fill "#fff1be"
+                    :stroke "#161820" :stroke-width 0.7
+                    :on-pointer-down (fn [event]
+                                       (.stopPropagation event)
+                                       (.preventDefault event)
+                                       (.setPointerCapture (.-currentTarget event)
+                                                           (.-pointerId event))
+                                       (reset! dragging [@selected active i]))}])])]))

frontend/src/arthur/ui/shell.cljs

@@ -16,6 +16,7 @@
             [arthur.subs.playback :as sub]
             [arthur.subs.render :as render]
             [arthur.ui.player :as player]
+            [arthur.ui.paint :as paint]
             [re-frame.core :as rf]
             [reagent.core :as r]))
 
@@ -299,15 +300,18 @@
   ;; store, so this being a re-render costs nothing per frame.
   (let [w @(rf/subscribe [::sub/width])
         h @(rf/subscribe [::sub/height])]
-    [:canvas.stage
-     {:ref   #(player/set-canvas! %)
-      :width w :height h
-      :style {:width (str (* zoom w) "px") :height (str (* zoom h) "px")}}]))
+    [:div.stage-wrap
+     [:canvas.stage
+      {:ref   #(player/set-canvas! %)
+       :width w :height h
+       :style {:width (str (* zoom w) "px") :height (str (* zoom h) "px")}}]
+     [paint/overlay w h zoom]]))
 
 (defn view []
   [:main
    [:h1 "arthur"]
    [stage]
+   [paint/toolbar]
    [audio]
    [transport]
    [exporter]