62 lines
1.9 KiB
Racket
62 lines
1.9 KiB
Racket
#lang racket
|
|
|
|
(require syntax/parse/define
|
|
fancy-app
|
|
(for-syntax racket/syntax))
|
|
|
|
(struct node (name index low-link on?) #:transparent #:mutable
|
|
#:methods gen:custom-write
|
|
[(define (write-proc v port mode) (fprintf port "~a" (node-name v)))])
|
|
|
|
(define-syntax-parser change!
|
|
[(_ x:id f) #'(set! x (f x))]
|
|
[(_ accessor:id v f)
|
|
#:with mutator! (format-id this-syntax "set-~a!" #'accessor)
|
|
#'(mutator! v (f (accessor v)))])
|
|
|
|
(define (tarjan g)
|
|
(define sccs '())
|
|
(define index 0)
|
|
(define s '())
|
|
|
|
(define (dfs v)
|
|
(set-node-index! v index)
|
|
(set-node-low-link! v index)
|
|
(set-node-on?! v #t)
|
|
(change! s (cons v _))
|
|
(change! index add1)
|
|
|
|
(for ([w (in-list (hash-ref g v '()))])
|
|
(match-define (node _ index low-link on?) w)
|
|
(cond
|
|
[(not index) (dfs w)
|
|
(change! node-low-link v (min (node-low-link w) _))]
|
|
[on? (change! node-low-link v (min index _))]))
|
|
|
|
(when (= (node-low-link v) (node-index v))
|
|
(define-values (scc* s*) (splitf-at s (λ (w) (not (eq? w v)))))
|
|
(set! s (rest s*))
|
|
(define scc (cons (first s*) scc*))
|
|
(for ([w (in-list scc)]) (set-node-on?! w #f))
|
|
(change! sccs (cons scc _))))
|
|
|
|
(for* ([(u _) (in-hash g)] #:when (not (node-index u))) (dfs u))
|
|
sccs)
|
|
|
|
(define (make-graph xs)
|
|
(define store (make-hash))
|
|
(define (make-node v) (hash-ref! store v (thunk (node v #f #f #f))))
|
|
|
|
;; it's important that we use hasheq instead of hash so that we compare
|
|
;; reference instead of actual value. Had we use the actual value,
|
|
;; the key would be a mutable value, which causes undefined behavior
|
|
(for/hasheq ([vs (in-list xs)]) (values (make-node (first vs)) (map make-node (rest vs)))))
|
|
|
|
(tarjan (make-graph '([0 1]
|
|
[2 0]
|
|
[5 2 6]
|
|
[6 5]
|
|
[1 2]
|
|
[3 1 2 4]
|
|
[4 5 3]
|
|
[7 4 7 6])))
|