Mercurial > core / lisp/lib/obj/graph/pkg.lisp
changeset 698: |
96958d3eb5b0 |
parent: |
b499d4bcfc39
|
author: |
Richard Westhaver <ellis@rwest.io> |
date: |
Fri, 04 Oct 2024 22:04:59 -0400 |
permissions: |
-rw-r--r-- |
description: |
fixes |
1 ;;; lib/obj/graph.lisp --- Graphs 3 ;; Graph objects and algorithms 7 ;; Mostly modeled off of eschulte's GRAPH library - see also DAT/DOT 9 ;; ref: https://eschulte.github.io/graph/ 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 18 (in-package :obj/graph) 25 (defclass vertex (id node) 27 (:documentation "generic vertex mixin. The difference between this class and NODE is 28 that a vertex always carries an ID slot.")) 32 ((in :initarg :in) (out :initarg :out)) 33 (:documentation "generic edge mixin. Compatible with the NODE and ID protocols.")) 35 (defclass edgex (edge id) 37 (:documentation "Edge compatible with the NODE and ID protocols.")) 39 (defclass directed-edge (edge) 41 (:documentation "An edge with an implicit direction from node A to B.")) 43 (defclass weighted-edge (edge) 44 ((weight :initform 1d0 :initarg :weight :accessor weight-of))) 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) 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) 67 (and (equalp (car a) (car b)) 68 (set-equal (cdr a) (cdr b) :test 'tree-equal))))) 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) 76 (defun edge-equalp (edge1 edge2) 77 (set-equal edge1 edge2 :test 'equal)) 79 (defun directed-edge-equalp (edge1 edge2) 80 (tree-equal edge1 edge2)) 82 (defun sxhash-edge (edge) 83 (sxhash (sort (copy-tree edge) 85 ((and (numberp (car edge)) (numberp (cdr edge))) 87 (or (< (imagpart a) (imagpart b)) 88 (and (= (imagpart a) (imagpart b)) 89 (< (realpart a) (realpart b)))))) 90 ((or (numberp (car edge)) (numberp (second edge))) 91 (lambda (a b) (declare (ignore a b)) t)) 94 (sb-ext:define-hash-table-test edge-equalp sxhash-edge) 96 (sb-ext:define-hash-table-test directed-edge-equalp sxhash) 99 (defgeneric nodes (graph)) 100 (defgeneric (setf nodes) (graph nodes)) 101 (defgeneric edges (graph)) 102 (defgeneric (setf edges) (graph edges)) 104 (defgeneric graph-equal (graph1 graph2)) 106 (defgeneric subgraph (graph nodes) 107 (:documentation "Return the subgraph of GRAPH restricted to NODES.")) 109 (defgeneric delete-node (graph node) 110 (:documentation "Delete NODE from GRAPH. 111 Delete and return the old edges of NODE in GRAPH.")) 113 (defgeneric has-node-p (graph node) 114 (:documentation "Return non-nil if GRAPH has node NODE.")) 115 (defgeneric has-edge-p (graph edge) 116 (:documentation "Return `true' if GRAPH has edge EDGE.")) 118 (defgeneric edge-weight (edge &key &allow-other-keys) 119 (:method ((edge t) &key &allow-other-keys) (values 1.0))) 121 (defgeneric edge-value (graph edge) 122 (:method ((graph t) (edge t)) (values nil))) 124 (defgeneric (setf edge-value) (new graph edge)) 126 (defgeneric delete-edge (graph edge) 127 (:documentation "Delete EDGE from GRAPH. 128 Return the old value of EDGE.")) 130 (defgeneric node-edges (graph node) 131 (:documentation "Return the edges of NODE in GRAPH.")) 133 (defgeneric (setf node-edges) (new graph node) 134 (:documentation "Set the edges of NODE in GRAPH to NEW. 135 Delete and return the old edges of NODE in GRAPH.")) 137 (defgeneric add-node (graph node)) 139 (defgeneric add-edge (graph edge &optional value)) 142 (defclass graph (node) 143 ((nodes :initform (make-hash-table :test 'equal) 144 :type (or (vector node) hash-table) 147 (edges :initform (make-hash-table :test 'edge-equalp) 151 (:documentation "generic graph object.")) 153 (defmethod copy-graph ((graph graph)) 154 (make-instance (type-of graph) :nodes (copy-hash (nodes graph)) :edges (copy-hash (edges graph)))) 156 (defmethod subgraph ((graph graph) nodes) 157 (make-instance (type-of graph) :nodes nodes :edges (copy-hash (edges graph)))) 159 (defmethod has-edge-p ((graph graph) edge) 160 (multiple-value-bind (value included) (gethash edge (edges graph)) 161 (declare (ignorable value)) included)) 163 (defmethod has-node-p ((graph graph) node) 164 (multiple-value-bind (value included) (gethash node (nodes graph)) 165 (declare (ignorable value)) included)) 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)))) 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))) 178 (remhash edge (edges graph)))) 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) 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))) 189 (defmethod add-edge ((graph graph) edge &optional value) 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)) 198 (setf (gethash edge (edges graph)) value) 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) 206 (defmethod (setf edge-value) (new (graph graph) edge) 207 (setf (gethash edge (edges graph)) new)) 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.")) 214 (defmethod merge-nodes ((graph graph) node1 node2 &key (new node1)) 215 ;; replace all removed edges with NEW instead of NODE1 or NODE2 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)) 230 (add-node graph new)))) 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.")) 238 (defmethod merge-edges ((graph graph) edge1 edge2 &key value) 239 (add-edge graph (remove-duplicates (append edge1 edge2)) 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))) 246 (defgeneric degree (graph node) 247 (:documentation "Return the degree of NODE in GRAPH.")) 249 (defmethod degree ((graph graph) node) 250 (length (node-edges graph node))) 252 (defmethod add-node ((graph graph) node) 253 ;; NOTE: This is where our implementation breaks character from Eschulte's 254 ;; implementation. We currently accept strings in addition to numbers and symbols. 255 (assert (or (numberp node) (symbolp node) (stringp node)) (node) 256 "Nodes must be numbers, symbols or keywords, not ~S.~%Invalid node:~S" 258 (unless (has-node-p graph node) 259 (setf (gethash node (nodes graph)) nil) 263 (defclass directed-graph (graph) 264 ((edges :initform (make-hash-table :test 'directed-edge-equalp) 265 :type (or (vector directed-edge) hash-table) 268 (:documentation "graph with only directed edges.")) 270 (defgeneric indegree (digraph node) 271 (:documentation "The number of edges directed to NODE in GRAPH.")) 273 (defmethod indegree ((digraph directed-graph) node) 274 (length (remove-if-not [{member node} #'cdr] (node-edges digraph node)))) 276 (defgeneric outdegree (digraph node) 277 (:documentation "The number of edges directed from NODE in DIGRAPH.")) 279 (defmethod outdegree ((digraph directed-graph) node) 280 (length (remove-if-not [{equal node} #'car] (node-edges digraph node)))) 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 294 (heuristic (constantly 0)) 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) 310 (sb-concurrency:enqueue fringe (gethash a f)) 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) 316 (values (nreverse (reconstruct-path b)) value)))) 318 (when (eql current b) 319 (return-from shortest-path 320 (values (nreverse (reconstruct-path current)) 321 (gethash current f)))) 323 (remhash current open) 324 (setf (gethash current closed) t) 327 (let ((weight (or (edge-value graph edge) 1))) 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) 334 (when (or (not present-p) 336 (setf (gethash next from) (cons current edge) 337 (gethash next g) tentative 339 (+ tentative (funcall heuristic next))) 340 (sb-concurrency:enqueue fringe (gethash next f))))))) 342 (directed-graph (cdr (member current edge))) 343 (graph (remove current edge)))))) 344 (node-edges graph current)))))) 348 ;; Stoer, M. and Wagner, Frank. 1997. A Simple Min-Cut Algorithm. 349 ;; Journal of the ACM 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'). 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)))) 362 (defgeneric min-cut (graph) 364 "Return both the global min-cut of GRAPH and the weight of the cut.")) 366 (defmethod min-cut ((graph graph)) 367 (let ((g (copy-graph graph)) 368 (merged-nodes (mapcar (lambda (n) (list n n)) (nodes graph))) 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))))) 376 ;; merge in the graph 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)))) 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)) 392 ;; store the cut-of-phase 393 (push (cons (connection-weight (cdr a) (car a)) 394 (cdr (assoc (car a) merged-nodes))) 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)))))) 403 ;; https://en.wikipedia.org/wiki/Degeneracy_(graph_theory)