[i/items] permutations

src/hyperfiddle/electric/impl/array_fields.cljc

@@ -2,30 +2,43 @@
   (:refer-clojure :exclude [get set])
   #?(:cljs (:require-macros hyperfiddle.electric.impl.array-fields))
   (:require [hyperfiddle.rcf :as rcf :refer [tests]]))
-;; #?(:clj (set! *warn-on-reflection* true))
+#?(:clj (set! *warn-on-reflection* true))
 (defmacro deffields [& fields]
   `(do ~@(for [[fld idx] (mapv vector fields (range))]
            `(def ~fld (int ~idx)))
        ~(count fields)))
+(defn get [^objects a k] (aget a (int k)))
+(defn set
+  ([^objects a i v] (aset a (int i) v))
+  ([^objects a i v i2 v2] (aset a (int i) v) (aset a (int i2) v2))
+  ([^objects a i v i2 v2 i3 v3] (aset a (int i) v) (aset a (int i2) v2) (aset a (int i3) v3))
+  ([^objects a i v i2 v2 i3 v3 i4 v4] (aset a (int i) v) (aset a (int i2) v2) (aset a (int i3) v3) (aset a (int i4) v4))
+  ([^objects a i v i2 v2 i3 v3 i4 v4 & more] (set a i v i2 v2 i3 v3 i4 v4) (apply set a more)))
 (defn swap
-  ([^objects a k f] (aset a k (f (aget a k))))
-  ([^objects a k f x] (aset a k (f (aget a k) x)))
-  ([^objects a k f x y] (aset a k (f (aget a k) x y)))
-  ([^objects a k f x y z] (aset a k (f (aget a k) x y z)))
-  ([^objects a k f x y z & more] (aset a k (apply f (aget a k) x y z more))))
+  ([^objects a k f] (set a k (f (get a k))))
+  ([^objects a k f x] (set a k (f (get a k) x)))
+  ([^objects a k f x y] (set a k (f (get a k) x y)))
+  ([^objects a k f x y z] (set a k (f (get a k) x y z)))
+  ([^objects a k f x y z & more] (set a k (apply f (get a k) x y z more))))
 (defmacro fswap [O k f & args] `(swap (.-state- ~O) ~k ~f ~@args))
-(defn get [^objects a k] (aget a k))
 (defmacro fget [O k] `(get (.-state- ~O) ~k))
-(defmacro set [arr & kvs]
-  (let [ar (with-meta (gensym "arr") {:tag 'objects})]
-    `(let [~ar ~arr]
-       ~@(for [[k v] (partition 2 kvs)]
-           ;; FIXME better way to fix reflection warning than call `identity`?
-           `(aset ~ar ~k (identity ~v))))))
 (defmacro fset [O & kvs] `(set (.-state- ~O) ~@kvs))
-(defn getset [^objects a k v] (let [ret (aget a k)] (aset a k v) ret))
+(defn getset [^objects a k v] (let [ret (get a k)] (set a k v) ret))
 (defmacro fgetset [O k v] `(getset (.-state- ~O) ~k ~v))
-(defn getswap [^objects a k f] (let [ret (aget a k)] (swap a k f) ret))
+(defn getswap [^objects a k f] (let [ret (get a k)] (swap a k f) ret))
+
+(defn rot
+  ([^objects a i j] (let [tmp (get a i)] (set a i (get a j) j tmp)))
+  ([^objects a i j k] (let [tmp (get a i)] (set a i (get a j) j (get a k) k tmp)))
+  ([^objects a i j k l] (let [tmp (get a i)] (set a i (get a j) j (get a k) k (get a l) l tmp)))
+  ([^objects a i j k l & more]
+   (let [tmp (get a i)]
+     (rot a i j k l)
+     (loop [[i j :as more] (seq (cons l more))]
+       (if j
+         (do (set a i (get a j)) (recur (next more)))
+         (set a i tmp))))))
+
 
 ;;; TESTS ;;;
 (deftype P [state-])
@@ -43,3 +56,17 @@
     (getswap (.-state- aP) x inc) := 100
     (fget aP x)                   := 101
     ))
+
+(tests
+  (let [a (object-array [:a :b])]
+    (rot a 0 1)
+    (vec a) := [:b :a])
+  (let [a (object-array [:a :b :c])]
+    (rot a 0 2 1)
+    (vec a) := [:c :a :b])
+  (let [a (object-array [:a :b :c :d])]
+    (rot a 0 2 1 3)
+    (vec a) := [:c :d :b :a])
+  (let [a (object-array [:a :b :c :d :e :f :g])]
+    (apply rot a (range 7))
+    (vec a) := [:b :c :d :e :f :g :a]))

src/hyperfiddle/incseq/items_eager_impl.cljc

@@ -1,6 +1,7 @@
 (ns hyperfiddle.incseq.items-eager-impl
   (:require [contrib.data :refer [->box]]
-            [hyperfiddle.electric.impl.array-fields :as a])
+            [hyperfiddle.electric.impl.array-fields :as a]
+            [hyperfiddle.incseq.perm-impl :as p])
   #?(:clj (:import [clojure.lang IDeref IFn])))
 
 (def ps-field-count (a/deffields -input-ps -input-stepper -input-doner -diff -item*))
@@ -24,7 +25,7 @@
           (#?(:clj invoke :cljs -invoke) [_ v] (when (not= v (a/get a -cache)) (a/set a -cache v) ((a/get a -step))))
           IDeref (#?(:clj deref :cljs -deref) [_] (a/set a -step step-idle) (a/get a -cache)))))))
 
-(defn grow-input! [^Ps ps diff]
+(defn grow! [^Ps ps diff]
   (run! (fn [i]
           (let [^Item item (->Item (object-array item-field-count))]
             (a/fset item -ps* (->box #{}))
@@ -37,9 +38,14 @@
                                             item-ps))))))
     (range (- (:degree diff) (:grow diff)) (:degree diff))))
 
+(defn permute! [^Ps ps {p :permutation}]
+  (let [rot* (p/decompose conj #{} p)
+        item* (a/fget ps -item*)]
+    (run! (fn [rot] (apply a/rot item* rot)) rot*)))
+
 (defn ->item ^Item [^Ps ps i] (a/get (a/fget ps -item*) i))
 
-(defn change-input! [^Ps ps diff]
+(defn change! [^Ps ps diff]
   (reduce-kv (fn [_ i v]
                (let [^Item item (->item ps i)]
                  (a/fset item -v v)
@@ -49,12 +55,13 @@
 (defn transfer-input [^Ps ps]
   (let [diff @(a/fget ps -input-ps)]
     (a/fset ps -diff {:change {}})
-    (grow-input! ps diff)
-    (change-input! ps diff)
+    (grow! ps diff)
+    (permute! ps diff)
+    (change! ps diff)
     (dissoc diff :change)))
 
 (defn needed-diff? [d]
-  (or (seq (:permutation d)) (seq (:change d)) (pos? (:grow d)) (pos? (:shrink d)) (seq (:freeze d))))
+  (or (seq (:permutation d)) (pos? (:grow d)) (pos? (:shrink d)) (seq (:freeze d))))
 
 (defn consume-input-step [^Ps ps]
   (fn [] (when (needed-diff? (a/fswap ps -diff merge (transfer-input ps)))  ((.-step ps)))))

test/hyperfiddle/incseq/items_eager_impl_test.cljc

@@ -147,10 +147,35 @@
         _                  (q ::none)
         _                  (t/is (= ::none (q)))]))
 
+(t/deftest input-permutation
+  (let [q                  (->mq)
+        _                  (q (assoc (d/empty-diff 2) :grow 2 :change {0 :foo, 1 :bar})) ; what input will return on transfer
+        items              (spawn-ps q)
+        [in-step _in-done] (q)
+        _                  (t/is (= :items-step (q)))
+        diff               @items
+        _                  (t/is (= (assoc (d/empty-diff 2) :grow 2) (assoc diff :change {})))
+        item0              ((-> diff :change (get 0)) #(q :item0-step) #(q :item0-done))
+        _                  (t/is (= :item0-step (q)))
+        _                  (t/is (= :foo @item0))
+        item1              ((-> diff :change (get 1)) #(q :item1-step) #(q :item1-done))
+        _                  (t/is (= :item1-step (q)))
+        _                  (t/is (= :bar @item1))
+        perm               (assoc (d/empty-diff 2) :permutation {0 1, 1 0})
+        _                  (q perm)
+        _                  (in-step)
+        _                  (t/is (= :items-step (q)))
+        diff               @items
+        _                  (t/is (= perm diff))
+        _                  (q (assoc (d/empty-diff 2) :change {0 :baz}))
+        _                  (in-step)
+        _                  (t/is (= :item1-step (q))) ; change on 0 means item1 after permutation
+        _                  (t/is (= :baz @item1))
+        _                  (q ::none)
+        _                  (t/is (= ::none (q)))]))
+
 ;; missing tests
 ;; - item-ps cancellation
-;; - 2+ item-ps
-;; - input permutation
 ;; - input shrink
 ;;   - all item-ps want to terminate
 ;;   - new ps transfers last value and terminates