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
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
