#!/usr/bin/guile -s
!#
;;;;    A topological sort.

;;;;    Copyright (C) 2001, 2002, 2003, 2004  Martin C Rodgers
;;;;
;;;;    This program is free software; you can redistribute it and/or modify
;;;;    it under the terms of the GNU General Public License as published by
;;;;    the Free Software Foundation; either version 2 of the License, or
;;;;    (at your option) any later version.
;;;;
;;;;    This program is distributed in the hope that it will be useful,
;;;;    but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;;    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;;;    GNU General Public License for more details.
;;;;
;;;;    You should have received a copy of the GNU General Public License
;;;;    along with this program; if not, write to the Free Software
;;;;    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.


;;;; Translated from SPARKS (Fortran superset, used in
;;;; Fundamentals of Data Structures, E. Horowitz & S. Sahni,
;;;; Computer Science Press 1976) to Guile.


(use-modules
    (ice-9 pretty-print))


(define (init-graph n v c verts)
    (for-each
	(lambda (vert j)
	    (vector-set! v j vert)
	    (for-each
		(lambda (i)
		    (vector-set! c i (+ 1 (vector-ref c i))))
		vert))
	verts
	(iota n)))

(define (%graph-sort n v c thunk)
    (let ((top -1))
	(define (empty?)
	    (< top 0))
	(define (push i)
	    (vector-set! c i top)
	    (set! top i))
	(define (pop)
	    (let ((j top))
		(set! top (vector-ref c top))
		j))
	(for-each
	    (lambda (i)
		(if (= 0 (vector-ref c i))
		    (push i)))
	    (iota n))
	(for-each
	    (lambda (i)
		(if (empty?)
		    (throw 'graph-cycle))
		(let ((j (pop)))
		    (thunk j)
		    (for-each
			(lambda (k)
			    (let ((new (- (vector-ref c k) 1)))
				(vector-set! c k new)
				(if (= 0 new)
				    (push k))))
			(vector-ref v j))))
	    (iota n))))

(define (graph-sort verts thunk)
    (let* ((n (length verts))
	   (v (make-vector n 0))
	   (c (make-vector n 0)))
	(init-graph n v c verts)
	(%graph-sort n v c thunk)))

(define (test verts)
    (pretty-print
	(catch 'graph-cycle
	    (lambda ()
		(let ((r '()))
		    (graph-sort
			verts
			(lambda (j)
			    (set! r (cons j r))))
		    r))
	    (lambda ()
		'cycle))))

(test '((1 2 3) (4) (4 5) (4 5) () ()))