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 ;;; ---------------------------------------------------------------------------
146 (defmethod find-connected-components ((graph basic-graph))
148 (make-iterator (connected-components graph) :unique t :transform #'parent)
151 (subgraph-containing graph (element component)
152 most-positive-fixnum))))
155 (defmethod find-connected-components ((graph basic-graph))
157 (found-elements (make-container 'simple-associative-container)))
159 (connected-components graph)
161 (let ((element (element (parent component))))
162 (unless (item-at found-elements element)
163 (setf (item-at found-elements element) t)
165 (push (subgraph-containing graph (element component)
166 most-positive-fixnum)
173 ;;; ---------------------------------------------------------------------------
174 ;;; minimum-spanning-tree based on kruskal's algorithm detailed in clrs2 -jjm
175 ;;; ---------------------------------------------------------------------------
177 (defmethod mst-find-set ((vertex basic-vertex))
179 (unless (previous-node vertex)
180 (return-from mst-find-set nil))
181 (unless (eq vertex (previous-node vertex))
182 (setf (previous-node vertex) (mst-find-set (previous-node vertex))))
183 (previous-node vertex))
185 ;;; ---------------------------------------------------------------------------
187 (defmethod mst-make-set ((vertex basic-vertex))
188 (setf (previous-node vertex) vertex
191 ;;; ---------------------------------------------------------------------------
193 (defmethod mst-tree-union ((v1 basic-vertex) (v2 basic-vertex))
194 (mst-link (mst-find-set v1) (mst-find-set v2)))
196 ;;; ---------------------------------------------------------------------------
198 (defmethod mst-link ((v1 basic-vertex) (v2 basic-vertex))
199 (cond ((> (rank v1) (rank v2))
200 (setf (previous-node v2) v1))
201 (t (setf (previous-node v1) v2)
202 (when (= (rank v1) (rank v2))
205 ;;; ---------------------------------------------------------------------------
206 ;;; jjm's implementation of mst depends on this
207 ;;; todo - figure out some what to add and edge we create to a graph rather
208 ;;; than always using add-edge-between-vertexes interface
209 ;;; ---------------------------------------------------------------------------
211 (defmethod add-edges-to-graph ((graph basic-graph) (edges list)
212 &key (if-duplicate-do :ignore))
216 (bind ((v1 (element (source-vertex edge)))
217 (v2 (element (target-vertex edge))))
218 (add-edge-between-vertexes
219 graph v1 v2 :edge-class (type-of edge)
220 :edge-type (if (directed-edge-p edge)
224 :edge-id (edge-id edge)
225 :element (element edge)
229 :if-duplicate-do if-duplicate-do))))
232 ;;; ---------------------------------------------------------------------------
234 ;;; ---------------------------------------------------------------------------
236 (defmethod make-graph-from-vertexes ((vertex-list list))
237 (bind ((edges-to-keep nil)
238 (g (copy-template (graph (first vertex-list)))))
243 (add-vertex g (element v))
247 (when (and (member (vertex-1 e) vertex-list)
248 (member (vertex-2 e) vertex-list))
249 (pushnew e edges-to-keep :test #'eq))))))
254 (bind ((v1 (source-vertex e))
255 (v2 (target-vertex e)))
256 ;;?? can we use copy here...
257 (add-edge-between-vertexes
258 g (element v1) (element v2)
259 :edge-type (if (directed-edge-p e)
262 :if-duplicate-do :force
263 :edge-class (type-of e)
272 ;;; ---------------------------------------------------------------------------
274 (defmethod edge-lessp-by-weight ((e1 basic-edge) (e2 basic-edge))
275 (< (weight e1) (weight e2)))
277 ;;; ---------------------------------------------------------------------------
278 ;;; minumum spanning tree
279 ;;; ---------------------------------------------------------------------------
282 (defmethod minimum-spanning-tree ((graph basic-graph)
284 (edge-sorter #'edge-lessp-by-weight))
291 (loop for edge in (sort (edges graph) edge-sorter) do
292 (bind ((v1 (source-vertex edge))
293 (v2 (target-vertex edge)))
295 (unless (eq (mst-find-set v1)
298 (mst-tree-union v1 v2)))
301 (cond ((= (length result) (- (length (vertexes graph)) 1))
303 (t (values nil result)))))))
305 ;;; ---------------------------------------------------------------------------
308 (defmethod minimum-spanning-tree ((vertex-list list)
310 (edge-sorter #'edge-lessp-by-weight))
312 (v-edges (remove-duplicates
313 (flatten (mapcar #'edges vertex-list)) :test #'eq)))
322 (loop for edge in (sort v-edges edge-sorter) do
323 (bind ((v1 (source-vertex edge))
324 (v2 (target-vertex edge))
325 (v1-set (mst-find-set v1))
326 (v2-set (mst-find-set v2)))
328 (when (or (not v1-set)
330 (return-from minimum-spanning-tree nil))
333 (unless (eq (mst-find-set v1)
336 (mst-tree-union v1 v2)))
339 (cond ((= (length result) (- (length vertex-list) 1))
341 (t (values nil result)))))))
343 ;;; ---------------------------------------------------------------------------
344 ;;; uses mst to determine if the graph is connected
345 ;;; ---------------------------------------------------------------------------
347 (defmethod connected-graph-p ((graph basic-graph) &key
348 (edge-sorter 'edge-lessp-by-weight))
349 (minimum-spanning-tree graph :edge-sorter edge-sorter))
352 ;;; ---------------------------------------------------------------------------
355 (bind ((g (make-container 'graph-container)))
356 (add-edge-between-vertexes g :v :y :edge-type :directed)
357 (add-edge-between-vertexes g :u :x :edge-type :directed)
358 (add-edge-between-vertexes g :x :v :edge-type :directed)
359 (add-edge-between-vertexes g :u :v :edge-type :directed)
360 (add-edge-between-vertexes g :y :x :edge-type :directed)
361 (add-edge-between-vertexes g :w :y :edge-type :directed)
362 (add-edge-between-vertexes g :w :z :edge-type :directed)
363 (add-edge-between-vertexes g :z :z :edge-type :directed
364 :if-duplicate-do :force)
365 (minimum-spanning-tree g))
367 ;;; ---------------------------------------------------------------------------
368 ;;; GWK's implementation of kruskal's - slightly faster, but it doesn't return
369 ;;; a tree (still faster even if it does). Will decide later if which to use
370 ;;; ignoring for now -jjm
371 ;;; ---------------------------------------------------------------------------
374 (defmethod minimum-spanning-tree ((graph basic-graph) &key (weight 'weight))
376 (union (make-container 'union-find-container))
377 (edges (sort (edges graph) #'< :key weight)))
379 graph (lambda (v) (insert-item union v)))
381 (let ((node-1 (representative-node union (vertex-1 edge)))
382 (node-2 (representative-node union (vertex-2 edge))))
383 (unless (eq (find-set node-1) (find-set node-2))
384 (graft-nodes node-1 node-2)
389 ;;; ---------------------------------------------------------------------------
392 (loop for f in '(mst-kruskal minimum-spanning-tree-kruskal) do
393 (fluid-bind (((random-seed *random-generator*) 1))
394 (bind ((g (generate-undirected-graph-via-vertex-probabilities
395 *random-generator* (make-instance 'graph-container :default-edge-type :directed)
398 #2A((0.2 0.1) (nil 0.2))
400 (form-keyword "H" (format nil "~2,'0D~4,'0D" kind count))))
402 (timeit (:report :values)
403 (loop for n from 1 to 100 do
404 (funcall f g (lambda (a b)
405 (declare (ignore a b))
408 ;;; ---------------------------------------------------------------------------
409 ;;; end minimum spanning tree
410 ;;; ---------------------------------------------------------------------------
413 ;;; ---------------------------------------------------------------------------
414 ;;; depth-first-search - clrs2
415 ;;; todo - figure out how to name this depth-first-search, which is already
416 ;;; defined in search.lisp
417 ;;; ---------------------------------------------------------------------------
419 ;;; ---------------------------------------------------------------------------
420 ;;; should probably make this special
421 ;;; ---------------------------------------------------------------------------
423 (defparameter *depth-first-search-timer* -1)
425 ;;; ---------------------------------------------------------------------------
426 ;;; undirected edges are less than edges that are directed
427 ;;; ---------------------------------------------------------------------------
429 #+ignore ;;; incorrect, methinks - jjm
430 (defmethod edge-lessp-by-direction ((e1 basic-edge) (e2 basic-edge))
431 (cond ((or (every #'directed-edge-p (list e1 e2))
432 (every #'undirected-edge-p (list e1 e2)))
434 ((and (undirected-edge-p e1) (directed-edge-p e2))
438 (defmethod edge-lessp-by-direction ((e1 basic-edge) (e2 basic-edge))
439 (and (undirected-edge-p e1) (directed-edge-p e2)))
441 ;;; ---------------------------------------------------------------------------
443 (defmethod out-edge-for-vertex-p ((edge basic-edge) (vertex basic-vertex))
444 (cond ((and (directed-edge-p edge)
445 (eq vertex (source-vertex edge)))
447 ((and (undirected-edge-p edge)
448 (or (eq vertex (source-vertex edge))
449 (eq vertex (target-vertex edge))))
453 ;;; ---------------------------------------------------------------------------
454 ;;; depth-first-search
455 ;;; ---------------------------------------------------------------------------
457 (defmethod dfs ((graph basic-graph) (root t) fn &key
458 (out-edge-sorter #'edge-lessp-by-direction))
459 (dfs graph (find-vertex graph root) fn :out-edge-sorter out-edge-sorter))
461 ;;; ---------------------------------------------------------------------------
463 (defmethod dfs ((graph basic-graph) (root basic-vertex) fn &key
464 (out-edge-sorter #'edge-lessp-by-direction))
465 (setf *depth-first-search-timer* -1)
470 (setf (color v) :white
471 (previous-node v) nil
472 (discovery-time v) -1
473 (finish-time v) -1)))
478 (setf (color e) nil)))
480 (loop with vl = (remove root (vertexes graph) :test #'eql)
481 for v in (push root vl) do
482 (when (eql (color v) :white)
483 (dfs-visit graph v fn out-edge-sorter)))
486 (sort (copy-list (vertexes graph)) #'< :key #'finish-time)
489 ;;; ---------------------------------------------------------------------------
491 (defmethod dfs-visit ((graph graph-container) (u basic-vertex)
495 (incf *depth-first-search-timer*)
496 (setf (color u) :gray
497 (discovery-time u) *depth-first-search-timer*)
500 (loop for edge in (sort (collect-elements
503 (out-edge-for-vertex-p e u))) sorter) do
504 (bind ((v (other-vertex edge u)))
507 (setf (color edge) (color v)))
509 (when (eql (color v) :white)
510 (setf (previous-node v) u)
512 (dfs-visit graph v fn sorter))))
514 (incf *depth-first-search-timer*)
516 (setf (color u) :black
517 (finish-time u) *depth-first-search-timer*))
519 ;;; ---------------------------------------------------------------------------
521 ;;; ---------------------------------------------------------------------------
524 (bind ((g (make-container 'graph-container)))
525 (add-edge-between-vertexes g :v :y :edge-type :directed)
526 (add-edge-between-vertexes g :u :x :edge-type :directed)
527 (add-edge-between-vertexes g :x :v :edge-type :directed)
528 (add-edge-between-vertexes g :u :v :edge-type :directed)
529 (add-edge-between-vertexes g :y :x :edge-type :directed)
530 (add-edge-between-vertexes g :w :y :edge-type :directed)
531 (add-edge-between-vertexes g :w :z :edge-type :directed)
532 (add-edge-between-vertexes g :z :z :edge-type :directed
533 :if-duplicate-do :force)
534 (assert (equal '(:X :Y :V :U :Z :W)
535 (mapcar #'element (dfs g :u #'identity)))))
537 ;;; ---------------------------------------------------------------------------
539 (defmethod dfs-tree-edge-p ((edge graph-container-edge))
540 (eql (color edge) :white))
542 ;;; ---------------------------------------------------------------------------
544 (defmethod dfs-back-edge-p ((edge graph-container-edge))
545 (eql (color edge) :gray))
547 ;;; ---------------------------------------------------------------------------
548 ;;; not correct - has to look at combination of discovery-time and finish-time
549 ;;; ---------------------------------------------------------------------------
551 (defmethod dfs-forward-edge-p ((edge graph-container-edge))
552 (warn "implementation is not correct.")
553 (unless (and (dfs-tree-edge-p edge)
554 (dfs-back-edge-p edge))
555 (< (discovery-time (source-vertex edge))
556 (discovery-time (target-vertex edge)))))
558 ;;; ---------------------------------------------------------------------------
559 ;;; not correct - has to look at combination of discovery-time and finish-time
560 ;;; ---------------------------------------------------------------------------
562 (defmethod dfs-cross-edge-p ((edge graph-container-edge))
563 (warn "implementation is not correct.")
564 (unless (and (dfs-tree-edge-p edge)
565 (dfs-back-edge-p edge))
566 (> (discovery-time (source-vertex edge))
567 (discovery-time (target-vertex edge)))))
569 ;;; ---------------------------------------------------------------------------
571 (defmethod dfs-edge-type ((edge graph-container-edge))
572 (cond ((dfs-tree-edge-p edge)
574 ((dfs-back-edge-p edge)
576 ((dfs-forward-edge-p edge)
578 ((dfs-cross-edge-p edge)
582 ;;; ---------------------------------------------------------------------------
584 ;;; ---------------------------------------------------------------------------
586 ;;; ---------------------------------------------------------------------------
587 ;;; mapping functions
588 ;;; ---------------------------------------------------------------------------
590 ;;; ---------------------------------------------------------------------------
592 ;;; ---------------------------------------------------------------------------
594 (defmethod map-over-all-combinations-of-k-vertexes ((graph basic-graph) k fn)
595 (bind ((vertex-count (size graph))
596 (symbols (make-list k :initial-element vertex-count))
597 (vertexes (vertexes graph)))
598 (iterate-over-indexes
600 (lambda (vertex-indexes)
601 (when (apply #'< vertex-indexes)
602 (funcall fn (mapcar (lambda (vertex-index)
603 (nth-element vertexes vertex-index))
604 vertex-indexes)))))))
606 ;;; ---------------------------------------------------------------------------
610 (g (make-container 'graph-container)))
611 (add-edge-between-vertexes g :u :v :edge-type :directed)
612 (add-edge-between-vertexes g :u :x :edge-type :directed)
613 (add-edge-between-vertexes g :x :v :edge-type :directed)
614 (add-edge-between-vertexes g :v :y :edge-type :directed)
615 (add-edge-between-vertexes g :y :x :edge-type :directed)
616 (add-edge-between-vertexes g :w :y :edge-type :directed)
617 (add-edge-between-vertexes g :w :z :edge-type :directed)
619 (map-over-all-combinations-of-k-vertexes
622 (lambda (vertex-list)
623 (bind ((graph-from-vertexes (make-graph-from-vertexes vertex-list)))
624 (when (mst-kruskal graph-from-vertexes #'identity-sorter)
625 (push graph-from-vertexes result)))))
628 ;;; ---------------------------------------------------------------------------
630 ;;; todo: merge these two defs
631 ;;; ---------------------------------------------------------------------------
633 (defmethod map-over-all-combinations-of-k-edges ((graph basic-graph) k fn)
634 (bind ((edge-count (edge-count graph))
635 (symbols (make-list k :initial-element edge-count))
636 (edges (edges graph)))
638 (iterate-over-indexes
640 (lambda (edge-indexes)
641 (when (apply #'< edge-indexes)
642 (funcall fn (mapcar (lambda (edge-index)
643 (nth-element edges edge-index))
646 ;;; ---------------------------------------------------------------------------
648 (defmethod map-over-all-combinations-of-k-edges ((vertex basic-vertex) k fn)
649 (bind ((edge-count (edge-count vertex))
650 (symbols (make-list k :initial-element edge-count))
651 (edges (edges vertex)))
653 (iterate-over-indexes
655 (lambda (edge-indexes)
656 (when (apply #'< edge-indexes)
657 (funcall fn (mapcar (lambda (edge-index)
658 (nth-element edges edge-index))
660 ;;; ---------------------------------------------------------------------------
663 (map-over-all-combinations-of-k-edges
664 (generate-undirected-graph-via-verex-probabilities
665 *random-generator* 'graph-container
668 #2A((0.2 0.1) (nil 0.2))
670 (form-keyword "H" (format nil "~2,'0D~4,'0D" kind count))))
675 (format t "~A -- ~A " (element (vertex-1 e)) (element (vertex-2 e))))
682 ;;; ***************************************************************************
684 ;;; ***************************************************************************