comparison src/clojure/contrib/datalog/literals.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 ;; literals.clj
10 ;;
11 ;; A Clojure implementation of Datalog -- Literals
12 ;;
13 ;; straszheimjeffrey (gmail)
14 ;; Created 25 Feburary 2009
15
16
17 (ns clojure.contrib.datalog.literals
18 (:use clojure.contrib.datalog.util)
19 (:use clojure.contrib.datalog.database)
20 (:use [clojure.set :only (intersection)])
21 (:use [clojure.contrib.set :only (subset?)]))
22
23
24 ;;; Type Definitions
25
26 (defstruct atomic-literal
27 :predicate ; The predicate name
28 :term-bindings ; A map of column names to bindings
29 :literal-type) ; ::literal or ::negated
30
31 (derive ::negated ::literal)
32
33 (defstruct conditional-literal
34 :fun ; The fun to call
35 :symbol ; The fun symbol (for display)
36 :terms ; The formal arguments
37 :literal-type) ; ::conditional
38
39
40 ;;; Basics
41
42
43 (defmulti literal-predicate
44 "Return the predicate/relation this conditional operates over"
45 :literal-type)
46
47 (defmulti literal-columns
48 "Return the column names this applies to"
49 :literal-type)
50
51 (defmulti literal-vars
52 "Returns the logic vars used by this literal"
53 :literal-type)
54
55 (defmulti positive-vars
56 "Returns the logic vars used in a positive position"
57 :literal-type)
58
59 (defmulti negative-vars
60 "Returns the logic vars used in a negative position"
61 :literal-type)
62
63 (defmethod literal-predicate ::literal
64 [l]
65 (:predicate l))
66
67 (defmethod literal-predicate ::conditional
68 [l]
69 nil)
70
71 (defmethod literal-columns ::literal
72 [l]
73 (-> l :term-bindings keys set))
74
75 (defmethod literal-columns ::conditional
76 [l]
77 nil)
78
79 (defmethod literal-vars ::literal
80 [l]
81 (set (filter is-var? (-> l :term-bindings vals))))
82
83 (defmethod literal-vars ::conditional
84 [l]
85 (set (filter is-var? (:terms l))))
86
87 (defmethod positive-vars ::literal
88 [l]
89 (literal-vars l))
90
91 (defmethod positive-vars ::negated
92 [l]
93 nil)
94
95 (defmethod positive-vars ::conditional
96 [l]
97 nil)
98
99 (defmethod negative-vars ::literal
100 [l]
101 nil)
102
103 (defmethod negative-vars ::negated
104 [l]
105 (literal-vars l))
106
107 (defmethod negative-vars ::conditional
108 [l]
109 (literal-vars l))
110
111 (defn negated?
112 "Is this literal a negated literal?"
113 [l]
114 (= (:literal-type l) ::negated))
115
116 (defn positive?
117 "Is this a positive literal?"
118 [l]
119 (= (:literal-type l) ::literal))
120
121
122 ;;; Building Literals
123
124 (def negation-symbol 'not!)
125 (def conditional-symbol 'if)
126
127 (defmulti build-literal
128 "(Returns an unevaluated expression (to be used in macros) of a
129 literal."
130 first)
131
132 (defn build-atom
133 "Returns an unevaluated expression (to be used in a macro) of an
134 atom."
135 [f type]
136 (let [p (first f)
137 ts (map #(if (is-var? %) `(quote ~%) %) (next f))
138 b (if (seq ts) (apply assoc {} ts) nil)]
139 `(struct atomic-literal ~p ~b ~type)))
140
141 (defmethod build-literal :default
142 [f]
143 (build-atom f ::literal))
144
145 (defmethod build-literal negation-symbol
146 [f]
147 (build-atom (rest f) ::negated))
148
149 (defmethod build-literal conditional-symbol
150 [f]
151 (let [symbol (fnext f)
152 terms (nnext f)
153 fun `(fn [binds#] (apply ~symbol binds#))]
154 `(struct conditional-literal
155 ~fun
156 '~symbol
157 '~terms
158 ::conditional)))
159
160
161 ;;; Display
162
163 (defmulti display-literal
164 "Converts a struct representing a literal to a normal list"
165 :literal-type)
166
167 (defn- display
168 [l]
169 (conj (-> l :term-bindings list* flatten) (literal-predicate l)))
170
171 (defmethod display-literal ::literal
172 [l]
173 (display l))
174
175 (defmethod display-literal ::negated
176 [l]
177 (conj (display l) negation-symbol))
178
179 (defmethod display-literal ::conditional
180 [l]
181 (list* conditional-symbol (:symbol l) (:terms l)))
182
183
184 ;;; Sip computation
185
186 (defmulti get-vs-from-cs
187 "From a set of columns, return the vars"
188 :literal-type)
189
190 (defmethod get-vs-from-cs ::literal
191 [l bound]
192 (set (filter is-var?
193 (vals (select-keys (:term-bindings l)
194 bound)))))
195
196 (defmethod get-vs-from-cs ::conditional
197 [l bound]
198 nil)
199
200
201 (defmulti get-cs-from-vs
202 "From a set of vars, get the columns"
203 :literal-type)
204
205 (defmethod get-cs-from-vs ::literal
206 [l bound]
207 (reduce conj
208 #{}
209 (remove nil?
210 (map (fn [[k v]] (if (bound v) k nil))
211 (:term-bindings l)))))
212
213 (defmethod get-cs-from-vs ::conditional
214 [l bound]
215 nil)
216
217
218 (defmulti get-self-bound-cs
219 "Get the columns that are bound withing the literal."
220 :literal-type)
221
222 (defmethod get-self-bound-cs ::literal
223 [l]
224 (reduce conj
225 #{}
226 (remove nil?
227 (map (fn [[k v]] (if (not (is-var? v)) k nil))
228 (:term-bindings l)))))
229
230 (defmethod get-self-bound-cs ::conditional
231 [l]
232 nil)
233
234
235 (defmulti literal-appropriate?
236 "When passed a set of bound vars, determines if this literal can be
237 used during this point of a SIP computation."
238 (fn [b l] (:literal-type l)))
239
240 (defmethod literal-appropriate? ::literal
241 [bound l]
242 (not (empty? (intersection (literal-vars l) bound))))
243
244 (defmethod literal-appropriate? ::negated
245 [bound l]
246 (subset? (literal-vars l) bound))
247
248 (defmethod literal-appropriate? ::conditional
249 [bound l]
250 (subset? (literal-vars l) bound))
251
252
253 (defmulti adorned-literal
254 "When passed a set of bound columns, returns the adorned literal"
255 (fn [l b] (:literal-type l)))
256
257 (defmethod adorned-literal ::literal
258 [l bound]
259 (let [pred (literal-predicate l)
260 bnds (intersection (literal-columns l) bound)]
261 (if (empty? bound)
262 l
263 (assoc l :predicate {:pred pred :bound bnds}))))
264
265 (defmethod adorned-literal ::conditional
266 [l bound]
267 l)
268
269
270 (defn get-adorned-bindings
271 "Get the bindings from this adorned literal."
272 [pred]
273 (:bound pred))
274
275 (defn get-base-predicate
276 "Get the base predicate from this predicate."
277 [pred]
278 (if (map? pred)
279 (:pred pred)
280 pred))
281
282
283 ;;; Magic Stuff
284
285 (defn magic-literal
286 "Create a magic version of this adorned predicate."
287 [l]
288 (assert (-> l :literal-type (isa? ::literal)))
289 (let [pred (literal-predicate l)
290 pred-map (if (map? pred) pred {:pred pred})
291 bound (get-adorned-bindings pred)
292 ntb (select-keys (:term-bindings l) bound)]
293 (assoc l :predicate (assoc pred-map :magic true) :term-bindings ntb :literal-type ::literal)))
294
295 (defn literal-magic?
296 "Is this literal magic?"
297 [lit]
298 (let [pred (literal-predicate lit)]
299 (when (map? pred)
300 (:magic pred))))
301
302 (defn build-seed-bindings
303 "Given a seed literal, already adorned and in magic form, convert
304 its bound constants to new variables."
305 [s]
306 (assert (-> s :literal-type (isa? ::literal)))
307 (let [ntbs (map-values (fn [_] (gensym '?_gen_)) (:term-bindings s))]
308 (assoc s :term-bindings ntbs)))
309
310
311 ;;; Semi-naive support
312
313 (defn negated-literal
314 "Given a literal l, return a negated version"
315 [l]
316 (assert (-> l :literal-type (= ::literal)))
317 (assoc l :literal-type ::negated))
318
319 (defn delta-literal
320 "Given a literal l, return a delta version"
321 [l]
322 (let [pred* (:predicate l)
323 pred (if (map? pred*) pred* {:pred pred*})]
324 (assoc l :predicate (assoc pred :delta true))))
325
326
327 ;;; Database operations
328
329 (defn- build-partial-tuple
330 [lit binds]
331 (let [tbs (:term-bindings lit)
332 each (fn [[key val :as pair]]
333 (if (is-var? val)
334 (if-let [n (binds val)]
335 [key n]
336 nil)
337 pair))]
338 (into {} (remove nil? (map each tbs)))))
339
340 (defn- project-onto-literal
341 "Given a literal, and a materialized tuple, return a set of variable
342 bindings."
343 [lit tuple]
344 (let [step (fn [binds [key val]]
345 (if (and (is-var? val)
346 (contains? tuple key))
347 (assoc binds val (tuple key))
348 binds))]
349 (reduce step {} (:term-bindings lit))))
350
351
352 (defn- join-literal*
353 [db lit bs fun]
354 (let [each (fn [binds]
355 (let [pt (build-partial-tuple lit binds)]
356 (fun binds pt)))]
357 (when (contains? db (literal-predicate lit))
358 (apply concat (map each bs)))))
359
360 (defmulti join-literal
361 "Given a database (db), a literal (lit) and a seq of bindings (bs),
362 return a new seq of bindings by joining this literal."
363 (fn [db lit bs] (:literal-type lit)))
364
365 (defmethod join-literal ::literal
366 [db lit bs]
367 (join-literal* db lit bs (fn [binds pt]
368 (map #(merge binds %)
369 (map (partial project-onto-literal lit)
370 (select db (literal-predicate lit) pt))))))
371
372 (defmethod join-literal ::negated
373 [db lit bs]
374 (join-literal* db lit bs (fn [binds pt]
375 (if (any-match? db (literal-predicate lit) pt)
376 nil
377 [binds]))))
378
379 (defmethod join-literal ::conditional
380 [db lit bs]
381 (let [each (fn [binds]
382 (let [resolve (fn [term]
383 (if (is-var? term)
384 (binds term)
385 term))
386 args (map resolve (:terms lit))]
387 (if ((:fun lit) args)
388 binds
389 nil)))]
390 (remove nil? (map each bs))))
391
392 (defn project-literal
393 "Project a stream of bindings onto a literal/relation. Returns a new
394 db."
395 ([db lit bs] (project-literal db lit bs is-var?))
396 ([db lit bs var?]
397 (assert (= (:literal-type lit) ::literal))
398 (let [rel-name (literal-predicate lit)
399 columns (-> lit :term-bindings keys)
400 idxs (vec (get-adorned-bindings (literal-predicate lit)))
401 db1 (ensure-relation db rel-name columns idxs)
402 rel (get-relation db1 rel-name)
403 step (fn [rel bindings]
404 (let [step (fn [t [k v]]
405 (if (var? v)
406 (assoc t k (bindings v))
407 (assoc t k v)))
408 tuple (reduce step {} (:term-bindings lit))]
409 (add-tuple rel tuple)))]
410 (replace-relation db rel-name (reduce step rel bs)))))
411
412
413 ;; End of file