-(define (graph bs)
- (define (go bs orig-bs)
- (define (find-refs prog)
- (ast-collect
- (lambda (x)
- (case (ast-type x)
- ; only count a reference if its a binding
- ['var (if (assoc x orig-bs) (list x) '())]
- [else '()]))
- prog))
- (if (null? bs)
- '(() . ())
- (let* [(bind (car bs))
-
- (vert (car bind))
- (refs (find-refs (cdr bind)))
- (edges (map (lambda (x) (cons vert x))
- refs))
-
- (rest (if (null? (cdr bs))
- (cons '() '())
- (go (cdr bs) orig-bs)))
- (total-verts (cons vert (car rest)))
- (total-edges (append edges (cdr rest)))]
- (cons total-verts total-edges))))
- (go bs bs))
-
-(define (successors graph v)
- (define (go v E)
- (if (null? E)
- '()
- (if (eqv? v (caar E))
- (cons (cdar E) (go v (cdr E)))
- (go v (cdr E)))))
- (go v (cdr graph)))
-
- ; takes in a graph (pair of vertices, edges)
- ; returns a list of strongly connected components
-
- ; ((x y w) . ((x . y) (x . w) (w . x))
-
- ; =>
- ; .->x->y
- ; | |
- ; | v
- ; .--w
-
- ; ((x w) (y))
-
- ; this uses tarjan's algorithm, to get reverse
- ; topological sorting for free
-(define (sccs graph)
-
- (let* ([indices (make-hash-table)]
- [lowlinks (make-hash-table)]
- [on-stack (make-hash-table)]
- [current 0]
- [stack '()]
- [result '()])
-
- (define (index v)
- (get-hash-table indices v #f))
- (define (lowlink v)
- (get-hash-table lowlinks v #f))
-
- (letrec
- ([strong-connect
- (lambda (v)
- (begin
- (put-hash-table! indices v current)
- (put-hash-table! lowlinks v current)
- (set! current (+ current 1))
- (push! stack v)
- (put-hash-table! on-stack v #t)
-
- (for-each
- (lambda (w)
- (if (not (hashtable-contains? indices w))
- ; successor w has not been visited, recurse
- (begin
- (strong-connect w)
- (put-hash-table! lowlinks
- v
- (min (lowlink v) (lowlink w))))
- ; successor w has been visited
- (when (get-hash-table on-stack w #f)
- (put-hash-table! lowlinks v (min (lowlink v) (index w))))))
- (successors graph v))
-
- (when (= (index v) (lowlink v))
- (let ([scc
- (let new-scc ()
- (let ([w (pop! stack)])
- (put-hash-table! on-stack w #f)
- (if (eqv? w v)
- (list w)
- (cons w (new-scc)))))])
- (set! result (cons scc result))))))])
- (for-each
- (lambda (v)
- (when (not (hashtable-contains? indices v)) ; v.index == -1
- (strong-connect v)))
- (car graph)))
- result))