[WIP] Implement pattern matcher and in-memory store

This is currently broken.

src/sicp-logic/core.clj

@@ -1,115 +0,0 @@
-(ns sicp-logic.core)
-
-(declare qeval)
-
-(defn var? [exp])
-
-(defn binding-in-frame [var frame]
-  "Returns the value the `var` is bound to in `frame`, or nil."
-  (frame (second var)))
-
-
-(defn instantiate [q frame unbound-var-handler]
-  "Instantiates the query `q` with the variables bound in `frame`."
-  (letfn [(copy [exp]
-               (cond (var? exp) (let [binding-value (binding-in-frame exp frame)]
-                                  (if binding-value
-                                    (copy binding-value)
-                                    (unbound-var-handler exp frame)))
-                     (sequential? exp) (cons (copy (first exp)) (copy (rest exp)))
-                     :else exp))]
-    (copy q)))
-
-(defn conjoin [conjuncts input-frames]
-  (if (empty? conjuncts)
-    input-frames
-    (conjoin (rest conjuncts)
-             (qeval (first conjuncts) input-frames))))
-
-(defn disjoin [disjuncts input-frames]
-  (if (empty? disjuncts)
-    nil
-    (concat (qeval (first disjuncts) input-frames)
-            (disjoin (rest disjuncts) input-frames))))
-
-
-(defn negate [operands input-frames]
-  (filter
-   (fn [frame]
-     (empty? (qeval operands [frame])))
-   input-frames))
-
-(defn execute [exp]
-  (let [predicate (first exp)
-        args (rest exp)]
-    (apply (eval predicate) args)))
-
-(defn lisp-value [call input-frames]
-  (mapcat
-   (fn [frame]
-     (if (execute
-          (instantiate
-           call
-           frame
-           (fn [v f]
-             (throw (java.lang.IllegalArgumentException. (str "Unknown pattern variable -- LISP-VALUE: " v))))))
-       [frame]
-       []))
-   input-frames))
-
-(defn find-assertions [query frame])
-
-(defn apply-rules [query frame])
-
-(defn simple-query [q input-frames]
-  "Processes a simple query, producing a sequence of frames with bindings for the variables in `q`."
-  (mapcat
-   (fn [frame]
-     (concat
-      (find-assertions q frame)
-      (apply-rules q frame)))
-   input-frames))
-
-(defn qeval [q input-frames]
-  "Evaluates the query `q` in the context of the `input-frames`."
-  (let [q-type (first q)]
-    (cond
-      (= q-type 'and) (conjoin (rest q) input-frames)
-      (= q-type 'or) (disjoin (rest q) input-frames)
-      (= q-type 'not) (negate (rest q) input-frames)
-      (= q-type 'lisp-value) (lisp-value (rest q) input-frames)
-      :else (simple-query q input-frames))))
-
-(defn contract-question-mark [v]
-  (symbol
-   (str "?"
-        (second v))))
-
-(defn map-over-symbols [proc exp]
-  (cond
-    (and (sequential? exp) (not (empty? exp)))
-    (cons (map-over-symbols proc (first exp))
-          (map-over-symbols proc (rest exp)))
-    (symbol? exp) (proc exp)
-    :else exp))
-
-(defn expand-question-mark [sym]
-  (let [chars (str sym)]
-    (if (= "?" (subs chars 0 1))
-      ['? (symbol (subs chars 1))]
-      sym)))
-
-(defn query-syntax-process [q]
-  (map-over-symbols #'expand-question-mark q))
-
-(defmacro query [q]
-  "Queries the database for assertions that match the query."
-  `(map (fn [frame]
-          (instantiate (quote ~q) frame (fn [v f] (contract-question-mark v))))
-    (qeval (query-syntax-process (quote ~q)) [{}])))
-
-(defmacro assert! []
-  "Adds a new assertion to the database.")
-
-(defmacro defrule []
-  "Adds a new rule to the database.")

src/sicp_logic/assertions.clj

@@ -0,0 +1,18 @@
+(ns sicp-logic.assertions
+  (:require [sicp-logic.db :as db]
+            [sicp-logic.match :refer [pattern-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)]
+    (if (= match-result :failed)
+      []
+      [match-result])))
+
+(defn find-assertions [db query frame]
+  (mapcat
+   (fn [assertion]
+     (check-an-assertion assertion query frame))
+   (fetch-assertions db query frame)))

src/sicp_logic/binding.clj

@@ -0,0 +1,23 @@
+(ns sicp-logic.binding)
+
+(defn var? [exp]
+  (and (sequential? exp) (= (first exp) '?)))
+
+(defn binding-in-frame [var frame]
+  "Returns the value the `var` is bound to in `frame`, or nil."
+  (frame (second var)))
+
+(defn extend [var data frame]
+  "Binds `var` to `data` in `frame`"
+  (assoc frame (second var) data))
+
+(defn instantiate [q frame unbound-var-handler]
+  "Instantiates the query `q` with the variables bound in `frame`."
+  (letfn [(copy [exp]
+               (cond (var? exp) (let [binding-value (binding-in-frame exp frame)]
+                                  (if binding-value
+                                    (copy binding-value)
+                                    (unbound-var-handler exp frame)))
+                     (and (sequential? exp) (not (empty? exp))) (cons (copy (first exp)) (copy (rest exp)))
+                     :else exp))]
+    (copy q)))

src/sicp_logic/core.clj

@@ -0,0 +1,40 @@
+(ns sicp-logic.core
+  (:require [sicp-logic.binding :refer [instantiate]]
+            [sicp-logic.db :refer [add-assertion]]
+            [sicp-logic.evaluator :refer [qeval]]))
+
+(defn contract-question-mark [v]
+  (symbol
+   (str "?"
+        (second v))))
+
+(defn map-over-symbols [proc exp]
+  (cond
+    (and (sequential? exp) (not (empty? exp)))
+    (cons (map-over-symbols proc (first exp))
+          (map-over-symbols proc (rest exp)))
+    (symbol? exp) (proc exp)
+    :else exp))
+
+(defn expand-question-mark [sym]
+  (let [chars (str sym)]
+    (if (= "?" (subs chars 0 1))
+      ['? (symbol (subs chars 1))]
+      sym)))
+
+(defn query-syntax-process [q]
+  (map-over-symbols #'expand-question-mark q))
+
+(defmacro query [db q]
+  "Queries the database for assertions that match the query."
+  (letfn [(process-frame [q frame]
+            (instantiate q frame (fn [v f] (contract-question-mark v))))]
+    `(map ~process-frame
+          (qeval ~db (query-syntax-process (quote ~q)) [{}]))))
+
+(defn assert! [db assertion]
+  "Adds a new assertion to the database."
+  (add-assertion db assertion))
+
+(defmacro defrule []
+  "Adds a new rule to the database.")

src/sicp_logic/db.clj

@@ -0,0 +1,7 @@
+(ns sicp-logic.db)
+
+(defprotocol FactDB
+  "The FactDB protocol specifies methods to store and retrieve
+   assertions (facts) and rules."
+  (fetch-assertions [db query frame] "Fetches assertions that may match the given query and frame.")
+  (add-assertion [db assertion] "Stores an assertion (a fact) in the database."))

src/sicp_logic/db/memory.clj

@@ -0,0 +1,41 @@
+(ns sicp-logic.db.memory
+  (:require [sicp-logic.binding :refer [instantiate var?]]
+            [sicp-logic.db :refer [FactDB]]))
+
+(defn use-index? [query]
+  (not (var? (first query))))
+
+(defn get-indexed-assertions [db query]
+  (get (deref (: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)
+   (fn [index]
+     (let [index-value (or (get index (first assertion)) [])]
+       (conj index-value assertion)))))
+
+
+(defn store! [db assertion]
+  (swap! (:store db) (fn [assertions] (conj assertions assertion))))
+
+(defrecord InMemoryDB [index store]
+  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-all-assertions db))))
+  (add-assertion [db assertion]
+    (when (indexable? assertion)
+      (index-assertion! db assertion))
+    (store! db assertion)))
+
+(defn new-db []
+  (->InMemoryDB (atom {}) (atom [])))

src/sicp_logic/evaluator.clj

@@ -0,0 +1,65 @@
+(ns sicp-logic.evaluator
+  (:require [sicp-logic.binding :refer [instantiate]]
+            [sicp-logic.assertions :refer [find-assertions]]
+            [sicp-logic.rules :refer [apply-rules]]))
+
+(declare qeval)
+
+(defn conjoin [db conjuncts input-frames]
+  (if (empty? conjuncts)
+    input-frames
+    (conjoin db
+             (rest conjuncts)
+             (qeval db (first conjuncts) input-frames))))
+
+(defn disjoin [db disjuncts input-frames]
+  (if (empty? disjuncts)
+    nil
+    (concat (qeval db (first disjuncts) input-frames)
+            (disjoin db (rest disjuncts) input-frames))))
+
+(defn negate [db operands input-frames]
+  (filter
+   (fn [frame]
+     (empty? (qeval db operands [frame])))
+   input-frames))
+
+(defn execute [exp]
+  (let [predicate (first exp)
+        args (rest exp)]
+    (apply (eval predicate) args)))
+
+(defn lisp-value [call input-frames]
+  "Evaluates `call` with any logic variables in it instantiated for each
+   input frame. If the call returns a falsy value, filter that frame out."
+  (mapcat
+   (fn [frame]
+     (if (execute
+          (instantiate
+           call
+           frame
+           (fn [v f]
+             (throw (IllegalArgumentException. (str "Unknown pattern variable -- LISP-VALUE: " v))))))
+       [frame]
+       []))
+   input-frames))
+
+(defn simple-query [db q input-frames]
+  "Processes a simple query, producing a sequence of frames with bindings for the variables in `q`."
+  (mapcat
+   (fn [frame]
+     (concat
+      (find-assertions db q frame)
+      (apply-rules db q frame)))
+   input-frames))
+
+(defn qeval [db q input-frames]
+  "Evaluates the query `q` in the context of the `input-frames` using
+   assertions and rules from the `db`."
+  (let [q-type (first q)]
+    (cond
+      (= q-type 'and) (conjoin (rest q) input-frames)
+      (= q-type 'or) (disjoin (rest q) input-frames)
+      (= q-type 'not) (negate (rest q) input-frames)
+      (= q-type 'lisp-value) (lisp-value (rest q) input-frames)
+      :else (simple-query db q input-frames))))

src/sicp_logic/match.clj

@@ -0,0 +1,36 @@
+(ns sicp-logic.match
+  (:require [sicp-logic.binding :refer [binding-in-frame extend var?]]))
+
+(declare pattern-match)
+
+(defn extend-if-consistent [var data frame]
+  "Extends `frame` by binding `var` to `data` as long as this is
+   consistent with the bindings already in `frame`."
+  (let [binding-value (binding-in-frame var frame)]
+    (if binding-value
+      (pattern-match binding-value data frame)  ;; recursive call to bind any variables in the binding-value
+      (extend var data frame))))
+
+(defn pattern-match [pattern data frame]
+  "Matches `pattern` against `data`, returning either a new frame
+   with the pattern variables bound or the keyword :failed if matching
+   fails"
+  (cond
+    ;; If the frame has already failed, fail
+    (= frame :failed) :failed
+    ;; If the pattern already equals the data,
+    ;; the frame already has the correct bindings
+    (= pattern data) frame
+    ;; If the pattern is a variable, try to extend the frame by binding that
+    ;; variable to the data
+    (var? pattern) (extend-if-consistent pattern data frame)
+    ;; If the pattern and data are both lists, recurse into the list
+    (and (sequential? pattern) (sequential? data))
+    (pattern-match
+     (rest pattern)
+     (rest data)
+     (pattern-match (first pattern)
+                    (first data)
+                    frame))
+    ;; Otherwise we can't match this pattern
+    :else :failed))

src/sicp_logic/rules.clj

@@ -0,0 +1,3 @@
+(ns sicp-logic.rules)
+
+(defn apply-rules [db query frame])