algebraic-graphs-0.0.4: src/Algebra/Graph/AdjacencyMap.hs
-----------------------------------------------------------------------------
-- |
-- Module : Algebra.Graph.AdjacencyMap
-- Copyright : (c) Andrey Mokhov 2016-2017
-- License : MIT (see the file LICENSE)
-- Maintainer : andrey.mokhov@gmail.com
-- Stability : experimental
--
-- __Alga__ is a library for algebraic construction and manipulation of graphs
-- in Haskell. See <https://github.com/snowleopard/alga-paper this paper> for the
-- motivation behind the library, the underlying theory, and implementation details.
--
-- This module defines the 'AdjacencyMap' data type, as well as associated
-- operations and algorithms. 'AdjacencyMap' is an instance of the 'C.Graph' type
-- class, which can be used for polymorphic graph construction and manipulation.
-- "Algebra.Graph.IntAdjacencyMap" defines adjacency maps specialised to graphs
-- with @Int@ vertices.
-----------------------------------------------------------------------------
module Algebra.Graph.AdjacencyMap (
-- * Data structure
AdjacencyMap, adjacencyMap,
-- * Basic graph construction primitives
empty, vertex, edge, overlay, connect, vertices, edges, overlays, connects,
graph, fromAdjacencyList,
-- * Relations on graphs
isSubgraphOf,
-- * Graph properties
isEmpty, hasVertex, hasEdge, vertexCount, edgeCount, vertexList, edgeList,
adjacencyList, vertexSet, edgeSet, postset,
-- * Standard families of graphs
path, circuit, clique, biclique, star, tree, forest,
-- * Graph transformation
removeVertex, removeEdge, replaceVertex, mergeVertices, gmap, induce,
-- * Algorithms
dfsForest, topSort, isTopSort, scc,
-- * Interoperability with King-Launchbury graphs
GraphKL, getGraph, getVertex, graphKL, fromGraphKL
) where
import Data.Array
import Data.Foldable (toList)
import Data.Set (Set)
import Data.Tree
import Algebra.Graph.AdjacencyMap.Internal
import qualified Algebra.Graph.Class as C
import qualified Data.Graph as KL
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
-- | Construct the /empty graph/.
-- Complexity: /O(1)/ time and memory.
--
-- @
-- 'isEmpty' empty == True
-- 'hasVertex' x empty == False
-- 'vertexCount' empty == 0
-- 'edgeCount' empty == 0
-- @
empty :: Ord a => AdjacencyMap a
empty = C.empty
-- | Construct the graph comprising /a single isolated vertex/.
-- Complexity: /O(1)/ time and memory.
--
-- @
-- 'isEmpty' (vertex x) == False
-- 'hasVertex' x (vertex x) == True
-- 'hasVertex' 1 (vertex 2) == False
-- 'vertexCount' (vertex x) == 1
-- 'edgeCount' (vertex x) == 0
-- @
vertex :: Ord a => a -> AdjacencyMap a
vertex = C.vertex
-- | Construct the graph comprising /a single edge/.
-- Complexity: /O(1)/ time, memory.
--
-- @
-- edge x y == 'connect' ('vertex' x) ('vertex' y)
-- 'hasEdge' x y (edge x y) == True
-- 'edgeCount' (edge x y) == 1
-- 'vertexCount' (edge 1 1) == 1
-- 'vertexCount' (edge 1 2) == 2
-- @
edge :: Ord a => a -> a -> AdjacencyMap a
edge = C.edge
-- | /Overlay/ two graphs. This is an idempotent, commutative and associative
-- operation with the identity 'empty'.
-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory.
--
-- @
-- 'isEmpty' (overlay x y) == 'isEmpty' x && 'isEmpty' y
-- 'hasVertex' z (overlay x y) == 'hasVertex' z x || 'hasVertex' z y
-- 'vertexCount' (overlay x y) >= 'vertexCount' x
-- 'vertexCount' (overlay x y) <= 'vertexCount' x + 'vertexCount' y
-- 'edgeCount' (overlay x y) >= 'edgeCount' x
-- 'edgeCount' (overlay x y) <= 'edgeCount' x + 'edgeCount' y
-- 'vertexCount' (overlay 1 2) == 2
-- 'edgeCount' (overlay 1 2) == 0
-- @
overlay :: Ord a => AdjacencyMap a -> AdjacencyMap a -> AdjacencyMap a
overlay = C.overlay
-- | /Connect/ two graphs. This is an associative operation with the identity
-- 'empty', which distributes over the overlay and obeys the decomposition axiom.
-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. Note that the
-- number of edges in the resulting graph is quadratic with respect to the number
-- of vertices of the arguments: /m = O(m1 + m2 + n1 * n2)/.
--
-- @
-- 'isEmpty' (connect x y) == 'isEmpty' x && 'isEmpty' y
-- 'hasVertex' z (connect x y) == 'hasVertex' z x || 'hasVertex' z y
-- 'vertexCount' (connect x y) >= 'vertexCount' x
-- 'vertexCount' (connect x y) <= 'vertexCount' x + 'vertexCount' y
-- 'edgeCount' (connect x y) >= 'edgeCount' x
-- 'edgeCount' (connect x y) >= 'edgeCount' y
-- 'edgeCount' (connect x y) >= 'vertexCount' x * 'vertexCount' y
-- 'edgeCount' (connect x y) <= 'vertexCount' x * 'vertexCount' y + 'edgeCount' x + 'edgeCount' y
-- 'vertexCount' (connect 1 2) == 2
-- 'edgeCount' (connect 1 2) == 1
-- @
connect :: Ord a => AdjacencyMap a -> AdjacencyMap a -> AdjacencyMap a
connect = C.connect
-- | Construct the graph comprising a given list of isolated vertices.
-- Complexity: /O(L * log(L))/ time and /O(L)/ memory, where /L/ is the length
-- of the given list.
--
-- @
-- vertices [] == 'empty'
-- vertices [x] == 'vertex' x
-- 'hasVertex' x . vertices == 'elem' x
-- 'vertexCount' . vertices == 'length' . 'Data.List.nub'
-- 'vertexSet' . vertices == Set.'Set.fromList'
-- @
vertices :: Ord a => [a] -> AdjacencyMap a
vertices = AdjacencyMap . Map.fromList . map (\x -> (x, Set.empty))
-- | Construct the graph from a list of edges.
-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory.
--
-- @
-- edges [] == 'empty'
-- edges [(x, y)] == 'edge' x y
-- 'edgeCount' . edges == 'length' . 'Data.List.nub'
-- 'edgeList' . edges == 'Data.List.nub' . 'Data.List.sort'
-- @
edges :: Ord a => [(a, a)] -> AdjacencyMap a
edges = fromAdjacencyList . map (fmap return)
-- | Overlay a given list of graphs.
-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory.
--
-- @
-- overlays [] == 'empty'
-- overlays [x] == x
-- overlays [x,y] == 'overlay' x y
-- 'isEmpty' . overlays == 'all' 'isEmpty'
-- @
overlays :: Ord a => [AdjacencyMap a] -> AdjacencyMap a
overlays = C.overlays
-- | Connect a given list of graphs.
-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory.
--
-- @
-- connects [] == 'empty'
-- connects [x] == x
-- connects [x,y] == 'connect' x y
-- 'isEmpty' . connects == 'all' 'isEmpty'
-- @
connects :: Ord a => [AdjacencyMap a] -> AdjacencyMap a
connects = C.connects
-- | Construct the graph from given lists of vertices /V/ and edges /E/.
-- The resulting graph contains the vertices /V/ as well as all the vertices
-- referred to by the edges /E/.
-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory.
--
-- @
-- graph [] [] == 'empty'
-- graph [x] [] == 'vertex' x
-- graph [] [(x,y)] == 'edge' x y
-- graph vs es == 'overlay' ('vertices' vs) ('edges' es)
-- @
graph :: Ord a => [a] -> [(a, a)] -> AdjacencyMap a
graph vs es = overlay (vertices vs) (edges es)
-- | Construct a graph from an adjacency list.
-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory.
--
-- @
-- fromAdjacencyList [] == 'empty'
-- fromAdjacencyList [(x, [])] == 'vertex' x
-- fromAdjacencyList [(x, [y])] == 'edge' x y
-- fromAdjacencyList . 'adjacencyList' == id
-- 'overlay' (fromAdjacencyList xs) (fromAdjacencyList ys) == fromAdjacencyList (xs ++ ys)
-- @
fromAdjacencyList :: Ord a => [(a, [a])] -> AdjacencyMap a
fromAdjacencyList as = AdjacencyMap $ Map.unionWith Set.union vs es
where
ss = map (fmap Set.fromList) as
vs = Map.fromSet (const Set.empty) . Set.unions $ map snd ss
es = Map.fromListWith Set.union ss
-- | The 'isSubgraphOf' function takes two graphs and returns 'True' if the
-- first graph is a /subgraph/ of the second.
-- Complexity: /O((n + m) * log(n))/ time.
--
-- @
-- isSubgraphOf 'empty' x == True
-- isSubgraphOf ('vertex' x) 'empty' == False
-- isSubgraphOf x ('overlay' x y) == True
-- isSubgraphOf ('overlay' x y) ('connect' x y) == True
-- isSubgraphOf ('path' xs) ('circuit' xs) == True
-- @
isSubgraphOf :: Ord a => AdjacencyMap a -> AdjacencyMap a -> Bool
isSubgraphOf x y = Map.isSubmapOfBy Set.isSubsetOf (adjacencyMap x) (adjacencyMap y)
-- | Check if a graph is empty.
-- Complexity: /O(1)/ time.
--
-- @
-- isEmpty 'empty' == True
-- isEmpty ('overlay' 'empty' 'empty') == True
-- isEmpty ('vertex' x) == False
-- isEmpty ('removeVertex' x $ 'vertex' x) == True
-- isEmpty ('removeEdge' x y $ 'edge' x y) == False
-- @
isEmpty :: AdjacencyMap a -> Bool
isEmpty = Map.null . adjacencyMap
-- | Check if a graph contains a given vertex.
-- Complexity: /O(log(n))/ time.
--
-- @
-- hasVertex x 'empty' == False
-- hasVertex x ('vertex' x) == True
-- hasVertex x . 'removeVertex' x == const False
-- @
hasVertex :: Ord a => a -> AdjacencyMap a -> Bool
hasVertex x = Map.member x . adjacencyMap
-- | Check if a graph contains a given edge.
-- Complexity: /O(log(n))/ time.
--
-- @
-- hasEdge x y 'empty' == False
-- hasEdge x y ('vertex' z) == False
-- hasEdge x y ('edge' x y) == True
-- hasEdge x y . 'removeEdge' x y == const False
-- @
hasEdge :: Ord a => a -> a -> AdjacencyMap a -> Bool
hasEdge u v a = case Map.lookup u (adjacencyMap a) of
Nothing -> False
Just vs -> Set.member v vs
-- | The number of vertices in a graph.
-- Complexity: /O(1)/ time.
--
-- @
-- vertexCount 'empty' == 0
-- vertexCount ('vertex' x) == 1
-- vertexCount == 'length' . 'vertexList'
-- @
vertexCount :: Ord a => AdjacencyMap a -> Int
vertexCount = Map.size . adjacencyMap
-- | The number of edges in a graph.
-- Complexity: /O(n)/ time.
--
-- @
-- edgeCount 'empty' == 0
-- edgeCount ('vertex' x) == 0
-- edgeCount ('edge' x y) == 1
-- edgeCount == 'length' . 'edgeList'
-- @
edgeCount :: Ord a => AdjacencyMap a -> Int
edgeCount = Map.foldr (\es r -> (Set.size es + r)) 0 . adjacencyMap
-- | The sorted list of vertices of a given graph.
-- Complexity: /O(n)/ time and memory.
--
-- @
-- vertexList 'empty' == []
-- vertexList ('vertex' x) == [x]
-- vertexList . 'vertices' == 'Data.List.nub' . 'Data.List.sort'
-- @
vertexList :: Ord a => AdjacencyMap a -> [a]
vertexList = Map.keys . adjacencyMap
-- | The sorted list of edges of a graph.
-- Complexity: /O(n + m)/ time and /O(m)/ memory.
--
-- @
-- edgeList 'empty' == []
-- edgeList ('vertex' x) == []
-- edgeList ('edge' x y) == [(x,y)]
-- edgeList ('star' 2 [3,1]) == [(2,1), (2,3)]
-- edgeList . 'edges' == 'Data.List.nub' . 'Data.List.sort'
-- @
edgeList :: AdjacencyMap a -> [(a, a)]
edgeList (AdjacencyMap m) = [ (x, y) | (x, ys) <- Map.toAscList m, y <- Set.toAscList ys ]
-- | The sorted /adjacency list/ of a graph.
-- Complexity: /O(n + m)/ time and /O(m)/ memory.
--
-- @
-- adjacencyList 'empty' == []
-- adjacencyList ('vertex' x) == [(x, [])]
-- adjacencyList ('edge' 1 2) == [(1, [2]), (2, [])]
-- adjacencyList ('star' 2 [3,1]) == [(1, []), (2, [1,3]), (3, [])]
-- 'fromAdjacencyList' . adjacencyList == id
-- @
adjacencyList :: AdjacencyMap a -> [(a, [a])]
adjacencyList = map (fmap Set.toAscList) . Map.toAscList . adjacencyMap
-- | The set of vertices of a given graph.
-- Complexity: /O(n)/ time and memory.
--
-- @
-- vertexSet 'empty' == Set.'Set.empty'
-- vertexSet . 'vertex' == Set.'Set.singleton'
-- vertexSet . 'vertices' == Set.'Set.fromList'
-- vertexSet . 'clique' == Set.'Set.fromList'
-- @
vertexSet :: Ord a => AdjacencyMap a -> Set a
vertexSet = Map.keysSet . adjacencyMap
-- | The set of edges of a given graph.
-- Complexity: /O((n + m) * log(m))/ time and /O(m)/ memory.
--
-- @
-- edgeSet 'empty' == Set.'Set.empty'
-- edgeSet ('vertex' x) == Set.'Set.empty'
-- edgeSet ('edge' x y) == Set.'Set.singleton' (x,y)
-- edgeSet . 'edges' == Set.'Set.fromList'
-- @
edgeSet :: Ord a => AdjacencyMap a -> Set (a, a)
edgeSet = Map.foldrWithKey (\v es -> Set.union (Set.mapMonotonic (v,) es)) Set.empty . adjacencyMap
-- | The /postset/ of a vertex is the set of its /direct successors/.
--
-- @
-- postset x 'empty' == Set.'Set.empty'
-- postset x ('vertex' x) == Set.'Set.empty'
-- postset x ('edge' x y) == Set.'Set.fromList' [y]
-- postset 2 ('edge' 1 2) == Set.'Set.empty'
-- @
postset :: Ord a => a -> AdjacencyMap a -> Set a
postset x = Map.findWithDefault Set.empty x . adjacencyMap
-- | The /path/ on a list of vertices.
-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory.
--
-- @
-- path [] == 'empty'
-- path [x] == 'vertex' x
-- path [x,y] == 'edge' x y
-- @
path :: Ord a => [a] -> AdjacencyMap a
path = C.path
-- | The /circuit/ on a list of vertices.
-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory.
--
-- @
-- circuit [] == 'empty'
-- circuit [x] == 'edge' x x
-- circuit [x,y] == 'edges' [(x,y), (y,x)]
-- @
circuit :: Ord a => [a] -> AdjacencyMap a
circuit = C.circuit
-- | The /clique/ on a list of vertices.
-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory.
--
-- @
-- clique [] == 'empty'
-- clique [x] == 'vertex' x
-- clique [x,y] == 'edge' x y
-- clique [x,y,z] == 'edges' [(x,y), (x,z), (y,z)]
-- @
clique :: Ord a => [a] -> AdjacencyMap a
clique = C.clique
-- | The /biclique/ on a list of vertices.
-- Complexity: /O(n * log(n) + m)/ time and /O(n + m)/ memory.
--
-- @
-- biclique [] [] == 'empty'
-- biclique [x] [] == 'vertex' x
-- biclique [] [y] == 'vertex' y
-- biclique [x1,x2] [y1,y2] == 'edges' [(x1,y1), (x1,y2), (x2,y1), (x2,y2)]
-- biclique xs ys == 'connect' ('vertices' xs) ('vertices' ys)
-- @
biclique :: Ord a => [a] -> [a] -> AdjacencyMap a
biclique xs ys = AdjacencyMap $ Map.fromSet adjacent (x `Set.union` y)
where
x = Set.fromList xs
y = Set.fromList ys
adjacent v
| v `Set.member` x = y
| otherwise = Set.empty
-- | The /star/ formed by a centre vertex and a list of leaves.
-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory.
--
-- @
-- star x [] == 'vertex' x
-- star x [y] == 'edge' x y
-- star x [y,z] == 'edges' [(x,y), (x,z)]
-- @
star :: Ord a => a -> [a] -> AdjacencyMap a
star = C.star
-- | The /tree graph/ constructed from a given 'Tree' data structure.
-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory.
--
-- @
-- tree (Node x []) == 'vertex' x
-- tree (Node x [Node y [Node z []]]) == 'path' [x,y,z]
-- tree (Node x [Node y [], Node z []]) == 'star' x [y,z]
-- tree (Node 1 [Node 2 [], Node 3 [Node 4 [], Node 5 []]]) == 'edges' [(1,2), (1,3), (3,4), (3,5)]
-- @
tree :: Ord a => Tree a -> AdjacencyMap a
tree = C.tree
-- | The /forest graph/ constructed from a given 'Forest' data structure.
-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory.
--
-- @
-- forest [] == 'empty'
-- forest [x] == 'tree' x
-- forest [Node 1 [Node 2 [], Node 3 []], Node 4 [Node 5 []]] == 'edges' [(1,2), (1,3), (4,5)]
-- forest == 'overlays' . map 'tree'
-- @
forest :: Ord a => Forest a -> AdjacencyMap a
forest = C.forest
-- | Remove a vertex from a given graph.
-- Complexity: /O(n*log(n))/ time.
--
-- @
-- removeVertex x ('vertex' x) == 'empty'
-- removeVertex x . removeVertex x == removeVertex x
-- @
removeVertex :: Ord a => a -> AdjacencyMap a -> AdjacencyMap a
removeVertex x = AdjacencyMap . Map.map (Set.delete x) . Map.delete x . adjacencyMap
-- | Remove an edge from a given graph.
-- Complexity: /O(log(n))/ time.
--
-- @
-- removeEdge x y ('edge' x y) == 'vertices' [x, y]
-- removeEdge x y . removeEdge x y == removeEdge x y
-- removeEdge x y . 'removeVertex' x == 'removeVertex' x
-- removeEdge 1 1 (1 * 1 * 2 * 2) == 1 * 2 * 2
-- removeEdge 1 2 (1 * 1 * 2 * 2) == 1 * 1 + 2 * 2
-- @
removeEdge :: Ord a => a -> a -> AdjacencyMap a -> AdjacencyMap a
removeEdge x y = AdjacencyMap . Map.adjust (Set.delete y) x . adjacencyMap
-- | The function @'replaceVertex' x y@ replaces vertex @x@ with vertex @y@ in a
-- given 'AdjacencyMap'. If @y@ already exists, @x@ and @y@ will be merged.
-- Complexity: /O((n + m) * log(n))/ time.
--
-- @
-- replaceVertex x x == id
-- replaceVertex x y ('vertex' x) == 'vertex' y
-- replaceVertex x y == 'mergeVertices' (== x) y
-- @
replaceVertex :: Ord a => a -> a -> AdjacencyMap a -> AdjacencyMap a
replaceVertex u v = gmap $ \w -> if w == u then v else w
-- | Merge vertices satisfying a given predicate with a given vertex.
-- Complexity: /O((n + m) * log(n))/ time, assuming that the predicate takes
-- /O(1)/ to be evaluated.
--
-- @
-- mergeVertices (const False) x == id
-- mergeVertices (== x) y == 'replaceVertex' x y
-- mergeVertices even 1 (0 * 2) == 1 * 1
-- mergeVertices odd 1 (3 + 4 * 5) == 4 * 1
-- @
mergeVertices :: Ord a => (a -> Bool) -> a -> AdjacencyMap a -> AdjacencyMap a
mergeVertices p v = gmap $ \u -> if p u then v else u
-- | Transform a graph by applying a function to each of its vertices. This is
-- similar to @Functor@'s 'fmap' but can be used with non-fully-parametric
-- 'AdjacencyMap'.
-- Complexity: /O((n + m) * log(n))/ time.
--
-- @
-- gmap f 'empty' == 'empty'
-- gmap f ('vertex' x) == 'vertex' (f x)
-- gmap f ('edge' x y) == 'edge' (f x) (f y)
-- gmap id == id
-- gmap f . gmap g == gmap (f . g)
-- @
gmap :: (Ord a, Ord b) => (a -> b) -> AdjacencyMap a -> AdjacencyMap b
gmap f = AdjacencyMap . Map.map (Set.map f) . Map.mapKeysWith Set.union f . adjacencyMap
-- | Construct the /induced subgraph/ of a given graph by removing the
-- vertices that do not satisfy a given predicate.
-- Complexity: /O(m)/ time, assuming that the predicate takes /O(1)/ to
-- be evaluated.
--
-- @
-- induce (const True) x == x
-- induce (const False) x == 'empty'
-- induce (/= x) == 'removeVertex' x
-- induce p . induce q == induce (\\x -> p x && q x)
-- 'isSubgraphOf' (induce p x) x == True
-- @
induce :: Ord a => (a -> Bool) -> AdjacencyMap a -> AdjacencyMap a
induce p = AdjacencyMap . Map.map (Set.filter p) . Map.filterWithKey (\k _ -> p k) . adjacencyMap
-- | Compute the /depth-first search/ forest of a graph.
--
-- @
-- 'forest' (dfsForest $ 'edge' 1 1) == 'vertex' 1
-- 'forest' (dfsForest $ 'edge' 1 2) == 'edge' 1 2
-- 'forest' (dfsForest $ 'edge' 2 1) == 'vertices' [1, 2]
-- 'isSubgraphOf' ('forest' $ dfsForest x) x == True
-- dfsForest . 'forest' . dfsForest == dfsForest
-- dfsForest $ 3 * (1 + 4) * (1 + 5) == [ Node { rootLabel = 1
-- , subForest = [ Node { rootLabel = 5
-- , subForest = [] }]}
-- , Node { rootLabel = 3
-- , subForest = [ Node { rootLabel = 4
-- , subForest = [] }]}]
-- @
dfsForest :: Ord a => AdjacencyMap a -> Forest a
dfsForest m = let GraphKL g r = graphKL m in fmap (fmap r) (KL.dff g)
-- | Compute the /topological sort/ of a graph or return @Nothing@ if the graph
-- is cyclic.
--
-- @
-- topSort (1 * 2 + 3 * 1) == Just [3,1,2]
-- topSort (1 * 2 + 2 * 1) == Nothing
-- fmap (flip 'isTopSort' x) (topSort x) /= Just False
-- @
topSort :: Ord a => AdjacencyMap a -> Maybe [a]
topSort m = if isTopSort result m then Just result else Nothing
where
GraphKL g r = graphKL m
result = map r (KL.topSort g)
-- | Check if a given list of vertices is a valid /topological sort/ of a graph.
--
-- @
-- isTopSort [3, 1, 2] (1 * 2 + 3 * 1) == True
-- isTopSort [1, 2, 3] (1 * 2 + 3 * 1) == False
-- isTopSort [] (1 * 2 + 3 * 1) == False
-- isTopSort [] 'empty' == True
-- isTopSort [x] ('vertex' x) == True
-- isTopSort [x] ('edge' x x) == False
-- @
isTopSort :: Ord a => [a] -> AdjacencyMap a -> Bool
isTopSort xs m = go Set.empty xs
where
go seen [] = seen == Map.keysSet (adjacencyMap m)
go seen (v:vs) = let newSeen = seen `seq` Set.insert v seen
in postset v m `Set.intersection` newSeen == Set.empty && go newSeen vs
-- | Compute the /condensation/ of a graph, where each vertex corresponds to a
-- /strongly-connected component/ of the original graph.
--
-- @
-- scc 'empty' == 'empty'
-- scc ('vertex' x) == 'vertex' (Set.'Set.singleton' x)
-- scc ('edge' x y) == 'edge' (Set.'Set.singleton' x) (Set.'Set.singleton' y)
-- scc ('circuit' (1:xs)) == 'edge' (Set.'Set.fromList' (1:xs)) (Set.'Set.fromList' (1:xs))
-- scc (3 * 1 * 4 * 1 * 5) == 'edges' [ (Set.'Set.fromList' [1,4], Set.'Set.fromList' [1,4])
-- , (Set.'Set.fromList' [1,4], Set.'Set.fromList' [5] )
-- , (Set.'Set.fromList' [3] , Set.'Set.fromList' [1,4])
-- , (Set.'Set.fromList' [3] , Set.'Set.fromList' [5] )]
-- @
scc :: Ord a => AdjacencyMap a -> AdjacencyMap (Set a)
scc m = gmap (\v -> Map.findWithDefault Set.empty v components) m
where
GraphKL g r = graphKL m
components = Map.fromList $ concatMap (expand . fmap r . toList) (KL.scc g)
expand xs = let s = Set.fromList xs in map (\x -> (x, s)) xs
-- | 'GraphKL' encapsulates King-Launchbury graphs, which are implemented in
-- the "Data.Graph" module of the @containers@ library. If @graphKL g == h@ then
-- the following holds:
--
-- @
-- map ('getVertex' h) ('Data.Graph.vertices' $ 'getGraph' h) == Set.'Set.toAscList' ('vertexSet' g)
-- map (\\(x, y) -> ('getVertex' h x, 'getVertex' h y)) ('Data.Graph.edges' $ 'getGraph' h) == 'edgeList' g
-- @
data GraphKL a = GraphKL {
-- | Array-based graph representation (King and Launchbury, 1995).
getGraph :: KL.Graph,
-- | A mapping of "Data.Graph.Vertex" to vertices of type @a@.
getVertex :: KL.Vertex -> a }
-- | Build 'GraphKL' from the adjacency map of a graph.
--
-- @
-- 'fromGraphKL' . graphKL == id
-- @
graphKL :: Ord a => AdjacencyMap a -> GraphKL a
graphKL m = GraphKL g $ \u -> case r u of (_, v, _) -> v
where
(g, r) = KL.graphFromEdges' [ ((), v, us) | (v, us) <- adjacencyList m ]
-- | Extract the adjacency map of a King-Launchbury graph.
--
-- @
-- fromGraphKL . 'graphKL' == id
-- @
fromGraphKL :: Ord a => GraphKL a -> AdjacencyMap a
fromGraphKL (GraphKL g r) = fromAdjacencyList $ map (\(x, ys) -> (r x, map r ys)) (assocs g)