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