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.