X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=dev%2Fgraph-algorithms.lisp;h=d84a799d89a05588300e3449274db07311486501;hb=6dae43e4ee011ea0ef4fedeae7c2a492823a9812;hp=9ee37a87b34b33a4c849d452a2e900db632370d6;hpb=438d1e0593dc62fe7b975a5865ec27955afcb7a1;p=cl-graph.git diff --git a/dev/graph-algorithms.lisp b/dev/graph-algorithms.lisp index 9ee37a8..d84a799 100644 --- a/dev/graph-algorithms.lisp +++ b/dev/graph-algorithms.lisp @@ -1,15 +1,12 @@ -(in-package metabang.graph) +(in-package #:metabang.graph) -;;; --------------------------------------------------------------------------- ;;; -;;; --------------------------------------------------------------------------- -(defstruct (vertex-datum (:conc-name "NODE-") (:type list)) +(defstruct (vertex-datum (:conc-name node-) (:type list)) (color nil) (depth most-positive-fixnum) (parent nil)) -;;; --------------------------------------------------------------------------- (defmethod initialize-vertex-data ((graph basic-graph)) (let ((vertex-data (make-container 'simple-associative-container))) @@ -18,14 +15,11 @@ (make-vertex-datum :color :white)))) (values vertex-data))) -;;; --------------------------------------------------------------------------- ;;; breadth-first-search by GWK -;;; --------------------------------------------------------------------------- (defmethod breadth-first-visitor ((graph basic-graph) (source t) fn) (breadth-first-visitor graph (find-vertex graph source) fn)) -;;; --------------------------------------------------------------------------- (defmethod breadth-first-visitor ((graph basic-graph) (source basic-vertex) fn) ;; initialize @@ -57,12 +51,10 @@ vertex-data))) -;;; --------------------------------------------------------------------------- (defmethod breadth-first-search-graph ((graph basic-graph) (source t)) (breadth-first-search-graph graph (find-vertex graph source))) -;;; --------------------------------------------------------------------------- (defmethod breadth-first-search-graph ((graph basic-graph) (source basic-vertex)) ;; initialize @@ -93,9 +85,7 @@ vertex-data))) -;;; --------------------------------------------------------------------------- ;;; single-source-shortest-paths - gwk -;;; --------------------------------------------------------------------------- #+NotYet (defmethod single-source-shortest-paths ((graph basic-graph)) @@ -105,9 +95,7 @@ (setf (node-depth source-datum) 0)) )) -;;; --------------------------------------------------------------------------- ;;; connected-components - gwk -;;; --------------------------------------------------------------------------- (defmethod connected-components ((graph basic-graph)) (let ((union (make-container 'union-find-container))) @@ -124,7 +112,6 @@ (iterate-elements union 'find-set) union)) -;;; --------------------------------------------------------------------------- (defmethod connected-component-count ((graph basic-graph)) ;;?? Gary King 2005-11-28: Super ugh @@ -141,15 +128,13 @@ (collect-elements (make-iterator (connected-components graph) :unique t :transform #'parent)))) -;;; --------------------------------------------------------------------------- - (defmethod find-connected-components ((graph basic-graph)) (collect-elements (make-iterator (connected-components graph) :unique t :transform #'parent) :transform (lambda (component) (subgraph-containing graph (element component) - most-positive-fixnum)))) + :depth most-positive-fixnum)))) #+Alternate (defmethod find-connected-components ((graph basic-graph)) @@ -161,8 +146,7 @@ (let ((element (element (parent component)))) (unless (item-at found-elements element) (setf (item-at found-elements element) t) - - (push (subgraph-containing graph (element component) + (push (subgraph-containing graph (element component) most-positive-fixnum) result))))) @@ -170,9 +154,7 @@ -;;; --------------------------------------------------------------------------- ;;; minimum-spanning-tree based on kruskal's algorithm detailed in clrs2 -jjm -;;; --------------------------------------------------------------------------- (defmethod mst-find-set ((vertex basic-vertex)) #+ignore @@ -182,18 +164,15 @@ (setf (previous-node vertex) (mst-find-set (previous-node vertex)))) (previous-node vertex)) -;;; --------------------------------------------------------------------------- (defmethod mst-make-set ((vertex basic-vertex)) (setf (previous-node vertex) vertex (rank vertex) 0)) -;;; --------------------------------------------------------------------------- (defmethod mst-tree-union ((v1 basic-vertex) (v2 basic-vertex)) (mst-link (mst-find-set v1) (mst-find-set v2))) -;;; --------------------------------------------------------------------------- (defmethod mst-link ((v1 basic-vertex) (v2 basic-vertex)) (cond ((> (rank v1) (rank v2)) @@ -202,19 +181,17 @@ (when (= (rank v1) (rank v2)) (incf (rank v2)))))) -;;; --------------------------------------------------------------------------- ;;; jjm's implementation of mst depends on this ;;; todo - figure out some what to add and edge we create to a graph rather ;;; than always using add-edge-between-vertexes interface -;;; --------------------------------------------------------------------------- (defmethod add-edges-to-graph ((graph basic-graph) (edges list) &key (if-duplicate-do :ignore)) (iterate-elements edges (lambda (edge) - (bind ((v1 (element (source-vertex edge))) - (v2 (element (target-vertex edge)))) + (let ((v1 (element (source-vertex edge))) + (v2 (element (target-vertex edge)))) (add-edge-between-vertexes graph v1 v2 :edge-class (type-of edge) :edge-type (if (directed-edge-p edge) @@ -229,67 +206,24 @@ :if-duplicate-do if-duplicate-do)))) graph) -;;; --------------------------------------------------------------------------- -;;; for completeness -;;; --------------------------------------------------------------------------- - -(defmethod make-graph-from-vertexes ((vertex-list list)) - (bind ((edges-to-keep nil) - (g (copy-template (graph (first vertex-list))))) - - (iterate-elements - vertex-list - (lambda (v) - (add-vertex g (element v)) - (iterate-elements - (edges v) - (lambda (e) - (when (and (member (vertex-1 e) vertex-list) - (member (vertex-2 e) vertex-list)) - (pushnew e edges-to-keep :test #'eq)))))) - - (iterate-elements - edges-to-keep - (lambda (e) - (bind ((v1 (source-vertex e)) - (v2 (target-vertex e))) - ;;?? can we use copy here... - (add-edge-between-vertexes - g (element v1) (element v2) - :edge-type (if (directed-edge-p e) - :directed - :undirected) - :if-duplicate-do :force - :edge-class (type-of e) - :value (value e) - :edge-id (edge-id e) - :element (element e) - :tag (tag e) - :graph g - :color (color e))))) - g)) - -;;; --------------------------------------------------------------------------- (defmethod edge-lessp-by-weight ((e1 basic-edge) (e2 basic-edge)) (< (weight e1) (weight e2))) -;;; --------------------------------------------------------------------------- ;;; minumum spanning tree -;;; --------------------------------------------------------------------------- (defmethod minimum-spanning-tree ((graph basic-graph) &key (edge-sorter #'edge-lessp-by-weight)) - (bind ((result nil)) + (let ((result nil)) (iterate-vertexes graph (lambda (v) (mst-make-set v))) (loop for edge in (sort (edges graph) edge-sorter) do - (bind ((v1 (source-vertex edge)) + (let ((v1 (source-vertex edge)) (v2 (target-vertex edge))) (unless (eq (mst-find-set v1) @@ -302,28 +236,25 @@ (values t result)) (t (values nil result))))))) -;;; --------------------------------------------------------------------------- -#+ignore ;;; shit +#+ignore ;;; shoot (defmethod minimum-spanning-tree ((vertex-list list) &key (edge-sorter #'edge-lessp-by-weight)) - (bind ((result nil) + (let ((result nil) (v-edges (remove-duplicates (flatten (mapcar #'edges vertex-list)) :test #'eq))) (iterate-container vertex-list (lambda (v) - (mst-make-set v))) - - + (mst-make-set v))) (loop for edge in (sort v-edges edge-sorter) do - (bind ((v1 (source-vertex edge)) - (v2 (target-vertex edge)) - (v1-set (mst-find-set v1)) - (v2-set (mst-find-set v2))) + (let ((v1 (source-vertex edge)) + (v2 (target-vertex edge)) + (v1-set (mst-find-set v1)) + (v2-set (mst-find-set v2))) (when (or (not v1-set) (not v2-set)) @@ -340,19 +271,16 @@ (values t result)) (t (values nil result))))))) -;;; --------------------------------------------------------------------------- ;;; uses mst to determine if the graph is connected -;;; --------------------------------------------------------------------------- (defmethod connected-graph-p ((graph basic-graph) &key (edge-sorter 'edge-lessp-by-weight)) (minimum-spanning-tree graph :edge-sorter edge-sorter)) -;;; --------------------------------------------------------------------------- #+test -(bind ((g (make-container 'graph-container))) +(let ((g (make-container 'graph-container))) (add-edge-between-vertexes g :v :y :edge-type :directed) (add-edge-between-vertexes g :u :x :edge-type :directed) (add-edge-between-vertexes g :x :v :edge-type :directed) @@ -364,11 +292,9 @@ :if-duplicate-do :force) (minimum-spanning-tree g)) -;;; --------------------------------------------------------------------------- ;;; GWK's implementation of kruskal's - slightly faster, but it doesn't return ;;; a tree (still faster even if it does). Will decide later if which to use ;;; ignoring for now -jjm -;;; --------------------------------------------------------------------------- #+not-yet (defmethod minimum-spanning-tree ((graph basic-graph) &key (weight 'weight)) @@ -386,7 +312,6 @@ (values a))) -;;; --------------------------------------------------------------------------- #+test (loop for f in '(mst-kruskal minimum-spanning-tree-kruskal) do @@ -405,26 +330,18 @@ (declare (ignore a b)) 0))))))) -;;; --------------------------------------------------------------------------- ;;; end minimum spanning tree -;;; --------------------------------------------------------------------------- -;;; --------------------------------------------------------------------------- ;;; depth-first-search - clrs2 ;;; todo - figure out how to name this depth-first-search, which is already ;;; defined in search.lisp -;;; --------------------------------------------------------------------------- -;;; --------------------------------------------------------------------------- ;;; should probably make this special -;;; --------------------------------------------------------------------------- (defparameter *depth-first-search-timer* -1) -;;; --------------------------------------------------------------------------- ;;; undirected edges are less than edges that are directed -;;; --------------------------------------------------------------------------- #+ignore ;;; incorrect, methinks - jjm (defmethod edge-lessp-by-direction ((e1 basic-edge) (e2 basic-edge)) @@ -438,7 +355,6 @@ (defmethod edge-lessp-by-direction ((e1 basic-edge) (e2 basic-edge)) (and (undirected-edge-p e1) (directed-edge-p e2))) -;;; --------------------------------------------------------------------------- (defmethod out-edge-for-vertex-p ((edge basic-edge) (vertex basic-vertex)) (cond ((and (directed-edge-p edge) @@ -450,15 +366,12 @@ t) (t nil))) -;;; --------------------------------------------------------------------------- ;;; depth-first-search -;;; --------------------------------------------------------------------------- (defmethod dfs ((graph basic-graph) (root t) fn &key (out-edge-sorter #'edge-lessp-by-direction)) (dfs graph (find-vertex graph root) fn :out-edge-sorter out-edge-sorter)) -;;; --------------------------------------------------------------------------- (defmethod dfs ((graph basic-graph) (root basic-vertex) fn &key (out-edge-sorter #'edge-lessp-by-direction)) @@ -486,7 +399,6 @@ (sort (copy-list (vertexes graph)) #'< :key #'finish-time) graph)) -;;; --------------------------------------------------------------------------- (defmethod dfs-visit ((graph graph-container) (u basic-vertex) fn sorter) @@ -501,7 +413,7 @@ (edges u) :filter (lambda (e) (out-edge-for-vertex-p e u))) sorter) do - (bind ((v (other-vertex edge u))) + (let ((v (other-vertex edge u))) (unless (color edge) (setf (color edge) (color v))) @@ -516,12 +428,10 @@ (setf (color u) :black (finish-time u) *depth-first-search-timer*)) -;;; --------------------------------------------------------------------------- ;;; from clrs2 -;;; --------------------------------------------------------------------------- #+test -(bind ((g (make-container 'graph-container))) +(let ((g (make-container 'graph-container))) (add-edge-between-vertexes g :v :y :edge-type :directed) (add-edge-between-vertexes g :u :x :edge-type :directed) (add-edge-between-vertexes g :x :v :edge-type :directed) @@ -534,19 +444,15 @@ (assert (equal '(:X :Y :V :U :Z :W) (mapcar #'element (dfs g :u #'identity))))) -;;; --------------------------------------------------------------------------- (defmethod dfs-tree-edge-p ((edge graph-container-edge)) (eql (color edge) :white)) -;;; --------------------------------------------------------------------------- (defmethod dfs-back-edge-p ((edge graph-container-edge)) (eql (color edge) :gray)) -;;; --------------------------------------------------------------------------- ;;; not correct - has to look at combination of discovery-time and finish-time -;;; --------------------------------------------------------------------------- (defmethod dfs-forward-edge-p ((edge graph-container-edge)) (warn "implementation is not correct.") @@ -555,9 +461,7 @@ (< (discovery-time (source-vertex edge)) (discovery-time (target-vertex edge))))) -;;; --------------------------------------------------------------------------- ;;; not correct - has to look at combination of discovery-time and finish-time -;;; --------------------------------------------------------------------------- (defmethod dfs-cross-edge-p ((edge graph-container-edge)) (warn "implementation is not correct.") @@ -566,7 +470,6 @@ (> (discovery-time (source-vertex edge)) (discovery-time (target-vertex edge))))) -;;; --------------------------------------------------------------------------- (defmethod dfs-edge-type ((edge graph-container-edge)) (cond ((dfs-tree-edge-p edge) @@ -579,20 +482,14 @@ :cross) (t nil))) -;;; --------------------------------------------------------------------------- ;;; end dfs -;;; --------------------------------------------------------------------------- -;;; --------------------------------------------------------------------------- ;;; mapping functions -;;; --------------------------------------------------------------------------- -;;; --------------------------------------------------------------------------- ;;; over vertexes -;;; --------------------------------------------------------------------------- (defmethod map-over-all-combinations-of-k-vertexes ((graph basic-graph) k fn) - (bind ((vertex-count (size graph)) + (let* ((vertex-count (size graph)) (symbols (make-list k :initial-element vertex-count)) (vertexes (vertexes graph))) (iterate-over-indexes @@ -603,10 +500,9 @@ (nth-element vertexes vertex-index)) vertex-indexes))))))) -;;; --------------------------------------------------------------------------- #+test -(bind ((result nil) +(let ((result nil) (g (make-container 'graph-container))) (add-edge-between-vertexes g :u :v :edge-type :directed) (add-edge-between-vertexes g :u :x :edge-type :directed) @@ -620,18 +516,16 @@ g 4 (lambda (vertex-list) - (bind ((graph-from-vertexes (make-graph-from-vertexes vertex-list))) + (let ((graph-from-vertexes (make-graph-from-vertexes vertex-list))) (when (mst-kruskal graph-from-vertexes #'identity-sorter) (push graph-from-vertexes result))))) result) -;;; --------------------------------------------------------------------------- ;;; over edges ;;; todo: merge these two defs -;;; --------------------------------------------------------------------------- (defmethod map-over-all-combinations-of-k-edges ((graph basic-graph) k fn) - (bind ((edge-count (edge-count graph)) + (let* ((edge-count (edge-count graph)) (symbols (make-list k :initial-element edge-count)) (edges (edges graph))) (print symbols) @@ -643,13 +537,12 @@ (nth-element edges edge-index)) edge-indexes))))))) -;;; --------------------------------------------------------------------------- (defmethod map-over-all-combinations-of-k-edges ((vertex basic-vertex) k fn) - (bind ((edge-count (edge-count vertex)) - (symbols (make-list k :initial-element edge-count)) - (edges (edges vertex))) - (print symbols) + (let* ((edge-count (edge-count vertex)) + (symbols (make-list k :initial-element edge-count)) + (edges (edges vertex))) + ;(print symbols) (iterate-over-indexes symbols (lambda (edge-indexes) @@ -657,7 +550,6 @@ (funcall fn (mapcar (lambda (edge-index) (nth-element edges edge-index)) edge-indexes))))))) -;;; --------------------------------------------------------------------------- #+test (map-over-all-combinations-of-k-edges