From 04ce4421d0ab4fc1e47173676734987b4993da44 Mon Sep 17 00:00:00 2001 From: Jeremy Dormitzer Date: Fri, 19 Jul 2019 18:54:49 -0400 Subject: [PATCH] Implement rules! --- src/sicp_logic/assertions.clj | 9 ++-- src/sicp_logic/core.clj | 20 ++++---- src/sicp_logic/db.clj | 2 +- src/sicp_logic/db/memory.clj | 47 +++++++++--------- src/sicp_logic/evaluator.clj | 20 ++++---- src/sicp_logic/match.clj | 89 +++++++++++++++++++++++------------ 6 files changed, 113 insertions(+), 74 deletions(-) diff --git a/src/sicp_logic/assertions.clj b/src/sicp_logic/assertions.clj index 1199240..37bd274 100644 --- a/src/sicp_logic/assertions.clj +++ b/src/sicp_logic/assertions.clj @@ -1,12 +1,9 @@ (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)) + (:require [sicp-logic.db :refer [fetch-assertions]] + [sicp-logic.match :refer [unify-match]])) (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]))) diff --git a/src/sicp_logic/core.clj b/src/sicp_logic/core.clj index cab6dbb..902db1c 100644 --- a/src/sicp_logic/core.clj +++ b/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#] - (instantiate (query-syntax-process (quote ~q)) - frame# - (fn [v# f#] (contract-question-mark v#)))) - (qeval ~db (query-syntax-process (quote ~q)) [{}]))) + (let [processed-q (query-syntax-process q)] + `(map (fn [frame#] + (instantiate (quote ~processed-q) + frame# + (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 [] - "Adds a new rule to the database.") +(defmacro defrule [db conclusion body] + "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])))) diff --git a/src/sicp_logic/db.clj b/src/sicp_logic/db.clj index d744282..b66cd5e 100644 --- a/src/sicp_logic/db.clj +++ b/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")) diff --git a/src/sicp_logic/db/memory.clj b/src/sicp_logic/db/memory.clj index 28f2bc0..6fdcc7d 100644 --- a/src/sicp_logic/db/memory.clj +++ b/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]])) - -(defn use-index? [query] - (not (var? (first query)))) + [sicp-logic.db :refer [FactDB]] + [sicp-logic.evaluator :refer [conclusion]])) (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)))) + (get @(:assertion-index db) (first query))) (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] - (swap! (:store db) (fn [assertions] (conj assertions assertion)))) +(defn index-rule! [db rule] + (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-all-assertions db)))) + (get-indexed-assertions db query))) (add-assertion [db assertion] - (when (indexable? assertion) - (index-assertion! db assertion)) - (store! db assertion))) + (index-assertion! db assertion)) + (fetch-rules [db query frame] + (get-indexed-rules db query)) + (add-rule [db rule] + (index-rule! db rule))) (defn new-db [] - (->InMemoryDB (atom {}) (atom []))) + (->InMemoryDB (atom {}) (atom {}))) diff --git a/src/sicp_logic/evaluator.clj b/src/sicp_logic/evaluator.clj index 5dd2d09..6a85d66 100644 --- a/src/sicp_logic/evaluator.clj +++ b/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)))) diff --git a/src/sicp_logic/match.clj b/src/sicp_logic/match.clj index 16aafb6..ab66c8b 100644 --- a/src/sicp_logic/match.clj +++ b/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] - "Extends `frame` by binding `var` to `data` as long as this is - consistent with the bindings already in `frame`." +(declare unify-match) + +(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 - (pattern-match binding-value data frame) ;; recursive call to bind any variables in the binding-value - (extend var data frame)))) + (cond + ;; If the var is already bound in the frame, attempt to unify + ;; 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 = + (depends-on? val var frame) :failed + :else (extend var val 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" +(defn unify-match [pattern1 pattern2 frame] + "Unifies `pattern1` with `pattern2` by binding variables + in `frame` such that both patterns could have the same + 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, - ;; 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 + ;; If the patterns are already equal, the frame already + ;; has the correct bindings + (= pattern1 pattern2) frame + ;; If pattern1 is a variable, try to bind it to pattern2 + (var? pattern1) (extend-if-possible pattern1 pattern2 frame) + ;; If pattern1 is not a variable but pattern2 is, try to bind + ;; pattern2 to pattern1 + (var? pattern2) (extend-if-possible pattern2 pattern1 frame) + ;; If both patterns are lists, recursively unify them + (and (sequential? pattern1) (sequential? pattern2)) + (unify-match (rest pattern1) + (rest pattern2) + (unify-match (first pattern1) + (first pattern2) + frame)) :else :failed)) - -(defn unify-match [pattern data frame])