blob: bcfe5c4c72e2e235572d0bfe33db9a458900a9bb (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
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
|
