🎉 Improve sync algorithm when swapped copies

common/src/app/common/files/helpers.cljc

@@ -361,7 +361,8 @@
 
 (defn set-touched-group
   [touched group]
-  (conj (or touched #{}) group))
+  (when group
+    (conj (or touched #{}) group)))
 
 (defn touched-group?
   [shape group]

common/src/app/common/types/component.cljc

@@ -4,7 +4,11 @@
 ;;
 ;; Copyright (c) KALEIDOS INC
 
-(ns app.common.types.component)
+(ns app.common.types.component
+  (:require
+   [app.common.data :as d]
+   [app.common.uuid :as uuid]
+   [cuerdas.core :as str]))
 
 ;; Attributes that may be synced in components, and the group they belong to.
 ;; When one attribute is modified in a shape inside a component, the corresponding
@@ -170,6 +174,29 @@
   (and (= shape-id (:main-instance-id component))
        (= page-id (:main-instance-page component))))
 
+(defn build-swap-slot-group
+  "Convert a swap-slot into a :touched group"
+  [swap-slot]
+  (when swap-slot
+    (keyword (str "swap-slot-" swap-slot))))
+
+(defn get-swap-slot
+  "If the shape has a :touched group in the form :swap-slot-<uuid>, get the id."
+  [shape]
+  (let [group (->> (:touched shape)
+                   (map name)
+                   (d/seek #(str/starts-with? % "swap-slot-")))]
+    (when group
+      (uuid/uuid (subs group 10)))))
+
+(defn match-swap-slot?
+  [shape-inst shape-main]
+  (let [slot-inst   (get-swap-slot shape-inst)
+        slot-main   (get-swap-slot shape-main)]
+    (when (some? slot-inst)
+      (or (= slot-inst slot-main)
+          (= slot-inst (:id shape-main))))))
+
 (defn get-component-root
   [component]
   (if (true? (:main-instance-id component))

common/src/app/common/types/file.cljc

@@ -177,12 +177,36 @@
                          shape-id)))
       (dm/get-in component [:objects shape-id]))))
 
+(defn get-component-shape-context
+  "Retrieve one shape in the component by id. Return the shape and its 
+  context (the file and the container)."
+  [file component shape-id]
+  (let [components-v2 (dm/get-in file [:data :options :components-v2])]
+    (if (and components-v2 (not (:deleted component)))
+      (let [component-page (get-component-page (:data file) component)]
+        (when component-page
+          (let [child (cfh/get-child (:objects component-page)
+                                     (:main-instance-id component)
+                                     shape-id)]
+            (when child
+              [child file (ctn/make-container component-page :page)]))))
+      [(dm/get-in component [:objects shape-id])
+       file
+       (ctn/make-container component :component)])))
+
 (defn get-ref-shape
   "Retrieve the shape in the component that is referenced by the instance shape."
   [file-data component shape]
   (when (:shape-ref shape)
     (get-component-shape file-data component (:shape-ref shape))))
 
+(defn get-ref-shape-context
+  "Retrieve the shape in the component that is referenced by the instance shape.
+   Return the shape and its context (the file and the container)."
+  [file component shape]
+  (when (:shape-ref shape)
+    (get-component-shape-context file component (:shape-ref shape))))
+
 (defn get-shape-in-copy
   "Given a shape in the main component and the root of the copy component returns the equivalent
   shape inside the root copy that matches the main-shape"
@@ -196,11 +220,33 @@
   [file page libraries shape & {:keys [include-deleted?] :or {include-deleted? false}}]
   (let [find-ref-shape-in-head
         (fn [head-shape]
-          (let [head-file      (find-component-file file libraries (:component-file head-shape))
+          (let [component-file (find-component-file file libraries (:component-file head-shape))
-                head-component (when (some? head-file)
+                component      (when (some? component-file)
-                                 (ctkl/get-component (:data head-file) (:component-id head-shape) include-deleted?))]
+                                 (ctkl/get-component (:data component-file) (:component-id head-shape) include-deleted?))]
-            (when (some? head-component)
+            (when (some? component)
-              (get-ref-shape (:data head-file) head-component shape))))]
+              (get-ref-shape (:data component-file) component shape))))]
+
+    (some find-ref-shape-in-head (ctn/get-parent-heads (:objects page) shape))))
+
+(defn find-ref-shape-context
+  "Locate the nearest component in the local file or libraries, and retrieve the shape
+   referenced by the instance shape. Return the shape and its context (the file and
+   the container)."
+  ; TODO: It should be nice to avoid this duplicity without adding overhead in the simple case.
+  ;       Perhaps adding the context as metadata of the shape?
+  [file page libraries shape & {:keys [include-deleted?] :or {include-deleted? false}}]
+  (let [find-ref-shape-in-head
+        (fn [head-shape]
+          ;; (js/console.log "head-shape" (clj->js head-shape))
+          ;; (js/console.log "     component-file" (str (:component-file head-shape)))
+          ;; (js/console.log "     component-id" (str (:component-id head-shape)))
+          (let [component-file (find-component-file file libraries (:component-file head-shape))
+                component      (when (some? component-file)
+                                 (ctkl/get-component (:data component-file) (:component-id head-shape) include-deleted?))]
+            ;; (js/console.log "component-file" (clj->js component-file))
+            ;; (js/console.log "component" (clj->js component))
+            (when (some? component)
+              (get-ref-shape-context component-file component shape))))]
 
     (some find-ref-shape-in-head (ctn/get-parent-heads (:objects page) shape))))
 
@@ -210,12 +256,14 @@
   [file page libraries shape & {:keys [include-deleted?] :or {include-deleted? false}}]
   (let [find-ref-component-in-head
         (fn [head-shape]
-          (let [head-file      (find-component-file file libraries (:component-file head-shape))
+          (let [component-file (find-component-file file libraries (:component-file head-shape))
-                head-component (when (some? head-file)
+                component      (when (some? component-file)
-                                 (ctkl/get-component (:data head-file) (:component-id head-shape) include-deleted?))]
+                                 (ctkl/get-component (:data component-file)
-            (when (some? head-component)
+                                                     (:component-id head-shape)
-              (when (get-ref-shape (:data head-file) head-component shape)
+                                                     include-deleted?))]
-                head-component))))]
+            (when (some? component)
+              (when (get-ref-shape (:data component-file) component shape)
+                component))))]
 
     (some find-ref-component-in-head (ctn/get-parent-copy-heads (:objects page) shape))))
 
@@ -251,6 +299,35 @@
   (let [ref-component (find-ref-component file page libraries shape :include-deleted? true)]
     (true? (= (:id component) (:id ref-component)))))
 
+(defn find-swap-slot
+  [shape page file libraries]
+  (dm/assert! "expected shape is head" (ctk/instance-head? shape))
+  ;; (js/console.log "find-swap-slot" (clj->js shape))
+  (if-let [swap-slot (ctk/get-swap-slot shape)]
+    ;; (do (js/console.log "uno" (str swap-slot)) swap-slot)
+    swap-slot
+    (let [[ref-shape ref-file ref-container] (find-ref-shape-context file
+                                                                     page
+                                                                     libraries
+                                                                     shape
+                                                                     :include-deleted? true)]
+      ;; (js/console.log "ref-shape" (clj->js ref-shape))
+      (when ref-shape
+        ;; (js/console.log "ref-shape" (clj->js ref-shape))
+        (if-let [swap-slot (ctk/get-swap-slot ref-shape)]
+          ;; (do (js/console.log "dos" (str swap-slot)) swap-slot)
+          swap-slot
+          (if (ctk/main-instance? ref-shape)
+            (:id shape)
+            (find-swap-slot ref-shape ref-container ref-file libraries)))))))
+
+(defn match-swap-slot?
+  [shape-inst shape-main page-inst page-main file libraries]
+  (let [slot-inst   (find-swap-slot shape-inst page-inst file libraries)
+        slot-main   (find-swap-slot shape-main page-main file libraries)]
+    (or (= slot-inst slot-main)
+        (= slot-inst (:id shape-main)))))
+
 (defn get-component-shapes
   "Retrieve all shapes of the component"
   [file-data component]

frontend/src/app/main/data/workspace/libraries.cljs

@@ -52,7 +52,7 @@
    [potok.v2.core :as ptk]))
 
 ;; Change this to :info :debug or :trace to debug this module, or :warn to reset to default
-(log/set-level! :warn)
+(log/set-level! :trace)
 
 (defn- log-changes
   [changes file]
@@ -870,16 +870,12 @@
             0)))))
 
 (defn- add-component-for-swap
-  [shape file-id id-new-component index target-cell keep-props-values {:keys [undo-group]}]
+  [shape file page libraries id-new-component index target-cell keep-props-values {:keys [undo-group]}]
   (dm/assert! (uuid? id-new-component))
-  (dm/assert! (uuid? file-id))
   (ptk/reify ::add-component-for-swap
     ptk/WatchEvent
-    (watch [it state _]
+    (watch [it _ _]
-      (let [page      (wsh/lookup-page state)
+      (let [objects   (:objects page)
-            libraries (wsh/get-libraries state)
-
-            objects   (:objects page)
             position  (gpt/point (:x shape) (:y shape))
             changes   (-> (pcb/empty-changes it (:id page))
                           (pcb/set-undo-group undo-group)
@@ -889,7 +885,7 @@
             [new-shape changes]
             (dwlh/generate-instantiate-component changes
                                                  objects
-                                                 file-id
+                                                 (:id file)
                                                  id-new-component
                                                  position
                                                  page
@@ -898,6 +894,16 @@
                                                  (:parent-id shape)
                                                  (:frame-id shape))
 
+            new-shape (cond-> new-shape
+                        (nil? (ctk/get-swap-slot new-shape))
+                        (update :touched cfh/set-touched-group (-> (ctf/find-swap-slot shape
+                                                                                       page
+                                                                                       {:id (:id file)
+                                                                                        :data file}
+                                                                                       libraries)
+                                                                   (ctk/build-swap-slot-group))))
+
+            ;; _ (js/console.log "new-shape" (str (:id new-shape)) (clj->js new-shape))
             changes
             (-> changes
                 ;; Restore the properties
@@ -905,7 +911,11 @@
 
                 ;; We need to set the same index as the original shape
                 (pcb/change-parent (:parent-id shape) [new-shape] index {:component-swap true
-                                                                         :ignore-touched true}))]
+                                                                         :ignore-touched true})
+                (dwlh/change-touched new-shape
+                                     shape
+                                     (ctn/make-container page :page)
+                                     {}))]
 
         ;; First delete so we don't break the grid layout cells
         (rx/of (dch/commit-changes changes)
@@ -921,7 +931,10 @@
     (watch [_ state _]
       ;; First delete shapes so we have space in the layout otherwise we can have problems
       ;; in the grid creating new rows/columns to make space
-      (let [objects (wsh/lookup-page-objects state)
+      (let [file      (wsh/get-file state file-id)
+            libraries (wsh/get-libraries state)
+            page    (wsh/lookup-page state)
+            objects (wsh/lookup-page-objects state)
             parent (get objects (:parent-id shape))
 
             ;; If the target parent is a grid layout we need to pass the target cell
@@ -941,7 +954,7 @@
          (dwsh/delete-shapes nil (d/ordered-set (:id shape)) {:component-swap true
                                                               :undo-id undo-id
                                                               :undo-group undo-group})
-         (add-component-for-swap shape file-id id-new-component index target-cell keep-props-values
+         (add-component-for-swap shape file page libraries id-new-component index target-cell keep-props-values
                                  {:undo-group undo-group})
          (ptk/data-event :layout/update [(:parent-id shape)])
          (dwu/commit-undo-transaction undo-id))))))
@@ -958,8 +971,12 @@
       {::ev/name "component-swap"})
 
     ptk/WatchEvent
-    (watch [_ _ _]
+    (watch [_ state _]
       (let [undo-id (js/Symbol)]
+        (log/info :msg "COMPONENT-SWAP"
+                  :file (dwlh/pretty-file file-id state)
+                  :id-new-component id-new-component
+                  :undo-id undo-id)
         (rx/concat
          (rx/of (dwu/start-undo-transaction undo-id))
          (rx/map #(component-swap % file-id id-new-component) (rx/from shapes))

frontend/src/app/main/data/workspace/libraries_helpers.cljs

@@ -30,7 +30,7 @@
    [clojure.set :as set]))
 
 ;; Change this to :info :debug or :trace to debug this module, or :warn to reset to default
-(log/set-level! :warn)
+(log/set-level! :trace)
 
 (declare generate-sync-container)
 (declare generate-sync-shape)
@@ -594,7 +594,7 @@
   "Generate changes to synchronize one shape that is the root of a component
   instance, and all its children, from the given component."
   [changes libraries container shape-id reset? components-v2]
-  (log/debug :msg "Sync shape direct" :shape (str shape-id) :reset? reset?)
+  (log/debug :msg "Sync shape direct" :shape-inst (str shape-id) :reset? reset?)
   (let [shape-inst (ctn/get-shape container shape-id)
         library    (dm/get-in libraries [(:component-file shape-inst) :data])
         component  (ctkl/get-component library (:component-id shape-inst) true)]
@@ -656,7 +656,7 @@
 (defn- generate-sync-shape-direct-recursive
   [changes container shape-inst component library shape-main root-inst root-main reset? initial-root? redirect-shaperef components-v2]
   (log/debug :msg "Sync shape direct recursive"
-             :shape (str (:name shape-inst))
+             :shape-inst (str (:name shape-inst) " " (pretty-uuid (:id shape-inst)))
              :component (:name component))
 
   (if (nil? shape-main)
@@ -713,6 +713,8 @@
                           (map #(redirect-shaperef %) children-inst) children-inst)
 
           only-inst (fn [changes child-inst]
+                      (log/trace :msg "Only inst"
+                                 :child-inst (str (:name child-inst) " " (pretty-uuid (:id child-inst))))
                       (if-not (and omit-touched?
                                    (contains? (:touched shape-inst)
                                               :shapes-group))
@@ -723,6 +725,8 @@
                         changes))
 
           only-main (fn [changes child-main]
+                      (log/trace :msg "Only main"
+                                 :child-main (str (:name child-main) " " (pretty-uuid (:id child-main))))
                       (if-not (and omit-touched?
                                    (contains? (:touched shape-inst)
                                               :shapes-group))
@@ -739,6 +743,9 @@
                         changes))
 
           both (fn [changes child-inst child-main]
+                 (log/trace :msg "Both"
+                            :child-inst (str (:name child-inst) " " (pretty-uuid (:id child-inst)))
+                            :child-main (str (:name child-main) " " (pretty-uuid (:id child-main))))
                  (generate-sync-shape-direct-recursive changes
                                                        container
                                                        child-inst
@@ -753,6 +760,9 @@
                                                        components-v2))
 
           moved (fn [changes child-inst child-main]
+                  (log/trace :msg "Move"
+                             :child-inst (str (:name child-inst) " " (pretty-uuid (:id child-inst)))
+                             :child-main (str (:name child-main) " " (pretty-uuid (:id child-main))))
                   (move-shape
                    changes
                    child-inst
@@ -768,7 +778,8 @@
                         only-main
                         both
                         moved
-                        false))))
+                        false
+                        reset?))))
 
 
 (defn- generate-rename-component
@@ -939,6 +950,7 @@
                             only-main
                             both
                             moved
+                            true
                             true)
 
           ;; The inverse sync may be made on a component that is inside a
@@ -957,12 +969,15 @@
 ;; ---- Operation generation helpers ----
 
 (defn- compare-children
-  [changes children-inst children-main only-inst-cb only-main-cb both-cb moved-cb inverse?]
+  [changes children-inst children-main only-inst-cb only-main-cb both-cb moved-cb inverse? reset?]
+  (log/trace :msg "Compare children")
   (loop [children-inst (seq (or children-inst []))
          children-main (seq (or children-main []))
          changes       changes]
     (let [child-inst (first children-inst)
           child-main (first children-main)]
+      (log/trace :main (str (:name child-main) " " (pretty-uuid (:id child-main)))
+                 :inst (str (:name child-inst) " " (pretty-uuid (:id child-inst))))
       (cond
         (and (nil? child-inst) (nil? child-main))
         changes
@@ -979,31 +994,58 @@
                  (next children-main)
                  (both-cb changes child-inst child-main))
 
-          (let [child-inst' (d/seek #(ctk/is-main-of? child-main %) children-inst)
+          (if (and (ctk/match-swap-slot? child-main child-inst) (not reset?))
-                child-main' (d/seek #(ctk/is-main-of? % child-inst) children-main)]
+            (do
-            (cond
+              (log/trace :msg "Match slot"
-              (nil? child-inst')
+                         :shape-inst (str (:name child-inst) " " (pretty-uuid (:id child-inst)))
-              (recur children-inst
+                         :shape-main (str (:name child-main) " " (pretty-uuid (:id child-main))))
-                     (next children-main)
-                     (only-main-cb changes child-main))
-
-              (nil? child-main')
               (recur (next children-inst)
-                     children-main
+                     (next children-main)
-                     (only-inst-cb changes child-inst))
+                     changes))
 
-              :else
+            (let [child-inst' (d/seek #(ctk/is-main-of? child-main %) children-inst)
-              (if inverse?
+                  child-main' (d/seek #(ctk/is-main-of? % child-inst) children-main)]
-                (recur (next children-inst)
+              (cond
-                       (remove #(= (:id %) (:id child-main')) children-main)
+                (nil? child-inst')
-                       (-> changes
+                (let [matching-inst (d/seek #(ctk/match-swap-slot? % child-main) children-inst)]
-                           (both-cb child-inst child-main')
+                  (if (and (some? matching-inst) (not reset?))
-                           (moved-cb child-inst child-main')))
+                    (do
-                (recur (remove #(= (:id %) (:id child-inst')) children-inst)
+                      (log/trace :msg "Match slot inst"
-                       (next children-main)
+                                 :shape-inst (str (:name child-inst') " " (pretty-uuid (:id child-inst')))
-                       (-> changes
+                                 :shape-main (str (:name child-main) " " (pretty-uuid (:id child-main))))
-                           (both-cb child-inst' child-main)
+                      (recur (remove #(= (:id %) (:id matching-inst)) children-inst)
-                           (moved-cb child-inst' child-main)))))))))))
+                             (next children-main)
+                             changes))
+                    (recur children-inst
+                           (next children-main)
+                           (only-main-cb changes child-main))))
+
+                (nil? child-main')
+                (let [matching-main (d/seek #(ctk/match-swap-slot? child-inst %) children-main)]
+                  (if (and (some? matching-main) (not reset?))
+                    (do
+                      (log/trace :msg "Match slot main"
+                                 :shape-inst (str (:name child-inst) " " (pretty-uuid (:id child-inst)))
+                                 :shape-main (str (:name child-main') " " (pretty-uuid (:id child-main'))))
+                      (recur (next children-inst)
+                             (remove #(= (:id %) (:id matching-main)) children-inst)
+                             changes))
+                    (recur (next children-inst)
+                           children-main
+                           (only-inst-cb changes child-inst))))
+
+                :else
+                (if inverse?
+                  (recur (next children-inst)
+                         (remove #(= (:id %) (:id child-main')) children-main)
+                         (-> changes
+                             (both-cb child-inst child-main')
+                             (moved-cb child-inst child-main')))
+                  (recur (remove #(= (:id %) (:id child-inst')) children-inst)
+                         (next children-main)
+                         (-> changes
+                             (both-cb child-inst' child-main)
+                             (moved-cb child-inst' child-main))))))))))))
 
 (defn- add-shape-to-instance
   [changes component-shape index component-page container root-instance root-main omit-touched? set-remote-synced?]
@@ -1033,7 +1075,8 @@
                                (assoc :remote-synced true)
 
                                :always
-                               (assoc :shape-ref (:id original-shape)))))
+                               (-> (assoc :shape-ref (:id original-shape))
+                                   (dissoc :touched))))) ; New shape, by definition, is synced to the main shape
 
         update-original-shape (fn [original-shape _new-shape]
                                 original-shape)
@@ -1270,11 +1313,10 @@
       changes
       changes')))
 
-(defn- change-touched
+(defn change-touched
   [changes dest-shape origin-shape container
    {:keys [reset-touched? copy-touched?] :as options}]
-  (if (or (nil? (:shape-ref dest-shape))
+  (if (nil? (:shape-ref dest-shape))
-          (not (or reset-touched? copy-touched?)))
     changes
     (do
       (log/info :msg (str "CHANGE-TOUCHED "
@@ -1287,12 +1329,16 @@
       (let [new-touched (cond
                           reset-touched?
                           nil
+
                           copy-touched?
                           (if (:remote-synced origin-shape)
                             nil
                             (set/union
                              (:touched dest-shape)
-                             (:touched origin-shape))))]
+                             (:touched origin-shape)))
+
+                          :else
+                          (:touched dest-shape))]
 
         (-> changes
             (update :redo-changes conj (make-change