From 3165cba36e6f8c3a7f3f1051f1c4880aaa14466d Mon Sep 17 00:00:00 2001 From: Gary King Date: Tue, 15 Mar 2011 20:47:08 -0400 Subject: [PATCH] fix bug in DFS, added rooted-dfs, improved docstring for find-vertex-between-edges-if Once again, all thanks are due to Robert Goldman! --- dev/api.lisp | 9 +- dev/graph-algorithms.lisp | 218 ++++++++++++++++++++++++++------------------- dev/package.lisp | 3 +- 3 files changed, 132 insertions(+), 98 deletions(-) diff --git a/dev/api.lisp b/dev/api.lisp index f5d836c..332b881 100644 --- a/dev/api.lisp +++ b/dev/api.lisp @@ -622,10 +622,11 @@ as a source. [?? Could be a defun].")) (defgeneric find-edge-between-vertexes-if (graph value-or-vertex-1 value-or-vertex-2 fn &key error-if-not-found?) - (:documentation "Finds and returns an edge between value-or-vertex-1 - and value-or-vertex-2 if one exists. Unless error-if-not-found? is - nil, then a error will be signaled. [?? Error not signal, need - test.]")) + (:documentation + "Finds and returns an edge between value-or-vertex-1 +and value-or-vertex-2 which returns true (as a generalized boolean) when +evaluated by `fn`. Unless error-if-not-found? is nil, then a error will +be signaled. [?? IS error really signaled? need a test.]")) (defgeneric vertices-share-edge-p (vertex-1 vertex-2) (:documentation "Return true if vertex-1 and vertex-2 are connected diff --git a/dev/graph-algorithms.lisp b/dev/graph-algorithms.lisp index da610ce..8a83636 100644 --- a/dev/graph-algorithms.lisp +++ b/dev/graph-algorithms.lisp @@ -10,11 +10,11 @@ (defmethod initialize-vertex-data ((graph basic-graph)) (let ((vertex-data (make-container 'simple-associative-container))) - (iterate-vertexes graph (lambda (v) - (setf (item-at vertex-data v) + (iterate-vertexes graph (lambda (v) + (setf (item-at vertex-data v) (make-vertex-datum :color :white)))) (values vertex-data))) - + ;;; breadth-first-search by GWK (defmethod breadth-first-visitor ((graph basic-graph) (source t) fn) @@ -25,12 +25,12 @@ ;; initialize (let ((vertex-data (initialize-vertex-data graph)) (queue (make-container 'basic-queue))) - + (let ((source-datum (item-at vertex-data source))) (setf (node-color source-datum) :grey (node-depth source-datum) 0) (enqueue queue source) - + (loop until (empty-p queue) do (let* ((current-vertex (first-item queue)) (current (item-at vertex-data current-vertex))) @@ -44,11 +44,11 @@ (node-depth child) (1+ (node-depth current)) (node-parent child) current-vertex) (enqueue queue child-vertex))))) - + (dequeue queue) (setf (node-color current) :black) (funcall fn current-vertex))) - + vertex-data))) @@ -60,12 +60,12 @@ ;; initialize (let ((vertex-data (initialize-vertex-data graph)) (queue (make-container 'basic-queue))) - + (let ((source-datum (item-at vertex-data source))) (setf (node-color source-datum) :grey (node-depth source-datum) 0) (enqueue queue source) - + (loop until (empty-p queue) do (let* ((current-vertex (first-item queue)) (current (item-at vertex-data current-vertex))) @@ -79,12 +79,12 @@ (node-depth child) (1+ (node-depth current)) (node-parent child) current-vertex) (enqueue queue child-vertex))))) - + (dequeue queue) (setf (node-color current) :black))) - + vertex-data))) - + ;;; single-source-shortest-paths - gwk #+NotYet @@ -102,9 +102,9 @@ (iterate-vertexes graph (lambda (v) (insert-item union v))) - (iterate-edges - graph - (lambda (e) + (iterate-edges + graph + (lambda (e) (let ((node-1 (representative-node union (vertex-1 e))) (node-2 (representative-node union (vertex-2 e)))) (unless (eq (find-set node-1) (find-set node-2)) @@ -115,25 +115,25 @@ (defmethod connected-component-count ((graph basic-graph)) ;;?? Gary King 2005-11-28: Super ugh - (size + (size (remove-duplicates - (collect-elements + (collect-elements (connected-components graph) :transform #'parent))) - + #+Fails ;;?? Gary King 2005-11-28: fails on big graphs? iterator design ;;?? Gary King 2005-11-28: ideally we don't want to cons up the list at all - (size + (size (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 + :transform (lambda (component) - (subgraph-containing graph (element component) + (subgraph-containing graph (element component) :depth most-positive-fixnum)))) #+Alternate @@ -146,14 +146,14 @@ (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))))) - + result)) - + ;;; minimum-spanning-tree based on kruskal's algorithm detailed in clrs2 -jjm (defmethod mst-find-set ((vertex basic-vertex)) @@ -185,13 +185,13 @@ ;;; 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) +(defmethod add-edges-to-graph ((graph basic-graph) (edges list) &key (if-duplicate-do :ignore)) (iterate-elements edges (lambda (edge) (let ((v1 (element (source-vertex edge))) - (v2 (element (target-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) @@ -213,19 +213,19 @@ ;;; minumum spanning tree -(defmethod minimum-spanning-tree ((graph basic-graph) +(defmethod minimum-spanning-tree ((graph basic-graph) &key (edge-sorter #'edge-lessp-by-weight)) (let ((result nil)) - (iterate-vertexes + (iterate-vertexes graph (lambda (v) (mst-make-set v))) - + (loop for edge in (sort (edges graph) edge-sorter) do (let ((v1 (source-vertex edge)) (v2 (target-vertex edge))) - + (unless (eq (mst-find-set v1) (mst-find-set v2)) (push edge result) @@ -238,29 +238,29 @@ #+ignore ;;; shoot -(defmethod minimum-spanning-tree ((vertex-list list) +(defmethod minimum-spanning-tree ((vertex-list list) &key (edge-sorter #'edge-lessp-by-weight)) (let ((result nil) - (v-edges (remove-duplicates + (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 (let ((v1 (source-vertex edge)) - (v2 (target-vertex edge)) - (v1-set (mst-find-set v1)) - (v2-set (mst-find-set v2))) + (v2 (target-vertex edge)) + (v1-set (mst-find-set v1)) + (v2-set (mst-find-set v2))) (when (or (not v1-set) (not v2-set)) (return-from minimum-spanning-tree nil)) - - + + (unless (eq (mst-find-set v1) (mst-find-set v2)) (push edge result) @@ -273,11 +273,11 @@ ;;; uses mst to determine if the graph is connected -(defmethod connected-graph-p ((graph basic-graph) &key +(defmethod connected-graph-p ((graph basic-graph) &key (edge-sorter 'edge-lessp-by-weight)) (minimum-spanning-tree graph :edge-sorter edge-sorter)) - + #+test (let ((g (make-container 'graph-container))) @@ -292,7 +292,7 @@ :if-duplicate-do :force) (minimum-spanning-tree g)) -;;; GWK's implementation of kruskal's - slightly faster, but it doesn't return +;;; 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 @@ -301,7 +301,7 @@ (let ((a nil) (union (make-container 'union-find-container)) (edges (sort (edges graph) #'< :key weight))) - (iterate-vertexes + (iterate-vertexes graph (lambda (v) (insert-item union v))) (dolist (edge edges) (let ((node-1 (representative-node union (vertex-1 edge))) @@ -309,7 +309,7 @@ (unless (eq (find-set node-1) (find-set node-2)) (graft-nodes node-1 node-2) (push edge a)))) - + (values a))) @@ -317,11 +317,11 @@ (loop for f in '(mst-kruskal minimum-spanning-tree-kruskal) do (fluid-bind (((random-seed *random-generator*) 1)) (bind ((g (generate-undirected-graph-via-vertex-probabilities - *random-generator* (make-instance 'graph-container :default-edge-type :directed) + *random-generator* (make-instance 'graph-container :default-edge-type :directed) 100 - #(0.8 0.2) + #(0.8 0.2) #2A((0.2 0.1) (nil 0.2)) - (lambda (kind count) + (lambda (kind count) (form-keyword "H" (format nil "~2,'0D~4,'0D" kind count)))) )) (timeit (:report :values) @@ -332,7 +332,7 @@ ;;; 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 @@ -367,8 +367,8 @@ (t nil))) ;;; depth-first-search - -(defmethod dfs ((graph basic-graph) (root t) fn &key + +(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)) @@ -376,55 +376,88 @@ (defmethod dfs ((graph basic-graph) (root basic-vertex) fn &key (out-edge-sorter #'edge-lessp-by-direction)) (setf *depth-first-search-timer* -1) - - (iterate-vertexes + + (iterate-vertexes graph (lambda (v) (setf (color v) :white (previous-node v) nil (discovery-time v) -1 (finish-time v) -1))) - + (iterate-edges graph (lambda (e) (setf (color e) nil))) - - (loop with vl = (remove root (vertexes graph) :test #'eql) - for v in (push root vl) do - (when (eql (color v) :white) - (dfs-visit graph v fn out-edge-sorter))) - + + (loop for v in (cons root (remove root (vertexes graph) :test #'eql)) + when (eql (color v) :white) + do (dfs-visit graph v fn out-edge-sorter)) + (values (sort (copy-list (vertexes graph)) #'< :key #'finish-time) graph)) +(defgeneric rooted-dfs (graph root fn &key out-edge-sorter) + (:documentation "A variant of DFS that does not visit nodes that are +unreachable from the ROOT.") + (:method ((graph basic-graph) (root t) fn &key + (out-edge-sorter #'edge-lessp-by-direction)) + (rooted-dfs graph (find-vertex graph root) fn :out-edge-sorter out-edge-sorter)) + (:method ((graph basic-graph) (root basic-vertex) fn &key + (out-edge-sorter #'edge-lessp-by-direction)) + (setf *depth-first-search-timer* -1) + + (iterate-vertexes + graph + (lambda (v) + (setf (color v) :white + (previous-node v) nil + (discovery-time v) -1 + (finish-time v) -1))) + + (iterate-edges + graph + (lambda (e) + (setf (color e) nil))) + + (dfs-visit graph root fn out-edge-sorter) + + (values + (sort (remove-if #'(lambda (v) (eq (color v) :white)) + (vertexes graph)) + #'< :key #'finish-time) + graph))) + (defmethod dfs-visit ((graph graph-container) (u basic-vertex) fn sorter) - - + + (incf *depth-first-search-timer*) + ;; the following should be removed later for efficiency [2011/03/10:rpg] + (unless (eq (color u) :white) + (error "precondition for DFS-VISIT violated.")) (setf (color u) :gray (discovery-time u) *depth-first-search-timer*) - - + ;; moved the funcall up here, fixing a boundary condition where the + ;; function was never called on root nodes. [2011/03/10:rpg] + (funcall fn u) + (loop for edge in (sort (collect-elements (edges u) :filter (lambda (e) - (out-edge-for-vertex-p e u))) sorter) do - (let ((v (other-vertex edge u))) - - (unless (color edge) - (setf (color edge) (color v))) - - (when (eql (color v) :white) + (out-edge-for-vertex-p e u))) sorter) + as v = (other-vertex edge u) + unless (color edge) + do (setf (color edge) (color v)) + when (eql (color v) :white) + do (setf (previous-node v) u) - (funcall fn v) - (dfs-visit graph v fn sorter)))) - + (dfs-visit graph v fn sorter)) + (incf *depth-first-search-timer*) - + (setf (color u) :black (finish-time u) *depth-first-search-timer*)) @@ -441,8 +474,7 @@ (add-edge-between-vertexes g :w :z :edge-type :directed) (add-edge-between-vertexes g :z :z :edge-type :directed :if-duplicate-do :force) - (print (mapcar #'element (dfs g :u #'identity))) - (assert (equal '(:x :y :v :u :z :w) + (assert (equal '(:X :Y :V :U :Z :W) (mapcar #'element (dfs g :u #'identity))))) @@ -492,8 +524,8 @@ (defmethod map-over-all-combinations-of-k-vertexes ((graph basic-graph) k fn) (let* ((vertex-count (size graph)) (symbols (make-list k :initial-element vertex-count)) - (vertexes (vertexes graph))) - (iterate-over-indexes + (vertexes (vertexes graph))) + (iterate-over-indexes symbols (lambda (vertex-indexes) (when (apply #'< vertex-indexes) @@ -512,8 +544,8 @@ (add-edge-between-vertexes g :y :x :edge-type :directed) (add-edge-between-vertexes g :w :y :edge-type :directed) (add-edge-between-vertexes g :w :z :edge-type :directed) - - (map-over-all-combinations-of-k-vertexes + + (map-over-all-combinations-of-k-vertexes g 4 (lambda (vertex-list) @@ -522,15 +554,15 @@ (push graph-from-vertexes result))))) result) -;;; over edges +;;; over edges ;;; todo: merge these two defs (defmethod map-over-all-combinations-of-k-edges ((graph basic-graph) k fn) (let* ((edge-count (edge-count graph)) (symbols (make-list k :initial-element edge-count)) - (edges (edges graph))) + (edges (edges graph))) (print symbols) - (iterate-over-indexes + (iterate-over-indexes symbols (lambda (edge-indexes) (when (apply #'< edge-indexes) @@ -541,10 +573,10 @@ (defmethod map-over-all-combinations-of-k-edges ((vertex basic-vertex) k fn) (let* ((edge-count (edge-count vertex)) - (symbols (make-list k :initial-element edge-count)) - (edges (edges vertex))) + (symbols (make-list k :initial-element edge-count)) + (edges (edges vertex))) ;(print symbols) - (iterate-over-indexes + (iterate-over-indexes symbols (lambda (edge-indexes) (when (apply #'< edge-indexes) @@ -553,15 +585,15 @@ edge-indexes))))))) #+test -(map-over-all-combinations-of-k-edges +(map-over-all-combinations-of-k-edges (generate-undirected-graph-via-verex-probabilities - *random-generator* 'graph-container + *random-generator* 'graph-container 10 - #(0.8 0.2) + #(0.8 0.2) #2A((0.2 0.1) (nil 0.2)) - (lambda (kind count) + (lambda (kind count) (form-keyword "H" (format nil "~2,'0D~4,'0D" kind count)))) - 2 + 2 (lambda (es) (format t "~%") (mapc (lambda (e) @@ -574,4 +606,4 @@ ;;; *************************************************************************** ;;; * End of File * -;;; *************************************************************************** +;;; *************************************************************************** \ No newline at end of file diff --git a/dev/package.lisp b/dev/package.lisp index 45d89b9..83e707f 100644 --- a/dev/package.lisp +++ b/dev/package.lisp @@ -146,7 +146,8 @@ DISCUSSION #:edge-lessp-by-direction #:out-edge-for-vertex-p #:dfs - + #:rooted-dfs + ;;; minimum-spanning-tree #+Ignore #:add-edges-to-graph -- 1.7.10.4