BFS in *.Algorithm modules

src/Algebra/Graph/AdjacencyIntMap/Algorithm.hs

@@ -1,3 +1,5 @@
+{-# language LambdaCase #-}
+
 -----------------------------------------------------------------------------
 -- |
 -- Module     : Algebra.Graph.AdjacencyIntMap.Algorithm
@@ -15,13 +17,15 @@
 -----------------------------------------------------------------------------
 module Algebra.Graph.AdjacencyIntMap.Algorithm (
     -- * Algorithms
-    dfsForest, dfsForestFrom, dfs, reachable, topSort, isAcyclic,
-
+    bfsForest, bfsForestFrom, bfs, dfsForest, dfsForestFrom, dfs, reachable,
+    topSort, isAcyclic,
+
     -- * Correctness properties
     isDfsForestOf, isTopSortOf
     ) where
 
 import Control.Monad
+import Control.Monad.State.Strict
 import Data.Maybe
 import Data.Tree
 
@@ -31,6 +35,56 @@ import qualified Data.Graph.Typed   as Typed
 import qualified Data.IntMap.Strict as IntMap
 import qualified Data.IntSet        as IntSet
 
+-- | Compute the forest of a graph's vertices in breadth first order.
+-- Complexity: /O(n+m*log n)/ time and /O(n+m)/ space.
+--
+-- @
+-- bfsForest 'empty'                         == []
+-- 'forest' (bfsForest $ 'edge' 1 1)           == 'vertex' 1
+-- 'forest' (bfsForest $ 'edge' 1 2)           == 'edge' 1 2
+-- 'forest' (bfsForest $ 'edge' 2 1)           == 'vertices' [1,2]
+-- 'isSubgraphOf' ('forest' $ bfsForest x) x   == True
+-- bfsForest . 'forest' . bfsForest          == bfsForest
+-- 'forest' (bfsForest ('circuit' [1..5] + 'circuit' [5,4..1])) == 'path' [1,2,3] + 'path' [1,5,4]
+-- @
+bfsForest :: AdjacencyIntMap -> Forest Int
+bfsForest g = bfsForestFrom' (vertexList g) g
+
+-- | Like 'bfsForest', but the traversal is seeded by a list of
+-- vertices.  Let /s/ be the number of seed vertices. Complexity:
+-- /O(n+(s+m)*log n)/ time and /O(n+m)/ space.
+--
+-- @
+-- 'forest' (bfsForestFrom [1,2] $ 'edge' 1 2) == 'vertices' [1,2]
+-- 'forest' (bfsForestFrom [2]   $ 'edge' 2 1) == 'vertex' 2
+-- 'forest' (bfsForestFrom [3]   $ 'edge' 1 2) == empty
+-- 'forest' (bfsForestFrom [3] ('circuit' [1..5] + 'circuit' [5,4..1])) == 'path' [3,2,1] + 'path' [3,4,5]
+-- @
+bfsForestFrom :: [Int] -> AdjacencyIntMap -> Forest Int
+bfsForestFrom vs g = bfsForestFrom' [ v | v <- vs, hasVertex v g] g
+
+bfsForestFrom' :: [Int] -> AdjacencyIntMap -> Forest Int
+bfsForestFrom' vs g = evalState (bff vs) IntSet.empty where
+  bff [] = return []
+  bff (v:vs) = discovered v >>= \case
+    False -> bff vs
+    True -> (:) <$> unfoldTreeM_BF walk v <*> bff vs
+  walk v = (v,) <$> adjacentM v
+  adjacentM v = filterM discovered $ IntSet.toList (postIntSet v g)
+  discovered v = do new <- gets (not . IntSet.member v)
+                    when new $ modify' (IntSet.insert v)
+                    return new
+
+-- | Like 'bfsForestFrom' with the resulting forest flattened to a
+-- list of vertices. Let /s/ be the number of seed
+-- vertices. Complexity: /O(n+(s+m)*log n)/ time and /O(n+m)/ space.
+-- 
+-- @
+-- bfs [3] ('circuit' [1..5] + 'circuit' [5,4..1]) == [[3],[2,4],[1,5]]
+-- @
+bfs :: [Int] -> AdjacencyIntMap -> [[Int]]
+bfs vs = bfsForestFrom vs >=> levels
+
 -- | Compute the /depth-first search/ forest of a graph that corresponds to
 -- searching from each of the graph vertices in the 'Ord' @a@ order.
 --
@@ -50,6 +104,7 @@ import qualified Data.IntSet        as IntSet
 --                                          , Node { rootLabel = 3
 --                                                 , subForest = [ Node { rootLabel = 4
 --                                                                      , subForest = [] }]}]
+-- 'forest' (dfsForest $ 'circuit' [1..5] + 'circuit' [5,4..1]) == 'path' [1,2,3,4,5]
 -- @
 dfsForest :: AdjacencyIntMap -> Forest Int
 dfsForest = Typed.dfsForest . Typed.fromAdjacencyIntMap
@@ -75,6 +130,7 @@ dfsForest = Typed.dfsForest . Typed.fromAdjacencyIntMap
 --                                                                                 , subForest = [] }
 --                                                     , Node { rootLabel = 4
 --                                                            , subForest = [] }]
+-- 'forest' (dfsForestFrom [3] $ 'circuit' [1..5] + 'circuit' [5,4..1]) == 'path' [3,2,1,5,4]
 -- @
 dfsForestFrom :: [Int] -> AdjacencyIntMap -> Forest Int
 dfsForestFrom vs = Typed.dfsForestFrom vs . Typed.fromAdjacencyIntMap
@@ -93,6 +149,7 @@ dfsForestFrom vs = Typed.dfsForestFrom vs . Typed.fromAdjacencyIntMap
 -- dfs []    $ x                        == []
 -- dfs [1,4] $ 3 * (1 + 4) * (1 + 5)    == [1,5,4]
 -- 'isSubgraphOf' ('vertices' $ dfs vs x) x == True
+-- dfs [3] $ 'circuit' [1..5] + 'circuit' [5,4..1] == [3,2,1,5,4]
 -- @
 dfs :: [Int] -> AdjacencyIntMap -> [Int]
 dfs vs = concatMap flatten . dfsForestFrom vs
@@ -113,7 +170,7 @@ dfs vs = concatMap flatten . dfsForestFrom vs
 -- 'isSubgraphOf' ('vertices' $ reachable x y) y == True
 -- @
 reachable :: Int -> AdjacencyIntMap -> [Int]
-reachable x = dfs [x]
+reachable x = concat . bfs [x]
 
 -- | Compute the /topological sort/ of a graph or return @Nothing@ if the graph
 -- is cyclic.

src/Algebra/Graph/AdjacencyMap/Algorithm.hs

@@ -1,3 +1,5 @@
+{-# language LambdaCase #-}
+
 -----------------------------------------------------------------------------
 -- |
 -- Module     : Algebra.Graph.AdjacencyMap.Algorithm
@@ -15,13 +17,15 @@
 -----------------------------------------------------------------------------
 module Algebra.Graph.AdjacencyMap.Algorithm (
     -- * Algorithms
-    dfsForest, dfsForestFrom, dfs, reachable, topSort, isAcyclic, scc,
-
+    bfsForest, bfsForestFrom, bfs, dfsForest, dfsForestFrom, dfs, reachable,
+    topSort, isAcyclic, scc,
+
     -- * Correctness properties
     isDfsForestOf, isTopSortOf
     ) where
 
 import Control.Monad
+import Control.Monad.State.Strict
 import Data.Foldable (toList)
 import Data.Maybe
 import Data.Tree
@@ -34,6 +38,57 @@ import qualified Data.Graph.Typed                    as Typed
 import qualified Data.Map.Strict                     as Map
 import qualified Data.Set                            as Set
 
+-- | Compute the forest of a graph's vertices in breadth first order. Complexity:
+-- /O(n+m*log n)/ time and /O(n+m)/ space.
+--
+-- @
+-- bfsForest 'empty'                         == []
+-- 'forest' (bfsForest $ 'edge' 1 1)           == 'vertex' 1
+-- 'forest' (bfsForest $ 'edge' 1 2)           == 'edge' 1 2
+-- 'forest' (bfsForest $ 'edge' 2 1)           == 'vertices' [1,2]
+-- 'isSubgraphOf' ('forest' $ bfsForest x) x   == True
+-- bfsForest . 'forest' . bfsForest          == bfsForest
+-- 'forest' (bfsForest ('circuit' [1..5] + 'circuit' [5,4..1])) == 'path' [1,2,3] + 'path' [1,5,4]
+-- @
+bfsForest :: Ord a => AdjacencyMap a -> Forest a
+bfsForest g = bfsForestFrom' (vertexList g) g
+
+-- | Like 'bfsForest', but the traversal is seeded by a list of
+-- vertices. Seed vertices not in the graph are ignored. Let /s/ be
+-- the number of seed vertices. Complexity: /O(n+(s+m)*log n)/ time
+-- and /O(n+m)/ space.
+--
+-- @
+-- 'forest' (bfsForestFrom [1,2] $ 'edge' 1 2) == 'vertices' [1,2]
+-- 'forest' (bfsForestFrom [2]   $ 'edge' 1 2) == 'vertex' 2
+-- 'forest' (bfsForestFrom [3]   $ 'edge' 1 2) == empty
+-- 'forest' (bfsForestFrom [3] ('circuit' [1..5] + 'circuit' [5,4..1])) == 'path' [3,2,1] + 'path' [3,4,5]
+-- @
+bfsForestFrom :: Ord a => [a] -> AdjacencyMap a -> Forest a
+bfsForestFrom vs g = bfsForestFrom' [ v | v <- vs, hasVertex v g ] g
+
+bfsForestFrom' :: Ord a => [a] -> AdjacencyMap a -> Forest a
+bfsForestFrom' vs g = evalState (bff vs) Set.empty where
+  bff [] = return []
+  bff (v:vs) = discovered v >>= \case
+    False -> bff vs
+    True -> (:) <$> unfoldTreeM_BF walk v <*> bff vs
+  walk v = (v,) <$> adjacentM v
+  adjacentM v = filterM discovered $ Set.toList (postSet v g)
+  discovered v = do new <- gets (not . Set.member v)
+                    when new $ modify' (Set.insert v)
+                    return new
+
+-- | Like 'bfsForestFrom' with the resulting forest flattened to a
+-- list of vertices. Let /s/ be the number of seed
+-- vertices. Complexity: /O(n+(s+m)*log n)/ time and /O(n+m)/ space.
+--
+-- @
+-- bfs [3] ('circuit' [1..5] + ('circuit' [5,4..1])) == [[3],[2,4],[1,5]]
+-- @
+bfs :: Ord a => [a] -> AdjacencyMap a -> [[a]]
+bfs vs = bfsForestFrom vs >=> levels
+
 -- | Compute the /depth-first search/ forest of a graph that corresponds to
 -- searching from each of the graph vertices in the 'Ord' @a@ order.
 --
@@ -53,6 +108,7 @@ import qualified Data.Set                            as Set
 --                                          , Node { rootLabel = 3
 --                                                 , subForest = [ Node { rootLabel = 4
 --                                                                      , subForest = [] }]}]
+-- 'forest' (dfsForest $ 'circuit' [1..5] + 'circuit' [5,4..1]) == 'path' [1,2,3,4,5]
 -- @
 dfsForest :: Ord a => AdjacencyMap a -> Forest a
 dfsForest g = dfsForestFrom (vertexList g) g
@@ -78,6 +134,7 @@ dfsForest g = dfsForestFrom (vertexList g) g
 --                                                                                 , subForest = [] }
 --                                                     , Node { rootLabel = 4
 --                                                            , subForest = [] }]
+--  'forest' (dfsForestFrom [3] $ 'circuit' [1..5] + 'circuit' [5,4..1]) == 'path' [3,2,1,5,4]
 -- @
 dfsForestFrom :: Ord a => [a] -> AdjacencyMap a -> Forest a
 dfsForestFrom vs = Typed.dfsForestFrom vs . Typed.fromAdjacencyMap
@@ -96,13 +153,14 @@ dfsForestFrom vs = Typed.dfsForestFrom vs . Typed.fromAdjacencyMap
 -- dfs []    $ x                        == []
 -- dfs [1,4] $ 3 * (1 + 4) * (1 + 5)    == [1,5,4]
 -- 'isSubgraphOf' ('vertices' $ dfs vs x) x == True
+-- dfs [3] $ 'circuit' [1..5] + 'circuit' [5,4..1] == [3,2,1,5,4]
 -- @
 dfs :: Ord a => [a] -> AdjacencyMap a -> [a]
 dfs vs = concatMap flatten . dfsForestFrom vs
 
--- | Compute the list of vertices that are /reachable/ from a given source
--- vertex in a graph. The vertices in the resulting list appear in the
--- /depth-first order/.
+-- | Compute the list of vertices that are /reachable/ from a given
+-- source vertex in a graph. The vertices in the resulting list appear
+-- in the /depth-first order/.
 --
 -- @
 -- reachable x $ 'empty'                       == []
@@ -116,7 +174,7 @@ dfs vs = concatMap flatten . dfsForestFrom vs
 -- 'isSubgraphOf' ('vertices' $ reachable x y) y == True
 -- @
 reachable :: Ord a => a -> AdjacencyMap a -> [a]
-reachable x = dfs [x]
+reachable x = concat . bfs [x]
 
 -- | Compute the /topological sort/ of a graph or return @Nothing@ if the graph
 -- is cyclic.

src/Data/Graph/Typed.hs

@@ -181,3 +181,4 @@ dfs vs = concatMap flatten . dfsForestFrom vs
 -- @
 topSort :: GraphKL a -> [a]
 topSort (GraphKL g r _) = map r (KL.topSort g)
+

test/Algebra/Graph/Test/API.hs

@@ -100,6 +100,9 @@ data API g c where
         , dfsForest                  :: forall a. c a => g a -> Forest a
         , dfsForestFrom              :: forall a. c a => [a] -> g a -> Forest a
         , dfs                        :: forall a. c a => [a] -> g a -> [a]
+        , bfsForest                  :: forall a. c a => g a -> Forest a
+        , bfsForestFrom              :: forall a. c a => [a] -> g a -> Forest a
+        , bfs                        :: forall a. c a => [a] -> g a -> [[a]]
         , reachable                  :: forall a. c a => a -> g a -> [a]
         , topSort                    :: forall a. c a => g a -> Maybe [a]
         , isAcyclic                  :: forall a. c a => g a -> Bool
@@ -179,6 +182,9 @@ adjacencyMapAPI = API
     , dfsForest                  = AM.dfsForest
     , dfsForestFrom              = AM.dfsForestFrom
     , dfs                        = AM.dfs
+    , bfsForest                  = AM.bfsForest
+    , bfsForestFrom              = AM.bfsForestFrom
+    , bfs                        = AM.bfs
     , reachable                  = AM.reachable
     , topSort                    = AM.topSort
     , isAcyclic                  = AM.isAcyclic
@@ -324,6 +330,9 @@ adjacencyIntMapAPI = API
     , dfsForest                  = coerce AIM.dfsForest
     , dfsForestFrom              = coerce AIM.dfsForestFrom
     , dfs                        = coerce AIM.dfs
+    , bfsForest                  = coerce AIM.bfsForest
+    , bfsForestFrom              = coerce AIM.bfsForestFrom
+    , bfs                        = coerce AIM.bfs
     , reachable                  = coerce AIM.reachable
     , topSort                    = coerce AIM.topSort
     , isAcyclic                  = coerce AIM.isAcyclic

test/Algebra/Graph/Test/AdjacencyIntMap.hs

@@ -44,6 +44,9 @@ testAdjacencyIntMap = do
     testDfsForest            t
     testDfsForestFrom        t
     testDfs                  t
+    testBfsForest            t
+    testBfsForestFrom        t
+    testBfs                  t
     testReachable            t
     testTopSort              t
     testIsAcyclic            t

test/Algebra/Graph/Test/AdjacencyMap.hs

@@ -50,6 +50,9 @@ testAdjacencyMap = do
     testDfsForest         t
     testDfsForestFrom     t
     testDfs               t
+    testBfsForest         t
+    testBfsForestFrom     t
+    testBfs               t
     testReachable         t
     testTopSort           t
     testIsAcyclic         t