Detect *all* cycles during topological sort
Previously the cycle detection was limited to detecting when we hit
a currently-being-visited node during a traversal. So something like this would
be correctly found:
A --> B --> C
^ |
| |
+-----+
We start at the root (A), go to B, then to C, then to B, and detect that we're
still working on B and signal the error.
But this doesn't find all cycles, because we *start* at the root nodes, and if
a cycle doesn't have any outcropping branches we'll never reach it at all. For
example:
A --> B
^ |
| |
+-----+
This graph has no roots, so we incorrectly ignore the cycle.
This patch fixes the problem by keeping a count of visited nodes and and making
sure it matches the digraph's size at the end.
Fixes https://github.com/sjl/cl-digraph/issues/4
| author |
Steve Losh <steve@stevelosh.com> |
| date |
Mon, 14 Dec 2020 20:13:51 -0500 |
| parents |
950037917ec4
|
| children |
3443da60edaa
|
| branches/tags |
v1.3.2 |
| files |
cl-digraph.asd docs/05-changelog.markdown src/directed-graph.lisp test/tests.lisp |
Changes
--- a/cl-digraph.asd Mon Dec 14 19:59:00 2020 -0500
+++ b/cl-digraph.asd Mon Dec 14 20:13:51 2020 -0500
@@ -4,7 +4,7 @@
:homepage "http://docs.stevelosh.com/cl-digraph/"
:license "MIT/X11"
- :version "1.3.1"
+ :version "1.3.2"
:depends-on ()
--- a/docs/05-changelog.markdown Mon Dec 14 19:59:00 2020 -0500
+++ b/docs/05-changelog.markdown Mon Dec 14 20:13:51 2020 -0500
@@ -5,6 +5,12 @@
[TOC]
+v1.3.2
+------
+
+[Fixed a bug](https://github.com/sjl/cl-digraph/issues/4) where certain kinds of
+cycles were not correctly detected during topological sorting.
+
v1.3.1
------
--- a/src/directed-graph.lisp Mon Dec 14 19:59:00 2020 -0500
+++ b/src/directed-graph.lisp Mon Dec 14 20:13:51 2020 -0500
@@ -405,6 +405,7 @@
(vertices digraph)))
+(declaim (inline topological-sort%))
(defun topological-sort% (function digraph)
(let ((status (make-hash-table-portably
:test (digraph-test digraph)
@@ -437,9 +438,12 @@
An error will be signaled if the graph contains a cycle.
"
- (let ((result nil))
- (topological-sort% (lambda (v) (push v result)) digraph)
- (nreverse result)))
+ (let ((result nil)
+ (i 0))
+ (topological-sort% (lambda (v) (incf i) (push v result)) digraph)
+ (if (= i (count-vertices digraph)) ; make sure there are no rootless cycles
+ (nreverse result)
+ (error "Cycle detected during topological sort."))))
(defun reachablep (digraph start target &key (strategy :breadth-first))
@@ -464,39 +468,3 @@
(funcall traverse check digraph start)
nil))
-
-;;;; Scratch ------------------------------------------------------------------
-(defun make-test-digraph ()
- ;; a ----> middle ----> z ORPHAN
- ;; ^ ^ ^
- ;; | | |
- ;; B ---------+ |
- ;; | | +-------------------+
- ;; v | | v
- ;; c --------> dogs FOO ----> bar ----> baz
- ;; ^ |
- ;; | |
- ;; +------------------------+
- (let ((g (make-digraph
- :initial-vertices
- '(a b c dogs middle z orphan foo bar baz))))
- (insert-edge g 'a 'middle)
- (insert-edge g 'b 'middle)
- (insert-edge g 'b 'a)
- (insert-edge g 'middle 'z)
- ; (insert-edge g 'z 'z)
- (insert-edge g 'b 'c)
- (insert-edge g 'c 'dogs)
- (insert-edge g 'dogs 'middle)
- ; (insert-edge g 'dogs 'c)
- (insert-edge g 'foo 'baz)
- (insert-edge g 'foo 'bar)
- (insert-edge g 'bar 'baz)
- g))
-
-
-#+scratch
-(progn
- (defparameter *d* (make-test-digraph))
- (setf cl-dot:*dot-path* "/usr/local/bin/dot")
- (digraph.dot:draw *d*))
--- a/test/tests.lisp Mon Dec 14 19:59:00 2020 -0500
+++ b/test/tests.lisp Mon Dec 14 20:13:51 2020 -0500
@@ -252,3 +252,22 @@
(is (null (arbitrary-vertex g)))
(insert-vertex g 'new)
(is (member (arbitrary-vertex g) '(new)))))
+
+
+(define-test topological-sort-cycle-detection
+ (let ((g (make-digraph :initial-vertices '(a b c d))))
+ (is (= 4 (length (topological-sort g))))
+ (insert-edge g 'a 'b)
+ (is (= 4 (length (topological-sort g))))
+ (insert-edge g 'b 'c)
+ (is (= 4 (length (topological-sort g))))
+ (insert-edge g 'c 'a)
+ (signals error (topological-sort g))
+ (remove-edge g 'c 'a)
+ (insert-edge g 'd 'd)
+ (signals error (topological-sort g))
+ (remove-edge g 'd 'd)
+ (insert-edge g 'c 'd)
+ (is (= 4 (length (topological-sort g))))
+ (insert-edge g 'd 'b)
+ (signals error (topological-sort g))))