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