module Util.Graph(
Graph(),
fromGraph,
newGraph,
newGraph',
newGraphReachable,
reachableFrom,
Util.Graph.reachable,
fromScc,
findLoopBreakers,
sccGroups,
Util.Graph.scc,
sccForest,
Util.Graph.dff,
Util.Graph.components,
Util.Graph.topSort,
cyclicNodes,
toDag,
restitchGraph,
mapGraph,
transitiveClosure,
transitiveReduction
) where
import Control.Monad
import Control.Monad.ST
import Data.Array.IArray
import Data.Array.ST hiding(unsafeFreeze)
import Data.Array.Unsafe (unsafeFreeze)
import Data.Graph hiding(Graph)
import Data.Maybe
import GenUtil
import Data.List(sort,sortBy,group,delete)
import qualified Data.Graph as G
import qualified Data.Map as Map
data Graph n = Graph G.Graph (Table n)
instance Show n => Show (Graph n) where
showsPrec n g = showsPrec n (Util.Graph.scc g)
fromGraph :: Graph n -> [(n,[n])]
fromGraph (Graph g lv) = [ (lv!v,map (lv!) vs) | (v,vs) <- assocs g ]
newGraph :: Ord k => [n] -> (n -> k) -> (n -> [k]) -> (Graph n)
newGraph ns a b = snd $ newGraph' ns a b
newGraphReachable :: Ord k => [n] -> (n -> k) -> (n -> [k]) -> ([k] -> [n],Graph n)
newGraphReachable ns fn fd = (rable,ng) where
(vmap,ng) = newGraph' ns fn fd
rable ks = Util.Graph.reachable ng [ v | Just v <- map (flip Map.lookup vmap) ks ]
reachableFrom :: Ord k => (n -> k) -> (n -> [k]) -> [n] -> [k] -> [n]
reachableFrom fn fd ns = fst $ newGraphReachable ns fn fd
newGraph' :: Ord k => [n] -> (n -> k) -> (n -> [k]) -> (Map.Map k Vertex,Graph n)
newGraph' ns fn fd = (kmap,Graph graph nr) where
nr = listArray bounds0 ns
max_v = length ns 1
bounds0 = (0,max_v) :: (Vertex, Vertex)
kmap = Map.fromList [ (fn n,i) | (i,n) <- zip [0 ..] ns ]
graph = listArray bounds0 [mapMaybe (flip Map.lookup kmap) (snub $ fd n) | n <- ns]
fromScc (Left n) = [n]
fromScc (Right n) = n
findLoopBreakers
:: (n -> Int)
-> (n -> Bool)
-> Graph n
-> ([n],[n])
findLoopBreakers func ex (Graph g ln) = ans where
scc = G.scc g
ans = f g scc [] [] where
f g (Node v []:sccs) fs lb
| v `elem` g ! v = let ng = (fmap (delete v) g) in f ng (G.scc ng) [] (v:lb)
| otherwise = f g sccs (v:fs) lb
f g (n:_) fs lb = f ng (G.scc ng) [] (mv:lb) where
mv = case sortBy (\ a b -> compare (snd b) (snd a)) [ (v,func (ln!v)) | v <- ns, ex (ln!v) ] of
((mv,_):_) -> mv
[] -> error "findLoopBreakers: no valid loopbreakers"
ns = dec n []
ng = fmap (delete mv) g
f _ [] xs lb = (map ((ln!) . head) (group $ sort lb),reverse $ map (ln!) xs)
dec (Node v ts) vs = v:foldr dec vs ts
reachable :: Graph n -> [Vertex] -> [n]
reachable (Graph g ln) vs = map (ln!) $ snub $ concatMap (G.reachable g) vs
sccGroups :: Graph n -> [[n]]
sccGroups g = map fromScc (Util.Graph.scc g)
scc :: Graph n -> [Either n [n]]
scc (Graph g ln) = map decode forest where
forest = G.scc g
decode (Node v [])
| v `elem` g ! v = Right [ln!v]
| otherwise = Left (ln!v)
decode other = Right (dec other [])
dec (Node v ts) vs = ln!v:foldr dec vs ts
sccForest :: Graph n -> Forest n
sccForest (Graph g ln) = map (fmap (ln!)) forest where
forest = G.scc g
dff :: Graph n -> Forest n
dff (Graph g ln) = map (fmap (ln!)) forest where
forest = G.dff g
components :: Graph n -> [[n]]
components (Graph g ln) = map decode forest where
forest = G.components g
decode n = dec n []
dec (Node v ts) vs = ln!v:foldr dec vs ts
topSort :: Graph n -> [n]
topSort (Graph g ln) = map (ln!) $ G.topSort g
cyclicNodes :: Graph n -> [n]
cyclicNodes g = concat [ xs | Right xs <- Util.Graph.scc g]
toDag :: Graph n -> Graph [n]
toDag (Graph g lv) = Graph g' ns' where
ns' = listArray (0,max_v) [ map (lv!) ns | ns <- nss ]
g' = listArray (0,max_v) [ snub [ v | n <- ns, v <- g!n ] | ns <- nss ]
max_v = length nss 1
nss = map (flip f []) (G.scc g) where
f (Node v ts) rs = v:foldr f rs ts
type AdjacencyMatrix s = STArray s (Vertex,Vertex) Bool
type IAdjacencyMatrix = Array (Vertex,Vertex) Bool
transitiveClosureAM :: AdjacencyMatrix s -> ST s ()
transitiveClosureAM arr = do
bnds@(_,(max_v,_)) <- getBounds arr
forM_ [0 .. max_v] $ \k -> do
forM_ (range bnds) $ \ (i,j) -> do
dij <- readArray arr (i,j)
dik <- readArray arr (i,k)
dkj <- readArray arr (k,j)
writeArray arr (i,j) (dij || (dik && dkj))
transitiveReductionAM :: AdjacencyMatrix s -> ST s ()
transitiveReductionAM arr = do
bnds@(_,(max_v,_)) <- getBounds arr
transitiveClosureAM arr
(farr :: IAdjacencyMatrix) <- freeze arr
forM_ [0 .. max_v] $ \k -> do
forM_ (range bnds) $ \ (i,j) -> do
if farr!(k,i) && farr!(i,j) then
writeArray arr (k,j) False
else return ()
toAdjacencyMatrix :: G.Graph -> ST s (AdjacencyMatrix s)
toAdjacencyMatrix g = do
let (0,max_v) = bounds g
arr <- newArray ((0,0),(max_v,max_v)) False :: ST s (STArray s (Vertex,Vertex) Bool)
sequence_ [ writeArray arr (v,u) True | (v,vs) <- assocs g, u <- vs ]
return arr
fromAdjacencyMatrix :: AdjacencyMatrix s -> ST s G.Graph
fromAdjacencyMatrix arr = do
bnds@(_,(max_v,_)) <- getBounds arr
rs <- getAssocs arr
let rs' = [ x | (x,True) <- rs ]
return (listArray (0,max_v) [ [ v | (n',v) <- rs', n == n' ] | n <- [ 0 .. max_v] ])
transitiveClosure :: Graph n -> Graph n
transitiveClosure (Graph g ns) = let g' = runST (tc g) in (Graph g' ns) where
tc g = do
a <- toAdjacencyMatrix g
transitiveClosureAM a
fromAdjacencyMatrix a
transitiveReduction :: Graph n -> Graph n
transitiveReduction (Graph g ns) = let g' = runST (tc g) in (Graph g' ns) where
tc g = do
a <- toAdjacencyMatrix g
transitiveReductionAM a
fromAdjacencyMatrix a
instance Functor Graph where
fmap f (Graph g n) = Graph g (fmap f n)
restitchGraph :: Ord k => (n -> k) -> (n -> [k]) -> Graph n -> Graph n
restitchGraph fn fd (Graph g nr) = Graph g' nr where
kmap = Map.fromList [ (fn n,i) | (i,n) <- assocs nr ]
g' = listArray (bounds g) [mapMaybe (flip Map.lookup kmap) (snub $ fd n) | n <- elems nr]
mapGraph :: forall a b . (a -> [b] -> b) -> Graph a -> Graph b
mapGraph f (Graph gr nr) = runST $ do
mnr <- thaw nr :: ST s (STArray s Vertex a)
mnr <- mapArray Left mnr
let g i = readArray mnr i >>= \v -> case v of
Right m -> return m
Left l -> mdo
writeArray mnr i (Right r)
rs <- mapM g (gr!i)
let r = f l rs
return r
mapM_ g (range $ bounds nr)
mnr <- mapArray fromRight mnr
mnr <- unsafeFreeze mnr
return (Graph gr mnr)