jdormit/sicp-logic
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Implement rules!

Browse Source
This commit is contained in:
Jeremy Dormitzer 2019-07-19 18:54:49 -04:00
parent 9f501dcd09
commit 04ce4421d0
6 changed files with 113 additions and 74 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
src/sicp_logic/assertions.clj
View File

@ -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])))

14
src/sicp_logic/core.clj
View File

@ -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."
(let [processed-q (query-syntax-process q)]
`(map (fn [frame#]
(instantiate (query-syntax-process (quote ~q))
(instantiate (quote ~processed-q)
frame#
(fn [v# f#] (contract-question-mark v#))))
(qeval ~db (query-syntax-process (quote ~q)) [{}])))
(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]))))

2
src/sicp_logic/db.clj
View File

@ -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"))

45
src/sicp_logic/db/memory.clj
View File

@ -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)))
(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 {})))

20
src/sicp_logic/evaluator.clj
View File

@ -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))))

97
src/sicp_logic/match.clj
View File

@ -1,38 +1,69 @@
(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"
(defn depends-on? [exp var frame]
"Returns `true` if `exp` contains `var` in the context
of `frame`."
(letfn [(tree-walk [node]
(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))
(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 unify-match [pattern data 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)]
(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 = <expression involving y>
(depends-on? val var frame) :failed
:else (extend var val frame))))
(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 unification has already failed, fail
(= frame :failed) :failed
;; 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))