rotations

src/hyperfiddle/domlike.cljc

@@ -0,0 +1,110 @@
+(ns hyperfiddle.domlike "
+A mutable tree implementation with an API isomorphic to a subset of the DOM.
+")
+
+(defn node "
+Return a fresh node.
+" []
+  (doto (object-array 3)
+    (aset 2 [])))
+
+(defn parent "
+Return `node`'s current parent.
+" [^objects node]
+  (aget node 0))
+
+(defn set-parent "
+Assign `node`'s parent to `parent`.
+" [^objects node parent]
+  (aset node 0 parent))
+
+(defn index "
+Return `node`'s current index.
+" [^objects node]
+  (aget node 1))
+
+(defn set-index "
+Assign `node`'s index to `index`.
+" [^objects node index]
+  (aset node 1 index))
+
+(defn children "
+Return `node`'s current children.
+" [^objects node]
+  (aget node 2))
+
+(defn set-children "
+Assign `node`s children to `children`.
+" [^objects node children]
+  (aset node 2 children))
+
+(defn nth-child "
+Return `node`'s child in position `i`, or `nil` if out of bounds.
+" [node i]
+  (nth (children node) i nil))
+
+(defn remove-at [node i]
+  (let [v (children node)]
+    (set-children node
+      (into (subvec v 0 i)
+        (map (fn [c] (set-index c (dec (index c))) c))
+        (subvec v (inc i))))))
+
+(defn remove-child "
+Remove `child` from `node`'s children and return the removed node.
+" [node child]
+  (when-not (identical? node (parent child))
+    (throw (#?(:clj Error. :cljs js/Error.) "not a child")))
+  (remove-at node (index child))
+  (set-parent child nil)
+  (set-index child nil)
+  child)
+
+(defn replace-child "
+Replace `old` by `child` in `node`'s children and return the removed node.
+" [node child old]
+  (when-not (identical? node (parent old))
+    (throw (#?(:clj Error. :cljs js/Error.) "not a child")))
+  (when-some [p (parent child)]
+    (remove-at p (index child)))
+  (set-parent child node)
+  (set-index child (index old))
+  (set-children node
+    (assoc (children node)
+      (index old) child))
+  (set-parent old nil)
+  (set-index old nil)
+  old)
+
+(defn insert-before "
+Insert `child` before `sibling` in `node`s children and return the added node.
+" [node child sibling]
+  (when-not (nil? sibling)
+    (when (identical? child sibling)
+      (throw (#?(:clj Error. :cljs js/Error.) "insert before self")))
+    (when-not (identical? node (parent sibling))
+      (throw (#?(:clj Error. :cljs js/Error.) "not a child"))))
+  (when-some [p (parent child)]
+    (remove-at p (index child)))
+  (let [v (children node)
+        i (if (nil? sibling)
+            (count v)
+            (index sibling))]
+    (set-parent child node)
+    (set-index child i)
+    (set-children node
+      (-> []
+        (into (subvec v 0 i))
+        (conj child)
+        (into (map (fn [c] (set-index c (inc (index c))) c))
+          (subvec v i))))
+    child))
+
+(defn append-child "
+Adds `child` at the end of `node`'s children and return the added node.
+" [node child]
+  (insert-before node child nil))
+
+(defn tree "
+Return a snapshot of the tree rooted at `node`.
+" [node] (into [node] (map tree) (children node)))

src/hyperfiddle/electric_dom3.cljc

@@ -49,6 +49,8 @@
    ;; [hyperfiddle.electric-dom3-events :as events]
    [hyperfiddle.kvs :as kvs]
    [hyperfiddle.incseq :as i]
+   [hyperfiddle.incseq.mount-impl :refer [mount]]
+   [hyperfiddle.incseq.perm-impl :as p]
    ;; [hyperfiddle.electric.impl.lang-de2 :as lang]
    )
   #?(:cljs (:require-macros [hyperfiddle.electric-dom3])))
@@ -77,59 +79,16 @@
      (defn set-mount-point [node mp] (aset node key mp))
      (defn remove-mount-point [node] (js-delete node key))))
 
-;; possibly improved algorith for DOM node reordering
-;; untested, current v3 bugs prevent from trying
-(defn pop-kv ([m] (pop-kv m (key (first m))))  ([m k] [[k (get m k)] (dissoc m k)]))
-
-(defn consume-cycle [[k v] p ret]
-  (let [end k]
-    (loop [v v, p p, ret ret]
-      (let [[[k v :as kv] p] (pop-kv p v)]
-        (if (= end v)  [p (conj ret [k (inc v)])]  (recur v p (conj ret kv)))))))
-
-(defn plan-reorder-cycles [p]
-  (loop [p p ret []]
-    (case p {} ret #_else (let [[kv p] (pop-kv p), [p ret] (consume-cycle kv p (conj ret kv))] (recur p ret)))))
-
-(defn indexes->nodes [idxs children]
-  (mapv (fn [[i j]] [(.item children i) (.item children j)]) idxs))
-
-(defn reorder [element permutation]
-  (run! (fn [[from to]] (.insertBefore element from to))
-    (indexes->nodes (plan-reorder-cycles permutation) (.-childNodes element))))
-
 (defn ->text [elem] (when elem (.-textContent elem)))
 (defn texts [coll] (mapv ->text coll))
 
-(defn- mount-items-debug-print [element actual expected diff tbd c start]
-  (let [cv (vec c), elem (or (not-empty (.-id element)) element)]
-    (some->
-      (not-empty
-        (str
-          (when (not= actual expected)
-            [:SIZE-MISMATCH {:elem elem, :children start, :expected expected, :actual actual, :diff diff}])
-          (when (not= tbd cv)
-            [:VIOLATED {:elem elem, :start start, :tbd (texts tbd), :actual (texts cv), :diff diff}])))
-      println)))
-
-;; A resilient version of `mount-items`. Uses `i/patch-vec` to figure out the
-;; final state and through a simple algorithm arranges the DOM nodelist to match
-;; that. This is sub-optimal in several ways, but most likely fast enough and
-;; more importantly so simple there should obviously be no bugs[1]. Currently
-;; there's corruption in the calls, we call it with a diff that doesn't match
-;; the current state of the nodelist (too many/few elements). The implementation
-;; tries its best to notify of the misalignment and correct course, which means
-;; the DOM state most likely corrupts after that. Once the calls get fixed we
-;; can change the logs to assertions.
-;;
-;; [1] https://en.wikiquote.org/wiki/C._A._R._Hoare
-(defn mount-items [element diff]
-  (let [c (.-childNodes element), actual (.-length c), expected (- (:degree diff) (:grow diff))
-        cv (vec c), start (texts cv), tbd (i/patch-vec cv diff), in? (set tbd)]
-    (run! #(when-not (in? %) (.remove %)) cv)
-    (run! #(when % (.appendChild element %)) tbd)
-    (mount-items-debug-print element actual expected diff tbd c start))
-  element)
+(def mount-items
+  (mount
+    (fn [element child] (.appendChild element child))
+    (fn [element child previous] (.replaceChild element child previous))
+    (fn [element child sibling] (.insertBefore element child sibling))
+    (fn [element child] (.removeChild element child))
+    (fn [element i] (.item (.-childNodes element) i))))
 
 #?(:cljs
    (defn attach! [parent-node tag e]

src/hyperfiddle/incseq.cljc

@@ -98,10 +98,10 @@ Arranges elements of `v` according to permutation `p`.
 " p/arrange)
 
 
-(def decompose "
+(defn decompose "
 Decompose permutation `p` as a product of disjoint cycles, represented as a set of vectors. 1-cycles matching fixed
 points are omitted, the size of each cycle is therefore at least 2.
-" p/decompose)
+" [p] (p/decompose conj #{} p))
 
 
 (def compose "

src/hyperfiddle/incseq/diff_impl.cljc

@@ -16,7 +16,7 @@
                         (pop! v)) v)))
         change! (fn [r c]
                   (reduce-kv assoc! r c))
-        cycles! (partial reduce
+        cycles! (partial p/decompose
                   (fn [v c]
                     (let [i (nth c 0)
                           x (nth v i)]
@@ -35,7 +35,7 @@
        (-> v
          (transient)
          (grow! (:grow d))
-         (cycles! (p/decompose (:permutation d)))
+         (cycles! (:permutation d))
          (shrink! (:shrink d))
          (change! (:change d))
          (persistent!))))))

src/hyperfiddle/incseq/items_impl.cljc

@@ -152,7 +152,7 @@
               iperm (p/inverse permutation)
               indices (into #{} (map (fn [i] (iperm i i))) created)]
           (reduce create-item parent created)
-          (reduce apply-cycle buffer (p/decompose permutation))
+          (p/decompose apply-cycle buffer permutation)
           (reduce detach buffer (range (- degree shrink) degree))
           (reduce-kv propagate-change buffer change)
           (reduce propagate-freeze buffer freeze)

src/hyperfiddle/incseq/latest_product_impl.cljc

@@ -181,26 +181,26 @@
                      lr-size-after (aget counts 1)
                      foreign-degree (unchecked-multiply-int l r)
                      product-degree (unchecked-multiply-int item-degree foreign-degree)
-                     product-cycles (into #{}
-                                      (mapcat
-                                        (fn [cycle]
-                                          (let [k (nth cycle 0)
-                                                x (aget buffer k)
-                                                f (frozen? freezer k)
-                                                l (reduce
-                                                    (fn [k l]
-                                                      (aset buffer k (aget buffer l))
-                                                      ((if (frozen? freezer l)
-                                                         freeze! unfreeze!)
-                                                       freezer k) l)
-                                                    k (subvec cycle 1))]
-                                            (aset buffer l x)
-                                            ((if f freeze! unfreeze!)
-                                             freezer k))
-                                          (->> cycle
-                                            (map (partial combine-indices product-degree item-degree r))
-                                            (apply map vector))))
-                                      (p/decompose (:permutation item-diff)))]
+                     product-cycles (p/decompose
+                                      (fn [cycles cycle]
+                                        (let [k (nth cycle 0)
+                                              x (aget buffer k)
+                                              f (frozen? freezer k)
+                                              l (reduce
+                                                  (fn [k l]
+                                                    (aset buffer k (aget buffer l))
+                                                    ((if (frozen? freezer l)
+                                                       freeze! unfreeze!)
+                                                     freezer k) l)
+                                                  k (subvec cycle 1))]
+                                          (aset buffer l x)
+                                          ((if f freeze! unfreeze!)
+                                           freezer k))
+                                        (->> cycle
+                                          (map (partial combine-indices product-degree item-degree r))
+                                          (apply map vector)
+                                          (into cycles)))
+                                      #{} (:permutation item-diff))]
                  (loop [i size-after]
                    (when (< i item-degree)
                      (unfreeze! freezer i)

src/hyperfiddle/incseq/mount_impl.cljc

@@ -0,0 +1,33 @@
+(ns hyperfiddle.incseq.mount-impl
+  (:require [hyperfiddle.incseq.perm-impl :as p]))
+
+(defn permute-keys [rf r p m]
+  (reduce-kv (fn [r k v] (rf r (p k k) v)) r m))
+
+(defn mount [append-child replace-child insert-before remove-child nth-child]
+  (letfn [(append [element degree grow permutation change]
+            (let [q (p/inverse permutation)]
+              (loop [i (- degree grow)
+                     c change]
+                (if (== i degree)
+                  (do (permute-keys replace element permutation c)
+                      (p/rotations rotate element permutation))
+                  (let [j (q i i)]
+                    (append-child element (c j))
+                    (recur (inc i) (dissoc c j)))))))
+          (replace [element i e]
+            (replace-child element e (nth-child element i)))
+          (rotate [element i j]
+            (insert-before element (nth-child element i)
+              (nth-child element (if (< i j) (inc j) j)))
+            element)]
+    (fn [element {:keys [grow shrink degree permutation change]}]
+      (let [size-after (- degree shrink)]
+        (loop [d degree
+               p permutation]
+          (if (== d size-after)
+            (append element d grow p change)
+            (let [i (dec d)
+                  j (p i i)]
+              (remove-child element (nth-child element j))
+              (recur i (p/compose p (p/rotation i j))))))))))