diff --git a/src/Data/Graph.purs b/src/Data/Graph.purs index 0d030ea..f9bed04 100644 --- a/src/Data/Graph.purs +++ b/src/Data/Graph.purs @@ -26,6 +26,7 @@ module Data.Graph , isAdjacent , areConnected , shortestPath + , stronglyConnectedComponents , allPaths ) where @@ -42,11 +43,12 @@ import Data.List as L import Data.List as List import Data.Map (Map) import Data.Map as M -import Data.Maybe (Maybe(..), isJust, maybe) +import Data.Maybe (Maybe(..), fromJust, isJust, maybe) import Data.Set (Set) import Data.Set as S import Data.Set as Set import Data.Tuple (Tuple(..), fst, snd, uncurry) +import Partial.Unsafe (unsafePartial) -- | A graph with vertices of type `v`. -- | @@ -271,3 +273,61 @@ topologicalSort (Graph g) = initialState = { unvisited: g , result: Nil } + +-- | Tarjan's algorithm for Strongly Connected Components (SCCs). +-- | +-- | Defines a `Map` where each node is mapped to its equivalence class +-- | representative once the graph is partitioned into SCCs. +-- | +-- | Running time: O(|E| log |V|) +stronglyConnectedComponents :: forall k v. Ord k => Graph k v -> Map k k +stronglyConnectedComponents (Graph g) = + Foldable.foldl + ( \scc next -> + if isJust (M.lookup next scc) then + -- have already found the SCC representative of `next` + scc + else + dfs next M.empty scc + ) + M.empty + $ M.keys g + where + dfs :: k -> Map k Int -> Map k k -> Map k k + -- perform a depth-first search in the graph starting from `n` + -- `depth` tracks the depth at which each node is visited + -- `scc` is the accumulating map from each node to its representative in its + -- SCC + -- - when `scc` is defined on all vertices of the graph, the procedure is + -- complete + dfs n depth scc = case ( Foldable.foldl + ( \(Tuple sccAcc shallowest) c -> case M.lookup c depth of + -- fold over the children `c` of `n`; the accumulator is a pair + -- consisting of + -- - `sccAcc`: the accumulating SCC map + -- - `shallowest`: the shallowest node we have seen so far in + -- this branch of the DFS (this will become the + -- SCC representative) + Just _ -> Tuple sccAcc $ shallower shallowest c + Nothing -> + let + sccWithChildData = dfs c (M.insert n (M.size depth) depth) sccAcc + + shallowestForChild = unsafePartial $ fromJust $ M.lookup c sccWithChildData + -- not actually partial; `c` is guaranteed to be in the map + in + Tuple sccWithChildData $ shallower shallowest shallowestForChild + ) + (Tuple scc n) + $ children n (Graph g) + ) of + Tuple newState shallow -> M.insert n shallow newState -- `shallow` becomes the representative + -- of the SCC containing `n` + where + shallower :: k -> k -> k + -- determine whether `x` or `y` was visited first in the DFS, as determined + -- by `depth` + shallower x y = case (Tuple (M.lookup x depth) (M.lookup y depth)) of + Tuple _ Nothing -> x + Tuple Nothing _ -> y + Tuple (Just p) (Just q) -> if q < p then y else x diff --git a/test/Main.purs b/test/Main.purs index 9416037..18636d3 100644 --- a/test/Main.purs +++ b/test/Main.purs @@ -130,3 +130,7 @@ main = do Graph.allPaths 1 8 acyclicGraph `shouldEqual` Set.singleton (List.fromFoldable [ 1, 2, 4, 8 ]) Graph.allPaths 2 6 acyclicGraph `shouldEqual` Set.singleton (List.fromFoldable [ 2, 3, 6 ]) Graph.allPaths 5 3 cyclicGraph `shouldEqual` Set.singleton (List.fromFoldable [ 5, 1, 2, 3 ]) + describe "stronglyConnectedComponents" do + it "works for examples" do + Graph.stronglyConnectedComponents acyclicGraph `shouldEqual` (Map.fromFoldable [ Tuple 1 1, Tuple 2 2, Tuple 3 3, Tuple 4 4, Tuple 5 5, Tuple 6 6, Tuple 7 7, Tuple 8 8]) + Graph.stronglyConnectedComponents cyclicGraph `shouldEqual` (Map.fromFoldable [ Tuple 1 1, Tuple 2 1, Tuple 3 1, Tuple 4 4, Tuple 5 5])