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 (let ((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 (defmethod edge-lessp-by-weight ((e1 basic-edge) (e2 basic-edge))
233 (< (weight e1) (weight e2)))
235 ;;; ---------------------------------------------------------------------------
236 ;;; minumum spanning tree
237 ;;; ---------------------------------------------------------------------------
240 (defmethod minimum-spanning-tree ((graph basic-graph)
242 (edge-sorter #'edge-lessp-by-weight))
249 (loop for edge in (sort (edges graph) edge-sorter) do
250 (let ((v1 (source-vertex edge))
251 (v2 (target-vertex edge)))
253 (unless (eq (mst-find-set v1)
256 (mst-tree-union v1 v2)))
259 (cond ((= (length result) (- (length (vertexes graph)) 1))
261 (t (values nil result)))))))
263 ;;; ---------------------------------------------------------------------------
266 (defmethod minimum-spanning-tree ((vertex-list list)
268 (edge-sorter #'edge-lessp-by-weight))
270 (v-edges (remove-duplicates
271 (flatten (mapcar #'edges vertex-list)) :test #'eq)))
278 (loop for edge in (sort v-edges edge-sorter) do
279 (let ((v1 (source-vertex edge))
280 (v2 (target-vertex edge))
281 (v1-set (mst-find-set v1))
282 (v2-set (mst-find-set v2)))
284 (when (or (not v1-set)
286 (return-from minimum-spanning-tree nil))
289 (unless (eq (mst-find-set v1)
292 (mst-tree-union v1 v2)))
295 (cond ((= (length result) (- (length vertex-list) 1))
297 (t (values nil result)))))))
299 ;;; ---------------------------------------------------------------------------
300 ;;; uses mst to determine if the graph is connected
301 ;;; ---------------------------------------------------------------------------
303 (defmethod connected-graph-p ((graph basic-graph) &key
304 (edge-sorter 'edge-lessp-by-weight))
305 (minimum-spanning-tree graph :edge-sorter edge-sorter))
308 ;;; ---------------------------------------------------------------------------
311 (let ((g (make-container 'graph-container)))
312 (add-edge-between-vertexes g :v :y :edge-type :directed)
313 (add-edge-between-vertexes g :u :x :edge-type :directed)
314 (add-edge-between-vertexes g :x :v :edge-type :directed)
315 (add-edge-between-vertexes g :u :v :edge-type :directed)
316 (add-edge-between-vertexes g :y :x :edge-type :directed)
317 (add-edge-between-vertexes g :w :y :edge-type :directed)
318 (add-edge-between-vertexes g :w :z :edge-type :directed)
319 (add-edge-between-vertexes g :z :z :edge-type :directed
320 :if-duplicate-do :force)
321 (minimum-spanning-tree g))
323 ;;; ---------------------------------------------------------------------------
324 ;;; GWK's implementation of kruskal's - slightly faster, but it doesn't return
325 ;;; a tree (still faster even if it does). Will decide later if which to use
326 ;;; ignoring for now -jjm
327 ;;; ---------------------------------------------------------------------------
330 (defmethod minimum-spanning-tree ((graph basic-graph) &key (weight 'weight))
332 (union (make-container 'union-find-container))
333 (edges (sort (edges graph) #'< :key weight)))
335 graph (lambda (v) (insert-item union v)))
337 (let ((node-1 (representative-node union (vertex-1 edge)))
338 (node-2 (representative-node union (vertex-2 edge))))
339 (unless (eq (find-set node-1) (find-set node-2))
340 (graft-nodes node-1 node-2)
345 ;;; ---------------------------------------------------------------------------
348 (loop for f in '(mst-kruskal minimum-spanning-tree-kruskal) do
349 (fluid-bind (((random-seed *random-generator*) 1))
350 (bind ((g (generate-undirected-graph-via-vertex-probabilities
351 *random-generator* (make-instance 'graph-container :default-edge-type :directed)
354 #2A((0.2 0.1) (nil 0.2))
356 (form-keyword "H" (format nil "~2,'0D~4,'0D" kind count))))
358 (timeit (:report :values)
359 (loop for n from 1 to 100 do
360 (funcall f g (lambda (a b)
361 (declare (ignore a b))
364 ;;; ---------------------------------------------------------------------------
365 ;;; end minimum spanning tree
366 ;;; ---------------------------------------------------------------------------
369 ;;; ---------------------------------------------------------------------------
370 ;;; depth-first-search - clrs2
371 ;;; todo - figure out how to name this depth-first-search, which is already
372 ;;; defined in search.lisp
373 ;;; ---------------------------------------------------------------------------
375 ;;; ---------------------------------------------------------------------------
376 ;;; should probably make this special
377 ;;; ---------------------------------------------------------------------------
379 (defparameter *depth-first-search-timer* -1)
381 ;;; ---------------------------------------------------------------------------
382 ;;; undirected edges are less than edges that are directed
383 ;;; ---------------------------------------------------------------------------
385 #+ignore ;;; incorrect, methinks - jjm
386 (defmethod edge-lessp-by-direction ((e1 basic-edge) (e2 basic-edge))
387 (cond ((or (every #'directed-edge-p (list e1 e2))
388 (every #'undirected-edge-p (list e1 e2)))
390 ((and (undirected-edge-p e1) (directed-edge-p e2))
394 (defmethod edge-lessp-by-direction ((e1 basic-edge) (e2 basic-edge))
395 (and (undirected-edge-p e1) (directed-edge-p e2)))
397 ;;; ---------------------------------------------------------------------------
399 (defmethod out-edge-for-vertex-p ((edge basic-edge) (vertex basic-vertex))
400 (cond ((and (directed-edge-p edge)
401 (eq vertex (source-vertex edge)))
403 ((and (undirected-edge-p edge)
404 (or (eq vertex (source-vertex edge))
405 (eq vertex (target-vertex edge))))
409 ;;; ---------------------------------------------------------------------------
410 ;;; depth-first-search
411 ;;; ---------------------------------------------------------------------------
413 (defmethod dfs ((graph basic-graph) (root t) fn &key
414 (out-edge-sorter #'edge-lessp-by-direction))
415 (dfs graph (find-vertex graph root) fn :out-edge-sorter out-edge-sorter))
417 ;;; ---------------------------------------------------------------------------
419 (defmethod dfs ((graph basic-graph) (root basic-vertex) fn &key
420 (out-edge-sorter #'edge-lessp-by-direction))
421 (setf *depth-first-search-timer* -1)
426 (setf (color v) :white
427 (previous-node v) nil
428 (discovery-time v) -1
429 (finish-time v) -1)))
434 (setf (color e) nil)))
436 (loop with vl = (remove root (vertexes graph) :test #'eql)
437 for v in (push root vl) do
438 (when (eql (color v) :white)
439 (dfs-visit graph v fn out-edge-sorter)))
442 (sort (copy-list (vertexes graph)) #'< :key #'finish-time)
445 ;;; ---------------------------------------------------------------------------
447 (defmethod dfs-visit ((graph graph-container) (u basic-vertex)
451 (incf *depth-first-search-timer*)
452 (setf (color u) :gray
453 (discovery-time u) *depth-first-search-timer*)
456 (loop for edge in (sort (collect-elements
459 (out-edge-for-vertex-p e u))) sorter) do
460 (let ((v (other-vertex edge u)))
463 (setf (color edge) (color v)))
465 (when (eql (color v) :white)
466 (setf (previous-node v) u)
468 (dfs-visit graph v fn sorter))))
470 (incf *depth-first-search-timer*)
472 (setf (color u) :black
473 (finish-time u) *depth-first-search-timer*))
475 ;;; ---------------------------------------------------------------------------
477 ;;; ---------------------------------------------------------------------------
480 (let ((g (make-container 'graph-container)))
481 (add-edge-between-vertexes g :v :y :edge-type :directed)
482 (add-edge-between-vertexes g :u :x :edge-type :directed)
483 (add-edge-between-vertexes g :x :v :edge-type :directed)
484 (add-edge-between-vertexes g :u :v :edge-type :directed)
485 (add-edge-between-vertexes g :y :x :edge-type :directed)
486 (add-edge-between-vertexes g :w :y :edge-type :directed)
487 (add-edge-between-vertexes g :w :z :edge-type :directed)
488 (add-edge-between-vertexes g :z :z :edge-type :directed
489 :if-duplicate-do :force)
490 (assert (equal '(:X :Y :V :U :Z :W)
491 (mapcar #'element (dfs g :u #'identity)))))
493 ;;; ---------------------------------------------------------------------------
495 (defmethod dfs-tree-edge-p ((edge graph-container-edge))
496 (eql (color edge) :white))
498 ;;; ---------------------------------------------------------------------------
500 (defmethod dfs-back-edge-p ((edge graph-container-edge))
501 (eql (color edge) :gray))
503 ;;; ---------------------------------------------------------------------------
504 ;;; not correct - has to look at combination of discovery-time and finish-time
505 ;;; ---------------------------------------------------------------------------
507 (defmethod dfs-forward-edge-p ((edge graph-container-edge))
508 (warn "implementation is not correct.")
509 (unless (and (dfs-tree-edge-p edge)
510 (dfs-back-edge-p edge))
511 (< (discovery-time (source-vertex edge))
512 (discovery-time (target-vertex edge)))))
514 ;;; ---------------------------------------------------------------------------
515 ;;; not correct - has to look at combination of discovery-time and finish-time
516 ;;; ---------------------------------------------------------------------------
518 (defmethod dfs-cross-edge-p ((edge graph-container-edge))
519 (warn "implementation is not correct.")
520 (unless (and (dfs-tree-edge-p edge)
521 (dfs-back-edge-p edge))
522 (> (discovery-time (source-vertex edge))
523 (discovery-time (target-vertex edge)))))
525 ;;; ---------------------------------------------------------------------------
527 (defmethod dfs-edge-type ((edge graph-container-edge))
528 (cond ((dfs-tree-edge-p edge)
530 ((dfs-back-edge-p edge)
532 ((dfs-forward-edge-p edge)
534 ((dfs-cross-edge-p edge)
538 ;;; ---------------------------------------------------------------------------
540 ;;; ---------------------------------------------------------------------------
542 ;;; ---------------------------------------------------------------------------
543 ;;; mapping functions
544 ;;; ---------------------------------------------------------------------------
546 ;;; ---------------------------------------------------------------------------
548 ;;; ---------------------------------------------------------------------------
550 (defmethod map-over-all-combinations-of-k-vertexes ((graph basic-graph) k fn)
551 (let* ((vertex-count (size graph))
552 (symbols (make-list k :initial-element vertex-count))
553 (vertexes (vertexes graph)))
554 (iterate-over-indexes
556 (lambda (vertex-indexes)
557 (when (apply #'< vertex-indexes)
558 (funcall fn (mapcar (lambda (vertex-index)
559 (nth-element vertexes vertex-index))
560 vertex-indexes)))))))
562 ;;; ---------------------------------------------------------------------------
566 (g (make-container 'graph-container)))
567 (add-edge-between-vertexes g :u :v :edge-type :directed)
568 (add-edge-between-vertexes g :u :x :edge-type :directed)
569 (add-edge-between-vertexes g :x :v :edge-type :directed)
570 (add-edge-between-vertexes g :v :y :edge-type :directed)
571 (add-edge-between-vertexes g :y :x :edge-type :directed)
572 (add-edge-between-vertexes g :w :y :edge-type :directed)
573 (add-edge-between-vertexes g :w :z :edge-type :directed)
575 (map-over-all-combinations-of-k-vertexes
578 (lambda (vertex-list)
579 (let ((graph-from-vertexes (make-graph-from-vertexes vertex-list)))
580 (when (mst-kruskal graph-from-vertexes #'identity-sorter)
581 (push graph-from-vertexes result)))))
584 ;;; ---------------------------------------------------------------------------
586 ;;; todo: merge these two defs
587 ;;; ---------------------------------------------------------------------------
589 (defmethod map-over-all-combinations-of-k-edges ((graph basic-graph) k fn)
590 (let* ((edge-count (edge-count graph))
591 (symbols (make-list k :initial-element edge-count))
592 (edges (edges graph)))
594 (iterate-over-indexes
596 (lambda (edge-indexes)
597 (when (apply #'< edge-indexes)
598 (funcall fn (mapcar (lambda (edge-index)
599 (nth-element edges edge-index))
602 ;;; ---------------------------------------------------------------------------
604 (defmethod map-over-all-combinations-of-k-edges ((vertex basic-vertex) k fn)
605 (let* ((edge-count (edge-count vertex))
606 (symbols (make-list k :initial-element edge-count))
607 (edges (edges vertex)))
609 (iterate-over-indexes
611 (lambda (edge-indexes)
612 (when (apply #'< edge-indexes)
613 (funcall fn (mapcar (lambda (edge-index)
614 (nth-element edges edge-index))
616 ;;; ---------------------------------------------------------------------------
619 (map-over-all-combinations-of-k-edges
620 (generate-undirected-graph-via-verex-probabilities
621 *random-generator* 'graph-container
624 #2A((0.2 0.1) (nil 0.2))
626 (form-keyword "H" (format nil "~2,'0D~4,'0D" kind count))))
631 (format t "~A -- ~A " (element (vertex-1 e)) (element (vertex-2 e))))
638 ;;; ***************************************************************************
640 ;;; ***************************************************************************