module Data.Graph.ArraySCC(scc) where
import Data.Graph(Graph,Vertex)
import Data.Array.ST
import Data.Array as A
import Control.Monad.ST
import Control.Monad(ap)
scc :: Graph -> ([(Int,[Vertex])], Vertex -> Int)
scc g = runST (
do ixes <- newArray (bounds g) 0
lows <- newArray (bounds g) 0
s <- roots g ixes lows (S [] 1 [] 1) (indices g)
sccm <- unsafeFreeze ixes
return (sccs s, \i -> sccm ! i)
)
type Func s a =
Graph
-> STUArray s Vertex Int
-> STUArray s Vertex Int
-> S
-> a
data S = S { stack :: ![Vertex]
, num :: !Int
, sccs :: ![(Int,[Vertex])]
, next_scc :: !Int
}
roots :: Func s ([Vertex] -> ST s S)
roots g ixes lows st (v:vs) =
do i <- readArray ixes v
if i == 0 then do s1 <- from_root g ixes lows st v
roots g ixes lows s1 vs
else roots g ixes lows st vs
roots _ _ _ s [] = return s
from_root :: Func s (Vertex -> ST s S)
from_root g ixes lows s v =
do let me = num s
writeArray ixes v (negate me)
writeArray lows v me
newS <- check_adj g ixes lows
s { stack = v : stack s, num = me + 1 } v (g ! v)
x <- readArray lows v
if x < me then return newS else
case span (/= v) (stack newS) of
(as,b:bs) ->
do let this = b : as
n = next_scc newS
mapM_ (\i -> writeArray ixes i n) this
return S { stack = bs
, num = num newS
, sccs = (n,this) : sccs newS
, next_scc = n + 1
}
_ -> error ("bug in scc---vertex not on the stack: " ++ show v)
check_adj :: Func s (Vertex -> [Vertex] -> ST s S)
check_adj g ixes lows st v (v':vs) =
do i <- readArray ixes v'
case () of
_ | i == 0 ->
do newS <- from_root g ixes lows st v'
new_low <- min `fmap` readArray lows v `ap` readArray lows v'
writeArray lows v new_low
check_adj g ixes lows newS v vs
| i < 0 ->
do j <- readArray lows v
writeArray lows v (min j (negate i))
check_adj g ixes lows st v vs
| otherwise -> check_adj g ixes lows st v vs
check_adj _ _ _ st _ [] = return st