Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 129 lines (112 sloc) 4.946 kb
82f5ad1 @straszheimjeffrey Added datalog
straszheimjeffrey authored
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 ;; magic.clj
10 ;;
11 ;; A Clojure implementation of Datalog -- Magic Sets
12 ;;
13 ;; straszheimjeffrey (gmail)
14 ;; Created 18 Feburary 2009
15
16
17 (ns clojure.contrib.datalog.magic
18 (:use clojure.contrib.datalog.util
19 clojure.contrib.datalog.literals
20 clojure.contrib.datalog.rules)
21 (:use [clojure.set :only (union intersection difference)]))
22
23
24 ;;; Adornment
25
26 (defn adorn-query
27 "Adorn a query"
28 [q]
29 (adorned-literal q (get-self-bound-cs q)))
30
31 (defn adorn-rules-set
32 "Adorns the given rules-set for the given query. (rs) is a
33 rules-set, (q) is an adorned query."
34 [rs q]
35 (let [i-preds (all-predicates rs)
36 p-map (predicate-map rs)]
37 (loop [nrs empty-rules-set ; The rules set being built
38 needed #{(literal-predicate q)}]
39 (if (empty? needed)
40 nrs
41 (let [pred (first needed)
42 remaining (disj needed pred)
43 base-pred (get-base-predicate pred)
44 bindings (get-adorned-bindings pred)
45 new-rules (p-map base-pred)
46 new-adorned-rules (map (partial compute-sip bindings i-preds)
47 new-rules)
48 new-nrs (reduce conj nrs new-adorned-rules)
49 current-preds (all-predicates new-nrs)
50 not-needed? (fn [pred]
51 (or (current-preds pred)
52 (-> pred get-base-predicate i-preds not)))
53 add-pred (fn [np pred]
54 (if (not-needed? pred) np (conj np pred)))
55 add-preds (fn [np rule]
56 (reduce add-pred np (map literal-predicate (:body rule))))
57 new-needed (reduce add-preds remaining new-adorned-rules)]
58 (recur new-nrs new-needed))))))
59
14c51b3 @straszheimjeffrey Fixed lousy representation for adorned predicates
straszheimjeffrey authored
60
82f5ad1 @straszheimjeffrey Added datalog
straszheimjeffrey authored
61 ;;; Magic !
62
63 (defn seed-relation
64 "Given a magic form of a query, give back the literal form of its seed
65 relation"
66 [q]
67 (let [pred (-> q literal-predicate get-base-predicate)
68 bnds (-> q literal-predicate get-adorned-bindings)]
69 (with-meta (assoc q :predicate [pred :magic-seed bnds]) {})))
70
71 (defn seed-rule
72 "Given an adorned query, give back its seed rule"
73 [q]
74 (let [mq (build-seed-bindings (magic-literal q))
75 sr (seed-relation mq)]
76 (build-rule mq [sr])))
77
7dfd0d9 @straszheimjeffrey More semi-naive work
straszheimjeffrey authored
78 (defn build-partial-tuple
79 "Given a query and a set of bindings, build a partial tuple needed
80 to extract the relation from the database."
81 [q bindings]
82 (into {} (remove nil? (map (fn [[k v :as pair]]
83 (if (is-var? v)
84 nil
85 (if (is-query-var? v)
86 [k (bindings v)]
87 pair)))
88 (:term-bindings q)))))
89
82f5ad1 @straszheimjeffrey Added datalog
straszheimjeffrey authored
90 (defn seed-predicate-for-insertion
91 "Given a query, return the predicate to use for database insertion."
92 [q]
93 (let [seed (-> q seed-rule :body first)
94 columns (-> seed :term-bindings keys)
95 new-term-bindings (-> q :term-bindings (select-keys columns))]
96 (assoc seed :term-bindings new-term-bindings)))
97
98 (defn magic-transform
99 "Return a magic transformation of an adorned rules-set (rs). The
100 (i-preds) are the predicates of the intension database. These
101 default to the predicates within the rules-set."
102 ([rs]
103 (magic-transform rs (all-predicates rs)))
104 ([rs i-preds]
105 (let [not-duplicate? (fn [l mh bd]
106 (or (not (empty? bd))
107 (not (= (magic-literal l)
108 mh))))
109 xr (fn [rs rule]
110 (let [head (:head rule)
111 body (:body rule)
112 mh (magic-literal head)
113 answer-rule (build-rule head
114 (concat [mh] body))
115 step (fn [[rs bd] l]
116 (if (and (i-preds (literal-predicate l))
117 (not-duplicate? l mh bd))
118 (let [nr (build-rule (magic-literal l)
119 (concat [mh] bd))]
120 [(conj rs nr) (conj bd l)])
121 [rs (conj bd l)]))
122 [nrs _] (reduce step [rs []] body)]
123 (conj nrs answer-rule)))]
124 (reduce xr empty-rules-set rs))))
125
126
127
128 ;; End of file
Something went wrong with that request. Please try again.