diff options
Diffstat (limited to 'src/main/clojure/clojure/contrib/datalog/rules.clj')
| -rw-r--r-- | src/main/clojure/clojure/contrib/datalog/rules.clj | 207 |
1 files changed, 207 insertions, 0 deletions
diff --git a/src/main/clojure/clojure/contrib/datalog/rules.clj b/src/main/clojure/clojure/contrib/datalog/rules.clj new file mode 100644 index 00000000..bcfe5c4c --- /dev/null +++ b/src/main/clojure/clojure/contrib/datalog/rules.clj @@ -0,0 +1,207 @@ +;; Copyright (c) Jeffrey Straszheim. All rights reserved. The use and +;; distribution terms for this software are covered by the Eclipse Public +;; License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) which can +;; be found in the file epl-v10.html at the root of this distribution. By +;; using this software in any fashion, you are agreeing to be bound by the +;; terms of this license. You must not remove this notice, or any other, +;; from this software. +;; +;; rules.clj +;; +;; A Clojure implementation of Datalog -- Rules Engine +;; +;; straszheimjeffrey (gmail) +;; Created 2 Feburary 2009 + + +(ns clojure.contrib.datalog.rules + (use clojure.contrib.datalog.util) + (use clojure.contrib.datalog.literals + clojure.contrib.datalog.database) + (use [clojure.set :only (union intersection difference)]) + (use [clojure.contrib.set :only (subset?)]) + (use [clojure.contrib.except :only (throwf)])) + + +(defstruct datalog-rule + :head + :body) + +(defn display-rule + "Return the rule in a readable format." + [rule] + (list* '<- + (-> rule :head display-literal) + (map display-literal (:body rule)))) + +(defn display-query + "Return a query in a readable format." + [query] + (list* '?- (display-literal query))) + + +;;; Check rule safety + +(defn is-safe? + "Is the rule safe according to the datalog protocol?" + [rule] + (let [hv (literal-vars (:head rule)) + bpv (apply union (map positive-vars (:body rule))) + bnv (apply union (map negative-vars (:body rule))) + ehv (difference hv bpv) + env (difference bnv bpv)] + (when-not (empty? ehv) + (throwf "Head vars %s not bound in body in rule %s" ehv rule)) + (when-not (empty? env) + (throwf "Body vars %s not bound in negative positions in rule %s" env rule)) + rule)) + + +;;; Rule creation and printing + +(defn build-rule + [hd bd] + (with-meta (struct datalog-rule hd bd) {:type ::datalog-rule})) + +(defmacro <- + "Build a datalog rule. Like this: + + (<- (:head :x ?x :y ?y) (:body-1 :x ?x :y ?y) (:body-2 :z ?z) (not! :body-3 :x ?x) (if > ?y ?z))" + [hd & body] + (let [head (build-atom hd :clojure.contrib.datalog.literals/literal) + body (map build-literal body)] + `(is-safe? (build-rule ~head [~@body])))) + +(defmethod print-method ::datalog-rule + [rule #^Writer writer] + (print-method (display-rule rule) writer)) + +(defn return-rule-data + "Returns an untypted rule that will be fully printed" + [rule] + (with-meta rule {})) + +(defmacro ?- + "Define a datalog query" + [& q] + (let [qq (build-atom q :clojure.contrib.datalog.literals/literal)] + `(with-meta ~qq {:type ::datalog-query}))) + +(defmethod print-method ::datalog-query + [query #^Writer writer] + (print-method (display-query query) writer)) + + + +;;; SIP + +(defn compute-sip + "Given a set of bound column names, return an adorned sip for this + rule. A set of intensional predicates should be provided to + determine what should be adorned." + [bindings i-preds rule] + (let [next-lit (fn [bv body] + (or (first (drop-while + #(not (literal-appropriate? bv %)) + body)) + (first (drop-while (complement positive?) body)))) + adorn (fn [lit bvs] + (if (i-preds (literal-predicate lit)) + (let [bnds (union (get-cs-from-vs lit bvs) + (get-self-bound-cs lit))] + (adorned-literal lit bnds)) + lit)) + new-h (adorned-literal (:head rule) bindings)] + (loop [bound-vars (get-vs-from-cs (:head rule) bindings) + body (:body rule) + sip []] + (if-let [next (next-lit bound-vars body)] + (recur (union bound-vars (literal-vars next)) + (remove #(= % next) body) + (conj sip (adorn next bound-vars))) + (build-rule new-h (concat sip body)))))) + + +;;; Rule sets + +(defn make-rules-set + "Given an existing set of rules, make it a 'rules-set' for + printing." + [rs] + (with-meta rs {:type ::datalog-rules-set})) + +(def empty-rules-set (make-rules-set #{})) + +(defn rules-set + "Given a collection of rules return a rules set" + [& rules] + (reduce conj empty-rules-set rules)) + +(defmethod print-method ::datalog-rules-set + [rules #^Writer writer] + (binding [*out* writer] + (do + (print "(rules-set") + (doseq [rule rules] + (println) + (print " ") + (print rule)) + (println ")")))) + +(defn predicate-map + "Given a rules-set, return a map of rules keyed by their predicates. + Each value will be a set of rules." + [rs] + (let [add-rule (fn [m r] + (let [pred (-> r :head literal-predicate) + os (get m pred #{})] + (assoc m pred (conj os r))))] + (reduce add-rule {} rs))) + +(defn all-predicates + "Given a rules-set, return all defined predicates" + [rs] + (set (map literal-predicate (map :head rs)))) + +(defn non-base-rules + "Return a collection of rules that depend, somehow, on other rules" + [rs] + (let [pred (all-predicates rs) + non-base (fn [r] + (if (some #(pred %) + (map literal-predicate (:body r))) + r + nil))] + (remove nil? (map non-base rs)))) + + +;;; Database operations + +(def empty-bindings [{}]) + +(defn apply-rule + "Apply the rule against db-1, adding the results to the appropriate + relation in db-2. The relation will be created if needed." + ([db rule] (apply-rule db db rule)) + ([db-1 db-2 rule] + (trace-datalog (println) + (println) + (println "--------------- Begin Rule ---------------") + (println rule)) + (let [head (:head rule) + body (:body rule) + step (fn [bs lit] + (trace-datalog (println bs) + (println lit)) + (join-literal db-1 lit bs)) + bs (reduce step empty-bindings body)] + (do (trace-datalog (println bs)) + (project-literal db-2 head bs))))) + +(defn apply-rules-set + [db rs] + (reduce (fn [rdb rule] + (apply-rule db rdb rule)) db rs)) + + +;; End of file
\ No newline at end of file |