1; Part of Scheme 48 1.9.  See file COPYING for notices and license.
2
3; Authors: Richard Kelsey, Jonathan Rees, Robert Ransom
4
5
6; Code to find the strongly connected components of a graph.
7; (TO <vertex>) are the vertices that have an edge to <vertex>.
8; (SLOT <vertex>) and (SET-SLOT! <vertex> <value>) is a settable slot
9; used by the algorithm.
10;
11; The components are returned in a backwards topologically sorted list.
12
13(define (strongly-connected-components vertices to slot set-slot!)
14  (make-vertices vertices to slot set-slot!)
15  (let loop ((to-do vertices) (index 0) (stack #t) (comps '()))
16    (let ((to-do (find-next-vertex to-do slot)))
17      (cond ((null? to-do)
18	     (for-each (lambda (n) (set-slot! n #f)) vertices)
19	     comps)
20	    (else
21	     (call-with-values
22	      (lambda ()
23		(do-vertex (slot (car to-do)) index stack comps))
24	      (lambda (index stack comps)
25		(loop to-do index stack comps))))))))
26
27(define (find-next-vertex vertices slot)
28  (do ((vertices vertices (cdr vertices)))
29      ((or (null? vertices)
30           (= 0 (vertex-index (slot (car vertices)))))
31       vertices)))
32
33(define-record-type vertex :vertex
34  (really-make-vertex data edges stack index parent lowpoint)
35  vertex?
36  (data vertex-data)    ; user's data
37  (edges vertex-edges set-vertex-edges!)    ; list of vertices
38  (stack vertex-stack set-vertex-stack!)    ; next vertex on the stack
39  (index vertex-index set-vertex-index!)    ; time at which this vertex was
40                                            ; reached in the traversal
41  (parent vertex-parent set-vertex-parent!) ; a vertex pointing to this one
42  (lowpoint vertex-lowpoint set-vertex-lowpoint!)) ; lowest index in this
43                                     ; vertex's strongly connected component
44
45(define (make-vertex data)
46  (really-make-vertex data '() #f 0 #f #f))
47
48(define (make-vertices vertices to slot set-slot!)
49  (let ((maybe-slot (lambda (n)
50		      (let ((s (slot n)))
51			(if (vertex? s)
52			    s
53			    (assertion-violation 'make-vertices
54						 "graph edge points to non-vertex"
55						 n))))))
56    (for-each (lambda (n)
57		(set-slot! n (make-vertex n)))
58	      vertices)
59    (for-each (lambda (n)
60		(set-vertex-edges! (slot n) (map maybe-slot (to n))))
61	      vertices)
62    (values)))
63
64; The numbers are the algorithm step numbers from page 65 of Graph Algorithms,
65; Shimon Even, Computer Science Press, 1979.
66
67; 2
68
69(define (do-vertex vertex index stack comps)
70  (let ((index (+ index '1)))
71    (set-vertex-index!    vertex index)
72    (set-vertex-lowpoint! vertex index)
73    (set-vertex-stack!    vertex stack)
74    (get-strong vertex index vertex comps)))
75
76; 3
77
78(define (get-strong vertex index stack comps)
79  (if (null? (vertex-edges vertex))
80      (end-vertex    vertex index stack comps)
81      (follow-edge vertex index stack comps)))
82
83; 7
84
85(define (end-vertex vertex index stack comps)
86  (call-with-values
87   (lambda ()
88     (if (= (vertex-index vertex) (vertex-lowpoint vertex))
89	 (unwind-stack vertex stack comps)
90	 (values stack comps)))
91   (lambda (stack comps)
92     (cond ((vertex-parent vertex)
93	    => (lambda (parent)
94		 (if (> (vertex-lowpoint parent) (vertex-lowpoint vertex))
95		     (set-vertex-lowpoint! parent (vertex-lowpoint vertex)))
96		 (get-strong parent index stack comps)))
97	   (else
98	    (values index stack comps))))))
99
100(define (unwind-stack vertex stack comps)
101  (let loop ((n stack) (c '()))
102    (let ((next (vertex-stack n))
103          (c (cons (vertex-data n) c)))
104      (set-vertex-stack! n #f)
105      (if (eq? n vertex)
106          (values next (cons c comps))
107          (loop next c)))))
108
109; 4
110
111(define (follow-edge vertex index stack comps)
112  (let* ((next (pop-vertex-edge! vertex))
113         (next-index (vertex-index next)))
114    (cond ((= next-index 0)
115           (set-vertex-parent! next vertex)
116           (do-vertex next index stack comps))
117          (else
118           (if (and (< next-index (vertex-index vertex))
119                    (vertex-stack next)
120                    (< next-index (vertex-lowpoint vertex)))
121               (set-vertex-lowpoint! vertex next-index))
122           (get-strong vertex index stack comps)))))
123
124(define (pop-vertex-edge! vertex)
125  (let ((edges (vertex-edges vertex)))
126    (set-vertex-edges! vertex (cdr edges))
127    (car edges)))
128
129; GRAPH is ((<symbol> . <symbol>*)*)
130
131;(define (test-strong graph)
132;  (let ((vertices (map (lambda (n)
133;                         (vector (car n) #f #f))
134;                       graph)))
135;    (for-each (lambda (data vertex)
136;                (vector-set! vertex 1 (map (lambda (s)
137;                                             (first (lambda (v)
138;                                                      (eq? s (vector-ref v 0)))
139;                                                    vertices))
140;                                           (cdr data))))
141;              graph
142;              vertices)
143;    (map (lambda (l)
144;           (map (lambda (n) (vector-ref n 0)) l))
145;         (strongly-connected-components vertices
146;                                        (lambda (v) (vector-ref v 1))
147;                                        (lambda (v) (vector-ref v 2))
148;                                        (lambda (v val)
149;                                          (vector-set! v 2 val))))))
150
151
152
153
154
155
156
157