diff --git a/Data/Graph/Wrapper.hs b/Data/Graph/Wrapper.hs --- a/Data/Graph/Wrapper.hs +++ b/Data/Graph/Wrapper.hs @@ -24,15 +24,19 @@ reachableVertices, hasPath, - topologicalSort, + 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 @@ -53,6 +57,15 @@ thd3 (_, _, c) = c +-- amapWithKey :: Ix i => (i -> v -> v') -> Array i v -> Array i v' +-- -- More efficient, but not portable (uses GHC.Arr exports): +-- --amapWithKey f arr = unsafeArray' (bounds arr) (numElements arr) [(i, f i (unsafeAt arr i)) | i <- [0 .. n - 1]] +-- amapWithKey f arr = array (bounds arr) [(i, f i v) | (i, v) <- assocs arr] + +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) + + -- | An edge from the first vertex to the second type Edge i = (i, i) @@ -76,9 +89,14 @@ traverse f g = fmap (\gvva -> g { gVertexVertexArray = gvva }) (Traversable.traverse f (gVertexVertexArray g)) +{-# RULES "indexGVertex/gVertexIndex" forall g i. gVertexIndex g (indexGVertex g i) = i #-} +{-# RULES "gVertexIndex/indexGVertex" forall g v. indexGVertex g (gVertexIndex g v) = v #-} + +{-# NOINLINE [0] indexGVertex #-} indexGVertex :: Ord i => Graph i v -> i -> G.Vertex indexGVertex g i = indexGVertex' (indexGVertexArray g) i +{-# NOINLINE [0] gVertexIndex #-} gVertexIndex :: Graph i v -> G.Vertex -> i gVertexIndex g gv = indexGVertexArray g ! gv @@ -175,7 +193,7 @@ -- | Topological sort of of the graph (). If the graph is acyclic, -- vertices will only appear in the list once all of those vertices with arrows to them have already appeared. -- --- Vertex i precedes j in the output whenever j is reachable from i but not vice versa. +-- Vertex /i/ precedes /j/ in the output whenever /j/ is reachable from /i/ but not vice versa. topologicalSort :: Graph i v -> [i] topologicalSort g = map (gVertexIndex g) $ G.topSort (graph g) @@ -184,10 +202,51 @@ reachableVertices g = map (gVertexIndex g) . G.reachable (graph g) . indexGVertex g -- | Is the second vertex reachable by following edges from the first vertex? -hasPath :: Ord i => Graph i v -> Edge i -> Bool -hasPath g (i1, i2) = G.path (graph g) (indexGVertex g i1) (indexGVertex g i2) +-- +-- It is worth sharing a partial application of 'hasPath' to the first vertex if you are testing for several +-- vertices being reachable from it. +hasPath :: Ord i => Graph i v -> i -> i -> Bool +hasPath g i1 = (`elem` reachableVertices g i1) +-- | Number the vertices in the graph by how far away they are from the given roots. The roots themselves have depth 0, +-- and every subsequent link we traverse adds 1 to the depth. If a vertex is not reachable it will have a depth of 'Nothing'. +depthNumbering :: Ord i => Graph i v -> [i] -> Graph i (v, Maybe Int) +depthNumbering g is = runST $ do + -- This array records the minimum known depth for the node at the moment + depth_array <- newArray (bounds (graph g)) Nothing :: ST s (STArray s G.Vertex (Maybe Int)) + let -- Lets us adjust the known depth given a new observation + 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') + -- Do an depth-first search on the graph (checking for cycles to prevent non-termination), + -- recording the depth at which any node was seen in that array. + 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) + + -- let go _ _ [] = return () + -- go seen depth gvs = do + -- let go_one (seen, next_gvs) gv + -- | gv `IS.member` seen = return (seen, next_gvs) + -- | otherwise = do gv `atDepth` depth + -- return (IS.insert gv seen, next_gvs ++ (graph g ! gv)) + -- (seen, next_gvs) <- foldM go_one (seen, []) gvs + -- go seen (depth + 1) next_gvs + -- + -- go 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) @@ -212,8 +271,8 @@ -- 1) Within the SCC itself (in the case of a 'CyclicSCC' only) -- 2) Or from a node in a SCC later on in the list -- --- Vertex i strictly precedes j in the output whenever i is reachable from j but not vice versa. --- Vertex i occurs in the same SCC as j whenever both i is reachable from j and j is reachable from i. +-- Vertex /i/ strictly precedes /j/ in the output whenever /i/ is reachable from /j/ but not vice versa. +-- Vertex /i/ occurs in the same SCC as /j/ whenever both /i/ is reachable from /j/ and /j/ is reachable from /i/. stronglyConnectedComponents :: Graph i v -> [SCC i] stronglyConnectedComponents g = map decode forest where diff --git a/graph-wrapper.cabal b/graph-wrapper.cabal --- a/graph-wrapper.cabal +++ b/graph-wrapper.cabal @@ -1,7 +1,7 @@ Cabal-Version: >= 1.2 Build-Type: Simple Name: graph-wrapper -Version: 0.1 +Version: 0.1.1 Maintainer: Max Bolingbroke Homepage: http://www.github.com/batterseapower/graph-wrapper License: BSD3 @@ -15,4 +15,4 @@ Build-Depends: base >= 3.0 && < 5.0, array >= 0.3 && < 0.4, - containers >= 0.3 && < 0.4 + containers >= 0.3 && < 0.5