summaryrefslogtreecommitdiffstats
path: root/tsort.scm
diff options
context:
space:
mode:
Diffstat (limited to 'tsort.scm')
-rw-r--r--tsort.scm46
1 files changed, 46 insertions, 0 deletions
diff --git a/tsort.scm b/tsort.scm
new file mode 100644
index 0000000..9371f3c
--- /dev/null
+++ b/tsort.scm
@@ -0,0 +1,46 @@
+;;; "tsort.scm" Topological sort
+;;; Copyright (C) 1995 Mikael Djurfeldt
+;
+; This code is in the public domain.
+
+;;; The algorithm is inspired by Cormen, Leiserson and Rivest (1990)
+;;; "Introduction to Algorithms", chapter 23
+
+(require 'hash-table)
+(require 'primes)
+
+(define (topological-sort dag pred)
+ (if (null? dag)
+ '()
+ (let* ((adj-table (make-hash-table
+ (car (primes> (length dag) 1))))
+ (insert (hash-associator pred))
+ (lookup (hash-inquirer pred))
+ (sorted '()))
+ (letrec ((visit
+ (lambda (u adj-list)
+ ;; Color vertex u
+ (insert adj-table u 'colored)
+ ;; Visit uncolored vertices which u connects to
+ (for-each (lambda (v)
+ (let ((val (lookup adj-table 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 adj-table (car def) (cdr def)))
+ (cdr dag))
+ ;; Visit vertices
+ (visit (caar dag) (cdar dag))
+ (for-each (lambda (def)
+ (let ((val (lookup adj-table (car def))))
+ (if (not (eq? val 'colored))
+ (visit (car def) (cdr def)))))
+ (cdr dag)))
+ sorted)))
+
+(define tsort topological-sort)