blob: ff6891a46ec28cec33d1d39d53f320eb5903a17d (
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
|
;; 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.
;;
;; magic.clj
;;
;; A Clojure implementation of Datalog -- Magic Sets
;;
;; straszheimjeffrey (gmail)
;; Created 18 Feburary 2009
(ns clojure.contrib.datalog.magic
(:use clojure.contrib.datalog.util
clojure.contrib.datalog.literals
clojure.contrib.datalog.rules)
(:use [clojure.set :only (union intersection difference)]))
;;; Adornment
(defn adorn-query
"Adorn a query"
[q]
(adorned-literal q (get-self-bound-cs q)))
(defn adorn-rules-set
"Adorns the given rules-set for the given query. (rs) is a
rules-set, (q) is an adorned query."
[rs q]
(let [i-preds (all-predicates rs)
p-map (predicate-map rs)]
(loop [nrs empty-rules-set ; The rules set being built
needed #{(literal-predicate q)}]
(if (empty? needed)
nrs
(let [pred (first needed)
remaining (disj needed pred)
base-pred (get-base-predicate pred)
bindings (get-adorned-bindings pred)
new-rules (p-map base-pred)
new-adorned-rules (map (partial compute-sip bindings i-preds)
new-rules)
new-nrs (reduce conj nrs new-adorned-rules)
current-preds (all-predicates new-nrs)
not-needed? (fn [pred]
(or (current-preds pred)
(-> pred get-base-predicate i-preds not)))
add-pred (fn [np pred]
(if (not-needed? pred) np (conj np pred)))
add-preds (fn [np rule]
(reduce add-pred np (map literal-predicate (:body rule))))
new-needed (reduce add-preds remaining new-adorned-rules)]
(recur new-nrs new-needed))))))
;;; Magic !
(defn seed-relation
"Given a magic form of a query, give back the literal form of its seed
relation"
[q]
(let [pred (-> q literal-predicate get-base-predicate)
bnds (-> q literal-predicate get-adorned-bindings)]
(with-meta (assoc q :predicate [pred :magic-seed bnds]) {})))
(defn seed-rule
"Given an adorned query, give back its seed rule"
[q]
(let [mq (build-seed-bindings (magic-literal q))
sr (seed-relation mq)]
(build-rule mq [sr])))
(defn build-partial-tuple
"Given a query and a set of bindings, build a partial tuple needed
to extract the relation from the database."
[q bindings]
(into {} (remove nil? (map (fn [[k v :as pair]]
(if (is-var? v)
nil
(if (is-query-var? v)
[k (bindings v)]
pair)))
(:term-bindings q)))))
(defn seed-predicate-for-insertion
"Given a query, return the predicate to use for database insertion."
[q]
(let [seed (-> q seed-rule :body first)
columns (-> seed :term-bindings keys)
new-term-bindings (-> q :term-bindings (select-keys columns))]
(assoc seed :term-bindings new-term-bindings)))
(defn magic-transform
"Return a magic transformation of an adorned rules-set (rs). The
(i-preds) are the predicates of the intension database. These
default to the predicates within the rules-set."
([rs]
(magic-transform rs (all-predicates rs)))
([rs i-preds]
(let [not-duplicate? (fn [l mh bd]
(or (not (empty? bd))
(not (= (magic-literal l)
mh))))
xr (fn [rs rule]
(let [head (:head rule)
body (:body rule)
mh (magic-literal head)
answer-rule (build-rule head
(concat [mh] body))
step (fn [[rs bd] l]
(if (and (i-preds (literal-predicate l))
(not-duplicate? l mh bd))
(let [nr (build-rule (magic-literal l)
(concat [mh] bd))]
[(conj rs nr) (conj bd l)])
[rs (conj bd l)]))
[nrs _] (reduce step [rs []] body)]
(conj nrs answer-rule)))]
(reduce xr empty-rules-set rs))))
;; End of file
|
