diff --git a/containers-tests/tests/graph-properties.hs b/containers-tests/tests/graph-properties.hs index 0eb58adc5..55d5b71b2 100644 --- a/containers-tests/tests/graph-properties.hs +++ b/containers-tests/tests/graph-properties.hs @@ -7,6 +7,7 @@ import qualified Data.Foldable as F import qualified Data.Graph as G import qualified Data.List as L import qualified Data.Set as S +import qualified Data.Tree as Tree default (Int) @@ -128,14 +129,14 @@ prop_dfs (Graph g) = in forAll vsgen $ \vs -> let ts = G.dfs g vs in S.fromList (concatMap F.toList ts) `S.isSubsetOf` S.fromList (G.vertices g) .&&. - S.fromList (concatMap treeEdges ts) `S.isSubsetOf` S.fromList (G.edges g) + S.fromList (concatMap Tree.edges ts) `S.isSubsetOf` S.fromList (G.edges g) -- Note: This tests some simple properties but not complete correctness prop_dff :: Graph -> Property prop_dff (Graph g) = let ts = G.dff g in L.sort (concatMap F.toList ts) === G.vertices g .&&. - S.fromList (concatMap treeEdges ts) `S.isSubsetOf` S.fromList (G.edges g) + S.fromList (concatMap Tree.edges ts) `S.isSubsetOf` S.fromList (G.edges g) prop_topSort :: DAG -> Property prop_topSort (DAG g) = @@ -147,7 +148,7 @@ prop_scc :: Graph -> Property prop_scc (Graph g) = let ts = G.scc g in L.sort (concatMap F.toList ts) === G.vertices g .&&. - S.fromList (concatMap treeEdges ts) `S.isSubsetOf` S.fromList (G.edges g) .&&. + S.fromList (concatMap Tree.edges ts) `S.isSubsetOf` S.fromList (G.edges g) .&&. -- vertices in a component are mutually reachable and [G.path g u v | t <- ts, u <- F.toList t, v <- F.toList t] .&&. -- vertices in later components are not reachable from earlier components, due to reverse @@ -160,7 +161,7 @@ prop_bcc (UndirectedG g) = comps = concatMap F.toList ts :: [[G.Vertex]] in S.fromList (concat comps) `S.isSubsetOf` S.fromList (G.vertices g) .&&. all testBCC comps .&&. - all (uncurry testBCCs) (concatMap treeEdges ts) + all (uncurry testBCCs) (concatMap Tree.edges ts) where -- a biconnected component remains connected even if any single vertex is removed testBCC c = and [subsetComponents (L.delete x c) == 1 | x <- c] @@ -194,7 +195,3 @@ prop_stronglyConnCompR (AdjList adj) = testSCC (G.AcyclicSCC (_, k, ks)) = k `notElem` ks testSCC (G.CyclicSCC [(_, k, ks)]) = k `elem` ks testSCC (G.CyclicSCC xs) = and [G.path g (getv k) (getv k') | (_,k,_) <- xs , (_,k',_) <- xs] - -treeEdges :: G.Tree a -> [(a, a)] -treeEdges t = go t [] - where go (G.Node x ts) acc = [(x,y) | G.Node y _ <- ts] ++ foldr go acc ts diff --git a/containers/src/Data/Graph.hs b/containers/src/Data/Graph.hs index 600b2b1ea..25e8e7e23 100644 --- a/containers/src/Data/Graph.hs +++ b/containers/src/Data/Graph.hs @@ -119,6 +119,7 @@ import Data.IntSet (IntSet) import qualified Data.IntSet as Set #endif import Data.Tree (Tree(..), Forest) +import qualified Data.Tree as Tree -- std interfaces import Data.Foldable as F @@ -647,15 +648,6 @@ run _ f = fst (runSetM (f contains include) Set.empty) -- Algorithm 1: depth first search numbering ------------------------------------------------------------ -preorder' :: Tree a -> [a] -> [a] -preorder' (Node a ts) = (a :) . preorderF' ts - -preorderF' :: [Tree a] -> [a] -> [a] -preorderF' ts = foldr (.) id $ map preorder' ts - -preorderF :: [Tree a] -> [a] -preorderF ts = preorderF' ts [] - tabulate :: Bounds -> [Vertex] -> UArray Vertex Int tabulate bnds vs = UA.array bnds (zipWith (flip (,)) [1..] vs) -- Why zipWith (flip (,)) instead of just using zip with the @@ -664,21 +656,12 @@ tabulate bnds vs = UA.array bnds (zipWith (flip (,)) [1..] vs) -- list argument. preArr :: Bounds -> [Tree Vertex] -> UArray Vertex Int -preArr bnds = tabulate bnds . preorderF +preArr bnds = tabulate bnds . concatMap Tree.flatten ------------------------------------------------------------ -- Algorithm 2: topological sorting ------------------------------------------------------------ -postorder :: Tree a -> [a] -> [a] -postorder (Node a ts) = postorderF ts . (a :) - -postorderF :: [Tree a] -> [a] -> [a] -postorderF ts = foldr (.) id $ map postorder ts - -postOrd :: Graph -> [Vertex] -postOrd g = postorderF (dff g) [] - -- | \(O(V+E)\). A topological sort of the graph. -- The order is partially specified by the condition that a vertex /i/ -- precedes /j/ whenever /j/ is reachable from /i/ but not vice versa. @@ -686,8 +669,14 @@ postOrd g = postorderF (dff g) [] -- Note: A topological sort exists only when there are no cycles in the graph. -- If the graph has cycles, the output of this function will not be a -- topological sort. In such a case consider using 'scc'. -topSort :: Graph -> [Vertex] -topSort = reverse . postOrd +topSort :: Graph -> [Vertex] +topSort = reversePostOrder' . dff + +-- Generates the result list at once. This is more efficient that being lazy if +-- we will consume the full result anyway. +reversePostOrder' :: [Tree a] -> [a] +reversePostOrder' = + F.foldl' (\xs t -> F.foldl' (flip (:)) xs (Tree.PostOrder t)) [] -- | \(O(V+E)\). Reverse ordering of `topSort`. -- @@ -695,7 +684,7 @@ topSort = reverse . postOrd -- -- @since 0.6.4 reverseTopSort :: Graph -> [Vertex] -reverseTopSort = postOrd +reverseTopSort = concatMap (F.toList . Tree.PostOrder) . dff ------------------------------------------------------------ -- Algorithm 3: connected components @@ -721,8 +710,8 @@ undirected g = buildG (bounds g) (edges g ++ reverseE g) -- > == [Node {rootLabel = 0, subForest = [Node {rootLabel = 1, subForest = [Node {rootLabel = 2, subForest = []}]}]} -- > ,Node {rootLabel = 3, subForest = []}] -scc :: Graph -> [Tree Vertex] -scc g = dfs g (reverse (postOrd (transposeG g))) +scc :: Graph -> [Tree Vertex] +scc g = dfs g (reversePostOrder' (dff (transposeG g))) ------------------------------------------------------------ -- Algorithm 5: Classifying edges @@ -764,7 +753,7 @@ mapT f t = array (bounds t) [ (,) v (f v (t!v)) | v <- indices t ] -- -- > reachable (buildG (0,2) [(0,1), (1,2)]) 0 == [0,1,2] reachable :: Graph -> Vertex -> [Vertex] -reachable g v = preorderF (dfs g [v]) +reachable g v = concatMap Tree.flatten (dfs g [v]) -- | \(O(V+E)\). Returns @True@ if the second vertex reachable from the first. --