diff --git a/src/Algebra/Graph/AdjacencyMap/Algorithm.hs b/src/Algebra/Graph/AdjacencyMap/Algorithm.hs index 79ad606cd..a7bd34fa5 100644 --- a/src/Algebra/Graph/AdjacencyMap/Algorithm.hs +++ b/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) \ No newline at end of file