changeset 656: | b499d4bcfc39 |
parent: | 5bde4fedc5c1 |
author: | Richard Westhaver <ellis@rwest.io> |
date: | Tue, 17 Sep 2024 22:19:19 -0400 |
permissions: | -rw-r--r-- |
description: | removed x.lisp |
104
6e5caf0c68a1
obj tree, id, hash, seq, graph.. added cli/progress and init cli/repl
ellis <ellis@rwest.io>
parents:
diff
changeset
|
1 | ;;; lib/obj/graph.lisp --- Graphs |
6e5caf0c68a1
obj tree, id, hash, seq, graph.. added cli/progress and init cli/repl
ellis <ellis@rwest.io>
parents:
diff
changeset
|
2 | |
456 | 3 | ;; Graph objects and algorithms |
4 | ||
5 | ;;; Commentary: |
|
6 | ||
7 | ;; Mostly modeled off of eschulte's GRAPH library - see also DAT/DOT |
|
8 | ||
9 | ;; ref: https://eschulte.github.io/graph/ |
|
10 | ||
11 | ;; Our goals are slightly different than the original library - we prioritize |
|
12 | ;; flexibility over speed or code size. To this end the base GRAPH class |
|
13 | ;; accepts NODE vectors in addition to hash-tables. We also make minimal |
|
14 | ;; assumptions about the underling node types - it is a blank class |
|
15 | ;; definition. Edges are a bit more complicated - they subclass ID which can be |
|
104
6e5caf0c68a1
obj tree, id, hash, seq, graph.. added cli/progress and init cli/repl
ellis <ellis@rwest.io>
parents:
diff
changeset
|
16 | |
6e5caf0c68a1
obj tree, id, hash, seq, graph.. added cli/progress and init cli/repl
ellis <ellis@rwest.io>
parents:
diff
changeset
|
17 | ;;; Code: |
6e5caf0c68a1
obj tree, id, hash, seq, graph.. added cli/progress and init cli/repl
ellis <ellis@rwest.io>
parents:
diff
changeset
|
18 | (in-package :obj/graph) |
6e5caf0c68a1
obj tree, id, hash, seq, graph.. added cli/progress and init cli/repl
ellis <ellis@rwest.io>
parents:
diff
changeset
|
19 | |
457 | 20 | (in-readtable :std) |
21 | ||
234
d7aa08025537
cry, obj/meta, ffi/magick
Richard Westhaver <ellis@rwest.io>
parents:
122
diff
changeset
|
22 | (defclass node () ()) |
d7aa08025537
cry, obj/meta, ffi/magick
Richard Westhaver <ellis@rwest.io>
parents:
122
diff
changeset
|
23 | |
104
6e5caf0c68a1
obj tree, id, hash, seq, graph.. added cli/progress and init cli/repl
ellis <ellis@rwest.io>
parents:
diff
changeset
|
24 | ;;; Vertex |
234
d7aa08025537
cry, obj/meta, ffi/magick
Richard Westhaver <ellis@rwest.io>
parents:
122
diff
changeset
|
25 | (defclass vertex (id node) |
104
6e5caf0c68a1
obj tree, id, hash, seq, graph.. added cli/progress and init cli/repl
ellis <ellis@rwest.io>
parents:
diff
changeset
|
26 | () |
6e5caf0c68a1
obj tree, id, hash, seq, graph.. added cli/progress and init cli/repl
ellis <ellis@rwest.io>
parents:
diff
changeset
|
27 | (:documentation "generic vertex mixin. The difference between this class and NODE is |
6e5caf0c68a1
obj tree, id, hash, seq, graph.. added cli/progress and init cli/repl
ellis <ellis@rwest.io>
parents:
diff
changeset
|
28 | that a vertex always carries an ID slot.")) |
6e5caf0c68a1
obj tree, id, hash, seq, graph.. added cli/progress and init cli/repl
ellis <ellis@rwest.io>
parents:
diff
changeset
|
29 | |
6e5caf0c68a1
obj tree, id, hash, seq, graph.. added cli/progress and init cli/repl
ellis <ellis@rwest.io>
parents:
diff
changeset
|
30 | ;;; Edge |
456 | 31 | (defclass edge (node) |
656 | 32 | ((in :initarg :in) (out :initarg :out)) |
104
6e5caf0c68a1
obj tree, id, hash, seq, graph.. added cli/progress and init cli/repl
ellis <ellis@rwest.io>
parents:
diff
changeset
|
33 | (:documentation "generic edge mixin. Compatible with the NODE and ID protocols.")) |
6e5caf0c68a1
obj tree, id, hash, seq, graph.. added cli/progress and init cli/repl
ellis <ellis@rwest.io>
parents:
diff
changeset
|
34 | |
456 | 35 | (defclass edgex (edge id) |
36 | () |
|
37 | (:documentation "Edge compatible with the NODE and ID protocols.")) |
|
38 | ||
105 | 39 | (defclass directed-edge (edge) |
456 | 40 | () |
234
d7aa08025537
cry, obj/meta, ffi/magick
Richard Westhaver <ellis@rwest.io>
parents:
122
diff
changeset
|
41 | (:documentation "An edge with an implicit direction from node A to B.")) |
104
6e5caf0c68a1
obj tree, id, hash, seq, graph.. added cli/progress and init cli/repl
ellis <ellis@rwest.io>
parents:
diff
changeset
|
42 | |
6e5caf0c68a1
obj tree, id, hash, seq, graph.. added cli/progress and init cli/repl
ellis <ellis@rwest.io>
parents:
diff
changeset
|
43 | (defclass weighted-edge (edge) |
6e5caf0c68a1
obj tree, id, hash, seq, graph.. added cli/progress and init cli/repl
ellis <ellis@rwest.io>
parents:
diff
changeset
|
44 | ((weight :initform 1d0 :initarg :weight :accessor weight-of))) |
6e5caf0c68a1
obj tree, id, hash, seq, graph.. added cli/progress and init cli/repl
ellis <ellis@rwest.io>
parents:
diff
changeset
|
45 | |
463
f2bb57563930
obj/graph and dat/dot test and fixes
Richard Westhaver <ellis@rwest.io>
parents:
462
diff
changeset
|
46 | ;;; Hashing |
456 | 47 | (defun copy-hash (hash &optional test comb) |
48 | "Return a copy of HASH. |
|
49 | Optional argument TEST specifies a new equality test to use for the |
|
50 | copy. Second optional argument COMB specifies a function to use to |
|
51 | combine the values of elements of HASH which collide in the copy due |
|
52 | to a new equality test specified with TEST." |
|
53 | (let ((comb (when comb (fdefinition comb))) |
|
54 | (copy (make-hash-table :test (or test (hash-table-test hash))))) |
|
55 | (maphash (lambda (k v) (setf (gethash k copy) |
|
56 | (if (and (gethash k copy) comb) |
|
57 | (funcall comb (gethash k copy) v) |
|
58 | v))) |
|
59 | hash) |
|
60 | copy)) |
|
61 | ||
62 | (defun node-hash-equal (hash1 hash2) |
|
63 | "Test node hashes HASH1 and HASH2 for equality." |
|
64 | (set-equal (hash-table-alist hash1) |
|
65 | (hash-table-alist hash2) |
|
66 | :test (lambda (a b) |
|
67 | (and (equalp (car a) (car b)) |
|
68 | (set-equal (cdr a) (cdr b) :test 'tree-equal))))) |
|
69 | ||
70 | (defun edge-hash-equal (hash1 hash2) |
|
71 | "Test edge hashes HASH1 and HASH2 for equality." |
|
72 | (set-equal (hash-table-alist hash1) |
|
73 | (hash-table-alist hash2) |
|
74 | :test 'equalp)) |
|
75 | ||
76 | (defun edge-equalp (edge1 edge2) |
|
463
f2bb57563930
obj/graph and dat/dot test and fixes
Richard Westhaver <ellis@rwest.io>
parents:
462
diff
changeset
|
77 | (set-equal edge1 edge2 :test 'equal)) |
456 | 78 | |
79 | (defun directed-edge-equalp (edge1 edge2) |
|
80 | (tree-equal edge1 edge2)) |
|
81 | ||
82 | (defun sxhash-edge (edge) |
|
83 | (sxhash (sort (copy-tree edge) |
|
463
f2bb57563930
obj/graph and dat/dot test and fixes
Richard Westhaver <ellis@rwest.io>
parents:
462
diff
changeset
|
84 | (cond |
f2bb57563930
obj/graph and dat/dot test and fixes
Richard Westhaver <ellis@rwest.io>
parents:
462
diff
changeset
|
85 | ((and (numberp (car edge)) (numberp (cdr edge))) |
f2bb57563930
obj/graph and dat/dot test and fixes
Richard Westhaver <ellis@rwest.io>
parents:
462
diff
changeset
|
86 | (lambda (a b) |
f2bb57563930
obj/graph and dat/dot test and fixes
Richard Westhaver <ellis@rwest.io>
parents:
462
diff
changeset
|
87 | (or (< (imagpart a) (imagpart b)) |
f2bb57563930
obj/graph and dat/dot test and fixes
Richard Westhaver <ellis@rwest.io>
parents:
462
diff
changeset
|
88 | (and (= (imagpart a) (imagpart b)) |
f2bb57563930
obj/graph and dat/dot test and fixes
Richard Westhaver <ellis@rwest.io>
parents:
462
diff
changeset
|
89 | (< (realpart a) (realpart b)))))) |
464 | 90 | ((or (numberp (car edge)) (numberp (second edge))) |
463
f2bb57563930
obj/graph and dat/dot test and fixes
Richard Westhaver <ellis@rwest.io>
parents:
462
diff
changeset
|
91 | (lambda (a b) (declare (ignore a b)) t)) |
f2bb57563930
obj/graph and dat/dot test and fixes
Richard Westhaver <ellis@rwest.io>
parents:
462
diff
changeset
|
92 | (t #'string<))))) |
456 | 93 | |
94 | (sb-ext:define-hash-table-test edge-equalp sxhash-edge) |
|
95 | ||
96 | (sb-ext:define-hash-table-test directed-edge-equalp sxhash) |
|
97 | ||
463
f2bb57563930
obj/graph and dat/dot test and fixes
Richard Westhaver <ellis@rwest.io>
parents:
462
diff
changeset
|
98 | ;;; Proto |
456 | 99 | (defgeneric nodes (graph)) |
100 | (defgeneric (setf nodes) (graph nodes)) |
|
101 | (defgeneric edges (graph)) |
|
102 | (defgeneric (setf edges) (graph edges)) |
|
103 | ||
104 | (defgeneric graph-equal (graph1 graph2)) |
|
105 | ||
106 | (defgeneric subgraph (graph nodes) |
|
107 | (:documentation "Return the subgraph of GRAPH restricted to NODES.")) |
|
108 | ||
109 | (defgeneric delete-node (graph node) |
|
110 | (:documentation "Delete NODE from GRAPH. |
|
111 | Delete and return the old edges of NODE in GRAPH.")) |
|
112 | ||
462
0a197b3b6995
random fixes, add sockopt-receive-timeout
Richard Westhaver <ellis@rwest.io>
parents:
457
diff
changeset
|
113 | (defgeneric has-node-p (graph node) |
0a197b3b6995
random fixes, add sockopt-receive-timeout
Richard Westhaver <ellis@rwest.io>
parents:
457
diff
changeset
|
114 | (:documentation "Return non-nil if GRAPH has node NODE.")) |
456 | 115 | (defgeneric has-edge-p (graph edge) |
116 | (:documentation "Return `true' if GRAPH has edge EDGE.")) |
|
117 | ||
463
f2bb57563930
obj/graph and dat/dot test and fixes
Richard Westhaver <ellis@rwest.io>
parents:
462
diff
changeset
|
118 | (defgeneric edge-weight (edge &key &allow-other-keys) |
f2bb57563930
obj/graph and dat/dot test and fixes
Richard Westhaver <ellis@rwest.io>
parents:
462
diff
changeset
|
119 | (:method ((edge t) &key &allow-other-keys) (values 1.0))) |
f2bb57563930
obj/graph and dat/dot test and fixes
Richard Westhaver <ellis@rwest.io>
parents:
462
diff
changeset
|
120 | |
f2bb57563930
obj/graph and dat/dot test and fixes
Richard Westhaver <ellis@rwest.io>
parents:
462
diff
changeset
|
121 | (defgeneric edge-value (graph edge) |
f2bb57563930
obj/graph and dat/dot test and fixes
Richard Westhaver <ellis@rwest.io>
parents:
462
diff
changeset
|
122 | (:method ((graph t) (edge t)) (values nil))) |
f2bb57563930
obj/graph and dat/dot test and fixes
Richard Westhaver <ellis@rwest.io>
parents:
462
diff
changeset
|
123 | |
f2bb57563930
obj/graph and dat/dot test and fixes
Richard Westhaver <ellis@rwest.io>
parents:
462
diff
changeset
|
124 | (defgeneric (setf edge-value) (new graph edge)) |
f2bb57563930
obj/graph and dat/dot test and fixes
Richard Westhaver <ellis@rwest.io>
parents:
462
diff
changeset
|
125 | |
f2bb57563930
obj/graph and dat/dot test and fixes
Richard Westhaver <ellis@rwest.io>
parents:
462
diff
changeset
|
126 | (defgeneric delete-edge (graph edge) |
f2bb57563930
obj/graph and dat/dot test and fixes
Richard Westhaver <ellis@rwest.io>
parents:
462
diff
changeset
|
127 | (:documentation "Delete EDGE from GRAPH. |
f2bb57563930
obj/graph and dat/dot test and fixes
Richard Westhaver <ellis@rwest.io>
parents:
462
diff
changeset
|
128 | Return the old value of EDGE.")) |
f2bb57563930
obj/graph and dat/dot test and fixes
Richard Westhaver <ellis@rwest.io>
parents:
462
diff
changeset
|
129 | |
f2bb57563930
obj/graph and dat/dot test and fixes
Richard Westhaver <ellis@rwest.io>
parents:
462
diff
changeset
|
130 | (defgeneric node-edges (graph node) |
f2bb57563930
obj/graph and dat/dot test and fixes
Richard Westhaver <ellis@rwest.io>
parents:
462
diff
changeset
|
131 | (:documentation "Return the edges of NODE in GRAPH.")) |
f2bb57563930
obj/graph and dat/dot test and fixes
Richard Westhaver <ellis@rwest.io>
parents:
462
diff
changeset
|
132 | |
f2bb57563930
obj/graph and dat/dot test and fixes
Richard Westhaver <ellis@rwest.io>
parents:
462
diff
changeset
|
133 | (defgeneric (setf node-edges) (new graph node) |
f2bb57563930
obj/graph and dat/dot test and fixes
Richard Westhaver <ellis@rwest.io>
parents:
462
diff
changeset
|
134 | (:documentation "Set the edges of NODE in GRAPH to NEW. |
f2bb57563930
obj/graph and dat/dot test and fixes
Richard Westhaver <ellis@rwest.io>
parents:
462
diff
changeset
|
135 | Delete and return the old edges of NODE in GRAPH.")) |
f2bb57563930
obj/graph and dat/dot test and fixes
Richard Westhaver <ellis@rwest.io>
parents:
462
diff
changeset
|
136 | |
f2bb57563930
obj/graph and dat/dot test and fixes
Richard Westhaver <ellis@rwest.io>
parents:
462
diff
changeset
|
137 | (defgeneric add-node (graph node)) |
f2bb57563930
obj/graph and dat/dot test and fixes
Richard Westhaver <ellis@rwest.io>
parents:
462
diff
changeset
|
138 | |
f2bb57563930
obj/graph and dat/dot test and fixes
Richard Westhaver <ellis@rwest.io>
parents:
462
diff
changeset
|
139 | (defgeneric add-edge (graph edge &optional value)) |
f2bb57563930
obj/graph and dat/dot test and fixes
Richard Westhaver <ellis@rwest.io>
parents:
462
diff
changeset
|
140 | |
f2bb57563930
obj/graph and dat/dot test and fixes
Richard Westhaver <ellis@rwest.io>
parents:
462
diff
changeset
|
141 | ;;; Graph |
234
d7aa08025537
cry, obj/meta, ffi/magick
Richard Westhaver <ellis@rwest.io>
parents:
122
diff
changeset
|
142 | (defclass graph (node) |
463
f2bb57563930
obj/graph and dat/dot test and fixes
Richard Westhaver <ellis@rwest.io>
parents:
462
diff
changeset
|
143 | ((nodes :initform (make-hash-table :test 'equal) |
456 | 144 | :type (or (vector node) hash-table) |
145 | :accessor nodes |
|
146 | :initarg :nodes) |
|
147 | (edges :initform (make-hash-table :test 'edge-equalp) |
|
148 | :type hash-table |
|
149 | :accessor edges |
|
150 | :initarg :edges)) |
|
151 | (:documentation "generic graph object.")) |
|
152 | ||
153 | (defmethod copy-graph ((graph graph)) |
|
154 | (make-instance (type-of graph) :nodes (copy-hash (nodes graph)) :edges (copy-hash (edges graph)))) |
|
155 | ||
156 | (defmethod subgraph ((graph graph) nodes) |
|
157 | (make-instance (type-of graph) :nodes nodes :edges (copy-hash (edges graph)))) |
|
158 | ||
159 | (defmethod has-edge-p ((graph graph) edge) |
|
160 | (multiple-value-bind (value included) (gethash edge (edges graph)) |
|
161 | (declare (ignorable value)) included)) |
|
162 | ||
462
0a197b3b6995
random fixes, add sockopt-receive-timeout
Richard Westhaver <ellis@rwest.io>
parents:
457
diff
changeset
|
163 | (defmethod has-node-p ((graph graph) node) |
0a197b3b6995
random fixes, add sockopt-receive-timeout
Richard Westhaver <ellis@rwest.io>
parents:
457
diff
changeset
|
164 | (multiple-value-bind (value included) (gethash node (nodes graph)) |
0a197b3b6995
random fixes, add sockopt-receive-timeout
Richard Westhaver <ellis@rwest.io>
parents:
457
diff
changeset
|
165 | (declare (ignorable value)) included)) |
463
f2bb57563930
obj/graph and dat/dot test and fixes
Richard Westhaver <ellis@rwest.io>
parents:
462
diff
changeset
|
166 | |
456 | 167 | (defmethod delete-node ((graph graph) node) |
168 | (prog1 (mapcar (lambda (edge) (cons edge (delete-edge graph edge))) |
|
169 | (node-edges graph node)) |
|
170 | (remhash node (nodes graph)))) |
|
171 | ||
172 | (defmethod delete-edge ((graph graph) edge) |
|
173 | (prog1 (edge-value graph edge) |
|
174 | (mapc (lambda (node) (setf (gethash node (nodes graph)) |
|
175 | (remove edge (gethash node (nodes graph)) |
|
176 | :test 'edge-equalp))) |
|
177 | edge) |
|
178 | (remhash edge (edges graph)))) |
|
179 | ||
180 | (defmethod node-edges ((graph graph) node) |
|
181 | (multiple-value-bind (edges included) (gethash node (nodes graph)) |
|
182 | (assert included (node graph) "~S doesn't include ~S" graph node) |
|
462
0a197b3b6995
random fixes, add sockopt-receive-timeout
Richard Westhaver <ellis@rwest.io>
parents:
457
diff
changeset
|
183 | edges)) |
456 | 184 | |
185 | (defmethod (setf node-edges) (new (graph graph) node) |
|
186 | (prog1 (mapc {delete-edge graph} (gethash node (nodes graph))) |
|
187 | (mapc {add-edge graph} new))) |
|
188 | ||
189 | (defmethod add-edge ((graph graph) edge &optional value) |
|
190 | (mapc (lambda (node) |
|
191 | (add-node graph node) |
|
192 | (pushnew (case (type-of graph) |
|
193 | (graph (remove-duplicates edge)) |
|
194 | (directed-graph edge)) |
|
195 | (gethash node (nodes graph)) |
|
196 | :test 'edge-equalp)) |
|
197 | edge) |
|
198 | (setf (gethash edge (edges graph)) value) |
|
199 | edge) |
|
200 | ||
201 | (defmethod edge-value ((graph graph) edge) |
|
202 | (multiple-value-bind (value included) (gethash edge (edges graph)) |
|
203 | (assert included (edge graph) "~S doesn't include ~S" graph edge) |
|
204 | value)) |
|
205 | ||
206 | (defmethod (setf edge-value) (new (graph graph) edge) |
|
207 | (setf (gethash edge (edges graph)) new)) |
|
208 | ||
209 | (defgeneric merge-nodes (graph node1 node2 &key new) |
|
210 | (:documentation "Combine NODE1 and NODE2 in GRAPH into the node NEW. |
|
211 | All edges of NODE1 and NODE2 in GRAPH will be combined into a new node |
|
212 | of value NEW. Edges between only NODE1 and NODE2 will be removed.")) |
|
213 | ||
214 | (defmethod merge-nodes ((graph graph) node1 node2 &key (new node1)) |
|
215 | ;; replace all removed edges with NEW instead of NODE1 or NODE2 |
|
216 | (mapcar |
|
217 | (lambda (l) |
|
218 | (destructuring-bind(edge . value) l |
|
219 | (let ((e (mapcar (lambda (n) (if (member n (list node1 node2)) new n)) edge))) |
|
220 | (if (has-edge-p graph e) |
|
221 | (when (and (edge-value graph e) value) |
|
222 | (setf (edge-value graph e) (+ (edge-value graph e) value))) |
|
223 | (add-edge graph e value))))) |
|
224 | ;; drop edges between only node1 and node2 |
|
225 | (remove-if-not [{set-difference _ (list node1 node2)} #'car] |
|
226 | ;; delete both nodes keeping their edges and values |
|
227 | (prog1 (append (delete-node graph node1) |
|
228 | (delete-node graph node2)) |
|
229 | ;; add the new node |
|
230 | (add-node graph new)))) |
|
231 | graph) |
|
232 | ||
233 | (defgeneric merge-edges (graph edge1 edge2 &key value) |
|
234 | (:documentation "Combine EDGE1 and EDGE2 in GRAPH into a new EDGE. |
|
235 | Optionally provide a value for the new edge, the values of EDGE1 and |
|
236 | EDGE2 will be combined.")) |
|
237 | ||
238 | (defmethod merge-edges ((graph graph) edge1 edge2 &key value) |
|
239 | (add-edge graph (remove-duplicates (append edge1 edge2)) |
|
240 | (or value |
|
241 | (when (and (edge-value graph edge1) (edge-value graph edge2)) |
|
242 | (+ (edge-value graph edge1) (edge-value graph edge2))))) |
|
243 | (append (delete-edge graph edge1) |
|
244 | (delete-edge graph edge2))) |
|
245 | ||
246 | (defgeneric degree (graph node) |
|
247 | (:documentation "Return the degree of NODE in GRAPH.")) |
|
248 | ||
249 | (defmethod degree ((graph graph) node) |
|
250 | (length (node-edges graph node))) |
|
251 | ||
462
0a197b3b6995
random fixes, add sockopt-receive-timeout
Richard Westhaver <ellis@rwest.io>
parents:
457
diff
changeset
|
252 | (defmethod add-node ((graph graph) node) |
463
f2bb57563930
obj/graph and dat/dot test and fixes
Richard Westhaver <ellis@rwest.io>
parents:
462
diff
changeset
|
253 | ;; NOTE: This is where our implementation breaks character from Eschulte's |
f2bb57563930
obj/graph and dat/dot test and fixes
Richard Westhaver <ellis@rwest.io>
parents:
462
diff
changeset
|
254 | ;; implementation. We currently accept strings in addition to numbers and symbols. |
f2bb57563930
obj/graph and dat/dot test and fixes
Richard Westhaver <ellis@rwest.io>
parents:
462
diff
changeset
|
255 | (assert (or (numberp node) (symbolp node) (stringp node)) (node) |
462
0a197b3b6995
random fixes, add sockopt-receive-timeout
Richard Westhaver <ellis@rwest.io>
parents:
457
diff
changeset
|
256 | "Nodes must be numbers, symbols or keywords, not ~S.~%Invalid node:~S" |
463
f2bb57563930
obj/graph and dat/dot test and fixes
Richard Westhaver <ellis@rwest.io>
parents:
462
diff
changeset
|
257 | (type-of node) node) |
462
0a197b3b6995
random fixes, add sockopt-receive-timeout
Richard Westhaver <ellis@rwest.io>
parents:
457
diff
changeset
|
258 | (unless (has-node-p graph node) |
0a197b3b6995
random fixes, add sockopt-receive-timeout
Richard Westhaver <ellis@rwest.io>
parents:
457
diff
changeset
|
259 | (setf (gethash node (nodes graph)) nil) |
0a197b3b6995
random fixes, add sockopt-receive-timeout
Richard Westhaver <ellis@rwest.io>
parents:
457
diff
changeset
|
260 | node)) |
0a197b3b6995
random fixes, add sockopt-receive-timeout
Richard Westhaver <ellis@rwest.io>
parents:
457
diff
changeset
|
261 | |
456 | 262 | ;;; Directed Graph |
263 | (defclass directed-graph (graph) |
|
264 | ((edges :initform (make-hash-table :test 'directed-edge-equalp) |
|
265 | :type (or (vector directed-edge) hash-table) |
|
266 | :accessor edges |
|
267 | :initarg :edges)) |
|
268 | (:documentation "graph with only directed edges.")) |
|
269 | ||
270 | (defgeneric indegree (digraph node) |
|
271 | (:documentation "The number of edges directed to NODE in GRAPH.")) |
|
272 | ||
273 | (defmethod indegree ((digraph directed-graph) node) |
|
274 | (length (remove-if-not [{member node} #'cdr] (node-edges digraph node)))) |
|
275 | ||
276 | (defgeneric outdegree (digraph node) |
|
277 | (:documentation "The number of edges directed from NODE in DIGRAPH.")) |
|
278 | ||
279 | (defmethod outdegree ((digraph directed-graph) node) |
|
280 | (length (remove-if-not [{equal node} #'car] (node-edges digraph node)))) |
|
281 | ||
282 | ;;; Shortest Path |
|
283 | (defgeneric shortest-path (graph a b &optional heuristic) |
|
284 | (:documentation "Return the shortest path in GRAPH from A to B. |
|
285 | Implemented using A* search. Optional argument HEURISTIC may be a |
|
286 | function which returns an estimated heuristic cost from an node to the |
|
287 | target B. The default value for HEURISTIC is the constant function of |
|
288 | 0, reducing this implementation to Dijkstra's algorithm. The |
|
289 | HEURISTIC function must satisfy HEURITIC(x)≤d(x,y)+HEURITIC(y) ∀ x,y |
|
290 | in GRAPH allowing the more efficient monotonic or \"consistent\" |
|
291 | implementation of A*.") |
|
292 | (:method ((graph graph) a b |
|
293 | &optional |
|
294 | (heuristic (constantly 0)) |
|
295 | &aux |
|
296 | (from (make-hash-table)) |
|
297 | (fringe (sb-concurrency:make-queue)) |
|
298 | (open (make-hash-table)) |
|
299 | (closed (make-hash-table)) |
|
300 | (g (make-hash-table)) |
|
301 | (f (make-hash-table))) |
|
302 | (when (equal a b) (return-from shortest-path nil)) |
|
303 | (labels ((reconstruct-path (current) |
|
304 | (destructuring-bind (node . edge) (gethash current from) |
|
305 | (cons edge (unless (member a edge) (reconstruct-path node)))))) |
|
306 | (setf (gethash a g) 0 |
|
307 | (gethash a f) (funcall heuristic a) |
|
308 | (gethash a open) t) |
|
309 | ||
310 | (sb-concurrency:enqueue fringe (gethash a f)) |
|
311 | ||
312 | (do ((current (sb-concurrency:dequeue fringe) (sb-concurrency:dequeue fringe))) |
|
313 | ((zerop (hash-table-count open)) |
|
314 | (multiple-value-bind (value present-p) (gethash b f) |
|
315 | (when present-p |
|
316 | (values (nreverse (reconstruct-path b)) value)))) |
|
317 | ||
318 | (when (eql current b) |
|
319 | (return-from shortest-path |
|
320 | (values (nreverse (reconstruct-path current)) |
|
321 | (gethash current f)))) |
|
322 | ||
323 | (remhash current open) |
|
324 | (setf (gethash current closed) t) |
|
325 | ||
326 | (mapc (lambda (edge) |
|
327 | (let ((weight (or (edge-value graph edge) 1))) |
|
328 | (mapc (lambda (next) |
|
329 | (unless (gethash next closed) |
|
330 | (setf (gethash next open) t) |
|
331 | (let ((tentative (+ (gethash current g) weight))) |
|
332 | (multiple-value-bind (value present-p) |
|
333 | (gethash next g) |
|
334 | (when (or (not present-p) |
|
335 | (< tentative value)) |
|
336 | (setf (gethash next from) (cons current edge) |
|
337 | (gethash next g) tentative |
|
338 | (gethash next f) |
|
339 | (+ tentative (funcall heuristic next))) |
|
340 | (sb-concurrency:enqueue fringe (gethash next f))))))) |
|
341 | (etypecase graph |
|
342 | (directed-graph (cdr (member current edge))) |
|
343 | (graph (remove current edge)))))) |
|
344 | (node-edges graph current)))))) |
|
345 | ||
346 | ;;; Min Cut |
|
347 | ;; |
|
348 | ;; Stoer, M. and Wagner, Frank. 1997. A Simple Min-Cut Algorithm. |
|
349 | ;; Journal of the ACM |
|
350 | ;; |
|
351 | ;; Theorem: Let s,t ∈ (nodes G), let G' be the result of merging s and |
|
352 | ;; t in G. Then (min-cut G) is equal to the minimum of the |
|
353 | ;; min cut of s and t in G and (min-cut G'). |
|
354 | ;; |
|
355 | (defun weigh-cut (graph cut) |
|
356 | (reduce #'+ (mapcar {edge-value graph} |
|
357 | (remove-if-not (lambda (edge) |
|
358 | (and (intersection edge (first cut)) |
|
359 | (intersection edge (second cut)))) |
|
360 | (edges graph))))) |
|
361 | ||
362 | (defgeneric min-cut (graph) |
|
363 | (:documentation |
|
364 | "Return both the global min-cut of GRAPH and the weight of the cut.")) |
|
365 | ||
366 | (defmethod min-cut ((graph graph)) |
|
367 | (let ((g (copy-graph graph)) |
|
368 | (merged-nodes (mapcar (lambda (n) (list n n)) (nodes graph))) |
|
369 | cuts-of-phase) |
|
370 | (flet ((connection-weight (group node) |
|
371 | ;; return the weight of edges between GROUP and NODE |
|
372 | (reduce #'+ (mapcar {edge-value g} |
|
373 | (remove-if-not {intersection group} |
|
374 | (node-edges g node))))) |
|
375 | (my-merge (a b) |
|
376 | ;; merge in the graph |
|
377 | (merge-nodes g a b) |
|
378 | ;; update our merged nodes alist |
|
379 | (setf (cdr (assoc a merged-nodes)) |
|
380 | (append (cdr (assoc a merged-nodes)) |
|
381 | (cdr (assoc b merged-nodes)))) |
|
382 | (setq merged-nodes |
|
383 | (remove-if (lambda (it) (eql (car it) b)) merged-nodes)))) |
|
384 | (loop :while (> (length (nodes g)) 1) :do |
|
385 | (let* ((a (list (random (nodes g)))) |
|
386 | (rest (remove (car a) (nodes g)))) |
|
387 | (loop :while rest :do |
|
388 | ;; grow A by adding the node most tightly connected to A |
|
389 | (let ((new (car (sort rest #'> :key {connection-weight a})))) |
|
390 | (setf rest (remove new rest)) |
|
391 | (push new a))) |
|
392 | ;; store the cut-of-phase |
|
393 | (push (cons (connection-weight (cdr a) (car a)) |
|
394 | (cdr (assoc (car a) merged-nodes))) |
|
395 | cuts-of-phase) |
|
396 | ;; merge two last added nodes |
|
397 | (my-merge (first a) (second a)))) |
|
398 | ;; return the minimum cut-of-phase |
|
399 | (let* ((half (cdar (sort cuts-of-phase #'< :key #'car))) |
|
400 | (cut (list half (set-difference (nodes graph) half)))) |
|
401 | (values (sort cut #'< :key #'length) (weigh-cut graph cut)))))) |
|
402 | ||
403 | ;; https://en.wikipedia.org/wiki/Degeneracy_(graph_theory) |