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