diff --git a/src/sicp-logic/core.clj b/src/sicp-logic/core.clj deleted file mode 100644 index 7f6e971..0000000 --- a/src/sicp-logic/core.clj +++ /dev/null @@ -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.") diff --git a/src/sicp_logic/assertions.clj b/src/sicp_logic/assertions.clj new file mode 100644 index 0000000..1199240 --- /dev/null +++ b/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))) diff --git a/src/sicp_logic/binding.clj b/src/sicp_logic/binding.clj new file mode 100644 index 0000000..c83c7bd --- /dev/null +++ b/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))) diff --git a/src/sicp_logic/core.clj b/src/sicp_logic/core.clj new file mode 100644 index 0000000..41ebad1 --- /dev/null +++ b/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.") diff --git a/src/sicp_logic/db.clj b/src/sicp_logic/db.clj new file mode 100644 index 0000000..e285df6 --- /dev/null +++ b/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.")) diff --git a/src/sicp_logic/db/memory.clj b/src/sicp_logic/db/memory.clj new file mode 100644 index 0000000..e2cea7b --- /dev/null +++ b/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 []))) diff --git a/src/sicp_logic/evaluator.clj b/src/sicp_logic/evaluator.clj new file mode 100644 index 0000000..011f8e7 --- /dev/null +++ b/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)))) diff --git a/src/sicp_logic/match.clj b/src/sicp_logic/match.clj new file mode 100644 index 0000000..70dd212 --- /dev/null +++ b/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)) diff --git a/src/sicp_logic/rules.clj b/src/sicp_logic/rules.clj new file mode 100644 index 0000000..5604123 --- /dev/null +++ b/src/sicp_logic/rules.clj @@ -0,0 +1,3 @@ +(ns sicp-logic.rules) + +(defn apply-rules [db query frame])