/usr/share/scsh-0.6/big/strong.scm is in scsh-common-0.6 0.6.7-8.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 | ; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. 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 :vertex
(really-make-vertex data edges stack index parent lowpoint)
vertex?
(data vertex-data) ; user's data
(edges vertex-edges set-vertex-edges!) ; list of vertices
(stack vertex-stack set-vertex-stack!) ; next vertex on the stack
(index vertex-index set-vertex-index!) ; time at which this vertex was
; reached in the traversal
(parent vertex-parent set-vertex-parent!) ; a vertex pointing to this one
(lowpoint vertex-lowpoint set-vertex-lowpoint!)) ; lowest index in this
; vertices strongly connected component
(define (make-vertex data)
(really-make-vertex data '() #f 0 #f #f))
(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 (make-vertex 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))))))
|