From 5bbe4a179948afd85027b62e982144f678333e42 Mon Sep 17 00:00:00 2001 From: Brian Goslinga Date: Fri, 9 Mar 2012 19:20:05 -0600 Subject: [PATCH] Added persistent memory tables. --- src/main/clojure/clojure/core/logic.clj | 151 +++++++++++++++++++++++++ src/test/clojure/clojure/core/logic/tests.clj | 71 ++++++++++++ 2 files changed, 222 insertions(+), 0 deletions(-) diff --git a/src/main/clojure/clojure/core/logic.clj b/src/main/clojure/clojure/core/logic.clj index e0aa16d..26bbd87 100644 --- a/src/main/clojure/clojure/core/logic.clj +++ b/src/main/clojure/clojure/core/logic.clj @@ -1650,6 +1650,157 @@ (retractions rel [(vec tuple)])) ;; ============================================================================= +;; Persistent Memory Tables + +(defprotocol ITableRel + (add-rows [this rows] "Return an ITableRel with the given rows added") + (remove-rows [this rows] "Return an ITableRel with the given rows removed") + (all-rows [this] "Return a set of all of the rows in the table") + (arity-of [this] "Return the arity (number of columns) in the table")) + +(defn lazy-intersection + "Lazily compute the intersection of the given sets." + [sets] + (if (seq sets) + (let [[source & filters] (sort-by count sets)] + (filter (fn [element] + (every? #(% element) filters)) + source)))) + +(defmacro make-table-rel-ctor + [ncols idxs] + (let [rows (gensym "rows") + indexes (gensym "indexes") + subst (gensym "subst") + set (gensym "set") + arg-sym #(symbol (str "arg" %)) + idx-sym #(symbol (str "idx" %)) + args (vec (map arg-sym (range ncols))) + check-arg (fn [i] `(let [wa# (walk* ~subst ~(arg-sym i))] + (if-not (contains-lvar? wa#) + (~(idx-sym i) wa#)))) + idx-sets (vec (map check-arg idxs)) + single-idx-set (->> + idxs + reverse + (map (fn [i] + (fn [else-branch] + `(let [wa# (walk* ~subst ~(arg-sym i))] + (if (contains-lvar? wa#) + ~else-branch + (~(idx-sym i) wa#)))))) + (reduce (fn [code f] + (f code)) + rows)) + gen-stream `(to-stream + (->> ~set + (map (fn [cand#] + (when-let [~subst (unify ~subst [~@args] cand#)] + ~subst))) + (remove nil?)))] + `(fn [~rows ~indexes] + (let [~@(mapcat (fn [i] [(idx-sym i) `(~indexes ~i)]) idxs)] + (fn [~@args] + (fn [~subst] + ~(cond + (empty? idxs) + `(let [~set ~rows] + ~gen-stream) + + (= (count idxs) 1) + `(let [~set ~single-idx-set] + ~gen-stream) + + :else + `(let [indexed-sets# (remove nil? ~idx-sets) + ~set (if (seq indexed-sets#) + (lazy-intersection indexed-sets#) + ~rows)] + ~gen-stream)))))))) + +(declare row-diff-impl) + +(defmacro TableRelHelper + [arity] + (let [sigs (map (fn [n] + (let [args (map a-sym (range 0 n))] + `(~'invoke [~'_ ~@args] (~'f ~@args)))) + (range 1 (+ arity 2)))] + `(deftype ~'TableRel ~'[meta rows indexes arity ^clojure.lang.IFn f g] + clojure.lang.IObj + (~'withMeta [~'this ~'meta] + (~'TableRel. ~'meta ~'rows ~'indexes ~'arity ~'f ~'g)) + (~'meta [~'_] + ~'meta) + clojure.lang.IFn + ~@sigs + (~'applyTo [~'_ ~'arglist] + (~'.applyTo ~'f ~'arglist)) + ITableRel + (~'add-rows [~'this ~'new-rows] + (if (seq ~'new-rows) + (row-diff-impl ~'this ~'new-rows conj) + ~'this)) + (~'remove-rows [~'this ~'new-rows] + (if (seq ~'new-rows) + (row-diff-impl ~'this ~'new-rows disj) + ~'this)) + (~'all-rows [~'this] + ~'rows) + (~'arity-of [~'this] + ~'arity) + Object + (~'hashCode [~'this] + (bit-xor (* 31 ~'arity) (hash ~'rows))) + (~'equals [~'this ~'o] + (cond + (nil? ~'o) false + (identical? ~'this ~'o) true + (not= ~'arity (arity-of ~'o)) false + :else (= ~'rows (all-rows ~'o))))))) + +(TableRelHelper 20) + +(defn- make-table-rel + [^TableRel rel rows indexes] + (let [meta (.meta rel) + arity (.arity rel) + g (.g rel) + f (g rows indexes)] + (TableRel. meta rows indexes arity f g))) + +(defn- update-index + [index column rows f] + (persistent! + (reduce (fn [index row] + (let [key (nth row column) + res (f (get index key #{}) row)] + (if (seq res) + (assoc! index key res) + (dissoc! index key)))) + (transient index) + rows))) + +(defn- row-diff-impl + [^TableRel rel rows f] + (assert (if (seq rows) (= (count (first rows)) (.arity rel)) true)) + (let [update-index (fn [res-index [col index]] + (assoc res-index col (update-index index col rows f))) + indexes (reduce update-index {} (.indexes rel)) + rows (reduce f (.rows rel) rows)] + (make-table-rel rel rows indexes))) + +(defmacro table-rel + "Drop in replacement for defrel. Returns an empty table rel." + [& cols] + (let [arity (count cols) + idxs (keep-indexed (fn [i sym] (if (:index (meta sym)) i)) cols) + indexes (zipmap idxs (repeat {}))] + `(let [g# (make-table-rel-ctor ~arity [~@idxs]) + f# (g# #{} ~indexes)] + (TableRel. {} #{} ~indexes ~arity f# g#)))) + +;; ============================================================================= ;; Tabling ;; ----------------------------------------------------------------------------- diff --git a/src/test/clojure/clojure/core/logic/tests.clj b/src/test/clojure/clojure/core/logic/tests.clj index 35c876c..5defa53 100644 --- a/src/test/clojure/clojure/core/logic/tests.clj +++ b/src/test/clojure/clojure/core/logic/tests.clj @@ -1087,6 +1087,77 @@ '(1)))) ;; ----------------------------------------------------------------------------- +;; Persistent memory tables + +(deftest test-mem-table-lookup + (let [rel-squares (add-rows (table-rel ^{:index true} n sq) + (map #(vector % (* % %)) (range 1000)))] + (is (= (run* [q] (rel-squares 9 q)) [81])) + (is (= (run* [q] (rel-squares q 361)) [19])))) + +(deftest test-mem-table-updates + (let [rel1 (add-rows (table-rel ^{:index true} a b) [[1 2] [1 3] [2 3]]) + rel2 (add-rows rel1 [[3 3]]) + rel3 (remove-rows rel1 [[2 3]])] + (is (= (.rows rel1) #{[1 2] [1 3] [2 3]})) + (is (= (.rows rel2) #{[1 2] [1 3] [2 3] [3 3]})) + (is (= (.rows rel3) #{[1 2] [1 3]})) + + (is (= (.indexes rel1) {0 {1 #{[1 2] [1 3]}, 2 #{[2 3]}}})) + (is (= (.indexes rel2) {0 {1 #{[1 2] [1 3]}, 2 #{[2 3]}, 3 #{[3 3]}}})) + (is (= (.indexes rel3) {0 {1 #{[1 2] [1 3]}}})))) + +(deftest test-mem-table-no-index + (let [rel (add-rows (table-rel a b) [[1 2] [1 3] [2 3]])] + (is (= (.indexes rel) {})) + (is (= (set (run* [q] (rel 1 q))) #{2 3})))) + +(deftest test-mem-table-two-indexes + (let [empty-rel (table-rel ^{:index true} a ^{:index true} b c) + rel (add-rows empty-rel [[1 2 3] [2 2 4] [3 2 5] [2 3 5]])] + (is (= (.indexes rel) + {0 {1 #{[1 2 3]}, + 2 #{[2 2 4] [2 3 5]}, + 3 #{[3 2 5]}}, + 1 {2 #{[1 2 3] [2 2 4] [3 2 5]}, + 3 #{[2 3 5]}}})) + (is (= (run* [q] + (fresh [a b] + (== a 1) + (== b 2) + (rel a b q))) + [3])))) + +(deftest test-mem-table-partially-ground + (let [rel (add-rows (table-rel ^{:index true} a b) [[[1 2] 3] [[4 5] 6]])] + (is (= (run* [q] + (fresh [a b] + (== a 1) + (rel [a b] q))) + [3])))) + +(deftest test-mem-table-bad-arity + (let [rel (table-rel a b)] + ; Todo: Better error message + (is (thrown? AssertionError (add-rows rel [[1 2 3]]))) + (is (thrown? AssertionError (add-rows rel [[1]]))) + (is (= rel (add-rows rel []))))) + +(deftest test-mem-table-hash-equals + (let [rel1 (table-rel a b) + rel2 (table-rel ^{:index true} a b) + rows [[1 2] [3 4]] + rel1a (add-rows rel1 rows) + rel2a (add-rows rel2 rows) + rel3 (table-rel a b c)] + (is (= rel1 rel2)) + (is (not= rel1 rel3)) + (is (= rel1a rel2a)) + (is (= (bit-xor (* 31 2) (hash #{})) (hash rel1))) + (is (= (bit-xor (* 31 2) (hash #{[1 2] [3 4]})) (hash rel1a))) + (is (= (bit-xor (* 31 3) (hash #{})) (hash rel3))))) + +;; ----------------------------------------------------------------------------- ;; nil in collection (deftest test-nil-in-coll-1 -- 1.7.5.4