1 (in-package #:metabang.graph)
3 ;;; ---------------------------------------------------------------------------
5 ;;; ---------------------------------------------------------------------------
7 (defstruct (vertex-datum (:conc-name node-) (:type list))
9 (depth most-positive-fixnum)
12 ;;; ---------------------------------------------------------------------------
14 (defmethod initialize-vertex-data ((graph basic-graph))
15 (let ((vertex-data (make-container 'simple-associative-container)))
16 (iterate-vertexes graph (lambda (v)
17 (setf (item-at vertex-data v)
18 (make-vertex-datum :color :white))))
19 (values vertex-data)))
21 ;;; ---------------------------------------------------------------------------
22 ;;; breadth-first-search by GWK
23 ;;; ---------------------------------------------------------------------------
25 (defmethod breadth-first-visitor ((graph basic-graph) (source t) fn)
26 (breadth-first-visitor graph (find-vertex graph source) fn))
28 ;;; ---------------------------------------------------------------------------
30 (defmethod breadth-first-visitor ((graph basic-graph) (source basic-vertex) fn)
32 (let ((vertex-data (initialize-vertex-data graph))
33 (queue (make-container 'basic-queue)))
35 (let ((source-datum (item-at vertex-data source)))
36 (setf (node-color source-datum) :grey
37 (node-depth source-datum) 0)
38 (enqueue queue source)
40 (loop until (empty-p queue) do
41 (let* ((current-vertex (first-item queue))
42 (current (item-at vertex-data current-vertex)))
43 ;(format t "~%~A:" current-vertex)
44 (iterate-children current-vertex
45 (lambda (child-vertex)
46 ;(format t "~A " child-vertex)
47 (let ((child (item-at vertex-data child-vertex)))
48 (when (eq (node-color child) :white)
49 (setf (node-color child) :grey
50 (node-depth child) (1+ (node-depth current))
51 (node-parent child) current-vertex)
52 (enqueue queue child-vertex)))))
55 (setf (node-color current) :black)
56 (funcall fn current-vertex)))
60 ;;; ---------------------------------------------------------------------------
62 (defmethod breadth-first-search-graph ((graph basic-graph) (source t))
63 (breadth-first-search-graph graph (find-vertex graph source)))
65 ;;; ---------------------------------------------------------------------------
67 (defmethod breadth-first-search-graph ((graph basic-graph) (source basic-vertex))
69 (let ((vertex-data (initialize-vertex-data graph))
70 (queue (make-container 'basic-queue)))
72 (let ((source-datum (item-at vertex-data source)))
73 (setf (node-color source-datum) :grey
74 (node-depth source-datum) 0)
75 (enqueue queue source)
77 (loop until (empty-p queue) do
78 (let* ((current-vertex (first-item queue))
79 (current (item-at vertex-data current-vertex)))
80 ;(format t "~%~A:" current-vertex)
81 (iterate-children current-vertex
82 (lambda (child-vertex)
83 ;(format t "~A " child-vertex)
84 (let ((child (item-at vertex-data child-vertex)))
85 (when (eq (node-color child) :white)
86 (setf (node-color child) :grey
87 (node-depth child) (1+ (node-depth current))
88 (node-parent child) current-vertex)
89 (enqueue queue child-vertex)))))
92 (setf (node-color current) :black)))
96 ;;; ---------------------------------------------------------------------------
97 ;;; single-source-shortest-paths - gwk
98 ;;; ---------------------------------------------------------------------------
101 (defmethod single-source-shortest-paths ((graph basic-graph))
102 (let ((vertex-data (initialize-vertex-data graph))
103 (queue (make-container 'priority-queue-on-container 'binary-search-tree)))
104 (let ((source-datum (item-at vertex-data source)))
105 (setf (node-depth source-datum) 0))
108 ;;; ---------------------------------------------------------------------------
109 ;;; connected-components - gwk
110 ;;; ---------------------------------------------------------------------------
112 (defmethod connected-components ((graph basic-graph))
113 (let ((union (make-container 'union-find-container)))
116 (lambda (v) (insert-item union v)))
120 (let ((node-1 (representative-node union (vertex-1 e)))
121 (node-2 (representative-node union (vertex-2 e))))
122 (unless (eq (find-set node-1) (find-set node-2))
123 (graft-nodes node-1 node-2)))))
124 (iterate-elements union 'find-set)
127 ;;; ---------------------------------------------------------------------------
129 (defmethod connected-component-count ((graph basic-graph))
130 ;;?? Gary King 2005-11-28: Super ugh
134 (connected-components graph)
135 :transform #'parent)))
138 ;;?? Gary King 2005-11-28: fails on big graphs? iterator design
139 ;;?? Gary King 2005-11-28: ideally we don't want to cons up the list at all
142 (make-iterator (connected-components graph) :unique t :transform #'parent))))
144 (defmethod find-connected-components ((graph basic-graph))
146 (make-iterator (connected-components graph) :unique t :transform #'parent)
149 (subgraph-containing graph (element component)
150 :depth most-positive-fixnum))))
153 (defmethod find-connected-components ((graph basic-graph))
155 (found-elements (make-container 'simple-associative-container)))
157 (connected-components graph)
159 (let ((element (element (parent component))))
160 (unless (item-at found-elements element)
161 (setf (item-at found-elements element) t)
163 (push (subgraph-containing graph (element component)
164 most-positive-fixnum)
171 ;;; ---------------------------------------------------------------------------
172 ;;; minimum-spanning-tree based on kruskal's algorithm detailed in clrs2 -jjm
173 ;;; ---------------------------------------------------------------------------
175 (defmethod mst-find-set ((vertex basic-vertex))
177 (unless (previous-node vertex)
178 (return-from mst-find-set nil))
179 (unless (eq vertex (previous-node vertex))
180 (setf (previous-node vertex) (mst-find-set (previous-node vertex))))
181 (previous-node vertex))
183 ;;; ---------------------------------------------------------------------------
185 (defmethod mst-make-set ((vertex basic-vertex))
186 (setf (previous-node vertex) vertex
189 ;;; ---------------------------------------------------------------------------
191 (defmethod mst-tree-union ((v1 basic-vertex) (v2 basic-vertex))
192 (mst-link (mst-find-set v1) (mst-find-set v2)))
194 ;;; ---------------------------------------------------------------------------
196 (defmethod mst-link ((v1 basic-vertex) (v2 basic-vertex))
197 (cond ((> (rank v1) (rank v2))
198 (setf (previous-node v2) v1))
199 (t (setf (previous-node v1) v2)
200 (when (= (rank v1) (rank v2))
203 ;;; ---------------------------------------------------------------------------
204 ;;; jjm's implementation of mst depends on this
205 ;;; todo - figure out some what to add and edge we create to a graph rather
206 ;;; than always using add-edge-between-vertexes interface
207 ;;; ---------------------------------------------------------------------------
209 (defmethod add-edges-to-graph ((graph basic-graph) (edges list)
210 &key (if-duplicate-do :ignore))
214 (bind ((v1 (element (source-vertex edge)))
215 (v2 (element (target-vertex edge))))
216 (add-edge-between-vertexes
217 graph v1 v2 :edge-class (type-of edge)
218 :edge-type (if (directed-edge-p edge)
222 :edge-id (edge-id edge)
223 :element (element edge)
227 :if-duplicate-do if-duplicate-do))))
230 ;;; ---------------------------------------------------------------------------
232 ;;; ---------------------------------------------------------------------------
234 (defmethod make-graph-from-vertexes ((vertex-list list))
235 (bind ((edges-to-keep nil)
236 (g (copy-template (graph (first vertex-list)))))
241 (add-vertex g (element v))
245 (when (and (member (vertex-1 e) vertex-list)
246 (member (vertex-2 e) vertex-list))
247 (pushnew e edges-to-keep :test #'eq))))))
252 (bind ((v1 (source-vertex e))
253 (v2 (target-vertex e)))
254 ;;?? can we use copy here...
255 (add-edge-between-vertexes
256 g (element v1) (element v2)
257 :edge-type (if (directed-edge-p e)
260 :if-duplicate-do :force
261 :edge-class (type-of e)
270 ;;; ---------------------------------------------------------------------------
272 (defmethod edge-lessp-by-weight ((e1 basic-edge) (e2 basic-edge))
273 (< (weight e1) (weight e2)))
275 ;;; ---------------------------------------------------------------------------
276 ;;; minumum spanning tree
277 ;;; ---------------------------------------------------------------------------
280 (defmethod minimum-spanning-tree ((graph basic-graph)
282 (edge-sorter #'edge-lessp-by-weight))
289 (loop for edge in (sort (edges graph) edge-sorter) do
290 (bind ((v1 (source-vertex edge))
291 (v2 (target-vertex edge)))
293 (unless (eq (mst-find-set v1)
296 (mst-tree-union v1 v2)))
299 (cond ((= (length result) (- (length (vertexes graph)) 1))
301 (t (values nil result)))))))
303 ;;; ---------------------------------------------------------------------------
306 (defmethod minimum-spanning-tree ((vertex-list list)
308 (edge-sorter #'edge-lessp-by-weight))
310 (v-edges (remove-duplicates
311 (flatten (mapcar #'edges vertex-list)) :test #'eq)))
320 (loop for edge in (sort v-edges edge-sorter) do
321 (bind ((v1 (source-vertex edge))
322 (v2 (target-vertex edge))
323 (v1-set (mst-find-set v1))
324 (v2-set (mst-find-set v2)))
326 (when (or (not v1-set)
328 (return-from minimum-spanning-tree nil))
331 (unless (eq (mst-find-set v1)
334 (mst-tree-union v1 v2)))
337 (cond ((= (length result) (- (length vertex-list) 1))
339 (t (values nil result)))))))
341 ;;; ---------------------------------------------------------------------------
342 ;;; uses mst to determine if the graph is connected
343 ;;; ---------------------------------------------------------------------------
345 (defmethod connected-graph-p ((graph basic-graph) &key
346 (edge-sorter 'edge-lessp-by-weight))
347 (minimum-spanning-tree graph :edge-sorter edge-sorter))
350 ;;; ---------------------------------------------------------------------------
353 (bind ((g (make-container 'graph-container)))
354 (add-edge-between-vertexes g :v :y :edge-type :directed)
355 (add-edge-between-vertexes g :u :x :edge-type :directed)
356 (add-edge-between-vertexes g :x :v :edge-type :directed)
357 (add-edge-between-vertexes g :u :v :edge-type :directed)
358 (add-edge-between-vertexes g :y :x :edge-type :directed)
359 (add-edge-between-vertexes g :w :y :edge-type :directed)
360 (add-edge-between-vertexes g :w :z :edge-type :directed)
361 (add-edge-between-vertexes g :z :z :edge-type :directed
362 :if-duplicate-do :force)
363 (minimum-spanning-tree g))
365 ;;; ---------------------------------------------------------------------------
366 ;;; GWK's implementation of kruskal's - slightly faster, but it doesn't return
367 ;;; a tree (still faster even if it does). Will decide later if which to use
368 ;;; ignoring for now -jjm
369 ;;; ---------------------------------------------------------------------------
372 (defmethod minimum-spanning-tree ((graph basic-graph) &key (weight 'weight))
374 (union (make-container 'union-find-container))
375 (edges (sort (edges graph) #'< :key weight)))
377 graph (lambda (v) (insert-item union v)))
379 (let ((node-1 (representative-node union (vertex-1 edge)))
380 (node-2 (representative-node union (vertex-2 edge))))
381 (unless (eq (find-set node-1) (find-set node-2))
382 (graft-nodes node-1 node-2)
387 ;;; ---------------------------------------------------------------------------
390 (loop for f in '(mst-kruskal minimum-spanning-tree-kruskal) do
391 (fluid-bind (((random-seed *random-generator*) 1))
392 (bind ((g (generate-undirected-graph-via-vertex-probabilities
393 *random-generator* (make-instance 'graph-container :default-edge-type :directed)
396 #2A((0.2 0.1) (nil 0.2))
398 (form-keyword "H" (format nil "~2,'0D~4,'0D" kind count))))
400 (timeit (:report :values)
401 (loop for n from 1 to 100 do
402 (funcall f g (lambda (a b)
403 (declare (ignore a b))
406 ;;; ---------------------------------------------------------------------------
407 ;;; end minimum spanning tree
408 ;;; ---------------------------------------------------------------------------
411 ;;; ---------------------------------------------------------------------------
412 ;;; depth-first-search - clrs2
413 ;;; todo - figure out how to name this depth-first-search, which is already
414 ;;; defined in search.lisp
415 ;;; ---------------------------------------------------------------------------
417 ;;; ---------------------------------------------------------------------------
418 ;;; should probably make this special
419 ;;; ---------------------------------------------------------------------------
421 (defparameter *depth-first-search-timer* -1)
423 ;;; ---------------------------------------------------------------------------
424 ;;; undirected edges are less than edges that are directed
425 ;;; ---------------------------------------------------------------------------
427 #+ignore ;;; incorrect, methinks - jjm
428 (defmethod edge-lessp-by-direction ((e1 basic-edge) (e2 basic-edge))
429 (cond ((or (every #'directed-edge-p (list e1 e2))
430 (every #'undirected-edge-p (list e1 e2)))
432 ((and (undirected-edge-p e1) (directed-edge-p e2))
436 (defmethod edge-lessp-by-direction ((e1 basic-edge) (e2 basic-edge))
437 (and (undirected-edge-p e1) (directed-edge-p e2)))
439 ;;; ---------------------------------------------------------------------------
441 (defmethod out-edge-for-vertex-p ((edge basic-edge) (vertex basic-vertex))
442 (cond ((and (directed-edge-p edge)
443 (eq vertex (source-vertex edge)))
445 ((and (undirected-edge-p edge)
446 (or (eq vertex (source-vertex edge))
447 (eq vertex (target-vertex edge))))
451 ;;; ---------------------------------------------------------------------------
452 ;;; depth-first-search
453 ;;; ---------------------------------------------------------------------------
455 (defmethod dfs ((graph basic-graph) (root t) fn &key
456 (out-edge-sorter #'edge-lessp-by-direction))
457 (dfs graph (find-vertex graph root) fn :out-edge-sorter out-edge-sorter))
459 ;;; ---------------------------------------------------------------------------
461 (defmethod dfs ((graph basic-graph) (root basic-vertex) fn &key
462 (out-edge-sorter #'edge-lessp-by-direction))
463 (setf *depth-first-search-timer* -1)
468 (setf (color v) :white
469 (previous-node v) nil
470 (discovery-time v) -1
471 (finish-time v) -1)))
476 (setf (color e) nil)))
478 (loop with vl = (remove root (vertexes graph) :test #'eql)
479 for v in (push root vl) do
480 (when (eql (color v) :white)
481 (dfs-visit graph v fn out-edge-sorter)))
484 (sort (copy-list (vertexes graph)) #'< :key #'finish-time)
487 ;;; ---------------------------------------------------------------------------
489 (defmethod dfs-visit ((graph graph-container) (u basic-vertex)
493 (incf *depth-first-search-timer*)
494 (setf (color u) :gray
495 (discovery-time u) *depth-first-search-timer*)
498 (loop for edge in (sort (collect-elements
501 (out-edge-for-vertex-p e u))) sorter) do
502 (bind ((v (other-vertex edge u)))
505 (setf (color edge) (color v)))
507 (when (eql (color v) :white)
508 (setf (previous-node v) u)
510 (dfs-visit graph v fn sorter))))
512 (incf *depth-first-search-timer*)
514 (setf (color u) :black
515 (finish-time u) *depth-first-search-timer*))
517 ;;; ---------------------------------------------------------------------------
519 ;;; ---------------------------------------------------------------------------
522 (bind ((g (make-container 'graph-container)))
523 (add-edge-between-vertexes g :v :y :edge-type :directed)
524 (add-edge-between-vertexes g :u :x :edge-type :directed)
525 (add-edge-between-vertexes g :x :v :edge-type :directed)
526 (add-edge-between-vertexes g :u :v :edge-type :directed)
527 (add-edge-between-vertexes g :y :x :edge-type :directed)
528 (add-edge-between-vertexes g :w :y :edge-type :directed)
529 (add-edge-between-vertexes g :w :z :edge-type :directed)
530 (add-edge-between-vertexes g :z :z :edge-type :directed
531 :if-duplicate-do :force)
532 (assert (equal '(:X :Y :V :U :Z :W)
533 (mapcar #'element (dfs g :u #'identity)))))
535 ;;; ---------------------------------------------------------------------------
537 (defmethod dfs-tree-edge-p ((edge graph-container-edge))
538 (eql (color edge) :white))
540 ;;; ---------------------------------------------------------------------------
542 (defmethod dfs-back-edge-p ((edge graph-container-edge))
543 (eql (color edge) :gray))
545 ;;; ---------------------------------------------------------------------------
546 ;;; not correct - has to look at combination of discovery-time and finish-time
547 ;;; ---------------------------------------------------------------------------
549 (defmethod dfs-forward-edge-p ((edge graph-container-edge))
550 (warn "implementation is not correct.")
551 (unless (and (dfs-tree-edge-p edge)
552 (dfs-back-edge-p edge))
553 (< (discovery-time (source-vertex edge))
554 (discovery-time (target-vertex edge)))))
556 ;;; ---------------------------------------------------------------------------
557 ;;; not correct - has to look at combination of discovery-time and finish-time
558 ;;; ---------------------------------------------------------------------------
560 (defmethod dfs-cross-edge-p ((edge graph-container-edge))
561 (warn "implementation is not correct.")
562 (unless (and (dfs-tree-edge-p edge)
563 (dfs-back-edge-p edge))
564 (> (discovery-time (source-vertex edge))
565 (discovery-time (target-vertex edge)))))
567 ;;; ---------------------------------------------------------------------------
569 (defmethod dfs-edge-type ((edge graph-container-edge))
570 (cond ((dfs-tree-edge-p edge)
572 ((dfs-back-edge-p edge)
574 ((dfs-forward-edge-p edge)
576 ((dfs-cross-edge-p edge)
580 ;;; ---------------------------------------------------------------------------
582 ;;; ---------------------------------------------------------------------------
584 ;;; ---------------------------------------------------------------------------
585 ;;; mapping functions
586 ;;; ---------------------------------------------------------------------------
588 ;;; ---------------------------------------------------------------------------
590 ;;; ---------------------------------------------------------------------------
592 (defmethod map-over-all-combinations-of-k-vertexes ((graph basic-graph) k fn)
593 (bind ((vertex-count (size graph))
594 (symbols (make-list k :initial-element vertex-count))
595 (vertexes (vertexes graph)))
596 (iterate-over-indexes
598 (lambda (vertex-indexes)
599 (when (apply #'< vertex-indexes)
600 (funcall fn (mapcar (lambda (vertex-index)
601 (nth-element vertexes vertex-index))
602 vertex-indexes)))))))
604 ;;; ---------------------------------------------------------------------------
608 (g (make-container 'graph-container)))
609 (add-edge-between-vertexes g :u :v :edge-type :directed)
610 (add-edge-between-vertexes g :u :x :edge-type :directed)
611 (add-edge-between-vertexes g :x :v :edge-type :directed)
612 (add-edge-between-vertexes g :v :y :edge-type :directed)
613 (add-edge-between-vertexes g :y :x :edge-type :directed)
614 (add-edge-between-vertexes g :w :y :edge-type :directed)
615 (add-edge-between-vertexes g :w :z :edge-type :directed)
617 (map-over-all-combinations-of-k-vertexes
620 (lambda (vertex-list)
621 (bind ((graph-from-vertexes (make-graph-from-vertexes vertex-list)))
622 (when (mst-kruskal graph-from-vertexes #'identity-sorter)
623 (push graph-from-vertexes result)))))
626 ;;; ---------------------------------------------------------------------------
628 ;;; todo: merge these two defs
629 ;;; ---------------------------------------------------------------------------
631 (defmethod map-over-all-combinations-of-k-edges ((graph basic-graph) k fn)
632 (bind ((edge-count (edge-count graph))
633 (symbols (make-list k :initial-element edge-count))
634 (edges (edges graph)))
636 (iterate-over-indexes
638 (lambda (edge-indexes)
639 (when (apply #'< edge-indexes)
640 (funcall fn (mapcar (lambda (edge-index)
641 (nth-element edges edge-index))
644 ;;; ---------------------------------------------------------------------------
646 (defmethod map-over-all-combinations-of-k-edges ((vertex basic-vertex) k fn)
647 (bind ((edge-count (edge-count vertex))
648 (symbols (make-list k :initial-element edge-count))
649 (edges (edges vertex)))
651 (iterate-over-indexes
653 (lambda (edge-indexes)
654 (when (apply #'< edge-indexes)
655 (funcall fn (mapcar (lambda (edge-index)
656 (nth-element edges edge-index))
658 ;;; ---------------------------------------------------------------------------
661 (map-over-all-combinations-of-k-edges
662 (generate-undirected-graph-via-verex-probabilities
663 *random-generator* 'graph-container
666 #2A((0.2 0.1) (nil 0.2))
668 (form-keyword "H" (format nil "~2,'0D~4,'0D" kind count))))
673 (format t "~A -- ~A " (element (vertex-1 e)) (element (vertex-2 e))))
680 ;;; ***************************************************************************
682 ;;; ***************************************************************************