module Data.Graph.Wrapper (
Edge, Graph,
vertex,
fromListSimple, fromList, fromListBy, fromVerticesEdges,
vertices, edges, successors,
outdegree, indegree,
transpose,
reachableVertices, hasPath,
topologicalSort, depthNumbering,
SCC(..), stronglyConnectedComponents, sccGraph
) where
import Control.Arrow (second)
import Control.Monad
import Control.Monad.ST
import Data.Array
import Data.Array.ST
import qualified Data.Graph as G
import qualified Data.IntSet as IS
import Data.List (sortBy, mapAccumL)
import Data.Maybe (fromMaybe, fromJust)
import qualified Data.Map as M
import Data.Ord
import qualified Data.Set as S
import qualified Data.Foldable as Foldable
import qualified Data.Traversable as Traversable
fst3 :: (a, b, c) -> a
fst3 (a, _, _) = a
snd3 :: (a, b, c) -> b
snd3 (_, b, _) = b
thd3 :: (a, b, c) -> c
thd3 (_, _, c) = c
amapWithKeyM :: (Monad m, Ix i) => (i -> v -> m v') -> Array i v -> m (Array i v')
amapWithKeyM f arr = liftM (array (bounds arr)) $ mapM (\(i, v) -> liftM (\v' -> (i, v')) $ f i v) (assocs arr)
type Edge i = (i, i)
data Graph i v = G {
graph :: G.Graph,
indexGVertexArray :: Array G.Vertex i,
gVertexVertexArray :: Array G.Vertex v
}
instance (Ord i, Show i, Show v) => Show (Graph i v) where
show g = "fromVerticesEdges " ++ show ([(i, vertex g i) | i <- vertices g]) ++ " " ++ show (edges g)
instance Functor (Graph i) where
fmap f g = g { gVertexVertexArray = fmap f (gVertexVertexArray g) }
instance Foldable.Foldable (Graph i) where
foldMap f g = Foldable.foldMap f (gVertexVertexArray g)
instance Traversable.Traversable (Graph i) where
traverse f g = fmap (\gvva -> g { gVertexVertexArray = gvva }) (Traversable.traverse f (gVertexVertexArray g))
indexGVertex :: Ord i => Graph i v -> i -> G.Vertex
indexGVertex g i = indexGVertex' (indexGVertexArray g) i
gVertexIndex :: Graph i v -> G.Vertex -> i
gVertexIndex g gv = indexGVertexArray g ! gv
gVertexVertex :: Graph i v -> G.Vertex -> v
gVertexVertex g gv = gVertexVertexArray g ! gv
vertex :: Ord i => Graph i v -> i -> v
vertex g = gVertexVertex g . indexGVertex g
fromListSimple :: Ord v => [(v, [v])] -> Graph v v
fromListSimple = fromListBy id
fromListBy :: Ord i => (v -> i) -> [(v, [i])] -> Graph i v
fromListBy f vertices = fromList [(f v, v, is) | (v, is) <- vertices]
fromVerticesEdges :: Ord i => [(i, v)] -> [Edge i] -> Graph i v
fromVerticesEdges vertices edges | M.null final_edges_map = fromList done_vertices
| otherwise = error "fromVerticesEdges: some edges originated from non-existant vertices"
where
(final_edges_map, done_vertices) = mapAccumL accum (M.fromListWith (++) (map (second return) edges)) vertices
accum edges_map (i, v) = case M.updateLookupWithKey (\_ _ -> Nothing) i edges_map of (mb_is, edges_map) -> (edges_map, (i, v, fromMaybe [] mb_is))
fromList :: Ord i => [(i, v, [i])] -> Graph i v
fromList vertices = G graph key_map vertex_map
where
max_v = length vertices 1
bounds0 = (0, max_v) :: (G.Vertex, G.Vertex)
sorted_vertices = sortBy (comparing fst3) vertices
graph = array bounds0 $ [0..] `zip` map (map (indexGVertex' key_map) . thd3) sorted_vertices
key_map = array bounds0 $ [0..] `zip` map fst3 sorted_vertices
vertex_map = array bounds0 $ [0..] `zip` map snd3 sorted_vertices
indexGVertex' :: Ord i => Array G.Vertex i -> i -> G.Vertex
indexGVertex' key_map k = go 0 (snd (bounds key_map))
where
go a b | a > b = error "Data.Graph.Wrapper.fromList: one of the edges of a vertex pointed to a vertex that was not supplied in the input"
| otherwise = case compare k (key_map ! mid) of
LT -> go a (mid 1)
EQ -> mid
GT -> go (mid + 1) b
where mid = (a + b) `div` 2
vertices :: Graph i v -> [i]
vertices g = map (gVertexIndex g) $ G.vertices (graph g)
edges :: Graph i v -> [Edge i]
edges g = map (\(x, y) -> (gVertexIndex g x, gVertexIndex g y)) $ G.edges (graph g)
successors :: Ord i => Graph i v -> i -> [i]
successors g i = map (gVertexIndex g) (graph g ! indexGVertex g i)
outdegree :: Ord i => Graph i v -> i -> Int
outdegree g = \i -> outdegrees ! indexGVertex g i
where outdegrees = G.outdegree (graph g)
indegree :: Ord i => Graph i v -> i -> Int
indegree g = \i -> indegrees ! indexGVertex g i
where indegrees = G.indegree (graph g)
transpose :: Graph i v -> Graph i v
transpose g = g { graph = G.transposeG (graph g) }
topologicalSort :: Graph i v -> [i]
topologicalSort g = map (gVertexIndex g) $ G.topSort (graph g)
reachableVertices :: Ord i => Graph i v -> i -> [i]
reachableVertices g = map (gVertexIndex g) . G.reachable (graph g) . indexGVertex g
hasPath :: Ord i => Graph i v -> i -> i -> Bool
hasPath g i1 = (`elem` reachableVertices g i1)
depthNumbering :: Ord i => Graph i v -> [i] -> Graph i (v, Maybe Int)
depthNumbering g is = runST $ do
depth_array <- newArray (bounds (graph g)) Nothing :: ST s (STArray s G.Vertex (Maybe Int))
let
atDepth gv depth = do
mb_old_depth <- readArray depth_array gv
let depth' = maybe depth (`min` depth) mb_old_depth
depth' `seq` writeArray depth_array gv (Just depth')
let gos seen depth gvs = mapM_ (go seen depth) gvs
go seen depth gv
| depth `seq` False = error "depthNumbering: unreachable"
| gv `IS.member` seen = return ()
| otherwise = do
gv `atDepth` depth
gos (IS.insert gv seen) (depth + 1) (graph g ! gv)
gos IS.empty 0 (map (indexGVertex g) is)
gvva <- amapWithKeyM (\gv v -> liftM (\mb_depth -> (v, mb_depth)) $ readArray depth_array gv) (gVertexVertexArray g)
return $ g { gVertexVertexArray = gvva }
data SCC i = AcyclicSCC i
| CyclicSCC [i]
deriving (Show)
instance Functor SCC where
fmap f (AcyclicSCC v) = AcyclicSCC (f v)
fmap f (CyclicSCC vs) = CyclicSCC (map f vs)
instance Foldable.Foldable SCC where
foldMap f (AcyclicSCC v) = f v
foldMap f (CyclicSCC vs) = Foldable.foldMap f vs
instance Traversable.Traversable SCC where
traverse f (AcyclicSCC v) = fmap AcyclicSCC (f v)
traverse f (CyclicSCC vs) = fmap CyclicSCC (Traversable.traverse f vs)
stronglyConnectedComponents :: Graph i v -> [SCC i]
stronglyConnectedComponents g = map decode forest
where
forest = G.scc (graph g)
decode (G.Node v []) | mentions_itself v = CyclicSCC [gVertexIndex g v]
| otherwise = AcyclicSCC (gVertexIndex g v)
decode other = CyclicSCC (dec other [])
where dec (G.Node v ts) vs = gVertexIndex g v : foldr dec vs ts
mentions_itself v = v `elem` (graph g ! v)
sccGraph :: Ord i => Graph i v -> Graph (S.Set i) (M.Map i v)
sccGraph g = fromList nodes'
where
(_final_i2scc_i, nodes') = mapAccumL go M.empty (stronglyConnectedComponents g)
go i2scc_i scc = (i2scc_i', (scc_i,
Foldable.foldMap (\i -> M.singleton i (vertex g i)) scc,
Foldable.foldMap (\i -> map (fromJust . (`M.lookup` i2scc_i')) (successors g i)) scc))
where
scc_i = Foldable.foldMap S.singleton scc
i2scc_i' = i2scc_i `M.union` Foldable.foldMap (\i -> M.singleton i scc_i) scc