>From 840b24477b38f1ca3815248ae9704911bd8527b0 Mon Sep 17 00:00:00 2001
From: Moritz Heidkamp <address@hidden>
Date: Sun, 3 Mar 2013 13:28:20 +0100
Subject: [PATCH] Reimplement topological-sort with cycle detection

---
 data-structures.scm | 85 ++++++++++++++++++++++++++---------------------------
 1 file changed, 41 insertions(+), 44 deletions(-)

diff --git a/data-structures.scm b/data-structures.scm
index 56944ec..d51abe4 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 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:
-- 
1.8.1.4