From 408849340506b856a63bcb2ef7d912940ccb3bd7 Mon Sep 17 00:00:00 2001 From: Andrey Mokhov Date: Sun, 2 Feb 2020 23:49:31 +0000 Subject: [PATCH] Revision in preparation for 0.5 (#255) --- AUTHORS.md | 17 +- CHANGES.md | 7 +- LICENSE | 2 +- algebraic-graphs.cabal | 5 +- src/Algebra/Graph.hs | 8 +- src/Algebra/Graph/Acyclic/AdjacencyMap.hs | 5 +- src/Algebra/Graph/AdjacencyIntMap.hs | 6 +- src/Algebra/Graph/AdjacencyMap.hs | 6 +- src/Algebra/Graph/AdjacencyMap/Algorithm.hs | 25 +- .../{ => Undirected}/AdjacencyMap.hs | 652 +++++++-------- src/Algebra/Graph/Internal.hs | 35 +- src/Algebra/Graph/Labelled.hs | 7 +- src/Algebra/Graph/Labelled/AdjacencyMap.hs | 5 +- src/Algebra/Graph/NonEmpty.hs | 6 +- src/Algebra/Graph/NonEmpty/AdjacencyMap.hs | 10 +- src/Algebra/Graph/Relation.hs | 6 +- src/Algebra/Graph/Relation/Symmetric.hs | 7 +- src/Algebra/Graph/Undirected.hs | 432 ++++------ test/Algebra/Graph/Test/API.hs | 3 +- .../Graph/Test/Acyclic/AdjacencyMap.hs | 11 +- test/Algebra/Graph/Test/Arbitrary.hs | 30 +- .../Graph/Test/Bipartite/AdjacencyMap.hs | 750 ------------------ .../Test/Bipartite/Undirected/AdjacencyMap.hs | 628 +++++++++++++++ test/Algebra/Graph/Test/Generic.hs | 19 +- .../Graph/Test/Labelled/AdjacencyMap.hs | 2 +- .../Graph/Test/NonEmpty/AdjacencyMap.hs | 15 +- test/Algebra/Graph/Test/NonEmpty/Graph.hs | 15 +- test/Algebra/Graph/Test/Undirected.hs | 1 - test/Main.hs | 34 +- 29 files changed, 1261 insertions(+), 1488 deletions(-) rename src/Algebra/Graph/Bipartite/{ => Undirected}/AdjacencyMap.hs (50%) delete mode 100644 test/Algebra/Graph/Test/Bipartite/AdjacencyMap.hs create mode 100644 test/Algebra/Graph/Test/Bipartite/Undirected/AdjacencyMap.hs diff --git a/AUTHORS.md b/AUTHORS.md index 1e99e2a9f..b70a16ebd 100644 --- a/AUTHORS.md +++ b/AUTHORS.md @@ -4,19 +4,20 @@ The Alga library was originally developed by but over time many contributors helped make it much better, including (among others): -* [Adithya Obilisetty](mailto:adi.obilisetty@gmail.com) [@adithyaov](https://github.com/adithyaov) +* [Vasily Alferov](mailto:vasily.v.alferov@gmail.com) [@vasalf](https://github.com/vasalf) +* [Piotr Gawryś](mailto:pgawrys2@gmail.com) [@Avasil](https://github.com/Avasil) * [Alexandre Moine](mailto:alexandre@moine.me) [@nobrakal](https://github.com/nobrakal) -* [Armando Santos](mailto:armandoifsantos@gmail.com) [@bolt12](https://github.com/bolt12) * [Joseph Novakovich](mailto:jrn@bluefarm.ca) [@jitwit](https://github.com/jitwit) -* [Piotr Gawryś](mailto:pgawrys2@gmail.com) [@Avasil](https://github.com/Avasil) -* [Vasily Alferov](mailto:vasily.v.alferov@gmail.com) [@vasalf](https://github.com/vasalf) +* [Adithya Obilisetty](mailto:adi.obilisetty@gmail.com) [@adithyaov](https://github.com/adithyaov) +* [Armando Santos](mailto:armandoifsantos@gmail.com) [@bolt12](https://github.com/bolt12) -If you are not on this list, it's not because your contributions are not appreciated, but -because I didn't want to add your name and contact details without your consent. Please fix this -by sending a PR, keeping the list alphabetical. +If you are not on this list, it's not because your contributions are not +appreciated, but because I didn't want to add your name and contact details +without your consent. Please fix this by sending a PR, keeping the list +alphabetical (sorted by last and then first name). Also see the autogenerated yet still possibly incomplete [list of contributors](https://github.com/snowleopard/alga/graphs/contributors). -Thank you all for your help! +Thank you all for your help! Andrey diff --git a/CHANGES.md b/CHANGES.md index eab2bd7cb..26934357f 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -2,9 +2,14 @@ ## 0.5 -* #172, #245: Stop supporting GHC 7.8.4 and GHC 7.10.3. +* #217, #224, #227, #234, #235: Add new BFS, DFS, topological sort, and SCC + algorithms for adjacency maps. +* #228, #247, #254: Improve algebraic graph fusion. +* #207, #218, #255: Add `Bipartite.Undirected.AdjacencyMap`. +* #220, #237, #255: Add `Algebra.Graph.Undirected`. * #203, #215, #223: Add `Acyclic.AdjacencyMap`. * #202, #209, #211: Add `induceJust` and `induceJust1`. +* #172, #245: Stop supporting GHC 7.8.4 and GHC 7.10.3. * #208: Add `fromNonEmpty` to `NonEmpty.AdjacencyMap`. * #208: Add `fromAdjacencyMap` to `AdjacencyIntMap`. * #208: Drop `Internal` modules for `AdjacencyIntMap`, `AdjacencyMap`, diff --git a/LICENSE b/LICENSE index 93b29c27e..dc5ac3f42 100644 --- a/LICENSE +++ b/LICENSE @@ -1,6 +1,6 @@ MIT License -Copyright (c) 2016-2018 Andrey Mokhov +Copyright (c) 2016-2020 Andrey Mokhov Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal diff --git a/algebraic-graphs.cabal b/algebraic-graphs.cabal index f46f1c7c0..19a4735c1 100644 --- a/algebraic-graphs.cabal +++ b/algebraic-graphs.cabal @@ -56,6 +56,7 @@ description: . extra-doc-files: + AUTHORS.md CHANGES.md README.md @@ -101,7 +102,7 @@ library Algebra.Graph.AdjacencyIntMap.Algorithm, Algebra.Graph.AdjacencyMap, Algebra.Graph.AdjacencyMap.Algorithm, - Algebra.Graph.Bipartite.AdjacencyMap, + Algebra.Graph.Bipartite.Undirected.AdjacencyMap, Algebra.Graph.Class, Algebra.Graph.Export, Algebra.Graph.Export.Dot, @@ -133,7 +134,7 @@ test-suite test-alga Algebra.Graph.Test.AdjacencyIntMap, Algebra.Graph.Test.AdjacencyMap, Algebra.Graph.Test.Arbitrary, - Algebra.Graph.Test.Bipartite.AdjacencyMap, + Algebra.Graph.Test.Bipartite.Undirected.AdjacencyMap, Algebra.Graph.Test.Export, Algebra.Graph.Test.Generic, Algebra.Graph.Test.Graph, diff --git a/src/Algebra/Graph.hs b/src/Algebra/Graph.hs index e0f99efd8..27b5fa804 100644 --- a/src/Algebra/Graph.hs +++ b/src/Algebra/Graph.hs @@ -309,7 +309,7 @@ empty = Empty -- -- @ -- 'isEmpty' (vertex x) == False --- 'hasVertex' x (vertex x) == True +-- 'hasVertex' x (vertex y) == (x == y) -- 'vertexCount' (vertex x) == 1 -- 'edgeCount' (vertex x) == 0 -- 'size' (vertex x) == 1 @@ -404,6 +404,7 @@ vertices xs = buildg $ \e v o _ -> combineR e o v xs -- @ -- edges [] == 'empty' -- edges [(x,y)] == 'edge' x y +-- edges == 'overlays' . 'map' ('uncurry' 'edge') -- 'edgeCount' . edges == 'length' . 'Data.List.nub' -- @ edges :: [(a, a)] -> Graph a @@ -550,7 +551,7 @@ _ === _ = False infix 4 === --- | Check if a graph is empty. A convenient alias for 'null'. +-- | Check if a graph is empty. -- Complexity: /O(s)/ time. -- -- Good consumer. @@ -591,8 +592,7 @@ size = foldg 1 (const 1) (+) (+) -- -- @ -- hasVertex x 'empty' == False --- hasVertex x ('vertex' x) == True --- hasVertex 1 ('vertex' 2) == False +-- hasVertex x ('vertex' y) == (x == y) -- hasVertex x . 'removeVertex' x == 'const' False -- @ hasVertex :: Eq a => a -> Graph a -> Bool diff --git a/src/Algebra/Graph/Acyclic/AdjacencyMap.hs b/src/Algebra/Graph/Acyclic/AdjacencyMap.hs index 976deded7..b6704d795 100644 --- a/src/Algebra/Graph/Acyclic/AdjacencyMap.hs +++ b/src/Algebra/Graph/Acyclic/AdjacencyMap.hs @@ -137,7 +137,7 @@ empty = coerce AM.empty -- -- @ -- 'isEmpty' (vertex x) == False --- 'hasVertex' x (vertex x) == True +-- 'hasVertex' x (vertex y) == (x == y) -- 'vertexCount' (vertex x) == 1 -- 'edgeCount' (vertex x) == 0 -- @ @@ -216,8 +216,7 @@ isEmpty = coerce AM.isEmpty -- -- @ -- hasVertex x 'empty' == False --- hasVertex x ('vertex' x) == True --- hasVertex 1 ('vertex' 2) == False +-- hasVertex x ('vertex' y) == (x == y) -- hasVertex x . 'removeVertex' x == 'const' False -- @ hasVertex :: Ord a => a -> AdjacencyMap a -> Bool diff --git a/src/Algebra/Graph/AdjacencyIntMap.hs b/src/Algebra/Graph/AdjacencyIntMap.hs index c100f3af0..185e4db80 100644 --- a/src/Algebra/Graph/AdjacencyIntMap.hs +++ b/src/Algebra/Graph/AdjacencyIntMap.hs @@ -234,7 +234,7 @@ empty = AM IntMap.empty -- -- @ -- 'isEmpty' (vertex x) == False --- 'hasVertex' x (vertex x) == True +-- 'hasVertex' x (vertex y) == (x == y) -- 'vertexCount' (vertex x) == 1 -- 'edgeCount' (vertex x) == 0 -- @ @@ -318,6 +318,7 @@ vertices = AM . IntMap.fromList . map (\x -> (x, IntSet.empty)) -- @ -- edges [] == 'empty' -- edges [(x,y)] == 'edge' x y +-- edges == 'overlays' . 'map' ('uncurry' 'edge') -- 'edgeCount' . edges == 'length' . 'Data.List.nub' -- 'edgeList' . edges == 'Data.List.nub' . 'Data.List.sort' -- @ @@ -385,8 +386,7 @@ isEmpty = IntMap.null . adjacencyIntMap -- -- @ -- hasVertex x 'empty' == False --- hasVertex x ('vertex' x) == True --- hasVertex 1 ('vertex' 2) == False +-- hasVertex x ('vertex' y) == (x == y) -- hasVertex x . 'removeVertex' x == 'const' False -- @ hasVertex :: Int -> AdjacencyIntMap -> Bool diff --git a/src/Algebra/Graph/AdjacencyMap.hs b/src/Algebra/Graph/AdjacencyMap.hs index 6b7c22798..c73f46541 100644 --- a/src/Algebra/Graph/AdjacencyMap.hs +++ b/src/Algebra/Graph/AdjacencyMap.hs @@ -220,7 +220,7 @@ empty = AM Map.empty -- -- @ -- 'isEmpty' (vertex x) == False --- 'hasVertex' x (vertex x) == True +-- 'hasVertex' x (vertex y) == (x == y) -- 'vertexCount' (vertex x) == 1 -- 'edgeCount' (vertex x) == 0 -- @ @@ -304,6 +304,7 @@ vertices = AM . Map.fromList . map (\x -> (x, Set.empty)) -- @ -- edges [] == 'empty' -- edges [(x,y)] == 'edge' x y +-- edges == 'overlays' . 'map' ('uncurry' 'edge') -- 'edgeCount' . edges == 'length' . 'Data.List.nub' -- 'edgeList' . edges == 'Data.List.nub' . 'Data.List.sort' -- @ @@ -371,8 +372,7 @@ isEmpty = Map.null . adjacencyMap -- -- @ -- hasVertex x 'empty' == False --- hasVertex x ('vertex' x) == True --- hasVertex 1 ('vertex' 2) == False +-- hasVertex x ('vertex' y) == (x == y) -- hasVertex x . 'removeVertex' x == 'const' False -- @ hasVertex :: Ord a => a -> AdjacencyMap a -> Bool diff --git a/src/Algebra/Graph/AdjacencyMap/Algorithm.hs b/src/Algebra/Graph/AdjacencyMap/Algorithm.hs index 7bc26a2cf..7c8a25d46 100644 --- a/src/Algebra/Graph/AdjacencyMap/Algorithm.hs +++ b/src/Algebra/Graph/AdjacencyMap/Algorithm.hs @@ -19,10 +19,10 @@ module Algebra.Graph.AdjacencyMap.Algorithm ( -- * Algorithms bfsForest, bfs, dfsForest, dfsForestFrom, dfs, reachable, topSort, isAcyclic, scc, - + -- * Correctness properties isDfsForestOf, isTopSortOf, - + -- * Type synonyms Cycle ) where @@ -50,7 +50,7 @@ import qualified Data.Set as Set -- argument vertices that will be the roots of the resulting -- forest. Duplicates in the list will have their first occurrence -- expanded and subsequent ones ignored. Argument vertices not in --- the graph are also ignored. +-- the graph are also ignored. -- -- Let /L/ be the number of seed vertices. Complexity: -- /O((L+m)*log n)/ time and /O(n)/ space. @@ -69,7 +69,7 @@ import qualified Data.Set as Set -- , Node { rootLabel = 4 -- , subForest = [] }] -- 'forest' (bfsForest [3] ('circuit' [1..5] + 'circuit' [5,4..1])) == 'path' [3,2,1] + 'path' [3,4,5] --- +-- -- @ bfsForest :: Ord a => [a] -> AdjacencyMap a -> Forest a bfsForest vs g = evalState (explore [ v | v <- vs, hasVertex v g ]) Set.empty where @@ -88,7 +88,7 @@ bfsForest vs g = evalState (explore [ v | v <- vs, hasVertex v g ]) Set.empty wh -- -- Let /L/ be the number of seed vertices. Complexity: -- /O((L+m)*log n)/ time and /O(n)/ space. --- +-- -- @ -- bfs vs 'empty' == [] -- bfs [] g == [] @@ -141,10 +141,10 @@ dfsForest g = dfsForestFrom' (vertexList g) g -- resulting forest does not necessarily span the whole graph, as -- some vertices may be unreachable. Any of the given vertices which -- are not in the graph are ignored. --- +-- -- Let /L/ be the number of seed vertices. Complexity: /O((L+m)*log n)/ -- time and /O(n)/ space. --- +-- -- @ -- dfsForestFrom vs 'empty' == [] -- 'forest' (dfsForestFrom [1] $ 'edge' 1 1) == 'vertex' 1 @@ -171,7 +171,7 @@ dfsForestFrom' :: Ord a => [a] -> AdjacencyMap a -> Forest a dfsForestFrom' vs g = evalState (explore vs) Set.empty where explore (v:vs) = discovered v >>= \case True -> (:) <$> walk v <*> explore vs - False -> explore vs + False -> explore vs explore [] = return [] walk v = Node v <$> explore (adjacent v) adjacent v = Set.toList (postSet v g) @@ -205,7 +205,7 @@ dfs vs = dfsForestFrom vs >=> flatten -- | Compute the list of vertices that are /reachable/ from a given -- source vertex in a graph. The vertices in the resulting list -- appear in /depth-first order/. --- +-- -- Complexity: /O(m*log n)/ time and /O(n)/ space. -- -- @ @@ -222,7 +222,7 @@ dfs vs = dfsForestFrom vs >=> flatten reachable :: Ord a => a -> AdjacencyMap a -> [a] reachable x = dfs [x] -type Cycle = NonEmpty +type Cycle = NonEmpty data NodeState = Entered | Exited data S a = S { parent :: Map.Map a a , entry :: Map.Map a NodeState @@ -289,7 +289,7 @@ topSort g = runContT (evalStateT (topSort' g) initialState) id where initialState = S Map.empty Map.empty [] -- | Check if a given graph is /acyclic/. --- +-- -- Complexity: /O((n+m)*log n)/ time and /O(n)/ space. -- -- @ @@ -384,7 +384,8 @@ gabowSCC g = insertComponent v = modify' (\(SCC pre scc bnd pth pres sccs gs es_i es_o) -> - let (curr,_v:pth') = span (/=v) pth + let (curr,v_pth') = span (/=v) pth + pth' = tail v_pth' -- Here we know that v_pth' starts with v (es,es_i') = span ((>=p_v).fst) es_i g_i | null es = vertex v | otherwise = edges (snd <$> es) diff --git a/src/Algebra/Graph/Bipartite/AdjacencyMap.hs b/src/Algebra/Graph/Bipartite/Undirected/AdjacencyMap.hs similarity index 50% rename from src/Algebra/Graph/Bipartite/AdjacencyMap.hs rename to src/Algebra/Graph/Bipartite/Undirected/AdjacencyMap.hs index 35e3844f6..28d849c42 100644 --- a/src/Algebra/Graph/Bipartite/AdjacencyMap.hs +++ b/src/Algebra/Graph/Bipartite/Undirected/AdjacencyMap.hs @@ -1,11 +1,8 @@ {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE ExplicitForAll #-} -{-# LANGUAGE ScopedTypeVariables #-} - ---------------------------------------------------------------------------- -- | --- Module : Algebra.Graph.Bipartite.AdjacencyMap --- Copyright : (c) Andrey Mokhov 2016-2019 +-- Module : Algebra.Graph.Bipartite.Undirected.AdjacencyMap +-- Copyright : (c) Andrey Mokhov 2016-2020 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental @@ -15,69 +12,75 @@ -- the motivation behind the library, the underlying theory, and -- implementation details. -- --- This module defines the 'AdjacencyMap' data type for bipartite graphs and --- basic associated functions. +-- This module defines the 'AdjacencyMap' data type for undirected bipartite +-- graphs and associated functions. To avoid name clashes with +-- "Algebra.Graph.AdjacencyMap", this module can be imported qualified: +-- +-- @ +-- import qualified Algebra.Graph.Bipartite.Undirected.AdjacencyMap as Bipartite +-- @ ---------------------------------------------------------------------------- -module Algebra.Graph.Bipartite.AdjacencyMap ( +module Algebra.Graph.Bipartite.Undirected.AdjacencyMap ( -- * Data structure AdjacencyMap, leftAdjacencyMap, rightAdjacencyMap, -- * Basic graph construction primitives - empty, leftVertex, rightVertex, vertex, edge, overlay, connect, - vertices, edges, overlays, connects, swap, + empty, leftVertex, rightVertex, vertex, edge, overlay, connect, vertices, + edges, overlays, connects, swap, -- * Conversion functions - toBipartite, toBipartiteWith, fromBipartite, fromGraph, + toBipartite, toBipartiteWith, fromBipartite, fromBipartiteWith, -- * Graph properties - isEmpty, hasEdge, hasLeftVertex, hasRightVertex, hasVertex, leftVertexCount, + isEmpty, hasLeftVertex, hasRightVertex, hasVertex, hasEdge, leftVertexCount, rightVertexCount, vertexCount, edgeCount, leftVertexList, rightVertexList, vertexList, edgeList, leftVertexSet, rightVertexSet, vertexSet, edgeSet, -- * Standard families of graphs circuit, biclique, - -- * Testing bipartiteness + -- * Algorithms OddCycle, detectParts, -- * Miscellaneous - consistent, + consistent ) where -import Control.Monad (guard) -import Control.Monad.Trans.Maybe (MaybeT(..)) -import Control.Monad.State (State, runState, modify, get) -import Data.Either (lefts, rights) -import Data.Foldable (asum) -import Data.List (sort, (\\)) -import Data.Maybe (fromJust) +import Control.Monad +import Control.Monad.Trans.Maybe +import Control.Monad.State +import Data.Either +import Data.Foldable +import Data.List +import Data.Map.Strict (Map) +import Data.Maybe +import Data.Set (Set) import GHC.Generics -import qualified Algebra.Graph as G import qualified Algebra.Graph.AdjacencyMap as AM import qualified Data.Map.Strict as Map import qualified Data.Set as Set import qualified Data.Tuple -{-| The 'Bipartite.AdjacencyMap' data type represents an __undirected__ -bipartite graph. The two type parameteters define the types of identifiers of -the vertices of each part. +{-| The 'Bipartite.AdjacencyMap' data type represents an undirected bipartite +graph. The two type parameteters define the types of identifiers of the vertices +of each part. -__Note:__ even if the identifiers and their types for two vertices of -different parts are equal, these vertices are considered to be different. -See examples for more details. +__Note:__ even if the identifiers and their types for two vertices of different +parts are equal, these vertices are considered to be different. See examples for +more details. We define a 'Num' instance as a convenient notation for working with bipartite graphs: @ -0 == rightVertex 0 -'swap' 1 == leftVertex 1 -'swap' 1 + 2 == vertices [1] [2] -('swap' 1) * 2 == edge 1 2 -('swap' 1) + 2 * ('swap' 3) == overlay (leftVertex 1) (edge 3 2) -('swap' 1) * (2 + ('swap' 3)) == connect (leftVertex 1) (vertices [3] [2]) +0 == rightVertex 0 +'swap' 1 == leftVertex 1 +'swap' 1 + 2 == vertices [1] [2] +'swap' 1 * 2 == edge 1 2 +'swap' 1 + 2 * 'swap' 3 == overlay (leftVertex 1) (edge 3 2) +'swap' 1 * (2 + 'swap' 3) == connect (leftVertex 1) (vertices [3] [2]) @ __Note:__ the 'Num' instance does not satisfy several "customary laws" of 'Num', @@ -91,15 +94,14 @@ would be able to utilise without violating any laws. The 'Show' instance is defined using basic graph construction primitives: @ -show (empty) == "empty" -show 1 == "rightVertex 1" -show ('swap' 2) == "leftVertex 2" -show (1 + 2) == "vertices [] [1,2]" -show ('swap' (1 + 2)) == "vertices [1,2] []" -show ('swap' 1 * 2) == "edge 1 2" -show ('swap' 1 * 2 * 'swap' 3) == "edges [(1,2),(3,2)]" -show ('swap' 1 * 2 + 'swap' 3) == "overlay (leftVertex 3) (edge 1 2)" -show ('swap' 1 * 2 + 'swap' 3 + 4) == "overlay (vertices [3] [4]) (edge 1 2)" +show empty == "empty" +show 1 == "rightVertex 1" +show ('swap' 2) == "leftVertex 2" +show (1 + 2) == "vertices [] [1,2]" +show ('swap' (1 + 2)) == "vertices [1,2] []" +show ('swap' 1 * 2) == "edge 1 2" +show ('swap' 1 * 2 * 'swap' 3) == "edges [(1,2),(3,2)]" +show ('swap' 1 * 2 + 'swap' 3) == "overlay (leftVertex 3) (edge 1 2)" @ The 'Eq' instance satisfies all axioms of algebraic graphs: @@ -109,16 +111,14 @@ The 'Eq' instance satisfies all axioms of algebraic graphs: > x + y == y + x > x + (y + z) == (x + y) + z - * 'connect' is commutative, associative and has - 'empty' as the identity: + * 'connect' is commutative, associative and has 'empty' as the identity: > x * empty == x > empty * x == x > x * y == y * x > x * (y * z) == (x * y) * z - * 'connect' distributes over - 'overlay': + * 'connect' distributes over 'overlay': > x * (y + z) == x * y + x * z > (x + y) * z == x * z + y * z @@ -129,13 +129,12 @@ The 'Eq' instance satisfies all axioms of algebraic graphs: * 'connect' has the same effect as 'overlay' on vertices of one part: - > (leftVertex x) * (leftVertex y) == (leftVertex x) + (leftVertex y) - > (rightVertex x) * (rightVertex y) == (rightVertex x) + (rightVertex y) + > leftVertex x * leftVertex y == leftVertex x + leftVertex y + > rightVertex x * rightVertex y == rightVertex x + rightVertex y The following useful theorems can be proved from the above set of axioms. - * 'overlay' has 'empty' - as the identity and is idempotent: + * 'overlay' has 'empty' as the identity and is idempotent: > x + empty == x > empty + x == x @@ -150,35 +149,32 @@ When specifying the time and memory complexity of graph algorithms, /n/ and /m/ will denote the number of vertices and edges in the graph, respectively. In addition, /l/ and /r/ will denote the number of vertices in the left and in the right part of graph, respectively. - -} data AdjacencyMap a b = BAM { - -- | The /adjacency map/ of the left part of the graph: each vertex is - -- associated with a set of its neighbours. Complexity: /O(1)/ time and - -- memory. + -- | The /adjacency map/ of the left part of the graph: each left vertex is + -- associated with a set of its right neighbours. + -- Complexity: /O(1)/ time and memory. -- -- @ - -- leftAdjacencyMap 'empty' == Map.'Map.empty' - -- leftAdjacencyMap ('leftVertex' 1) == Map.'Map.singleton' 1 Set.'Set.empty' - -- leftAdjacencyMap ('rightVertex' 1) == Map.'Map.empty' - -- leftAdjacencyMap ('edge' 1 1) == Map.'Map.singleton' 1 (Set.'Set.singleton' 1) - -- leftAdjacencyMap ('edge' 1 "a") == Map.'Map.singleton' 1 (Set.'Set.singleton' "a") - -- leftAdjacencyMap ('edges' [(1, 1), (1, 2)]) == Map.'Map.singleton' 1 (Set.'Set.fromAscList' [1, 2]) + -- leftAdjacencyMap 'empty' == Map.'Map.empty' + -- leftAdjacencyMap ('leftVertex' x) == Map.'Map.singleton' x Set.'Set.empty' + -- leftAdjacencyMap ('rightVertex' x) == Map.'Map.empty' + -- leftAdjacencyMap ('edge' x y) == Map.'Map.singleton' x (Set.'Set.singleton' y) -- @ - leftAdjacencyMap :: Map.Map a (Set.Set b), + leftAdjacencyMap :: Map a (Set b), - -- | The inverse map for 'leftAdjacencyMap'. Complexity: /O(1)/ time and memory. + -- | The /adjacency map/ of the right part of the graph: each right vertex + -- is associated with a set of left neighbours. + -- Complexity: /O(1)/ time and memory. -- -- @ - -- rightAdjacencyMap 'empty' == Map.'Map.empty' - -- rightAdjacencyMap ('leftVertex' 1) == Map.'Map.empty' - -- rightAdjacencyMap ('rightVertex' 1) == Map.'Map.singleton' 1 Set.'Set.empty' - -- rightAdjacencyMap ('edge' 1 1) == Map.'Map.singleton' 1 (Set.'Set.singleton' 1) - -- rightAdjacencyMap ('edge' 1 "a") == Map.'Map.singleton' "a" (Set.'Set.singleton' 1) - -- rightAdjacencyMap ('edges' [(1, 1), (1, 2)]) == Map.'Map.fromAscList' [(1, Set.'Set.singleton' 1), (2, Set.'Set.singleton' 1)] + -- rightAdjacencyMap 'empty' == Map.'Map.empty' + -- rightAdjacencyMap ('leftVertex' x) == Map.'Map.empty' + -- rightAdjacencyMap ('rightVertex' x) == Map.'Map.singleton' x Set.'Set.empty' + -- rightAdjacencyMap ('edge' x y) == Map.'Map.singleton' y (Set.'Set.singleton' x) -- @ - rightAdjacencyMap :: Map.Map b (Set.Set a) -} deriving Generic + rightAdjacencyMap :: Map b (Set a) + } deriving Generic -- | __Note:__ this does not satisfy the usual ring laws; see 'AdjacencyMap' -- for more details. @@ -191,40 +187,48 @@ instance (Ord a, Ord b, Num b) => Num (AdjacencyMap a b) where negate = id instance (Ord a, Ord b) => Eq (AdjacencyMap a b) where - (BAM lr1 rl1) == (BAM lr2 rl2) = (lr1 == lr2) && (Map.keysSet rl1 == Map.keysSet rl2) + BAM lr1 rl1 == BAM lr2 rl2 = lr1 == lr2 && Map.keysSet rl1 == Map.keysSet rl2 + +instance (Ord a, Ord b) => Ord (AdjacencyMap a b) where + compare x y = mconcat + [ compare (vertexCount x) (vertexCount y) + , compare (vertexSet x) (vertexSet y) + , compare (edgeCount x) (edgeCount y) + , compare (edgeSet x) (edgeSet y) ] instance (Ord a, Ord b, Show a, Show b) => Show (AdjacencyMap a b) where showsPrec p bam | null lvs && null rvs = showString "empty" | null es = showParen (p > 10) $ vshow lvs rvs | (lvs == lused) && (rvs == rused) = showParen (p > 10) $ eshow es - | otherwise = showParen (p > 10) $ - showString "overlay (" . - veshow (vs \\ used) . - showString ") (" . - eshow es . - showString ")" + | otherwise = showParen (p > 10) + $ showString "overlay (" + . veshow (vs \\ used) + . showString ") (" + . eshow es + . showString ")" where lvs = leftVertexList bam rvs = rightVertexList bam - vs = vertexList bam - es = edgeList bam + vs = vertexList bam + es = edgeList bam vshow [x] [] = showString "leftVertex " . showsPrec 11 x vshow [] [x] = showString "rightVertex " . showsPrec 11 x - vshow xs ys = showString "vertices " . showsPrec 11 xs . - showString " " . showsPrec 11 ys - veshow xs = vshow (lefts xs) (rights xs) - eshow [(x, y)] = showString "edge " . showsPrec 11 x . - showString " " . showsPrec 11 y + vshow xs ys = showString "vertices " . showsPrec 11 xs + . showString " " . showsPrec 11 ys + veshow xs = vshow (lefts xs) (rights xs) + eshow [(x, y)] = showString "edge " . showsPrec 11 x + . showString " " . showsPrec 11 y eshow es = showString "edges " . showsPrec 11 es lused = Set.toAscList $ Set.fromAscList [ u | (u, _) <- edgeList bam ] rused = Set.toAscList $ Set.fromList [ v | (_, v) <- edgeList bam ] - used = (map Left lused) ++ (map Right rused) + used = map Left lused ++ map Right rused -- | Construct the /empty graph/. -- Complexity: /O(1)/ time and memory. -- -- @ +-- 'isEmpty' empty == True -- 'leftAdjacencyMap' empty == Map.'Map.empty' -- 'rightAdjacencyMap' empty == Map.'Map.empty' -- 'hasVertex' x empty == False @@ -239,9 +243,9 @@ empty = BAM Map.empty Map.empty -- @ -- 'leftAdjacencyMap' (leftVertex x) == Map.'Map.singleton' x Set.'Set.empty' -- 'rightAdjacencyMap' (leftVertex x) == Map.'Map.empty' +-- 'hasLeftVertex' x (leftVertex y) == (x == y) +-- 'hasRightVertex' x (leftVertex y) == False -- 'hasEdge' x y (leftVertex z) == False --- 'hasLeftVertex' x (leftVertex x) == True --- 'hasRightVertex' x (leftVertex x) == False -- @ leftVertex :: a -> AdjacencyMap a b leftVertex x = BAM (Map.singleton x Set.empty) Map.empty @@ -253,9 +257,9 @@ leftVertex x = BAM (Map.singleton x Set.empty) Map.empty -- @ -- 'leftAdjacencyMap' (rightVertex x) == Map.'Map.empty' -- 'rightAdjacencyMap' (rightVertex x) == Map.'Map.singleton' x Set.'Set.empty' --- 'hasEdge' x y (rightVertex y) == False --- 'hasLeftVertex' x (rightVertex x) == False --- 'hasRightVertex' x (rightVertex x) == True +-- 'hasLeftVertex' x (rightVertex y) == False +-- 'hasRightVertex' x (rightVertex y) == (x == y) +-- 'hasEdge' x y (rightVertex z) == False -- @ rightVertex :: b -> AdjacencyMap a b rightVertex y = BAM Map.empty (Map.singleton y Set.empty) @@ -264,10 +268,8 @@ rightVertex y = BAM Map.empty (Map.singleton y Set.empty) -- Complexity: /O(1)/ time and memory. -- -- @ --- vertex (Left x) == 'leftVertex' x --- vertex (Right x) == 'rightVertex' x --- 'hasEdge' x y (vertex (Left x)) == False --- 'hasEdge' x y (vertex (Right y)) == False +-- vertex . Left == 'leftVertex' +-- vertex . Right == 'rightVertex' -- @ vertex :: Either a b -> AdjacencyMap a b vertex (Left x) = leftVertex x @@ -277,14 +279,15 @@ vertex (Right y) = rightVertex y -- Complexity: /O(1)/ time and memory. -- -- @ +-- edge x y == 'connect' ('leftVertex' x) ('rightVertex' y) -- 'leftAdjacencyMap' (edge x y) == Map.'Map.singleton' x (Set.'Set.singleton' y) -- 'rightAdjacencyMap' (edge x y) == Map.'Map.singleton' y (Set.'Set.singleton' x) -- 'hasEdge' x y (edge x y) == True --- 'hasEdge' 1 1 (edge 1 1) == True --- 'hasEdge' 2 1 (edge 1 2) == False +-- 'hasEdge' 1 2 (edge 2 1) == False -- @ edge :: a -> b -> AdjacencyMap a b -edge x y = BAM (Map.singleton x (Set.singleton y)) (Map.singleton y (Set.singleton x)) +edge x y = + BAM (Map.singleton x (Set.singleton y)) (Map.singleton y (Set.singleton x)) -- | /Overlay/ two bipartite graphs. This is a commutative, associative and -- idempotent operation with the identity 'empty'. @@ -299,7 +302,8 @@ edge x y = BAM (Map.singleton x (Set.singleton y)) (Map.singleton y (Set.singlet -- 'edgeCount' (overlay x y) <= 'edgeCount' x + 'edgeCount' y -- @ overlay :: (Ord a, Ord b) => AdjacencyMap a b -> AdjacencyMap a b -> AdjacencyMap a b -overlay (BAM lr1 rl1) (BAM lr2 rl2) = BAM (Map.unionWith Set.union lr1 lr2) (Map.unionWith Set.union rl1 rl2) +overlay (BAM lr1 rl1) (BAM lr2 rl2) = + BAM (Map.unionWith Set.union lr1 lr2) (Map.unionWith Set.union rl1 rl2) -- | /Connect/ two bipartite graphs, not adding the edges between vertices in -- the same part. This is a commutative and associative operation with the @@ -307,35 +311,33 @@ overlay (BAM lr1 rl1) (BAM lr2 rl2) = BAM (Map.unionWith Set.union lr1 lr2) (Map -- 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 in the arguments: /m = O(m1 + m2 + l1 * r2 + l2 * r1)/. +-- number of vertices in the arguments: /O(m1 + m2 + l1 * r2 + l2 * r1)/. -- -- @ --- connect ('leftVertex' 1) ('rightVertex' "a") == 'edge' 1 "a" --- connect ('leftVertex' 1) ('rightVertex' 1) == 'edge' 1 1 --- connect ('leftVertex' 1) ('leftVertex' 2) == 'vertices' [1, 2] [] --- connect ('vertices' [1] [4]) ('vertices' [2] [3]) == 'edges' [(1, 3), (2, 4)] +-- connect ('leftVertex' x) ('leftVertex' y) == 'vertices' [x,y] [] +-- connect ('leftVertex' x) ('rightVertex' y) == 'edge' x y +-- connect ('rightVertex' x) ('leftVertex' y) == 'edge' y x +-- connect ('rightVertex' x) ('rightVertex' y) == 'vertices' [] [x,y] +-- connect ('vertices' xs1 ys1) ('vertices' xs2 ys2) == 'overlay' ('biclique' xs1 ys2) ('biclique' xs2 ys1) -- '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) >= 'leftVertexCount' x * 'rightVertexCount' y -- 'edgeCount' (connect x y) <= 'leftVertexCount' x * 'rightVertexCount' y + 'rightVertexCount' x * 'leftVertexCount' y + 'edgeCount' x + 'edgeCount' y -- @ connect :: (Ord a, Ord b) => AdjacencyMap a b -> AdjacencyMap a b -> AdjacencyMap a b connect (BAM lr1 rl1) (BAM lr2 rl2) = BAM lr rl - where - lr = Map.unionsWith Set.union $ - [ lr1, lr2 - , Map.fromSet (const $ Map.keysSet rl2) (Map.keysSet lr1) - , Map.fromSet (const $ Map.keysSet rl1) (Map.keysSet lr2) - ] - rl = Map.unionsWith Set.union $ - [ rl1, rl2 - , Map.fromSet (const $ Map.keysSet lr2) (Map.keysSet rl1) - , Map.fromSet (const $ Map.keysSet lr1) (Map.keysSet rl2) - ] + where + l1 = Map.keysSet lr1 + l2 = Map.keysSet lr2 + r1 = Map.keysSet rl1 + r2 = Map.keysSet rl2 + lr = Map.unionsWith Set.union + [ lr1, lr2, Map.fromSet (const r2) l1, Map.fromSet (const r1) l2 ] + rl = Map.unionsWith Set.union + [ rl1, rl2, Map.fromSet (const l2) r1, Map.fromSet (const l1) r2 ] -- | Construct the graph comprising two given lists of isolated vertices for -- each part. @@ -343,28 +345,29 @@ connect (BAM lr1 rl1) (BAM lr2 rl2) = BAM lr rl -- length of two lists. -- -- @ --- vertices [] [] == 'empty' --- vertices [x] [] == 'leftVertex' x --- vertices [] [x] == 'rightVertex' x --- 'hasLeftVertex' x (vertices ys zs) == 'elem' x ys --- 'hasRightVertex' x (vertices ys zs) == 'elem' x zs +-- vertices [] [] == 'empty' +-- vertices [x] [] == 'leftVertex' x +-- vertices [] [x] == 'rightVertex' x +-- 'hasLeftVertex' x (vertices xs ys) == 'elem' x xs +-- 'hasRightVertex' y (vertices xs ys) == 'elem' y ys -- @ vertices :: (Ord a, Ord b) => [a] -> [b] -> AdjacencyMap a b -vertices ls rs = BAM (Map.fromList $ map ((flip (,)) Set.empty) ls) (Map.fromList $ map ((flip (,)) Set.empty) rs) +vertices ls rs = BAM (Map.fromList [ (l, Set.empty) | l <- ls ]) + (Map.fromList [ (r, Set.empty) | r <- rs ]) -- | 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' +-- edges [] == 'empty' +-- edges [(x,y)] == 'edge' x y +-- edges == 'overlays' . 'map' ('uncurry' 'edge') +-- 'hasEdge' x y . edges == 'elem' (x,y) +-- 'edgeCount' . edges == 'length' . 'nub' -- @ edges :: (Ord a, Ord b) => [(a, b)] -> AdjacencyMap a b -edges es = BAM (Map.fromListWith Set.union (map (onRight Set.singleton) es)) $ - Map.fromListWith Set.union (map (onRight Set.singleton) (map Data.Tuple.swap es)) - where - onRight f (x, y) = (x, f y) +edges es = BAM (Map.fromListWith Set.union [ (x, Set.singleton y) | (x, y) <- es ]) + (Map.fromListWith Set.union [ (y, Set.singleton x) | (x, y) <- es ]) -- | Overlay a given list of graphs. -- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. @@ -377,8 +380,8 @@ edges es = BAM (Map.fromListWith Set.union (map (onRight Set.singleton) es)) $ -- 'isEmpty' . overlays == 'all' 'isEmpty' -- @ overlays :: (Ord a, Ord b) => [AdjacencyMap a b] -> AdjacencyMap a b -overlays ams = BAM (Map.unionsWith Set.union (map leftAdjacencyMap ams)) $ - Map.unionsWith Set.union (map rightAdjacencyMap ams) +overlays ams = BAM (Map.unionsWith Set.union (map leftAdjacencyMap ams)) + (Map.unionsWith Set.union (map rightAdjacencyMap ams)) -- | Connect a given list of graphs. -- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. @@ -397,80 +400,84 @@ connects = foldr connect empty -- Complexity: /O(1)/ time and memory. -- -- @ --- swap 'empty' == 'empty' --- swap . 'leftVertex' == rightVertex --- swap . 'vertices' == flip 'vertices' --- swap ('edge' 1 "a") == 'edge' "a" 1 --- swap . 'edges' == 'edges' . map Data.Tuple.'Data.Tuple.swap' --- swap . swap == id +-- swap 'empty' == 'empty' +-- swap . 'leftVertex' == 'rightVertex' +-- swap ('vertices' xs ys) == 'vertices' ys xs +-- swap ('edge' x y) == 'edge' y x +-- swap . 'edges' == 'edges' . 'map' Data.Tuple.'Data.Tuple.swap' +-- swap . swap == 'id' -- @ swap :: AdjacencyMap a b -> AdjacencyMap b a swap (BAM lr rl) = BAM rl lr --- | Construct a bipartite 'AdjacencyMap' from "Algebra.Graph.AdjacencyMap" +-- | Construct a bipartite 'AdjacencyMap' from an "Algebra.Graph.AdjacencyMap" -- with given part identifiers, adding all needed edges to make the graph --- undirected and removing all edges inside one part. --- Complexity: /O(m log(n))/. +-- undirected and removing all edges within the same parts. +-- Complexity: /O(m * log(n))/. -- -- @ --- toBipartite (Algebra.Graph.AdjacencyMap.'Algebra.Graph.AdjacencyMap.empty') == 'empty' --- toBipartite (Algebra.Graph.AdjacencyMap.'Algebra.Graph.AdjacencyMap.edge' (Left 1) (Right 1)) == 'edge' 1 1 --- toBipartite (Algebra.Graph.AdjacencyMap.'Algebra.Graph.AdjacencyMap.edge' (Left 1) (Left 1)) == 'empty' --- toBipartite (Algebra.Graph.AdjacencyMap.'Algebra.Graph.AdjacencyMap.edge' (Left 1) (Right "a")) == 'edge' 1 "a" +-- toBipartite 'Algebra.Graph.AdjacencyMap.empty' == 'empty' +-- toBipartite ('Algebra.Graph.AdjacencyMap.vertex' (Left x)) == 'leftVertex' x +-- toBipartite ('Algebra.Graph.AdjacencyMap.vertex' (Right x)) == 'rightVertex' x +-- toBipartite ('Algebra.Graph.AdjacencyMap.edge' (Left x) (Left y)) == 'vertices' [x,y] [] +-- toBipartite ('Algebra.Graph.AdjacencyMap.edge' (Left x) (Right y)) == 'edge' x y +-- toBipartite ('Algebra.Graph.AdjacencyMap.edge' (Right x) (Left y)) == 'edge' y x +-- toBipartite ('Algebra.Graph.AdjacencyMap.edge' (Right x) (Right y)) == 'vertices' [] [x,y] +-- toBipartite ('Algebra.Graph.AdjacencyMap.clique' xs) == 'uncurry' 'biclique' ('partitionEithers' xs) +-- toBipartite . 'fromBipartite' == 'id' -- @ toBipartite :: (Ord a, Ord b) => AM.AdjacencyMap (Either a b) -> AdjacencyMap a b -toBipartite m = BAM (Map.fromAscList [ (u, setRights vs) | (Left u, vs) <- symmetricList]) - (Map.fromAscList [ (u, setLefts vs) | (Right u, vs) <- symmetricList]) - where - setRights = Set.fromAscList . rights . Set.toAscList - setLefts = Set.fromAscList . lefts . Set.toAscList - symmetricList = Map.toAscList $ AM.adjacencyMap $ AM.symmetricClosure m +toBipartite m = BAM (Map.fromAscList [ (x, setRights ys) | (Left x, ys) <- symmetricList ]) + (Map.fromAscList [ (x, setLefts ys) | (Right x, ys) <- symmetricList ]) + where + setRights = Set.fromAscList . rights . Set.toAscList + setLefts = Set.fromAscList . lefts . Set.toAscList + symmetricList = Map.toAscList $ AM.adjacencyMap $ AM.symmetricClosure m -- | Construct a bipartite 'AdjacencyMap' from "Algebra.Graph.AdjacencyMap" -- with part identifiers obtained from a given function, adding all neeeded --- edges to make the graph undirected and removing all edges inside one part. --- Complexity: /O(m log(n))/ +-- edges to make the graph undirected and removing all edges within the same +-- parts. +-- Complexity: /O(m * log(n))/. -- -- @ --- toBipartiteWith f Algebra.Graph.AdjacencyMap.'Algebra.Graph.AdjacencyMap.empty' == 'empty' --- toBipartiteWith Left x == 'empty' --- toBipartiteWith Right x == 'empty' --- toBipartiteWith f == 'toBiparitite' . Algebra.Graph.AdjacencyMap.'Algebra.Graph.AdjacencyMap.gmap' f --- toBipartiteWith id == 'toBipartite' +-- toBipartiteWith f 'Algebra.Graph.AdjacencyMap.empty' == 'empty' +-- toBipartiteWith Left x == 'vertices' ('vertexList' x) [] +-- toBipartiteWith Right x == 'vertices' [] ('vertexList' x) +-- toBipartiteWith f == 'toBipartite' . 'Algebra.Graph.AdjacencyMap.gmap' f +-- toBipartiteWith id == 'toBipartite' -- @ toBipartiteWith :: (Ord a, Ord b, Ord c) => (a -> Either b c) -> AM.AdjacencyMap a -> AdjacencyMap b c toBipartiteWith f = toBipartite . AM.gmap f --- | Construct an 'Algrebra.Graph.AdjacencyMap' from a bipartite --- 'AdjacencyMap'. --- Complexity: /O(m log(n))/. +-- | Construct an 'Algrebra.Graph.AdjacencyMap' from a bipartite 'AdjacencyMap'. +-- Complexity: /O(m * log(n))/. -- -- @ -- fromBipartite 'empty' == 'Algebra.Graph.AdjacencyMap.empty' --- fromBipartite ('leftVertex' 1) == 'Algebra.Graph.AdjacencyMap.vertex' (Left 1) --- fromBipartite ('edge' 1 2) == 'Algebra.Graph.AdjacencyMap.edges' [(Left 1, Right 2), (Right 2, Left 1)] +-- fromBipartite ('leftVertex' x) == 'Algebra.Graph.AdjacencyMap.vertex' (Left x) +-- fromBipartite ('edge' x y) == 'Algebra.Graph.AdjacencyMap.edges' [(Left x, Right y), (Right y, Left x)] +-- 'toBipartite' . fromBipartite == 'id' -- @ fromBipartite :: (Ord a, Ord b) => AdjacencyMap a b -> AM.AdjacencyMap (Either a b) fromBipartite (BAM lr rl) = AM.fromAdjacencySets $ - [ (Left u, Set.map Right vs) | (u, vs) <- Map.toAscList lr ] ++ - [ (Right v, Set.map Left us) | (v, us) <- Map.toAscList rl ] + [ (Left x, Set.mapMonotonic Right ys) | (x, ys) <- Map.toAscList lr ] ++ + [ (Right y, Set.mapMonotonic Left xs) | (y, xs) <- Map.toAscList rl ] --- | Construct a bipartite 'AdjacencyMap' from a 'Algebra.Graph.Graph' with --- given part identifiers, adding all needed edges to make the graph undirected --- and removing all edges inside one part. --- Complexity: /O(m log n)/. +-- | Construct an 'Algrebra.Graph.AdjacencyMap' from a bipartite 'AdjacencyMap' +-- given a way to inject vertices from different parts into the resulting vertex +-- type. +-- Complexity: /O(m * log(n))/. -- -- @ --- fromGraph (Algebra.Graph.'Algebra.Graph.empty') == 'empty' --- fromGraph (Algebra.Graph.'Algebra.Graph.edge' (Left 1) (Right 1)) == 'edge' 1 1 --- fromGraph (Algebra.Graph.'Algebra.Graph.edge' (Left 1) (Right "a")) == 'edge' 1 "a" --- fromGraph (Algebra.Graph.'Algebra.Graph.edge' (Left 1) (Left 2)) == 'empty' +-- fromBipartiteWith Left Right == 'fromBipartite' +-- fromBipartiteWith id id ('vertices' xs ys) == 'Algebra.Graph.AdjacencyMap.vertices' (xs ++ ys) +-- fromBipartiteWith id id . 'edges' == 'Algebra.Graph.AdjacencyMap.symmetricClosure' . 'Algebra.Graph.AdjacencyMap.edges' -- @ -fromGraph :: (Ord a, Ord b) => G.Graph (Either a b) -> AdjacencyMap a b -fromGraph = toBipartite . (G.foldg AM.empty AM.vertex AM.overlay AM.connect) - -internalEdgeList :: Map.Map a (Set.Set b) -> [(a, b)] -internalEdgeList lr = [ (u, v) | (u, vs) <- Map.toAscList lr, v <- Set.toAscList vs ] +fromBipartiteWith :: Ord c => (a -> c) -> (b -> c) -> AdjacencyMap a b -> AM.AdjacencyMap c +fromBipartiteWith f g (BAM lr rl) = AM.fromAdjacencySets $ + [ (f x, Set.map g ys) | (x, ys) <- Map.toAscList lr ] ++ + [ (g y, Set.map f xs) | (y, xs) <- Map.toAscList rl ] -- | Check if a graph is empty. -- Complecity: /O(1)/ time. @@ -484,58 +491,51 @@ internalEdgeList lr = [ (u, v) | (u, vs) <- Map.toAscList lr, v <- Set.toAscList isEmpty :: AdjacencyMap a b -> Bool isEmpty (BAM lr rl) = Map.null lr && Map.null rl --- | Check if a graph contains a given edge. --- Complexity: /O(log(n))/ time. --- --- @ --- hasEdge x y 'empty' == False --- hasEdge x y ('edge' x y) == True --- hasEdge 2 3 ('edge' 1 2) == False --- hasEdge x y ('overlay' z ('edge' x y)) == True --- hasEdge 1 2 ('fromGraph' ('Algebra.Graph.edge' (Left 1) (Left 2))) == False --- @ -hasEdge :: (Ord a, Ord b) => a -> b -> AdjacencyMap a b -> Bool -hasEdge u v (BAM m _) = (Set.member v <$> (u `Map.lookup` m)) == Just True - -- | Check if a graph contains a given vertex in the left part. -- Complexity: /O(log(n))/ time. -- -- @ -- hasLeftVertex x 'empty' == False --- hasLeftVertex x ('leftVertex' x) == True --- hasLeftVertex x ('rightVertex' x) == False --- hasLeftVertex 1 ('leftVertex' 2) == False +-- hasLeftVertex x ('leftVertex' y) == (x == y) +-- hasLeftVertex x ('rightVertex' y) == False -- @ hasLeftVertex :: Ord a => a -> AdjacencyMap a b -> Bool -hasLeftVertex x (BAM lr _) = x `Map.member` lr +hasLeftVertex x (BAM lr _) = Map.member x lr -- | Check if a graph contains a given vertex in the right part. -- Complexity: /O(log(n))/ time. -- -- @ -- hasRightVertex x 'empty' == False --- hasRightVertex x ('rightVertex' x) == True --- hasRightVertex x ('leftVertex' x) == False --- hasRightVertex 1 ('rightVertex' 2) == False +-- hasRightVertex x ('leftVertex' y) == False +-- hasRightVertex x ('rightVertex' y) == (x == y) -- @ hasRightVertex :: Ord b => b -> AdjacencyMap a b -> Bool -hasRightVertex y (BAM _ rl) = y `Map.member` rl +hasRightVertex y (BAM _ rl) = Map.member y rl -- | Check if a graph contains a given vertex. -- Complexity: /O(log(n))/ time. -- -- @ --- hasVertex x 'empty' == False --- hasVertex (Right x) ('rightVertex' x) == True --- hasVertex (Right x) ('leftVertex' x) == False --- hasVertex (Left 1) ('leftVertex' 2) == False --- hasVertex . Left == 'hasLeftVertex' --- hasVertex . Right == 'hasRightVertex' +-- hasVertex . Left == 'hasLeftVertex' +-- hasVertex . Right == 'hasRightVertex' -- @ hasVertex :: (Ord a, Ord b) => Either a b -> AdjacencyMap a b -> Bool hasVertex (Left x) = hasLeftVertex x hasVertex (Right y) = hasRightVertex y +-- | 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 == 'elem' (x,y) . 'edgeList' +-- @ +hasEdge :: (Ord a, Ord b) => a -> b -> AdjacencyMap a b -> Bool +hasEdge x y (BAM m _) = (Set.member y <$> Map.lookup x m) == Just True + -- | The number of vertices in the left part in a graph. -- Complexity: /O(1)/ time. -- @@ -543,7 +543,8 @@ hasVertex (Right y) = hasRightVertex y -- leftVertexCount 'empty' == 0 -- leftVertexCount ('leftVertex' x) == 1 -- leftVertexCount ('rightVertex' x) == 0 --- leftVertexCount . 'edges' == 'length' . 'Data.List.nub' . 'map' 'fst' +-- leftVertexCount ('edge' x y) == 1 +-- leftVertexCount . 'edges' == 'length' . 'nub' . 'map' 'fst' -- @ leftVertexCount :: AdjacencyMap a b -> Int leftVertexCount = Map.size . leftAdjacencyMap @@ -553,9 +554,10 @@ leftVertexCount = Map.size . leftAdjacencyMap -- -- @ -- rightVertexCount 'empty' == 0 --- rightVertexCount ('rightVertex' x) == 1 -- rightVertexCount ('leftVertex' x) == 0 --- rightVertexCount . 'edges' == 'length' . 'Data.List.nub' . 'map' 'snd' +-- rightVertexCount ('rightVertex' x) == 1 +-- rightVertexCount ('edge' x y) == 1 +-- rightVertexCount . 'edges' == 'length' . 'nub' . 'map' 'snd' -- @ rightVertexCount :: AdjacencyMap a b -> Int rightVertexCount = Map.size . rightAdjacencyMap @@ -564,10 +566,10 @@ rightVertexCount = Map.size . rightAdjacencyMap -- Complexity: /O(1)/ time. -- -- @ --- vertexCount 'empty' == 0 --- vertexCount ('leftVertex' x) == 1 --- vertexCount ('rightVertex' x) == 1 --- vertexCount x == 'leftVertexCount' x + 'rightVertexCount' x +-- vertexCount 'empty' == 0 +-- vertexCount ('vertex' x) == 1 +-- vertexCount ('edge' x y) == 2 +-- vertexCount x == 'leftVertexCount' x + 'rightVertexCount' x -- @ vertexCount :: AdjacencyMap a b -> Int vertexCount g = leftVertexCount g + rightVertexCount g @@ -579,7 +581,7 @@ vertexCount g = leftVertexCount g + rightVertexCount g -- edgeCount 'empty' == 0 -- edgeCount ('vertex' x) == 0 -- edgeCount ('edge' x y) == 1 --- edgeCount . 'edges' == 'length' . 'Data.List.nub' +-- edgeCount . 'edges' == 'length' . 'nub' -- @ edgeCount :: AdjacencyMap a b -> Int edgeCount = Map.foldr ((+) . Set.size) 0 . leftAdjacencyMap @@ -588,10 +590,10 @@ edgeCount = Map.foldr ((+) . Set.size) 0 . leftAdjacencyMap -- Complexity: /O(l)/ time and memory. -- -- @ --- leftVertexList 'empty' == [] --- leftVertexList ('leftVertex' x) == [x] --- leftVertexList ('rightVertex' x) == [] --- leftVertexList . ('flip' 'vertices') [] == 'Data.List.nub' . 'Data.List.sort' +-- leftVertexList 'empty' == [] +-- leftVertexList ('leftVertex' x) == [x] +-- leftVertexList ('rightVertex' x) == [] +-- leftVertexList . 'flip' 'vertices' [] == 'nub' . 'sort' -- @ leftVertexList :: AdjacencyMap a b -> [a] leftVertexList = Map.keys . leftAdjacencyMap @@ -603,7 +605,7 @@ leftVertexList = Map.keys . leftAdjacencyMap -- rightVertexList 'empty' == [] -- rightVertexList ('leftVertex' x) == [] -- rightVertexList ('rightVertex' x) == [x] --- rightVertexList . 'vertices' [] == 'Data.List.nub' . 'Data.List.sort' +-- rightVertexList . 'vertices' [] == 'nub' . 'sort' -- @ rightVertexList :: AdjacencyMap a b -> [b] rightVertexList = Map.keys . rightAdjacencyMap @@ -614,10 +616,11 @@ rightVertexList = Map.keys . rightAdjacencyMap -- @ -- vertexList 'empty' == [] -- vertexList ('vertex' x) == [x] --- vertexList (vertices ('Data.Either.lefts' vs) ('Data.Either.rights' vs)) == 'Data.List.nub' ('Data.List.sort' vs) +-- vertexList ('edge' x y) == [Left x, Right y] +-- vertexList ('vertices' ('lefts' xs) ('rights' xs)) == 'nub' ('sort' xs) -- @ vertexList :: AdjacencyMap a b -> [Either a b] -vertexList g = (map Left $ leftVertexList g) ++ (map Right $ rightVertexList g) +vertexList g = map Left (leftVertexList g) ++ map Right (rightVertexList g) -- | The sorted list of edges of a graph. -- Complexity: /O(n + m)/ time and /O(m)/ memory. @@ -625,45 +628,46 @@ vertexList g = (map Left $ leftVertexList g) ++ (map Right $ rightVertexList g) -- @ -- edgeList 'empty' == [] -- edgeList ('vertex' x) == [] --- edgeList ('edge' x y) == [(x, y)] --- edgeList . 'edges' == 'Data.List.nub' . 'Data.List.sort' +-- edgeList ('edge' x y) == [(x,y)] +-- edgeList . 'edges' == 'nub' . 'sort' -- @ edgeList :: AdjacencyMap a b -> [(a, b)] -edgeList (BAM lr _) = [ (u, v) | (u, vs) <- Map.toAscList lr, v <- Set.toAscList vs ] +edgeList (BAM lr _) = [ (x, y) | (x, ys) <- Map.toAscList lr, y <- Set.toAscList ys ] -- | The set of vertices of the left part of a given graph. -- Complexity: /O(l)/ time and memory. -- -- @ --- leftVertexSet 'empty' == Set.'Data.Set.empty' --- leftVertexSet . 'leftVertex' == Set.'Data.Set.singleton' --- leftVertexSet . 'rightVertex' == 'const' Set.'Data.Set.empty' --- leftVertexSet . ('flip' 'vertices') [] == Set.'Data.Set.fromList' +-- leftVertexSet 'empty' == Set.'Set.empty' +-- leftVertexSet . 'leftVertex' == Set.'Set.singleton' +-- leftVertexSet . 'rightVertex' == 'const' Set.'Set.empty' +-- leftVertexSet . 'flip' 'vertices' [] == Set.'Set.fromList' -- @ -leftVertexSet :: AdjacencyMap a b -> Set.Set a +leftVertexSet :: AdjacencyMap a b -> Set a leftVertexSet = Map.keysSet . leftAdjacencyMap -- | The set of vertices of the right part of a given graph. -- Complexity: /O(r)/ time and memory. -- -- @ --- rightVertexSet 'empty' == Set.'Data.Set.empty' --- rightVertexSet . 'leftVertex' == 'const' Set.'Data.Set.empty' --- rightVertexSet . 'rightVertex' == Set.'Data.Set.singleton' --- rightVertexSet . 'vertices' [] == Set.'Data.Set.fromList' +-- rightVertexSet 'empty' == Set.'Set.empty' +-- rightVertexSet . 'leftVertex' == 'const' Set.'Set.empty' +-- rightVertexSet . 'rightVertex' == Set.'Set.singleton' +-- rightVertexSet . 'vertices' [] == Set.'Set.fromList' -- @ -rightVertexSet :: AdjacencyMap a b -> Set.Set b +rightVertexSet :: AdjacencyMap a b -> Set b rightVertexSet = Map.keysSet . rightAdjacencyMap -- | The set of vertices of a given graph. -- Complexity: /O(n)/ time and memory. -- -- @ --- vertexSet 'empty' == Set.'Data.Set.empty' --- vertexSet . 'vertex' == Set.'Data.Set.singleton' --- vertexSet ('vertices' ('Data.Either.lefts' vs) ('Data.Either.rights' vs)) == Set.'Data.Set.fromList' vs +-- vertexSet 'empty' == Set.'Set.empty' +-- vertexSet . 'vertex' == Set.'Set.singleton' +-- vertexSet ('edge' x y) == Set.'Set.fromList' [Left x, Right y] +-- vertexSet ('vertices' ('lefts' xs) ('rights' xs)) == Set.'Set.fromList' xs -- @ -vertexSet :: (Ord a, Ord b) => AdjacencyMap a b -> Set.Set (Either a b) +vertexSet :: (Ord a, Ord b) => AdjacencyMap a b -> Set (Either a b) vertexSet = Set.fromAscList . vertexList -- | The set of edges of a given graph. @@ -672,27 +676,27 @@ vertexSet = Set.fromAscList . vertexList -- @ -- edgeSet 'empty' == Set.'Data.Set.empty' -- edgeSet ('vertex' x) == Set.'Data.Set.empty' --- edgeSet ('edge' x y) == Set.'Data.Set.singleton' (x, y) +-- edgeSet ('edge' x y) == Set.'Data.Set.singleton' (x,y) -- edgeSet . 'edges' == Set.'Data.Set.fromList' -- @ -edgeSet :: (Ord a, Ord b) => AdjacencyMap a b -> Set.Set (a, b) +edgeSet :: (Ord a, Ord b) => AdjacencyMap a b -> Set (a, b) edgeSet = Set.fromAscList . edgeList -- | The /circuit/ on a list of vertices. -- Complexity: /O(n * log(n))/ time and /O(n)/ memory. -- -- @ --- circuit [] == 'empty' --- circuit [(x, y)] == 'edge' x y --- circuit [(x, y), (z, w)] == 'biclique' [x, z] [y, w] --- circuit [(1, 2), (3, 4), (5, 6)] == swap 1 * (2 + 6) + swap 3 * (2 + 4) + swap 5 * (6 + 2) --- circuit . 'reverse' == 'swap' . circuit . 'map' 'Data.Tuple.swap' +-- circuit [] == 'empty' +-- circuit [(x,y)] == 'edge' x y +-- circuit [(1,2), (3,4)] == 'biclique' [1,3] [2,4] +-- circuit [(1,2), (3,4), (5,6)] == 'edges' [(1,2), (3,2), (3,4), (5,4), (5,6), (1,6)] +-- circuit . 'reverse' == 'swap' . circuit . 'map' Data.Tuple.'Data.Tuple.swap' -- @ circuit :: (Ord a, Ord b) => [(a, b)] -> AdjacencyMap a b circuit [] = empty circuit xs = edges $ xs ++ zip (drop 1 $ cycle as) bs - where - (as, bs) = unzip xs + where + (as, bs) = unzip xs -- | The /biclique/ on two lists of vertices. -- Complexity: /O(n * log(n) + m)/ time and /O(n + m)/ memory. @@ -704,30 +708,25 @@ circuit xs = edges $ xs ++ zip (drop 1 $ cycle as) bs -- biclique xs ys == 'connect' ('vertices' xs []) ('vertices' [] ys) -- @ biclique :: (Ord a, Ord b) => [a] -> [b] -> AdjacencyMap a b -biclique xs ys = let sxs = Set.fromList xs - sys = Set.fromList ys - in BAM (Map.fromSet (const sys) sxs) - (Map.fromSet (const sxs) sys) +biclique xs ys = BAM (Map.fromSet (const sys) sxs) (Map.fromSet (const sxs) sys) + where + sxs = Set.fromList xs + sys = Set.fromList ys -data Part = LeftPart | RightPart - deriving (Show, Eq) +data Part = LeftPart | RightPart deriving (Show, Eq) otherPart :: Part -> Part otherPart LeftPart = RightPart otherPart RightPart = LeftPart -type PartMap a = Map.Map a Part -type PartMonad a = MaybeT (State (PartMap a)) [a] - --- | An odd cycle. For example, @[1, 2, 3]@ represents the cycle 1 → 2 → 3 → 1. +-- | An cycle of odd length. For example, @[1, 2, 3]@ represents the cycle +-- @1 -> 2 -> 3 -> 1@. type OddCycle a = [a] -- TODO: Make this representation type-safe -neighbours :: Ord a => a -> AM.AdjacencyMap a -> [a] -neighbours v = Set.toAscList . AM.postSet v - --- | Test bipartiteness of given graph. In case of success, return an +-- | Test the bipartiteness of given graph. In case of success, return an -- 'AdjacencyMap' with the same set of edges and each vertex marked with the --- part it belongs to. In case of failure, return any odd cycle in the graph. +-- part it belongs to. In case of failure, return any cycle of odd length in the +-- graph. -- -- The returned partition is lexicographically minimal. That is, consider the -- string of part identifiers for each vertex in ascending order. Then, @@ -735,96 +734,103 @@ neighbours v = Set.toAscList . AM.postSet v -- of the right part, this string is lexicographically minimal of all such -- strings for all partitions. -- --- The returned odd cycle is optimal in the following way: there exists a path --- that is either empty or ends in a vertex adjacent to the first vertex in the +-- The returned cycle is optimal in the following way: there exists a path that +-- is either empty or ends in a vertex adjacent to the first vertex in the -- cycle, such that all vertices in @path ++ cycle@ are distinct and --- @path ++ cycle@ is lexicographically minimal among all such pairs of odd --- cycles and paths. +-- @path ++ cycle@ is lexicographically minimal among all such pairs of paths +-- and cycles. -- --- /Note/: as 'AdjacencyMap' only represents __undirected__ bipartite graphs, --- all edges in the input graph are assumed to be bidirected and all edges in --- the output 'AdjacencyMap' are bidirected. +-- /Note/: since 'AdjacencyMap' represents __undirected__ bipartite graphs, all +-- edges in the input graph are treated as undirected. See the examples and the +-- correctness property for a clarification. -- -- It is advised to use 'leftVertexList' and 'rightVertexList' to obtain the -- partition of the vertices and 'hasLeftVertex' and 'hasRightVertex' to check -- whether a vertex belongs to a part. -- --- Complexity: /O((n + m) log(n))/ time and /O(n + m)/ memory. +-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. -- -- @ -- detectParts 'Algebra.Graph.AdjacencyMap.empty' == Right 'empty' -- detectParts ('Algebra.Graph.AdjacencyMap.vertex' x) == Right ('leftVertex' x) --- detectParts (1 * (2 + 3)) == Right ('edges' [(1, 2), (1, 3)]) --- detectParts ((1 + 3) * (2 + 4) + 6 * 5) == Right ('swap' (1 + 3) * (2 + 4) + 'swap' 5 * 6) --- detectParts ('Algebra.Graph.AdjacencyMap.edge' 1 1) == Left [1] +-- detectParts ('Algebra.Graph.AdjacencyMap.edge' x x) == Left [x] -- detectParts ('Algebra.Graph.AdjacencyMap.edge' 1 2) == Right ('edge' 1 2) +-- detectParts (1 * (2 + 3)) == Right ('edges' [(1,2), (1,3)]) -- detectParts (1 * 2 * 3) == Left [1, 2, 3] +-- detectParts ((1 + 3) * (2 + 4) + 6 * 5) == Right ('swap' (1 + 3) * (2 + 4) + 'swap' 5 * 6) -- detectParts ((1 * 3 * 4) + 2 * (1 + 2)) == Left [2] -- detectParts ('Algebra.Graph.AdjacencyMap.clique' [1..10]) == Left [1, 2, 3] +-- detectParts ('Algebra.Graph.AdjacencyMap.circuit' [1..10]) == Right ('circuit' [(x, x + 1) | x <- [1,3,5,7,9]]) -- detectParts ('Algebra.Graph.AdjacencyMap.circuit' [1..11]) == Left [1..11] --- detectParts ('Algebra.Graph.AdjacencyMap.circuit' [1..10]) == Right ('circuit' [(2 * x - 1, 2 * x) | x <- [1..5]]) --- detectParts ('Algebra.Graph.AdjacencyMap.biclique' [] xs) == Right (vertices xs []) --- detectParts ('Algebra.Graph.AdjacencyMap.biclique' (map Left (x:xs)) (map Right ys)) == Right ('biclique' (map Left (x:xs)) (map Right ys)) --- 'Data.Either.isRight' (detectParts ('Algebra.Graph.AdjacencyMap.star' x ys)) == not (elem x ys) --- 'Data.Either.isRight' (detectParts ('fromBipartite' ('toBipartite' x))) == True --- @ -detectParts :: forall a. Ord a => AM.AdjacencyMap a -> Either (OddCycle a) (AdjacencyMap a a) -detectParts x = case runState (runMaybeT $ dfs) Map.empty of - (Nothing, m) -> Right $ toBipartiteWith (toEither m) g - (Just c, _) -> Left $ oddCycle c - where - g :: AM.AdjacencyMap a - g = AM.symmetricClosure x - - dfs :: PartMonad a - dfs = asum [ processVertex v | v <- AM.vertexList g ] - - {-# INLINE onEdge #-} - onEdge :: Part -> a -> PartMonad a - onEdge p v = do m <- get - case v `Map.lookup` m of - Nothing -> inVertex p v - Just q -> do guard (p /= q) - return [v] - - inVertex :: Part -> a -> PartMonad a - inVertex p v = ((:) v) <$> do modify (Map.insert v p) - let q = otherPart p - asum [ onEdge q u | u <- neighbours v g ] - - processVertex :: a -> PartMonad a - processVertex v = do m <- get - guard (v `Map.notMember` m) - inVertex LeftPart v - - toEither :: PartMap a -> a -> Either a a - toEither m v = case fromJust (v `Map.lookup` m) of - LeftPart -> Left v - RightPart -> Right v - - oddCycle :: [a] -> [a] - oddCycle c = init $ dropUntil (last c) c - - dropUntil :: a -> [a] -> [a] - dropUntil _ [] = [] - dropUntil x ys@(y:yt) | y == x = ys - | otherwise = dropUntil x yt - +-- detectParts ('Algebra.Graph.AdjacencyMap.biclique' [] xs) == Right ('vertices' xs []) +-- detectParts ('Algebra.Graph.AdjacencyMap.biclique' ('map' Left (x:xs)) ('map' Right ys)) == Right ('biclique' ('map' Left (x:xs)) ('map' Right ys)) +-- 'isRight' (detectParts ('Algebra.Graph.AdjacencyMap.star' x ys)) == 'notElem' x ys +-- 'isRight' (detectParts ('fromBipartite' ('toBipartite' x))) == True +-- @ +-- +-- The correctness of 'detectParts' can be expressed by the following property: +-- +-- @ +-- let undirected = 'Algebra.Graph.AdjacencyMap.symmetricClosure' input in +-- case detectParts input of +-- Left cycle -> 'mod' (length cycle) 2 == 1 && 'Algebra.Graph.AdjacencyMap.isSubgraphOf' ('Algebra.Graph.AdjacencyMap.circuit' cycle) undirected +-- Right result -> 'Algebra.Graph.AdjacencyMap.gmap' 'Data.Either.Extra.fromEither' ('fromBipartite' result) == undirected +-- @ +detectParts :: Ord a => AM.AdjacencyMap a -> Either (OddCycle a) (AdjacencyMap a a) +detectParts x = case runState (runMaybeT dfs) Map.empty of + (Nothing, m) -> Right $ toBipartiteWith (toEither m) g + (Just c, _) -> Left $ oddCycle c + where + -- g :: AM.AdjacencyMap a + g = AM.symmetricClosure x + + -- type PartMap a = Map a Part + -- type PartMonad a = MaybeT (State (PartMap a)) [a] + -- dfs :: PartMonad a + dfs = asum [ processVertex v | v <- AM.vertexList g ] + + -- processVertex :: a -> PartMonad a + processVertex v = do m <- get + guard (Map.notMember v m) + inVertex LeftPart v + + -- inVertex :: Part -> a -> PartMonad a + inVertex p v = ((:) v) <$> do modify (Map.insert v p) + let q = otherPart p + asum [ onEdge q u | u <- Set.toAscList (AM.postSet v g) ] + + {-# INLINE onEdge #-} + -- onEdge :: Part -> a -> PartMonad a + onEdge p v = do m <- get + case Map.lookup v m of + Nothing -> inVertex p v + Just q -> do guard (p /= q) + return [v] + + -- toEither :: PartMap a -> a -> Either a a + toEither m v = case fromJust (Map.lookup v m) of + LeftPart -> Left v + RightPart -> Right v + + -- oddCycle :: [a] -> [a] + oddCycle c = init $ dropWhile (/= last c) c -- | Check that the internal graph representation is consistent, i.e. that all --- edges that are present in the 'leftAdjacencyMap' are present in the --- 'rightAdjacencyMap' map. +-- edges that are present in the 'leftAdjacencyMap' are also present in the +-- 'rightAdjacencyMap' map. It should be impossible to create an inconsistent +-- adjacency map, and we use this function in testing. -- -- @ -- consistent 'empty' == True -- consistent ('vertex' x) == True -- consistent ('edge' x y) == True -- consistent ('edges' x) == True --- consistent ('fromGraph' x) == True -- consistent ('toBipartite' x) == True -- consistent ('swap' x) == True -- consistent ('circuit' x) == True -- consistent ('biclique' x y) == True -- @ consistent :: (Ord a, Ord b) => AdjacencyMap a b -> Bool -consistent (BAM lr rl) = internalEdgeList lr == sort (map Data.Tuple.swap $ internalEdgeList rl) +consistent (BAM lr rl) = edgeList lr == sort (map Data.Tuple.swap $ edgeList rl) + where + edgeList lr = [ (u, v) | (u, vs) <- Map.toAscList lr, v <- Set.toAscList vs ] diff --git a/src/Algebra/Graph/Internal.hs b/src/Algebra/Graph/Internal.hs index 4e10fd981..ca846d8c7 100644 --- a/src/Algebra/Graph/Internal.hs +++ b/src/Algebra/Graph/Internal.hs @@ -2,7 +2,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Internal --- Copyright : (c) Andrey Mokhov 2016-2019 +-- Copyright : (c) Andrey Mokhov 2016-2020 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental @@ -24,9 +24,11 @@ module Algebra.Graph.Internal ( maybeF, -- * Utilities - setProduct, setProductWith, forEach, forEachInt + setProduct, setProductWith, forEach, forEachInt, coerce00, coerce10, + coerce20, coerce01, coerce11, coerce21 ) where +import Data.Coerce import Data.Foldable import Data.Semigroup import Data.IntSet (IntSet) @@ -138,3 +140,32 @@ forEach s f = Set.foldr (\a u -> f a *> u) (pure ()) s -- | Perform an applicative action for each member of an IntSet. forEachInt :: Applicative f => IntSet -> (Int -> f a) -> f () forEachInt s f = IntSet.foldr (\a u -> f a *> u) (pure ()) s + +-- TODO: Get rid of this boilerplate. + +-- | Help GHC with type inference when direct use of 'coerce' does not compile. +coerce00 :: Coercible f g => f x -> g x +coerce00 = coerce + +-- | Help GHC with type inference when direct use of 'coerce' does not compile. +coerce10 :: (Coercible a b, Coercible f g) => (a -> f x) -> (b -> g x) +coerce10 = coerce + +-- | Help GHC with type inference when direct use of 'coerce' does not compile. +coerce20 :: (Coercible a b, Coercible c d, Coercible f g) + => (a -> c -> f x) -> (b -> d -> g x) +coerce20 = coerce + +-- | Help GHC with type inference when direct use of 'coerce' does not compile. +coerce01 :: (Coercible a b, Coercible f g) => (f x -> a) -> (g x -> b) +coerce01 = coerce + +-- | Help GHC with type inference when direct use of 'coerce' does not compile. +coerce11 :: (Coercible a b, Coercible c d, Coercible f g) + => (a -> f x -> c) -> (b -> g x -> d) +coerce11 = coerce + +-- | Help GHC with type inference when direct use of 'coerce' does not compile. +coerce21 :: (Coercible a b, Coercible c d, Coercible p q, Coercible f g) + => (a -> c -> f x -> p) -> (b -> d -> g x -> q) +coerce21 = coerce diff --git a/src/Algebra/Graph/Labelled.hs b/src/Algebra/Graph/Labelled.hs index 55926ace2..6707ed793 100644 --- a/src/Algebra/Graph/Labelled.hs +++ b/src/Algebra/Graph/Labelled.hs @@ -156,7 +156,7 @@ empty = Empty -- -- @ -- 'isEmpty' (vertex x) == False --- 'hasVertex' x (vertex x) == True +-- 'hasVertex' x (vertex y) == (x == y) -- 'Algebra.Graph.ToGraph.vertexCount' (vertex x) == 1 -- 'Algebra.Graph.ToGraph.edgeCount' (vertex x) == 0 -- @ @@ -289,7 +289,7 @@ edges = overlays . map (\(e, x, y) -> edge e x y) overlays :: Monoid e => [Graph e a] -> Graph e a overlays = foldr overlay empty --- | Check if a graph is empty. A convenient alias for 'null'. +-- | Check if a graph is empty. -- Complexity: /O(s)/ time. -- -- @ @@ -322,8 +322,7 @@ size = foldg 1 (const 1) (const (+)) -- -- @ -- hasVertex x 'empty' == False --- hasVertex x ('vertex' x) == True --- hasVertex 1 ('vertex' 2) == False +-- hasVertex x ('vertex' y) == (x == y) -- hasVertex x . 'removeVertex' x == 'const' False -- @ hasVertex :: Eq a => a -> Graph e a -> Bool diff --git a/src/Algebra/Graph/Labelled/AdjacencyMap.hs b/src/Algebra/Graph/Labelled/AdjacencyMap.hs index f1abc32e2..233e963c9 100644 --- a/src/Algebra/Graph/Labelled/AdjacencyMap.hs +++ b/src/Algebra/Graph/Labelled/AdjacencyMap.hs @@ -127,7 +127,7 @@ empty = AM Map.empty -- -- @ -- 'isEmpty' (vertex x) == False --- 'hasVertex' x (vertex x) == True +-- 'hasVertex' x (vertex y) == (x == y) -- 'vertexCount' (vertex x) == 1 -- 'edgeCount' (vertex x) == 0 -- @ @@ -323,8 +323,7 @@ isEmpty = Map.null . adjacencyMap -- -- @ -- hasVertex x 'empty' == False --- hasVertex x ('vertex' x) == True --- hasVertex 1 ('vertex' 2) == False +-- hasVertex x ('vertex' y) == (x == y) -- hasVertex x . 'removeVertex' x == 'const' False -- @ hasVertex :: Ord a => a -> AdjacencyMap e a -> Bool diff --git a/src/Algebra/Graph/NonEmpty.hs b/src/Algebra/Graph/NonEmpty.hs index a98a37b8d..665aba4fd 100644 --- a/src/Algebra/Graph/NonEmpty.hs +++ b/src/Algebra/Graph/NonEmpty.hs @@ -240,7 +240,7 @@ toNonEmpty = G.foldg Nothing (Just . Vertex) (go Overlay) (go Connect) -- Complexity: /O(1)/ time, memory and size. -- -- @ --- 'hasVertex' x (vertex x) == True +-- 'hasVertex' x (vertex y) == (x == y) -- 'vertexCount' (vertex x) == 1 -- 'edgeCount' (vertex x) == 0 -- 'size' (vertex x) == 1 @@ -335,6 +335,7 @@ vertices1 = overlays1 . fmap vertex -- -- @ -- edges1 [(x,y)] == 'edge' x y +-- edges1 == 'overlays1' . 'fmap' ('uncurry' 'edge') -- 'edgeCount' . edges1 == 'Data.List.NonEmpty.length' . 'Data.List.NonEmpty.nub' -- @ edges1 :: NonEmpty (a, a) -> Graph a @@ -442,8 +443,7 @@ size = foldg1 (const 1) (+) (+) -- Complexity: /O(s)/ time. -- -- @ --- hasVertex x ('vertex' x) == True --- hasVertex 1 ('vertex' 2) == False +-- hasVertex x ('vertex' y) == (x == y) -- @ hasVertex :: Eq a => a -> Graph a -> Bool hasVertex v = foldg1 (==v) (||) (||) diff --git a/src/Algebra/Graph/NonEmpty/AdjacencyMap.hs b/src/Algebra/Graph/NonEmpty/AdjacencyMap.hs index 9d6144813..185570980 100644 --- a/src/Algebra/Graph/NonEmpty/AdjacencyMap.hs +++ b/src/Algebra/Graph/NonEmpty/AdjacencyMap.hs @@ -211,9 +211,9 @@ fromNonEmpty = am -- Complexity: /O(1)/ time and memory. -- -- @ --- 'AdjacencyMap.hasVertex' x (vertex x) == True --- 'AdjacencyMap.vertexCount' (vertex x) == 1 --- 'AdjacencyMap.edgeCount' (vertex x) == 0 +-- 'hasVertex' x (vertex y) == (x == y) +-- 'vertexCount' (vertex x) == 1 +-- 'edgeCount' (vertex x) == 0 -- @ vertex :: a -> AdjacencyMap a vertex = coerce AM.vertex @@ -289,6 +289,7 @@ vertices1 = coerce AM.vertices . toList -- -- @ -- edges1 [(x,y)] == 'edge' x y +-- edges1 == 'overlays1' . 'fmap' ('uncurry' 'edge') -- 'edgeCount' . edges1 == 'Data.List.NonEmpty.length' . 'Data.List.NonEmpty.nub' -- @ edges1 :: Ord a => NonEmpty (a, a) -> AdjacencyMap a @@ -333,8 +334,7 @@ isSubgraphOf = coerce AM.isSubgraphOf -- Complexity: /O(log(n))/ time. -- -- @ --- hasVertex x ('vertex' x) == True --- hasVertex 1 ('vertex' 2) == False +-- hasVertex x ('vertex' y) == (x == y) -- @ hasVertex :: Ord a => a -> AdjacencyMap a -> Bool hasVertex = coerce AM.hasVertex diff --git a/src/Algebra/Graph/Relation.hs b/src/Algebra/Graph/Relation.hs index 0c17f3a97..3a6395e14 100644 --- a/src/Algebra/Graph/Relation.hs +++ b/src/Algebra/Graph/Relation.hs @@ -207,7 +207,7 @@ empty = Relation Set.empty Set.empty -- -- @ -- 'isEmpty' (vertex x) == False --- 'hasVertex' x (vertex x) == True +-- 'hasVertex' x (vertex y) == (x == y) -- 'vertexCount' (vertex x) == 1 -- 'edgeCount' (vertex x) == 0 -- @ @@ -286,6 +286,7 @@ vertices xs = Relation (Set.fromList xs) Set.empty -- @ -- edges [] == 'empty' -- edges [(x,y)] == 'edge' x y +-- edges == 'overlays' . 'map' ('uncurry' 'edge') -- 'edgeCount' . edges == 'length' . 'Data.List.nub' -- @ edges :: Ord a => [(a, a)] -> Relation a @@ -351,8 +352,7 @@ isEmpty = null . domain -- -- @ -- hasVertex x 'empty' == False --- hasVertex x ('vertex' x) == True --- hasVertex 1 ('vertex' 2) == False +-- hasVertex x ('vertex' y) == (x == y) -- hasVertex x . 'removeVertex' x == 'const' False -- @ hasVertex :: Ord a => a -> Relation a -> Bool diff --git a/src/Algebra/Graph/Relation/Symmetric.hs b/src/Algebra/Graph/Relation/Symmetric.hs index 54c659a42..c724fd196 100644 --- a/src/Algebra/Graph/Relation/Symmetric.hs +++ b/src/Algebra/Graph/Relation/Symmetric.hs @@ -159,7 +159,7 @@ empty = coerce R.empty -- -- @ -- 'isEmpty' (vertex x) == False --- 'hasVertex' x (vertex x) == True +-- 'hasVertex' x (vertex y) == (x == y) -- 'vertexCount' (vertex x) == 1 -- 'edgeCount' (vertex x) == 0 -- @ @@ -307,8 +307,7 @@ isEmpty = coerce R.isEmpty -- -- @ -- hasVertex x 'empty' == False --- hasVertex x ('vertex' x) == True --- hasVertex 1 ('vertex' 2) == False +-- hasVertex x ('vertex' y) == (x == y) -- hasVertex x . 'removeVertex' x == 'const' False -- @ hasVertex :: Ord a => a -> Relation a -> Bool @@ -350,7 +349,7 @@ vertexCount = coerce R.vertexCount -- edgeCount == 'length' . 'edgeList' -- @ edgeCount :: Ord a => Relation a -> Int -edgeCount = length . edgeList +edgeCount = Set.size . edgeSet -- | The sorted list of vertices of a given graph. -- Complexity: /O(n)/ time and memory. diff --git a/src/Algebra/Graph/Undirected.hs b/src/Algebra/Graph/Undirected.hs index 49cd15106..f8753e208 100644 --- a/src/Algebra/Graph/Undirected.hs +++ b/src/Algebra/Graph/Undirected.hs @@ -1,9 +1,8 @@ {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Undirected --- Copyright : (c) Andrey Mokhov 2016-2019 +-- Copyright : (c) Andrey Mokhov 2016-2020 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental @@ -12,14 +11,17 @@ -- in Haskell. See for the -- motivation behind the library, the underlying theory, and implementation details. -- --- This module defines and abstraction over the core data type 'Graph' and associated algorithms. --- Undirected graphs satisfy all laws of the --- 'Algebra.Graph.Class.Undirected' type class, including the commutativity --- of 'connect'. --- 'Graph' is an instance of type classes defined in --- modules "Algebra.Graph.Class" and "Algebra.Graph.HigherKinded.Class", which --- can be used for polymorphic graph construction and manipulation. +-- This module defines an undirected version of algebraic graphs. Undirected +-- graphs satisfy all laws of the 'Algebra.Graph.Class.Undirected' type class, +-- including the commutativity of 'connect'. -- +-- To avoid name clashes with "Algebra.Graph", this module can be imported +-- qualified: +-- +-- @ +-- import qualified Algebra.Graph.Undirected as Undirected +-- @ + ----------------------------------------------------------------------------- module Algebra.Graph.Undirected ( -- * Algebraic data type for graphs @@ -32,7 +34,7 @@ module Algebra.Graph.Undirected ( foldg, -- * Relations on graphs - isSubgraphOf, + isSubgraphOf, toRelation, -- * Graph properties isEmpty, size, hasVertex, hasEdge, vertexCount, edgeCount, vertexList, @@ -42,35 +44,33 @@ module Algebra.Graph.Undirected ( path, circuit, clique, biclique, star, stars, tree, forest, -- * Graph transformation - removeVertex, removeEdge, replaceVertex, mergeVertices, - induce, induceJust, toSymmetricRelation, complement, - - -- * Miscellaneous - consistent - + removeVertex, removeEdge, replaceVertex, mergeVertices, induce, induceJust, + complement ) where -import Control.Applicative (Alternative) -import Control.DeepSeq -import Control.Monad (MonadPlus (..)) -import Data.Coerce -import GHC.Generics -import Algebra.Graph.ToGraph (toGraph) -import Data.List ((\\)) +import Algebra.Graph.Internal +import Algebra.Graph.ToGraph (toGraph) +import Control.Applicative (Alternative) +import Control.DeepSeq +import Control.Monad +import Data.Coerce +import Data.List +import GHC.Generics +import Data.Set (Set) +import Data.Tree (Tree, Forest) import qualified Algebra.Graph as G - -import qualified Algebra.Graph.Relation.Symmetric as SR -import qualified Control.Applicative as Ap -import qualified Data.IntSet as IntSet +import qualified Algebra.Graph.Relation.Symmetric as R import qualified Data.Set as Set -import qualified Data.Tree as Tree +-- TODO: Specialise the API for graphs with vertices of type 'Int'. -{-| The Undirected 'Graph' data type is an abstraction over the 'Graph' data - type and provides the same graph construction -primitives 'empty', 'vertex', 'overlay' and 'connect'. We define the same 'Num' -as 'Graph' instance as a convenient notation for working with graphs: +{-| The 'Graph' data type provides the four algebraic graph construction +primitives 'empty', 'vertex', 'overlay' and 'connect', as well as various +derived functions. The only difference compared to the 'Algebra.Graph.Graph' +data type defined in "Algebra.Graph" is that the 'connect' operation is +/commutative/. We define a 'Num' instance as a convenient notation for working +with undirected graphs: > 0 == vertex 0 > 1 + 2 == vertices [1,2] @@ -86,7 +86,7 @@ working with algebraic graphs; we hope that in future Haskell's Prelude will provide a more fine-grained class hierarchy for algebraic structures, which we would be able to utilise without violating any laws. -The 'Eq' instance is currently implemented using the 'AM.AdjacencyMap' as the +The 'Eq' instance is currently implemented using the 'R.Relation' as the /canonical graph representation/ and satisfies all axioms of algebraic graphs: * 'overlay' is commutative and associative: @@ -124,10 +124,10 @@ The following useful theorems can be proved from the above set of axioms. > x * x * x == x * x When specifying the time and memory complexity of graph algorithms, /n/ will -denote the number of vertices in the graph, /m/ will denote the number of -edges in the graph, and /s/ will denote the /size/ of the corresponding -'Graph' expression. For example, if @g@ is an Undirected 'Graph' then /n/, /m/ and /s/ can -be computed as follows: +denote the number of vertices in the graph, /m/ will denote the number of edges +in the graph, and /s/ will denote the /size/ of the corresponding 'Graph' +expression. For example, if @g@ is a 'Graph' then /n/, /m/ and /s/ can be +computed as follows: @n == 'vertexCount' g m == 'edgeCount' g @@ -142,10 +142,10 @@ Note that 'size' counts all leaves of the expression: 'vertexCount' ('empty' + 'empty') == 0 'size' ('empty' + 'empty') == 2@ -Converting an Undirected 'Graph' to the corresponding 'AM.AdjacencyMap' takes /O(s + m * log(m))/ -time and /O(s + m)/ memory. This is also the complexity of the graph equality -test, because it is currently implemented by converting graph expressions to -canonical representations based on adjacency maps. +Converting an undirected 'Graph' to the corresponding 'R.Relation' takes +/O(s + m * log(m))/ time and /O(s + m)/ memory. This is also the complexity of +the graph equality test, because it is currently implemented by converting graph +expressions to canonical representations based on adjacency maps. The total order on graphs is defined using /size-lexicographic/ comparison: @@ -173,17 +173,11 @@ compatible with 'overlay' and 'connect' operations: x <= x + y x + y <= x * y@ -} -newtype Graph a = UG { _fromUndirected :: G.Graph a } - deriving (Generic, NFData) +newtype Graph a = UG (G.Graph a) + deriving (Alternative, Applicative, Functor, Generic, Monad, MonadPlus, NFData) instance (Show a, Ord a) => Show (Graph a) where - show = show . toSymmetricRelation - -{- See Note [Functions for rewrite rules] in 'Algebra.Graph' -} - -instance Functor Graph where - fmap f = UG . fmap f . coerce - {-# INLINE fmap #-} + show = show . toRelation -- | __Note:__ this does not satisfy the usual ring laws; see 'Graph' for more -- details. @@ -202,81 +196,14 @@ instance Ord a => Ord (Graph a) where compare = ordR -- TODO: Find a more efficient equality check. --- TODO: Implement toUndirectedAdjacencyMap. --- Check if two graphs are equal by converting them to their symmetric --- relations. +-- Check if two graphs are equal by converting them to symmetric relations. eqR :: Ord a => Graph a -> Graph a -> Bool -eqR x y = toSymmetricRelation x == toSymmetricRelation y -{-# NOINLINE [1] eqR #-} -{-# RULES "eqR/Int" eqR = eqIntR #-} - --- Like 'eqR' but specialised for graphs with vertices of type 'Int'. --- TODO: This is currently not specialised to vertices of type 'Int'. But it's still --- here for when 'UndirectedAdjacencyIntMap' is implemented. -eqIntR :: Graph Int -> Graph Int -> Bool -eqIntR x y = toSymmetricRelation x == toSymmetricRelation y +eqR x y = toRelation x == toRelation y -- TODO: Find a more efficient comparison. --- TODO: Implement toUndirectedAdjacencyIntMap. --- Compare two graphs by converting them to their adjacency maps. +-- Compare two graphs by converting them to their symmetric relations. ordR :: Ord a => Graph a -> Graph a -> Ordering -ordR x y = compare (toSymmetricRelation x) (toSymmetricRelation y) -{-# NOINLINE [1] ordR #-} -{-# RULES "ordR/Int" ordR = ordIntR #-} - --- Like 'ordR' but specialised for graphs with vertices of type 'Int'. --- TODO: This is currently not specialised to vertices of type 'Int'. But it's still --- here for when 'UndirectedAdjacencyIntMap' is implemented. -ordIntR :: Graph Int -> Graph Int -> Ordering -ordIntR x y = compare (toSymmetricRelation x) (toSymmetricRelation y) - -instance Applicative Graph where - pure = vertex - (<*>) = coerce3 (<*>) - {-# INLINE (<*>) #-} - -instance Monad Graph where - return = pure - (>>=) g = UG . (>>=) (coerce5 g) . coerce - {-# INLINE (>>=) #-} - -instance Alternative Graph where - empty = empty - (<|>) = overlay - -instance MonadPlus Graph where - mzero = empty - mplus = overlay - --- Help GHC with type inference (direct use of 'coerce' does not --- compile). -coerce0 :: G.Graph a -> Graph a -coerce0 = coerce - --- Help GHC with type inference (direct use of 'coerce' does not --- compile). -coerce1 :: (Coercible a b) => (a -> G.Graph c) -> (b -> Graph c) -coerce1 = coerce - --- Help GHC with type inference (direct use of 'coerce' does not --- compile). -coerce2 :: (Coercible a b, Coercible c d) => (a -> c -> G.Graph e) -> (b -> d -> Graph e) -coerce2 = coerce - --- Help GHC with type inference (direct use of 'coerce' does not --- compile). -coerce3 :: (Coercible b c) => (G.Graph a -> b) -> (Graph a -> c) -coerce3 = coerce - --- Help GHC with type inference (direct use of 'coerce' does not --- compile). -coerce4 :: (Coercible b c) => (a -> G.Graph a -> b) -> (a -> Graph a -> c) -coerce4 = coerce - --- Help GHC with type inference (direct use of 'coerce' does not --- compile). -coerce5 :: Graph a -> G.Graph a -coerce5 = coerce +ordR x y = compare (toRelation x) (toRelation y) -- | Construct an undirected graph from a given "Algebra.Graph". -- Complexity: /O(1)/ time. @@ -288,7 +215,7 @@ coerce5 = coerce -- (*2) . 'edgeCount' . toUndirected >= 'Algebra.Graph.edgeCount' -- @ toUndirected :: G.Graph a -> Graph a -toUndirected = UG +toUndirected = coerce -- | Extract the underlying "Algebra.Graph". -- Complexity: /O(n + m)/ time. @@ -299,8 +226,8 @@ toUndirected = UG -- 'Algebra.Graph.vertexCount' . fromUndirected == 'vertexCount' -- 'Algebra.Graph.edgeCount' . fromUndirected <= (*2) . 'edgeCount' -- @ -fromUndirected :: (Ord a) => Graph a -> G.Graph a -fromUndirected = toGraph . toSymmetricRelation +fromUndirected :: Ord a => Graph a -> G.Graph a +fromUndirected = toGraph . toRelation -- | Construct the /empty graph/. -- Complexity: /O(1)/ time, memory and size. @@ -313,7 +240,7 @@ fromUndirected = toGraph . toSymmetricRelation -- 'size' empty == 1 -- @ empty :: Graph a -empty = coerce0 G.empty +empty = coerce00 G.empty {-# INLINE empty #-} -- | Construct the graph comprising /a single isolated vertex/. @@ -321,13 +248,13 @@ empty = coerce0 G.empty -- -- @ -- 'isEmpty' (vertex x) == False --- 'hasVertex' x (vertex x) == True +-- 'hasVertex' x (vertex y) == (x == y) -- 'vertexCount' (vertex x) == 1 -- 'edgeCount' (vertex x) == 0 -- 'size' (vertex x) == 1 -- @ vertex :: a -> Graph a -vertex = coerce1 G.vertex +vertex = coerce10 G.vertex {-# INLINE vertex #-} -- | Construct the graph comprising /a single edge/. @@ -343,11 +270,11 @@ vertex = coerce1 G.vertex -- 'vertexCount' (edge 1 2) == 2 -- @ edge :: a -> a -> Graph a -edge = coerce2 G.edge +edge = coerce20 G.edge {-# INLINE edge #-} --- | /Overlay/ two graphs. This is a --- commutative, associative and idempotent operation with the identity 'empty'. +-- | /Overlay/ two graphs. This is a commutative, associative and idempotent +-- operation with the identity 'empty'. -- Complexity: /O(1)/ time and memory, /O(s1 + s2)/ size. -- -- @ @@ -362,12 +289,12 @@ edge = coerce2 G.edge -- 'edgeCount' (overlay 1 2) == 0 -- @ overlay :: Graph a -> Graph a -> Graph a -overlay = coerce2 G.overlay +overlay = coerce20 G.overlay {-# INLINE overlay #-} --- | /Connect/ two graphs. This is a commutative and --- associative operation with the identity 'empty', which distributes over --- 'overlay' and obeys the decomposition axiom. +-- | /Connect/ two graphs. This is a commutative and associative operation with +-- the identity 'empty', which distributes over 'overlay' and obeys the +-- decomposition axiom. -- Complexity: /O(1)/ time and memory, /O(s1 + s2)/ size. 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)/. @@ -387,7 +314,7 @@ overlay = coerce2 G.overlay -- 'edgeCount' (connect 1 2) == 1 -- @ connect :: Graph a -> Graph a -> Graph a -connect = coerce2 G.connect +connect = coerce20 G.connect {-# INLINE connect #-} -- | Construct the graph comprising a given list of isolated vertices. @@ -402,21 +329,20 @@ connect = coerce2 G.connect -- 'vertexSet' . vertices == Set . 'Set.fromList' -- @ vertices :: [a] -> Graph a -vertices = coerce1 G.vertices +vertices = coerce10 G.vertices {-# INLINE vertices #-} --- TODO: Use a faster nubBy implementation with 'Data.Set' -- | Construct the graph from a list of edges. --- Complexity: /O(L)/ time, /O(L)/ memory and size, where /L/ is the length of the +-- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the -- given list. -- -- @ --- edges [] == 'empty' --- edges [(x,y)] == 'edge' x y +-- edges [] == 'empty' +-- edges [(x,y)] == 'edge' x y -- edges [(x,y), (y,x)] == 'edge' x y -- @ edges :: [(a, a)] -> Graph a -edges = coerce1 G.edges +edges = coerce10 G.edges {-# INLINE edges #-} -- | Overlay a given list of graphs. @@ -431,7 +357,7 @@ edges = coerce1 G.edges -- 'isEmpty' . overlays == 'all' 'isEmpty' -- @ overlays :: [Graph a] -> Graph a -overlays = coerce1 G.overlays +overlays = coerce10 G.overlays {-# INLINE overlays #-} -- | Connect a given list of graphs. @@ -447,10 +373,10 @@ overlays = coerce1 G.overlays -- connects == connects . 'reverse' -- @ connects :: [Graph a] -> Graph a -connects = coerce1 G.connects +connects = coerce10 G.connects {-# INLINE connects #-} --- | Generalised 'Graph' folding: recursively collapse an 'Graph' by applying +-- | Generalised 'Graph' folding: recursively collapse a 'Graph' by applying -- the provided functions to the leaves and internal nodes of the expression. -- The order of arguments is: empty, vertex, overlay and connect. -- Complexity: /O(s)/ applications of given functions. As an example, the @@ -464,9 +390,11 @@ connects = coerce1 G.connects -- foldg False (== x) (||) (||) == 'hasVertex' x -- @ foldg :: b -> (a -> b) -> (b -> b -> b) -> (b -> b -> b) -> Graph a -> b -foldg = (coerce :: (b -> (a -> b) -> (b -> b -> b) -> (b -> b -> b) -> G.Graph a -> b) - -> (b -> (a -> b) -> (b -> b -> b) -> (b -> b -> b) -> Graph a -> b)) - G.foldg +foldg = coerce G.foldg + where + coerce :: (b -> (a -> b) -> (b -> b -> b) -> (b -> b -> b) -> G.Graph a -> b) + -> (b -> (a -> b) -> (b -> b -> b) -> (b -> b -> b) -> Graph a -> b) + coerce = Data.Coerce.coerce {-# INLINE foldg #-} -- | The 'isSubgraphOf' function takes two graphs and returns 'True' if the @@ -484,18 +412,18 @@ foldg = (coerce :: (b -> (a -> b) -> (b -> b -> b) -> (b -> b -> b) -> G.Graph a -- isSubgraphOf x y ==> x <= y -- @ isSubgraphOf :: Ord a => Graph a -> Graph a -> Bool -isSubgraphOf x y = SR.isSubgraphOf (toSymmetricRelation x) (toSymmetricRelation y) +isSubgraphOf x y = R.isSubgraphOf (toRelation x) (toRelation y) {-# NOINLINE [1] isSubgraphOf #-} -{-# RULES "isSubgraphOf/Int" isSubgraphOf = isSubgraphOfIntR #-} --- Like 'isSubgraphOf' but specialised for graphs with vertices of type 'Int'. --- TODO: This is currently not specialised to vertices of type 'Int'. But it's still --- here for when 'UndirectedAdjacencyIntMap' is implemented. -isSubgraphOfIntR :: Graph Int -> Graph Int -> Bool -isSubgraphOfIntR x y = SR.isSubgraphOf (toSymmetricRelation x) (toSymmetricRelation y) -{-# INLINE isSubgraphOfIntR #-} +-- TODO: This is a very inefficient implementation. Find a way to construct a +-- symmetric relation directly, without building intermediate representations +-- for all subgraphs. +-- | Convert an undirected graph to a symmetric 'R.Relation'. +toRelation :: Ord a => Graph a -> R.Relation a +toRelation = foldg R.empty R.vertex R.overlay R.connect +{-# INLINE toRelation #-} --- | Check if a graph is empty. A convenient alias for 'null'. +-- | Check if a graph is empty. -- Complexity: /O(s)/ time. -- -- @ @@ -506,7 +434,7 @@ isSubgraphOfIntR x y = SR.isSubgraphOf (toSymmetricRelation x) (toSymmetricRelat -- isEmpty ('removeEdge' x y $ 'edge' x y) == False -- @ isEmpty :: Graph a -> Bool -isEmpty = coerce3 G.isEmpty +isEmpty = coerce01 G.isEmpty {-# INLINE isEmpty #-} -- | The /size/ of a graph, i.e. the number of leaves of the expression @@ -522,7 +450,7 @@ isEmpty = coerce3 G.isEmpty -- size x >= 'vertexCount' x -- @ size :: Graph a -> Int -size = coerce3 G.size +size = coerce01 G.size {-# INLINE size #-} -- | Check if a graph contains a given vertex. @@ -530,16 +458,15 @@ size = coerce3 G.size -- -- @ -- hasVertex x 'empty' == False --- hasVertex x ('vertex' x) == True --- hasVertex 1 ('vertex' 2) == False +-- hasVertex x ('vertex' y) == (x == y) -- hasVertex x . 'removeVertex' x == 'const' False -- @ hasVertex :: Eq a => a -> Graph a -> Bool -hasVertex = coerce4 G.hasVertex +hasVertex = coerce11 G.hasVertex {-# INLINE hasVertex #-} {-# SPECIALISE hasVertex :: Int -> Graph Int -> Bool #-} --- TODO: Optimize this further. +-- TODO: Optimise this further. -- | Check if a graph contains a given edge. -- Complexity: /O(s)/ time. -- @@ -566,15 +493,8 @@ hasEdge s t (UG g) = G.hasEdge s t g || G.hasEdge t s g -- vertexCount x \< vertexCount y ==> x \< y -- @ vertexCount :: Ord a => Graph a -> Int -vertexCount = coerce3 G.vertexCount +vertexCount = coerce01 G.vertexCount {-# INLINE [1] vertexCount #-} -{-# RULES "vertexCount/Int" vertexCount = vertexIntCountR #-} - --- Like 'vertexCount' but specialised for graphs with vertices of type 'Int'. --- TODO: This is currently not specialised to vertices of type 'Int'. But it's still --- here for when 'UndirectedAdjacencyIntMap' is implemented. -vertexIntCountR :: Graph Int -> Int -vertexIntCountR = IntSet.size . vertexIntSetR -- | The number of edges in a graph. -- Complexity: /O(s + m * log(m))/ time. Note that the number of edges /m/ of a @@ -587,16 +507,8 @@ vertexIntCountR = IntSet.size . vertexIntSetR -- edgeCount == 'length' . 'edgeList' -- @ edgeCount :: Ord a => Graph a -> Int -edgeCount = length . edgeList +edgeCount = R.edgeCount . toRelation {-# INLINE [1] edgeCount #-} -{-# RULES "edgeCount/Int" edgeCount = edgeCountIntR #-} - --- Like 'edgeCount' but specialised for graphs with vertices of type 'Int'. --- TODO: This is currently not specialised to vertices of type 'Int'. But it's still --- here for when 'UndirectedAdjacencyIntMap' is implemented. -edgeCountIntR :: Graph Int -> Int -edgeCountIntR = length . edgeList -{-# INLINE edgeCountIntR #-} -- | The sorted list of vertices of a given graph. -- Complexity: /O(s * log(n))/ time and /O(n)/ memory. @@ -607,14 +519,8 @@ edgeCountIntR = length . edgeList -- vertexList . 'vertices' == 'Data.List.nub' . 'Data.List.sort' -- @ vertexList :: Ord a => Graph a -> [a] -vertexList = Set.toAscList . vertexSet +vertexList = coerce01 G.vertexList {-# INLINE [1] vertexList #-} -{-# RULES "vertexList/Int" vertexList = vertexIntListR #-} - --- Like 'vertexList' but specialised for graphs with vertices of type 'Int'. -vertexIntListR :: Graph Int -> [Int] -vertexIntListR = IntSet.toList . vertexIntSetR -{-# INLINE vertexIntListR #-} -- | The sorted list of edges of a graph. -- Complexity: /O(s + m * log(m))/ time and /O(m)/ memory. Note that the number of @@ -627,16 +533,8 @@ vertexIntListR = IntSet.toList . vertexIntSetR -- edgeList ('star' 2 [3,1]) == [(1,2), (2,3)] -- @ edgeList :: Ord a => Graph a -> [(a, a)] -edgeList = SR.edgeList . toSymmetricRelation +edgeList = R.edgeList . toRelation {-# INLINE [1] edgeList #-} -{-# RULES "edgeList/Int" edgeList = edgeIntListR #-} - --- Like 'edgeList' but specialised for graphs with vertices of type 'Int'. --- TODO: This is currently not specialised to vertices of type 'Int'. But it's still --- here for when 'UndirectedAdjacencyIntMap' is implemented. -edgeIntListR :: Graph Int -> [(Int, Int)] -edgeIntListR = SR.edgeList . toSymmetricRelation -{-# INLINE edgeIntListR #-} -- | The set of vertices of a given graph. -- Complexity: /O(s * log(n))/ time and /O(n)/ memory. @@ -646,15 +544,10 @@ edgeIntListR = SR.edgeList . toSymmetricRelation -- vertexSet . 'vertex' == Set.'Set.singleton' -- vertexSet . 'vertices' == Set.'Set.fromList' -- @ -vertexSet :: Ord a => Graph a -> Set.Set a -vertexSet = coerce3 G.vertexSet +vertexSet :: Ord a => Graph a -> Set a +vertexSet = coerce01 G.vertexSet {-# INLINE vertexSet #-} --- Like 'vertexSet' but specialised for graphs with vertices of type 'Int'. -vertexIntSetR :: Graph Int -> IntSet.IntSet -vertexIntSetR = foldg IntSet.empty IntSet.singleton IntSet.union IntSet.union -{-# INLINE vertexIntSetR #-} - -- | The set of edges of a given graph. -- Complexity: /O(s * log(m))/ time and /O(m)/ memory. -- @@ -663,17 +556,9 @@ vertexIntSetR = foldg IntSet.empty IntSet.singleton IntSet.union IntSet.union -- edgeSet ('vertex' x) == Set.'Set.empty' -- edgeSet ('edge' x y) == Set.'Set.singleton' ('min' x y, 'max' x y) -- @ -edgeSet :: Ord a => Graph a -> Set.Set (a, a) -edgeSet = SR.edgeSet . toSymmetricRelation +edgeSet :: Ord a => Graph a -> Set (a, a) +edgeSet = R.edgeSet . toRelation {-# INLINE [1] edgeSet #-} -{-# RULES "edgeSet/Int" edgeSet = edgeIntSetR #-} - --- Like 'edgeSet' but specialised for graphs with vertices of type 'Int'. --- TODO: This is currently not specialised to vertices of type 'Int'. But it's still --- here for when 'UndirectedAdjacencyIntMap' is implemented. -edgeIntSetR :: Graph Int -> Set.Set (Int,Int) -edgeIntSetR = SR.edgeSet . toSymmetricRelation -{-# INLINE edgeIntSetR #-} -- | The sorted /adjacency list/ of a graph. -- Complexity: /O(n + m)/ time and /O(m)/ memory. @@ -686,38 +571,21 @@ edgeIntSetR = SR.edgeSet . toSymmetricRelation -- 'stars' . adjacencyList == id -- @ adjacencyList :: Ord a => Graph a -> [(a, [a])] -adjacencyList = SR.adjacencyList . toSymmetricRelation +adjacencyList = R.adjacencyList . toRelation {-# INLINE adjacencyList #-} {-# SPECIALISE adjacencyList :: Graph Int -> [(Int, [Int])] #-} --- TODO: This is a very inefficient implementation. Find a way to construct an --- symmetric relation directly, without building intermediate representations for all --- subgraphs. --- TODO: Change this implementation when 'UndirectedAdjacencyMap' is --- defined. --- Convert a graph to 'SR.Relation'. -toSymmetricRelation :: Ord a => Graph a -> SR.Relation a -toSymmetricRelation = foldg SR.empty SR.vertex SR.overlay SR.connect -{-# INLINE toSymmetricRelation #-} - --- | Complement of a graph. --- Complexity: /O(n^2*m)/ time, /O(n^2)/ memory where +-- | The set of vertices /adjacent/ to a given vertex. -- -- @ --- complement 'empty' == 'empty' --- complement ('vertex' x) == ('vertex' x) --- complement ('edge' 1 2) == ('vertices' [1, 2]) --- complement ('edge' 0 0) == ('edge' 0 0) --- complement ('star' 1 [2, 3]) == ('overlay' ('vertex' 1) ('edge' 2 3)) --- complement . complement == id +-- neighbours x 'empty' == Set.'Set.empty' +-- neighbours x ('vertex' x) == Set.'Set.empty' +-- neighbours x ('edge' x y) == Set.'Set.fromList' [y] +-- neighbours y ('edge' x y) == Set.'Set.fromList' [x] -- @ -complement :: Ord a => Graph a -> Graph a -complement g@(UG _) = overlay (vertices allVertices) (edges complementEdges) - where cliqueG = clique . vertexList - allVertices = vertexList g - previousEdges = edgeList g - loops = filter (uncurry (==)) previousEdges - complementEdges = loops ++ (edgeList (cliqueG g) \\ previousEdges) +neighbours :: Ord a => a -> Graph a -> Set a +neighbours x = R.neighbours x . toRelation +{-# INLINE neighbours #-} -- | The /path/ on a list of vertices. -- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the @@ -730,7 +598,7 @@ complement g@(UG _) = overlay (vertices allVertices) (edges complementEdges) -- path . 'reverse' == path -- @ path :: [a] -> Graph a -path = coerce1 G.path +path = coerce10 G.path {-# INLINE path #-} -- | The /circuit/ on a list of vertices. @@ -744,7 +612,7 @@ path = coerce1 G.path -- circuit . 'reverse' == circuit -- @ circuit :: [a] -> Graph a -circuit = coerce1 G.circuit +circuit = coerce10 G.circuit {-# INLINE circuit #-} -- | The /clique/ on a list of vertices. @@ -760,7 +628,7 @@ circuit = coerce1 G.circuit -- clique . 'reverse' == clique -- @ clique :: [a] -> Graph a -clique = coerce1 G.clique +clique = coerce10 G.clique {-# INLINE clique #-} -- | The /biclique/ on two lists of vertices. @@ -775,7 +643,7 @@ clique = coerce1 G.clique -- biclique xs ys == 'connect' ('vertices' xs) ('vertices' ys) -- @ biclique :: [a] -> [a] -> Graph a -biclique = coerce2 G.biclique +biclique = coerce20 G.biclique {-# INLINE biclique #-} -- | The /star/ formed by a centre vertex connected to a list of leaves. @@ -789,7 +657,7 @@ biclique = coerce2 G.biclique -- star x ys == 'connect' ('vertex' x) ('vertices' ys) -- @ star :: a -> [a] -> Graph a -star = coerce2 G.star +star = coerce20 G.star {-# INLINE star #-} -- | The /stars/ formed by overlaying a list of 'star's. An inverse of @@ -807,10 +675,10 @@ star = coerce2 G.star -- 'overlay' (stars xs) (stars ys) == stars (xs ++ ys) -- @ stars :: [(a, [a])] -> Graph a -stars = coerce1 G.stars +stars = coerce10 G.stars {-# INLINE stars #-} --- | The /tree graph/ constructed from a given 'Tree.Tree' data structure. +-- | The /tree graph/ constructed from a given 'Tree' data structure. -- Complexity: /O(T)/ time, memory and size, where /T/ is the size of the -- given tree (i.e. the number of vertices in the tree). -- @@ -820,11 +688,11 @@ stars = coerce1 G.stars -- 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 :: Tree.Tree a -> Graph a -tree = coerce1 G.tree +tree :: Tree a -> Graph a +tree = coerce10 G.tree {-# INLINE tree #-} --- | The /forest graph/ constructed from a given 'Tree.Forest' data structure. +-- | The /forest graph/ constructed from a given 'Forest' data structure. -- Complexity: /O(F)/ time, memory and size, where /F/ is the size of the -- given forest (i.e. the number of vertices in the forest). -- @@ -834,8 +702,8 @@ tree = coerce1 G.tree -- forest [Node 1 [Node 2 [], Node 3 []], Node 4 [Node 5 []]] == 'edges' [(1,2), (1,3), (4,5)] -- forest == 'overlays' . 'map' 'tree' -- @ -forest :: Tree.Forest a -> Graph a -forest = coerce1 G.forest +forest :: Forest a -> Graph a +forest = coerce10 G.forest {-# INLINE forest #-} -- | Remove a vertex from a given graph. @@ -849,11 +717,11 @@ forest = coerce1 G.forest -- removeVertex x . removeVertex x == removeVertex x -- @ removeVertex :: Eq a => a -> Graph a -> Graph a -removeVertex = coerce4 G.removeVertex +removeVertex = coerce11 G.removeVertex {-# INLINE removeVertex #-} -{-# SPECIALISE removeVertex :: Int -> Graph Int -> - Graph Int #-} +{-# SPECIALISE removeVertex :: Int -> Graph Int -> Graph Int #-} +-- TODO: Optimise by doing a single graph traversal. -- | Remove an edge from a given graph. -- Complexity: /O(s)/ time, memory and size. -- @@ -866,10 +734,9 @@ removeVertex = coerce4 G.removeVertex -- removeEdge 1 2 (1 * 1 * 2 * 2) == 1 * 1 + 2 * 2 -- @ removeEdge :: Eq a => a -> a -> Graph a -> Graph a -removeEdge s t = coerce $ G.removeEdge s t . G.removeEdge t s +removeEdge s t = Data.Coerce.coerce $ G.removeEdge s t . G.removeEdge t s {-# INLINE removeEdge #-} -{-# SPECIALISE removeEdge :: Int -> Int -> Graph Int -> - Graph Int #-} +{-# SPECIALISE removeEdge :: Int -> Int -> Graph Int -> Graph Int #-} -- | The function @'replaceVertex' x y@ replaces vertex @x@ with vertex @y@ in a -- given 'Graph'. If @y@ already exists, @x@ and @y@ will be merged. @@ -881,7 +748,7 @@ removeEdge s t = coerce $ G.removeEdge s t . G.removeEdge t s -- replaceVertex x y == 'mergeVertices' (== x) y -- @ replaceVertex :: Eq a => a -> a -> Graph a -> Graph a -replaceVertex u v = coerce (G.replaceVertex u v) +replaceVertex = coerce21 G.replaceVertex {-# INLINE replaceVertex #-} {-# SPECIALISE replaceVertex :: Int -> Int -> Graph Int -> Graph Int #-} @@ -896,7 +763,7 @@ replaceVertex u v = coerce (G.replaceVertex u v) -- mergeVertices 'odd' 1 (3 + 4 * 5) == 4 * 1 -- @ mergeVertices :: (a -> Bool) -> a -> Graph a -> Graph a -mergeVertices p v = coerce (G.mergeVertices p v) +mergeVertices = coerce21 G.mergeVertices {-# INLINE mergeVertices #-} -- TODO: Implement via 'induceJust' to reduce code duplication. @@ -913,7 +780,7 @@ mergeVertices p v = coerce (G.mergeVertices p v) -- 'isSubgraphOf' (induce p x) x == True -- @ induce :: (a -> Bool) -> Graph a -> Graph a -induce = coerce2 G.induce +induce = coerce20 G.induce {-# INLINE induce #-} -- | Construct the /induced subgraph/ of a given graph by removing the vertices @@ -927,37 +794,26 @@ induce = coerce2 G.induce -- induceJust . 'fmap' (\\x -> if p x then 'Just' x else 'Nothing') == 'induce' p -- @ induceJust :: Graph (Maybe a) -> Graph a -induceJust = coerce1 G.induceJust +induceJust = coerce10 G.induceJust {-# INLINE induceJust #-} --- | The set of /neighbours/ of an element @x@ is the set of elements that are --- related to it, i.e. @neighbours x == { a | aRx }@. In the context of undirected --- graphs, this corresponds to the set of /adjacent/ vertices of vertex @x@. +-- | The edge complement of a graph. Note that, as can be seen from the examples +-- below, this operation ignores self-loops. +-- Complexity: /O(n^2 * log n)/ time, /O(n^2)/ memory. -- -- @ --- neighbours x 'empty' == Set.'Set.empty' --- neighbours x ('vertex' x) == Set.'Set.empty' --- neighbours x ('edge' x y) == Set.'Set.fromList' [y] --- neighbours y ('edge' x y) == Set.'Set.fromList' [x] --- @ -neighbours :: Ord a => a -> Graph a -> Set.Set a -neighbours x = SR.neighbours x . toSymmetricRelation -{-# INLINE neighbours #-} - --- | Check that the internal representation of an undirected graph is --- consistent, i.e. that (i) that all edges refer to existing vertices, and (ii) --- all edges have their symmetric counterparts. It should be impossible to --- create an inconsistent 'Graph', and we use this function in testing. --- --- @ --- consistent 'empty' == True --- consistent ('vertex' x) == True --- consistent ('overlay' x y) == True --- consistent ('connect' x y) == True --- consistent ('edge' x y) == True --- consistent ('edges' xs) == True --- consistent ('stars' xs) == True +-- complement 'empty' == 'empty' +-- complement ('vertex' x) == ('vertex' x) +-- complement ('edge' 1 2) == ('vertices' [1, 2]) +-- complement ('edge' 0 0) == ('edge' 0 0) +-- complement ('star' 1 [2, 3]) == ('overlay' ('vertex' 1) ('edge' 2 3)) +-- complement . complement == id -- @ -consistent :: Ord a => Graph a -> Bool -consistent (UG g) = UG g == (UG $ G.transpose g) -{-# INLINE consistent #-} +complement :: Ord a => Graph a -> Graph a +complement g = overlay (vertices vsOld) (edges $ Set.toAscList esNew) + where + vsOld = vertexList g + esOld = edgeSet g + loops = Set.filter (uncurry (==)) esOld + esAll = Set.fromAscList [ (x, y) | x:ys <- tails vsOld, y <- ys ] + esNew = Set.union loops (Set.difference esAll esOld) diff --git a/test/Algebra/Graph/Test/API.hs b/test/Algebra/Graph/Test/API.hs index e76e28cfd..ee43aac3f 100644 --- a/test/Algebra/Graph/Test/API.hs +++ b/test/Algebra/Graph/Test/API.hs @@ -332,8 +332,7 @@ undirectedGraphAPI = API , transpose = id , gmap = fmap , induce = UG.induce - , induceJust = UG.induceJust - , consistent = UG.consistent } + , induceJust = UG.induceJust } -- | The API of 'AIM.AdjacencyIntMap'. adjacencyIntMapAPI :: API (Mono AIM.AdjacencyIntMap) ((~) Int) diff --git a/test/Algebra/Graph/Test/Acyclic/AdjacencyMap.hs b/test/Algebra/Graph/Test/Acyclic/AdjacencyMap.hs index 07c179c11..608e35817 100644 --- a/test/Algebra/Graph/Test/Acyclic/AdjacencyMap.hs +++ b/test/Algebra/Graph/Test/Acyclic/AdjacencyMap.hs @@ -84,8 +84,8 @@ testAcyclicAdjacencyMap = do test "isEmpty (vertex x) == False" $ \(x :: Int) -> isEmpty (vertex x) == False - test "hasVertex x (vertex x) == True" $ \(x :: Int) -> - hasVertex x (vertex x) == True + test "hasVertex x (vertex y) == (x == y)" $ \(x :: Int) y -> + hasVertex x (vertex y) == (x == y) test "vertexCount (vertex x) == 1" $ \(x :: Int) -> vertexCount (vertex x) == 1 @@ -164,11 +164,8 @@ testAcyclicAdjacencyMap = do test "hasVertex x empty == False" $ \(x :: Int) -> hasVertex x empty == False - test "hasVertex x (vertex x) == True" $ \(x :: Int) -> - hasVertex x (vertex x) == True - - test "hasVertex 1 (vertex 2) == False" $ - hasVertex 1 (vertex 2 :: AAI) == False + test "hasVertex x (vertex y) == (x == y)" $ \(x :: Int) y -> + hasVertex x (vertex y) == (x == y) test "hasVertex x . removeVertex x == const False" $ \(x :: Int) y -> (hasVertex x . removeVertex x) y == const False y diff --git a/test/Algebra/Graph/Test/Arbitrary.hs b/test/Algebra/Graph/Test/Arbitrary.hs index 1f031c215..8ffd51073 100644 --- a/test/Algebra/Graph/Test/Arbitrary.hs +++ b/test/Algebra/Graph/Test/Arbitrary.hs @@ -24,21 +24,21 @@ import Algebra.Graph import Algebra.Graph.Export import Algebra.Graph.Label -import qualified Algebra.Graph.Undirected as UG -import qualified Algebra.Graph.Acyclic.AdjacencyMap as AAM -import qualified Algebra.Graph.AdjacencyIntMap as AIM -import qualified Algebra.Graph.AdjacencyMap as AM -import qualified Algebra.Graph.Bipartite.AdjacencyMap as BAM -import qualified Algebra.Graph.NonEmpty.AdjacencyMap as NAM -import qualified Algebra.Graph.Class as C -import qualified Algebra.Graph.Labelled as LG -import qualified Algebra.Graph.Labelled.AdjacencyMap as LAM -import qualified Algebra.Graph.NonEmpty as NonEmpty -import qualified Algebra.Graph.Relation as Relation -import qualified Algebra.Graph.Relation.Preorder as Preorder -import qualified Algebra.Graph.Relation.Reflexive as Reflexive -import qualified Algebra.Graph.Relation.Symmetric as Symmetric -import qualified Algebra.Graph.Relation.Transitive as Transitive +import qualified Algebra.Graph.Undirected as UG +import qualified Algebra.Graph.Acyclic.AdjacencyMap as AAM +import qualified Algebra.Graph.AdjacencyIntMap as AIM +import qualified Algebra.Graph.AdjacencyMap as AM +import qualified Algebra.Graph.Bipartite.Undirected.AdjacencyMap as BAM +import qualified Algebra.Graph.NonEmpty.AdjacencyMap as NAM +import qualified Algebra.Graph.Class as C +import qualified Algebra.Graph.Labelled as LG +import qualified Algebra.Graph.Labelled.AdjacencyMap as LAM +import qualified Algebra.Graph.NonEmpty as NonEmpty +import qualified Algebra.Graph.Relation as Relation +import qualified Algebra.Graph.Relation.Preorder as Preorder +import qualified Algebra.Graph.Relation.Reflexive as Reflexive +import qualified Algebra.Graph.Relation.Symmetric as Symmetric +import qualified Algebra.Graph.Relation.Transitive as Transitive -- | Generate an arbitrary 'C.Graph' value of a specified size. arbitraryGraph :: (C.Graph g, Arbitrary (C.Vertex g)) => Gen g diff --git a/test/Algebra/Graph/Test/Bipartite/AdjacencyMap.hs b/test/Algebra/Graph/Test/Bipartite/AdjacencyMap.hs deleted file mode 100644 index d546fe5d0..000000000 --- a/test/Algebra/Graph/Test/Bipartite/AdjacencyMap.hs +++ /dev/null @@ -1,750 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Algebra.Graph.Test.AdjacencyMap --- Copyright : (c) Andrey Mokhov 2016-2018 --- License : MIT (see the file LICENSE) --- Maintainer : andrey.mokhov@gmail.com --- Stability : experimental --- --- Testsuite for "Algebra.Graph.Bipartite.AdjacencyMap". ------------------------------------------------------------------------------ -module Algebra.Graph.Test.Bipartite.AdjacencyMap ( - -- * Testsuite - testBipartiteAdjacencyMap - ) where - -import Algebra.Graph.Bipartite.AdjacencyMap -import Algebra.Graph.Test - -import qualified Algebra.Graph as G -import qualified Algebra.Graph.AdjacencyMap as AM - -import qualified Data.Map.Strict as Map -import qualified Data.Set as Set - -import qualified Data.Tuple - -import Data.Bifunctor (bimap) -import Data.Either (lefts, rights, isRight) -import Data.List (nub) - -type GII = G.Graph (Either Int Int) -type AII = AM.AdjacencyMap (Either Int Int) -type AI = AM.AdjacencyMap Int -type BAII = AdjacencyMap Int Int -type BAIS = AdjacencyMap Int String - -testBipartiteAdjacencyMap :: IO () -testBipartiteAdjacencyMap = do - putStrLn "\n============ Bipartite.AdjacencyMap.consistent ============" - test "consistent empty == True" $ - consistent (empty :: BAII) - test "consistent (vertex x) == True" $ \x -> - consistent (vertex x :: BAII) - test "consistent (edge x y) == True" $ \(x :: Int) (y :: Int) -> - consistent (edge x y) - test "consistent (edges x) == True" $ \(x :: [(Int, Int)]) -> - consistent (edges x) - test "consistent (fromGraph x) == True" $ \(x :: GII) -> - consistent $ fromGraph x - test "consistent (toBipartite x) == True" $ \(x :: AII) -> - consistent $ toBipartite x - test "consistent (swap x) == True" $ \(x :: BAII) -> - consistent $ swap x - test "consistent (biclique xs ys) == True" $ \(xs :: [Int]) (ys :: [Int]) -> - consistent $ biclique xs ys - test "consistent (circuit xs) == True" $ \(xs :: [(Int, Int)]) -> - consistent $ circuit xs - - putStrLn "\n============ Bipartite.AdjacencyMap.toBipartite ============" - test "leftAdjacencyMap (toBipartite empty) == Map.empty" $ - (leftAdjacencyMap $ toBipartite (AM.empty :: AII)) == Map.empty - test "rightAdjacencyMap (toBipartite empty) == Map.empty" $ - (rightAdjacencyMap $ toBipartite (AM.empty :: AII)) == Map.empty - test "leftAdjacencyMap (toBipartite (vertex (Left 1))) == Map.singleton 1 Set.empty" $ - (leftAdjacencyMap $ toBipartite (AM.vertex (Left 1) :: AII)) == Map.singleton 1 Set.empty - test "rightAdjacencyMap (toBipartite (vertex (Left 1))) == Map.empty" $ - (rightAdjacencyMap $ toBipartite (AM.vertex (Left 1) :: AII)) == Map.empty - test "leftAdjacencyMap (toBipartite (vertex (Right 1))) == Map.empty" $ - (leftAdjacencyMap $ toBipartite (AM.vertex (Right 1) :: AII)) == Map.empty - test "rightAdjacencyMap (toBipartite (vertex (Right 1))) == Map.singleton 1 Set.empty" $ - (rightAdjacencyMap $ toBipartite (AM.vertex (Right 1) :: AII)) == Map.singleton 1 Set.empty - test "leftAdjacencyMap (toBipartite (edge (Left 1) (Right 2))) == Map.singleton 1 (Set.singleton 2)" $ - (leftAdjacencyMap $ toBipartite (AM.edge (Left 1) (Right 2) :: AII)) == Map.singleton 1 (Set.singleton 2) - test "rightAdjacencyMap (toBipartite (edge (Left 1) (Right 2))) == Map.singleton 2 (Set.singleton 1)" $ - (rightAdjacencyMap $ toBipartite (AM.edge (Left 1) (Right 2) :: AII)) == Map.singleton 2 (Set.singleton 1) - test "leftAdjacencyMap (toBipartite (edges [(Left 1, Right 2), (Right 2, Left 1)])) == Map.singleton 1 (Set.singleton 2)" $ - (leftAdjacencyMap $ toBipartite (AM.edges [(Left 1, Right 2), (Right 2, Left 1)] :: AII)) - == Map.singleton 1 (Set.singleton 2) - test "rightAdjacencyMap (toBipartite (edges [(Left 1, Right 2), (Right 2, Left 1)])) == Map.singleton 2 (Set.singleton 1)" $ - (rightAdjacencyMap $ toBipartite (AM.edges [(Left 1, Right 2), (Right 2, Left 1)] :: AII)) - == Map.singleton 2 (Set.singleton 1) - test "leftAdjacencyMap (toBipartite (edge (Left 1) (Right 1))) == Map.singleton 1 (Set.singleton 2)" $ - (leftAdjacencyMap $ toBipartite (AM.edge (Left 1) (Right 1) :: AII)) == Map.singleton 1 (Set.singleton 1) - test "rightAdjacencyMap (toBipartite (edge (Left 1) (Right 2))) == Map.singleton 2 (Set.singleton 1)" $ - (rightAdjacencyMap $ toBipartite (AM.edge (Left 1) (Right 1) :: AII)) == Map.singleton 1 (Set.singleton 1) - test "leftAdjacencyMap (toBipartite (edges [(Left 1, Right 1), (Right 1, Left 1)])) == Map.singleton 1 (Set.singleton 1)" $ - (leftAdjacencyMap $ toBipartite (AM.edges [(Left 1, Right 1), (Right 1, Left 1)] :: AII)) - == Map.singleton 1 (Set.singleton 1) - test "rightAdjacencyMap (toBipartite (edges [(Left 1, Right 2), (Right 2, Left 1)])) == Map.singleton 1 (Set.singleton 1)" $ - (rightAdjacencyMap $ toBipartite (AM.edges [(Left 1, Right 1), (Right 1, Left 1)] :: AII)) - == Map.singleton 1 (Set.singleton 1) - test "leftAdjacencyMap (toBipartite (edges [(Left 1, Right 1), (Left 1, Right 2)])) == Map.singleton 1 (Set.fromAscList [1, 2])" $ - (leftAdjacencyMap $ toBipartite (AM.edges [(Left 1, Right 1), (Left 1, Right 2)] :: AII)) - == Map.singleton 1 (Set.fromAscList [1, 2]) - test "rightAdjacencyMap (toBipartite (edges [(Left 1, Right 1), (Left 1, Right 2)])) == Map.fromAscList [(1, Set.singleton 1), (2, Set.singleton 1)]" $ - (rightAdjacencyMap $ toBipartite (AM.edges [(Left 1, Right 1), (Left 1, Right 2)] :: AII)) - == Map.fromAscList [(1, Set.singleton 1), (2, Set.singleton 1)] - test "leftAdjacencyMap (toBipartite (edges [(Left 1, Right 2), (Left 1, Right 4), (Right 2, Left 3), (Left 3, Right 4), (Left 1, Left 3)])) == " $ - (leftAdjacencyMap $ toBipartite (AM.edges [(Left 1, Right 2), (Left 1, Right 4), (Right 2, Left 3), (Left 3, Right 4), (Left 1, Left 3)] :: AII)) - == Map.fromAscList [(1, Set.fromAscList [2, 4]), (3, Set.fromAscList [2, 4])] - test "rightAdjacencyMap (toBipartite (edges [(Left 1, Right 2), (Left 1, Right 4), (Right 2, Left 3), (Left 3, Right 4), (Left 1, Left 3)])) == " $ - (rightAdjacencyMap $ toBipartite (AM.edges ([(Left 1, Right 2), (Left 1, Right 4), (Right 2, Left 3), (Left 3, Right 4), (Left 1, Left 3)]) :: AII)) - == Map.fromAscList [(2, Set.fromAscList [1, 3]), (4, Set.fromAscList [1, 3])] - test "leftAdjacencyMap (toBipartite (biclique (map Left [1..x]) (map Right [1..y]))) == " $ \(x :: Int) (y :: Int) -> - (leftAdjacencyMap $ toBipartite $ AM.biclique (map Left [1..x]) (map Right [1..y])) - == expectedBicliqueMap x y - test "rightAdjacencyMap (toBipartite (biclique (map Left [1..x]) (map Right [1..y]))) == " $ \(x :: Int) (y :: Int) -> - (rightAdjacencyMap $ toBipartite $ AM.biclique (map Left [1..x]) (map Right [1..y])) - == expectedBicliqueMap y x - - putStrLn "\n============ Bipartite.AdjacencyMap.toBipartiteWith ============" - test "toBipartiteWith parity empty == empty" $ - toBipartiteWith parity AM.empty == empty - test "toBipartiteWith Left g == vertices (vertexList g) []" $ \(g :: AI) -> - toBipartiteWith Left g == (vertices (AM.vertexList g) [] :: BAII) - test "toBipartiteWith Right g == vertices [] (vertexList g)" $ \(g :: AI) -> - toBipartiteWith Right g == (vertices [] (AM.vertexList g) :: BAII) - test "toBipartiteWith parity (clique [1..3]) == biclique [1, 3] [2]" $ - toBipartiteWith parity (AM.clique [1..3] :: AI) == biclique [1, 3] [2] - test "toBipartiteWith parity (edge 1 1) == leftVertex 1" $ - toBipartiteWith parity (AM.edge 1 1) == leftVertex 1 - test "toBipartiteWith id g == toBipartite g" $ \(g :: AII) -> - toBipartiteWith id g == toBipartite g - - putStrLn "\n============ Bipartite.AdjacencyMap.fromGraph ============" - test "leftAdjacencyMap (fromGraph empty) == Map.empty" $ - (leftAdjacencyMap $ fromGraph (G.empty :: GII)) == Map.empty - test "rightAdjacencyMap (fromGraph empty) == Map.empty" $ - (rightAdjacencyMap $ fromGraph (G.empty :: GII)) == Map.empty - test "leftAdjacencyMap (fromGraph (Vertex (Left 1))) == Map.singleton 1 Set.empty" $ - (leftAdjacencyMap $ fromGraph (G.Vertex (Left 1) :: GII)) == Map.singleton 1 Set.empty - test "rightAdjacencyMap (fromGraph (Vertex (Left 1))) == Map.empty" $ - (rightAdjacencyMap $ fromGraph (G.Vertex (Left 1) :: GII)) == Map.empty - test "leftAdjacencyMap (fromGraph (Vertex (Right 1))) == Map.empty" $ - (leftAdjacencyMap $ fromGraph (G.Vertex (Right 1) :: GII)) == Map.empty - test "rightAdjacencyMap (fromGraph (Vertex (Right 1))) == Map.singleton 1 Set.empty" $ - (rightAdjacencyMap $ fromGraph (G.Vertex (Right 1) :: GII)) == Map.singleton 1 Set.empty - test "leftAdjacencyMap (fromGraph (edge (Left 1) (Right 2))) == Map.singleton 1 (Set.singleton 2)" $ - (leftAdjacencyMap $ fromGraph (G.edge (Left 1) (Right 2) :: GII)) == Map.singleton 1 (Set.singleton 2) - test "rightAdjacencyMap (fromGraph (edge (Left 1) (Right 2))) == Map.singleton 2 (Set.singleton 1)" $ - (rightAdjacencyMap $ fromGraph (G.edge (Left 1) (Right 2) :: GII)) == Map.singleton 2 (Set.singleton 1) - test "leftAdjacencyMap (fromGraph (edges [(Left 1, Right 2), (Right 2, Left 1)])) == Map.singleton 1 (Set.singleton 2)" $ - (leftAdjacencyMap $ fromGraph (G.edges [(Left 1, Right 2), (Right 2, Left 1)] :: GII)) - == Map.singleton 1 (Set.singleton 2) - test "rightAdjacencyMap (fromGraph (edges [(Left 1, Right 2), (Right 2, Left 1)])) == Map.singleton 2 (Set.singleton 1)" $ - (rightAdjacencyMap $ fromGraph (G.edges [(Left 1, Right 2), (Right 2, Left 1)] :: GII)) - == Map.singleton 2 (Set.singleton 1) - test "leftAdjacencyMap (fromGraph (edge (Left 1) (Right 1))) == Map.singleton 1 (Set.singleton 2)" $ - (leftAdjacencyMap $ fromGraph (G.edge (Left 1) (Right 1) :: GII)) == Map.singleton 1 (Set.singleton 1) - test "rightAdjacencyMap (fromGraph (edge (Left 1) (Right 2))) == Map.singleton 2 (Set.singleton 1)" $ - (rightAdjacencyMap $ fromGraph (G.edge (Left 1) (Right 1) :: GII)) == Map.singleton 1 (Set.singleton 1) - test "leftAdjacencyMap (fromGraph (edges [(Left 1, Right 1), (Right 1, Left 1)])) == Map.singleton 1 (Set.singleton 1)" $ - (leftAdjacencyMap $ fromGraph (G.edges [(Left 1, Right 1), (Right 1, Left 1)] :: GII)) - == Map.singleton 1 (Set.singleton 1) - test "rightAdjacencyMap (fromGraph (edges [(Left 1, Right 2), (Right 2, Left 1)])) == Map.singleton 1 (Set.singleton 1)" $ - (rightAdjacencyMap $ fromGraph (G.edges [(Left 1, Right 1), (Right 1, Left 1)] :: GII)) - == Map.singleton 1 (Set.singleton 1) - test "leftAdjacencyMap (fromGraph (edges [(Left 1, Right 1), (Left 1, Right 2)])) == Map.singleton 1 (Set.fromAscList [1, 2])" $ - (leftAdjacencyMap $ fromGraph (G.edges [(Left 1, Right 1), (Left 1, Right 2)] :: GII)) - == Map.singleton 1 (Set.fromAscList [1, 2]) - test "rightAdjacencyMap (fromGraph (edges [(Left 1, Right 1), (Left 1, Right 2)])) == Map.fromAscList [(1, Set.singleton 1), (2, Set.singleton 1)]" $ - (rightAdjacencyMap $ fromGraph (G.edges [(Left 1, Right 1), (Left 1, Right 2)] :: GII)) - == Map.fromAscList [(1, Set.singleton 1), (2, Set.singleton 1)] - test "leftAdjacencyMap (fromGraph (edges [(Left 1, Right 2), (Left 1, Right 4), (Right 2, Left 3), (Left 3, Right 4), (Left 1, Left 3)])) == " $ - (leftAdjacencyMap $ fromGraph $ (G.edges [(Left 1, Right 2), (Left 1, Right 4), (Right 2, Left 3), (Left 3, Right 4), (Left 1, Left 3)] :: GII)) - == Map.fromAscList [(1, Set.fromAscList [2, 4]), (3, Set.fromAscList [2, 4])] - test "rightAdjacencyMap (fromGraph (edges [(Left 1, Right 2), (Left 1, Right 4), (Right 2, Left 3), (Left 3, Right 4), (Left 1, Left 3)])) == " $ - (rightAdjacencyMap $ fromGraph $ (G.edges [(Left 1, Right 2), (Left 1, Right 4), (Right 2, Left 3), (Left 3, Right 4), (Left 1, Left 3)] :: GII)) - == Map.fromAscList [(2, Set.fromAscList [1, 3]), (4, Set.fromAscList [1, 3])] - test "leftAdjacencyMap (fromGraph (biclique (map Left [1..x]) (map Right [1..y]))) == " $ \(x :: Int) (y :: Int) -> - (leftAdjacencyMap $ fromGraph $ G.biclique (map Left [1..x]) (map Right [1..y])) - == expectedBicliqueMap x y - test "rightAdjacencyMap (fromGraph (biclique (map Left [1..x]) (map Right [1..y]))) == " $ \(x :: Int) (y :: Int) -> - (rightAdjacencyMap $ fromGraph $ G.biclique (map Left [1..x]) (map Right [1..y])) - == expectedBicliqueMap y x - - putStrLn "\n============ Bipartite.AdjacencyMap.fromBipartite ============" - test "fromBipartite empty == AM.empty" $ - fromBipartite (empty :: BAII) == AM.empty - test "fromBipartite (leftVertex 1) == AM.vertex (Left 1)" $ - fromBipartite (leftVertex 1 :: BAII) == AM.vertex (Left 1) - test "fromBipartite (rightVertex 1) == AM.vertex (Right 1)" $ - fromBipartite (rightVertex 1 :: BAII) == (AM.vertex (Right 1)) - test "fromBipartite (edge x y) == AM.edges [(Left x, Right y), (Right y, Left x)]" $ \(x :: Int) (y :: Int) -> - fromBipartite (edge x y) == AM.edges [(Left x, Right y), (Right y, Left x)] - test "fromBipartite (toBipartite (AM.edges [(Left x, Right y), (Right y, Left x)])) == AM.edges [(Left x, Right y), (Right y, Left x)]" $ \(x :: Int) (y :: Int) -> - (fromBipartite $ toBipartite (AM.edges [(Left x, Right y), (Right y, Left x)])) == AM.edges [(Left x, Right y), (Right y, Left x)] - test "fromBipartite (edges [(1, 1), (1, 2)]) == " $ - fromBipartite (edges [(1, 1), (1, 2)] :: BAII) - == (AM.edges [(Left 1, Right 1), (Left 1, Right 2), (Right 1, Left 1), (Right 2, Left 1)]) - test "AM.consistent (fromBipartite x) == True" $ \x -> - AM.consistent $ fromBipartite (x :: BAII) - test "fromBipartite (toBipartite (AM.biclique (map Left [1..x]) (map Right [1..y]))) == " $ \(x :: Int) (y :: Int) -> - (fromBipartite $ toBipartite $ AM.biclique (map Left [1..x]) (map Right [1..y])) - == AM.overlay (AM.biclique (map Left [1..x]) (map Right [1..y])) - (AM.biclique (map Right [1..y]) (map Left [1..x])) - - putStrLn "\n============ Bipartite.AdjacencyMap.hasEdge ============" - test "hasEdge x y empty == False" $ \(x :: Int) (y :: Int) -> - not $ hasEdge x y empty - test "hasEdge x y (edge x y) == True" $ \(x :: Int) (y :: Int) -> - hasEdge x y $ edge x y - test "hasEdge 1 2 (fromGraph (edge (Left 1) (Left 2))) == False" $ - not $ hasEdge 1 2 $ fromGraph $ (G.edge (Left 1) (Left 2) :: GII) - test "hasEdge 2 3 (edge 1 2) == False" $ - not $ hasEdge 2 3 $ (edge 1 2 :: BAII) - test "hasEdge x y (overlay z (edge x y)) == True" $ \(z :: BAII) (x :: Int) (y :: Int) -> - hasEdge x y $ overlay z $ edge x y - - putStrLn "\n============ Bipartite.AdjacencyMap.leftAdjacencyMap ============" - test "leftAdjacencyMap empty == Map.empty" $ - leftAdjacencyMap (empty :: BAII) == Map.empty - test "leftAdjacencyMap (leftVertex 1) == Map.singleton 1 Set.empty" $ - leftAdjacencyMap (leftVertex 1 :: BAII) == Map.singleton 1 Set.empty - test "leftAdjacencyMap (rightVertex 1) == Map.empty" $ - leftAdjacencyMap (rightVertex 1 :: BAII) == Map.empty - test "leftAdjacencyMap (edge 1 1) == Map.singleton 1 (Set.singleton 1)" $ - leftAdjacencyMap (edge 1 1 :: BAII) == Map.singleton 1 (Set.singleton 1) - test "leftAdjacencyMap (edge 1 \"a\") == Map.singleton 1 (Set.singleton \"a\")" $ - leftAdjacencyMap (edge 1 "a" :: BAIS) == Map.singleton 1 (Set.singleton "a") - test "leftAdjacencyMap (edges [(1, 1), (1, 2)]) == Map.singleton 1 (Set.fromAscList [1, 2])" $ - leftAdjacencyMap (edges [(1, 1), (1, 2)] :: BAII) == Map.singleton 1 (Set.fromAscList [1, 2]) - - putStrLn "\n============ Bipartite.AdjacencyMap.rightAdjacencyMap ============" - test "rightAdjacencyMap empty == Map.empty" $ - rightAdjacencyMap (empty :: BAII) == Map.empty - test "rightAdjacencyMap (leftVertex 1) == Map.empty" $ - rightAdjacencyMap (leftVertex 1 :: BAII) == Map.empty - test "rightAdjacencyMap (rightVertex 1) == Map.singleton 1 Set.empty" $ - rightAdjacencyMap (rightVertex 1 :: BAII) == Map.singleton 1 Set.empty - test "rightAdjacencyMap (edge 1 1) == Map.singleton 1 (Set.singleton 1)" $ - rightAdjacencyMap (edge 1 1 :: BAII) == Map.singleton 1 (Set.singleton 1) - test "rightAdjacencyMap (edge 1 \"a\") == Map.singleton \"a\" (Set.singleton 1)" $ - rightAdjacencyMap (edge 1 "a" :: BAIS) == Map.singleton "a" (Set.singleton 1) - test "rightAdjacencyMap (edges [(1, 1), (1, 2)]) == Map.fromAscList [(1, Set.singleton 1), (2, Set.singleton 1)]" $ - rightAdjacencyMap (edges [(1, 1), (1, 2)] :: BAII) == Map.fromAscList [(1, Set.singleton 1), (2, Set.singleton 1)] - - putStrLn "\n============ Bipartite.AdjacencyMap.empty ============" - test "isEmpty empty == True" $ - isEmpty empty - test "hasVertex x empty == False" $ \x -> - not $ hasVertex x (empty :: BAII) - test "hasEdge x y empty == False" $ \x y -> - not $ hasEdge x y (empty :: BAII) - test "vertexCount empty == 0" $ - vertexCount (empty :: BAII) == 0 - test "edgeCount empty == 0" $ - edgeCount (empty :: BAII) == 0 - - putStrLn "\n============ Bipartite.AdjacencyMap.leftVertex ============" - test "leftAdjacencyMap (leftVertex 1) == Map.singleton 1 Set.empty" $ - leftAdjacencyMap (leftVertex 1 :: BAII) == Map.singleton 1 Set.empty - test "rightAdjacencyMap (leftVertex 1) == Map.empty" $ - rightAdjacencyMap (leftVertex 1 :: BAII) == Map.empty - test "hasEdge x y (leftVertex x) == False" $ \x y -> - not $ hasEdge x y (leftVertex x :: BAII) - test "hasLeftVertex 1 (leftVertex 1) == True" $ - hasLeftVertex 1 (leftVertex 1 :: BAII) - test "hasRightVertex 1 (leftVertex 1) == False" $ - not $ hasRightVertex 1 (leftVertex 1 :: BAII) - - putStrLn "\n============ Bipartite.AdjacencyMap.rightVertex ============" - test "leftAdjacencyMap (rightVertex 1) == Map.empty" $ - leftAdjacencyMap (rightVertex 1 :: BAII) == Map.empty - test "rightAdjacencyMap (rightVertex 1) == Map.singleton 1 Set.empty" $ - rightAdjacencyMap (rightVertex 1 :: BAII) == Map.singleton 1 Set.empty - test "hasEdge x y (rightVertex y) == False" $ \x y -> - not $ hasEdge x y (rightVertex y :: BAII) - test "hasLeftVertex 1 (rightVertex 1) == False" $ - not $ hasLeftVertex 1 (rightVertex 1 :: BAII) - test "hasRightVertex 1 (rightVertex 1) == True" $ - hasRightVertex 1 (rightVertex 1 :: BAII) - - putStrLn "\n============ Bipartite.AdjacencyMap.vertex ============" - test "vertex (Left 1) == leftVertex 1" $ - vertex (Left 1) == (leftVertex 1 :: BAII) - test "vertex (Right 1) == rightVertex 1" $ - vertex (Right 1) == (rightVertex 1 :: BAII) - test "hasEdge x y (vertex (Left x)) == False" $ \x y -> - not $ hasEdge x y (vertex (Left x) :: BAII) - test "hasEdge x y (vertex (Right y)) == False" $ \x y -> - not $ hasEdge x y (vertex (Right y) :: BAII) - test "vertex (Left 1) == leftVertex 1" $ - vertex (Left 1) == (leftVertex 1 :: BAII) - test "vertex (Right 1) == rightVertex 1" $ - vertex (Right 1) == (rightVertex 1 :: BAII) - - putStrLn "\n============ Bipartite.AdjacencyMap.edge ============" - test "leftAdjacencyMap (edge x y) == Map.singleton x (Set.singleton y)" $ \(x :: Int) (y :: Int) -> - leftAdjacencyMap (edge x y) == Map.singleton x (Set.singleton y) - test "rightAdjacencyMap (edge x y) == Map.singleton y (Set.singleton x)" $ \(x :: Int) (y :: Int) -> - rightAdjacencyMap (edge x y) == Map.singleton y (Set.singleton x) - test "hasEdge x y (edge x y) == True" $ \(x :: Int) (y :: Int) -> - hasEdge x y (edge x y) - test "hasEdge y x (edge x y) == (x == y)" $ \(x :: Int) (y :: Int) -> - hasEdge y x (edge x y) == (x == y) - test "leftAdjacencyMap (edge 1 \"a\") == Map.singleton 1 (Set.singleton \"a\")" $ - leftAdjacencyMap (edge 1 "a" :: BAIS) == Map.singleton 1 (Set.singleton "a") - test "rightAdjacencyMap (edge 1 \"a\") == Map.singleton \"a\" (Set.singleton 1)" $ - rightAdjacencyMap (edge 1 "a" :: BAIS) == Map.singleton "a" (Set.singleton 1) - - putStrLn "\n============ Bipartite.AdjacencyMap.overlay ============" - test "overlay (leftVertex 1) (rightVertex 2) == vertices [1] [2]" $ - overlay (leftVertex 1) (rightVertex 2) == (vertices [1] [2] :: BAII) - test "overlay (leftVertex 1) (rightVertex 1) == vertices [1] [1]" $ - overlay (leftVertex 1) (rightVertex 1) == (vertices [1] [1] :: BAII) - test "isEmpty (overlay x y) == isEmpty x && isEmpty y" $ \(x :: BAII) (y :: BAII) -> - isEmpty (overlay x y) == (isEmpty x && isEmpty y) - test "hasVertex z (overlay x y) == hasVertex z x || hasVertex z y" $ \(x :: BAII) (y :: BAII) z -> - hasVertex z (overlay x y) == hasVertex z x || hasVertex z y - test "vertexCount (overlay x y) >= vertexCount x" $ \(x :: BAII) (y :: BAII) -> - vertexCount (overlay x y) >= vertexCount x - test "vertexCount (overlay x y) <= vertexCount x + vertexCount y" $ \(x :: BAII) (y :: BAII) -> - vertexCount (overlay x y) <= vertexCount x + vertexCount y - test "edgeCount (overlay x y) >= edgeCount x" $ \(x :: BAII) (y :: BAII) -> - edgeCount (overlay x y) >= edgeCount x - test "edgeCount (overlay x y) <= edgeCount x + edgeCount y" $ \(x :: BAII) (y :: BAII) -> - edgeCount (overlay x y) <= edgeCount x + edgeCount y - test "hasEdge x y (overlay (edge x y) z) == True" $ \(x :: Int) (y :: Int) (z :: BAII) -> - hasEdge x y (overlay (edge x y) z) - - putStrLn "\n============ Bipartite.AdjacencyMap.connect ============" - test "connect (leftVertex 1) (rightVertex 2) == edge 1 2" $ - connect (leftVertex 1) (rightVertex 2) == (edge 1 2 :: BAII) - test "connect (leftVertex 1) (rightVertex 1) == edge 1 1" $ - connect (leftVertex 1) (rightVertex 1) == (edge 1 1 :: BAII) - test "connect (leftVertex 1) (leftVertex 2) == vertices [1, 2] []" $ - connect (leftVertex 1) (leftVertex 2) == (vertices [1, 2] [] :: BAII) - test "connect (vertices [1] [4]) (vertices [2] [3]) == edges [(1, 3), (2, 4)]" $ - connect (vertices [1] [4] :: BAII) (vertices [2] [3] :: BAII) == edges [(1, 3), (2, 4)] - test "isEmpty (connect x y) == isEmpty x && isEmpty y" $ \(x :: BAII) (y :: BAII) -> - isEmpty (connect x y) == (isEmpty x && isEmpty y) - test "hasVertex z (connect x y) == hasVertex z x || hasVertex z y" $ \(x :: BAII) (y :: BAII) z -> - hasVertex z (connect x y) == (hasVertex z x || hasVertex z y) - test "vertexCount (connect x y) >= vertexCount x" $ \(x :: BAII) (y :: BAII) -> - vertexCount (connect x y) >= vertexCount x - test "vertexCount (connect x y) <= vertexCount x + vertexCount y" $ \(x :: BAII) (y :: BAII) -> - vertexCount (connect x y) <= vertexCount x + vertexCount y - test "vertexCount (connect x y) == vertexCount (overlay x y)" $ \(x :: BAII) (y :: BAII) -> - vertexCount (connect x y) == vertexCount (overlay x y) - test "edgeCount (connect x y) >= edgeCount x" $ \(x :: BAII) (y :: BAII) -> - edgeCount (connect x y) >= edgeCount x - test "edgeCount (connect x y) >= leftVertexCount x * rightVertexCount y" $ \(x :: BAII) (y :: BAII) -> - edgeCount (connect x y) >= leftVertexCount x * rightVertexCount y - test "edgeCount (connect x y) <= leftVertexCount x * rightVertexCount y + rightVertexCount x * leftVertexCount y + edgeCount x + edgeCount y" $ \(x :: BAII) (y :: BAII) -> - edgeCount (connect x y) <= leftVertexCount x * rightVertexCount y + rightVertexCount x * leftVertexCount y + edgeCount x + edgeCount y - - putStrLn "\n============ Bipartite.AdjacencyMap.vertices ============" - test "vertices [] [] == empty" $ - vertices [] [] == (empty :: BAII) - test "vertices [1] [] == leftVertex 1" $ - vertices [1] [] == (leftVertex 1 :: BAII) - test "vertices [] [1] == rightVertex 1" $ - vertices [] [1] == (rightVertex 1 :: BAII) - test "hasEdge x y (vertices [x] [y]) == False" $ \(x :: Int) (y :: Int) -> - not $ hasEdge x y (vertices [x] [y]) - test "hasLeftVertex x (vertices ys zs) == elem x ys" $ \(x :: Int) (ys :: [Int]) (zs :: [Int]) -> - hasLeftVertex x (vertices ys zs) == elem x ys - test "hasRightVertex x (vertices ys zs) == elem x zs" $ \(x :: Int) (ys :: [Int]) (zs :: [Int]) -> - hasRightVertex x (vertices ys zs) == elem x zs - - putStrLn "\n============ Bipartite.AdjacencyMap.edges ============" - test "edges [] == empty" $ - edges [] == (empty :: BAII) - test "leftAdjacencyMap (edges [(1, 1), (1, 2)]) == Map.singleton 1 (Set.fromAscList [1, 2])" $ - leftAdjacencyMap (edges [(1, 1), (1, 2)] :: BAII) == Map.singleton 1 (Set.fromAscList [1, 2]) - test "rightAdjacencyMap (edges [(1, 1), (1, 2)]) == Map.fromAscList [(1, Set.singleton 1), (2, Set.singleton 1)]" $ - rightAdjacencyMap (edges [(1, 1), (1, 2)] :: BAII) == Map.fromAscList [(1, Set.singleton 1), (2, Set.singleton 1)] - test "edges [(x, y)] == edge x y" $ \(x :: Int) (y :: Int) -> - edges [(x, y)] == edge x y - test "(edgeCount . edges) x == (length . nub) x" $ \(x :: [(Int, Int)]) -> - (edgeCount . edges) x == (length . nub) x - test "hasEdge x y (edges [(x, y)]) == True" $ \(x :: Int) (y :: Int) -> - hasEdge x y (edges [(x, y)]) - - putStrLn "\n============ Bipartite.AdjacencyMap.overlays ============" - test "overlays [] == empty" $ - overlays [] == (empty :: BAII) - test "overlays [x] == x" $ \(x :: BAII) -> - overlays [x] == x - test "overlays [x, y] == overlay x y" $ \(x :: BAII) (y :: BAII) -> - overlays [x, y] == overlay x y - test "overlays xs == foldr overlay empty xs" $ \(xs :: [BAII]) -> - overlays xs == foldr overlay empty xs - test "isEmpty (overlays xs) == all isEmpty xs" $ \(xs :: [BAII]) -> - isEmpty (overlays xs) == all isEmpty xs - - putStrLn "\n============ Bipartite.AdjacencyMap.connects ============" - test "connects [] == empty" $ - connects [] == (empty :: BAII) - test "connects [x] == x" $ \(x :: BAII) -> - connects [x] == x - test "connects [x, y] == connect x y" $ \(x :: BAII) (y :: BAII) -> - connects [x, y] == connect x y - test "connects xs == foldr connect empty xs" $ \(xs :: [BAII]) -> - connects xs == foldr connect empty xs - test "isEmpty (connects xs) == all isEmpty xs" $ \(xs :: [BAII]) -> - isEmpty (connects xs) == all isEmpty xs - - putStrLn "\n============ Bipartite.AdjacencyMap.isEmpty ============" - test "isEmpty empty == True" $ - isEmpty (empty :: BAII) - test "isEmpty (overlay empty empty) == True" $ - isEmpty (overlay empty empty :: BAII) - test "isEmpty (vertex x) == False" $ \(x :: Either Int Int) -> - not $ isEmpty (vertex x) - test "isEmpty x == (x == empty)" $ \(x :: BAII) -> - isEmpty x == (x == empty) - - putStrLn "\n============ Bipartite.AdjacencyMap.leftVertexCount ============" - test "leftVertexCount empty == 0" $ - leftVertexCount (empty :: BAII) == 0 - test "leftVertexCount (leftVertex 1) == 1" $ - leftVertexCount (leftVertex 1 :: BAII) == 1 - test "leftVertexCount (rightVertex (-2)) == 0" $ - leftVertexCount (rightVertex (-2) :: BAII) == 0 - test "leftVertexCount (edges [(1, 1), (1, 2)]) == 1" $ - leftVertexCount (edges [(1, 1), (1, 2)] :: BAII) == 1 - test "leftVertexCount (edges x) == (length . nub . map fst) x" $ \(x :: [(Int, Int)]) -> - leftVertexCount (edges x) == (length . nub . map fst) x - - putStrLn "\n============ Bipartite.AdjacencyMap.rightVertexCount ============" - test "rightVertexCount empty == 0" $ - rightVertexCount (empty :: BAII) == 0 - test "rightVertexCount (rightVertex (-2)) == 1" $ - rightVertexCount (rightVertex (-2) :: BAII) == 1 - test "rightVertexCount (leftVertex 1) == 0" $ - rightVertexCount (leftVertex 1 :: BAII) == 0 - test "rightVertexCount (edges [(1, 1), (1, 2)]) == 2" $ - rightVertexCount (edges [(1, 1), (1, 2)] :: BAII) == 2 - test "rightVertexCount (edges x) == (length . nub . map snd) x" $ \(x :: [(Int, Int)]) -> - rightVertexCount (edges x) == (length . nub . map snd) x - - putStrLn "\n============ Bipartite.AdjacencyMap.vertexCount ============" - test "vertexCount empty == 0" $ - vertexCount (empty :: BAII) == 0 - test "vertexCount (leftVertex 1) == 1" $ - vertexCount (leftVertex 1 :: BAII) == 1 - test "vertexCount (rightVertex 1) == 1" $ - vertexCount (rightVertex 1 :: BAII) == 1 - test "vertexCount (edges [(1, 1), (1, 2)]) == 3" $ - vertexCount (edges [(1, 1), (1, 2)] :: BAII) == 3 - test "vertexCount x == leftVertexCount x + rightVertexCount x" $ \(x :: BAII) -> - vertexCount x == leftVertexCount x + rightVertexCount x - - putStrLn "\n============ Bipartite.AdjacencyMap.edgeCount ============" - test "edgeCount empty == 0" $ - edgeCount (empty :: BAII) == 0 - test "edgeCount (vertex x) == 0" $ \x -> - edgeCount (vertex x :: BAII) == 0 - test "edgeCount (edge 1 2) == 1" $ - edgeCount (edge 1 2 :: BAII) == 1 - test "edgeCount (edge 1 1) == 1" $ - edgeCount (edge 1 1 :: BAII) == 1 - test "edgeCount (edges x) == (length . nub) x" $ \(x :: [(Int, Int)]) -> - edgeCount (edges x) == (length . nub) x - - putStrLn "\n============ Bipartite.AdjacencyMap.hasLeftVertex ============" - test "hasLeftVertex x empty == False" $ \x -> - not $ hasLeftVertex x (empty :: BAII) - test "hasLeftVertex x (leftVertex x) == True" $ \x -> - hasLeftVertex x (leftVertex x :: BAII) - test "hasLeftVertex x (rightVertex x) == False" $ \x -> - not $ hasLeftVertex x (rightVertex x :: BAII) - test "hasLeftVertex 1 (leftVertex 2) == False" $ - not $ hasLeftVertex 1 (leftVertex 2 :: BAII) - - putStrLn "\n============ Bipartite.AdjacencyMap.hasRightVertex ============" - test "hasRightVertex x empty == False" $ \x -> - not $ hasRightVertex x (empty :: BAII) - test "hasRightVertex x (rightVertex x) == True" $ \x -> - hasRightVertex x (rightVertex x :: BAII) == True - test "hasRightVertex x (leftVertex x) == False" $ \x -> - not $ hasRightVertex x (leftVertex x :: BAII) - test "hasRightVertex 1 (rightVertex 2) == False" $ - not $ hasRightVertex 1 (rightVertex 2 :: BAII) - - putStrLn "\n============ Bipartite.AdjacencyMap.hasVertex ============" - test "hasVertex x empty == False" $ \x -> - not $ hasVertex x (empty :: BAII) - test "hasVertex (Right x) (rightVertex x) == True" $ \x -> - hasVertex (Right x) (rightVertex x :: BAII) - test "hasVertex (Right x) (leftVertex x) == False" $ \x -> - not $ hasVertex (Right x) (leftVertex x :: BAII) - test "hasVertex (Left 1) (leftVertex 2) == False" $ - not $ hasVertex (Left 1) (leftVertex 2 :: BAII) - test "hasVertex (Left x) y == hasLeftVertex x y" $ \x (y :: BAII) -> - hasVertex (Left x) y == hasLeftVertex x y - test "hasVertex (Right x) y == hasRightVertex x y" $ \x (y :: BAII) -> - hasVertex (Right x) y == hasRightVertex x y - - putStrLn "\n============ Bipartite.AdjacencyMap.swap ============" - test "swap empty == empty" $ - swap (empty :: BAII) == empty - test "swap (leftVertex 1) == rightVertex 1" $ - swap (leftVertex 1 :: BAII) == rightVertex 1 - test "swap (vertices ls rs) == (flip vertices) ls rs" $ \(ls :: [Int]) (rs :: [Int]) -> - swap (vertices ls rs) == (flip vertices) ls rs - test "swap (edge 1 \"a\") == edge \"a\" 1" $ - swap (edge 1 "a" :: BAIS) == edge "a" 1 - test "swap (edges x) == (edges . map Data.Tuple.swap) x" $ \(x :: [(Int, Int)]) -> - swap (edges x) == (edges . map Data.Tuple.swap) x - test "swap (swap x) == x" $ \x -> - swap (swap x :: BAII) == x - - putStrLn "\n============ Bipartite.AdjacencyMap.leftVertexList ============" - test "leftVertexList empty == []" $ - leftVertexList (empty :: BAII) == [] - test "leftVertexList (leftVertex 1) == [1]" $ - leftVertexList (leftVertex 1 :: BAII) == [1] - test "leftVertexList (rightVertex 1) == []" $ - leftVertexList (rightVertex 1 :: BAII) == [] - test "leftVertexList (vertices vs us) == (nub . sort) vs" $ \(vs :: [Int]) (us :: [Int]) -> - leftVertexList (vertices vs us) == (nub . sort) vs - test "isSorted (leftVertexList x) == True" $ \(x :: BAII) -> - isSorted $ leftVertexList x - - putStrLn "\n============ Bipartite.AdjacencyMap.rightVertexList ============" - test "rightVertexList empty == []" $ - rightVertexList (empty :: BAII) == [] - test "rightVertexList (leftVertex 1) == []" $ - rightVertexList (leftVertex 1 :: BAII) == [] - test "rightVertexList (rightVertex 1) == [1]" $ - rightVertexList (rightVertex 1 :: BAII) == [1] - test "rightVertexList (vertices vs us) == (nub . sort) us" $ \(vs :: [Int]) (us :: [Int]) -> - rightVertexList (vertices vs us) == (nub . sort) us - test "isSorted (rightVertexList x) == True" $ \(x :: BAII) -> - isSorted $ rightVertexList x - - putStrLn "\n============ Bipartite.AdjacencyMap.vertexList ============" - test "vertexList empty == []" $ - vertexList (empty :: BAII) == [] - test "vertexList (vertex x) == [x]" $ \x -> - vertexList (vertex x :: BAII) == [x] - test "vertexList (vertices (lefts vs) (rights vs)) == nub (sort vs)" $ \(vs :: [Either Int Int]) -> - vertexList (vertices (lefts vs) (rights vs)) == nub (sort vs) - test "isSorted (vertexList x) == True" $ \(x :: BAII) -> - isSorted $ vertexList x - - putStrLn "\n============ Bipartite.AdjacencyMap.edgeList ============" - test "edgeList empty == []" $ - edgeList (empty :: BAII) == [] - test "edgeList (leftVertex 1) == []" $ - edgeList (leftVertex 1 :: BAII) == [] - test "edgeList (rightVertex 1) == []" $ - edgeList (rightVertex 1 :: BAII) == [] - test "edgeList (edge 1 1) == [(1, 1)]" $ - edgeList (edge 1 1 :: BAII) == [(1, 1)] - test "edgeList (edge 1 2) == [(1, 2)]" $ - edgeList (edge 1 2 :: BAII) == [(1, 2)] - test "(edgeList . edges) x == (nub . sort) x" $ \(x :: [(Int, Int)]) -> - (edgeList . edges) x == (nub . sort) x - - putStrLn "\n============ Bipartite.AdjacencyMap.leftVertexSet ============" - test "leftVertexSet empty == Set.empty" $ - leftVertexSet (empty :: BAII) == Set.empty - test "leftVertexSet (leftVertex 1) == Set.singleton" $ - leftVertexSet (leftVertex 1 :: BAII) == Set.singleton 1 - test "leftVertexSet (rightVertex 1) == Set.empty" $ - leftVertexSet (rightVertex 1 :: BAII) == Set.empty - test "leftVertexSet (vertices vs us) == Set.fromList vs" $ \(vs :: [Int]) (us :: [Int]) -> - leftVertexSet (vertices vs us) == Set.fromList vs - - putStrLn "\n============ Bipartite.AdjacencyMap.rightVertexSet ============" - test "rightVertexSet empty == Set.empty" $ - rightVertexSet (empty :: BAII) == Set.empty - test "rightVertexSet (leftVertex 1) == Set.singleton 1" $ - rightVertexSet (leftVertex 1 :: BAII) == Set.empty - test "rightVertexSet (rightVertex 1) == Set.empty" $ - rightVertexSet (rightVertex 1 :: BAII) == Set.singleton 1 - test "(rightVertexSet . vertices []) vs == Set.fromList vs" $ \(vs :: [Int]) (us :: [Int]) -> - rightVertexSet (vertices vs us) == Set.fromList us - - putStrLn "\n============ Bipartite.AdjacencyMap.vertexSet ============" - test "vertexSet empty == Set.empty" $ - vertexSet (empty :: BAII) == Set.empty - test "vertexSet (leftVertex 1) == Set.singleton 1" $ - vertexSet (leftVertex 1 :: BAII) == Set.singleton (Left 1) - test "vertexSet (rightVertex 1) == Set.empty" $ - vertexSet (rightVertex 1 :: BAII) == Set.singleton (Right 1) - test "vertexSet (vertices (lefts vs) (rights vs)) == Set.fromList vs" $ \(vs :: [Either Int Int]) -> - vertexSet (vertices (lefts vs) (rights vs)) == Set.fromList vs - - putStrLn "\n============ Bipartite.AdjacencyMap.edgeSet ============" - test "edgeSet empty == Set.empty" $ - edgeSet (empty :: BAII) == Set.empty - test "edgeSet (leftVertex 1) == Set.empty" $ - edgeSet (leftVertex 1 :: BAII) == Set.empty - test "edgeSet (rightVertex 1) == Set.empty" $ - edgeSet (rightVertex 1 :: BAII) == Set.empty - test "edgeSet (edge 1 1) == Set.singleton (1, 1)" $ - edgeSet (edge 1 1 :: BAII) == Set.singleton (1, 1) - test "edgeSet (edge 1 2) == Set.singleton (1, 2)" $ - edgeSet (edge 1 2 :: BAII) == Set.singleton (1, 2) - test "edgeSet (edges x) == Set.fromList x" $ \(x :: [(Int, Int)]) -> - edgeSet (edges x) == Set.fromList x - - putStrLn "\n============ Num (Bipartite.AdjacencyMap a b) ============" - test "0 == rightVertex 0" $ - (0 :: BAII) == rightVertex 0 - test "swap 1 == leftVertex 1" $ - (swap 1 :: BAII) == leftVertex 1 - test "(swap 1) + 2 == vertices [1] [2]" $ - ((swap 1) + 2 :: BAII) == vertices [1] [2] - test "(swap 1) + 2 * (swap 3) == overlay (leftVertex 1) (edge 3 2)" $ - ((swap 1) + 2 * (swap 3) :: BAII) == overlay (leftVertex 1) (edge 3 2) - test "(swap 1) * (2 + (swap 3)) == connect (leftVertex 1) (vertices [3] [2])" $ - (swap 1) * (2 + (swap 3) :: BAII) == connect (leftVertex 1) (vertices [3] [2]) - - putStrLn "\n============ Eq (Bipartite.AdjacencyMap a b) ============" - test "(x == y) == ((leftAdjacencyMap x == leftAdjacencyMap y) && (rightAdjacencyMap x == rightAdjacencyMap y))" $ \(x :: BAII) (y :: BAII) -> - (x == y) == ((leftAdjacencyMap x == leftAdjacencyMap y) && (rightAdjacencyMap x == rightAdjacencyMap y)) - test " x + y == y + x" $ \(x :: BAII) (y :: BAII) -> - x + y == y + x - test "x + (y + z) == (x + y) + z" $ \(x :: BAII) (y :: BAII) (z :: BAII) -> - x + (y + z) == (x + y) + z - test " x * empty == x" $ \(x :: BAII) -> - x * empty == x - test " empty * x == x" $ \(x :: BAII) -> - empty * x == x - test " x * y == y * x" $ \(x :: BAII) (y :: BAII) -> - x * y == y * x - test "x * (y * z) == (x * y) * z" $ \(x :: BAII) (y :: BAII) (z :: BAII) -> - x * (y * z) == (x * y) * z - test "x * (y + z) == x * y + x * z" $ \(x :: BAII) (y :: BAII) (z :: BAII) -> - x * (y + z) == x * (y + z) - test "(x + y) * z == x * z + y * z" $ \(x :: BAII) (y :: BAII) (z :: BAII) -> - (x + y) * z == x * z + y * z - test " x * y * z == x * y + x * z + y * z" $ \(x :: BAII) (y :: BAII) (z :: BAII) -> - x * y * z == x * y + x * z + y * z - test " (leftVertex x) * (leftVertex y) == (leftVertex x) + (leftVertex y)" $ \(x :: Int) (y :: Int) -> - ((leftVertex x) * (leftVertex y) :: BAII) == (leftVertex x) + (leftVertex y) - test "(rightVertex x) * (rightVertex y) == (rightVertex x) + (rightVertex y)" $ \(x :: Int) (y :: Int) -> - ((rightVertex x) * (rightVertex y) :: BAII) == (rightVertex x) + (rightVertex y) - test " x + empty == x" $ \(x :: BAII) -> - x + empty == x - test " empty + x == x" $ \(x :: BAII) -> - empty + x == x - test " x + x == x" $ \(x :: BAII) -> - x + x == x - test "x * y + x + y == x * y" $ \(x :: BAII) (y :: BAII) -> - x * y + x + y == x * y - test " x * x * x == x * x" $ \(x :: BAII) -> - x * x * x == x * x - - putStrLn "\n============ Show (Bipartite.AdjacencyMap a b) ============" - test "show (empty) == \"empty\"" $ - show (empty :: BAII) == "empty" - test "show 1 == \"rightVertex 1\"" $ - show (1 :: BAII) == "rightVertex 1" - test "show (swap 2) == \"leftVertex 2\"" $ - show (swap 2 :: BAII) == "leftVertex 2" - test "show 1 + 2 == \"vertices [] [1,2]\"" $ - show (1 + 2 :: BAII) == "vertices [] [1,2]" - test "show (swap (1 + 2)) == \"vertices [1,2] []\"" $ - show (swap (1 + 2) :: BAII) == "vertices [1,2] []" - test "show (swap 1 * 2) == \"edge 1 2\"" $ - show (swap 1 * 2 :: BAII) == "edge 1 2" - test "show (swap 1 * 2 * swap 3) == \"edges [(1,2),(3,2)]\"" $ - show (swap 1 * 2 * swap 3 :: BAII) == "edges [(1,2),(3,2)]" - test "show (swap 1 * 2 + swap 3) == \"overlay (leftVertex 3) (edge 1 2)\"" $ - show (swap 1 * 2 + swap 3 :: BAII) == "overlay (leftVertex 3) (edge 1 2)" - test "show (swap 1 * 2 + swap 3 + 4) == \"overlay (vertices [3] [4]) (edge 1 2)\"" $ - show (swap 1 * 2 + swap 3 + 4 :: BAII) == "overlay (vertices [3] [4]) (edge 1 2)" - test "show ((3 + swap 2) * (2 + swap 0)) == \"edges [(2,2),(3,0)]\"" $ - show ((3 + swap 2) * (2 + swap 0) :: BAII) == "edges [(0,3),(2,2)]" - - putStrLn "\n============ Bipartite.AdjacencyMap.circuit ============" - test "circuit [] == empty" $ - circuit [] == (empty :: BAII) - test "circuit [(x, y)] == edge x y" $ \(x :: Int) (y :: Int) -> - circuit [(x, y)] == edge x y - test "circuit [(x, y), (z, w)] == biclique [x, z] [y, w]" $ \(x :: Int) (y :: Int) (z :: Int) (w :: Int) -> - circuit [(x, y), (z, w)] == biclique [x, z] [y, w] - test "circuit [(1, 2), (3, 4), (5, 6)] == swap 1 * (2 + 6) + swap 3 * (2 + 4) + swap 5 * (4 + 6)" $ - circuit [(1, 2), (3, 4), (5, 6)] == (swap 1 * (2 + 6) + swap 3 * (2 + 4) + swap 5 * (4 + 6) :: BAII) - test "circuit (reverse x) == swap (circuit (map swap x))" $ \(x :: [(Int, Int)]) -> - circuit (reverse x) == swap (circuit (map Data.Tuple.swap x)) - - putStrLn "\n============ Bipartite.AdjacencyMap.biclique ============" - test "biclique [] [] == empty" $ - biclique [] [] == (empty :: BAII) - test "biclique xs [] == vertices xs []" $ \(xs :: [Int]) -> - biclique xs [] == (vertices xs [] :: BAII) - test "biclique [] ys == vertices [] ys" $ \(ys :: [Int]) -> - biclique [] ys == (vertices [] ys :: BAII) - test "biclique xs ys == connect (vertices xs []) (vertices [] ys)" $ \(xs :: [Int]) (ys :: [Int]) -> - biclique xs ys == connect (vertices xs []) (vertices [] ys) - - putStrLn "\n============ Bipartite.AdjacencyMap.detectParts ============" - test "detectParts empty == Right empty" $ - detectParts (AM.empty :: AI) == Right empty - test "detectParts (vertex 1) == Right (leftVertex 1)" $ - detectParts (AM.vertex 1 :: AI) == Right (leftVertex 1) - test "detectParts (edge 1 1) == Left [1]" $ - detectParts (AM.edge 1 1 :: AI) == Left [1] - test "detectParts (edge 1 2) == Right (edge 1 2)" $ - detectParts (AM.edge 1 2 :: AI) == Right (edge 1 2) - test "detectParts (edge 0 (-1)) == Right (edge (-1) 0)" $ - detectParts (AM.edge 0 (-1) :: AI) == Right (edge (-1) 0) - test "detectParts (1 * (2 + 3)) == Right (edges [(1, 2), (1, 3)])" $ - detectParts (1 * (2 + 3) :: AI) == Right (edges [(1, 2), (1, 3)]) - test "detectParts ((1 + 3) * (2 + 4) + 6 * 5) == Right (swap (1 + 3) * (2 + 4) + swap 5 * 6" $ - detectParts ((1 + 3) * (2 + 4) + 6 * 5 :: AI) == Right (swap (1 + 3) * (2 * 4) + swap 5 * 6) - test "detectParts ((1 + 2) * (3 + 4) * (5 + 6)) == Left [1, 3, 2, 4, 5]" $ - detectParts ((1 + 2) * (3 + 4) * (5 + 6) :: AI) == Left [1, 3, 2, 4, 5] - test "detectParts ((1 + 2) * (3 + 4) + (3 + 4) * 5) == Right (swap (1 + 2) * (3 + 4) + swap 5 * (3 + 4))" $ - detectParts ((1 + 2) * (3 + 4) + (3 + 4) * 5 :: AI) == Right (swap (1 + 2) * (3 + 4) + swap 5 * (3 + 4)) - test "detectParts (1 * 2 * 3) == Left [2, 3, 1]" $ - detectParts (1 * 2 * 3 :: AI) == Left [1, 2, 3] - test "detectParts ((1 * 3 * 4) + 2 * (1 + 2)) == Left [2]" $ - detectParts ((1 * 3 * 4) + 2 * (1 + 2) :: AI) == Left [2] - test "detectParts (clique [1..10]) == Left [1, 2, 3]" $ - detectParts (AM.clique [1..10] :: AI) == Left [1, 2, 3] - test "detectParts (circuit [1..11]) == Left [1..11]" $ - detectParts (AM.circuit [1..11] :: AI) == Left [1..11] - test "detectParts (circuit [1..10]) == Right (circuit [(2 * x - 1, 2 * x) | x <- [1..5]])" $ - detectParts (AM.circuit [1..10] :: AI) == Right (circuit [(2 * x - 1, 2 * x) | x <- [1..5]]) - test "detectParts (biclique [] xs) == Right (vertices xs [])" $ \(xs :: [Int]) -> - detectParts (AM.biclique [] xs :: AI) == Right (vertices xs []) - test "detectParts (biclique (map Left (x:xs)) (map Right ys)) == Right (biclique (map Left (x:xs)) (map Right ys))" $ \(x :: Int) (xs :: [Int]) (ys :: [Int]) -> - detectParts (AM.biclique (map Left (x:xs)) (map Right ys)) == Right (biclique (map Left (x:xs)) (map Right ys)) - test "isRight (detectParts (star x ys)) == not (elem x ys)" $ \(x :: Int) (ys :: [Int]) -> - isRight (detectParts (AM.star x ys)) == (not $ elem x ys) - test "isRight (detectParts (fromBipartite (toBipartite x))) == True" $ \(x :: AII) -> - isRight (detectParts (fromBipartite (toBipartite x))) - test "((all ((flip Set.member) $ edgeSet $ symmetricClosure x) . edgeSet) <$> detectParts x) /= Right False" $ \(x :: AI) -> - ((all ((flip Set.member) $ AM.edgeSet $ AM.symmetricClosure x) . edgeSet) <$> detectParts x) /= Right False - test "(Set.map $ fromEither) <$> (vertexSet <$> (detectParts (fromBipartite (toBipartite x)))) == Right (vertexSet x)" $ \(x :: AII) -> - ((Set.map $ fromEither) <$> (vertexSet <$> (detectParts (fromBipartite (toBipartite x))))) == Right (AM.vertexSet x) - test "fromEither (bimap ((flip Set.isSubsetOf) (vertexSet x) . Set.fromList) (const True) (detectParts x)) == True" $ \(x :: AI) -> - fromEither (bimap ((flip Set.isSubsetOf) (AM.vertexSet x) . Set.fromList) (const True) (detectParts x)) - test "fromEither (bimap ((flip Set.isSubsetOf) (edgeSet (symmetricClosure x)) . AM.edgeSet . circuit) (const True) (detectParts x)) == True" $ \(x :: AI) -> - fromEither (bimap ((flip Set.isSubsetOf) (AM.edgeSet (AM.symmetricClosure x)) . AM.edgeSet . AM.circuit) (const True) (detectParts x)) - test "fromEither (bimap (((==) 1) . ((flip mod) 2) . length) (const True) (detectParts x)) == True" $ \(x :: AI) -> - fromEither (bimap (((==) 1) . ((flip mod) 2) . length) (const True) (detectParts x)) - -expectedBicliqueMap :: Int -> Int -> Map.Map Int (Set.Set Int) -expectedBicliqueMap n m = Map.fromAscList [ (u, Set.fromAscList [1..m]) | u <- [1..n] ] - -isSorted :: Ord a => [a] -> Bool -isSorted xs = and $ zipWith (<=) xs $ tail xs - -fromEither :: Either a a -> a -fromEither (Left x) = x -fromEither (Right y) = y - -parity :: Int -> Either Int Int -parity x | x `mod` 2 == 1 = Left x - | otherwise = Right x diff --git a/test/Algebra/Graph/Test/Bipartite/Undirected/AdjacencyMap.hs b/test/Algebra/Graph/Test/Bipartite/Undirected/AdjacencyMap.hs new file mode 100644 index 000000000..11ab07ce9 --- /dev/null +++ b/test/Algebra/Graph/Test/Bipartite/Undirected/AdjacencyMap.hs @@ -0,0 +1,628 @@ +{-# LANGUAGE ViewPatterns #-} +----------------------------------------------------------------------------- +-- | +-- Module : Algebra.Graph.Test.Bipartite.Undirected.AdjacencyMap +-- Copyright : (c) Andrey Mokhov 2016-2020 +-- License : MIT (see the file LICENSE) +-- Maintainer : andrey.mokhov@gmail.com +-- Stability : experimental +-- +-- Testsuite for "Algebra.Graph.Bipartite.Undirected.AdjacencyMap". +----------------------------------------------------------------------------- +module Algebra.Graph.Test.Bipartite.Undirected.AdjacencyMap ( + -- * Testsuite + testBipartiteUndirectedAdjacencyMap + ) where + +import Algebra.Graph.Bipartite.Undirected.AdjacencyMap +import Algebra.Graph.Test +import Data.Either +import Data.Either.Extra +import Data.List +import Data.Map.Strict (Map) +import Data.Set (Set) + +import qualified Algebra.Graph.AdjacencyMap as AM +import qualified Algebra.Graph.Bipartite.Undirected.AdjacencyMap as B +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set +import qualified Data.Tuple + +type AI = AM.AdjacencyMap Int +type AII = AM.AdjacencyMap (Either Int Int) +type BAII = AdjacencyMap Int Int + +testBipartiteUndirectedAdjacencyMap :: IO () +testBipartiteUndirectedAdjacencyMap = do + -- Help with type inference by shadowing overly polymorphic functions + let consistent :: BAII -> Bool + consistent = B.consistent + show :: BAII -> String + show = Prelude.show + leftAdjacencyMap :: BAII -> Map Int (Set Int) + leftAdjacencyMap = B.leftAdjacencyMap + rightAdjacencyMap :: BAII -> Map Int (Set Int) + empty :: BAII + empty = B.empty + vertex :: Either Int Int -> BAII + vertex = B.vertex + leftVertex :: Int -> BAII + leftVertex = B.leftVertex + rightVertex :: Int -> BAII + rightVertex = B.rightVertex + edge :: Int -> Int -> BAII + edge = B.edge + rightAdjacencyMap = B.rightAdjacencyMap + isEmpty :: BAII -> Bool + isEmpty = B.isEmpty + hasLeftVertex :: Int -> BAII -> Bool + hasLeftVertex = B.hasLeftVertex + hasRightVertex :: Int -> BAII -> Bool + hasRightVertex = B.hasRightVertex + hasVertex :: Either Int Int -> BAII -> Bool + hasVertex = B.hasVertex + hasEdge :: Int -> Int -> BAII -> Bool + hasEdge = B.hasEdge + vertexCount :: BAII -> Int + vertexCount = B.vertexCount + edgeCount :: BAII -> Int + edgeCount = B.edgeCount + vertices :: [Int] -> [Int] -> BAII + vertices = B.vertices + edges :: [(Int, Int)] -> BAII + edges = B.edges + overlays :: [BAII] -> BAII + overlays = B.overlays + connects :: [BAII] -> BAII + connects = B.connects + swap :: BAII -> BAII + swap = B.swap + toBipartite :: AII -> BAII + toBipartite = B.toBipartite + toBipartiteWith :: Ord a => (a -> Either Int Int) -> AM.AdjacencyMap a -> BAII + toBipartiteWith = B.toBipartiteWith + fromBipartite :: BAII -> AII + fromBipartite = B.fromBipartite + biclique :: [Int] -> [Int] -> BAII + biclique = B.biclique + + putStrLn "\n============ Bipartite.Undirected.AdjacencyMap.consistent ============" + test "consistent empty == True" $ + consistent empty == True + test "consistent (vertex x) == True" $ \x -> + consistent (vertex x) == True + test "consistent (edge x y) == True" $ \x y -> + consistent (edge x y) == True + test "consistent (edges x) == True" $ \x -> + consistent (edges x) == True + test "consistent (toBipartite x) == True" $ \x -> + consistent (toBipartite x) == True + test "consistent (swap x) == True" $ \x -> + consistent (swap x) == True + test "consistent (biclique xs ys) == True" $ \xs ys -> + consistent (biclique xs ys) == True + test "consistent (circuit xs) == True" $ \xs -> + consistent (circuit xs) == True + + putStrLn "\n============ Bipartite.Undirected.AdjacencyMap.leftAdjacencyMap ============" + test "leftAdjacencyMap empty == Map.empty" $ + leftAdjacencyMap empty == Map.empty + test "leftAdjacencyMap (leftVertex x) == Map.singleton x Set.empty" $ \x -> + leftAdjacencyMap (leftVertex x) == Map.singleton x Set.empty + test "leftAdjacencyMap (rightVertex x) == Map.empty" $ \x -> + leftAdjacencyMap (rightVertex x) == Map.empty + test "leftAdjacencyMap (edge x y) == Map.singleton x (Set.singleton y)" $ \x y -> + leftAdjacencyMap (edge x y) == Map.singleton x (Set.singleton y) + + putStrLn "\n============ Bipartite.Undirected.AdjacencyMap.rightAdjacencyMap ============" + test "rightAdjacencyMap empty == Map.empty" $ + rightAdjacencyMap empty == Map.empty + test "rightAdjacencyMap (leftVertex x) == Map.empty" $ \x -> + rightAdjacencyMap (leftVertex x) == Map.empty + test "rightAdjacencyMap (rightVertex x) == Map.singleton x Set.empty" $ \x -> + rightAdjacencyMap (rightVertex x) == Map.singleton x Set.empty + test "rightAdjacencyMap (edge x y) == Map.singleton y (Set.singleton x)" $ \x y -> + rightAdjacencyMap (edge x y) == Map.singleton y (Set.singleton x) + + putStrLn "\n============ Bipartite.Undirected.AdjacencyMap.Num ============" + test "0 == rightVertex 0" $ + 0 == rightVertex 0 + test "swap 1 == leftVertex 1" $ + swap 1 == leftVertex 1 + test "swap 1 + 2 == vertices [1] [2]" $ + swap 1 + 2 == vertices [1] [2] + test "swap 1 * 2 == edge 1 2" $ + swap 1 * 2 == edge 1 2 + test "swap 1 + 2 * swap 3 == overlay (leftVertex 1) (edge 3 2)" $ + swap 1 + 2 * swap 3 == overlay (leftVertex 1) (edge 3 2) + test "swap 1 * (2 + swap 3) == connect (leftVertex 1) (vertices [3] [2])" $ + swap 1 * (2 + swap 3) == connect (leftVertex 1) (vertices [3] [2]) + + putStrLn "\n============ Bipartite.Undirected.AdjacencyMap.Eq ============" + test "(x == y) == (leftAdjacencyMap x == leftAdjacencyMap y && rightAdjacencyMap x == rightAdjacencyMap y)" $ \(x :: BAII) (y :: BAII) -> + (x == y) == (leftAdjacencyMap x == leftAdjacencyMap y && rightAdjacencyMap x == rightAdjacencyMap y) + + putStrLn "" + test " x + y == y + x" $ \(x :: BAII) y -> + x + y == y + x + test "x + (y + z) == (x + y) + z" $ \(x :: BAII) y z -> + x + (y + z) == (x + y) + z + test " x * empty == x" $ \(x :: BAII) -> + x * empty == x + test " empty * x == x" $ \(x :: BAII) -> + empty * x == x + test " x * y == y * x" $ \(x :: BAII) y -> + x * y == y * x + test "x * (y * z) == (x * y) * z" $ size10 $ \(x :: BAII) y z -> + x * (y * z) == (x * y) * z + test "x * (y + z) == x * y + x * z" $ size10 $ \(x :: BAII) y z -> + x * (y + z) == x * (y + z) + test "(x + y) * z == x * z + y * z" $ size10 $ \(x :: BAII) y z -> + (x + y) * z == x * z + y * z + test " x * y * z == x * y + x * z + y * z" $ size10 $ \(x :: BAII) y z -> + x * y * z == x * y + x * z + y * z + test " x + empty == x" $ \(x :: BAII) -> + x + empty == x + test " empty + x == x" $ \(x :: BAII) -> + empty + x == x + test " x + x == x" $ \(x :: BAII) -> + x + x == x + test "x * y + x + y == x * y" $ \(x :: BAII) (y :: BAII) -> + x * y + x + y == x * y + test " x * x * x == x * x" $ size10 $ \(x :: BAII) -> + x * x * x == x * x + + putStrLn "" + test " leftVertex x * leftVertex y == leftVertex x + leftVertex y " $ \(x :: Int) y -> + leftVertex x * leftVertex y == leftVertex x + leftVertex y + test "rightVertex x * rightVertex y == rightVertex x + rightVertex y" $ \(x :: Int) y -> + rightVertex x * rightVertex y == rightVertex x + rightVertex y + + putStrLn "\n============ Bipartite.Undirected.AdjacencyMap.Show ============" + test "show empty == \"empty\"" $ + show empty == "empty" + test "show 1 == \"rightVertex 1\"" $ + show 1 == "rightVertex 1" + test "show (swap 2) == \"leftVertex 2\"" $ + show (swap 2) == "leftVertex 2" + test "show 1 + 2 == \"vertices [] [1,2]\"" $ + show (1 + 2) == "vertices [] [1,2]" + test "show (swap (1 + 2)) == \"vertices [1,2] []\"" $ + show (swap (1 + 2)) == "vertices [1,2] []" + test "show (swap 1 * 2) == \"edge 1 2\"" $ + show (swap 1 * 2) == "edge 1 2" + test "show (swap 1 * 2 * swap 3) == \"edges [(1,2),(3,2)]\"" $ + show (swap 1 * 2 * swap 3) == "edges [(1,2),(3,2)]" + test "show (swap 1 * 2 + swap 3) == \"overlay (leftVertex 3) (edge 1 2)\"" $ + show (swap 1 * 2 + swap 3) == "overlay (leftVertex 3) (edge 1 2)" + + putStrLn "\n============ Bipartite.Undirected.AdjacencyMap.empty ============" + test "isEmpty empty == True" $ + isEmpty empty == True + test "leftAdjacencyMap empty == Map.empty" $ + leftAdjacencyMap empty == Map.empty + test "rightAdjacencyMap empty == Map.empty" $ + rightAdjacencyMap empty == Map.empty + test "hasVertex x empty == False" $ \x -> + hasVertex x empty == False + + putStrLn "\n============ Bipartite.Undirected.AdjacencyMap.leftVertex ============" + test "leftAdjacencyMap (leftVertex x) == Map.singleton x Set.empty" $ \x -> + leftAdjacencyMap (leftVertex x) == Map.singleton x Set.empty + test "rightAdjacencyMap (leftVertex x) == Map.empty" $ \x -> + rightAdjacencyMap (leftVertex x) == Map.empty + test "hasLeftVertex x (leftVertex y) == (x == y)" $ \x y -> + hasLeftVertex x (leftVertex y) == (x == y) + test "hasRightVertex x (leftVertex y) == False" $ \x y -> + hasRightVertex x (leftVertex y) == False + test "hasEdge x y (leftVertex z) == False" $ \x y z -> + hasEdge x y (leftVertex z) == False + + putStrLn "\n============ Bipartite.Undirected.AdjacencyMap.rightVertex ============" + test "leftAdjacencyMap (rightVertex x) == Map.empty" $ \x -> + leftAdjacencyMap (rightVertex x) == Map.empty + test "rightAdjacencyMap (rightVertex x) == Map.singleton x Set.empty" $ \x -> + rightAdjacencyMap (rightVertex x) == Map.singleton x Set.empty + test "hasLeftVertex x (rightVertex y) == False" $ \x y -> + hasLeftVertex x (rightVertex y) == False + test "hasRightVertex x (rightVertex y) == (x == y)" $ \x y -> + hasRightVertex x (rightVertex y) == (x == y) + test "hasEdge x y (rightVertex z) == False" $ \x y z -> + hasEdge x y (rightVertex z) == False + + putStrLn "\n============ Bipartite.Undirected.AdjacencyMap.vertex ============" + test "vertex (Left x) == leftVertex x" $ \x -> + vertex (Left x) == leftVertex x + test "vertex (Right x) == rightVertex x" $ \x -> + vertex (Right x) == rightVertex x + + putStrLn "\n============ Bipartite.Undirected.AdjacencyMap.edge ============" + test "edge x y == connect (leftVertex x) (rightVertex y)" $ \x y -> + edge x y == connect (leftVertex x) (rightVertex y) + test "leftAdjacencyMap (edge x y) == Map.singleton x (Set.singleton y)" $ \x y -> + leftAdjacencyMap (edge x y) == Map.singleton x (Set.singleton y) + test "rightAdjacencyMap (edge x y) == Map.singleton y (Set.singleton x)" $ \x y -> + rightAdjacencyMap (edge x y) == Map.singleton y (Set.singleton x) + test "hasEdge x y (edge x y) == True" $ \x y -> + hasEdge x y (edge x y) == True + test "hasEdge 1 2 (edge 2 1) == False" $ + hasEdge 1 2 (edge 2 1) == False + + putStrLn "\n============ Bipartite.Undirected.AdjacencyMap.overlay ============" + test "isEmpty (overlay x y) == isEmpty x && isEmpty y" $ \x y -> + isEmpty (overlay x y) ==(isEmpty x && isEmpty y) + test "hasVertex z (overlay x y) == hasVertex z x || hasVertex z y" $ \x y z -> + hasVertex z (overlay x y) ==(hasVertex z x || hasVertex z y) + test "vertexCount (overlay x y) >= vertexCount x" $ \x y -> + vertexCount (overlay x y) >= vertexCount x + test "vertexCount (overlay x y) <= vertexCount x + vertexCount y" $ \x y -> + vertexCount (overlay x y) <= vertexCount x + vertexCount y + test "edgeCount (overlay x y) >= edgeCount x" $ \x y -> + edgeCount (overlay x y) >= edgeCount x + test "edgeCount (overlay x y) <= edgeCount x + edgeCount y" $ \x y -> + edgeCount (overlay x y) <= edgeCount x + edgeCount y + + putStrLn "\n============ Bipartite.Undirected.AdjacencyMap.connect ============" + test "connect (leftVertex x) (leftVertex y) == vertices [x,y] []" $ \x y -> + connect (leftVertex x) (leftVertex y) == vertices [x,y] [] + test "connect (leftVertex x) (rightVertex y) == edge x y" $ \x y -> + connect (leftVertex x) (rightVertex y) == edge x y + test "connect (rightVertex x) (leftVertex y) == edge y x" $ \x y -> + connect (rightVertex x) (leftVertex y) == edge y x + test "connect (rightVertex x) (rightVertex y) == vertices [] [x,y]" $ \x y -> + connect (rightVertex x) (rightVertex y) == vertices [] [x,y] + test "connect (vertices xs1 ys1) (vertices xs2 ys2) == overlay (biclique xs1 ys2) (biclique xs2 ys1)" $ \xs1 ys1 xs2 ys2 -> + connect (vertices xs1 ys1) (vertices xs2 ys2) == overlay (biclique xs1 ys2) (biclique xs2 ys1) + test "isEmpty (connect x y) == isEmpty x && isEmpty y" $ \x y -> + isEmpty (connect x y) ==(isEmpty x && isEmpty y) + test "hasVertex z (connect x y) == hasVertex z x || hasVertex z y" $ \x y z -> + hasVertex z (connect x y) ==(hasVertex z x || hasVertex z y) + test "vertexCount (connect x y) >= vertexCount x" $ \x y -> + vertexCount (connect x y) >= vertexCount x + test "vertexCount (connect x y) <= vertexCount x + vertexCount y" $ \x y -> + vertexCount (connect x y) <= vertexCount x + vertexCount y + test "edgeCount (connect x y) >= edgeCount x" $ \x y -> + edgeCount (connect x y) >= edgeCount x + test "edgeCount (connect x y) >= leftVertexCount x * rightVertexCount y" $ \x y -> + edgeCount (connect x y) >= leftVertexCount x * rightVertexCount y + test "edgeCount (connect x y) <= leftVertexCount x * rightVertexCount y + rightVertexCount x * leftVertexCount y + edgeCount x + edgeCount y" $ \x y -> + edgeCount (connect x y) <= leftVertexCount x * rightVertexCount y + rightVertexCount x * leftVertexCount y + edgeCount x + edgeCount y + + putStrLn "\n============ Bipartite.Undirected.AdjacencyMap.vertices ============" + test "vertices [] [] == empty" $ + vertices [] [] == empty + test "vertices [x] [] == leftVertex x" $ \x -> + vertices [x] [] == leftVertex x + test "vertices [] [x] == rightVertex x" $ \x -> + vertices [] [x] == rightVertex x + test "hasLeftVertex x (vertices xs ys) == elem x xs" $ \x xs ys -> + hasLeftVertex x (vertices xs ys) == elem x xs + test "hasRightVertex y (vertices xs ys) == elem y ys" $ \y xs ys -> + hasRightVertex y (vertices xs ys) == elem y ys + + putStrLn "\n============ Bipartite.Undirected.AdjacencyMap.edges ============" + test "edges [] == empty" $ + edges [] == empty + test "edges [(x,y)] == edge x y" $ \x y -> + edges [(x,y)] == edge x y + test "edges == overlays . map (uncurry edge)" $ \xs -> + edges xs == (overlays . map (uncurry edge)) xs + test "hasEdge x y . edges == elem (x,y)" $ \x y es -> + (hasEdge x y . edges) es == elem (x,y) es + test "edgeCount . edges == length . nub" $ \es -> + (edgeCount . edges) es == (length . nubOrd) es + + putStrLn "\n============ Bipartite.Undirected.AdjacencyMap.overlays ============" + test "overlays [] == empty" $ + overlays [] == empty + test "overlays [x] == x" $ \x -> + overlays [x] == x + test "overlays [x,y] == overlay x y" $ \x y -> + overlays [x,y] == overlay x y + test "overlays == foldr overlay empty" $ size10 $ \xs -> + overlays xs == foldr overlay empty xs + test "isEmpty . overlays == all isEmpty" $ size10 $ \xs -> + (isEmpty . overlays) xs == all isEmpty xs + + putStrLn "\n============ Bipartite.Undirected.AdjacencyMap.connects ============" + test "connects [] == empty" $ + connects [] == empty + test "connects [x] == x" $ \x -> + connects [x] == x + test "connects [x,y] == connect x y" $ \x y -> + connects [x,y] == connect x y + test "connects == foldr connect empty" $ size10 $ \xs -> + connects xs == foldr connect empty xs + test "isEmpty . connects == all isEmpty" $ size10 $ \ xs -> + (isEmpty . connects) xs == all isEmpty xs + + putStrLn "\n============ Bipartite.Undirected.AdjacencyMap.swap ============" + test "swap empty == empty" $ + swap empty == empty + test "swap . leftVertex == rightVertex" $ \x -> + (swap . leftVertex) x == rightVertex x + test "swap (vertices xs ys) == vertices ys xs" $ \xs ys -> + swap (vertices xs ys) == vertices ys xs + test "swap (edge x y) == edge y x" $ \x y -> + swap (edge x y) == edge y x + test "swap . edges == edges . map Data.Tuple.swap" $ \es -> + (swap . edges) es == (edges . map Data.Tuple.swap) es + test "swap . swap == id" $ \x -> + (swap . swap) x == x + + putStrLn "\n============ Bipartite.Undirected.AdjacencyMap.toBipartite ============" + test "toBipartite empty == empty" $ + toBipartite AM.empty == empty + test "toBipartite (vertex (Left x)) == leftVertex x" $ \x -> + toBipartite (AM.vertex (Left x)) == leftVertex x + test "toBipartite (vertex (Right x)) == rightVertex x" $ \x -> + toBipartite (AM.vertex (Right x)) == rightVertex x + test "toBipartite (edge (Left x) (Left y)) == vertices [x,y] []" $ \x y -> + toBipartite (AM.edge (Left x) (Left y)) == vertices [x,y] [] + test "toBipartite (edge (Left x) (Right y)) == edge x y" $ \x y -> + toBipartite (AM.edge (Left x) (Right y)) == edge x y + test "toBipartite (edge (Right x) (Left y)) == edge y x" $ \x y -> + toBipartite (AM.edge (Right x) (Left y)) == edge y x + test "toBipartite (edge (Right x) (Right y)) == vertices [] [x,y]" $ \x y -> + toBipartite (AM.edge (Right x) (Right y)) == vertices [] [x,y] + test "toBipartite (clique xs) == uncurry biclique (partitionEithers xs)" $ \xs -> + toBipartite (AM.clique xs) == uncurry biclique (partitionEithers xs) + + putStrLn "\n============ Bipartite.Undirected.AdjacencyMap.toBipartiteWith ============" + test "toBipartiteWith f empty == empty" $ \(apply -> f) -> + toBipartiteWith f (AM.empty :: AII) == empty + test "toBipartiteWith Left x == vertices (vertexList x) []" $ \x -> + toBipartiteWith Left x == vertices (AM.vertexList x) [] + test "toBipartiteWith Right x == vertices [] (vertexList x)" $ \x -> + toBipartiteWith Right x == vertices [] (AM.vertexList x) + test "toBipartiteWith f == toBipartite . gmap f" $ \(apply -> f) x -> + toBipartiteWith f x == (toBipartite . AM.gmap f) (x :: AII) + test "toBipartiteWith id == toBipartite" $ \x -> + toBipartiteWith id x == toBipartite x + + putStrLn "\n============ Bipartite.Undirected.AdjacencyMap.fromBipartite ============" + test "fromBipartite empty == empty" $ + fromBipartite empty == AM.empty + test "fromBipartite (leftVertex x) == vertex (Left x)" $ \x -> + fromBipartite (leftVertex x) == AM.vertex (Left x) + test "fromBipartite (edge x y) == edges [(Left x, Right y), (Right y, Left x)]" $ \x y -> + fromBipartite (edge x y) == AM.edges [(Left x, Right y), (Right y, Left x)] + test "toBipartite . fromBipartite == id" $ \x -> + (toBipartite . fromBipartite) x == x + + putStrLn "\n============ Bipartite.Undirected.AdjacencyMap.fromBipartiteWith ============" + test "fromBipartiteWith Left Right == fromBipartite" $ \x -> + fromBipartiteWith Left Right x == fromBipartite x + test "fromBipartiteWith id id (vertices xs ys) == vertices (xs ++ ys)" $ \xs ys -> + fromBipartiteWith id id (vertices xs ys) == AM.vertices (xs ++ ys) + test "fromBipartiteWith id id . edges == edges" $ \xs -> + (fromBipartiteWith id id . edges) xs == (AM.symmetricClosure . AM.edges) xs + + putStrLn "\n============ Bipartite.Undirected.AdjacencyMap.isEmpty ============" + test "isEmpty empty == True" $ + isEmpty empty == True + test "isEmpty (overlay empty empty) == True" $ + isEmpty (overlay empty empty) == True + test "isEmpty (vertex x) == False" $ \x -> + isEmpty (vertex x) == False + test "isEmpty == (==) empty" $ \x -> + isEmpty x == (==) empty x + + putStrLn "\n============ Bipartite.Undirected.AdjacencyMap.hasLeftVertex ============" + test "hasLeftVertex x empty == False" $ \x -> + hasLeftVertex x empty == False + test "hasLeftVertex x (leftVertex y) == (x == y)" $ \x y -> + hasLeftVertex x (leftVertex y) == (x == y) + test "hasLeftVertex x (rightVertex y) == False" $ \x y -> + hasLeftVertex x (rightVertex y) == False + + putStrLn "\n============ Bipartite.Undirected.AdjacencyMap.hasRightVertex ============" + test "hasRightVertex x empty == False" $ \x -> + hasRightVertex x empty == False + test "hasRightVertex x (leftVertex y) == False" $ \x y -> + hasRightVertex x (leftVertex y) == False + test "hasRightVertex x (rightVertex y) == (x == y)" $ \x y -> + hasRightVertex x (rightVertex y) == (x == y) + + putStrLn "\n============ Bipartite.Undirected.AdjacencyMap.hasVertex ============" + test "hasVertex . Left == hasLeftVertex" $ \x y -> + (hasVertex . Left) x y == hasLeftVertex x y + test "hasVertex . Right == hasRightVertex" $ \x y -> + (hasVertex . Right) x y == hasRightVertex x y + + putStrLn "\n============ Bipartite.Undirected.AdjacencyMap.hasEdge ============" + test "hasEdge x y empty == False" $ \x y -> + hasEdge x y empty == False + test "hasEdge x y (vertex z) == False" $ \x y z -> + hasEdge x y (vertex z) == False + test "hasEdge x y (edge x y) == True" $ \x y -> + hasEdge x y (edge x y) == True + test "hasEdge x y == elem (x,y) . edgeList" $ \x y z -> do + let es = edgeList z + (x, y) <- elements ((x, y) : es) + return $ hasEdge x y z == elem (x, y) es + + putStrLn "\n============ Bipartite.Undirected.AdjacencyMap.leftVertexCount ============" + test "leftVertexCount empty == 0" $ + leftVertexCount empty == 0 + test "leftVertexCount (leftVertex x) == 1" $ \x -> + leftVertexCount (leftVertex x) == 1 + test "leftVertexCount (rightVertex x) == 0" $ \x -> + leftVertexCount (rightVertex x) == 0 + test "leftVertexCount (edge x y) == 1" $ \x y -> + leftVertexCount (edge x y) == 1 + test "leftVertexCount . edges == length . nub . map fst" $ \xs -> + (leftVertexCount . edges) xs == (length . nub . map fst) xs + + putStrLn "\n============ Bipartite.Undirected.AdjacencyMap.rightVertexCount ============" + test "rightVertexCount empty == 0" $ + rightVertexCount empty == 0 + test "rightVertexCount (leftVertex x) == 0" $ \x -> + rightVertexCount (leftVertex x) == 0 + test "rightVertexCount (rightVertex x) == 1" $ \x -> + rightVertexCount (rightVertex x) == 1 + test "rightVertexCount (edge x y) == 1" $ \x y -> + rightVertexCount (edge x y) == 1 + test "rightVertexCount . edges == length . nub . map snd" $ \xs -> + (rightVertexCount . edges) xs == (length . nub . map snd) xs + + putStrLn "\n============ Bipartite.Undirected.AdjacencyMap.vertexCount ============" + test "vertexCount empty == 0" $ + vertexCount empty == 0 + test "vertexCount (vertex x) == 1" $ \x -> + vertexCount (vertex x) == 1 + test "vertexCount (edge x y) == 2" $ \x y -> + vertexCount (edge x y) == 2 + test "vertexCount x == leftVertexCount x + rightVertexCount x" $ \x -> + vertexCount x == leftVertexCount x + rightVertexCount x + + putStrLn "\n============ Bipartite.Undirected.AdjacencyMap.edgeCount ============" + test "edgeCount empty == 0" $ + edgeCount empty == 0 + test "edgeCount (vertex x) == 0" $ \x -> + edgeCount (vertex x) == 0 + test "edgeCount (edge x y) == 1" $ \x y -> + edgeCount (edge x y) == 1 + test "edgeCount . edges == length . nub" $ \xs -> + (edgeCount . edges) xs == (length . nubOrd) xs + + putStrLn "\n============ Bipartite.Undirected.AdjacencyMap.leftVertexList ============" + test "leftVertexList empty == []" $ + leftVertexList empty == [] + test "leftVertexList (leftVertex x) == [x]" $ \x -> + leftVertexList (leftVertex x) == [x] + test "leftVertexList (rightVertex x) == []" $ \x -> + leftVertexList (rightVertex x) == [] + test "leftVertexList . flip vertices [] == nub . sort" $ \xs -> + (leftVertexList . flip vertices []) xs == (nubOrd . sort) xs + + putStrLn "\n============ Bipartite.Undirected.AdjacencyMap.rightVertexList ============" + test "rightVertexList empty == []" $ + rightVertexList empty == [] + test "rightVertexList (leftVertex x) == []" $ \x -> + rightVertexList (leftVertex x) == [] + test "rightVertexList (rightVertex x) == [x]" $ \x -> + rightVertexList (rightVertex x) == [x] + test "rightVertexList . vertices [] == nub . sort" $ \xs -> + (rightVertexList . vertices []) xs == (nubOrd . sort) xs + + putStrLn "\n============ Bipartite.Undirected.AdjacencyMap.vertexList ============" + test "vertexList empty == []" $ + vertexList empty == [] + test "vertexList (vertex x) == [x]" $ \x -> + vertexList (vertex x) == [x] + test "vertexList (edge x y) == [Left x, Right y]" $ \x y -> + vertexList (edge x y) == [Left x, Right y] + test "vertexList (vertices (lefts xs) (rights xs)) == nub (sort xs)" $ \xs -> + vertexList (vertices (lefts xs) (rights xs)) == nubOrd (sort xs) + + putStrLn "\n============ Bipartite.Undirected.AdjacencyMap.edgeList ============" + test "edgeList empty == []" $ + edgeList empty == [] + test "edgeList (vertex x) == []" $ \x -> + edgeList (vertex x) == [] + test "edgeList (edge x y) == [(x,y)]" $ \x y -> + edgeList (edge x y) == [(x,y)] + test "edgeList . edges == nub . sort" $ \xs -> + (edgeList . edges) xs == (nubOrd . sort) xs + + putStrLn "\n============ Bipartite.Undirected.AdjacencyMap.leftVertexSet ============" + test "leftVertexSet empty == Set.empty" $ + leftVertexSet empty == Set.empty + test "leftVertexSet . leftVertex == Set.singleton" $ \x -> + (leftVertexSet . leftVertex) x == Set.singleton x + test "leftVertexSet . rightVertex == const Set.empty" $ \x -> + (leftVertexSet . rightVertex) x == const Set.empty x + test "leftVertexSet . flip vertices [] == Set.fromList" $ \xs -> + (leftVertexSet . flip vertices []) xs == Set.fromList xs + + putStrLn "\n============ Bipartite.Undirected.AdjacencyMap.rightVertexSet ============" + test "rightVertexSet empty == Set.empty" $ + rightVertexSet empty == Set.empty + test "rightVertexSet . leftVertex == const Set.empty" $ \x -> + (rightVertexSet . leftVertex) x == const Set.empty x + test "rightVertexSet . rightVertex == Set.singleton" $ \x -> + (rightVertexSet . rightVertex) x == Set.singleton x + test "rightVertexSet . vertices [] == Set.fromList" $ \xs -> + (rightVertexSet . vertices []) xs == Set.fromList xs + + putStrLn "\n============ Bipartite.Undirected.AdjacencyMap.vertexSet ============" + test "vertexSet empty == Set.empty" $ + vertexSet empty == Set.empty + test "vertexSet . vertex == Set.singleton" $ \x -> + (vertexSet . vertex) x == Set.singleton x + test "vertexSet (edge x y) == Set.fromList [Left x, Right y]" $ \x y -> + vertexSet (edge x y) == Set.fromList [Left x, Right y] + test "vertexSet (vertices (lefts xs) (rights xs)) == Set.fromList xs" $ \xs -> + vertexSet (vertices (lefts xs) (rights xs)) == Set.fromList xs + + putStrLn "\n============ Bipartite.Undirected.AdjacencyMap.edgeSet ============" + test "edgeSet empty == Set.empty" $ + edgeSet empty == Set.empty + test "edgeSet (vertex x) == Set.empty" $ \x -> + edgeSet (vertex x) == Set.empty + test "edgeSet (edge x y) == Set.singleton (x,y)" $ \x y -> + edgeSet (edge x y) == Set.singleton (x,y) + test "edgeSet . edges == Set.fromList" $ \xs -> + (edgeSet . edges) xs == Set.fromList xs + + putStrLn "\n============ Bipartite.Undirected.AdjacencyMap.circuit ============" + test "circuit [] == empty" $ + circuit [] == empty + test "circuit [(x,y)] == edge x y" $ \x y -> + circuit [(x,y)] == edge x y + test "circuit [(1,2), (3,4)] == biclique [1,3] [2,4]" $ + circuit [(1,2), (3,4)] == biclique [1,3 :: Int] [2,4 :: Int] + test "circuit [(1,2), (3,4), (5,6)] == edges [(1,2), (3,2), (3,4), (5,4), (5,6), (1,6)]" $ + circuit [(1,2), (3,4), (5,6)] == edges [(1,2), (3,2), (3,4), (5,4), (5,6), (1,6)] + test "circuit . reverse == swap . circuit . map Data.Tuple.swap" $ \xs -> + (circuit . reverse) xs == (swap . circuit . map Data.Tuple.swap) xs + + putStrLn "\n============ Bipartite.Undirected.AdjacencyMap.biclique ============" + test "biclique [] [] == empty" $ + biclique [] [] == empty + test "biclique xs [] == vertices xs []" $ \xs -> + biclique xs [] == vertices xs [] + test "biclique [] ys == vertices [] ys" $ \ys -> + biclique [] ys == vertices [] ys + test "biclique xs ys == connect (vertices xs []) (vertices [] ys)" $ \xs ys -> + biclique xs ys == connect (vertices xs []) (vertices [] ys) + + putStrLn "\n============ Bipartite.Undirected.AdjacencyMap.detectParts ============" + test "detectParts empty == Right empty" $ + detectParts AM.empty == Right empty + test "detectParts (vertex x) == Right (leftVertex x)" $ \x -> + detectParts (AM.vertex x) == Right (leftVertex x) + test "detectParts (edge x x) == Left [x]" $ \x -> + detectParts (AM.edge x x :: AI) == Left [x] + test "detectParts (edge 1 2) == Right (edge 1 2)" $ + detectParts (AM.edge 1 2) == Right (edge 1 2) + test "detectParts (1 * (2 + 3)) == Right (edges [(1,2), (1,3)])" $ + detectParts (1 * (2 + 3)) == Right (edges [(1,2), (1,3)]) + test "detectParts (1 * 2 * 3) == Left [1, 2, 3]" $ + detectParts (1 * 2 * 3 :: AI) == Left [1, 2, 3] + test "detectParts ((1 + 3) * (2 + 4) + 6 * 5) == Right (swap (1 + 3) * (2 + 4) + swap 5 * 6)" $ + detectParts ((1 + 3) * (2 + 4) + 6 * 5) == Right (swap (1 + 3) * (2 + 4) + swap 5 * 6) + test "detectParts ((1 * 3 * 4) + 2 * (1 + 2)) == Left [2]" $ + detectParts ((1 * 3 * 4) + 2 * (1 + 2) :: AI) == Left [2] + test "detectParts (clique [1..10]) == Left [1, 2, 3]" $ + detectParts (AM.clique [1..10] :: AI) == Left [1, 2, 3] + test "detectParts (circuit [1..11]) == Left [1..11]" $ + detectParts (AM.circuit [1..11] :: AI) == Left [1..11] + test "detectParts (circuit [1..10]) == Right (circuit [(x, x + 1) | x <- [1,3,5,7,9]])" $ + detectParts (AM.circuit [1..10] :: AI) == Right (circuit [(x, x + 1) | x <- [1,3,5,7,9]]) + test "detectParts (biclique [] xs) == Right (vertices xs [])" $ \xs -> + detectParts (AM.biclique [] xs) == Right (vertices xs []) + test "detectParts (biclique (map Left (x:xs)) (map Right ys)) == Right (biclique (map Left (x:xs)) (map Right ys))" $ \(x :: Int) xs (ys :: [Int]) -> + detectParts (AM.biclique (map Left (x:xs)) (map Right ys)) == Right (B.biclique (map Left (x:xs)) (map Right ys)) + test "isRight (detectParts (star x ys)) == notElem x ys" $ \(x :: Int) ys -> + isRight (detectParts (AM.star x ys)) == notElem x ys + test "isRight (detectParts (fromBipartite x)) == True" $ \x -> + isRight (detectParts (fromBipartite x)) == True + + putStrLn "" + test "Correctness of detectParts" $ \input -> + let undirected = AM.symmetricClosure input in + case detectParts input of + Left cycle -> mod (length cycle) 2 == 1 && AM.isSubgraphOf (AM.circuit cycle) undirected + Right bipartite -> AM.gmap fromEither (fromBipartite bipartite) == undirected diff --git a/test/Algebra/Graph/Test/Generic.hs b/test/Algebra/Graph/Test/Generic.hs index b80cf7397..963dd51b8 100644 --- a/test/Algebra/Graph/Test/Generic.hs +++ b/test/Algebra/Graph/Test/Generic.hs @@ -289,8 +289,8 @@ testVertex (prefix, API{..}) = do test "isEmpty (vertex x) == False" $ \x -> isEmpty (vertex x) == False - test "hasVertex x (vertex x) == True" $ \x -> - hasVertex x (vertex x) == True + test "hasVertex x (vertex y) == (x == y)" $ \x y -> + hasVertex x (vertex y) == (x == y) test "vertexCount (vertex x) == 1" $ \x -> vertexCount (vertex x) == 1 @@ -463,6 +463,9 @@ testEdges (prefix, API{..}) = do test "edges [(x,y)] == edge x y" $ \x y -> edges [(x,y)] == edge x y + test "edges == overlays . map (uncurry edge)" $ \xs -> + edges xs == (overlays . map (uncurry edge)) xs + test "edgeCount . edges == length . nub" $ \xs -> (edgeCount . edges) xs == (length . nubOrd) xs @@ -870,11 +873,8 @@ testHasVertex (prefix, API{..}) = do test "hasVertex x empty == False" $ \x -> hasVertex x empty == False - test "hasVertex x (vertex x) == True" $ \x -> - hasVertex x (vertex x) == True - - test "hasVertex 1 (vertex 2) == False" $ - hasVertex 1 (vertex 2) == False + test "hasVertex x (vertex y) == (x == y)" $ \x y -> + hasVertex x (vertex y) == (x == y) test "hasVertex x . removeVertex x == const False" $ \x y -> (hasVertex x . removeVertex x) y == const False y @@ -895,8 +895,9 @@ testHasEdge (prefix, API{..}) = do (hasEdge x y . removeEdge x y) z == const False z test "hasEdge x y == elem (x,y) . edgeList" $ \x y z -> do - (u, v) <- elements ((x, y) : edgeList z) - return $ hasEdge u v z == elem (u, v) (edgeList z) + let es = edgeList z + (x, y) <- elements ((x, y) : es) + return $ hasEdge x y z == elem (x, y) es testSymmetricHasEdge :: TestsuiteInt g -> IO () testSymmetricHasEdge (prefix, API{..}) = do diff --git a/test/Algebra/Graph/Test/Labelled/AdjacencyMap.hs b/test/Algebra/Graph/Test/Labelled/AdjacencyMap.hs index 9fe32ca8f..ae54c492d 100644 --- a/test/Algebra/Graph/Test/Labelled/AdjacencyMap.hs +++ b/test/Algebra/Graph/Test/Labelled/AdjacencyMap.hs @@ -42,7 +42,7 @@ type LAD = AdjacencyMap D Int testLabelledAdjacencyMap :: IO () testLabelledAdjacencyMap = do - putStrLn "\n============ Labelled.AdjacencyMap.Internal.consistent ============" + putStrLn "\n============ Labelled.AdjacencyMap.consistent ============" test "arbitraryLabelledAdjacencyMap" $ \x -> consistent (x :: LAS) test "empty" $ consistent (empty :: LAS) test "vertex" $ \x -> consistent (vertex x :: LAS) diff --git a/test/Algebra/Graph/Test/NonEmpty/AdjacencyMap.hs b/test/Algebra/Graph/Test/NonEmpty/AdjacencyMap.hs index e77e9193f..737737511 100644 --- a/test/Algebra/Graph/Test/NonEmpty/AdjacencyMap.hs +++ b/test/Algebra/Graph/Test/NonEmpty/AdjacencyMap.hs @@ -124,8 +124,8 @@ testNonEmptyAdjacencyMap = do (AM.isEmpty . fromNonEmpty) x == const False x putStrLn $ "\n============ NonEmpty.AdjacencyMap.vertex ============" - test "hasVertex x (vertex x) == True" $ \(x :: Int) -> - hasVertex x (vertex x) == True + test "hasVertex x (vertex y) == (x == y)" $ \(x :: Int) y -> + hasVertex x (vertex y) == (x == y) test "vertexCount (vertex x) == 1" $ \(x :: Int) -> vertexCount (vertex x) == 1 @@ -219,6 +219,10 @@ testNonEmptyAdjacencyMap = do test "edges1 [(x,y)] == edge x y" $ \(x :: Int) y -> edges1 [(x,y)] == edge x y + test "edges1 == overlays1 . fmap (uncurry edge)" $ \(xs' :: NonEmptyList (Int, Int)) -> + let xs = NonEmpty.fromList (getNonEmpty xs') + in edges1 xs == (overlays1 . fmap (uncurry edge)) xs + test "edgeCount . edges1 == length . nub" $ \(xs' :: NonEmptyList (Int, Int)) -> let xs = NonEmpty.fromList (getNonEmpty xs') in (edgeCount . edges1) xs == (NonEmpty.length . NonEmpty.nub) xs @@ -253,11 +257,8 @@ testNonEmptyAdjacencyMap = do in isSubgraphOf x y ==> x <= y putStrLn $ "\n============ NonEmpty.AdjacencyMap.hasVertex ============" - test "hasVertex x (vertex x) == True" $ \(x :: Int) -> - hasVertex x (vertex x) == True - - test "hasVertex 1 (vertex 2) == False" $ - hasVertex 1 (vertex 2 :: G) == False + test "hasVertex x (vertex y) == (x == y)" $ \(x :: Int) y -> + hasVertex x (vertex y) == (x == y) putStrLn $ "\n============ NonEmpty.AdjacencyMap.hasEdge ============" test "hasEdge x y (vertex z) == False" $ \(x :: Int) y z -> diff --git a/test/Algebra/Graph/Test/NonEmpty/Graph.hs b/test/Algebra/Graph/Test/NonEmpty/Graph.hs index 28b2257be..4bc33b905 100644 --- a/test/Algebra/Graph/Test/NonEmpty/Graph.hs +++ b/test/Algebra/Graph/Test/NonEmpty/Graph.hs @@ -119,8 +119,8 @@ testNonEmptyGraph = do toNonEmpty (toGraph x) == Just (x :: G) putStrLn $ "\n============ NonEmpty.Graph.vertex ============" - test "hasVertex x (vertex x) == True" $ \(x :: Int) -> - hasVertex x (vertex x) == True + test "hasVertex x (vertex y) == (x == y)" $ \(x :: Int) y -> + hasVertex x (vertex y) == (x == y) test "vertexCount (vertex x) == 1" $ \(x :: Int) -> vertexCount (vertex x) == 1 @@ -231,6 +231,10 @@ testNonEmptyGraph = do test "edges1 [(x,y)] == edge x y" $ \(x :: Int) y -> edges1 [(x,y)] == edge x y + test "edges1 == overlays1 . fmap (uncurry edge)" $ \(xs' :: NonEmptyList (Int, Int)) -> + let xs = NonEmpty.fromList (getNonEmpty xs') + in edges1 xs == (overlays1 . fmap (uncurry edge)) xs + test "edgeCount . edges1 == length . nub" $ \(xs' :: NonEmptyList (Int, Int)) -> let xs = NonEmpty.fromList (getNonEmpty xs') in (edgeCount . edges1) xs == (NonEmpty.length . NonEmpty.nub) xs @@ -307,11 +311,8 @@ testNonEmptyGraph = do size x >= vertexCount x putStrLn $ "\n============ NonEmpty.Graph.hasVertex ============" - test "hasVertex x (vertex x) == True" $ \(x :: Int) -> - hasVertex x (vertex x) == True - - test "hasVertex 1 (vertex 2) == False" $ - hasVertex 1 (vertex 2 :: G) == False + test "hasVertex x (vertex y) == (x == y)" $ \(x :: Int) y -> + hasVertex x (vertex y) == (x == y) putStrLn $ "\n============ NonEmpty.Graph.hasEdge ============" test "hasEdge x y (vertex z) == False" $ \(x :: Int) y z -> diff --git a/test/Algebra/Graph/Test/Undirected.hs b/test/Algebra/Graph/Test/Undirected.hs index 0e5e4a2a2..2746a25bf 100644 --- a/test/Algebra/Graph/Test/Undirected.hs +++ b/test/Algebra/Graph/Test/Undirected.hs @@ -36,7 +36,6 @@ testUndirected = do putStrLn "\n============ Graph.Undirected ============" test "Axioms of undirected graphs" $ size10 $ undirectedAxioms @ G - testConsistent t testSymmetricShow t putStrLn $ "\n============ Graph.Undirected.toUndirected ============" diff --git a/test/Main.hs b/test/Main.hs index 87375b415..7626d8fb5 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -1,7 +1,7 @@ import Algebra.Graph.Test.Acyclic.AdjacencyMap import Algebra.Graph.Test.AdjacencyIntMap import Algebra.Graph.Test.AdjacencyMap -import Algebra.Graph.Test.Bipartite.AdjacencyMap +import Algebra.Graph.Test.Bipartite.Undirected.AdjacencyMap import Algebra.Graph.Test.Export import Algebra.Graph.Test.Graph import Algebra.Graph.Test.Internal @@ -29,19 +29,19 @@ main :: IO () main = do selected <- getArgs let go current = when (null selected || current `elem` selected) - go "Acyclic.AdjacencyMap" testAcyclicAdjacencyMap - go "AdjacencyIntMap" testAdjacencyIntMap - go "AdjacencyMap" testAdjacencyMap - go "Bipartite.AdjacencyMap" testBipartiteAdjacencyMap - go "Export" testExport - go "Graph" testGraph - go "Internal" testInternal - go "Label" testLabel - go "Labelled.AdjacencyMap" testLabelledAdjacencyMap - go "Labelled.Graph" testLabelledGraph - go "NonEmpty.AdjacencyMap" testNonEmptyAdjacencyMap - go "NonEmpty.Graph" testNonEmptyGraph - go "Relation" testRelation - go "Symmetric.Relation" testSymmetricRelation - go "Typed" testTyped - go "Undirected" testUndirected + go "Acyclic.AdjacencyMap" testAcyclicAdjacencyMap + go "AdjacencyIntMap" testAdjacencyIntMap + go "AdjacencyMap" testAdjacencyMap + go "Bipartite.Undirected.AdjacencyMap" testBipartiteUndirectedAdjacencyMap + go "Export" testExport + go "Graph" testGraph + go "Internal" testInternal + go "Label" testLabel + go "Labelled.AdjacencyMap" testLabelledAdjacencyMap + go "Labelled.Graph" testLabelledGraph + go "NonEmpty.AdjacencyMap" testNonEmptyAdjacencyMap + go "NonEmpty.Graph" testNonEmptyGraph + go "Relation" testRelation + go "Symmetric.Relation" testSymmetricRelation + go "Typed" testTyped + go "Undirected" testUndirected