scsh-0.6/ps-compiler/util/strong.scm

148 lines
4.7 KiB
Scheme
Raw Normal View History

1999-09-14 08:45:02 -04:00
; Copyright (c) 1993-1999 by Richard Kelsey. See file COPYING.
; Code to find the strongly connected components of a graph.
; (TO <vertex>) are the vertices that have an edge to <vertex>.
; (SLOT <vertex>) and (SET-SLOT! <vertex> <value>) is a settable slot
; used by the algorithm.
;
; The components are returned in a backwards topologically sorted list.
(define (strongly-connected-components vertices to slot set-slot!)
(make-vertices vertices to slot set-slot!)
(let loop ((to-do vertices) (index 0) (stack #t) (comps '()))
(let ((to-do (find-next-vertex to-do slot)))
(cond ((null? to-do)
(for-each (lambda (n) (set-slot! n #f)) vertices)
comps)
(else
(call-with-values
(lambda ()
(do-vertex (slot (car to-do)) index stack comps))
(lambda (index stack comps)
(loop to-do index stack comps))))))))
(define (find-next-vertex vertices slot)
(do ((vertices vertices (cdr vertices)))
((or (null? vertices)
(= 0 (vertex-index (slot (car vertices)))))
vertices)))
(define-record-type vertex
(data ; user's data
)
((edges '()) ; list of vertices
(stack #f) ; next vertex on the stack
(index 0) ; time at which this vertex was reached in the traversal
(parent #f) ; a vertex pointing to this one
(lowpoint #f) ; lowest index in this vertices strongly connected component
))
(define (make-vertices vertices to slot set-slot!)
(let ((maybe-slot (lambda (n)
(let ((s (slot n)))
(if (vertex? s)
s
(error "graph edge points to non-vertex" n))))))
(for-each (lambda (n)
(set-slot! n (vertex-maker n)))
vertices)
(for-each (lambda (n)
(set-vertex-edges! (slot n) (map maybe-slot (to n))))
vertices)
(values)))
; The numbers are the algorithm step numbers from page 65 of Graph Algorithms,
; Shimon Even, Computer Science Press, 1979.
; 2
(define (do-vertex vertex index stack comps)
(let ((index (+ index '1)))
(set-vertex-index! vertex index)
(set-vertex-lowpoint! vertex index)
(set-vertex-stack! vertex stack)
(get-strong vertex index vertex comps)))
; 3
(define (get-strong vertex index stack comps)
(if (null? (vertex-edges vertex))
(end-vertex vertex index stack comps)
(follow-edge vertex index stack comps)))
; 7
(define (end-vertex vertex index stack comps)
(call-with-values
(lambda ()
(if (= (vertex-index vertex) (vertex-lowpoint vertex))
(unwind-stack vertex stack comps)
(values stack comps)))
(lambda (stack comps)
(cond ((vertex-parent vertex)
=> (lambda (parent)
(if (> (vertex-lowpoint parent) (vertex-lowpoint vertex))
(set-vertex-lowpoint! parent (vertex-lowpoint vertex)))
(get-strong parent index stack comps)))
(else
(values index stack comps))))))
(define (unwind-stack vertex stack comps)
(let loop ((n stack) (c '()))
(let ((next (vertex-stack n))
(c (cons (vertex-data n) c)))
(set-vertex-stack! n #f)
(if (eq? n vertex)
(values next (cons c comps))
(loop next c)))))
; 4
(define (follow-edge vertex index stack comps)
(let* ((next (pop-vertex-edge! vertex))
(next-index (vertex-index next)))
(cond ((= next-index 0)
(set-vertex-parent! next vertex)
(do-vertex next index stack comps))
(else
(if (and (< next-index (vertex-index vertex))
(vertex-stack next)
(< next-index (vertex-lowpoint vertex)))
(set-vertex-lowpoint! vertex next-index))
(get-strong vertex index stack comps)))))
(define (pop-vertex-edge! vertex)
(let ((edges (vertex-edges vertex)))
(set-vertex-edges! vertex (cdr edges))
(car edges)))
; GRAPH is ((<symbol> . <symbol>*)*)
;(define (test-strong graph)
; (let ((vertices (map (lambda (n)
; (vector (car n) #f #f))
; graph)))
; (for-each (lambda (data vertex)
; (vector-set! vertex 1 (map (lambda (s)
; (first (lambda (v)
; (eq? s (vector-ref v 0)))
; vertices))
; (cdr data))))
; graph
; vertices)
; (map (lambda (l)
; (map (lambda (n) (vector-ref n 0)) l))
; (strongly-connected-components vertices
; (lambda (v) (vector-ref v 1))
; (lambda (v) (vector-ref v 2))
; (lambda (v val)
; (vector-set! v 2 val))))))