~ chicken-core (chicken-5) 9247cec3930849e6570a18333739b9733daed2ce

commit 9247cec3930849e6570a18333739b9733daed2ce
Author:     Moritz Heidkamp <moritz@twoticketsplease.de>
AuthorDate: Sun Mar 3 13:28:20 2013 +0100
Commit:     felix <felix@call-with-current-continuation.org>
CommitDate: Fri May 10 10:41:48 2013 +0200

    Reimplement topological-sort with cycle detection.
    
    Signed-off-by: felix <felix@call-with-current-continuation.org>

diff --git a/data-structures.scm b/data-structures.scm
index 56944ec0..54089249 100644
--- a/data-structures.scm
+++ b/data-structures.scm
@@ -707,52 +707,49 @@
 	(sort! (append seq '()) less?)))
 
 
-;;;  Simple topological sort:
-;
-; Taken from SLIB (slightly adapted): Copyright (C) 1995 Mikael Djurfeldt
+;;; Topological sort with cycle detection:
+;;
+;; A functional implementation of the algorithm described in Cormen,
+;; et al. (2009), Introduction to Algorithms (3rd ed.), pp. 612-615.
 
 (define (topological-sort dag pred)
-  (if (null? dag)
-      '()
-      (let* ((adj-table '())
-	     (sorted '()))
-
-	(define (insert x y)
-	  (let loop ([at adj-table])
-	    (cond [(null? at) (set! adj-table (cons (cons x y) adj-table))]
-		  [(pred x (caar at)) (set-cdr! (car at) y)]
-		  [else (loop (cdr at))] ) ) )
-	
-	(define (lookup x)
-	  (let loop ([at adj-table])
-	    (cond [(null? at) #f]
-		  [(pred x (caar at)) (cdar at)]
-		  [else (loop (cdr at))] ) ) )
-	
-	(define (visit u adj-list)
-	  ;; Color vertex u
-	  (insert u 'colored)
-	  ;; Visit uncolored vertices which u connects to
-	  (for-each (lambda (v)
-		      (let ((val (lookup v)))
-			(if (not (eq? val 'colored))
-			    (visit v (or val '())))))
-		    adj-list)
-	  ;; Since all vertices downstream u are visited
-	  ;; by now, we can safely put u on the output list
-	  (set! sorted (cons u sorted)) )
-	
-	;; Hash adjacency lists
-	(for-each (lambda (def) (insert (car def) (cdr def)))
-		  (cdr dag))
-	;; Visit vertices
-	(visit (caar dag) (cdar dag))
-	(for-each (lambda (def)
-		    (let ((val (lookup (car def))))
-		      (if (not (eq? val 'colored))
-			  (visit (car def) (cdr def)))))
-		  (cdr dag)) 
-	sorted) ) )
+  (define (visit dag node edges path state)
+    (case (alist-ref node (car state) pred)
+      ((grey)
+       (##sys#abort
+        (##sys#make-structure
+         'condition
+         '(exn runtime cycle)
+         `((exn . message) "cycle detected"
+           (exn . arguments) ,(list (cons node (reverse path)))
+           (exn . call-chain) ,(##sys#get-call-chain)
+           (exn . location) topological-sort))))
+      ((black)
+       state)
+      (else
+       (let walk ((edges (or edges (alist-ref node dag pred '())))
+                  (state (cons (cons (cons node 'grey) (car state))
+                               (cdr state))))
+         (if (null? edges)
+             (cons (alist-update! node 'black (car state) pred)
+                   (cons node (cdr state)))
+             (let ((edge (car edges)))
+               (walk (cdr edges)
+                     (visit dag
+                            edge
+                            #f
+                            (cons edge path)
+                            state))))))))
+  (let loop ((dag dag)
+             (state (cons (list) (list))))
+    (if (null? dag)
+        (cdr state)
+        (loop (cdr dag)
+              (visit dag
+                     (caar dag)
+                     (cdar dag)
+                     '()
+                     state)))))
 
 
 ;;; Binary search:
diff --git a/manual/Unit data-structures b/manual/Unit data-structures
index 5412ea4d..c64432e1 100644
--- a/manual/Unit data-structures	
+++ b/manual/Unit data-structures	
@@ -282,6 +282,9 @@ Time complexity: O (|V| + |E|)
 (socks undershorts pants shoes watch shirt belt tie jacket)
 </enscript>
 
+If a cycle is detected during the sorting process, an exception of the
+condition kinds {{(exn runtime cycle)}} is thrown.
+
 === Random numbers
 
 
diff --git a/tests/data-structures-tests.scm b/tests/data-structures-tests.scm
index b0f8794b..de3872b6 100644
--- a/tests/data-structures-tests.scm
+++ b/tests/data-structures-tests.scm
@@ -2,6 +2,11 @@
 
 (use data-structures)
 
+(define-syntax assert-error
+  (syntax-rules ()
+    ((_ expr)
+     (assert (handle-exceptions _ #t expr #f)))))
+
 (let ((alist '((foo . 123) ("bar" . "baz"))))
   (alist-update! 'foo 999 alist)
   (assert (= (alist-ref 'foo alist) 999))
@@ -37,3 +42,10 @@
 (assert (> 0 (string-compare3-ci "foo\x00A" "foo\x00b")))
 (assert (< 0 (string-compare3-ci "foo\x00b" "foo\x00a")))
 (assert (< 0 (string-compare3-ci "foo\x00b" "foo\x00A")))
+
+;; topological-sort
+
+(assert (equal? '() (topological-sort '() eq?)))
+(assert (equal? '(a b c d) (topological-sort '((a b) (b c) (c d)) eq?)))
+(assert (equal? '(c d a b) (topological-sort '((a b) (c d)) eq?)))
+(assert-error (topological-sort '((a b) (b a)) eq?))