Separate out query* logic (returning var mappings) from query macro

src/sicp_logic/core.clj

@@ -1,5 +1,5 @@
 (ns sicp-logic.core
-  (:require [sicp-logic.binding :refer [instantiate]]
+  (:require [sicp-logic.binding :refer [instantiate var?]]
             [sicp-logic.db :as db]
             [sicp-logic.evaluator :refer [qeval]]))
 
@@ -25,14 +25,43 @@
 (defn query-syntax-process [q]
   (map-over-symbols #'expand-question-mark q))
 
-(defmacro query [db q]
+(defn sanitize-frame [q frame]
+  "Fully resolves all variables in q and returns a map
+   of the variable names to their bindings"
+  (letfn [(vars [acc node]
+            (cond
+              (var? node) (conj acc [(second node) node])
+              (and (sequential? node) (not (empty? node)))
+              (concat
+               (vars acc (first node))
+               (vars acc (rest node)))))]
+    (let [qvars (vars [] q)]
+      (into {} (map vec (instantiate qvars frame (fn [v f] v)))))))
+
+(defn query-results [db q]
   "Queries the database for assertions that match the query."
   (let [processed-q (query-syntax-process q)]
-    `(map (fn [frame#]
+    (map (fn [frame]
-            (instantiate (quote ~processed-q)
+           (sanitize-frame processed-q frame))
-                         frame#
+         (qeval db processed-q [{}]))))
-                         (fn [v# f#] (contract-question-mark v#))))
+
-          (qeval ~db (quote ~processed-q) [{}]))))
+(defn instantiate-query [q frames]
+  "Fills in the query with variables from frames"
+  (let [processed-q (query-syntax-process q)]
+    (map (fn [frame]
+           (instantiate processed-q
+                        frame
+                        (fn [v f] (contract-question-mark v))))
+         frames)))
+
+(defn query* [db q]
+  (instantiate-query q
+    (query-results db q)))
+
+(defmacro query [db q]
+  "Convenience macro to query the database for assertions
+   that match the query."
+  `(query* ~db (quote ~q)))
 
 (defn assert! [db assertion]
   "Adds a new assertion to the database."

tests/sicp_logic/tests.clj

@@ -1,5 +1,5 @@
 (ns sicp-logic.tests
-  (:require [clojure.test :as test :refer [deftest is]]
+  (:require [clojure.test :as test :refer [deftest is testing]]
             [sicp-logic.core :as logic]
             [sicp-logic.db.memory :as memdb]))
 
@@ -116,15 +116,45 @@
                   (lisp-value > 75000 30000))]))))
 
 (deftest rules
-  (let [db (memdb/new-db)]
+  (testing "Basic rules"
-    (setup-sicp-dataset! db)
+    (let [db (memdb/new-db)]
-    (is (= (logic/query db [lives-near ?x [Bitdiddle Ben]])
+     (setup-sicp-dataset! db)
-           '[(lives-near (Reasoner Louis) (Bitdiddle Ben))
+     (is (= (logic/query db [lives-near ?x [Bitdiddle Ben]])
-             (lives-near (Aull DeWitt) (Bitdiddle Ben))]))
+            '[(lives-near (Reasoner Louis) (Bitdiddle Ben))
-    (is (= (logic/query db (and [job ?x [computer programmer]]
+              (lives-near (Aull DeWitt) (Bitdiddle Ben))]))
-                                [lives-near ?x [Hacker Alyssa P]]))
+     (is (= (logic/query db (and [job ?x [computer programmer]]
-           '[(and (job (Fect Cy D) (computer programmer))
+                                 [lives-near ?x [Hacker Alyssa P]]))
-                  (lives-near (Fect Cy D) (Hacker Alyssa P)))]))))
+            '[(and (job (Fect Cy D) (computer programmer))
+                   (lives-near (Fect Cy D) (Hacker Alyssa P)))]))))
+  (testing "More complicated rules"
+    (let [db (memdb/new-db)]
+      (logic/defrule! db [append-to-form [] ?y ?y])
+      (logic/defrule! db [append-to-form [?u & ?v] ?y [?u & ?z]]
+        (append-to-form ?v ?y ?z))
+      (is (= (logic/query db [append-to-form [a b] [c d] ?z])
+             '[[append-to-form [a b] [c d] [a & [b & [c d]]]]]))
+      (is (= (logic/query db [append-to-form [a ?x] [c d] [a b c d]])
+             '[[append-to-form [a b] [c d] [a b c d]]])))))
+
+(deftest raw-query
+  (testing "Raw queries"
+    (let [db (memdb/new-db)]
+      (setup-sicp-dataset! db)
+      (is (= (logic/query-results db '[job ?x [computer programmer]])
+             '[{x [Hacker Alyssa P]}
+               {x [Fect Cy D]}]))
+      (is (= (logic/query-results db '[job ?x [computer ?type]])
+             '[{x [Bitdiddle Ben]
+                type wizard}
+               {x [Hacker Alyssa P]
+                type programmer}
+               {x [Fect Cy D]
+                type programmer}
+               {x [Tweakit Lem E]
+                type technician}]))
+      (is (= (logic/query-results db '[lives-near ?x [Bitdiddle Ben]])
+             '[{x [Reasoner Louis]}
+               {x [Aull DeWitt]}])))))
 
 (defn run-tests []
   (test/run-tests 'sicp-logic.tests))