From 8ffbc2df0fde83082610149d24e594c1cd879f4a Mon Sep 17 00:00:00 2001 From: Bryan Newbold Date: Mon, 20 Feb 2017 00:05:25 -0800 Subject: Import Upstream version 2a6 --- tsort.scm | 46 ++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 46 insertions(+) create mode 100644 tsort.scm (limited to 'tsort.scm') 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) -- cgit v1.2.3