1 (in-package #:metabang.graph)
5 (defstruct (vertex-datum (:conc-name node-) (:type list))
7 (depth most-positive-fixnum)
11 (defmethod initialize-vertex-data ((graph basic-graph))
12 (let ((vertex-data (make-container 'simple-associative-container)))
13 (iterate-vertexes graph (lambda (v)
14 (setf (item-at vertex-data v)
15 (make-vertex-datum :color :white))))
16 (values vertex-data)))
18 ;;; breadth-first-search by GWK
20 (defmethod breadth-first-visitor ((graph basic-graph) (source t) fn)
21 (breadth-first-visitor graph (find-vertex graph source) fn))
24 (defmethod breadth-first-visitor ((graph basic-graph) (source basic-vertex) fn)
26 (let ((vertex-data (initialize-vertex-data graph))
27 (queue (make-container 'basic-queue)))
29 (let ((source-datum (item-at vertex-data source)))
30 (setf (node-color source-datum) :grey
31 (node-depth source-datum) 0)
32 (enqueue queue source)
34 (loop until (empty-p queue) do
35 (let* ((current-vertex (first-item queue))
36 (current (item-at vertex-data current-vertex)))
37 ;(format t "~%~A:" current-vertex)
38 (iterate-children current-vertex
39 (lambda (child-vertex)
40 ;(format t "~A " child-vertex)
41 (let ((child (item-at vertex-data child-vertex)))
42 (when (eq (node-color child) :white)
43 (setf (node-color child) :grey
44 (node-depth child) (1+ (node-depth current))
45 (node-parent child) current-vertex)
46 (enqueue queue child-vertex)))))
49 (setf (node-color current) :black)
50 (funcall fn current-vertex)))
55 (defmethod breadth-first-search-graph ((graph basic-graph) (source t))
56 (breadth-first-search-graph graph (find-vertex graph source)))
59 (defmethod breadth-first-search-graph ((graph basic-graph) (source basic-vertex))
61 (let ((vertex-data (initialize-vertex-data graph))
62 (queue (make-container 'basic-queue)))
64 (let ((source-datum (item-at vertex-data source)))
65 (setf (node-color source-datum) :grey
66 (node-depth source-datum) 0)
67 (enqueue queue source)
69 (loop until (empty-p queue) do
70 (let* ((current-vertex (first-item queue))
71 (current (item-at vertex-data current-vertex)))
72 ;(format t "~%~A:" current-vertex)
73 (iterate-children current-vertex
74 (lambda (child-vertex)
75 ;(format t "~A " child-vertex)
76 (let ((child (item-at vertex-data child-vertex)))
77 (when (eq (node-color child) :white)
78 (setf (node-color child) :grey
79 (node-depth child) (1+ (node-depth current))
80 (node-parent child) current-vertex)
81 (enqueue queue child-vertex)))))
84 (setf (node-color current) :black)))
88 ;;; single-source-shortest-paths - gwk
91 (defmethod single-source-shortest-paths ((graph basic-graph))
92 (let ((vertex-data (initialize-vertex-data graph))
93 (queue (make-container 'priority-queue-on-container 'binary-search-tree)))
94 (let ((source-datum (item-at vertex-data source)))
95 (setf (node-depth source-datum) 0))
98 ;;; connected-components - gwk
100 (defmethod connected-components ((graph basic-graph))
101 (let ((union (make-container 'union-find-container)))
104 (lambda (v) (insert-item union v)))
108 (let ((node-1 (representative-node union (vertex-1 e)))
109 (node-2 (representative-node union (vertex-2 e))))
110 (unless (eq (find-set node-1) (find-set node-2))
111 (graft-nodes node-1 node-2)))))
112 (iterate-elements union 'find-set)
116 (defmethod connected-component-count ((graph basic-graph))
117 ;;?? Gary King 2005-11-28: Super ugh
121 (connected-components graph)
122 :transform #'parent)))
125 ;;?? Gary King 2005-11-28: fails on big graphs? iterator design
126 ;;?? Gary King 2005-11-28: ideally we don't want to cons up the list at all
129 (make-iterator (connected-components graph) :unique t :transform #'parent))))
131 (defmethod find-connected-components ((graph basic-graph))
133 (make-iterator (connected-components graph) :unique t :transform #'parent)
136 (subgraph-containing graph (element component)
137 :depth most-positive-fixnum))))
140 (defmethod find-connected-components ((graph basic-graph))
142 (found-elements (make-container 'simple-associative-container)))
144 (connected-components graph)
146 (let ((element (element (parent component))))
147 (unless (item-at found-elements element)
148 (setf (item-at found-elements element) t)
149 (push (subgraph-containing graph (element component)
150 most-positive-fixnum)
157 ;;; minimum-spanning-tree based on kruskal's algorithm detailed in clrs2 -jjm
159 (defmethod mst-find-set ((vertex basic-vertex))
161 (unless (previous-node vertex)
162 (return-from mst-find-set nil))
163 (unless (eq vertex (previous-node vertex))
164 (setf (previous-node vertex) (mst-find-set (previous-node vertex))))
165 (previous-node vertex))
168 (defmethod mst-make-set ((vertex basic-vertex))
169 (setf (previous-node vertex) vertex
173 (defmethod mst-tree-union ((v1 basic-vertex) (v2 basic-vertex))
174 (mst-link (mst-find-set v1) (mst-find-set v2)))
177 (defmethod mst-link ((v1 basic-vertex) (v2 basic-vertex))
178 (cond ((> (rank v1) (rank v2))
179 (setf (previous-node v2) v1))
180 (t (setf (previous-node v1) v2)
181 (when (= (rank v1) (rank v2))
184 ;;; jjm's implementation of mst depends on this
185 ;;; todo - figure out some what to add and edge we create to a graph rather
186 ;;; than always using add-edge-between-vertexes interface
188 (defmethod add-edges-to-graph ((graph basic-graph) (edges list)
189 &key (if-duplicate-do :ignore))
193 (let ((v1 (element (source-vertex edge)))
194 (v2 (element (target-vertex edge))))
195 (add-edge-between-vertexes
196 graph v1 v2 :edge-class (type-of edge)
197 :edge-type (if (directed-edge-p edge)
201 :edge-id (edge-id edge)
202 :element (element edge)
206 :if-duplicate-do if-duplicate-do))))
210 (defmethod edge-lessp-by-weight ((e1 basic-edge) (e2 basic-edge))
211 (< (weight e1) (weight e2)))
213 ;;; minumum spanning tree
216 (defmethod minimum-spanning-tree ((graph basic-graph)
218 (edge-sorter #'edge-lessp-by-weight))
225 (loop for edge in (sort (edges graph) edge-sorter) do
226 (let ((v1 (source-vertex edge))
227 (v2 (target-vertex edge)))
229 (unless (eq (mst-find-set v1)
232 (mst-tree-union v1 v2)))
235 (cond ((= (length result) (- (length (vertexes graph)) 1))
237 (t (values nil result)))))))
241 (defmethod minimum-spanning-tree ((vertex-list list)
243 (edge-sorter #'edge-lessp-by-weight))
245 (v-edges (remove-duplicates
246 (flatten (mapcar #'edges vertex-list)) :test #'eq)))
253 (loop for edge in (sort v-edges edge-sorter) do
254 (let ((v1 (source-vertex edge))
255 (v2 (target-vertex edge))
256 (v1-set (mst-find-set v1))
257 (v2-set (mst-find-set v2)))
259 (when (or (not v1-set)
261 (return-from minimum-spanning-tree nil))
264 (unless (eq (mst-find-set v1)
267 (mst-tree-union v1 v2)))
270 (cond ((= (length result) (- (length vertex-list) 1))
272 (t (values nil result)))))))
274 ;;; uses mst to determine if the graph is connected
276 (defmethod connected-graph-p ((graph basic-graph) &key
277 (edge-sorter 'edge-lessp-by-weight))
278 (minimum-spanning-tree graph :edge-sorter edge-sorter))
283 (let ((g (make-container 'graph-container)))
284 (add-edge-between-vertexes g :v :y :edge-type :directed)
285 (add-edge-between-vertexes g :u :x :edge-type :directed)
286 (add-edge-between-vertexes g :x :v :edge-type :directed)
287 (add-edge-between-vertexes g :u :v :edge-type :directed)
288 (add-edge-between-vertexes g :y :x :edge-type :directed)
289 (add-edge-between-vertexes g :w :y :edge-type :directed)
290 (add-edge-between-vertexes g :w :z :edge-type :directed)
291 (add-edge-between-vertexes g :z :z :edge-type :directed
292 :if-duplicate-do :force)
293 (minimum-spanning-tree g))
295 ;;; GWK's implementation of kruskal's - slightly faster, but it doesn't return
296 ;;; a tree (still faster even if it does). Will decide later if which to use
297 ;;; ignoring for now -jjm
300 (defmethod minimum-spanning-tree ((graph basic-graph) &key (weight 'weight))
302 (union (make-container 'union-find-container))
303 (edges (sort (edges graph) #'< :key weight)))
305 graph (lambda (v) (insert-item union v)))
307 (let ((node-1 (representative-node union (vertex-1 edge)))
308 (node-2 (representative-node union (vertex-2 edge))))
309 (unless (eq (find-set node-1) (find-set node-2))
310 (graft-nodes node-1 node-2)
317 (loop for f in '(mst-kruskal minimum-spanning-tree-kruskal) do
318 (fluid-bind (((random-seed *random-generator*) 1))
319 (bind ((g (generate-undirected-graph-via-vertex-probabilities
320 *random-generator* (make-instance 'graph-container :default-edge-type :directed)
323 #2A((0.2 0.1) (nil 0.2))
325 (form-keyword "H" (format nil "~2,'0D~4,'0D" kind count))))
327 (timeit (:report :values)
328 (loop for n from 1 to 100 do
329 (funcall f g (lambda (a b)
330 (declare (ignore a b))
333 ;;; end minimum spanning tree
336 ;;; depth-first-search - clrs2
337 ;;; todo - figure out how to name this depth-first-search, which is already
338 ;;; defined in search.lisp
340 ;;; should probably make this special
342 (defparameter *depth-first-search-timer* -1)
344 ;;; undirected edges are less than edges that are directed
346 #+ignore ;;; incorrect, methinks - jjm
347 (defmethod edge-lessp-by-direction ((e1 basic-edge) (e2 basic-edge))
348 (cond ((or (every #'directed-edge-p (list e1 e2))
349 (every #'undirected-edge-p (list e1 e2)))
351 ((and (undirected-edge-p e1) (directed-edge-p e2))
355 (defmethod edge-lessp-by-direction ((e1 basic-edge) (e2 basic-edge))
356 (and (undirected-edge-p e1) (directed-edge-p e2)))
359 (defmethod out-edge-for-vertex-p ((edge basic-edge) (vertex basic-vertex))
360 (cond ((and (directed-edge-p edge)
361 (eq vertex (source-vertex edge)))
363 ((and (undirected-edge-p edge)
364 (or (eq vertex (source-vertex edge))
365 (eq vertex (target-vertex edge))))
369 ;;; depth-first-search
371 (defmethod dfs ((graph basic-graph) (root t) fn &key
372 (out-edge-sorter #'edge-lessp-by-direction))
373 (dfs graph (find-vertex graph root) fn :out-edge-sorter out-edge-sorter))
376 (defmethod dfs ((graph basic-graph) (root basic-vertex) fn &key
377 (out-edge-sorter #'edge-lessp-by-direction))
378 (setf *depth-first-search-timer* -1)
383 (setf (color v) :white
384 (previous-node v) nil
385 (discovery-time v) -1
386 (finish-time v) -1)))
391 (setf (color e) nil)))
393 (loop with vl = (remove root (vertexes graph) :test #'eql)
394 for v in (push root vl) do
395 (when (eql (color v) :white)
396 (dfs-visit graph v fn out-edge-sorter)))
399 (sort (copy-list (vertexes graph)) #'< :key #'finish-time)
403 (defmethod dfs-visit ((graph graph-container) (u basic-vertex)
407 (incf *depth-first-search-timer*)
408 (setf (color u) :gray
409 (discovery-time u) *depth-first-search-timer*)
412 (loop for edge in (sort (collect-elements
415 (out-edge-for-vertex-p e u))) sorter) do
416 (let ((v (other-vertex edge u)))
419 (setf (color edge) (color v)))
421 (when (eql (color v) :white)
422 (setf (previous-node v) u)
424 (dfs-visit graph v fn sorter))))
426 (incf *depth-first-search-timer*)
428 (setf (color u) :black
429 (finish-time u) *depth-first-search-timer*))
434 (let ((g (make-container 'graph-container)))
435 (add-edge-between-vertexes g :v :y :edge-type :directed)
436 (add-edge-between-vertexes g :u :x :edge-type :directed)
437 (add-edge-between-vertexes g :x :v :edge-type :directed)
438 (add-edge-between-vertexes g :u :v :edge-type :directed)
439 (add-edge-between-vertexes g :y :x :edge-type :directed)
440 (add-edge-between-vertexes g :w :y :edge-type :directed)
441 (add-edge-between-vertexes g :w :z :edge-type :directed)
442 (add-edge-between-vertexes g :z :z :edge-type :directed
443 :if-duplicate-do :force)
444 (assert (equal '(:X :Y :V :U :Z :W)
445 (mapcar #'element (dfs g :u #'identity)))))
448 (defmethod dfs-tree-edge-p ((edge graph-container-edge))
449 (eql (color edge) :white))
452 (defmethod dfs-back-edge-p ((edge graph-container-edge))
453 (eql (color edge) :gray))
455 ;;; not correct - has to look at combination of discovery-time and finish-time
457 (defmethod dfs-forward-edge-p ((edge graph-container-edge))
458 (warn "implementation is not correct.")
459 (unless (and (dfs-tree-edge-p edge)
460 (dfs-back-edge-p edge))
461 (< (discovery-time (source-vertex edge))
462 (discovery-time (target-vertex edge)))))
464 ;;; not correct - has to look at combination of discovery-time and finish-time
466 (defmethod dfs-cross-edge-p ((edge graph-container-edge))
467 (warn "implementation is not correct.")
468 (unless (and (dfs-tree-edge-p edge)
469 (dfs-back-edge-p edge))
470 (> (discovery-time (source-vertex edge))
471 (discovery-time (target-vertex edge)))))
474 (defmethod dfs-edge-type ((edge graph-container-edge))
475 (cond ((dfs-tree-edge-p edge)
477 ((dfs-back-edge-p edge)
479 ((dfs-forward-edge-p edge)
481 ((dfs-cross-edge-p edge)
487 ;;; mapping functions
491 (defmethod map-over-all-combinations-of-k-vertexes ((graph basic-graph) k fn)
492 (let* ((vertex-count (size graph))
493 (symbols (make-list k :initial-element vertex-count))
494 (vertexes (vertexes graph)))
495 (iterate-over-indexes
497 (lambda (vertex-indexes)
498 (when (apply #'< vertex-indexes)
499 (funcall fn (mapcar (lambda (vertex-index)
500 (nth-element vertexes vertex-index))
501 vertex-indexes)))))))
506 (g (make-container 'graph-container)))
507 (add-edge-between-vertexes g :u :v :edge-type :directed)
508 (add-edge-between-vertexes g :u :x :edge-type :directed)
509 (add-edge-between-vertexes g :x :v :edge-type :directed)
510 (add-edge-between-vertexes g :v :y :edge-type :directed)
511 (add-edge-between-vertexes g :y :x :edge-type :directed)
512 (add-edge-between-vertexes g :w :y :edge-type :directed)
513 (add-edge-between-vertexes g :w :z :edge-type :directed)
515 (map-over-all-combinations-of-k-vertexes
518 (lambda (vertex-list)
519 (let ((graph-from-vertexes (make-graph-from-vertexes vertex-list)))
520 (when (mst-kruskal graph-from-vertexes #'identity-sorter)
521 (push graph-from-vertexes result)))))
525 ;;; todo: merge these two defs
527 (defmethod map-over-all-combinations-of-k-edges ((graph basic-graph) k fn)
528 (let* ((edge-count (edge-count graph))
529 (symbols (make-list k :initial-element edge-count))
530 (edges (edges graph)))
532 (iterate-over-indexes
534 (lambda (edge-indexes)
535 (when (apply #'< edge-indexes)
536 (funcall fn (mapcar (lambda (edge-index)
537 (nth-element edges edge-index))
541 (defmethod map-over-all-combinations-of-k-edges ((vertex basic-vertex) k fn)
542 (let* ((edge-count (edge-count vertex))
543 (symbols (make-list k :initial-element edge-count))
544 (edges (edges vertex)))
546 (iterate-over-indexes
548 (lambda (edge-indexes)
549 (when (apply #'< edge-indexes)
550 (funcall fn (mapcar (lambda (edge-index)
551 (nth-element edges edge-index))
555 (map-over-all-combinations-of-k-edges
556 (generate-undirected-graph-via-verex-probabilities
557 *random-generator* 'graph-container
560 #2A((0.2 0.1) (nil 0.2))
562 (form-keyword "H" (format nil "~2,'0D~4,'0D" kind count))))
567 (format t "~A -- ~A " (element (vertex-1 e)) (element (vertex-2 e))))
574 ;;; ***************************************************************************
576 ;;; ***************************************************************************