1{-# LANGUAGE DeriveGeneric #-} 2---------------------------------------------------------------------------- 3-- | 4-- Module : Algebra.Graph.Bipartite.Undirected.AdjacencyMap 5-- Copyright : (c) Andrey Mokhov 2016-2020 6-- License : MIT (see the file LICENSE) 7-- Maintainer : andrey.mokhov@gmail.com 8-- Stability : experimental 9-- 10-- __Alga__ is a library for algebraic construction and manipulation of graphs 11-- in Haskell. See <https://github.com/snowleopard/alga-paper this paper> for 12-- the motivation behind the library, the underlying theory, and 13-- implementation details. 14-- 15-- This module defines the 'AdjacencyMap' data type for undirected bipartite 16-- graphs and associated functions. To avoid name clashes with 17-- "Algebra.Graph.AdjacencyMap", this module can be imported qualified: 18-- 19-- @ 20-- import qualified Algebra.Graph.Bipartite.Undirected.AdjacencyMap as Bipartite 21-- @ 22---------------------------------------------------------------------------- 23module Algebra.Graph.Bipartite.Undirected.AdjacencyMap ( 24 -- * Data structure 25 AdjacencyMap, leftAdjacencyMap, rightAdjacencyMap, 26 27 -- * Basic graph construction primitives 28 empty, leftVertex, rightVertex, vertex, edge, overlay, connect, vertices, 29 edges, overlays, connects, swap, 30 31 -- * Conversion functions 32 toBipartite, toBipartiteWith, fromBipartite, fromBipartiteWith, 33 34 -- * Graph properties 35 isEmpty, hasLeftVertex, hasRightVertex, hasVertex, hasEdge, leftVertexCount, 36 rightVertexCount, vertexCount, edgeCount, leftVertexList, rightVertexList, 37 vertexList, edgeList, leftVertexSet, rightVertexSet, vertexSet, edgeSet, 38 39 -- * Standard families of graphs 40 circuit, biclique, 41 42 -- * Algorithms 43 OddCycle, detectParts, 44 45 -- * Miscellaneous 46 consistent 47 ) where 48 49import Control.Monad 50import Control.Monad.Trans.Maybe 51import Control.Monad.State 52import Data.Either 53import Data.Foldable 54import Data.List 55import Data.Map.Strict (Map) 56import Data.Maybe 57import Data.Set (Set) 58import GHC.Generics 59 60import qualified Algebra.Graph.AdjacencyMap as AM 61 62import qualified Data.Map.Strict as Map 63import qualified Data.Set as Set 64import qualified Data.Tuple 65 66{-| The 'Bipartite.AdjacencyMap' data type represents an undirected bipartite 67graph. The two type parameteters define the types of identifiers of the vertices 68of each part. 69 70__Note:__ even if the identifiers and their types for two vertices of different 71parts are equal, these vertices are considered to be different. See examples for 72more details. 73 74We define a 'Num' instance as a convenient notation for working with bipartite 75graphs: 76 77@ 780 == rightVertex 0 79'swap' 1 == leftVertex 1 80'swap' 1 + 2 == vertices [1] [2] 81'swap' 1 * 2 == edge 1 2 82'swap' 1 + 2 * 'swap' 3 == overlay (leftVertex 1) (edge 3 2) 83'swap' 1 * (2 + 'swap' 3) == connect (leftVertex 1) (vertices [3] [2]) 84@ 85 86__Note:__ the 'Num' instance does not satisfy several "customary laws" of 'Num', 87which dictate that 'fromInteger' @0@ and 'fromInteger' @1@ should act as 88additive and multiplicative identities, and 'negate' as additive inverse. 89Nevertheless, overloading 'fromInteger', '+' and '*' is very convenient when 90working with algebraic graphs; we hope that in future Haskell's Prelude will 91provide a more fine-grained class hierarchy for algebraic structures, which we 92would be able to utilise without violating any laws. 93 94The 'Show' instance is defined using basic graph construction primitives: 95 96@ 97show empty == "empty" 98show 1 == "rightVertex 1" 99show ('swap' 2) == "leftVertex 2" 100show (1 + 2) == "vertices [] [1,2]" 101show ('swap' (1 + 2)) == "vertices [1,2] []" 102show ('swap' 1 * 2) == "edge 1 2" 103show ('swap' 1 * 2 * 'swap' 3) == "edges [(1,2),(3,2)]" 104show ('swap' 1 * 2 + 'swap' 3) == "overlay (leftVertex 3) (edge 1 2)" 105@ 106 107The 'Eq' instance satisfies all axioms of algebraic graphs: 108 109 * 'overlay' is commutative and associative: 110 111 > x + y == y + x 112 > x + (y + z) == (x + y) + z 113 114 * 'connect' is commutative, associative and has 'empty' as the identity: 115 116 > x * empty == x 117 > empty * x == x 118 > x * y == y * x 119 > x * (y * z) == (x * y) * z 120 121 * 'connect' distributes over 'overlay': 122 123 > x * (y + z) == x * y + x * z 124 > (x + y) * z == x * z + y * z 125 126 * 'connect' can be decomposed: 127 128 > x * y * z == x * y + x * z + y * z 129 130 * 'connect' has the same effect as 'overlay' on vertices of one part: 131 132 > leftVertex x * leftVertex y == leftVertex x + leftVertex y 133 > rightVertex x * rightVertex y == rightVertex x + rightVertex y 134 135The following useful theorems can be proved from the above set of axioms. 136 137 * 'overlay' has 'empty' as the identity and is idempotent: 138 139 > x + empty == x 140 > empty + x == x 141 > x + x == x 142 143 * Absorption and saturation of 'connect': 144 145 > x * y + x + y == x * y 146 > x * x * x == x * x 147 148When specifying the time and memory complexity of graph algorithms, /n/ and /m/ 149will denote the number of vertices and edges in the graph, respectively. In 150addition, /l/ and /r/ will denote the number of vertices in the left and in the 151right part of graph, respectively. 152-} 153data AdjacencyMap a b = BAM { 154 -- | The /adjacency map/ of the left part of the graph: each left vertex is 155 -- associated with a set of its right neighbours. 156 -- Complexity: /O(1)/ time and memory. 157 -- 158 -- @ 159 -- leftAdjacencyMap 'empty' == Map.'Map.empty' 160 -- leftAdjacencyMap ('leftVertex' x) == Map.'Map.singleton' x Set.'Set.empty' 161 -- leftAdjacencyMap ('rightVertex' x) == Map.'Map.empty' 162 -- leftAdjacencyMap ('edge' x y) == Map.'Map.singleton' x (Set.'Set.singleton' y) 163 -- @ 164 leftAdjacencyMap :: Map a (Set b), 165 166 -- | The /adjacency map/ of the right part of the graph: each right vertex 167 -- is associated with a set of left neighbours. 168 -- Complexity: /O(1)/ time and memory. 169 -- 170 -- @ 171 -- rightAdjacencyMap 'empty' == Map.'Map.empty' 172 -- rightAdjacencyMap ('leftVertex' x) == Map.'Map.empty' 173 -- rightAdjacencyMap ('rightVertex' x) == Map.'Map.singleton' x Set.'Set.empty' 174 -- rightAdjacencyMap ('edge' x y) == Map.'Map.singleton' y (Set.'Set.singleton' x) 175 -- @ 176 rightAdjacencyMap :: Map b (Set a) 177 } deriving Generic 178 179-- | __Note:__ this does not satisfy the usual ring laws; see 'AdjacencyMap' 180-- for more details. 181instance (Ord a, Ord b, Num b) => Num (AdjacencyMap a b) where 182 fromInteger = rightVertex . fromInteger 183 (+) = overlay 184 (*) = connect 185 signum = const empty 186 abs = id 187 negate = id 188 189instance (Ord a, Ord b) => Eq (AdjacencyMap a b) where 190 BAM lr1 rl1 == BAM lr2 rl2 = lr1 == lr2 && Map.keysSet rl1 == Map.keysSet rl2 191 192instance (Ord a, Ord b) => Ord (AdjacencyMap a b) where 193 compare x y = mconcat 194 [ compare (vertexCount x) (vertexCount y) 195 , compare (vertexSet x) (vertexSet y) 196 , compare (edgeCount x) (edgeCount y) 197 , compare (edgeSet x) (edgeSet y) ] 198 199instance (Ord a, Ord b, Show a, Show b) => Show (AdjacencyMap a b) where 200 showsPrec p bam 201 | null lvs && null rvs = showString "empty" 202 | null es = showParen (p > 10) $ vshow lvs rvs 203 | (lvs == lused) && (rvs == rused) = showParen (p > 10) $ eshow es 204 | otherwise = showParen (p > 10) 205 $ showString "overlay (" 206 . veshow (vs \\ used) 207 . showString ") (" 208 . eshow es 209 . showString ")" 210 where 211 lvs = leftVertexList bam 212 rvs = rightVertexList bam 213 vs = vertexList bam 214 es = edgeList bam 215 vshow [x] [] = showString "leftVertex " . showsPrec 11 x 216 vshow [] [x] = showString "rightVertex " . showsPrec 11 x 217 vshow xs ys = showString "vertices " . showsPrec 11 xs 218 . showString " " . showsPrec 11 ys 219 veshow xs = vshow (lefts xs) (rights xs) 220 eshow [(x, y)] = showString "edge " . showsPrec 11 x 221 . showString " " . showsPrec 11 y 222 eshow es = showString "edges " . showsPrec 11 es 223 lused = Set.toAscList $ Set.fromAscList [ u | (u, _) <- edgeList bam ] 224 rused = Set.toAscList $ Set.fromList [ v | (_, v) <- edgeList bam ] 225 used = map Left lused ++ map Right rused 226 227-- | Construct the /empty graph/. 228-- Complexity: /O(1)/ time and memory. 229-- 230-- @ 231-- 'isEmpty' empty == True 232-- 'leftAdjacencyMap' empty == Map.'Map.empty' 233-- 'rightAdjacencyMap' empty == Map.'Map.empty' 234-- 'hasVertex' x empty == False 235-- @ 236empty :: AdjacencyMap a b 237empty = BAM Map.empty Map.empty 238 239-- | Construct the bipartite graph comprising /a single isolated vertex/ in 240-- the left part. 241-- Complexity: /O(1)/ time and memory. 242-- 243-- @ 244-- 'leftAdjacencyMap' (leftVertex x) == Map.'Map.singleton' x Set.'Set.empty' 245-- 'rightAdjacencyMap' (leftVertex x) == Map.'Map.empty' 246-- 'hasLeftVertex' x (leftVertex y) == (x == y) 247-- 'hasRightVertex' x (leftVertex y) == False 248-- 'hasEdge' x y (leftVertex z) == False 249-- @ 250leftVertex :: a -> AdjacencyMap a b 251leftVertex x = BAM (Map.singleton x Set.empty) Map.empty 252 253-- | Construct the bipartite graph comprising /a single isolated vertex/ in 254-- the right part. 255-- Complexity: /O(1)/ time and memory. 256-- 257-- @ 258-- 'leftAdjacencyMap' (rightVertex x) == Map.'Map.empty' 259-- 'rightAdjacencyMap' (rightVertex x) == Map.'Map.singleton' x Set.'Set.empty' 260-- 'hasLeftVertex' x (rightVertex y) == False 261-- 'hasRightVertex' x (rightVertex y) == (x == y) 262-- 'hasEdge' x y (rightVertex z) == False 263-- @ 264rightVertex :: b -> AdjacencyMap a b 265rightVertex y = BAM Map.empty (Map.singleton y Set.empty) 266 267-- | Construct the bipartite graph comprising /a single isolated vertex/. 268-- Complexity: /O(1)/ time and memory. 269-- 270-- @ 271-- vertex . Left == 'leftVertex' 272-- vertex . Right == 'rightVertex' 273-- @ 274vertex :: Either a b -> AdjacencyMap a b 275vertex (Left x) = leftVertex x 276vertex (Right y) = rightVertex y 277 278-- | Construct the bipartite graph comprising /a single edge/. 279-- Complexity: /O(1)/ time and memory. 280-- 281-- @ 282-- edge x y == 'connect' ('leftVertex' x) ('rightVertex' y) 283-- 'leftAdjacencyMap' (edge x y) == Map.'Map.singleton' x (Set.'Set.singleton' y) 284-- 'rightAdjacencyMap' (edge x y) == Map.'Map.singleton' y (Set.'Set.singleton' x) 285-- 'hasEdge' x y (edge x y) == True 286-- 'hasEdge' 1 2 (edge 2 1) == False 287-- @ 288edge :: a -> b -> AdjacencyMap a b 289edge x y = 290 BAM (Map.singleton x (Set.singleton y)) (Map.singleton y (Set.singleton x)) 291 292-- | /Overlay/ two bipartite graphs. This is a commutative, associative and 293-- idempotent operation with the identity 'empty'. 294-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. 295-- 296-- @ 297-- 'isEmpty' (overlay x y) == 'isEmpty' x && 'isEmpty' y 298-- 'hasVertex' z (overlay x y) == 'hasVertex' z x || 'hasVertex' z y 299-- 'vertexCount' (overlay x y) >= 'vertexCount' x 300-- 'vertexCount' (overlay x y) <= 'vertexCount' x + 'vertexCount' y 301-- 'edgeCount' (overlay x y) >= 'edgeCount' x 302-- 'edgeCount' (overlay x y) <= 'edgeCount' x + 'edgeCount' y 303-- @ 304overlay :: (Ord a, Ord b) => AdjacencyMap a b -> AdjacencyMap a b -> AdjacencyMap a b 305overlay (BAM lr1 rl1) (BAM lr2 rl2) = 306 BAM (Map.unionWith Set.union lr1 lr2) (Map.unionWith Set.union rl1 rl2) 307 308-- | /Connect/ two bipartite graphs, not adding the edges between vertices in 309-- the same part. This is a commutative and associative operation with the 310-- identity 'empty', which distributes over 'overlay' and obeys the 311-- decomposition axiom. 312-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. Note that the 313-- number of edges in the resulting graph is quadratic with respect to the 314-- number of vertices in the arguments: /O(m1 + m2 + l1 * r2 + l2 * r1)/. 315-- 316-- @ 317-- connect ('leftVertex' x) ('leftVertex' y) == 'vertices' [x,y] [] 318-- connect ('leftVertex' x) ('rightVertex' y) == 'edge' x y 319-- connect ('rightVertex' x) ('leftVertex' y) == 'edge' y x 320-- connect ('rightVertex' x) ('rightVertex' y) == 'vertices' [] [x,y] 321-- connect ('vertices' xs1 ys1) ('vertices' xs2 ys2) == 'overlay' ('biclique' xs1 ys2) ('biclique' xs2 ys1) 322-- 'isEmpty' (connect x y) == 'isEmpty' x && 'isEmpty' y 323-- 'hasVertex' z (connect x y) == 'hasVertex' z x || 'hasVertex' z y 324-- 'vertexCount' (connect x y) >= 'vertexCount' x 325-- 'vertexCount' (connect x y) <= 'vertexCount' x + 'vertexCount' y 326-- 'edgeCount' (connect x y) >= 'edgeCount' x 327-- 'edgeCount' (connect x y) >= 'leftVertexCount' x * 'rightVertexCount' y 328-- 'edgeCount' (connect x y) <= 'leftVertexCount' x * 'rightVertexCount' y + 'rightVertexCount' x * 'leftVertexCount' y + 'edgeCount' x + 'edgeCount' y 329-- @ 330connect :: (Ord a, Ord b) => AdjacencyMap a b -> AdjacencyMap a b -> AdjacencyMap a b 331connect (BAM lr1 rl1) (BAM lr2 rl2) = BAM lr rl 332 where 333 l1 = Map.keysSet lr1 334 l2 = Map.keysSet lr2 335 r1 = Map.keysSet rl1 336 r2 = Map.keysSet rl2 337 lr = Map.unionsWith Set.union 338 [ lr1, lr2, Map.fromSet (const r2) l1, Map.fromSet (const r1) l2 ] 339 rl = Map.unionsWith Set.union 340 [ rl1, rl2, Map.fromSet (const l2) r1, Map.fromSet (const l1) r2 ] 341 342-- | Construct the graph comprising two given lists of isolated vertices for 343-- each part. 344-- Complexity: /O(L * log(L))/ time and /O(L)/ memory, where /L/ is the total 345-- length of two lists. 346-- 347-- @ 348-- vertices [] [] == 'empty' 349-- vertices [x] [] == 'leftVertex' x 350-- vertices [] [x] == 'rightVertex' x 351-- 'hasLeftVertex' x (vertices xs ys) == 'elem' x xs 352-- 'hasRightVertex' y (vertices xs ys) == 'elem' y ys 353-- @ 354vertices :: (Ord a, Ord b) => [a] -> [b] -> AdjacencyMap a b 355vertices ls rs = BAM (Map.fromList [ (l, Set.empty) | l <- ls ]) 356 (Map.fromList [ (r, Set.empty) | r <- rs ]) 357 358-- | Construct the graph from a list of edges. 359-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. 360-- 361-- @ 362-- edges [] == 'empty' 363-- edges [(x,y)] == 'edge' x y 364-- edges == 'overlays' . 'map' ('uncurry' 'edge') 365-- 'hasEdge' x y . edges == 'elem' (x,y) 366-- 'edgeCount' . edges == 'length' . 'nub' 367-- @ 368edges :: (Ord a, Ord b) => [(a, b)] -> AdjacencyMap a b 369edges es = BAM (Map.fromListWith Set.union [ (x, Set.singleton y) | (x, y) <- es ]) 370 (Map.fromListWith Set.union [ (y, Set.singleton x) | (x, y) <- es ]) 371 372-- | Overlay a given list of graphs. 373-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. 374-- 375-- @ 376-- overlays [] == 'empty' 377-- overlays [x] == x 378-- overlays [x,y] == 'overlay' x y 379-- overlays == 'foldr' 'overlay' 'empty' 380-- 'isEmpty' . overlays == 'all' 'isEmpty' 381-- @ 382overlays :: (Ord a, Ord b) => [AdjacencyMap a b] -> AdjacencyMap a b 383overlays ams = BAM (Map.unionsWith Set.union (map leftAdjacencyMap ams)) 384 (Map.unionsWith Set.union (map rightAdjacencyMap ams)) 385 386-- | Connect a given list of graphs. 387-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. 388-- 389-- @ 390-- connects [] == 'empty' 391-- connects [x] == x 392-- connects [x,y] == connect x y 393-- connects == 'foldr' 'connect' 'empty' 394-- 'isEmpty' . connects == 'all' 'isEmpty' 395-- @ 396connects :: (Ord a, Ord b) => [AdjacencyMap a b] -> AdjacencyMap a b 397connects = foldr connect empty 398 399-- | Swap parts of a given graph. 400-- Complexity: /O(1)/ time and memory. 401-- 402-- @ 403-- swap 'empty' == 'empty' 404-- swap . 'leftVertex' == 'rightVertex' 405-- swap ('vertices' xs ys) == 'vertices' ys xs 406-- swap ('edge' x y) == 'edge' y x 407-- swap . 'edges' == 'edges' . 'map' Data.Tuple.'Data.Tuple.swap' 408-- swap . swap == 'id' 409-- @ 410swap :: AdjacencyMap a b -> AdjacencyMap b a 411swap (BAM lr rl) = BAM rl lr 412 413-- | Construct a bipartite 'AdjacencyMap' from an "Algebra.Graph.AdjacencyMap" 414-- with given part identifiers, adding all needed edges to make the graph 415-- undirected and removing all edges within the same parts. 416-- Complexity: /O(m * log(n))/. 417-- 418-- @ 419-- toBipartite 'Algebra.Graph.AdjacencyMap.empty' == 'empty' 420-- toBipartite ('Algebra.Graph.AdjacencyMap.vertex' (Left x)) == 'leftVertex' x 421-- toBipartite ('Algebra.Graph.AdjacencyMap.vertex' (Right x)) == 'rightVertex' x 422-- toBipartite ('Algebra.Graph.AdjacencyMap.edge' (Left x) (Left y)) == 'vertices' [x,y] [] 423-- toBipartite ('Algebra.Graph.AdjacencyMap.edge' (Left x) (Right y)) == 'edge' x y 424-- toBipartite ('Algebra.Graph.AdjacencyMap.edge' (Right x) (Left y)) == 'edge' y x 425-- toBipartite ('Algebra.Graph.AdjacencyMap.edge' (Right x) (Right y)) == 'vertices' [] [x,y] 426-- toBipartite ('Algebra.Graph.AdjacencyMap.clique' xs) == 'uncurry' 'biclique' ('partitionEithers' xs) 427-- toBipartite . 'fromBipartite' == 'id' 428-- @ 429toBipartite :: (Ord a, Ord b) => AM.AdjacencyMap (Either a b) -> AdjacencyMap a b 430toBipartite m = BAM (Map.fromAscList [ (x, setRights ys) | (Left x, ys) <- symmetricList ]) 431 (Map.fromAscList [ (x, setLefts ys) | (Right x, ys) <- symmetricList ]) 432 where 433 setRights = Set.fromAscList . rights . Set.toAscList 434 setLefts = Set.fromAscList . lefts . Set.toAscList 435 symmetricList = Map.toAscList $ AM.adjacencyMap $ AM.symmetricClosure m 436 437-- | Construct a bipartite 'AdjacencyMap' from "Algebra.Graph.AdjacencyMap" 438-- with part identifiers obtained from a given function, adding all neeeded 439-- edges to make the graph undirected and removing all edges within the same 440-- parts. 441-- Complexity: /O(m * log(n))/. 442-- 443-- @ 444-- toBipartiteWith f 'Algebra.Graph.AdjacencyMap.empty' == 'empty' 445-- toBipartiteWith Left x == 'vertices' ('vertexList' x) [] 446-- toBipartiteWith Right x == 'vertices' [] ('vertexList' x) 447-- toBipartiteWith f == 'toBipartite' . 'Algebra.Graph.AdjacencyMap.gmap' f 448-- toBipartiteWith id == 'toBipartite' 449-- @ 450toBipartiteWith :: (Ord a, Ord b, Ord c) => (a -> Either b c) -> AM.AdjacencyMap a -> AdjacencyMap b c 451toBipartiteWith f = toBipartite . AM.gmap f 452 453-- | Construct an 'Algrebra.Graph.AdjacencyMap' from a bipartite 'AdjacencyMap'. 454-- Complexity: /O(m * log(n))/. 455-- 456-- @ 457-- fromBipartite 'empty' == 'Algebra.Graph.AdjacencyMap.empty' 458-- fromBipartite ('leftVertex' x) == 'Algebra.Graph.AdjacencyMap.vertex' (Left x) 459-- fromBipartite ('edge' x y) == 'Algebra.Graph.AdjacencyMap.edges' [(Left x, Right y), (Right y, Left x)] 460-- 'toBipartite' . fromBipartite == 'id' 461-- @ 462fromBipartite :: (Ord a, Ord b) => AdjacencyMap a b -> AM.AdjacencyMap (Either a b) 463fromBipartite (BAM lr rl) = AM.fromAdjacencySets $ 464 [ (Left x, Set.mapMonotonic Right ys) | (x, ys) <- Map.toAscList lr ] ++ 465 [ (Right y, Set.mapMonotonic Left xs) | (y, xs) <- Map.toAscList rl ] 466 467-- | Construct an 'Algrebra.Graph.AdjacencyMap' from a bipartite 'AdjacencyMap' 468-- given a way to inject vertices from different parts into the resulting vertex 469-- type. 470-- Complexity: /O(m * log(n))/. 471-- 472-- @ 473-- fromBipartiteWith Left Right == 'fromBipartite' 474-- fromBipartiteWith id id ('vertices' xs ys) == 'Algebra.Graph.AdjacencyMap.vertices' (xs ++ ys) 475-- fromBipartiteWith id id . 'edges' == 'Algebra.Graph.AdjacencyMap.symmetricClosure' . 'Algebra.Graph.AdjacencyMap.edges' 476-- @ 477fromBipartiteWith :: Ord c => (a -> c) -> (b -> c) -> AdjacencyMap a b -> AM.AdjacencyMap c 478fromBipartiteWith f g (BAM lr rl) = AM.fromAdjacencySets $ 479 [ (f x, Set.map g ys) | (x, ys) <- Map.toAscList lr ] ++ 480 [ (g y, Set.map f xs) | (y, xs) <- Map.toAscList rl ] 481 482-- | Check if a graph is empty. 483-- Complecity: /O(1)/ time. 484-- 485-- @ 486-- isEmpty 'empty' == True 487-- isEmpty ('overlay' 'empty' 'empty') == True 488-- isEmpty ('vertex' x) == False 489-- isEmpty == (==) 'empty' 490-- @ 491isEmpty :: AdjacencyMap a b -> Bool 492isEmpty (BAM lr rl) = Map.null lr && Map.null rl 493 494-- | Check if a graph contains a given vertex in the left part. 495-- Complexity: /O(log(n))/ time. 496-- 497-- @ 498-- hasLeftVertex x 'empty' == False 499-- hasLeftVertex x ('leftVertex' y) == (x == y) 500-- hasLeftVertex x ('rightVertex' y) == False 501-- @ 502hasLeftVertex :: Ord a => a -> AdjacencyMap a b -> Bool 503hasLeftVertex x (BAM lr _) = Map.member x lr 504 505-- | Check if a graph contains a given vertex in the right part. 506-- Complexity: /O(log(n))/ time. 507-- 508-- @ 509-- hasRightVertex x 'empty' == False 510-- hasRightVertex x ('leftVertex' y) == False 511-- hasRightVertex x ('rightVertex' y) == (x == y) 512-- @ 513hasRightVertex :: Ord b => b -> AdjacencyMap a b -> Bool 514hasRightVertex y (BAM _ rl) = Map.member y rl 515 516-- | Check if a graph contains a given vertex. 517-- Complexity: /O(log(n))/ time. 518-- 519-- @ 520-- hasVertex . Left == 'hasLeftVertex' 521-- hasVertex . Right == 'hasRightVertex' 522-- @ 523hasVertex :: (Ord a, Ord b) => Either a b -> AdjacencyMap a b -> Bool 524hasVertex (Left x) = hasLeftVertex x 525hasVertex (Right y) = hasRightVertex y 526 527-- | Check if a graph contains a given edge. 528-- Complexity: /O(log(n))/ time. 529-- 530-- @ 531-- hasEdge x y 'empty' == False 532-- hasEdge x y ('vertex' z) == False 533-- hasEdge x y ('edge' x y) == True 534-- hasEdge x y == 'elem' (x,y) . 'edgeList' 535-- @ 536hasEdge :: (Ord a, Ord b) => a -> b -> AdjacencyMap a b -> Bool 537hasEdge x y (BAM m _) = (Set.member y <$> Map.lookup x m) == Just True 538 539-- | The number of vertices in the left part in a graph. 540-- Complexity: /O(1)/ time. 541-- 542-- @ 543-- leftVertexCount 'empty' == 0 544-- leftVertexCount ('leftVertex' x) == 1 545-- leftVertexCount ('rightVertex' x) == 0 546-- leftVertexCount ('edge' x y) == 1 547-- leftVertexCount . 'edges' == 'length' . 'nub' . 'map' 'fst' 548-- @ 549leftVertexCount :: AdjacencyMap a b -> Int 550leftVertexCount = Map.size . leftAdjacencyMap 551 552-- | The number of vertices in the right part in a graph. 553-- Complexity: /O(1)/ time. 554-- 555-- @ 556-- rightVertexCount 'empty' == 0 557-- rightVertexCount ('leftVertex' x) == 0 558-- rightVertexCount ('rightVertex' x) == 1 559-- rightVertexCount ('edge' x y) == 1 560-- rightVertexCount . 'edges' == 'length' . 'nub' . 'map' 'snd' 561-- @ 562rightVertexCount :: AdjacencyMap a b -> Int 563rightVertexCount = Map.size . rightAdjacencyMap 564 565-- | The number of vertices in a graph. 566-- Complexity: /O(1)/ time. 567-- 568-- @ 569-- vertexCount 'empty' == 0 570-- vertexCount ('vertex' x) == 1 571-- vertexCount ('edge' x y) == 2 572-- vertexCount x == 'leftVertexCount' x + 'rightVertexCount' x 573-- @ 574vertexCount :: AdjacencyMap a b -> Int 575vertexCount g = leftVertexCount g + rightVertexCount g 576 577-- | The number of edges in a graph. 578-- Complexity: /O(n)/ time. 579-- 580-- @ 581-- edgeCount 'empty' == 0 582-- edgeCount ('vertex' x) == 0 583-- edgeCount ('edge' x y) == 1 584-- edgeCount . 'edges' == 'length' . 'nub' 585-- @ 586edgeCount :: AdjacencyMap a b -> Int 587edgeCount = Map.foldr ((+) . Set.size) 0 . leftAdjacencyMap 588 589-- | The sorted list of vertices of the left part of a given graph. 590-- Complexity: /O(l)/ time and memory. 591-- 592-- @ 593-- leftVertexList 'empty' == [] 594-- leftVertexList ('leftVertex' x) == [x] 595-- leftVertexList ('rightVertex' x) == [] 596-- leftVertexList . 'flip' 'vertices' [] == 'nub' . 'sort' 597-- @ 598leftVertexList :: AdjacencyMap a b -> [a] 599leftVertexList = Map.keys . leftAdjacencyMap 600 601-- | The sorted list of vertices of the right part of a given graph. 602-- Complexity: /O(r)/ time and memory. 603-- 604-- @ 605-- rightVertexList 'empty' == [] 606-- rightVertexList ('leftVertex' x) == [] 607-- rightVertexList ('rightVertex' x) == [x] 608-- rightVertexList . 'vertices' [] == 'nub' . 'sort' 609-- @ 610rightVertexList :: AdjacencyMap a b -> [b] 611rightVertexList = Map.keys . rightAdjacencyMap 612 613-- | The sorted list of vertices of a given graph. 614-- Complexity: /O(n)/ time and memory 615-- 616-- @ 617-- vertexList 'empty' == [] 618-- vertexList ('vertex' x) == [x] 619-- vertexList ('edge' x y) == [Left x, Right y] 620-- vertexList ('vertices' ('lefts' xs) ('rights' xs)) == 'nub' ('sort' xs) 621-- @ 622vertexList :: AdjacencyMap a b -> [Either a b] 623vertexList g = map Left (leftVertexList g) ++ map Right (rightVertexList g) 624 625-- | The sorted list of edges of a graph. 626-- Complexity: /O(n + m)/ time and /O(m)/ memory. 627-- 628-- @ 629-- edgeList 'empty' == [] 630-- edgeList ('vertex' x) == [] 631-- edgeList ('edge' x y) == [(x,y)] 632-- edgeList . 'edges' == 'nub' . 'sort' 633-- @ 634edgeList :: AdjacencyMap a b -> [(a, b)] 635edgeList (BAM lr _) = [ (x, y) | (x, ys) <- Map.toAscList lr, y <- Set.toAscList ys ] 636 637-- | The set of vertices of the left part of a given graph. 638-- Complexity: /O(l)/ time and memory. 639-- 640-- @ 641-- leftVertexSet 'empty' == Set.'Set.empty' 642-- leftVertexSet . 'leftVertex' == Set.'Set.singleton' 643-- leftVertexSet . 'rightVertex' == 'const' Set.'Set.empty' 644-- leftVertexSet . 'flip' 'vertices' [] == Set.'Set.fromList' 645-- @ 646leftVertexSet :: AdjacencyMap a b -> Set a 647leftVertexSet = Map.keysSet . leftAdjacencyMap 648 649-- | The set of vertices of the right part of a given graph. 650-- Complexity: /O(r)/ time and memory. 651-- 652-- @ 653-- rightVertexSet 'empty' == Set.'Set.empty' 654-- rightVertexSet . 'leftVertex' == 'const' Set.'Set.empty' 655-- rightVertexSet . 'rightVertex' == Set.'Set.singleton' 656-- rightVertexSet . 'vertices' [] == Set.'Set.fromList' 657-- @ 658rightVertexSet :: AdjacencyMap a b -> Set b 659rightVertexSet = Map.keysSet . rightAdjacencyMap 660 661-- | The set of vertices of a given graph. 662-- Complexity: /O(n)/ time and memory. 663-- 664-- @ 665-- vertexSet 'empty' == Set.'Set.empty' 666-- vertexSet . 'vertex' == Set.'Set.singleton' 667-- vertexSet ('edge' x y) == Set.'Set.fromList' [Left x, Right y] 668-- vertexSet ('vertices' ('lefts' xs) ('rights' xs)) == Set.'Set.fromList' xs 669-- @ 670vertexSet :: (Ord a, Ord b) => AdjacencyMap a b -> Set (Either a b) 671vertexSet = Set.fromAscList . vertexList 672 673-- | The set of edges of a given graph. 674-- Complexity: /O(n + m)/ time and /O(m)/ memory. 675-- 676-- @ 677-- edgeSet 'empty' == Set.'Data.Set.empty' 678-- edgeSet ('vertex' x) == Set.'Data.Set.empty' 679-- edgeSet ('edge' x y) == Set.'Data.Set.singleton' (x,y) 680-- edgeSet . 'edges' == Set.'Data.Set.fromList' 681-- @ 682edgeSet :: (Ord a, Ord b) => AdjacencyMap a b -> Set (a, b) 683edgeSet = Set.fromAscList . edgeList 684 685-- | The /circuit/ on a list of vertices. 686-- Complexity: /O(n * log(n))/ time and /O(n)/ memory. 687-- 688-- @ 689-- circuit [] == 'empty' 690-- circuit [(x,y)] == 'edge' x y 691-- circuit [(1,2), (3,4)] == 'biclique' [1,3] [2,4] 692-- circuit [(1,2), (3,4), (5,6)] == 'edges' [(1,2), (3,2), (3,4), (5,4), (5,6), (1,6)] 693-- circuit . 'reverse' == 'swap' . circuit . 'map' Data.Tuple.'Data.Tuple.swap' 694-- @ 695circuit :: (Ord a, Ord b) => [(a, b)] -> AdjacencyMap a b 696circuit [] = empty 697circuit xs = edges $ xs ++ zip (drop 1 $ cycle as) bs 698 where 699 (as, bs) = unzip xs 700 701-- | The /biclique/ on two lists of vertices. 702-- Complexity: /O(n * log(n) + m)/ time and /O(n + m)/ memory. 703-- 704-- @ 705-- biclique [] [] == 'empty' 706-- biclique xs [] == 'vertices' xs [] 707-- biclique [] ys == 'vertices' [] ys 708-- biclique xs ys == 'connect' ('vertices' xs []) ('vertices' [] ys) 709-- @ 710biclique :: (Ord a, Ord b) => [a] -> [b] -> AdjacencyMap a b 711biclique xs ys = BAM (Map.fromSet (const sys) sxs) (Map.fromSet (const sxs) sys) 712 where 713 sxs = Set.fromList xs 714 sys = Set.fromList ys 715 716data Part = LeftPart | RightPart deriving (Show, Eq) 717 718otherPart :: Part -> Part 719otherPart LeftPart = RightPart 720otherPart RightPart = LeftPart 721 722-- | An cycle of odd length. For example, @[1, 2, 3]@ represents the cycle 723-- @1 -> 2 -> 3 -> 1@. 724type OddCycle a = [a] -- TODO: Make this representation type-safe 725 726-- | Test the bipartiteness of given graph. In case of success, return an 727-- 'AdjacencyMap' with the same set of edges and each vertex marked with the 728-- part it belongs to. In case of failure, return any cycle of odd length in the 729-- graph. 730-- 731-- The returned partition is lexicographically minimal. That is, consider the 732-- string of part identifiers for each vertex in ascending order. Then, 733-- considering that the identifier of the left part is less then the identifier 734-- of the right part, this string is lexicographically minimal of all such 735-- strings for all partitions. 736-- 737-- The returned cycle is optimal in the following way: there exists a path that 738-- is either empty or ends in a vertex adjacent to the first vertex in the 739-- cycle, such that all vertices in @path ++ cycle@ are distinct and 740-- @path ++ cycle@ is lexicographically minimal among all such pairs of paths 741-- and cycles. 742-- 743-- /Note/: since 'AdjacencyMap' represents __undirected__ bipartite graphs, all 744-- edges in the input graph are treated as undirected. See the examples and the 745-- correctness property for a clarification. 746-- 747-- It is advised to use 'leftVertexList' and 'rightVertexList' to obtain the 748-- partition of the vertices and 'hasLeftVertex' and 'hasRightVertex' to check 749-- whether a vertex belongs to a part. 750-- 751-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. 752-- 753-- @ 754-- detectParts 'Algebra.Graph.AdjacencyMap.empty' == Right 'empty' 755-- detectParts ('Algebra.Graph.AdjacencyMap.vertex' x) == Right ('leftVertex' x) 756-- detectParts ('Algebra.Graph.AdjacencyMap.edge' x x) == Left [x] 757-- detectParts ('Algebra.Graph.AdjacencyMap.edge' 1 2) == Right ('edge' 1 2) 758-- detectParts (1 * (2 + 3)) == Right ('edges' [(1,2), (1,3)]) 759-- detectParts (1 * 2 * 3) == Left [1, 2, 3] 760-- detectParts ((1 + 3) * (2 + 4) + 6 * 5) == Right ('swap' (1 + 3) * (2 + 4) + 'swap' 5 * 6) 761-- detectParts ((1 * 3 * 4) + 2 * (1 + 2)) == Left [2] 762-- detectParts ('Algebra.Graph.AdjacencyMap.clique' [1..10]) == Left [1, 2, 3] 763-- detectParts ('Algebra.Graph.AdjacencyMap.circuit' [1..10]) == Right ('circuit' [(x, x + 1) | x <- [1,3,5,7,9]]) 764-- detectParts ('Algebra.Graph.AdjacencyMap.circuit' [1..11]) == Left [1..11] 765-- detectParts ('Algebra.Graph.AdjacencyMap.biclique' [] xs) == Right ('vertices' xs []) 766-- detectParts ('Algebra.Graph.AdjacencyMap.biclique' ('map' Left (x:xs)) ('map' Right ys)) == Right ('biclique' ('map' Left (x:xs)) ('map' Right ys)) 767-- 'isRight' (detectParts ('Algebra.Graph.AdjacencyMap.star' x ys)) == 'notElem' x ys 768-- 'isRight' (detectParts ('fromBipartite' ('toBipartite' x))) == True 769-- @ 770-- 771-- The correctness of 'detectParts' can be expressed by the following property: 772-- 773-- @ 774-- let undirected = 'Algebra.Graph.AdjacencyMap.symmetricClosure' input in 775-- case detectParts input of 776-- Left cycle -> 'mod' (length cycle) 2 == 1 && 'Algebra.Graph.AdjacencyMap.isSubgraphOf' ('Algebra.Graph.AdjacencyMap.circuit' cycle) undirected 777-- Right result -> 'Algebra.Graph.AdjacencyMap.gmap' 'Data.Either.Extra.fromEither' ('fromBipartite' result) == undirected 778-- @ 779detectParts :: Ord a => AM.AdjacencyMap a -> Either (OddCycle a) (AdjacencyMap a a) 780detectParts x = case runState (runMaybeT dfs) Map.empty of 781 (Nothing, m) -> Right $ toBipartiteWith (toEither m) g 782 (Just c, _) -> Left $ oddCycle c 783 where 784 -- g :: AM.AdjacencyMap a 785 g = AM.symmetricClosure x 786 787 -- type PartMap a = Map a Part 788 -- type PartMonad a = MaybeT (State (PartMap a)) [a] 789 -- dfs :: PartMonad a 790 dfs = asum [ processVertex v | v <- AM.vertexList g ] 791 792 -- processVertex :: a -> PartMonad a 793 processVertex v = do m <- get 794 guard (Map.notMember v m) 795 inVertex LeftPart v 796 797 -- inVertex :: Part -> a -> PartMonad a 798 inVertex p v = ((:) v) <$> do modify (Map.insert v p) 799 let q = otherPart p 800 asum [ onEdge q u | u <- Set.toAscList (AM.postSet v g) ] 801 802 {-# INLINE onEdge #-} 803 -- onEdge :: Part -> a -> PartMonad a 804 onEdge p v = do m <- get 805 case Map.lookup v m of 806 Nothing -> inVertex p v 807 Just q -> do guard (p /= q) 808 return [v] 809 810 -- toEither :: PartMap a -> a -> Either a a 811 toEither m v = case fromJust (Map.lookup v m) of 812 LeftPart -> Left v 813 RightPart -> Right v 814 815 -- oddCycle :: [a] -> [a] 816 oddCycle c = init $ dropWhile (/= last c) c 817 818-- | Check that the internal graph representation is consistent, i.e. that all 819-- edges that are present in the 'leftAdjacencyMap' are also present in the 820-- 'rightAdjacencyMap' map. It should be impossible to create an inconsistent 821-- adjacency map, and we use this function in testing. 822-- 823-- @ 824-- consistent 'empty' == True 825-- consistent ('vertex' x) == True 826-- consistent ('edge' x y) == True 827-- consistent ('edges' x) == True 828-- consistent ('toBipartite' x) == True 829-- consistent ('swap' x) == True 830-- consistent ('circuit' x) == True 831-- consistent ('biclique' x y) == True 832-- @ 833consistent :: (Ord a, Ord b) => AdjacencyMap a b -> Bool 834consistent (BAM lr rl) = edgeList lr == sort (map Data.Tuple.swap $ edgeList rl) 835 where 836 edgeList lr = [ (u, v) | (u, vs) <- Map.toAscList lr, v <- Set.toAscList vs ] 837