Merge branch 'de'

.clj-kondo/config.edn

@@ -2,5 +2,6 @@
            hyperfiddle.electric3/for     clojure.core/let
            hyperfiddle.electric3/cursor  clojure.core/let
            hyperfiddle.electric3/with-cycle clojure.core/let
-           hyperfiddle.electric3/fn      clojure.core/fn}
+           hyperfiddle.electric3/fn      clojure.core/fn
+           hyperfiddle.electric.impl.array-fields/deffields clojure.core/declare}
  :linters {:redundant-expression {:level :off}}}

.clj-kondo/hyperfiddle/electric/config.edn

@@ -1,7 +1,7 @@
 {:lint-as {hyperfiddle.electric/def        clojure.core/def
            hyperfiddle.electric/defn       clojure.core/defn
-           hyperfiddle.electric-de/defn    clojure.core/defn
-           hyperfiddle.electric-de/cursor  clojure.core/for
+           hyperfiddle.electric3/defn    clojure.core/defn
+           hyperfiddle.electric3/cursor  clojure.core/for
            hyperfiddle.electric/for        clojure.core/for
            hyperfiddle.electric/with-cycle clojure.core/let
            hyperfiddle.electric/fn         clojure.core/fn}

deps.edn

@@ -3,7 +3,6 @@
          com.cognitect/transit-cljs {:mvn/version "0.8.280"}
          com.hyperfiddle/rcf        {:mvn/version "20220926-202227"}
          missionary/missionary      {:mvn/version "b.35"}
-         dom-top/dom-top            {:mvn/version "1.0.9"} ; for loopr macro
          fipp/fipp                  {:mvn/version "0.6.26"}
          org.clojure/clojure        {:mvn/version "1.12.0-alpha11"}
          org.clojure/clojurescript  {:mvn/version "1.11.121"}

src/contrib/data.cljc

@@ -353,3 +353,11 @@
   ([f a b c d e] (fn [o] (f o a b c d e))))
 
 (defn keep-if [v pred] (when (pred v) v))
+
+(defn ->box
+  ([] (->box nil))
+  ([init] (let [o (doto (object-array 1) (aset (int 0) init))]
+            (fn box
+              ([] (aget o (int 0)))
+              ([v] (aset o (int 0) v))
+              ([retf swapf] (let [v (box), ret (retf v)] (box (swapf v)) ret))))))

src/contrib/triple_store.clj → src/contrib/triple_store.cljc

@@ -1,8 +1,8 @@
 (ns contrib.triple-store
   (:refer-clojure :exclude [find])
-  (:require [dom-top.core :refer [loopr]]
-            [clojure.set :as set]
-            [contrib.assert :as ca]))
+  (:require [clojure.set :as set]
+            [contrib.assert :as ca]
+            [contrib.data :refer [->box]]))
 
 ;; ts - triple store
 ;; e  - entity    (id of entity)
@@ -18,27 +18,25 @@
 ;; ave :foo 1 -> (sorted-set 1 2) <- sorted so e.g. :parent e is well ordered
 ;; vea 1 1 -> #{:foo :bar}    CURRENTLY NOT USED/FILLED
 
-(defrecord TripleStore [o eav ave vea])
+(defrecord TripleStore [o eav ave])
 
-(defn ->ts ([] (->ts {})) ([o] (->TripleStore o {} {} {})))
+(defn ->ts ([] (->ts {})) ([o] (->TripleStore o {} {})))
 
 (defn add [ts nd]
   (let [e (get nd :db/id)
-        [eav ave vea]
-        (loopr [eav (:eav ts), ave (:ave ts), vea (:vea ts)]
-          [[a v] nd]
-          (recur (update eav e assoc a v)
-            (update ave a update v (fnil conj (sorted-set)) e)
-            vea
-            #_(update vea v update e (fnil conj #{}) a)))]
-    (->TripleStore (:o ts) eav ave vea)))
+        -eav (->box (:eav ts)), -ave (->box (:ave ts))]
+    (reduce-kv (fn [_ a v]
+                 (-eav (update (-eav) e assoc a v))
+                 (-ave (update (-ave) a update v (fnil conj (sorted-set)) e)))
+      nil nd)
+    (->TripleStore (:o ts) (-eav) (-ave))))
 
 (defn del [ts e]
   (let [nd (-> ts :eav (get e))
-        {:keys [o eav ave vea]} ts
+        {:keys [o eav ave]} ts
         eav (dissoc eav e)
         ave (reduce-kv (fn [ave a v] (update ave a update v disj e)) ave nd)]
-    (->TripleStore o eav ave vea)))
+    (->TripleStore o eav ave)))
 
 (defn upd [ts e a f]
   (let [v0 (-> ts :eav (get e) (get a))
@@ -48,26 +46,13 @@
               (:ave ts)
               (let [ave (update (:ave ts) a update v1 (fnil conj (sorted-set)) e)
                     ave (cond-> ave (contains? (get ave a) v0) (update a update v0 disj e))]
-                (cond-> ave (not (seq (-> ave (get a) (get v0)))) (update a dissoc v0))))
-        vea (:vea ts)
-        ;; vea (update (:vea ts) v1 update e (fnil conj #{}) a)
-        ;; vea (cond-> vea (contains? (get vea v0) e) (update v0 update e disj a))
-        ]
-    (->TripleStore (:o ts) eav ave vea)))
+                (cond-> ave (not (seq (-> ave (get a) (get v0)))) (update a dissoc v0))))]
+    (->TripleStore (:o ts) eav ave)))
 
 (defn asc
   ([ts e a v] (upd ts e a (fn [_] v)))
   ([ts e a v & avs] (apply asc (asc ts e a v) e avs)))
 
-(defn get-entity [ts e] (get (:eav ts) e))
-
-(defn ->datoms [ts]
-  (loopr [datoms (transient [])]
-    [[e av] (:eav ts)
-     [a v] av]
-    (recur (conj! datoms [e a v]))
-    (persistent! datoms)))
-
 ;;;;;;;;;;;;;;;
 ;;; HELPERS ;;;
 ;;;;;;;;;;;;;;;

src/hyperfiddle/electric/impl/array_fields.cljc

@@ -2,29 +2,51 @@
   (: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)))))
+           `(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)] (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 (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 set= [^objects a i oldv newv] (if (= oldv (get a i)) (do (set a i newv) true) false))
+(defmacro fset= [O i oldv newv] `(set= (.-state- ~O) ~i ~oldv ~newv))
+(defn set-not= [^objects a i oldv newv] (if (not= oldv (get a i)) (do (set a i newv) true) false))
+(defmacro fset-not= [O i oldv newv] `(set-not= (.-state- ~O) ~i ~oldv ~newv))
+
+(defn copy [x y n] #?(:clj (System/arraycopy x 0 y 0 n) :cljs (dotimes [i n] (aset y i (aget x i))))  y)
+(defn overfit [k n] (loop [k (* 2 k)] (if (>= k n) k (recur (* 2 k)))))
+(defn ensure-fits ^objects [^objects a n] (let [l (alength a)] (cond-> a (< l n) (copy (object-array (overfit l n)) l))))
+
+(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-])
@@ -42,3 +64,21 @@
     (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]))
+
+(tests
+  (alength (ensure-fits (object-array 2) 9)) := 16
+  )

src/hyperfiddle/electric/impl/lang3.clj

@@ -4,10 +4,9 @@
             [cljs.env]
             [clojure.string :as str]
             [contrib.assert :as ca]
-            [contrib.data :refer [keep-if]]
+            [contrib.data :refer [keep-if ->box]]
             [clojure.set :as set]
             [contrib.triple-store :as ts]
-            [dom-top.core :refer [loopr]]
             [fipp.edn]
             [hyperfiddle.electric3 :as-alias e]
             [hyperfiddle.electric.impl.cljs-analyzer2 :as cljs-ana]
@@ -110,14 +109,12 @@
   (let [ns (-> env :ns :name), {:keys [line column]} (meta o)]
     (str ns ":" line ":" column " " o)))
 
-(defn js-uppercase-sym? [sym] (re-matches #"^js/(Math|String).*$" (str sym)))
-
 (defn electric-sym? [sym]
   (let [s (name sym)]
     (and (pos? (.length s))
       (Character/isUpperCase (.charAt s 0))
       (not (re-matches #"G__\d+" s))    ; default gensym generated symbols
-      (not (js-uppercase-sym? sym))
+      (not= "js" (namespace sym))
       (not= 'RCF__tap sym))))
 
 (defn ?expand-macro [o env caller]
@@ -136,9 +133,10 @@
   `(::call ((::static-vars r/dispatch) '~F ~F ~@(map (fn [arg] `(::pure ~arg)) args))))
 
 (defn -expand-let-bindings [bs env]
-  (loopr [bs2 [], env2 env]
-    [[sym v] (eduction (partition-all 2) bs)]
-    (recur (conj bs2 sym (-expand-all-foreign v env2)) (add-local env2 sym))))
+  (let [<env> (->box env)
+        f (fn [bs [sym v]] (let [env (<env>)] (<env> (add-local env sym)) (conj bs sym (-expand-all-foreign v env))))
+        bs (transduce (partition-all 2) (completing f) [] bs)]
+    [bs (<env>)]))
 
 (defn jvm-type? [sym] (try (.getJavaClass (clojure.lang.Compiler$VarExpr. nil sym)) (catch Throwable _)))
 
@@ -245,11 +243,11 @@
         (let [[_ bs & body] o] (recur (?meta o (list* 'let* (dst/destructure* bs) body)) env))
 
         (let*) (let [[_ bs & body] o
-                     [bs2 env2] (loopr [bs2 [] , env2 env]
-                                  [[sym v] (eduction (partition-all 2) bs)]
-                                  (let [sym (?untag sym env2)]
-                                    (recur (conj bs2 sym (-expand-all v env2)) (add-local env2 sym))))]
-                 (?meta o (list 'let* bs2 (-expand-all (?meta body (cons 'do body)) env2))))
+                     <env> (->box env)
+                     f (fn [bs [sym v]]
+                         (let [env (<env>)] (<env> (add-local env sym)) (conj bs sym (-expand-all v env))))
+                     bs2 (transduce (partition-all 2) (completing f) [] bs)]
+                 (?meta o (list 'let* bs2 (-expand-all (?meta body (cons 'do body)) (<env>)))))
 
         (loop*) (let [[_ bs & body] o
                       [bs2 env2] (reduce
@@ -564,13 +562,14 @@
                             ts (analyze v e env ts)]
                         (recur bform e env ts))
         (case) (let [[_ test & brs] form
-                     [default brs2] (if (odd? (count brs)) [(last brs) (butlast brs)] [:TODO brs])]
-                 (loopr [bs [], mp {}]
-                   [[v br] (partition 2 brs2)]
-                   (let [b (gensym "case-val")]
-                     (recur (conj bs b `(::ctor ~br))
-                       (reduce (fn [ac nx] (assoc ac (list 'quote nx) b)) mp (if (seq? v) v [v]))))
-                   (recur (?meta form `(let* ~bs (::call (~mp ~test (::ctor ~default))))) pe env ts)))
+                     [default brs2] (if (odd? (count brs)) [(last brs) (butlast brs)] [:TODO brs])
+                     <mp> (->box {})
+                     f (fn [bs [v br]]
+                         (let [b (gensym "case-val")]
+                           (<mp> (reduce (fn [ac nx] (assoc ac (list 'quote nx) b)) (<mp>) (if (seq? v) v [v])))
+                           (conj bs b `(::ctor ~br))))
+                     bs (transduce (partition-all 2) (completing f) [] brs2)]
+                 (recur (?meta form `(let* ~bs (::call (~(<mp>) ~test (::ctor ~default))))) pe env ts))
         (quote) (let [e (->id)]
                   (-> ts (ts/add {:db/id e, ::parent pe, ::type ::pure})
                     (ts/add {:db/id (->id), ::parent e, ::type ::literal, ::v form})))
@@ -761,14 +760,15 @@
            (let [[l bs & body] form, let*-u (->u)
                  ts (addf ts let*-u p ->i {::t (case l (let*) ::let* (loop*) ::loop*)})
                  ->sym-i (->->id)
-                 [ts2 env2] (loopr [ts2 ts, env2 env]
-                              [[sym v] (eduction (partition-all 2) bs)]
-                              (let [sym-u (->u)]
-                                (recur (-> ts2 (addf sym-u let*-u ->sym-i {::t ::let*-sym, ::sym sym})
-                                         (analyze-foreign v env2 sym-u (->->id)))
-                                  (add-foreign-local env2 sym))))
+                 <env> (->box env)
+                 f (fn [ts2 [sym v]]
+                     (let [sym-u (->u), env (<env>)]
+                       (<env> (add-foreign-local env sym))
+                       (-> ts2 (addf sym-u let*-u ->sym-i {::t ::let*-sym, ::sym sym})
+                         (analyze-foreign v env sym-u (->->id)))))
+                 ts2 (transduce (partition-all 2) (completing f) ts bs)
                  body-u (->u), ->body-i (->->id)]
-             (reduce (fn [ts nx] (analyze-foreign ts nx env2 body-u ->body-i))
+             (reduce (fn [ts nx] (analyze-foreign ts nx (<env>) body-u ->body-i))
                (addf ts2 body-u let*-u (->->id) {::t ::body}) body))
 
            (binding clojure.core/binding)
@@ -984,30 +984,31 @@
      (emit u))))
 
 (defn wrap-foreign-for-electric
-  ([ts] (wrap-foreign-for-electric ts gensym))
+  ([ts] (wrap-foreign-for-electric ts #(gensym (str/replace % #"/" "_"))))
   ([ts gen]
    (letfn [(->node [u] (ts/->node ts (ts/find1 ts ::u u)))
            (e->u [e] (::u (ts/->node ts e)))
            (order [u*] (sort-by (comp ::i ->node) u*))
            (find [& kvs] (order (eduction (map e->u) (apply ts/find ts kvs))))
            (? [u k] (get (->node u) k))]
-     (let [[ts arg* val* dyn*]
-           (loopr [ts ts, arg* [], val* [], dyn* [], seen {}]
-             [u (remove #(let [nd (->node %)] (and (zero? (::i nd))
-                                                (not= -1 (::p nd))
-                                                (= ::set! (? (::p nd) ::t))))
-                  (find ::t ::var))]
-             (let [nd (->node u), r (::resolved nd), s (::sym nd)]
-               (if (:dynamic (::meta nd))
-                 (if (seen r)
-                   (recur ts arg* val* dyn* seen)
-                   (let [lex (gen (name r))]
-                     (recur ts (conj arg* lex) (conj val* r) (into dyn* [s lex]) (assoc seen r true))))
-                 (if-some [lex (seen r)]
-                   (recur (ts/asc ts (:db/id nd) ::sym lex) arg* val* dyn* seen)
-                   (let [lex (gen (name s))]
-                     (recur (ts/asc ts (:db/id nd) ::sym lex)
-                       (conj arg* lex) (conj val* r) dyn* (assoc seen r lex)))))))
+     (let [<arg*> (->box []), <val*> (->box []), <dyn*> (->box []), <seen> (->box {})
+           f (fn [ts u]
+               (let [nd (->node u), r (::resolved nd), s (::sym nd), seen (<seen>)]
+                 (if (:dynamic (::meta nd))
+                   (if (seen r)
+                     ts
+                     (let [lex (gen (name r))]
+                       (<arg*> (conj (<arg*>) lex))     (<val*> (conj (<val*>) r))
+                       (<dyn*> (into (<dyn*>) [s lex])) (<seen> (assoc seen r true))
+                       ts))
+                   (if-some [lex (seen r)]
+                     (ts/asc ts (:db/id nd) ::sym lex)
+                     (let [lex (gen (name s))]
+                       (<arg*> (conj (<arg*>) lex)) (<val*> (conj (<val*>) r)) (<seen> (assoc seen r lex))
+                       (ts/asc ts (:db/id nd) ::sym lex))))))
+           xf (remove #(let [nd (->node %)] (and (zero? (::i nd)) (not= -1 (::p nd)) (= ::set! (? (::p nd) ::t)))))
+           ts (transduce xf (completing f) ts (find ::t ::var))
+           arg* (<arg*>), val* (<val*>), dyn* (<dyn*>)
            code (cond->> (emit-foreign ts) (seq dyn*) (list 'binding dyn*))
            e-local* (into [] (comp (map #(? % ::sym)) (distinct)) (find ::t ::electric-local))]
        (when (or (seq arg*) (seq e-local*))