Add chess test

test/datahike/test/chess_model_test.clj

@@ -0,0 +1,158 @@
+(ns datahike.test.chess-model-test
+  (:require [clojure.test.check.clojure-test :refer [defspec]]
+            [clojure.test.check.generators :as gen]
+            [clojure.test.check.properties :as prop]
+            [datahike.api :as d]
+            [datahike.test.model.rng :as rng])
+  (:import [java.util UUID]))
+
+(def X ["A" "B" "C" "D" "E" "F" "G" "H"])
+(def Y (vec (range 1 9)))
+
+(def xmap (into {} (map-indexed (fn [i s] [s i])) X))
+
+(def empty-board (into {} (for [x X
+                                y Y]
+                            [[x y] nil])))
+
+(defn put-piece [board x y piece]
+  (let [id (:piece/id piece)]
+    (-> empty-board
+
+        ;; Reset any occurrence with this id.
+        (into (filter (fn [[_ piece]] (not= id (:piece/id piece)))) board)
+
+        ;; Then put the piece.
+        (assoc [x y] piece))))
+
+(defn threatens? [type xd yd]
+  (let [same-line? (or (zero? xd) (zero? yd))
+        same-diagonal? (or (= xd yd) (= (- xd) yd))
+        squared-distance (+ (* xd xd) (* yd yd))]
+    (case type
+      :rook same-line?
+      :knight (= 5 squared-distance)
+      :bishop same-diagonal?
+      :pawn (and (contains? {-1 1} xd)
+                 (= 1 yd))
+      :queen (or same-line? same-diagonal?)
+      :king (contains? #{1 2} squared-distance))))
+
+(defn board-datoms [board]
+  (-> []
+      (into (for [[[x0 y0] piece0] board
+                  [[x1 y1] piece1] board
+                  :when piece0
+                  :when piece1
+                  :when (not= [x0 y0] [x1 y1])
+                  :when (threatens? (:piece/type piece0) (- (xmap x1) (xmap x0)) (- y1 y0))]
+              [(:piece/id piece0) :piece/threatens (:piece/id piece1)]))
+      (into (mapcat (fn [[[x y] {:keys [piece/type piece/id]}]]
+                      (when type
+                        [[id :piece/type type]
+                         [id :piece/x x]
+                         [id :piece/y y]]))) board)))
+
+(def entity-id-start 10000)
+
+(defn step-board-1 [board rng]
+  (put-piece board
+             (rng/rand-nth-rng rng X)
+             (rng/rand-nth-rng rng Y)
+             (rng/random-branch rng
+                                nil
+                                (let [all-ids (vec (into #{} (keep (comp :piece/id val)) board))
+                                      default-next-id (inc (apply max entity-id-start all-ids))]
+                                  {:piece/type (rng/rand-nth-rng rng [:rook :knight :bishop :pawn :queen :king])
+                                   :piece/id (if (seq all-ids)
+                                               (rng/random-branch rng
+                                                                  default-next-id
+                                                                  (rng/rand-nth-rng rng all-ids))
+                                               default-next-id)}))))
+
+(defn step-board-n [board rng n]
+  (if (<= n 0)
+    board
+    (recur (step-board-1 board rng) rng (dec n))))
+
+(def chess-schema
+  [{:db/ident :piece/type
+    :db/valueType :db.type/keyword
+    :db/cardinality :db.cardinality/one}
+   {:db/ident :piece/x
+    :db/valueType :db.type/string
+    :db/cardinality :db.cardinality/one}
+   {:db/ident :piece/y
+    :db/valueType :db.type/long
+    :db/cardinality :db.cardinality/one}
+   {:db/ident :piece/threatens
+    :db/valueType :db.type/ref
+    :db/cardinality :db.cardinality/many}])
+
+(def user-attrs (into #{} (map :db/ident) chess-schema))
+
+(defn create-chess-db []
+  (let [cfg {:store {:backend :memory :id (UUID/randomUUID)}
+             :keep-history? true
+             :schema-flexibility :write}]
+    (d/delete-database cfg)
+    (d/create-database cfg)
+    (let [conn (d/connect cfg)]
+      (d/transact conn chess-schema)
+      conn)))
+
+(defn tx-data [old-datoms new-datoms]
+  (let [old-set (set old-datoms)
+        new-set (set new-datoms)]
+    (for [[op to-add to-remove] [[:db/add new-set old-set]
+                                 [:db/retract old-set new-set]]
+          [e a v :as datom] to-add
+          :when (not (to-remove datom))]
+      [op e a v])))
+
+(defn db-datoms
+  "Extract user datoms from database as [e a v] triples."
+  [db]
+  (into []
+        (keep (fn [[e a v]] (when (user-attrs a) [e a v])))
+        (d/datoms db :eavt)))
+
+(defn check-history [history db]
+  (every? (fn [[tx-id expected-datoms]]
+            (let [historic-db (d/as-of db tx-id)
+                  from-db (set (db-datoms historic-db))
+                  from-model (set expected-datoms)]
+              (= from-model from-db)))
+          (take-last 3 history)))
+
+(def seed-gen (gen/choose 0 9223372036854775807))
+
+(defn chess-sync-prop []
+  (prop/for-all [seed seed-gen]
+                (let [rng (rng/create seed)
+                      conn (create-chess-db)
+                      iterations 20]
+                  (loop [i 0
+                         board empty-board
+                         prev-datoms []
+                         history []]
+                    (if (>= i iterations)
+                      true
+                      (let [board' (step-board-n board rng 4)
+                            new-datoms (board-datoms board')
+                            tx (tx-data prev-datoms new-datoms)
+                            tx-id (when (seq tx)
+                                    (:max-tx (:db-after (d/transact conn {:tx-data tx}))))
+                            db (d/db conn)
+                            from-db (set (db-datoms db))
+                            from-board (set new-datoms)
+                            history' (if tx-id
+                                       (conj history [tx-id new-datoms])
+                                       history)]
+                        (if (and (= from-board from-db)
+                                 (check-history history' db))
+                          (recur (inc i) board' new-datoms history')
+                          false)))))))
+
+(defspec chess-board-sync 30
+  (chess-sync-prop))

test/datahike/test/model/rng.cljc

@@ -58,6 +58,10 @@
   [rng coll]
   (nth coll (next-int rng (count coll))))
 
+(defmacro random-branch [rng & branches]
+  `(case (next-int ~rng ~(count branches))
+     ~@(into [] (comp (map-indexed vector) cat) branches)))
+
 (defn weighted-sample-rng
   [rng pairs]
   (let [sum (transduce (map second) + pairs)
@@ -79,4 +83,4 @@
               vi (v i)
               vj (v j)]
           (recur (dec i) (assoc v i vj j vi)))
-        v))))
+        v))))

test/datahike/test/model_test.clj

@@ -214,4 +214,4 @@
           parent-val (rng/next-int rng 100)
           child-val (rng/next-int child 100)]
       (is (number? parent-val))
-      (is (number? child-val)))))
+      (is (number? child-val)))))