/
graph.clj
201 lines (173 loc) · 6.71 KB
/
graph.clj
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
(ns advent-utils.graph
(:require [clojure.data.priority-map :refer [priority-map]]
[clojure.math.combinatorics :as combo]
[advent-utils.core :as u]))
(defprotocol Graph
(vertices [this] "A collection of all the vertices in the graph")
(vertex [this v] "Any data/information/label associated with the given vertex in the graph")
(edges [this v] "A collection of the edges for the given vertex in the graph")
(distance [this v1 v2] "The distance (or edge weight) between two vertices")
(without-vertex [this v] "Produces a new graph with the vertex removed")
(rewired-without-vertex [this v] "Produces a new graph, re-wired to preserve the transitive edges through the removed vertex"))
(defrecord MapGraph [graph]
Graph
(vertices
[_]
(keys graph))
(edges
[_ v]
(keys (graph v)))
(distance
[_ v1 v2]
(get-in graph [v1 v2]))
(without-vertex
[g v]
(let [neighbors (edges g v)
newgraph (-> (reduce #(update %1 %2 dissoc v) graph neighbors)
(dissoc v))]
(assoc g :graph newgraph)))
(rewired-without-vertex
[g v]
(let [neighbors (edges g v)
all-pairs (combo/permuted-combinations neighbors 2)
newedge-fn (fn [g [v1 v2]]
(update-in g [:graph v1] assoc v2 (+ (distance g v1 v)
(distance g v v2))))]
(without-vertex (reduce newedge-fn g all-pairs) v))))
(defrecord LabeledMapGraph [graph]
Graph
(vertices
[_]
(keys graph))
(vertex
[_ v]
(graph v))
(edges
[_ v]
(keys (:edges (graph v))))
(distance
[_ v1 v2]
(get-in graph [:edges v1 v2]))
(without-vertex
[_ v]
(let [neighbors (keys (:edges graph v))
newgraph (-> (reduce #(update-in %1 [:edges %2] dissoc v) graph neighbors)
(dissoc v))]
(->LabeledMapGraph newgraph))))
(defn degree
"The degree of a vertex is the number of edges it has"
[g v]
(count (edges g v)))
(defn leaf?
"Whether a vertex is a leaf vertex (meaning that it has at most one edge)"
[g v]
(= 1 (degree g v)))
(defn junction?
"Whether a vertex is a junction (meaning that it has more than two edges)"
[g v]
(> (degree g v) 2))
(defn path-distance
"Computes the distance along a path (an ordered collection of vertices)"
[g path]
(reduce + (map #(apply (partial distance g) %) (partition 2 1 path))))
(defn entries-in-set
[s m]
(filter (fn [[k _]] (s k)) m))
(defn entries-not-in-set
[s m]
(filter (fn [[k _]] ((complement s) k)) m))
(defn single-path
"Return the only possible path traversal from the start vertex (presumed to be a leaf vertex)
until reaching another leaf vertex or a vertex with more than one un-traversed edge"
([g v & {:keys [exclude]}]
(loop [visited (if exclude [exclude v] [v])
neighbors (if exclude (filter (complement #{exclude}) (edges g v)) (edges g v))]
(if (or (> (count neighbors) 1) (= (count neighbors) 0))
visited
(recur (conj visited (first neighbors))
(filter (complement (set visited)) (edges g (first neighbors))))))))
(defn single-path-2
"Return the only possible path traversal from the start vertex (presumed to be a leaf vertex)
until reaching another leaf vertex or a vertex with more than one un-traversed edge"
([g v s stop-at]
(loop [visited [s v]
neighbors (filter (complement #{s}) (edges g v))]
(if (or (> (count neighbors) 1)
(= (count neighbors) 0)
(some? (stop-at (last visited))))
visited
(recur (conj visited (first neighbors))
(filter (complement (set visited)) (edges g (first neighbors))))))))
(defn all-paths
"Find all the paths from a vertex reaching a leaf vertex or a vertex with more than one
untraversed edges"
[g v & {:keys [excludes]}]
(let [neighbors (edges g v)
stop-at (if excludes (set excludes) #{})]
(map #(single-path-2 g % v stop-at) neighbors)))
(defn dijkstra-update
[graph vertex {:keys [dist prev queue] :as state} neighbor]
(let [alt (+ (dist vertex) (distance graph vertex neighbor))]
(if (or (nil? (dist neighbor)) (< alt (dist neighbor)))
{:dist (assoc dist neighbor alt)
:queue (assoc queue neighbor alt)
:prev (assoc prev neighbor vertex)}
state)))
(defn dijkstra-retrace
[prev-steps finish]
(loop [vertex finish chain []]
(if (nil? vertex)
chain
(recur (prev-steps vertex) (conj chain vertex)))))
(defn dijkstra
"Executes Dijkstra's algorithm to identify the shortest path between the start and finish vertices"
[graph start finish & {:keys [limit]}]
(let [max-search (or limit (count (vertices graph)))
init-state {:dist {start 0} :prev {} :queue (priority-map start 0)}]
(loop [visited #{}
visited-count 1
vertex start
state init-state]
(if (or (= max-search visited-count) (= vertex finish))
(reverse (dijkstra-retrace (state :prev) finish))
(let [neighbors (remove visited (edges graph vertex))
new-state (-> (reduce (partial dijkstra-update graph vertex) state neighbors)
(update :queue dissoc vertex))]
(recur
(conj visited vertex)
(if (visited vertex) visited-count (inc visited-count))
(ffirst (:queue new-state))
new-state))))))
(defn shortest-distance
[graph start finish]
(path-distance graph (dijkstra graph start finish)))
(defn pruned
"Prunes the single branches from a graph, excluding any vertices in the exclude-set"
[graph exclude-set]
(loop [newgraph graph]
(let [dead-end-pred (every-pred (partial leaf? newgraph) (complement exclude-set))
dead-ends (filter dead-end-pred (vertices newgraph))]
(if (= 0 (count dead-ends))
newgraph
(recur (reduce without-vertex newgraph dead-ends))))))
(defn summarize-path
[g path]
[(first path) {(last path) (path-distance g path)}])
(defn adjacencies
[graph]
(let [leaves (filter (partial leaf? graph) (vertices graph))
junctions (filter (partial junction? graph) (vertices graph))
nodes (concat leaves junctions)]
(->> (mapcat (partial all-paths graph) nodes)
(map (partial summarize-path graph))
(group-by first)
(u/fmap #(apply merge (map second %))))))
(defn reachable
[graph start stop-cond]
(loop [visited #{start} explore (edges graph start)]
(let [next-neighbors (filter (complement visited) explore)]
(if (zero? (count next-neighbors))
(disj visited start)
(let [node (first next-neighbors)]
(recur (conj visited node)
(if (stop-cond node) explore (concat explore (edges graph node)))))))))