source: project/topological-sort/topological-sort.scm @ 3914

Last change on this file since 3914 was 3914, checked in by Kon Lovett, 13 years ago

Added declarations.

File size: 1.4 KB
Line 
1;; Simple topological sort (taken from SLIB, slightly adapted):
2;; Copyright (C) 1995 Mikael Djurfeldt
3
4(require-extension srfi-69)
5
6(eval-when (compile)
7  (declare
8    (usual-integrations)
9    (no-procedure-checks)
10    (no-bound-checks)
11    (fixnum)
12    (export
13      topological-sort) ) )
14
15(define (topological-sort dag pred)
16  #;(unless (list? dag)
17    (error 'topological-sort "invalid directed-acyclic-graph representation") )
18  #;(unless (procedure? pred)
19    (error 'topological-sort "invalid procedure") )
20  (if (null? dag)
21      '()
22      (let* ((adj-table (make-hash-table pred))
23             (sorted '()))
24        (letrec ((visit
25                  (lambda (u adj-list)
26                    ;; Color vertex u
27                    (hash-table-set! adj-table u 'colored)
28                    ;; Visit uncolored vertices which u connects to
29                    (for-each (lambda (v)
30                                (let ((val (hash-table-ref/default adj-table v #f)))
31                                  (if (not (eq? val 'colored))
32                                      (visit v (or val '())))))
33                              adj-list)
34                    ;; Since all vertices downstream u are visited
35                    ;; by now, we can safely put u on the output list
36                    (set! sorted (cons u sorted)))))
37          ;; Hash adjacency lists
38          (for-each (lambda (def)
39                      (hash-table-set! adj-table (car def) (cdr def)))
40                    (cdr dag))
41          ;; Visit vertices
42          (visit (caar dag) (cdar dag))
43          (for-each (lambda (def)
44                      (let ((val (hash-table-ref/default adj-table (car def) #f)))
45                        (if (not (eq? val 'colored))
46                            (visit (car def) (cdr def)))))
47                    (cdr dag)))
48        sorted)))
Note: See TracBrowser for help on using the repository browser.