[Chicken-hackers] [PATCH] Reimplement topological-sort with cycle detection

2013-03-03 Thread Moritz Heidkamp
Fellow Chickeneers,

I recently noticed that Chicken's topological-sort function does not
detect cycles in the passed graph. Initially I ventured into patching
this functionality into the existing implementation which originates
from SLIB. This turned out to be tricky as it is a heavily imperative
implemenatation. By the time I had figured out how it works I had
already opened the relevant chapter of Introduction to
Algorithms. According to the header comment of the SLIB implementation
(see
http://cvs.savannah.gnu.org/viewvc/slib/slib/tsort.scm?revision=1.2) it
is also based on that algorithm, but apparently without the cycle
detection (or maybe it wasn't in the 1st edition which is what the
author used, while I used the 3rd edition). Eventually I found it easier
to reimplement the algorithm in a functinal style to add the cycle
detection bit.

One thing I'm not sure about is how I raise the condition in case a
cycle is detected. Comments on that are very welcome!

Have a nice Sunday
Moritz

From 840b24477b38f1ca3815248ae9704911bd8527b0 Mon Sep 17 00:00:00 2001
From: Moritz Heidkamp mor...@twoticketsplease.de
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

___
Chicken-hackers mailing list
Chicken-hackers@nongnu.org
https://lists.nongnu.org/mailman/listinfo/chicken-hackers


Re: [Chicken-hackers] [PATCH] Reimplement topological-sort with cycle detection

2013-03-03 Thread John Cowan
Moritz Heidkamp scripsit:

 Only the first cycle detected is reported currently.

I think that's more than satisfactory.  Users shouldn't be topologically
sorting a graph that might have cycles anyway.

-- 
Normally I can handle panic attacks on my own;   John Cowan co...@ccil.org
but panic is, at the moment, a way of life.  http://www.ccil.org/~cowan
--Joseph Zitt

___
Chicken-hackers mailing list
Chicken-hackers@nongnu.org
https://lists.nongnu.org/mailman/listinfo/chicken-hackers