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
