Mercurial > lasercutter
comparison src/clojure/contrib/datalog/softstrat.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 ;; 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 :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] | |
42 (if-let [pred (literal-predicate lit)] | |
43 (conj pds pred) | |
44 pds)) | |
45 pds | |
46 lits)) | |
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 |