Adding BFS support to AdjacencyMaps.

src/Algebra/Graph/AdjacencyMap/Algorithm.hs

@@ -15,7 +15,7 @@
 -----------------------------------------------------------------------------
 module Algebra.Graph.AdjacencyMap.Algorithm (
     -- * Algorithms
-    dfsForest, dfsForestFrom, dfs, reachable, topSort, isAcyclic, scc,
+    dfsForest, dfsForestFrom, dfs, bfsForest, bfsForestFrom, bfs, reachable, topSort, isAcyclic, scc,
 
     -- * Correctness properties
     isDfsForestOf, isTopSortOf
@@ -34,6 +34,7 @@ import qualified Data.Graph                          as KL
 import qualified Data.Graph.Typed                    as Typed
 import qualified Data.Map.Strict                     as Map
 import qualified Data.Set                            as Set
+import qualified Data.Sequence                       as Seq
 
 -- | Compute the /depth-first search/ forest of a graph that corresponds to
 -- searching from each of the graph vertices in the 'Ord' @a@ order.
@@ -233,3 +234,147 @@ isTopSortOf xs m = go Set.empty xs
                   && go newSeen vs
       where
         newSeen = Set.insert v seen
+
+-- | Compute the /breadth-first search/ forest of a graph that corresponds to
+-- searching from each of the graph vertices in the 'Ord' @a@ order.
+-- Complexity: /O((n + m) * log(n))/ time and O(n+m) memory.
+-- @
+-- 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
+-- 'isbfsForestOf' (bfsForest x) x         == True
+-- bfsForest . 'forest' . bfsForest        == bfsForest
+-- bfsForest ('vertices' vs)               == 'map' (\\v -> Node v []) ('Data.List.nub' $ 'Data.List.sort' vs)
+-- bfsForest $ 1 * (3+5+7) + 3 * (5+4) + (4+3+5+7) * 6 ==  [Node {rootLabel = 1
+--                                                               , subForest = [Node {rootLabel = 3
+--                                                                                   , subForest = [ Node {rootLabel = 4
+--                                                                                                        , subForest = [] }
+--                                                                                                 , Node {rootLabel = 6
+--                                                                                                        , subForest = [] }]}
+--                                                                             , Node {rootLabel = 5
+--                                                                                    , subForest = [] }
+--                                                                             , Node {rootLabel = 7
+--                                                                                    , subForest = [] }]}]
+-- @
+bfsForest :: Ord a => AdjacencyMap a -> Forest a
+bfsForest g = bfsForestFrom (vertexList g) g
+
+
+-- | Compute the /breadth-first search/ AdjacencyMap of a graph that corresponds to
+-- searching from a single vertex of the graph. 
+-- Complexity: /O((n + m) * log(n))/ time and O(n+m) memory.
+bfsTreeAdjacencyMap :: Ord a => a -> AdjacencyMap a -> AdjacencyMap a
+bfsTreeAdjacencyMap s g = case (hasVertex s g) of
+    True -> bfsTreeAdjacencyMapUtil (Seq.singleton s) initVisited g 
+        where initVisited = Map.unionsWith (||) $ ( Map.singleton s True):(map (\x -> Map.singleton x False) (vertexList g))
+    _ -> empty
+
+-- | Compute the /breadth-first search/ AdjacencyMap of a graph that corresponds to
+-- searching from the head of a queue (followed by other vertices to search from), 
+-- given a Set of seen vertices (vertices that shouldn't be visited).
+-- Complexity: /O((n + m) * log(n))/ time and O(n+m) memory.
+bfsTreeAdjacencyMapUtil :: Ord a => Seq.Seq a -> Map.Map a Bool -> AdjacencyMap a -> AdjacencyMap a
+bfsTreeAdjacencyMapUtil queue visited g
+    | queue == Seq.empty = empty
+    | otherwise = overlay (AM.AM $ Map.singleton v vSet) (bfsTreeAdjacencyMapUtil newQueue newVisited g)
+        where
+            v Seq.:< qv = Seq.viewl queue
+            neighbors = postSet v g
+            (newQueue, newVisited, vSet) = bfsTreeNewParams neighbors visited qv
+
+
+-- | Compute the /breadth-first search/ intermediate values for `bfsTreeAdjacencyMapUtil`. Given a set of neighbors
+-- (source doesnt matter), a map of visisted nodes (Map a Bool) and a queue (Sequence), obtain the new queue, update
+-- map and set of vertices to add to the graph.
+-- Complexity: /O((n + m) * log(n))/ time and O(n+m) memory.
+bfsTreeNewParams :: (Ord a) => Set.Set a -> Map.Map a Bool -> Seq.Seq a -> (Seq.Seq a, Map.Map a Bool, Set.Set a)
+bfsTreeNewParams neighbors visited queue = (newQueue, newVisited, vSet )
+            where vSet = Set.filter (\x -> (not . fromJust . Map.lookup x) visited) neighbors
+                  vList = Set.toAscList vSet
+                  newQueue = foldl (Seq.|>) queue vList
+                  newVisited = Map.unionsWith (||) $ visited : (map (\x -> Map.singleton x True) vList)
+
+-- | Compute the /breadth-first search/ Tree of a graph that corresponds to
+-- searching from a single vertex of the graph. This is just for internal use. 
+-- Might move it to `*.Internal` then?
+-- Complexity: /O((n + m) * log(n))/ time and O(n+m) memory.
+bfsTree :: Ord a => a -> AdjacencyMap a -> Tree a
+bfsTree s g = unfoldTree neighbors s
+    where neighbors b = (b, Set.toAscList . postSet b $ bfsAM)
+          bfsAM = bfsTreeAdjacencyMap s g
+
+-- | Compute the /breadth-first search/ forest of a graph, searching from each of
+-- the given vertices in order. Note that the resulting forest does not
+-- necessarily span the whole graph, as some vertices may be unreachable.
+-- Complexity: /O((n + m) * log(n))/ time and O(n+m) memory.
+-- bfsForestFrom vs 'empty'                                      == []
+-- 'forest' (bfsForestFrom [1]   $ 'edge' 1 1)                   == 'vertex' 1
+-- 'forest' (bfsForestFrom [1]   $ 'edge' 1 2)                   == 'edge' 1 2
+-- 'forest' (bfsForestFrom [2]   $ 'edge' 1 2)                   == 'vertex' 2
+-- 'forest' (bfsForestFrom [3]   $ 'edge' 1 2)                   == 'empty'
+-- 'forest' (bfsForestFrom [2,1] $ 'edge' 1 2)                   == 'vertices' [1,2]
+-- 'isSubgraphOf' ('forest' $ bfsForestFrom vs x) x              == True
+-- bfsForestFrom ('vertexList' x) x                              == 'bfsForest' x
+-- bfsForestFrom vs             ('vertices' vs)                  == 'map' (\\v -> Node v []) ('Data.List.nub' vs)
+-- bfsForestFrom []             x                                == []
+-- bfsForestFrom [1,4] $ 1 * (3+5+7) + 3 * (5+4) + (4+3+5+7) * 6 ==  [ Node { rootLabel = 3
+--                                                                          , subForest = [ Node { rootLabel = 4
+--                                                                                                 , subForest = []}
+--                                                                                        , Node { rootLabel = 5
+--                                                                                               , subForest = []}
+--                                                                                        , Node { rootLabel = 6
+--                                                                                               , subForest = [] }]}
+--                                                                   , Node { rootLabel = 1
+--                                                                          , subForest = [ Node { rootLabel = 7
+--                                                                                               , subForest = [] }]}]
+-- @
+bfsForestFrom :: Ord a => [a] -> AdjacencyMap a -> Forest a
+bfsForestFrom [] _ = []
+bfsForestFrom (v:vs) g
+    | hasVertex v g = headTree:bfsForestFrom vs (induce remove g)
+    | otherwise = bfsForestFrom vs g
+        where headTree = bfsTree v g
+              removedVertices = flatten headTree
+              remove x = not $ elem x removedVertices
+
+-- -- | Compute the list of vertices visited by the /breadth-first search/ by level in a
+-- graph, when searching from each of the given vertices in order.
+-- Complexity: /O((n + m) * log(n))/ time and O(n+m) memory.
+-- @
+-- bfs vs    $ 'empty'                    == []
+-- bfs [1]   $ 'edge' 1 1                 == [[1]]
+-- bfs [1]   $ 'edge' 1 2                 == [[1],[2]]
+-- bfs [2]   $ 'edge' 1 2                 == [[2]]
+-- bfs [3]   $ 'edge' 1 2                 == []
+-- bfs [1,2] $ 'edge' 1 2                 == [[1],[2]]
+-- bfs [2,1] $ 'edge' 1 2                 == [[2,1]]
+-- bfs []    $ x                        == []
+-- bfs [1,4] $ 3 * (1 + 4) * (1 + 5)    == [[1,4],[5]]
+-- @
+bfs :: Ord a => [a] -> AdjacencyMap a -> [[a]]
+bfs vs g = foldr (zipWith (++)) acc (map (++ repeat []) l)
+    where l = bfsPerTree vs g 
+          maxLength = case l of
+            [] -> 0
+            _ -> maximum (map length l)
+          acc = [ [] | _<-[1..maxLength]]
+
+
+-- -- | Compute the list of vertices visited by the /breadth-first search/ in a graph.
+-- For every tree in the forest, a different list of vertices by level is given.
+-- Complexity: /O((n + m) * log(n))/ time and O(n+m) memory.
+-- @
+-- bfsPerTree vs    $ 'empty'                    == []
+-- bfsPerTree [1]   $ 'edge' 1 1                 == [[[1]]]
+-- bfsPerTree [1]   $ 'edge' 1 2                 == [[[1],[2]]]
+-- bfsPerTree [2]   $ 'edge' 1 2                 == [[[2]]]
+-- bfsPerTree [3]   $ 'edge' 1 2                 == []
+-- bfsPerTree [1,2] $ 'edge' 1 2                 == [[[1],[2]]]
+-- bfsPerTree [2,1] $ 'edge' 1 2                 == [[[2]],[[1]]]
+-- bfsPerTree []    $ x                        == []
+-- bfsPerTree [1,4] $ 3 * (1 + 4) * (1 + 5)    == [[[1],[5]],[[4]]]
+-- @
+bfsPerTree :: Ord a => [a] -> AdjacencyMap a -> [[[a]]]
+bfsPerTree vs = (map levels . bfsForestFrom vs)