# HG changeset patch
# User Steve Losh <steve@stevelosh.com>
# Date 1607994831 18000
# Node ID 884333cfb6fb9bb90258da9204ae14af85faafcf
# Parent  950037917ec4611ae6357c4e1d6fcf0d0bb0ce71
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

diff -r 950037917ec4 -r 884333cfb6fb cl-digraph.asd
--- 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 ()
 
diff -r 950037917ec4 -r 884333cfb6fb docs/05-changelog.markdown
--- 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
 ------
 
diff -r 950037917ec4 -r 884333cfb6fb src/directed-graph.lisp
--- 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*))
diff -r 950037917ec4 -r 884333cfb6fb test/tests.lisp
--- 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))))