Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Newer
Older
100644 162 lines (137 sloc) 5.481 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 ;; softstrat.clj
10 ;;
11 ;; A Clojure implementation of Datalog -- Soft Stratification
12 ;;
13 ;; straszheimjeffrey (gmail)
14 ;; Created 28 Feburary 2009
15
16
17 (ns clojure.contrib.datalog.softstrat
18 (:use clojure.contrib.datalog.util
19 clojure.contrib.datalog.database
20 clojure.contrib.datalog.literals
21 clojure.contrib.datalog.rules
22 clojure.contrib.datalog.magic)
23 (:use [clojure.set :only (union intersection difference)])
24 (:use [clojure.contrib.seq-utils :only (indexed)])
25 (:require [clojure.contrib.graph :as graph]))
26
27
28 ;;; Dependency graph
29
30 (defn- build-rules-graph
31 "Given a rules-set (rs), build a graph where each predicate symbol in rs,
32 there is a node n, and for each rule (<- h b-1 b-2 ...), there are edges
33 from the (literal-predicate h) -> (literal-predicate b-*), one for each
34 b-*."
35 [rs]
36 (let [preds (all-predicates rs)
37 pred-map (predicate-map rs)
38 step (fn [nbs pred]
39 (let [rules (pred-map pred)
40 preds (reduce (fn [pds lits]
41 (reduce (fn [pds lit]
a0a4c1b @straszheimjeffrey Tweaks
straszheimjeffrey authored
42 (if-let [pred (literal-predicate lit)]
43 (conj pds pred)
44 pds))
45 pds
46 lits))
82f5ad1 @straszheimjeffrey Added datalog
straszheimjeffrey authored
47 #{}
48 (map :body rules))]
49 (assoc nbs pred preds)))
50 neighbors (reduce step {} preds)]
51 (struct graph/directed-graph preds neighbors)))
52
53 (defn- build-def
54 "Given a rules-set, build its def function"
55 [rs]
56 (let [pred-map (predicate-map rs)
57 graph (-> rs
58 build-rules-graph
59 graph/transitive-closure
60 graph/add-loops)]
61 (fn [pred]
62 (apply union (map set (map pred-map (graph/get-neighbors graph pred)))))))
63
64
65 ;;; Soft Stratificattion REQ Graph
66
67 (defn- req
68 "Returns a rules-set that is a superset of req(lit) for the lit at
69 index lit-index"
70 [rs soft-def rule lit-index]
71 (let [head (:head rule)
72 body (:body rule)
73 lit (nth body lit-index)
74 pre (subvec (vec body) 0 lit-index)]
75 (conj (-> lit literal-predicate soft-def (magic-transform (all-predicates rs)))
76 (build-rule (magic-literal lit) pre))))
77
78 (defn- rule-dep
79 "Given a rule, return the set of rules it depends on."
80 [rs mrs soft-def rule]
81 (let [step (fn [nrs [idx lit]]
82 (if (negated? lit)
83 (union nrs (req rs soft-def rule idx))
84 nrs))]
85 (intersection mrs
86 (reduce step empty-rules-set (-> rule :body indexed)))))
87
88 (defn- soft-strat-graph
89 "The dependency graph for soft stratification."
90 [rs mrs]
91 (let [soft-def (build-def rs)
92 step (fn [nbrs rule]
93 (assoc nbrs rule (rule-dep rs mrs soft-def rule)))
94 nbrs (reduce step {} mrs)]
95 (struct graph/directed-graph mrs nbrs)))
96
97 (defn- build-soft-strat
98 "Given a rules-set (unadorned) and an adorned query, return the soft
99 stratified list. The rules will be magic transformed, and the
100 magic seed will be appended."
101 [rs q]
102 (let [ars (adorn-rules-set rs q)
103 mrs (conj (magic-transform ars)
104 (seed-rule q))
105 gr (soft-strat-graph ars mrs)]
106 (map make-rules-set (graph/dependency-list gr))))
107
108
109 ;;; Work plan
110
111 (defstruct soft-strat-work-plan
112 :query
113 :stratification)
114
115 (defn build-soft-strat-work-plan
116 "Return a work plan for the given rules-set and query"
117 [rs q]
118 (let [aq (adorn-query q)]
119 (struct soft-strat-work-plan aq (build-soft-strat rs aq))))
120
121 (defn get-all-relations
122 "Return a set of all relation names defined in this workplan"
123 [ws]
124 (apply union (map all-predicates (:stratification ws))))
125
126
127 ;;; Evaluate
128
129 (defn- weak-consq-operator
130 [db strat]
131 (trace-datalog (println)
132 (println)
133 (println "=============== Begin iteration ==============="))
134 (let [counts (database-counts db)]
135 (loop [strat strat]
136 (let [rs (first strat)]
137 (if rs
138 (let [new-db (apply-rules-set db rs)]
139 (if (= counts (database-counts new-db))
140 (recur (next strat))
141 new-db))
142 db)))))
143
144 (defn evaluate-soft-work-set
145 ([ws db] (evaluate-soft-work-set ws db {}))
146 ([ws db bindings]
147 (let [query (:query ws)
148 strat (:stratification ws)
149 seed (seed-predicate-for-insertion query)
150 seeded-db (project-literal db seed [bindings] is-query-var?)
151 fun (fn [data]
152 (weak-consq-operator data strat))
153 equal (fn [db1 db2]
154 (= (database-counts db1) (database-counts db2)))
155 new-db (graph/fixed-point seeded-db fun nil equal)
156 pt (build-partial-tuple query bindings)]
157 (select new-db (literal-predicate query) pt))))
158
159
160
161 ;; End of file
Something went wrong with that request. Please try again.