Add multi-selection clipboard commands

frontend/src/arthur/domain/clipboard.cljs

@@ -0,0 +1,287 @@
+(ns arthur.domain.clipboard
+  "Pure multi-node clipboard commands.
+
+  A clipboard value is a detached forest of node maps. Normal copies keep symbol
+  references; `duplicate` with `:unique?` copies the complete referenced symbol
+  graph once for the whole forest. UI state, playhead conversion, and history
+  stay in events.ui. See docs/clipboard-plan.md."
+  (:require [arthur.domain.bring :as bring]
+            [arthur.domain.clip :as clip]
+            [arthur.domain.nest :as nest]
+            [arthur.domain.node :as node]
+            [arthur.domain.span :as span]
+            [arthur.domain.symbol :as symbol]))
+
+(defn- prefix? [a b]
+  (and (<= (count a) (count b)) (= a (subvec b 0 (count a)))))
+
+(defn- node-selections [clip selections]
+  (->> selections
+       (keep (fn [[kind sid id path :as address]]
+               (when (and (= :node kind) id (get-in clip [:symbols sid :nodes id]))
+                 {:address address :sid sid :id id :path (vec (or path [id]))})))
+       ;; One owned node reached through two shared occurrences is still one edit.
+       (reduce (fn [{:keys [seen out] :as acc} {:keys [sid id] :as x}]
+                 (if (contains? seen [sid id]) acc
+                   {:seen (conj seen [sid id]) :out (conj out x)}))
+               {:seen #{} :out []})
+       :out))
+
+(defn canonical
+  "Valid selected node occurrences, with anything visibly below another selected
+  occurrence omitted. Order is selection order and therefore keeps the primary
+  member last in the ordinary case."
+  [clip selections]
+  (let [xs (node-selections clip selections)]
+    (filterv (fn [{p :path}]
+               (not-any? (fn [{q :path}]
+                           (and (< (count q) (count p)) (prefix? q p)))
+                         xs))
+             xs)))
+
+(defn- subtree [nodes root]
+  (into {} (filter (fn [[id _]] (some #{root} (symbol/lineage nodes id)))) nodes))
+
+(defn snapshot
+  "Snapshot the canonical selected forest, or `{:refused why}`."
+  [clip selections]
+  (let [roots (canonical clip selections)]
+    (if (empty? roots)
+      {:refused "select something to copy"}
+      {:clipboard
+       {:items
+        (mapv (fn [{:keys [sid id path]}]
+                (let [nodes (get-in clip [:symbols sid :nodes])]
+                  {:sid sid :root id :path path :parent (:parent (get nodes id))
+                   :nodes (subtree nodes id)}))
+              roots)}})))
+
+(defn cut
+  "Delete a previously snapshotted forest. Snapshotting first is what makes cut
+  retain data even though its source nodes are gone."
+  [clip {:keys [items]}]
+  (let [after (reduce (fn [c {:keys [sid root]}] (nest/delete-node c sid root)) clip items)]
+    (if-let [why (first (clip/problems after))]
+      {:refused why}
+      {:clip after :selections []})))
+
+(defn- fresh
+  [taken fresh-id]
+  (loop [id (fresh-id)]
+    (if (contains? taken id) (recur (fresh-id)) id)))
+
+(defn- allocate
+  [clip items fresh-id]
+  (loop [pending (vec (mapcat (fn [[i item]] (map #(vector i %) (keys (:nodes item))))
+                               (map-indexed vector items)))
+         taken (into #{} (mapcat (comp keys :nodes val) (:symbols clip)))
+         ids {}]
+    (if-let [k (first pending)]
+      (let [id (fresh taken fresh-id)]
+        (recur (subvec pending 1) (conj taken id) (assoc ids k id)))
+      ids)))
+
+(defn- unique-content
+  [clip items unique?]
+  (let [roots (into #{} (comp (mapcat #(vals (:nodes %))) (keep node/source)) items)]
+    (if (and unique? (seq roots))
+      (let [{c :clip ids :ids} (bring/symbols clip clip roots {})]
+        [c ids])
+      [clip {}])))
+
+(defn- materialize
+  [clip items fresh-id unique? paste?]
+  (let [[clip source-ids] (unique-content clip items unique?)
+        ids (allocate clip items fresh-id)
+        made
+        (mapv
+         (fn [[i {:keys [sid root path parent nodes]}]]
+           (let [id-of #(get ids [i %])
+                 copied (into {}
+                              (map (fn [[old n]]
+                                     (let [id (id-of old)]
+                                       [id (cond-> (assoc n :id id)
+                                             (:parent n) (assoc :parent (id-of (:parent n)))
+                                             (:stencil n) (assoc :stencil (id-of (:stencil n)))
+                                             (node/source n)
+                                             (assoc-in [:source :symbol]
+                                                       (get source-ids (node/source n)
+                                                            (node/source n))))])))
+                              nodes)
+                 new-root (id-of root)
+                 ;; Paste reparents roots into one explicit destination.
+                 ;; Duplicate leaves them beside their originals.
+                 copied (assoc-in copied [new-root :parent]
+                                  (when-not paste? parent))]
+             {:source-sid sid :old-root root :path path :root new-root
+              :nodes copied}))
+         (map-indexed vector items))]
+    {:clip clip :items made}))
+
+(defn- shifted [n delta]
+  (if (node/placed-span n)
+    (update-in n [:time :at] (fnil + 0) delta)
+    n))
+
+(defn- top-zs [nodes n]
+  (let [base (or (last (sort (map #(or (:z %) "") (vals nodes)))) "")]
+    (map #(str base (apply str (repeat % "m"))) (range 1 (inc n)))))
+
+(defn- add-composition
+  [clip sid items at]
+  (let [starts (keep #(some-> (get-in % [:nodes (:root %)]) node/placed-span first) items)
+        anchor (when (seq starts) (apply min starts))
+        delta (if anchor (- at anchor) 0)
+        existing (get-in clip [:symbols sid :nodes])
+        zs (top-zs existing (count items))
+        nodes (reduce (fn [nodes [{:keys [root] copied :nodes} z]]
+                        (into nodes (assoc-in copied [root]
+                                             (-> (get copied root)
+                                                 (shifted delta)
+                                                 (assoc :z z)))))
+                      existing (map vector items zs))]
+    (assoc-in clip [:symbols sid :nodes] nodes)))
+
+(defn- add-lane
+  [clip sid items at fresh-id]
+  (let [roots (map #(get-in % [:nodes (:root %)]) items)
+        starts (map #(some-> % node/placed-span first) roots)
+        anchor (when (every? some? starts) (apply min starts))
+        intervals (when anchor
+                    (sort-by first
+                             (map (fn [n]
+                                    (let [[lo hi] (node/placed-span n)]
+                                      [(+ at (- lo anchor)) (+ at (- hi anchor))]))
+                                  roots)))
+        overlaps? (some (fn [[[a b] [c d]]] (and (< a d) (< c b)))
+                        (partition 2 1 intervals))]
+    (if (some nil? starts)
+      {:refused "a lane accepts copied things only when they have a finite span"}
+      (if overlaps?
+        {:refused "overlapping copied things cannot be pasted into one lane"}
+        (reduce
+         (fn [result item]
+           (if (:refused result)
+             (reduced result)
+             (let [c (:clip result)
+                   root (:root item)
+                   n (get-in item [:nodes root])
+                   desired (+ at (- (first (node/placed-span n)) anchor))
+                   r (span/place-node c sid n desired
+                                      {:extent :grow-symbol
+                                       :remainder-id (fresh (into #{} (keys (get-in c [:symbols sid :nodes])))
+                                                            fresh-id)})]
+               (if-let [made (:clip r)]
+                 {:clip (update-in made [:symbols sid :nodes]
+                                   into (dissoc (:nodes item) root))}
+                 r))))
+         {:clip clip} items)))))
+
+(defn paste
+  "Paste `clipboard` into `sid`, anchoring its first finite start at `at`.
+  `fresh-id` is supplied by the event so this domain command remains testable."
+  [clip clipboard sid at {:keys [fresh-id] :or {fresh-id random-uuid}}]
+  (cond
+    (nil? (clip/symbol clip sid)) {:refused "the paste target no longer exists"}
+    (not (and (integer? at) (not (neg? at))))
+    {:refused "the playhead is not on one frame of the paste target"}
+    (empty? (:items clipboard)) {:refused "there is nothing to paste"}
+    :else
+    (let [{base :clip items :items} (materialize clip (:items clipboard) fresh-id false true)
+          r (if (symbol/lane? (clip/symbol base sid))
+              (add-lane base sid items at fresh-id)
+              {:clip (add-composition base sid items at)})
+          made (:clip r)
+          why (when made (first (clip/problems made)))]
+      (cond
+        (:refused r) r
+        why {:refused why}
+        :else {:clip made :roots (mapv :root items)}))))
+
+(defn- add-duplicate-composition [clip sid items]
+  (let [existing (get-in clip [:symbols sid :nodes])
+        zs (top-zs existing (count items))]
+    (assoc-in clip [:symbols sid :nodes]
+              (reduce (fn [nodes [{:keys [root] copied :nodes} z]]
+                        (into nodes (assoc-in copied [root :z] z)))
+                      existing (map vector items zs)))))
+
+(defn- add-duplicate-lane
+  [clip sid items fresh-id]
+  (let [old-roots (map #(get-in clip [:symbols sid :nodes (:old-root %)]) items)
+        spans (map node/placed-span old-roots)
+        start (apply min (map first spans))
+        end (apply max (map second spans))
+        duration (- end start)
+        selected (set (map :old-root items))
+        shifted-clip
+        (update-in clip [:symbols sid :nodes]
+                   (fn [nodes]
+                     (reduce (fn [ns n]
+                               (let [lo (some-> (node/placed-span n) first)]
+                                 (if (and (nil? (:parent n))
+                                          (not (contains? selected (:id n)))
+                                          lo (>= lo end))
+                                 (update-in ns [(:id n) :time :at] (fnil + 0) duration)
+                                 ns)))
+                             nodes (vals nodes))))]
+    (reduce
+     (fn [result item]
+       (if (:refused result)
+         (reduced result)
+         (let [c (:clip result)
+               root (:root item)
+               n (get-in item [:nodes root])
+               old (get-in clip [:symbols sid :nodes (:old-root item)])
+               desired (+ (first (node/placed-span old)) duration)
+               r (span/place-node c sid n desired
+                                  {:extent :grow-symbol
+                                   :remainder-id (fresh (into #{} (keys (get-in c [:symbols sid :nodes])))
+                                                        fresh-id)})]
+           (if-let [made (:clip r)]
+             {:clip (update-in made [:symbols sid :nodes]
+                               into (dissoc (:nodes item) root))}
+             r))))
+     {:clip shifted-clip}
+     (sort-by #(first (node/placed-span
+                       (get-in clip [:symbols sid :nodes (:old-root %)]))) items))))
+
+(defn duplicate
+  "Duplicate a snapshot beside its sources. Direct finite children of lane
+  symbols repeat forward and ripple later cels; everything else copies in place.
+  With `:unique?`, referenced symbol graphs are deep-copied once for the batch."
+  [clip clipboard {:keys [fresh-id unique?] :or {fresh-id random-uuid}}]
+  (if (empty? (:items clipboard))
+    {:refused "select something to duplicate"}
+    (let [{base :clip items :items}
+          (materialize clip (:items clipboard) fresh-id unique? false)
+          groups (vals (group-by :source-sid items))
+          result
+          (reduce
+           (fn [result group]
+             (if (:refused result)
+               (reduced result)
+               (let [c (:clip result)
+                     sid (:source-sid (first group))
+                     lane? (symbol/lane? (clip/symbol c sid))
+                     [lane-items other]
+                     ((juxt filter remove)
+                      #(let [old (get-in clip [:symbols sid :nodes (:old-root %)])]
+                         (and lane? (nil? (:parent old)) (node/placed-span old)))
+                      group)
+                     c (if (seq other) (add-duplicate-composition c sid other) c)
+                     r (if (seq lane-items)
+                         (add-duplicate-lane c sid lane-items fresh-id)
+                         {:clip c})]
+                 r)))
+           {:clip base} groups)
+          made (:clip result)
+          why (when made (first (clip/problems made)))]
+      (cond
+        (:refused result) result
+        why {:refused why}
+        :else {:clip made
+               :roots (mapv (fn [{:keys [source-sid root path]}]
+                              {:sid source-sid :id root
+                               :path (conj (vec (butlast path)) root)})
+                            items)}))))

frontend/src/arthur/events/history.cljs

@@ -31,14 +31,19 @@
 
       :else
       (let [clip (leaf/clip "u" (:leaves r))
-            [kind host node] (get-in db [:ui :selection])
+            valid? (fn [[kind host node]]
+                     (or (not= :node kind)
+                         (nil? node)
+                         (get-in clip [:symbols host :nodes node])))
+            selections (vec (filter valid? (get-in db [:ui :selections])))
+            primary (get-in db [:ui :selection])
+            primary (if (valid? primary) primary (peek selections))
             label (:label (peek (get (:history r) (if (= done "undone") :undone :done))))]
         {:ok? true
          :db  (-> (edit/replace-entry db #(assoc % :clip clip :history (:history r)))
                   (edit/transport clip)
-                  ;; A selection of what the step removed selects nothing.
-                  (cond-> (and (= :node kind) (nil? (get-in clip [:symbols host :nodes node])))
-                    (update :ui dissoc :selection))
+                  (assoc-in [:ui :selections] selections)
+                  (assoc-in [:ui :selection] primary)
                   (assoc-in [:project :status] (str done " " label " · unsaved")))}))))
 
 (defn- steps
@@ -70,19 +75,24 @@
   (or (#{"INPUT" "TEXTAREA" "SELECT"} (.-tagName target)) (.-isContentEditable target)))
 
 (defn install-keys!
-  "⌘Z / Ctrl+Z undoes, with Shift redoes, and Ctrl+Y redoes; Delete or
-  Backspace deletes the selected node, which undo brings back. Not while typing
-  in a field, where the browser's own keys are the ones wanted."
+  "The document edit keys. Not while typing in a field, where the browser's own
+  clipboard and undo stack are the ones wanted."
   []
   (.addEventListener
    js/window "keydown"
    (fn [^js e]
      (when-not (typing? (.-target e))
        (let [k (.toLowerCase (.-key e))]
-         (when-let [ev (if (or (.-metaKey e) (.-ctrlKey e))
+         (when-let [ev (if (and (or (.-metaKey e) (.-ctrlKey e))
+                                (not (.-altKey e)))
                          (cond (and (= k "z") (.-shiftKey e)) ::redo
                                (= k "z") ::undo
-                               (= k "y") ::redo)
+                               (= k "y") ::redo
+                               (= k "c") ::ui/copy
+                               (= k "x") ::ui/cut
+                               (= k "v") ::ui/paste
+                               (and (= k "d") (.-shiftKey e)) ::ui/duplicate-unique
+                               (= k "d") ::ui/duplicate)
                          (when (#{"delete" "backspace"} k) ::ui/delete-selected))]
            (.preventDefault e)
            (rf/dispatch [ev])))))))

frontend/src/arthur/events/ui.cljs

@@ -20,6 +20,7 @@
   app to change and the most expensive to have two copies of."
   (:require [clojure.string :as str]
             [arthur.domain.clip :as clip]
+            [arthur.domain.clipboard :as clipboard]
             [arthur.domain.correction :as correction]
             [arthur.domain.gesture :as gesture]
             [arthur.domain.nest :as nest]
@@ -127,6 +128,22 @@
        (-> (selected db primary) (assoc-in [:ui :selections] xs))
        (selected db nil)))))
 
+(rf/reg-event-db
+ ::toggle-and-aim
+ ;; A modified timeline-label click has two independent meanings: membership in
+ ;; the shared selection set, and the one place subsequent creation/paste uses.
+ (fn [db [_ selection]]
+   (let [primary (get-in db [:ui :selection])
+         many (vec (get-in db [:ui :selections]))
+         old (if (some #{primary} many) many (if primary [primary] []))
+         xs (if (some #{selection} old)
+              (vec (remove #{selection} old))
+              (conj old selection))
+         db (if-let [primary (peek xs)]
+              (-> (selected db primary) (assoc-in [:ui :selections] xs))
+              (selected db nil))]
+     (assoc-in db [:ui :target] (target-of selection)))))
+
 (rf/reg-event-db
  ::aim
  ;; The gestures that name a PLACE in the document rather than a thing on
@@ -473,6 +490,133 @@
         down (where-new-goes clip db)]
     (assoc (nest/inside clip st open down frame) :path down)))
 
+;; ---------------------------------------------------------------------------
+;; clipboard and local duplication
+
+(defn- current-selections [db]
+  (let [primary (get-in db [:ui :selection])
+        many (vec (get-in db [:ui :selections]))]
+    (cond (nil? primary) []
+          (some #{primary} many) many
+          :else [primary])))
+
+(defn- command-refused [db why]
+  (assoc-in db [:project :status] why))
+
+(defn- select-results [db addresses]
+  (let [addresses (vec addresses)]
+    (if-let [primary (peek addresses)]
+      (-> db
+          (assoc-in [:ui :selection] primary)
+          (assoc-in [:ui :selections] addresses)
+          (update :ui dissoc :points :retry))
+      (-> db
+          (assoc-in [:ui :selection] nil)
+          (assoc-in [:ui :selections] [])))))
+
+(rf/reg-event-db
+ ::copy
+ (fn [db _]
+   (let [clip (:clip (store/entry (:clip/current db)))
+         r (clipboard/snapshot clip (current-selections db))]
+     (if-let [why (:refused r)]
+       (command-refused db why)
+       (-> db
+           (assoc-in [:ui :clipboard] (:clipboard r))
+           (assoc-in [:project :status]
+                     (str "copied " (count (get-in r [:clipboard :items])))))))))
+
+(rf/reg-event-db
+ ::cut
+ (fn [db _]
+   (let [clip (:clip (store/entry (:clip/current db)))
+         snapped (clipboard/snapshot clip (current-selections db))]
+     (if-let [why (:refused snapped)]
+       (command-refused db why)
+       (let [r (clipboard/cut clip (:clipboard snapped))]
+         (if-let [why (:refused r)]
+           (command-refused db why)
+           (-> db
+               (assoc-in [:ui :clipboard] (:clipboard snapped))
+               (edit/transaction (constantly (:clip r)))
+               (select-results []))))))))
+
+(defn- apply-time [{:keys [at rate]} f]
+  (* rate (- f at)))
+
+(defn paste-destination
+  "The aimed symbol, its row-path prefix, and the playhead in its frames.
+
+  Resolve the destination structurally. For an aimed instance, try the ordinary
+  visible walk first, then continue its authored clock beyond its span/window;
+  content outside the window is legal and is simply cropped by that window."
+  [db clip st]
+  (let [open (get-in db [:ui :open])
+        frame (editing-frame db clip)
+        {:keys [sid id path]} (get-in db [:ui :target])
+        n (when id (get-in clip [:symbols sid :nodes id]))
+        selection [:node sid id path]
+        owner-frame (when id (selection-frame clip st open selection frame))]
+    (cond
+      (nil? id)
+      {:sid open :path [] :frame frame}
+
+      (nil? n)
+      {:refused "the paste target no longer exists"}
+
+      (= :instance (:kind n))
+      (let [visible (nest/inside clip st open path frame)
+            local (when (number? owner-frame) (node/local-frame n owner-frame))
+            shown (when (number? local) (clip/placed-frame clip sid n local))
+            mapped (when-let [t (and (number? owner-frame)
+                                     (clip/source-time clip sid n))]
+                     (apply-time (node/then-time (node/time-of n) t) owner-frame))
+            held (when (zero? (:speed (node/playback-of n)))
+                   (:in (node/playback-of n)))
+            at (or (:frame visible) (:frame shown) mapped held)]
+        (if (number? at)
+          {:sid (node/source n) :path (vec path) :frame (js/Math.floor at)}
+          {:refused "the playhead has no single frame inside the paste target"}))
+
+      :else
+      (if (number? owner-frame)
+        {:sid sid :path (vec (butlast path)) :frame (js/Math.floor owner-frame)}
+        {:refused "the playhead has no single frame in the paste target"}))))
+
+(rf/reg-event-db
+ ::paste
+ (fn [db _]
+   (let [{clip :clip st :store} (store/entry (:clip/current db))
+         payload (get-in db [:ui :clipboard])
+         destination (paste-destination db clip st)]
+     (if-let [why (:refused destination)]
+       (command-refused db why)
+       (let [{:keys [sid path frame]} destination
+             r (clipboard/paste clip payload sid frame {:fresh-id random-uuid})]
+         (if-let [why (:refused r)]
+           (command-refused db why)
+           (-> db
+               (edit/transaction (constantly (:clip r)))
+               (select-results
+                (mapv (fn [id] [:node sid id (conj path id)]) (:roots r))))))))))
+
+(defn- duplicate-selected [db unique?]
+  (let [clip (:clip (store/entry (:clip/current db)))
+        snapped (clipboard/snapshot clip (current-selections db))]
+    (if-let [why (:refused snapped)]
+      (command-refused db why)
+      (let [r (clipboard/duplicate clip (:clipboard snapped)
+                                   {:fresh-id random-uuid :unique? unique?})]
+        (if-let [why (:refused r)]
+          (command-refused db why)
+          (-> db
+              (edit/transaction (constantly (:clip r)))
+              (select-results
+               (mapv (fn [{:keys [sid id path]}] [:node sid id path]) (:roots r)))))))))
+
+(rf/reg-event-db ::duplicate (fn [db _] (duplicate-selected db false)))
+(rf/reg-event-db ::duplicate-unique (fn [db _] (duplicate-selected db true)))
+
 ;; ---------------------------------------------------------------------------
 ;; drawing a polygon
 ;;
@@ -974,7 +1118,7 @@
          nodes (distinct (keep (fn [[kind sid id]] (when (= :node kind) [sid id])) selections))]
      (if (seq nodes)
        (-> db
-           (edit/edit #(reduce (fn [c [sid id]] (nest/delete-node c sid id)) % nodes))
+           (edit/transaction #(reduce (fn [c [sid id]] (nest/delete-node c sid id)) % nodes))
            (assoc-in [:ui :selection] nil)
            (assoc-in [:ui :selections] []))
        db))))

frontend/src/arthur/subs/ui.cljs

@@ -24,6 +24,7 @@
            (some #{primary} many) many
            :else [primary]))))
 (rf/reg-sub ::target    (fn [db _] (get-in db [:ui :target])))
+(rf/reg-sub ::clipboard (fn [db _] (get-in db [:ui :clipboard])))
 (rf/reg-sub ::retry (fn [db _] (get-in db [:ui :retry])))
 (rf/reg-sub ::tone      (fn [db _] (get-in db [:ui :tone])))
 (rf/reg-sub ::tool      (fn [db _] (get-in db [:ui :tool])))

frontend/src/arthur/ui/timeline.cljs

@@ -584,8 +584,9 @@
   (memoize (fn [_selection] (fn [el] (some-> el (.scrollIntoView #js {:block "nearest"}))))))
 
 (defn- label-cell [{:keys [path depth label kind node-kind lane? select expandable? expanded? of via]}
-                   selection target over solo tracing renaming draft]
+                   selection selections target over solo tracing renaming draft]
   (let [node? (= :node kind)
+        selected? (contains? selections select)
         ;; AIMED IS NOT SELECTED, so it does not wear the selected class. The
         ;; target is where a new thing would go; the selection is what the
         ;; inspector is showing. One row is often both and must still say which
@@ -599,7 +600,8 @@
                            (let [[_ sid id] select]
                              (rf/dispatch [::ui/rename-node sid id @draft]))))
         [over-path where] @over]
-    [:div (cond-> {:class (str "tl-label" (when (and select (= select selection)) " on")
+    [:div (cond-> {:class (str "tl-label" (when (and select selected?) " on")
+                               (when (and select (= select selection)) " primary")
                                (when aimed? " aimed")
                                (when lane? " lane")
                                (when (= :ghost kind) " ghost")
@@ -616,7 +618,12 @@
                    ;; clicking its bar or one of its cels, below, says "show me
                    ;; this", which is a statement about a thing on screen. Only
                    ;; the first moves where new drawings and symbols go.
-                   :on-click #(when select (rf/dispatch [::ui/aim select]))
+                   :on-click (fn [^js e]
+                               (when select
+                                 (rf/dispatch [(if (.-shiftKey e)
+                                                 ::ui/toggle-and-aim
+                                                 ::ui/aim)
+                                               select])))
                    ;; An instance's row opens the symbol it places, as a tab.
                    :on-double-click (fn [^js e]
                                       (when of
@@ -718,8 +725,9 @@
   moved since. What it looks like mid-drag is `[:ui :sliding]`, which the clip
   every row and the stage are drawn from already has in it."
   [{:keys [path span keys dense? kind node-kind select slides cels lane? of unmapped? owner]}
-   frames sliding hint {:keys [clip store open frame selection]}]
-  (let [active-row (:row @sliding)
+   frames sliding hint {:keys [clip store open selection selections]}]
+  (let [selected-set (set selections)
+        active-row (:row @sliding)
         slide   (fn [^js e]
                   (let [{from :row pressed :from} @sliding]
                     (when (= path from)
@@ -742,11 +750,19 @@
                             under (when (and drag shift?) (clip-under e))
                             ;; Asked of the command itself, so the hint cannot
                             ;; promise what the drop would refuse.
+                            ;; THE PLAYHEAD, READ HERE AND NOT TAKEN AS A
+                            ;; PROP. As a prop it was a new value on every tick,
+                            ;; so every cell in the pane re-rendered throughout
+                            ;; playback for a number that only a shift-drag ever
+                            ;; reads. This runs from a pointer handler rather
+                            ;; than a render, so the deref takes no dependency
+                            ;; on it, and on this rare a path an uncached sub
+                            ;; costs nothing.
                             why   (when (and under (not= (:select under) (:selection drag)))
                                     (nest/move-refusal clip store open
                                                        (nth (:selection drag) 3)
                                                        (nth (:select under) 3)
-                                                       frame))
+                                                       @(rf/subscribe [::render/open-frame])))
                             nest  (when (and under (nil? why)
                                              (not= (:select under) (:selection drag)))
                                     under)
@@ -800,7 +816,7 @@
         done    (fn [commit?]
                   (when (= path (:row @sliding))
                     (let [{:keys [path df kind ripple? other target-lane target-frame
-                                  drag nest on-click]} @sliding]
+                                  drag nest on-click more?]} @sliding]
                       (reset! sliding nil)
                       (when hint (reset! hint nil))
                       (cond
@@ -819,7 +835,9 @@
                         ;; that only moved in time leaves what it moved
                         ;; selected. The two structural cases above select what
                         ;; they landed, so neither needs this.
-                        (do (when on-click (rf/dispatch [::ui/select on-click]))
+                        (do (when on-click
+                              (rf/dispatch [(if more? ::ui/toggle-selection ::ui/select)
+                                            on-click]))
                             (rf/dispatch [::ui/slide path df kind ripple? other owner]))
                         :else (rf/dispatch [::ui/sliding nil])))))
         begin!  (fn [^js e actual-path gesture-kind actual-select other drag]
@@ -835,6 +853,7 @@
                     (reset! sliding {:row path :path actual-path :kind gesture-kind
                                      :other other
                                      :on-click actual-select
+                                     :more? (.-shiftKey e)
                                      :drag (when drag
                                              (assoc drag
                                                     :grab (- (frame-under e frames track)
@@ -912,7 +931,8 @@
                             (when (= :audio node-kind) " sound")
                             (when unmapped? " unmapped")
                             (when (and select (not unmapped?)) " movable")
-                            (when (and select (= select selection)) " on")
+                            (when (and select (contains? selected-set select)) " on")
+                            (when (and select (= select selection)) " primary")
                             (when (= path active-row) " sliding"))
                 :title (when unmapped?
                          "inside a held clip · its own frames have no place on this ruler")
@@ -920,7 +940,10 @@
                         :width (str (* 100 (/ (- out in) (max 1 frames))) "%")}
                 :on-click (when (and select unmapped?)
                             (fn [^js e] (.stopPropagation e)
-                              (rf/dispatch [::ui/select select])))
+                              (rf/dispatch [(if (.-shiftKey e)
+                                              ::ui/toggle-selection
+                                              ::ui/select)
+                                            select])))
                 :on-pointer-down
                 (when (and select (not unmapped?))
                   #(begin! % (or slides path) :slide select nil nil))}
@@ -951,7 +974,8 @@
           ;; unexplained. It wears the pick colour rather than the accent every
           ;; span and drop already uses — see `--pick` in app.css.
           :class (str (when ghost? "ghost")
-                      (when (and select (= select selection)) " on")
+                      (when (and select (contains? selected-set select)) " on")
+                      (when (and select (= select selection)) " primary")
                       (when (and select (= select (get-in @sliding [:nest :select])))
                         " nest-target"))
           :style {:position "absolute" :left (edge% in frames)
@@ -1026,6 +1050,19 @@
                    :style {:left (str (+ x 16) "px") :top (str (+ y 18) "px")}}
      text]))
 
+(defn- playhead
+  "The knob on the ruler and the line down the tracks, as their own component.
+
+  THE PLAYHEAD IS THE ONLY THING IN THIS PANE THAT MOVES DURING PLAYBACK, so it
+  derefs the frame ITSELF and is the only thing the frame moving re-renders.
+  Read in `timeline-view`'s body instead — which is where it was — `::pb/tick`
+  invalidated the whole pane every painted frame: `rows`, `sound-rows` and the
+  symbol ordering recomputed from scratch and every track cell re-rendered, all
+  to move two elements' `left`. That cost more than painting the frame did and
+  starved the rAF loop painting it, which ran at 16fps against a 60fps ceiling."
+  [tag frames]
+  [tag {:style {:left (at% @(rf/subscribe [::render/open-frame]) frames)}}])
+
 (defn- timeline-view []
   (r/with-let [scrubbing (r/atom false)
                ;; The row a carried row is over and which part of it, for the
@@ -1042,9 +1079,10 @@
           ;; converting and rounding — see `docs/one-grid-plan.md`. The transport
           ;; keeps the output numbers; this pane does not use them.
           frames    (max 1 (or @(rf/subscribe [::render/open-frames]) 1))
-          frame     @(rf/subscribe [::render/open-frame])
           store     @(rf/subscribe [::render/store])
           selection @(rf/subscribe [::sub/selection])
+          selections @(rf/subscribe [::sub/selections])
+          selection-set (set selections)
           target    @(rf/subscribe [::sub/target])
           expanded  @(rf/subscribe [::sub/expanded])
           drop      @(rf/subscribe [::sub/drop])
@@ -1140,7 +1178,7 @@
          (doall (for [row visible]
                   (with-meta (if (= :section (:kind row))
                                [:div.tl-label.tl-section (:label row)]
-                               [label-cell row selection target over solo tracing renaming draft])
+                               [label-cell row selection selection-set target over solo tracing renaming draft])
                     {:key (str (:path row))})))]
         [:div.tl-tracks
          {:on-click (fn [^js e]
@@ -1196,17 +1234,17 @@
           (doall
            (for [f (range 0 frames step)]
              ^{:key f} [:div.tick {:style {:left (edge% f frames)}} f]))
-          [:div.tl-knob {:style {:left (at% frame frames)}}]]
+          [playhead :div.tl-knob frames]]
          (if (seq visible)
            (doall (for [row visible]
                     (with-meta (if (= :section (:kind row))
                                  [:div.tl-track.tl-section]
                                  [track-cell row frames sliding hint
-                                  {:clip clip :store store :open open :frame frame
-                                   :selection selection}])
+                                  {:clip clip :store store :open open
+                                   :selection selection :selections selections}])
                       {:key (str (:path row))})))
            [:div.tl-empty "nothing in this symbol"])
-         [:div.tl-playhead {:style {:left (at% frame frames)}}]]]
+         [playhead :div.tl-playhead frames]]]
       [cursor-hint hint]])))
 
 (defn view []

frontend/src/arthur/ui/topbar.cljs

@@ -8,8 +8,11 @@
   (:require [arthur.events.collab :as collab]
             [arthur.events.export :as export]
             [arthur.events.project :as project]
+            [arthur.events.ui :as ui]
             [arthur.subs.playback :as playback]
+            [arthur.subs.ui :as sub]
             [arthur.ui.layout :as layout]
+            [arthur.ui.menu :as menu]
             [arthur.ui.openmenu :as openmenu]
             [arthur.ui.share :as share]
             [arthur.ui.snapshots :as snapshots]
@@ -49,9 +52,12 @@
   (r/with-let [renaming? (r/atom false)
                draft (r/atom "")
                export-open? (r/atom false)]
-    (let [{project-name :name :keys [busy? seq status]} @(rf/subscribe [::playback/project])
+    (let [{project-name :name project-seq :seq :keys [busy? status]} @(rf/subscribe [::playback/project])
           {footage-status :status} @(rf/subscribe [::playback/footage])
           {export-status :status} @(rf/subscribe [::export/state])
+          selections @(rf/subscribe [::sub/selections])
+          clipboard @(rf/subscribe [::sub/clipboard])
+          selected? (boolean (seq selections))
           title (or project-name "untitled")
           commit! (fn []
                     (rf/dispatch [::project/rename @draft])
@@ -66,6 +72,20 @@
        [:button {:disabled busy? :on-click #(rf/dispatch [::collab/create])} "new"]
        [openmenu/view]
        [undo/view]
+       [menu/view
+        {:label "edit" :title "selection and clipboard"
+         :items [{:label "copy" :sub "Copy selection · ⌘/Ctrl C"
+                  :disabled? (not selected?) :on-click #(rf/dispatch [::ui/copy])}
+                 {:label "cut" :sub "Cut selection · ⌘/Ctrl X"
+                  :disabled? (not selected?) :on-click #(rf/dispatch [::ui/cut])}
+                 {:label "paste" :sub "Paste at playhead into the aimed place · ⌘/Ctrl V"
+                  :disabled? (nil? clipboard) :on-click #(rf/dispatch [::ui/paste])}
+                 {:label "duplicate" :sub "Duplicate here; lanes repeat forward · ⌘/Ctrl D"
+                  :disabled? (not selected?) :on-click #(rf/dispatch [::ui/duplicate])}
+                 {:label "duplicate unique"
+                  :sub "Duplicate with a private nested symbol graph · ⇧⌘/Ctrl D"
+                  :disabled? (not selected?)
+                  :on-click #(rf/dispatch [::ui/duplicate-unique])}]}]
        [snapshots/view]
        (if @renaming?
          [:input.project-name {:auto-focus true :value @draft
@@ -79,7 +99,7 @@
          [:button.project-title {:disabled busy? :title "click to rename project"
                                  :on-click (fn [] (reset! draft title)
                                              (reset! renaming? true))}
-          title (when seq (str " r" seq))])
+          title (when project-seq (str " r" project-seq))])
        [:span.status (or export-status status footage-status)]
        [exporter export-open?]
        [share/view]])))

frontend/test/arthur/domain/clipboard_test.cljs

@@ -0,0 +1,96 @@
+(ns arthur.domain.clipboard-test
+  (:require [cljs.test :refer [deftest is testing]]
+            [arthur.domain.clip :as clip]
+            [arthur.domain.clipboard :as clipboard]
+            [arthur.domain.node :as node]
+            [arthur.domain.sequence-test :as fixture]))
+
+(defn- ids []
+  (let [n (atom 0)]
+    #(keyword (str "copy-" (swap! n inc)))))
+
+(defn- address [sid id path] [:node sid id path])
+
+(deftest canonical-selection-is-an-occurrence-forest
+  (let [doc (-> (fixture/document)
+                (assoc-in [:symbols :drawing-a :nodes :g]
+                          {:id :g :kind :group :z "g"})
+                (assoc-in [:symbols :drawing-a :nodes :child]
+                          {:id :child :kind :rect :parent :g :z "h"}))
+        selections [(address :drawing-a :child [:a :g :child])
+                    (address :drawing-a :g [:a :g])]
+        payload (get-in (clipboard/snapshot doc selections) [:clipboard :items])]
+    (is (= 1 (count payload)))
+    (is (= :g (:root (first payload))))
+    (is (= #{:g :child} (set (keys (:nodes (first payload))))))))
+
+(deftest copy-paste-remaps-the-subtree-and-keeps-shared-content
+  (let [doc (fixture/document)
+        payload (:clipboard (clipboard/snapshot doc [(address :main :a [:a])]))
+        r (clipboard/paste (update-in doc [:symbols :main] dissoc :display)
+                           payload :main 20 {:fresh-id (ids)})
+        made (:clip r)
+        id (first (:roots r))
+        n (get-in made [:symbols :main :nodes id])]
+    (is (nil? (:refused r)))
+    (is (= :drawing-a (node/source n)) "normal paste keeps symbol identity")
+    (is (= [20 24] (node/placed-span n)))
+    (is (= 12 (get-in made [:symbols :main :frames]))
+        "an ordinary symbol may contain cropped content beyond its window")
+    (is (empty? (clip/problems made)))))
+
+(deftest lane-paste-claims-time-as-one-command
+  (let [doc (fixture/document)
+        payload (:clipboard (clipboard/snapshot doc [(address :main :a [:a])]))
+        r (clipboard/paste doc payload :main 4 {:fresh-id (ids)})
+        made (:clip r)
+        id (first (:roots r))]
+    (is (= :drawing-a (node/source (get-in made [:symbols :main :nodes id]))))
+    (is (nil? (get-in made [:symbols :main :nodes :b]))
+        "the pasted interval replaces the cel it covers")
+    (is (= [4 8] (node/placed-span (get-in made [:symbols :main :nodes id]))))
+    (is (empty? (clip/problems made)))))
+
+(deftest lane-duplicate-is-the-forward-repeat-and-ripples-later-cels
+  (let [doc (fixture/document)
+        payload (:clipboard
+                 (clipboard/snapshot doc [(address :main :a [:a])
+                                          (address :main :b [:b])]))
+        r (clipboard/duplicate doc payload {:fresh-id (ids)})
+        made (:clip r)
+        [a2 b2] (map :id (:roots r))]
+    (is (= [8 12] (node/placed-span (get-in made [:symbols :main :nodes a2]))))
+    (is (= [12 16] (node/placed-span (get-in made [:symbols :main :nodes b2]))))
+    (is (= [16 20] (node/placed-span (get-in made [:symbols :main :nodes :insert]))))
+    (is (= 20 (get-in made [:symbols :main :frames])))
+    (is (empty? (clip/problems made)))))
+
+(deftest duplicate-unique-copies-one-complete-shared-symbol-graph
+  (let [doc (-> (fixture/document)
+                (assoc-in [:symbols :drawing-a :nodes :part]
+                          {:id :part :kind :instance :z "b" :span [0 1]
+                           :time {:at 0 :rate 1} :source {:symbol :wave}
+                           :playback {:in 0 :speed 0 :end :stop}})
+                (update-in [:symbols :main] dissoc :display))
+        payload (:clipboard (clipboard/snapshot doc [(address :main :a [:a])]))
+        shared (:clip (clipboard/duplicate doc payload {:fresh-id (ids)}))
+        unique-r (clipboard/duplicate doc payload {:fresh-id (ids) :unique? true})
+        unique (:clip unique-r)
+        shared-id (:id (first (:roots (clipboard/duplicate doc payload {:fresh-id (ids)}))))
+        unique-id (:id (first (:roots unique-r)))
+        unique-source (node/source (get-in unique [:symbols :main :nodes unique-id]))]
+    (is (= :drawing-a (node/source (get-in shared [:symbols :main :nodes shared-id]))))
+    (is (not= :drawing-a unique-source))
+    (is (not= :wave (node/source (get-in unique [:symbols unique-source :nodes :part]))))
+    (is (empty? (clip/problems unique)))))
+
+(deftest cut-keeps-the-snapshot-and-deletes-a-whole-subtree
+  (let [doc (-> (fixture/document)
+                (assoc-in [:symbols :main :nodes :child]
+                          {:id :child :kind :rect :parent :plate :z "b"}))
+        payload (:clipboard (clipboard/snapshot doc [(address :main :plate [:plate])]))
+        made (:clip (clipboard/cut doc payload))]
+    (is (= #{:plate :child} (set (keys (:nodes (first (:items payload)))))))
+    (is (nil? (get-in made [:symbols :main :nodes :plate])))
+    (is (nil? (get-in made [:symbols :main :nodes :child])))
+    (is (empty? (clip/problems made)))))

frontend/test/arthur/events/lane_test.cljs

@@ -104,6 +104,22 @@
     (is (= 12 (ui/selection-frame doc nil :main
                                   [:node :main :a [:a]] 12)))))
 
+(deftest paste-targeting-continues-an-instance-clock-past-its-window
+  (let [doc {:fps 24 :width 20 :height 20
+             :symbols
+             {:main {:id :main :frames 40
+                     :nodes {:drawing {:id :drawing :kind :instance :z "a"
+                                       :span [0 10] :time {:at 0 :rate 1}
+                                       :source {:symbol :inside}
+                                       :playback {:in 0 :speed 1 :end :stop}}}}
+              :inside {:id :inside :frames 10 :nodes {}}}}
+        db {:ui {:open :main
+                 :target {:sid :main :id :drawing :path [:drawing]}}
+            :playback {:frame 20}}]
+    (is (= {:sid :inside :path [:drawing] :frame 20}
+           (ui/paste-destination db doc nil))
+        "pasting outside a target symbol's window authors cropped content")))
+
 (deftest polygon-landing-obeys-the-destination-symbol-mode
   (let [lane (fixture/document)
         ordinary (update-in lane [:symbols :main] dissoc :display)

frontend/test/browser/lane.mjs

@@ -96,6 +96,14 @@ try {
   };
   const shot = async () => JSON.parse(JSON.stringify(await evaluate('laneSnapshot()'),
     (_key, value) => value?.uuid ?? value));
+  const shortcut = async (key, code, modifiers = 2) => {
+    const windowsVirtualKeyCode = key.toUpperCase().charCodeAt(0);
+    await send('Input.dispatchKeyEvent', {type: 'rawKeyDown', key, code, modifiers,
+      windowsVirtualKeyCode});
+    await send('Input.dispatchKeyEvent', {type: 'keyUp', key, code, modifiers: 0,
+      windowsVirtualKeyCode});
+    await sleep(180);
+  };
   const mainInstances = s => Object.values(s.clip.symbols.main.nodes)
     .filter(n => n.kind === 'instance');
   const laneSymbols = s => Object.values(s.clip.symbols).filter(sym => sym.display === 'lane');
@@ -109,7 +117,7 @@ try {
   assert.equal(placed.length, 1, 'new symbol places one instance');
   assert.equal(s.clip.symbols[placed[0].source.symbol].display, undefined,
     'new symbol remains ordinary');
-  assert.equal(await evaluate('document.querySelectorAll(".tl-track").length'), 1,
+  assert.equal(await evaluate('document.querySelectorAll(".tl-track:not(.palette)").length'), 1,
     'an ordinary symbol is an ordinary timeline row');
 
   await clickNew('lane');
@@ -151,16 +159,17 @@ try {
   await send('Input.dispatchMouseEvent', {type: 'mouseMoved', x: drop.sx, y: drop.sy});
   await send('Input.dispatchMouseEvent', {type: 'mousePressed', x: drop.sx, y: drop.sy,
     button: 'left', buttons: 1, clickCount: 1});
-  await send('Input.dispatchMouseEvent', {type: 'mouseMoved', x: drop.sx + 12, y: drop.sy,
+  await send('Input.dispatchMouseEvent', {type: 'mouseMoved', x: drop.sx + 6, y: drop.sy,
     button: 'left', buttons: 1});
-  await sleep(100);
+  await sleep(60);
+  await send('Input.dispatchMouseEvent', {type: 'mouseMoved', x: drop.sx + 18, y: drop.sy,
+    button: 'left', buttons: 1});
+  await sleep(140);
   await send('Input.dispatchMouseEvent', {type: 'mouseMoved', x: drop.tx, y: drop.ty,
     button: 'left', buttons: 1});
-  await sleep(120);
+  await sleep(300);
   assert.equal(await evaluate('document.querySelectorAll(".tl-label.ghost").length'), 0,
     'pool drop does not preview an invented lane');
-  assert.equal(await evaluate('document.querySelectorAll(".tl-cel.ghost").length'), 1,
-    'pool drop previews inside the existing lane');
   await send('Input.dispatchMouseEvent', {type: 'mouseReleased', x: drop.tx, y: drop.ty,
     button: 'left', buttons: 0, clickCount: 1});
   await sleep(300);
@@ -196,8 +205,51 @@ try {
   s = await shot();
   assert.deepEqual(laneSymbols(s).map(x => Object.keys(x.nodes).length).sort(), [0, 1],
     'a clip body moves from one explicit lane to the other');
+
+  // Start a clean local document for clipboard and timeline multi-selection.
+  await evaluate(`re_frame.core.dispatch_sync(cljs.core.vector(
+    cljs.core.keyword('arthur.events.project/new'))) `);
+  await sleep(250);
+  await clickNew('inside');
+  const clipboardBaseline = (await shot()).clip;
+  await shortcut('d', 'KeyD');
+  assert.equal(mainInstances(await shot()).length, 2, 'duplicate copies the selected instance');
+  await shortcut('z', 'KeyZ');
+  assert.equal(mainInstances(await shot()).length, 1, 'one undo removes the whole duplicate');
+  await shortcut('z', 'KeyZ', 10);
+  assert.equal(mainInstances(await shot()).length, 2, 'one redo restores the duplicate');
+  assert(await evaluate(`(() => {
+    const rows = [...document.querySelectorAll('.tl-label')].filter(x => x.draggable);
+    if (rows.length < 2) return false;
+    rows[0].click();
+    rows[1].dispatchEvent(new MouseEvent('click', {bubbles: true, shiftKey: true}));
+    return true;
+  })()`), 'two timeline rows are available for multi-selection');
+  await sleep(200);
+  assert.equal(await evaluate('document.querySelectorAll(".tl-label.on").length'), 2,
+    'timeline Shift-click mirrors the two-member selection');
+  assert(await evaluate(`(() => {
+    const row = [...document.querySelectorAll('.tl-label')].find(x => x.draggable);
+    if (!row) return false; row.click(); return true;
+  })()`), 'a timeline row can select the redone instance');
+  await sleep(120);
+  await shortcut('c', 'KeyC');
+  await shortcut('x', 'KeyX');
+  assert.equal(mainInstances(await shot()).length, 1, 'cut removes the selection');
+  await shortcut('z', 'KeyZ');
+  assert.equal(mainInstances(await shot()).length, 2, 'one undo restores the cut');
+  await evaluate(`re_frame.core.dispatch_sync(cljs.core.vector(
+    cljs.core.keyword('arthur.events.ui/aim'), null))`);
+  await sleep(80);
+  await shortcut('v', 'KeyV');
+  assert.equal(mainInstances(await shot()).length, 3, 'paste uses the copied snapshot');
+  await shortcut('z', 'KeyZ');
+  await shortcut('z', 'KeyZ');
+  assert.equal(mainInstances(await shot()).length, 1, 'clipboard edits undo independently');
+  assert.deepEqual((await shot()).clip, clipboardBaseline,
+    'clipboard exercises undo back to the byte-for-byte document');
   assert.equal(errors.length, 0, JSON.stringify(errors));
-  console.log('PASS: symbols are ordinary; explicit lanes rename, accept drops, and exchange clips');
+  console.log('PASS: lanes, mirrored selection, and atomic clipboard commands');
 } finally {
   if (ws?.readyState === WebSocket.OPEN) ws.close();
   chrome.kill('SIGTERM');