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

Last change on this file since 8676 was 8676, checked in by felix winkelmann, 12 years ago

trivial test change

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