Implement rules!

src/sicp_logic/assertions.clj

@@ -1,12 +1,9 @@
 (ns sicp-logic.assertions
-  (:require [sicp-logic.db :as db]
+  (:require [sicp-logic.db :refer [fetch-assertions]]
-            [sicp-logic.match :refer [pattern-match]]))
+            [sicp-logic.match :refer [unify-match]]))
-
-(defn fetch-assertions [db query frame]
-  (db/fetch-assertions db query frame))
 
 (defn check-an-assertion [assertion query frame]
-  (let [match-result (pattern-match query assertion frame)]
+  (let [match-result (unify-match query assertion frame)]
     (if (= match-result :failed)
       []
       [match-result])))

src/sicp_logic/core.clj

@@ -1,6 +1,6 @@
 (ns sicp-logic.core
   (:require [sicp-logic.binding :refer [instantiate]]
-            [sicp-logic.db :refer [add-assertion]]
+            [sicp-logic.db :refer [add-assertion add-rule]]
             [sicp-logic.evaluator :refer [qeval]]))
 
 (defn contract-question-mark [v]
@@ -27,15 +27,19 @@
 
 (defmacro query [db q]
   "Queries the database for assertions that match the query."
-  `(map (fn [frame#]
+  (let [processed-q (query-syntax-process q)]
-          (instantiate (query-syntax-process (quote ~q))
+    `(map (fn [frame#]
-                       frame#
+            (instantiate (quote ~processed-q)
-                       (fn [v# f#] (contract-question-mark v#))))
+                         frame#
-    (qeval ~db (query-syntax-process (quote ~q)) [{}])))
+                         (fn [v# f#] (contract-question-mark v#))))
+          (qeval ~db (quote ~processed-q) [{}]))))
 
 (defn assert! [db assertion]
   "Adds a new assertion to the database."
   (add-assertion db assertion))
 
-(defmacro defrule []
+(defmacro defrule [db conclusion body]
-  "Adds a new rule to the database.")
+  "Adds a new rule to the database."
+  (let [processed-conclusion (query-syntax-process conclusion)
+        processed-body (query-syntax-process body)]
+    `(add-rule ~db (quote [~processed-conclusion ~processed-body]))))

src/sicp_logic/db.clj

@@ -9,5 +9,5 @@
     "Stores an assertion (a fact) in the database.")
   (fetch-rules [db query frame]
     "Fetches rules whose conditions may unify with the given query and frame")
-  (add-rules [db rule]
+  (add-rule [db rule]
     "Adds a new rule to the database"))

src/sicp_logic/db/memory.clj

@@ -1,41 +1,44 @@
 (ns sicp-logic.db.memory
   (:require [sicp-logic.binding :refer [instantiate var?]]
-            [sicp-logic.db :refer [FactDB]]))
+            [sicp-logic.db :refer [FactDB]]
-
+            [sicp-logic.evaluator :refer [conclusion]]))
-(defn use-index? [query]
-  (not (var? (first query))))
 
 (defn get-indexed-assertions [db query]
-  (get (deref (:index db)) (first query)))
+  (get @(:assertion-index db) (first query)))
-
-(defn get-all-assertions [db]
-  (deref (:store db)))
-
-(defn indexable? [assertion]
-  (not (var? (first assertion))))
 
 (defn index-assertion! [db assertion]
   (swap!
-   (:index db)
+   (:assertion-index db)
    (fn [index]
      (let [index-value (or (get index (first assertion)) [])]
        (assoc index (first assertion) (conj index-value assertion))))))
 
+(defn get-indexed-rules [db query]
+  (concat
+   (get @(:rule-index db) (first query))
+   (get @(:rule-index db) '?)))
 
-(defn store! [db assertion]
+(defn index-rule! [db rule]
-  (swap! (:store db) (fn [assertions] (conj assertions assertion))))
+  (swap!
+   (:rule-index db)
+   (fn [index]
+     (let [index-key (if (var? (first (conclusion rule)))
+                       '?
+                       (first (conclusion rule)))
+           index-value (or (get index index-key) [])]
+       (assoc index index-key (conj index-value rule))))))
 
-(defrecord InMemoryDB [index store]
+(defrecord InMemoryDB [assertion-index rule-index]
   FactDB
   (fetch-assertions [db query frame]
     (let [instantiated (instantiate query frame (fn [v f] v))]
-      (if (use-index? query)
+      (get-indexed-assertions db query)))
-       (get-indexed-assertions db query)
-       (get-all-assertions db))))
   (add-assertion [db assertion]
-    (when (indexable? assertion)
+    (index-assertion! db assertion))
-      (index-assertion! db assertion))
+  (fetch-rules [db query frame]
-    (store! db assertion)))
+    (get-indexed-rules db query))
+  (add-rule [db rule]
+    (index-rule! db rule)))
 
 (defn new-db []
-  (->InMemoryDB (atom {}) (atom [])))
+  (->InMemoryDB (atom {}) (atom {})))

src/sicp_logic/evaluator.clj

@@ -1,6 +1,6 @@
 (ns sicp-logic.evaluator
   (:require [sicp-logic.assertions :refer [find-assertions]]
-            [sicp-logic.binding :refer [instantiate]]
+            [sicp-logic.binding :refer [instantiate var?]]
             [sicp-logic.db :refer [fetch-rules]]
             [sicp-logic.match :refer [unify-match]]))
 
@@ -60,10 +60,10 @@
                      (let [var-name (second var)
                            binding (get @bindings var-name)]
                        (if binding
-                         binding
+                         ['? binding]
                          (let [new-binding (gensym var-name)]
                            (swap! bindings (fn [m] (assoc m var-name new-binding)))
-                           new-binding))))
+                           ['? new-binding]))))
         rename-vars (fn rename-vars [exp]
                       (cond
                         (var? exp) (rename-var exp)
@@ -75,12 +75,14 @@
 
 
 (defn conclusion [rule]
-  "Selects the rule's conclusion")
+  "Selects the rule's conclusion"
+  (first rule))
 
 (defn rule-body [rule]
-  "Selects the rule's body")
+  "Selects the rule's body"
+  (or (second rule) :always-true))
 
-(defn apply-a-rule [rule query frame]
+(defn apply-a-rule [db rule query frame]
   "Applies the `rule` to the `query` in the
    `frame` by unifying the query with the rule to
    produce a new frame then evaluating the body
@@ -91,13 +93,14 @@
                                   frame)]
     (if (= unify-result :failed)
       []
-      (qeval (rule-body clean-rule)
+      (qeval db
+             (rule-body clean-rule)
              [unify-result]))))
 
 (defn apply-rules [db query frame]
   (mapcat
    (fn [rule]
-     (apply-a-rule rule query frame))
+     (apply-a-rule db rule query frame))
    (fetch-rules db query frame)))
 
 (defn simple-query [db q input-frames]
@@ -119,4 +122,5 @@
       (= q-type 'or) (disjoin db (rest q) input-frames)
       (= q-type 'not) (negate db (rest q) input-frames)
       (= q-type 'lisp-value) (lisp-value (rest q) input-frames)
+      (= q-type :always-true) input-frames
       :else (simple-query db q input-frames))))

src/sicp_logic/match.clj

@@ -1,38 +1,69 @@
 (ns sicp-logic.match
   (:require [sicp-logic.binding :refer [binding-in-frame extend var?]]))
 
-(declare pattern-match)
+(defn depends-on? [exp var frame]
+  "Returns `true` if `exp` contains `var` in the context
+   of `frame`."
+  (letfn [(tree-walk [node]
+            (cond
+              (var? node) (if (= var node)
+                            true
+                            (let [binding-value (binding-in-frame node frame)]
+                              (if binding-value
+                                (tree-walk binding-value)
+                                false)))
+              (and (sequential? node) (not (empty? node)))
+              (or (tree-walk (first node))
+                  (tree-walk (rest node)))
+              :else false))]
+    (tree-walk exp)))
 
-(defn extend-if-consistent [var data frame]
+(declare unify-match)
-  "Extends `frame` by binding `var` to `data` as long as this is
+
-   consistent with the bindings already in `frame`."
+(defn extend-if-possible [var val frame]
+  "Extends the frame by binding `var` to `val` unless that
+   results in an invalid state."
   (let [binding-value (binding-in-frame var frame)]
-    (if binding-value
+    (cond
-      (pattern-match binding-value data frame)  ;; recursive call to bind any variables in the binding-value
+      ;; If the var is already bound in the frame, attempt to unify
-      (extend var data frame))))
+      ;; its value with the new value
+      binding-value (unify-match binding-value val frame)
+      ;; If the the value is a variable that is already bound, attempt
+      ;; to unify its value with the variable currently being bound
+      (var? val) (let [binding-value (binding-in-frame val frame)]
+                   (if binding-value
+                     (unify-match var binding-value frame)
+                     (extend var val frame)))
+      ;; If the var is found somewhere in the val, fail, since it
+      ;; is not possible to generally solve equations of the form
+      ;; y = <expression involving y>
+      (depends-on? val var frame) :failed
+      :else (extend var val frame))))
 
-(defn pattern-match [pattern data frame]
+(defn unify-match [pattern1 pattern2 frame]
-  "Matches `pattern` against `data`, returning either a new frame
+  "Unifies `pattern1` with `pattern2` by binding variables
-   with the pattern variables bound or the keyword :failed if matching
+   in `frame` such that both patterns could have the same
-   fails"
+   value. Some pattern variables in either pattern may remain
+   unbound.
+   
+   For example, (unify-match '[?a ?b foo] '[?c [?d bar] ?e] {}) yields
+   the new frame '{a [?c], b [?d bar], e foo}."
   (cond
-    ;; If the frame has already failed, fail
+    ;; If the unification has already failed, fail
     (= frame :failed) :failed
-    ;; If the pattern already equals the data,
+    ;; If the patterns are already equal, the frame already
-    ;; the frame already has the correct bindings
+    ;; has the correct bindings
-    (= pattern data) frame
+    (= pattern1 pattern2) frame
-    ;; If the pattern is a variable, try to extend the frame by binding that
+    ;; If pattern1 is a variable, try to bind it to pattern2
-    ;; variable to the data
+    (var? pattern1) (extend-if-possible pattern1 pattern2 frame)
-    (var? pattern) (extend-if-consistent pattern data frame)
+    ;; If pattern1 is not a variable but pattern2 is, try to bind
-    ;; If the pattern and data are both lists, recurse into the list
+    ;; pattern2 to pattern1
-    (and (sequential? pattern) (sequential? data))
+    (var? pattern2) (extend-if-possible pattern2 pattern1 frame)
-    (pattern-match
+    ;; If both patterns are lists, recursively unify them
-     (rest pattern)
+    (and (sequential? pattern1) (sequential? pattern2))
-     (rest data)
+    (unify-match (rest pattern1)
-     (pattern-match (first pattern)
+                 (rest pattern2)
-                    (first data)
+                 (unify-match (first pattern1)
-                    frame))
+                              (first pattern2)
-    ;; Otherwise we can't match this pattern
+                              frame))
     :else :failed))
-
-(defn unify-match [pattern data frame])