guile-prescheme/ps-compiler/util/strong.scm

;;; Ported from Scheme 48 1.9.  See file COPYING for notices and license.
;;;
;;; Port Author: Andrew Whatson
;;;
;;; Original Authors: Richard Kelsey
;;;
;;;   scheme48-1.9.2/ps-compiler/util/strong.scm
;;;
;;; 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-module (ps-compiler util strong)
  #:use-module (prescheme s48-defrecord)
  #:export (strongly-connected-components))

(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))))))