diff --git a/src/hyperfiddle/electric/impl/array_fields.cljc b/src/hyperfiddle/electric/impl/array_fields.cljc index 19c44abb8..24a3170b0 100644 --- a/src/hyperfiddle/electric/impl/array_fields.cljc +++ b/src/hyperfiddle/electric/impl/array_fields.cljc @@ -23,7 +23,7 @@ (defmacro fswap [O k f & args] `(swap (.-state- ~O) ~k ~f ~@args)) (defmacro fget [O k] `(get (.-state- ~O) ~k)) (defmacro fset [O & kvs] `(set (.-state- ~O) ~@kvs)) -(defn getset [^objects a k v] (let [ret (get a k)] (set a k v) ret)) +(defn getset [^objects a k v] (let [ret (get a k)] (when (not= ret v) (set a k v)) ret)) (defmacro fgetset [O k v] `(getset (.-state- ~O) ~k ~v)) (defn getswap [^objects a k f] (let [ret (get a k)] (swap a k f) ret)) diff --git a/src/hyperfiddle/incseq/items_eager_impl.cljc b/src/hyperfiddle/incseq/items_eager_impl.cljc index 20f443577..f5cb61cd4 100644 --- a/src/hyperfiddle/incseq/items_eager_impl.cljc +++ b/src/hyperfiddle/incseq/items_eager_impl.cljc @@ -2,61 +2,94 @@ (:require [contrib.data :refer [->box]] [hyperfiddle.electric.impl.array-fields :as a] [hyperfiddle.incseq.perm-impl :as p]) - #?(:clj (:import [clojure.lang IDeref IFn]))) + (:import #?(:clj [clojure.lang IDeref IFn]) + [missionary Cancelled])) (def ps-field-count (a/deffields -input-ps -input-stepper -input-doner -diff -item*)) (deftype Ps [step done state-] IFn (#?(:clj invoke :cljs -invoke) [_] ((a/get state- -input-ps)) (done)) IDeref (#?(:clj deref :cljs -deref) [_] (a/get state- -diff))) -(def item-field-count (a/deffields -v -flow -ps*)) +(def item-field-count (a/deffields -v -flow -ps* -dead)) (deftype Item [state-]) -(def item-ps-field-count (a/deffields -step -done -cache)) +(def item-ps-field-count (a/deffields -stepped -cache -cancelled)) + +(defn remove-item-ps [^Item item ps] (let [ps* (a/fget item -ps*)] (ps* (disj (ps*) ps)))) + +(defn cleanup-item-ps [ps a done] (when-not (identical? ps (a/getset a -cache ps)) (done))) + +(defn ->item-ps [^Item item step done] + (let [a (object-array item-ps-field-count)] + (a/set a -cache a, -cancelled false) + (reify + IFn + (#?(:clj invoke :cljs -invoke) [this] + (remove-item-ps item this) + (let [cancelled? (a/getset a -cancelled true)] + (when (not (or (a/getset a -stepped true) cancelled?)) (step)))) + (#?(:clj invoke :cljs -invoke) [_ v] + (when-not (or (= v (a/getset a -cache v)) (a/getset a -stepped true)) + (step))) + IDeref + (#?(:clj deref :cljs -deref) [this] + (a/set a -stepped false) + (if (a/get a -cancelled) + (do (cleanup-item-ps this a done) (throw (Cancelled.))) + (a/get a -cache)))))) + (let [nul #?(:clj (Object.) :cljs (js/Object.))] - (defn ->item-ps [^Item item step done] - (let [a (object-array item-ps-field-count)] - (a/set a -cache nul) - (letfn [(step-idle [] (a/set a -step step-loaded) (step)) - (step-loaded [])] - (a/set a -step step-idle) - (reify - IFn (#?(:clj invoke :cljs -invoke) [this] (let [ps* (a/fget item -ps*)] (ps* (disj (ps*) this))) (done)) - (#?(: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 ->dead-item-ps [step done -v] + (step) + (let [ (->box -v)] + (reify + IFn (#?(:clj invoke :cljs -invoke) [_] ( nul)) + IDeref (#?(:clj deref :cljs -deref) [this] + (done) + (if (identical? nul ()) (throw (Cancelled.)) (let [v ()] ( this) v))))))) -(defn grow! [^Ps ps diff] +(defn grow! [^Ps ps {d :degree, n :grow}] (run! (fn [i] (let [^Item item (->Item (object-array item-field-count))] (a/fset item -ps* (->box #{})) (a/set (a/fget ps -item*) i item) (a/fswap ps -diff update :change assoc i (a/fset item -flow (fn [step done] - (let [item-ps (->item-ps item step done), ps* (a/fget item -ps*)] - (ps* (conj (ps*) item-ps)) - (item-ps (a/fget item -v)) - item-ps)))))) - (range (- (:degree diff) (:grow diff)) (:degree diff)))) + (if (a/fget item -dead) + (->dead-item-ps step done (a/fget item -v)) + (let [item-ps (->item-ps item step done), ps* (a/fget item -ps*)] + (ps* (conj (ps*) item-ps)) + (item-ps (a/fget item -v)) + item-ps))))))) + (range (- d n) d))) (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 shrink! [^Ps ps {d :degree, n :shrink}] + (let [item* (a/fget ps -item*)] + (run! (fn [i] + (let [^Item item (a/get item* i)] + (a/fset item -dead true) + (run! #(%) ((a/fget item -ps*))))) + (range (- d n) d)))) (defn change! [^Ps ps diff] - (reduce-kv (fn [_ i v] - (let [^Item item (->item ps i)] - (a/fset item -v v) - (run! (fn [item-ps] (item-ps v)) ((a/fget item -ps*))))) - nil (:change diff))) + (let [item* (a/fget ps -item*)] + (reduce-kv (fn [_ i v] + (let [^Item item (a/get item* i)] + (a/fset item -v v) + (run! (fn [item-ps] (item-ps v)) ((a/fget item -ps*))))) + nil (:change diff)))) (defn transfer-input [^Ps ps] (let [diff @(a/fget ps -input-ps)] (a/fset ps -diff {:change {}}) (grow! ps diff) (permute! ps diff) + (shrink! ps diff) (change! ps diff) (dissoc diff :change))) diff --git a/test/hyperfiddle/incseq/items_eager_impl_test.cljc b/test/hyperfiddle/incseq/items_eager_impl_test.cljc index e556c5359..5dd7d68e5 100644 --- a/test/hyperfiddle/incseq/items_eager_impl_test.cljc +++ b/test/hyperfiddle/incseq/items_eager_impl_test.cljc @@ -4,8 +4,8 @@ [contrib.assert :as ca] [hyperfiddle.incseq.diff-impl :as d] [hyperfiddle.incseq.items-eager-impl :as items]) - #?(:clj (:import - [clojure.lang ExceptionInfo IDeref IFn]))) + (:import #?(:clj [clojure.lang ExceptionInfo IDeref IFn]) + [missionary Cancelled])) (defn ->queue ([] #?(:clj clojure.lang.PersistentQueue/EMPTY :cljs #queue [])) @@ -42,7 +42,7 @@ _ (q (d/empty-diff 0)) ; what input will return on transfer ps (spawn-ps q) ;; transfer (fn transfer [diff] (q diff) @ps) - [_input-step _in-done] (q) + [_in-step _in-done] (q) _ (t/is (= :items-step (q))) _ (t/is (= (d/empty-diff 0) @ps))])) @@ -50,7 +50,7 @@ (let [q (->mq) _ (q (assoc (d/empty-diff 1) :grow 1 :change {0 :foo})) ; what input will return on transfer items (spawn-ps q) - [_input-step _in-done] (q) + [_in-step _in-done] (q) _ (t/is (= :items-step (q))) diff @items _ (t/is (= (assoc (d/empty-diff 1) :grow 1) (assoc diff :change {}))) @@ -147,7 +147,7 @@ _ (q ::none) _ (t/is (= ::none (q)))])) -(t/deftest input-permutation +(t/deftest 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) @@ -174,11 +174,122 @@ _ (q ::none) _ (t/is (= ::none (q)))])) +(t/deftest shrink-terminates-idle-item-ps + (let [q (->mq) + _ (q (assoc (d/empty-diff 1) :grow 1 :change {0 :foo})) ; 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 1) :grow 1) (assoc diff :change {}))) + item0 ((-> diff :change (get 0)) #(q :item0-step) #(q :item0-done)) + _ (t/is (= :item0-step (q))) + _ (t/is (= :foo @item0)) + shrink1 (assoc (d/empty-diff 1) :shrink 1) + _ (q shrink1) + _ (in-step) + _ (t/is (= :item0-step (q))) + _ (t/is (= :items-step (q))) + _ (t/is (= shrink1 @items)) + _ (t/is (thrown? Cancelled @item0)) + _ (t/is (= :item0-done (q))) + _ (q ::none) + _ (t/is (= ::none (q)))])) + +(t/deftest shrink-terminates-stepped-item-ps + (let [q (->mq) + _ (q (assoc (d/empty-diff 1) :grow 1 :change {0 :foo})) ; 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 1) :grow 1) (assoc diff :change {}))) + item0 ((-> diff :change (get 0)) #(q :item0-step) #(q :item0-done)) + _ (t/is (= :item0-step (q))) + shrink1 (assoc (d/empty-diff 1) :shrink 1) + _ (q shrink1) + _ (in-step) + _ (t/is (= :items-step (q))) + _ (t/is (= shrink1 @items)) + _ (t/is (thrown? Cancelled @item0)) + _ (t/is (= :item0-done (q))) + _ (q ::none) + _ (t/is (= ::none (q)))])) + +(t/deftest item-spawned-after-shrink-returns-last-value-and-terminates + (let [q (->mq) + _ (q (assoc (d/empty-diff 1) :grow 1 :change {0 :foo})) ; 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 1) :grow 1) (assoc diff :change {}))) + item0-flow (-> diff :change (get 0)) + shrink1 (assoc (d/empty-diff 1) :shrink 1) + _ (q shrink1) + _ (in-step) + _ (t/is (= :items-step (q))) + _ (t/is (= shrink1 @items)) + item0 (item0-flow #(q :item0-step) #(q :item0-done)) + _ (t/is (= :item0-step (q))) + _ (t/is (= :foo @item0)) + _ (t/is (= :item0-done (q))) + _ (q ::none) + _ (t/is (= ::none (q)))])) + +(t/deftest item-spawned-after-shrink-and-cancelled-throws-and-terminates + (let [q (->mq) + _ (q (assoc (d/empty-diff 1) :grow 1 :change {0 :foo})) ; 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 1) :grow 1) (assoc diff :change {}))) + item0-flow (-> diff :change (get 0)) + shrink1 (assoc (d/empty-diff 1) :shrink 1) + _ (q shrink1) + _ (in-step) + _ (t/is (= :items-step (q))) + _ (t/is (= shrink1 @items)) + item0 (item0-flow #(q :item0-step) #(q :item0-done)) + _ (t/is (= :item0-step (q))) + _ (item0) + _ (t/is (thrown? Cancelled @item0)) + _ (t/is (= :item0-done (q))) + _ (q ::none) + _ (t/is (= ::none (q)))])) + +(t/deftest item-ps-cancellation-idle + (let [q (->mq) + _ (q (assoc (d/empty-diff 1) :grow 1 :change {0 :foo})) ; 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 1) :grow 1) (assoc diff :change {}))) + item0 ((-> diff :change (get 0)) #(q :item0-step) #(q :item0-done)) + _ (t/is (= :item0-step (q))) + _ (t/is (= :foo @item0)) + _ (item0) + _ (t/is (= :item0-step (q))) + _ (t/is (thrown? Cancelled @item0)) + _ (t/is (= :item0-done (q)))])) + +(t/deftest item-ps-cancellation-stepped + (let [q (->mq) + _ (q (assoc (d/empty-diff 1) :grow 1 :change {0 :foo})) ; 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 1) :grow 1) (assoc diff :change {}))) + item0 ((-> diff :change (get 0)) #(q :item0-step) #(q :item0-done)) + _ (t/is (= :item0-step (q))) + _ (item0) + _ (t/is (thrown? Cancelled @item0)) + _ (t/is (= :item0-done (q)))])) + ;; missing tests -;; - item-ps cancellation -;; - input shrink -;; - all item-ps want to terminate -;; - new ps transfers last value and terminates ;; - input terminate ;; - failures ;; - thread safety