Mercurial > lasercutter
comparison src/clojure/contrib/datalog/rules.clj @ 10:ef7dbbd6452c
added clojure source goodness
author | Robert McIntyre <rlm@mit.edu> |
---|---|
date | Sat, 21 Aug 2010 06:25:44 -0400 |
parents | |
children |
comparison
equal
deleted
inserted
replaced
9:35cf337adfcf | 10:ef7dbbd6452c |
---|---|
1 ;; Copyright (c) Jeffrey Straszheim. All rights reserved. The use and | |
2 ;; distribution terms for this software are covered by the Eclipse Public | |
3 ;; License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) which can | |
4 ;; be found in the file epl-v10.html at the root of this distribution. By | |
5 ;; using this software in any fashion, you are agreeing to be bound by the | |
6 ;; terms of this license. You must not remove this notice, or any other, | |
7 ;; from this software. | |
8 ;; | |
9 ;; rules.clj | |
10 ;; | |
11 ;; A Clojure implementation of Datalog -- Rules Engine | |
12 ;; | |
13 ;; straszheimjeffrey (gmail) | |
14 ;; Created 2 Feburary 2009 | |
15 | |
16 | |
17 (ns clojure.contrib.datalog.rules | |
18 (:use clojure.contrib.datalog.util) | |
19 (:use clojure.contrib.datalog.literals | |
20 clojure.contrib.datalog.database) | |
21 (:use [clojure.set :only (union intersection difference)]) | |
22 (:use [clojure.contrib.set :only (subset?)]) | |
23 (:use [clojure.contrib.except :only (throwf)]) | |
24 (:import java.io.Writer)) | |
25 | |
26 | |
27 (defstruct datalog-rule | |
28 :head | |
29 :body) | |
30 | |
31 (defn display-rule | |
32 "Return the rule in a readable format." | |
33 [rule] | |
34 (list* '<- | |
35 (-> rule :head display-literal) | |
36 (map display-literal (:body rule)))) | |
37 | |
38 (defn display-query | |
39 "Return a query in a readable format." | |
40 [query] | |
41 (list* '?- (display-literal query))) | |
42 | |
43 | |
44 ;;; Check rule safety | |
45 | |
46 (defn is-safe? | |
47 "Is the rule safe according to the datalog protocol?" | |
48 [rule] | |
49 (let [hv (literal-vars (:head rule)) | |
50 bpv (apply union (map positive-vars (:body rule))) | |
51 bnv (apply union (map negative-vars (:body rule))) | |
52 ehv (difference hv bpv) | |
53 env (difference bnv bpv)] | |
54 (when-not (empty? ehv) | |
55 (throwf "Head vars %s not bound in body in rule %s" ehv rule)) | |
56 (when-not (empty? env) | |
57 (throwf "Body vars %s not bound in negative positions in rule %s" env rule)) | |
58 rule)) | |
59 | |
60 | |
61 ;;; Rule creation and printing | |
62 | |
63 (defn build-rule | |
64 [hd bd] | |
65 (with-meta (struct datalog-rule hd bd) {:type ::datalog-rule})) | |
66 | |
67 (defmacro <- | |
68 "Build a datalog rule. Like this: | |
69 | |
70 (<- (:head :x ?x :y ?y) (:body-1 :x ?x :y ?y) (:body-2 :z ?z) (not! :body-3 :x ?x) (if > ?y ?z))" | |
71 [hd & body] | |
72 (let [head (build-atom hd :clojure.contrib.datalog.literals/literal) | |
73 body (map build-literal body)] | |
74 `(is-safe? (build-rule ~head [~@body])))) | |
75 | |
76 (defmethod print-method ::datalog-rule | |
77 [rule ^Writer writer] | |
78 (print-method (display-rule rule) writer)) | |
79 | |
80 (defn return-rule-data | |
81 "Returns an untypted rule that will be fully printed" | |
82 [rule] | |
83 (with-meta rule {})) | |
84 | |
85 (defmacro ?- | |
86 "Define a datalog query" | |
87 [& q] | |
88 (let [qq (build-atom q :clojure.contrib.datalog.literals/literal)] | |
89 `(with-meta ~qq {:type ::datalog-query}))) | |
90 | |
91 (defmethod print-method ::datalog-query | |
92 [query ^Writer writer] | |
93 (print-method (display-query query) writer)) | |
94 | |
95 | |
96 | |
97 ;;; SIP | |
98 | |
99 (defn compute-sip | |
100 "Given a set of bound column names, return an adorned sip for this | |
101 rule. A set of intensional predicates should be provided to | |
102 determine what should be adorned." | |
103 [bindings i-preds rule] | |
104 (let [next-lit (fn [bv body] | |
105 (or (first (drop-while | |
106 #(not (literal-appropriate? bv %)) | |
107 body)) | |
108 (first (drop-while (complement positive?) body)))) | |
109 adorn (fn [lit bvs] | |
110 (if (i-preds (literal-predicate lit)) | |
111 (let [bnds (union (get-cs-from-vs lit bvs) | |
112 (get-self-bound-cs lit))] | |
113 (adorned-literal lit bnds)) | |
114 lit)) | |
115 new-h (adorned-literal (:head rule) bindings)] | |
116 (loop [bound-vars (get-vs-from-cs (:head rule) bindings) | |
117 body (:body rule) | |
118 sip []] | |
119 (if-let [next (next-lit bound-vars body)] | |
120 (recur (union bound-vars (literal-vars next)) | |
121 (remove #(= % next) body) | |
122 (conj sip (adorn next bound-vars))) | |
123 (build-rule new-h (concat sip body)))))) | |
124 | |
125 | |
126 ;;; Rule sets | |
127 | |
128 (defn make-rules-set | |
129 "Given an existing set of rules, make it a 'rules-set' for | |
130 printing." | |
131 [rs] | |
132 (with-meta rs {:type ::datalog-rules-set})) | |
133 | |
134 (def empty-rules-set (make-rules-set #{})) | |
135 | |
136 (defn rules-set | |
137 "Given a collection of rules return a rules set" | |
138 [& rules] | |
139 (reduce conj empty-rules-set rules)) | |
140 | |
141 (defmethod print-method ::datalog-rules-set | |
142 [rules ^Writer writer] | |
143 (binding [*out* writer] | |
144 (do | |
145 (print "(rules-set") | |
146 (doseq [rule rules] | |
147 (println) | |
148 (print " ") | |
149 (print rule)) | |
150 (println ")")))) | |
151 | |
152 (defn predicate-map | |
153 "Given a rules-set, return a map of rules keyed by their predicates. | |
154 Each value will be a set of rules." | |
155 [rs] | |
156 (let [add-rule (fn [m r] | |
157 (let [pred (-> r :head literal-predicate) | |
158 os (get m pred #{})] | |
159 (assoc m pred (conj os r))))] | |
160 (reduce add-rule {} rs))) | |
161 | |
162 (defn all-predicates | |
163 "Given a rules-set, return all defined predicates" | |
164 [rs] | |
165 (set (map literal-predicate (map :head rs)))) | |
166 | |
167 (defn non-base-rules | |
168 "Return a collection of rules that depend, somehow, on other rules" | |
169 [rs] | |
170 (let [pred (all-predicates rs) | |
171 non-base (fn [r] | |
172 (if (some #(pred %) | |
173 (map literal-predicate (:body r))) | |
174 r | |
175 nil))] | |
176 (remove nil? (map non-base rs)))) | |
177 | |
178 | |
179 ;;; Database operations | |
180 | |
181 (def empty-bindings [{}]) | |
182 | |
183 (defn apply-rule | |
184 "Apply the rule against db-1, adding the results to the appropriate | |
185 relation in db-2. The relation will be created if needed." | |
186 ([db rule] (apply-rule db db rule)) | |
187 ([db-1 db-2 rule] | |
188 (trace-datalog (println) | |
189 (println) | |
190 (println "--------------- Begin Rule ---------------") | |
191 (println rule)) | |
192 (let [head (:head rule) | |
193 body (:body rule) | |
194 step (fn [bs lit] | |
195 (trace-datalog (println bs) | |
196 (println lit)) | |
197 (join-literal db-1 lit bs)) | |
198 bs (reduce step empty-bindings body)] | |
199 (do (trace-datalog (println bs)) | |
200 (project-literal db-2 head bs))))) | |
201 | |
202 (defn apply-rules-set | |
203 [db rs] | |
204 (reduce (fn [rdb rule] | |
205 (apply-rule db rdb rule)) db rs)) | |
206 | |
207 | |
208 ;; End of file |