Mercurial > lasercutter
comparison src/clojure/contrib/graph.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 ;; graph | |
10 ;; | |
11 ;; Basic Graph Theory Algorithms | |
12 ;; | |
13 ;; straszheimjeffrey (gmail) | |
14 ;; Created 23 June 2009 | |
15 | |
16 | |
17 (ns | |
18 ^{:author "Jeffrey Straszheim", | |
19 :doc "Basic graph theory algorithms"} | |
20 clojure.contrib.graph | |
21 (use [clojure.set :only (union)])) | |
22 | |
23 | |
24 (defstruct directed-graph | |
25 :nodes ; The nodes of the graph, a collection | |
26 :neighbors) ; A function that, given a node returns a collection | |
27 ; neighbor nodes. | |
28 | |
29 (defn get-neighbors | |
30 "Get the neighbors of a node." | |
31 [g n] | |
32 ((:neighbors g) n)) | |
33 | |
34 | |
35 ;; Graph Modification | |
36 | |
37 (defn reverse-graph | |
38 "Given a directed graph, return another directed graph with the | |
39 order of the edges reversed." | |
40 [g] | |
41 (let [op (fn [rna idx] | |
42 (let [ns (get-neighbors g idx) | |
43 am (fn [m val] | |
44 (assoc m val (conj (get m val #{}) idx)))] | |
45 (reduce am rna ns))) | |
46 rn (reduce op {} (:nodes g))] | |
47 (struct directed-graph (:nodes g) rn))) | |
48 | |
49 (defn add-loops | |
50 "For each node n, add the edge n->n if not already present." | |
51 [g] | |
52 (struct directed-graph | |
53 (:nodes g) | |
54 (into {} (map (fn [n] | |
55 [n (conj (set (get-neighbors g n)) n)]) (:nodes g))))) | |
56 | |
57 (defn remove-loops | |
58 "For each node n, remove any edges n->n." | |
59 [g] | |
60 (struct directed-graph | |
61 (:nodes g) | |
62 (into {} (map (fn [n] | |
63 [n (disj (set (get-neighbors g n)) n)]) (:nodes g))))) | |
64 | |
65 | |
66 ;; Graph Walk | |
67 | |
68 (defn lazy-walk | |
69 "Return a lazy sequence of the nodes of a graph starting a node n. Optionally, | |
70 provide a set of visited notes (v) and a collection of nodes to | |
71 visit (ns)." | |
72 ([g n] | |
73 (lazy-walk g [n] #{})) | |
74 ([g ns v] | |
75 (lazy-seq (let [s (seq (drop-while v ns)) | |
76 n (first s) | |
77 ns (rest s)] | |
78 (when s | |
79 (cons n (lazy-walk g (concat (get-neighbors g n) ns) (conj v n)))))))) | |
80 | |
81 (defn transitive-closure | |
82 "Returns the transitive closure of a graph. The neighbors are lazily computed. | |
83 | |
84 Note: some version of this algorithm return all edges a->a | |
85 regardless of whether such loops exist in the original graph. This | |
86 version does not. Loops will be included only if produced by | |
87 cycles in the graph. If you have code that depends on such | |
88 behavior, call (-> g transitive-closure add-loops)" | |
89 [g] | |
90 (let [nns (fn [n] | |
91 [n (delay (lazy-walk g (get-neighbors g n) #{}))]) | |
92 nbs (into {} (map nns (:nodes g)))] | |
93 (struct directed-graph | |
94 (:nodes g) | |
95 (fn [n] (force (nbs n)))))) | |
96 | |
97 | |
98 ;; Strongly Connected Components | |
99 | |
100 (defn- post-ordered-visit | |
101 "Starting at node n, perform a post-ordered walk." | |
102 [g n [visited acc :as state]] | |
103 (if (visited n) | |
104 state | |
105 (let [[v2 acc2] (reduce (fn [st nd] (post-ordered-visit g nd st)) | |
106 [(conj visited n) acc] | |
107 (get-neighbors g n))] | |
108 [v2 (conj acc2 n)]))) | |
109 | |
110 (defn post-ordered-nodes | |
111 "Return a sequence of indexes of a post-ordered walk of the graph." | |
112 [g] | |
113 (fnext (reduce #(post-ordered-visit g %2 %1) | |
114 [#{} []] | |
115 (:nodes g)))) | |
116 | |
117 (defn scc | |
118 "Returns, as a sequence of sets, the strongly connected components | |
119 of g." | |
120 [g] | |
121 (let [po (reverse (post-ordered-nodes g)) | |
122 rev (reverse-graph g) | |
123 step (fn [stack visited acc] | |
124 (if (empty? stack) | |
125 acc | |
126 (let [[nv comp] (post-ordered-visit rev | |
127 (first stack) | |
128 [visited #{}]) | |
129 ns (remove nv stack)] | |
130 (recur ns nv (conj acc comp)))))] | |
131 (step po #{} []))) | |
132 | |
133 (defn component-graph | |
134 "Given a graph, perhaps with cycles, return a reduced graph that is acyclic. | |
135 Each node in the new graph will be a set of nodes from the old. | |
136 These sets are the strongly connected components. Each edge will | |
137 be the union of the corresponding edges of the prior graph." | |
138 ([g] | |
139 (component-graph g (scc g))) | |
140 ([g sccs] | |
141 (let [find-node-set (fn [n] | |
142 (some #(if (% n) % nil) sccs)) | |
143 find-neighbors (fn [ns] | |
144 (let [nbs1 (map (partial get-neighbors g) ns) | |
145 nbs2 (map set nbs1) | |
146 nbs3 (apply union nbs2)] | |
147 (set (map find-node-set nbs3)))) | |
148 nm (into {} (map (fn [ns] [ns (find-neighbors ns)]) sccs))] | |
149 (struct directed-graph (set sccs) nm)))) | |
150 | |
151 (defn recursive-component? | |
152 "Is the component (recieved from scc) self recursive?" | |
153 [g ns] | |
154 (or (> (count ns) 1) | |
155 (let [n (first ns)] | |
156 (some #(= % n) (get-neighbors g n))))) | |
157 | |
158 (defn self-recursive-sets | |
159 "Returns, as a sequence of sets, the components of a graph that are | |
160 self-recursive." | |
161 [g] | |
162 (filter (partial recursive-component? g) (scc g))) | |
163 | |
164 | |
165 ;; Dependency Lists | |
166 | |
167 (defn fixed-point | |
168 "Repeatedly apply fun to data until (equal old-data new-data) | |
169 returns true. If max iterations occur, it will throw an | |
170 exception. Set max to nil for unlimited iterations." | |
171 [data fun max equal] | |
172 (let [step (fn step [data idx] | |
173 (when (and idx (= 0 idx)) | |
174 (throw (Exception. "Fixed point overflow"))) | |
175 (let [new-data (fun data)] | |
176 (if (equal data new-data) | |
177 new-data | |
178 (recur new-data (and idx (dec idx))))))] | |
179 (step data max))) | |
180 | |
181 (defn- fold-into-sets | |
182 [priorities] | |
183 (let [max (inc (apply max 0 (vals priorities))) | |
184 step (fn [acc [n dep]] | |
185 (assoc acc dep (conj (acc dep) n)))] | |
186 (reduce step | |
187 (vec (replicate max #{})) | |
188 priorities))) | |
189 | |
190 (defn dependency-list | |
191 "Similar to a topological sort, this returns a vector of sets. The | |
192 set of nodes at index 0 are independent. The set at index 1 depend | |
193 on index 0; those at 2 depend on 0 and 1, and so on. Those withing | |
194 a set have no mutual dependencies. Assume the input graph (which | |
195 much be acyclic) has an edge a->b when a depends on b." | |
196 [g] | |
197 (let [step (fn [d] | |
198 (let [update (fn [n] | |
199 (inc (apply max -1 (map d (get-neighbors g n)))))] | |
200 (into {} (map (fn [[k v]] [k (update k)]) d)))) | |
201 counts (fixed-point (zipmap (:nodes g) (repeat 0)) | |
202 step | |
203 (inc (count (:nodes g))) | |
204 =)] | |
205 (fold-into-sets counts))) | |
206 | |
207 (defn stratification-list | |
208 "Similar to dependency-list (see doc), except two graphs are | |
209 provided. The first is as dependency-list. The second (which may | |
210 have cycles) provides a partial-dependency relation. If node a | |
211 depends on node b (meaning an edge a->b exists) in the second | |
212 graph, node a must be equal or later in the sequence." | |
213 [g1 g2] | |
214 (assert (= (-> g1 :nodes set) (-> g2 :nodes set))) | |
215 (let [step (fn [d] | |
216 (let [update (fn [n] | |
217 (max (inc (apply max -1 | |
218 (map d (get-neighbors g1 n)))) | |
219 (apply max -1 (map d (get-neighbors g2 n)))))] | |
220 (into {} (map (fn [[k v]] [k (update k)]) d)))) | |
221 counts (fixed-point (zipmap (:nodes g1) (repeat 0)) | |
222 step | |
223 (inc (count (:nodes g1))) | |
224 =)] | |
225 (fold-into-sets counts))) | |
226 | |
227 | |
228 ;; End of file |