diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -1,5 +1,16 @@ # Change log +## 0.6 + +* #276: Add `Monoid` and `Semigroup` instances. +* #278: Stop supporting GHC 8.0 and GHC 8.2. +* #274, #277: Expand the API and add algorithms for bipartite graphs, drop the + `Undirected` component in `Bipartite.Undirected.AdjacencyMap`. +* #273: Add attribute quoting style to `Export.Dot`. +* #259: Allow newer QuickCheck. +* #257: Add `IsString` instances. +* #226: Expand the API of `Bipartite.Undirected.AdjacencyMap`. + ## 0.5 * #217, #224, #227, #234, #235: Add new BFS, DFS, topological sort, and SCC @@ -9,7 +20,7 @@ * #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. +* #172, #245: Stop supporting GHC 7.8 and GHC 7.10. * #208: Add `fromNonEmpty` to `NonEmpty.AdjacencyMap`. * #208: Add `fromAdjacencyMap` to `AdjacencyIntMap`. * #208: Drop `Internal` modules for `AdjacencyIntMap`, `AdjacencyMap`, diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,6 +1,6 @@ MIT License -Copyright (c) 2016-2020 Andrey Mokhov +Copyright (c) 2016-2021 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/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,12 +1,12 @@ # Algebraic graphs -[![Hackage version](https://img.shields.io/hackage/v/algebraic-graphs.svg?label=Hackage)](https://hackage.haskell.org/package/algebraic-graphs) [![Linux & OS X status](https://img.shields.io/travis/snowleopard/alga/master.svg?label=Linux%20%26%20OS%20X)](https://travis-ci.org/snowleopard/alga) [![Windows status](https://img.shields.io/appveyor/ci/snowleopard/alga/master.svg?label=Windows)](https://ci.appveyor.com/project/snowleopard/alga) +[![Hackage version](https://img.shields.io/hackage/v/algebraic-graphs.svg?label=Hackage)](https://hackage.haskell.org/package/algebraic-graphs) [![Build status](https://img.shields.io/github/workflow/status/snowleopard/alga/ci.svg)](https://github.com/snowleopard/alga/actions) **Alga** is a library for algebraic construction and manipulation of graphs in Haskell. See [this Haskell Symposium paper](https://github.com/snowleopard/alga-paper) and the corresponding [talk](https://www.youtube.com/watch?v=EdQGLewU-8k) for the motivation behind the library, the underlying theory and implementation details. There is also a -[Haskell eXchange talk](https://skillsmatter.com/skillscasts/10635-algebraic-graphs), +[Haskell eXchange talk](https://skillsmatter.com/skillscasts/10635-algebraic-graphs), and a [tutorial](https://nobrakal.github.io/alga-tutorial) by Alexandre Moine. ## Main idea @@ -84,5 +84,8 @@ ## Algebraic graphs in other languages -See draft implementations in [Agda](http://github.com/algebraic-graphs/agda) -and [Scala](http://github.com/algebraic-graphs/scala). +Algebraic graphs were implemented in a few other languages, including +[Agda](http://github.com/algebraic-graphs/agda), +[F#](https://github.com/algebraic-graphs/fsharp), +[Scala](http://github.com/algebraic-graphs/scala) and +[TypeScript](https://github.com/algebraic-graphs/typescript). diff --git a/algebraic-graphs.cabal b/algebraic-graphs.cabal --- a/algebraic-graphs.cabal +++ b/algebraic-graphs.cabal @@ -1,22 +1,18 @@ cabal-version: 2.2 name: algebraic-graphs -version: 0.5 +version: 0.6 synopsis: A library for algebraic graph construction and transformation license: MIT license-file: LICENSE author: Andrey Mokhov , github: @snowleopard maintainer: Andrey Mokhov , github: @snowleopard, Alexandre Moine , github: @nobrakal -copyright: Andrey Mokhov, 2016-2019 +copyright: Andrey Mokhov, 2016-2021 homepage: https://github.com/snowleopard/alga +bug-reports: https://github.com/snowleopard/alga/issues category: Algebra, Algorithms, Data Structures, Graphs build-type: Simple -tested-with: GHC == 8.0.2, - GHC == 8.2.2, - GHC == 8.4.4, - GHC == 8.6.5, - GHC == 8.8.1 -stability: experimental +tested-with: GHC==9.0, GHC==8.10, GHC==8.8, GHC==8.6, GHC==8.4 description: is a library for algebraic construction and manipulation of graphs in Haskell. See @@ -34,13 +30,19 @@ . The library also provides conventional graph data structures, such as - along with its various flavours: adjacency maps specialised to graphs with - vertices of type 'Int' + along with its various flavours: + . + * adjacency maps specialised to graphs with vertices of type 'Int' (), - non-empty adjacency maps + * non-empty adjacency maps (), - and adjacency maps with edge labels - (). + * adjacency maps for undirected bipartite graphs + (), + * adjacency maps with edge labels + (), + * acyclic adjacency maps + (), + . A large part of the API of algebraic graphs and adjacency maps is available through the 'Foldable'-like type class . @@ -72,24 +74,30 @@ mtl >= 2.1 && < 2.3, transformers >= 0.4 && < 0.6 default-language: Haskell2010 - default-extensions: FlexibleContexts + default-extensions: ConstraintKinds + DeriveFunctor + DeriveGeneric + FlexibleContexts FlexibleInstances + GADTs GeneralizedNewtypeDeriving + MultiParamTypeClasses + RankNTypes ScopedTypeVariables TupleSections TypeApplications TypeFamilies other-extensions: CPP - DeriveFunctor OverloadedStrings - RankNTypes RecordWildCards - GHC-options: -Wall + ViewPatterns + ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -fno-warn-name-shadowing + -fno-warn-unused-imports -fspec-constr library @@ -102,7 +110,8 @@ Algebra.Graph.AdjacencyIntMap.Algorithm, Algebra.Graph.AdjacencyMap, Algebra.Graph.AdjacencyMap.Algorithm, - Algebra.Graph.Bipartite.Undirected.AdjacencyMap, + Algebra.Graph.Bipartite.AdjacencyMap, + Algebra.Graph.Bipartite.AdjacencyMap.Algorithm, Algebra.Graph.Class, Algebra.Graph.Export, Algebra.Graph.Export.Dot, @@ -134,7 +143,7 @@ Algebra.Graph.Test.AdjacencyIntMap, Algebra.Graph.Test.AdjacencyMap, Algebra.Graph.Test.Arbitrary, - Algebra.Graph.Test.Bipartite.Undirected.AdjacencyMap, + Algebra.Graph.Test.Bipartite.AdjacencyMap, Algebra.Graph.Test.Export, Algebra.Graph.Test.Generic, Algebra.Graph.Test.Graph, @@ -152,9 +161,6 @@ build-depends: algebraic-graphs, extra >= 1.4 && < 2, inspection-testing >= 0.4.2.2 && < 0.5, - QuickCheck >= 2.10 && < 2.14 + QuickCheck >= 2.14 && < 2.15 other-extensions: ConstrainedClassMethods - ConstraintKinds - MultiParamTypeClasses TemplateHaskell - ViewPatterns diff --git a/src/Algebra/Graph.hs b/src/Algebra/Graph.hs --- a/src/Algebra/Graph.hs +++ b/src/Algebra/Graph.hs @@ -1,8 +1,7 @@ -{-# LANGUAGE DeriveGeneric, RankNTypes #-} ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph --- Copyright : (c) Andrey Mokhov 2016-2019 +-- Copyright : (c) Andrey Mokhov 2016-2021 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental @@ -56,7 +55,7 @@ import Control.Monad.State (runState, get, put) import Data.Foldable (toList) import Data.Maybe (fromMaybe) -import Data.Semigroup ((<>)) +import Data.String import Data.Tree import GHC.Generics @@ -75,11 +74,13 @@ primitives 'empty', 'vertex', 'overlay' and 'connect'. We define a 'Num' instance as a convenient notation for working with graphs: - > 0 == Vertex 0 - > 1 + 2 == Overlay (Vertex 1) (Vertex 2) - > 1 * 2 == Connect (Vertex 1) (Vertex 2) - > 1 + 2 * 3 == Overlay (Vertex 1) (Connect (Vertex 2) (Vertex 3)) - > 1 * (2 + 3) == Connect (Vertex 1) (Overlay (Vertex 2) (Vertex 3)) +@ +0 == 'vertex' 0 +1 + 2 == 'overlay' ('vertex' 1) ('vertex' 2) +1 * 2 == 'connect' ('vertex' 1) ('vertex' 2) +1 + 2 * 3 == 'overlay' ('vertex' 1) ('connect' ('vertex' 2) ('vertex' 3)) +1 * (2 + 3) == 'connect' ('vertex' 1) ('overlay' ('vertex' 2) ('vertex' 3)) +@ __Note:__ the 'Num' instance does not satisfy several "customary laws" of 'Num', which dictate that 'fromInteger' @0@ and 'fromInteger' @1@ should act as @@ -174,9 +175,10 @@ x <= x + y x + y <= x * y@ -Deforestation (fusion) is implemented for some functions in this module. This means -that when a function tagged as a \"good producer\" is composed with a \"good consumer\", -the intermediate structure will not be built. +Deforestation (fusion) is implemented for some functions in this module. This +means that when a function tagged as a \"good producer\" is composed with a +function tagged as a \"good consumer\", the intermediate structure will not be +built. -} data Graph a = Empty | Vertex a @@ -197,12 +199,12 @@ inlining, which would be impossible or unreliable if we used standard functions instead. For example, the function 'eqR' has the following annotations: - NOINLINE [1] eqR - RULES "eqIntR" eqR = eqIntR + INLINE [2] eqR + RULES "eqR/Int" eqR = eqIntR -This tells GHC to rewrite 'eqR' to faster 'eqIntR' if possible (if the types -match), and -- importantly -- not to inline 'eqR' too early, before the rewrite -rule had a chance to fire. +The above tells GHC to rewrite 'eqR' to faster 'eqIntR' if possible (if the +types match), and -- importantly -- not to inline 'eqR' too early, before the +rewrite rule had a chance to fire. We could have written the following rule instead: @@ -234,6 +236,9 @@ abs = id negate = id +instance IsString a => IsString (Graph a) where + fromString = Vertex . fromString + -- | `==` is a good consumer of both arguments. instance Ord a => Eq (Graph a) where (==) = eqR @@ -242,7 +247,10 @@ instance Ord a => Ord (Graph a) where compare = ordR --- TODO: Find a more efficient equality check. +-- TODO: Find a more efficient equality check. Note that assuming the Strong +-- Exponential Time Hypothesis (SETH), it is impossible to compare two algebraic +-- graphs in O(s^1.99), i.e. a quadratic algorithm is the best one can hope for. + -- Check if two graphs are equal by converting them to their adjacency maps. eqR :: Ord a => Graph a -> Graph a -> Bool eqR x y = toAdjacencyMap x == toAdjacencyMap y @@ -267,18 +275,16 @@ {-# INLINE ordIntR #-} -- TODO: It should be a good consumer of its second argument too. --- | `<*>` is a good consumer of its first agument and producer. +-- | `<*>` is a good consumer of its first argument and a good producer. instance Applicative Graph where pure = Vertex - f <*> x = buildg $ \e v o c -> - foldg e (\w -> foldg e (v . w) o c x) o c f + f <*> x = buildg $ \e v o c -> foldg e (\w -> foldg e (v . w) o c x) o c f {-# INLINE (<*>) #-} -- | `>>=` is a good consumer and producer. instance Monad Graph where return = pure - g >>= f = buildg $ \e v o c -> - foldg e (composeR (foldg e v o c) f) o c g + g >>= f = buildg $ \e v o c -> foldg e (composeR (foldg e v o c) f) o c g {-# INLINE (>>=) #-} instance Alternative Graph where @@ -289,8 +295,15 @@ mzero = Empty mplus = Overlay +-- | Defined via 'overlay'. +instance Semigroup (Graph a) where + (<>) = overlay + +-- | Defined via 'overlay' and 'empty'. +instance Monoid (Graph a) where + mempty = empty + -- | Construct the /empty graph/. An alias for the constructor 'Empty'. --- Complexity: /O(1)/ time, memory and size. -- -- @ -- 'isEmpty' empty == True @@ -305,7 +318,6 @@ -- | Construct the graph comprising /a single isolated vertex/. An alias for the -- constructor 'Vertex'. --- Complexity: /O(1)/ time, memory and size. -- -- @ -- 'isEmpty' (vertex x) == False @@ -319,7 +331,6 @@ {-# INLINE vertex #-} -- | Construct the graph comprising /a single edge/. --- Complexity: /O(1)/ time, memory and size. -- -- @ -- edge x y == 'connect' ('vertex' x) ('vertex' y) @@ -375,7 +386,7 @@ connect = Connect {-# INLINE connect #-} --- TODO: Simplifiy the definition to `overlays . map vertex` while presreving +-- TODO: Simplify the definition to `overlays . map vertex` while preserving -- goodness properties (which is not trivial since overlays is only a good -- consumer of lists and not of lists of graphs). -- | Construct the graph comprising a given list of isolated vertices. @@ -387,6 +398,7 @@ -- @ -- vertices [] == 'empty' -- vertices [x] == 'vertex' x +-- vertices == 'overlays' . map 'vertex' -- 'hasVertex' x . vertices == 'elem' x -- 'vertexCount' . vertices == 'length' . 'Data.List.nub' -- 'vertexSet' . vertices == Set.'Set.fromList' @@ -408,8 +420,7 @@ -- 'edgeCount' . edges == 'length' . 'Data.List.nub' -- @ edges :: [(a, a)] -> Graph a -edges xs = buildg $ \e v o c -> - combineR e o (\e -> c (v (fst e)) (v (snd e))) xs +edges xs = buildg $ \e v o c -> combineR e o (\(x, y) -> c (v x) (v y)) xs {-# INLINE edges #-} -- | Overlay a given list of graphs. @@ -455,8 +466,8 @@ -- | 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 --- complexity of 'size' is /O(s)/, since all functions have cost /O(1)/. +-- Complexity: /O(s)/ applications of the given functions. As an example, the +-- complexity of 'size' is /O(s)/, since 'const' and '+' have constant costs. -- -- Good consumer. -- @@ -477,18 +488,24 @@ {-# INLINE [0] foldg #-} {-# RULES + "foldg/Empty" forall e v o c. foldg e v o c Empty = e + "foldg/Vertex" forall e v o c x. foldg e v o c (Vertex x) = v x + "foldg/Overlay" forall e v o c x y. foldg e v o c (Overlay x y) = o (foldg e v o c x) (foldg e v o c y) + "foldg/Connect" forall e v o c x y. foldg e v o c (Connect x y) = c (foldg e v o c x) (foldg e v o c y) - #-} --- | Build a graph given an interpretation of the four graph construction primitives 'empty', --- 'vertex', 'overlay' and 'connect', in this order. See examples for further clarification. +#-} + +-- | Build a graph given an interpretation of the four graph construction +-- primitives 'empty', 'vertex', 'overlay' and 'connect', in this order. See +-- examples for further clarification. -- -- Functions expressed with 'buildg' are good producers. -- @@ -502,7 +519,7 @@ -- buildg (\\e v o c -> 'foldg' e v o ('flip' c) g) == 'transpose' g -- 'foldg' e v o c (buildg f) == f e v o c -- @ -buildg :: (forall b. b -> (a -> b) -> (b -> b -> b) -> (b -> b -> b) -> b) -> Graph a +buildg :: (forall r. r -> (a -> r) -> (r -> r -> r) -> (r -> r -> r) -> r) -> Graph a buildg f = f Empty Vertex Overlay Connect {-# INLINE [1] buildg #-} @@ -601,12 +618,13 @@ {-# SPECIALISE hasVertex :: Int -> Graph Int -> Bool #-} {- Note [The implementation of hasEdge] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We fold a graph into a function of type Int -> Int where the Int stands for the number of vertices of the specified edge that have been matched so far. The edge belongs to the graph if we reach the number 2. Note that this algorithm can be generalised to algebraic graphs of higher dimensions, e.g. we can similarly find -3-edges (triangles), 4-edges (tetrahedra) and k-edges in O(s) time. +3-edges (triangles), 4-edges (tetrahedra), and k-edges in O(s) time. The four graph constructors are interpreted as follows: @@ -615,9 +633,10 @@ * Overlay x y : pick the best match in the two subexpressions; * Connect x y : match the subexpressions one after another. -Note that in the last two cases we can (and do) shortcircuit the computation as +Note that in the last two cases we can (and do) short-circuit the computation as soon as the edge is fully matched in one of the subexpressions. -} + -- | Check if a graph contains a given edge. -- Complexity: /O(s)/ time. -- @@ -771,7 +790,7 @@ {-# INLINE edgeIntSetR #-} -- | The sorted /adjacency list/ of a graph. --- Complexity: /O(n + m)/ time and /O(m)/ memory. +-- Complexity: /O(n + m)/ time and memory. -- -- Good consumer. -- @@ -800,7 +819,7 @@ toAdjacencyIntMap = foldg AIM.empty AIM.vertex AIM.overlay AIM.connect {-# INLINE toAdjacencyIntMap #-} --- TODO: Make path a good consumer of lists, that is, express it with foldr. +-- TODO: Make path a good consumer of lists, that is, express it with 'foldr'. -- This is not straightforward if we want to preserve efficiency. -- | The /path/ on a list of vertices. -- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the @@ -815,14 +834,13 @@ -- path . 'reverse' == 'transpose' . path -- @ path :: [a] -> Graph a -path xs = buildg $ \e v o c -> - case xs of - [] -> e - [x] -> v x - (_:ys) -> foldg e v o c $ edges (zip xs ys) +path xs = buildg $ \e v o c -> case xs of + [] -> e + [x] -> v x + (_ : ys) -> foldg e v o c $ edges (zip xs ys) {-# INLINE path #-} --- TODO: Make circuit a good consumer of lists, that is, express it with foldr. +-- TODO: Make circuit a good consumer of lists, that is, express it with 'foldr'. -- This is not straightforward if we want to preserve efficiency. -- | The /circuit/ on a list of vertices. -- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the @@ -837,10 +855,9 @@ -- circuit . 'reverse' == 'transpose' . circuit -- @ circuit :: [a] -> Graph a -circuit xs = buildg $ \e v o c -> - case xs of - [] -> e - (x:xs) -> foldg e v o c $ path $ [x] ++ xs ++ [x] +circuit xs = buildg $ \e v o c -> case xs of + [] -> e + (x : xs) -> foldg e v o c $ path $ [x] ++ xs ++ [x] {-# INLINE circuit #-} -- | The /clique/ on a list of vertices. @@ -875,11 +892,9 @@ -- biclique xs ys == 'connect' ('vertices' xs) ('vertices' ys) -- @ biclique :: [a] -> [a] -> Graph a -biclique xs ys = buildg $ \e v o c -> - case foldr1Safe o (map v xs) of +biclique xs ys = buildg $ \e v o c -> case foldr1Safe o (map v xs) of Nothing -> foldg e v o c $ vertices ys - Just xs -> - case foldr1Safe o (map v ys) of + Just xs -> case foldr1Safe o (map v ys) of Nothing -> xs Just ys -> c xs ys {-# INLINE biclique #-} @@ -897,10 +912,9 @@ -- star x ys == 'connect' ('vertex' x) ('vertices' ys) -- @ star :: a -> [a] -> Graph a -star x ys = buildg $ \_ v o c -> - case foldr1Safe o (map v ys) of +star x ys = buildg $ \_ v o c -> case foldr1Safe o (map v ys) of Nothing -> v x - Just vertices -> c (v x) vertices + Just ys -> c (v x) ys {-# INLINE star #-} -- | The /stars/ formed by overlaying a list of 'star's. An inverse of @@ -920,8 +934,7 @@ -- 'overlay' (stars xs) (stars ys) == stars (xs ++ ys) -- @ stars :: [(a, [a])] -> Graph a -stars xs = buildg $ \e v o c -> - combineR e o (foldg e v o c . uncurry star) xs +stars xs = buildg $ \e v o c -> combineR e o (foldg e v o c . uncurry star) xs {-# INLINE stars #-} -- | The /tree graph/ constructed from a given 'Tree.Tree' data structure. @@ -968,14 +981,15 @@ mesh [] _ = empty mesh _ [] = empty mesh [x] [y] = vertex (x, y) -mesh xs ys = stars $ [ ((a1, b1), [(a1, b2), (a2, b1)]) | (a1, a2) <- ipxs, (b1, b2) <- ipys ] - ++ [ ((lx,y1), [(lx,y2)]) | (y1,y2) <- ipys] - ++ [ ((x1,ly), [(x2,ly)]) | (x1,x2) <- ipxs] +mesh xs ys = stars $ + [ ((a1, b1), [(a1, b2), (a2, b1)]) | (a1, a2) <- ix, (b1, b2) <- iy ] + ++ [ ((lx, y1), [(lx, y2)]) | (y1, y2) <- iy ] + ++ [ ((x1, ly), [(x2, ly)]) | (x1, x2) <- ix ] where lx = last xs ly = last ys - ipxs = init (pairs xs) - ipys = init (pairs ys) + ix = init (pairs xs) + iy = init (pairs ys) -- | Construct a /torus graph/ from two lists of vertices. -- Complexity: /O(L1 * L2)/ time, memory and size, where /L1/ and /L2/ are the @@ -990,7 +1004,8 @@ -- , ((2,\'a\'),(1,\'a\')), ((2,\'a\'),(2,\'b\')), ((2,\'b\'),(1,\'b\')), ((2,\'b\'),(2,\'a\')) ] -- @ torus :: [a] -> [b] -> Graph (a, b) -torus xs ys = stars [ ((a1, b1), [(a1, b2), (a2, b1)]) | (a1, a2) <- pairs xs, (b1, b2) <- pairs ys ] +torus xs ys = stars + [ ((a1, b1), [(a1, b2), (a2, b1)]) | (a1, a2) <- pairs xs, (b1, b2) <- pairs ys ] -- | Auxiliary function for 'mesh' and 'torus' pairs :: [a] -> [(a, a)] @@ -1079,7 +1094,7 @@ -- | Merge vertices satisfying a given predicate into a given vertex. -- Complexity: /O(s)/ time, memory and size, assuming that the predicate takes --- /O(1)/ to be evaluated. +-- constant time. -- -- Good consumer and producer. -- @@ -1108,8 +1123,8 @@ -- @ splitVertex :: Eq a => a -> [a] -> Graph a -> Graph a splitVertex x us g = buildg $ \e v o c -> - let gus = foldg e v o c (vertices us) in - foldg e (\w -> if w == x then gus else v w) o c g + let split y = if x == y then foldg e v o c (vertices us) else v y in + foldg e split o c g {-# INLINE splitVertex #-} {-# SPECIALISE splitVertex :: Int -> [Int] -> Graph Int -> Graph Int #-} @@ -1130,11 +1145,10 @@ transpose g = buildg $ \e v o c -> foldg e v o (flip c) g {-# INLINE transpose #-} --- TODO: Implement via 'induceJust' to reduce code duplication. -- | Construct the /induced subgraph/ of a given graph by removing the -- vertices that do not satisfy a given predicate. -- Complexity: /O(s)/ time, memory and size, assuming that the predicate takes --- /O(1)/ to be evaluated. +-- constant time. -- -- Good consumer and producer. -- @@ -1146,12 +1160,7 @@ -- 'isSubgraphOf' (induce p x) x == True -- @ induce :: (a -> Bool) -> Graph a -> Graph a -induce p g = buildg $ \e v o c -> fromMaybe e $ - foldg Nothing (\x -> if p x then Just (v x) else Nothing) (k o) (k c) g - where - k _ x Nothing = x -- Constant folding to get rid of Empty leaves - k _ Nothing y = y - k f (Just x) (Just y) = Just (f x y) +induce p = induceJust . fmap (\a -> if p a then Just a else Nothing) {-# INLINE induce #-} -- | Construct the /induced subgraph/ of a given graph by removing the vertices @@ -1168,7 +1177,7 @@ -- @ induceJust :: Graph (Maybe a) -> Graph a induceJust g = buildg $ \e v o c -> fromMaybe e $ - foldg Nothing (fmap v) (k o) (k c) g + foldg Nothing (fmap v) (k o) (k c) g where k _ x Nothing = x -- Constant folding to get rid of Empty leaves k _ Nothing y = y @@ -1259,10 +1268,10 @@ -- , ((0,\'b\'), (1,\'b\')) -- , ((1,\'a\'), (1,\'b\')) ] -- @ --- Up to an isomorphism between the resulting vertex types, this operation --- is /commutative/, /associative/, /distributes/ over 'overlay', has singleton +-- Up to isomorphism between the resulting vertex types, this operation is +-- /commutative/, /associative/, /distributes/ over 'overlay', has singleton -- graphs as /identities/ and 'empty' as the /annihilating zero/. Below @~~@ --- stands for the equality up to an isomorphism, e.g. @(x, ()) ~~ x@. +-- stands for equality up to an isomorphism, e.g. @(x,@ @()) ~~ x@. -- -- @ -- box x y ~~ box y x @@ -1342,39 +1351,41 @@ The rules for foldg work very similarly to GHC's mapFB rules; see a note below this line: http://hackage.haskell.org/package/base/docs/src/GHC.Base.html#mapFB. -* All concerned expressions are inlined to allow the compiler to apply the main - rule: "foldg/buildg". - This rule states that the composition of a good producer (expressed via buildg) - and a good consumer (expressed via foldg) can be fused to remove the construction - of the intermediate structure. +* The expressions are first inlined to allow the compiler to apply the main rule + "foldg/buildg" that states that the composition of a good producer (expressed + via 'buildg') and a good consumer (expressed via 'foldg') can be fused to + avoid the construction of an intermediate structure. -* If this inlining is made blindlessly, it can lead to unneeded operations. They - are optimized via the "foldg/id" rule. +* If this inlining is made blindly, it can lead to unneeded operations. They are + optimised via the "foldg/id" rule. -* composeR is here to allow further optimization. As an high-order function, it - benefit from inlining in the final phase. +* 'composeR' is here to allow further optimisation. As a high-order function, it + benefits from inlining in the final phase. -* The "composeR/composeR" rule optimises compositions of multiple composeR's. +* The "composeR/composeR" rule optimises compositions of 'composeR' chains. -} composeR :: (b -> c) -> (a -> b) -> a -> c composeR = (.) {-# INLINE [1] composeR #-} --- Rewrite rules for fusion. +-- Rewrite rules for algebraic graph fusion. {-# RULES --- Fuse a foldg followed by a buildg. + +-- Fuse a 'foldg' followed by a 'buildg': "foldg/buildg" forall e v o c (g :: forall b. b -> (a -> b) -> (b -> b -> b) -> (b -> b -> b) -> b). foldg e v o c (buildg g) = g e v o c --- Fuse composeR's (from bind's definition). +-- Fuse 'composeR' chains (see the definition of the bind operator). "composeR/composeR" forall c f g. composeR (composeR c f) g = composeR c (f . g) --- Rewrite identity (which can appear in the inlining of 'buildg') to a more efficient one. +-- Rewrite identity (which can appear in the inlining of 'buildg') to a more +-- efficient one. "foldg/id" foldg Empty Vertex Overlay Connect = id - #-} + +#-} -- 'Focus' on a specified subgraph. focus :: (a -> Bool) -> Graph a -> Focus a diff --git a/src/Algebra/Graph/Acyclic/AdjacencyMap.hs b/src/Algebra/Graph/Acyclic/AdjacencyMap.hs --- a/src/Algebra/Graph/Acyclic/AdjacencyMap.hs +++ b/src/Algebra/Graph/Acyclic/AdjacencyMap.hs @@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Acyclic.AdjacencyMap --- Copyright : (c) Andrey Mokhov 2016-2019 +-- Copyright : (c) Andrey Mokhov 2016-2021 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental @@ -121,7 +121,6 @@ vshow xs = showString "vertices " . showsPrec 11 xs -- | Construct the /empty graph/. --- Complexity: /O(1)/ time and memory. -- -- @ -- 'isEmpty' empty == True @@ -133,7 +132,6 @@ empty = coerce AM.empty -- | Construct the graph comprising /a single isolated vertex/. --- Complexity: /O(1)/ time and memory. -- -- @ -- 'isEmpty' (vertex x) == False @@ -283,7 +281,7 @@ edgeList = coerce AM.edgeList -- | The sorted /adjacency list/ of a graph. --- Complexity: /O(n + m)/ time and /O(m)/ memory. +-- Complexity: /O(n + m)/ time and memory. -- -- @ -- adjacencyList 'empty' == [] @@ -379,8 +377,7 @@ -- | Construct the /induced subgraph/ of a given graph by removing the -- vertices that do not satisfy a given predicate. --- Complexity: /O(n + m)/ time, assuming that the predicate takes /O(1)/ to --- be evaluated. +-- Complexity: /O(n + m)/ time, assuming that the predicate takes constant time. -- -- @ -- induce ('const' True ) x == x @@ -404,19 +401,19 @@ induceJust = coerce AM.induceJust -- | Compute the /Cartesian product/ of graphs. --- Complexity: /O(n * m * log(n)^2)/ time. +-- Complexity: /O((n + m) * log(n))/ time and O(n + m) memory. -- -- @ --- 'edgeList' (box (shrink $ 1 * 2) (shrink $ 10 * 20)) == [ ((1,10), (1,20)) +-- 'edgeList' (box ('shrink' $ 1 * 2) ('shrink' $ 10 * 20)) == [ ((1,10), (1,20)) -- , ((1,10), (2,10)) -- , ((1,20), (2,20)) -- , ((2,10), (2,20)) ] -- @ -- --- Up to an isomorphism between the resulting vertex types, this operation --- is /commutative/ and /associative/, has singleton graphs as /identities/ and --- 'empty' as the /annihilating zero/. Below @~~@ stands for the equality up to --- an isomorphism, e.g. @(x, ()) ~~ x@. +-- Up to isomorphism between the resulting vertex types, this operation is +-- /commutative/ and /associative/, has singleton graphs as /identities/ and +-- 'empty' as the /annihilating zero/. Below @~~@ stands for equality up to +-- an isomorphism, e.g. @(x,@ @()) ~~ x@. -- -- @ -- box x y ~~ box y x @@ -453,8 +450,8 @@ -- @ topSort :: Ord a => AdjacencyMap a -> [a] topSort g = case AM.topSort (coerce g) of - Right vs -> vs - Left _ -> error "Internal error: the acyclicity invariant is violated in topSort" + Right vs -> vs + Left _ -> error "Internal error: the acyclicity invariant is violated in topSort" -- | Compute the acyclic /condensation/ of a graph, where each vertex -- corresponds to a /strongly-connected component/ of the original graph. Note @@ -503,10 +500,9 @@ -- TODO: Add time complexity -- TODO: Change Arbitrary instance of Acyclic and Labelled Acyclic graph -- | Construct an acyclic graph from a given adjacency map using 'scc'. --- If the graph is acyclic in nature, the same graph is returned as an acyclic graph. --- If the graph is cyclic, then a representative for every strongly connected --- component in its condensation graph is chosen an these representatives are --- used to build an acyclic graph. +-- If the graph is acyclic, it is returned as is. If the graph is cyclic, then a +-- representative for every strongly connected component in its condensation +-- graph is chosen and these representatives are used to build an acyclic graph. -- -- @ -- shrink . 'AM.vertex' == 'vertex' diff --git a/src/Algebra/Graph/AdjacencyIntMap.hs b/src/Algebra/Graph/AdjacencyIntMap.hs --- a/src/Algebra/Graph/AdjacencyIntMap.hs +++ b/src/Algebra/Graph/AdjacencyIntMap.hs @@ -1,8 +1,7 @@ -{-# LANGUAGE DeriveGeneric #-} ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.AdjacencyIntMap --- Copyright : (c) Andrey Mokhov 2016-2019 +-- Copyright : (c) Andrey Mokhov 2016-2021 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental @@ -66,11 +65,13 @@ their adjacency sets. We define a 'Num' instance as a convenient notation for working with graphs: - > 0 == vertex 0 - > 1 + 2 == overlay (vertex 1) (vertex 2) - > 1 * 2 == connect (vertex 1) (vertex 2) - > 1 + 2 * 3 == overlay (vertex 1) (connect (vertex 2) (vertex 3)) - > 1 * (2 + 3) == connect (vertex 1) (overlay (vertex 2) (vertex 3)) +@ +0 == 'vertex' 0 +1 + 2 == 'overlay' ('vertex' 1) ('vertex' 2) +1 * 2 == 'connect' ('vertex' 1) ('vertex' 2) +1 + 2 * 3 == 'overlay' ('vertex' 1) ('connect' ('vertex' 2) ('vertex' 3)) +1 * (2 + 3) == 'connect' ('vertex' 1) ('overlay' ('vertex' 2) ('vertex' 3)) +@ __Note:__ the 'Num' instance does not satisfy several "customary laws" of 'Num', which dictate that 'fromInteger' @0@ and 'fromInteger' @1@ should act as @@ -202,6 +203,14 @@ instance NFData AdjacencyIntMap where rnf (AM a) = rnf a +-- | Defined via 'overlay'. +instance Semigroup AdjacencyIntMap where + (<>) = overlay + +-- | Defined via 'overlay' and 'empty'. +instance Monoid AdjacencyIntMap where + mempty = empty + -- | Construct an 'AdjacencyIntMap' from an 'AM.AdjacencyMap' with vertices of -- type 'Int'. -- Complexity: /O(n + m)/ time and memory. @@ -217,7 +226,6 @@ . AM.adjacencyMap -- | Construct the /empty graph/. --- Complexity: /O(1)/ time and memory. -- -- @ -- 'isEmpty' empty == True @@ -230,7 +238,6 @@ {-# NOINLINE [1] empty #-} -- | Construct the graph comprising /a single isolated vertex/. --- Complexity: /O(1)/ time and memory. -- -- @ -- 'isEmpty' (vertex x) == False @@ -243,7 +250,6 @@ {-# NOINLINE [1] vertex #-} -- | Construct the graph comprising /a single edge/. --- Complexity: /O(1)/ time, memory. -- -- @ -- edge x y == 'connect' ('vertex' x) ('vertex' y) @@ -304,12 +310,13 @@ -- @ -- vertices [] == 'empty' -- vertices [x] == 'vertex' x +-- vertices == 'overlays' . map 'vertex' -- 'hasVertex' x . vertices == 'elem' x -- 'vertexCount' . vertices == 'length' . 'Data.List.nub' -- 'vertexIntSet' . vertices == IntSet.'IntSet.fromList' -- @ vertices :: [Int] -> AdjacencyIntMap -vertices = AM . IntMap.fromList . map (\x -> (x, IntSet.empty)) +vertices = AM . IntMap.fromList . map (, IntSet.empty) {-# NOINLINE [1] vertices #-} -- | Construct the graph from a list of edges. @@ -482,7 +489,7 @@ edgeSet = Set.fromAscList . edgeList -- | The sorted /adjacency list/ of a graph. --- Complexity: /O(n + m)/ time and /O(m)/ memory. +-- Complexity: /O(n + m)/ time and memory. -- -- @ -- adjacencyList 'empty' == [] @@ -697,7 +704,7 @@ -- | Merge vertices satisfying a given predicate into a given vertex. -- Complexity: /O((n + m) * log(n))/ time, assuming that the predicate takes --- /O(1)/ to be evaluated. +-- constant time. -- -- @ -- mergeVertices ('const' False) x == id @@ -755,8 +762,7 @@ -- | Construct the /induced subgraph/ of a given graph by removing the -- vertices that do not satisfy a given predicate. --- Complexity: /O(n + m)/ time, assuming that the predicate takes /O(1)/ to --- be evaluated. +-- Complexity: /O(n + m)/ time, assuming that the predicate takes constant time. -- -- @ -- induce ('const' True ) x == x @@ -825,7 +831,7 @@ -- reflexiveClosure . reflexiveClosure == reflexiveClosure -- @ reflexiveClosure :: AdjacencyIntMap -> AdjacencyIntMap -reflexiveClosure (AM m) = AM $ IntMap.mapWithKey (\k -> IntSet.insert k) m +reflexiveClosure (AM m) = AM $ IntMap.mapWithKey IntSet.insert m -- | Compute the /symmetric closure/ of a graph by overlaying it with its own -- transpose. diff --git a/src/Algebra/Graph/AdjacencyIntMap/Algorithm.hs b/src/Algebra/Graph/AdjacencyIntMap/Algorithm.hs --- a/src/Algebra/Graph/AdjacencyIntMap/Algorithm.hs +++ b/src/Algebra/Graph/AdjacencyIntMap/Algorithm.hs @@ -3,7 +3,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.AdjacencyIntMap.Algorithm --- Copyright : (c) Andrey Mokhov 2016-2018 +-- Copyright : (c) Andrey Mokhov 2016-2021 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : unstable @@ -23,7 +23,7 @@ -- * Algorithms bfsForest, bfs, dfsForest, dfsForestFrom, dfs, reachable, topSort, isAcyclic, - + -- * Correctness properties isDfsForestOf, isTopSortOf, @@ -50,7 +50,7 @@ -- 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)*min(n,W))/ time and /O(n)/ space. @@ -69,7 +69,7 @@ -- , Node { rootLabel = 4 -- , subForest = [] }] -- 'forest' (bfsForest [3] ('circuit' [1..5] + 'circuit' [5,4..1])) == 'path' [3,2,1] + 'path' [3,4,5] --- +-- -- @ bfsForest :: [Int] -> AdjacencyIntMap -> Forest Int bfsForest vs g = evalState (explore [ v | v <- vs, hasVertex v g ]) IntSet.empty where @@ -88,7 +88,7 @@ -- -- Let /L/ be the number of seed vertices. Complexity: -- /O((L+m)*min(n,W))/ time and /O(n)/ space. --- +-- -- @ -- bfs vs 'empty' == [] -- bfs [] g == [] @@ -141,7 +141,7 @@ -- 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)*min(n,W))/ time and /O(n)/ space. -- @@ -182,7 +182,7 @@ -- | Compute the vertices visited by /depth-first search/ in a graph -- from the given vertices. Adjacent vertices are explored in -- increasing order with respect to their 'Ord' instance. --- +-- -- Let /L/ be the number of seed vertices. Complexity: -- /O((L+m)*min(n,W))/ time and /O(n)/ space. -- @@ -207,7 +207,7 @@ -- appear in /depth-first order/. -- -- Complexity: /O(m*min(n,W))/ time and /O(n)/ space. --- +-- -- @ -- reachable x $ 'empty' == [] -- reachable 1 $ 'vertex' 1 == [1] diff --git a/src/Algebra/Graph/AdjacencyMap.hs b/src/Algebra/Graph/AdjacencyMap.hs --- a/src/Algebra/Graph/AdjacencyMap.hs +++ b/src/Algebra/Graph/AdjacencyMap.hs @@ -1,8 +1,7 @@ -{-# LANGUAGE DeriveGeneric #-} ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.AdjacencyMap --- Copyright : (c) Andrey Mokhov 2016-2019 +-- Copyright : (c) Andrey Mokhov 2016-2021 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental @@ -12,9 +11,9 @@ -- motivation behind the library, the underlying theory, and implementation details. -- -- This module defines the 'AdjacencyMap' data type and associated functions. --- See "Algebra.Graph.AdjacencyMap.Algorithm" for implementations of basic graph --- algorithms. 'AdjacencyMap' is an instance of the 'C.Graph' type class, which --- can be used for polymorphic graph construction and manipulation. +-- See "Algebra.Graph.AdjacencyMap.Algorithm" for basic graph algorithms. +-- 'AdjacencyMap' is an instance of the 'C.Graph' type class, which can be used +-- for polymorphic graph construction and manipulation. -- "Algebra.Graph.AdjacencyIntMap" defines adjacency maps specialised to graphs -- with @Int@ vertices. ----------------------------------------------------------------------------- @@ -55,6 +54,7 @@ import Data.Map.Strict (Map) import Data.Monoid import Data.Set (Set) +import Data.String import Data.Tree import GHC.Generics @@ -66,11 +66,13 @@ their adjacency sets. We define a 'Num' instance as a convenient notation for working with graphs: - > 0 == vertex 0 - > 1 + 2 == overlay (vertex 1) (vertex 2) - > 1 * 2 == connect (vertex 1) (vertex 2) - > 1 + 2 * 3 == overlay (vertex 1) (connect (vertex 2) (vertex 3)) - > 1 * (2 + 3) == connect (vertex 1) (overlay (vertex 2) (vertex 3)) +@ +0 == 'vertex' 0 +1 + 2 == 'overlay' ('vertex' 1) ('vertex' 2) +1 * 2 == 'connect' ('vertex' 1) ('vertex' 2) +1 + 2 * 3 == 'overlay' ('vertex' 1) ('connect' ('vertex' 2) ('vertex' 3)) +1 * (2 + 3) == 'connect' ('vertex' 1) ('overlay' ('vertex' 2) ('vertex' 3)) +@ __Note:__ the 'Num' instance does not satisfy several "customary laws" of 'Num', which dictate that 'fromInteger' @0@ and 'fromInteger' @1@ should act as @@ -199,11 +201,21 @@ abs = id negate = id +instance IsString a => IsString (AdjacencyMap a) where + fromString = vertex . fromString + instance NFData a => NFData (AdjacencyMap a) where rnf (AM a) = rnf a +-- | Defined via 'overlay'. +instance Ord a => Semigroup (AdjacencyMap a) where + (<>) = overlay + +-- | Defined via 'overlay' and 'empty'. +instance Ord a => Monoid (AdjacencyMap a) where + mempty = empty + -- | Construct the /empty graph/. --- Complexity: /O(1)/ time and memory. -- -- @ -- 'isEmpty' empty == True @@ -216,7 +228,6 @@ {-# NOINLINE [1] empty #-} -- | Construct the graph comprising /a single isolated vertex/. --- Complexity: /O(1)/ time and memory. -- -- @ -- 'isEmpty' (vertex x) == False @@ -229,7 +240,6 @@ {-# NOINLINE [1] vertex #-} -- | Construct the graph comprising /a single edge/. --- Complexity: /O(1)/ time, memory. -- -- @ -- edge x y == 'connect' ('vertex' x) ('vertex' y) @@ -279,7 +289,7 @@ -- 'edgeCount' (connect 1 2) == 1 -- @ connect :: Ord a => AdjacencyMap a -> AdjacencyMap a -> AdjacencyMap a -connect (AM x) (AM y) = AM $ Map.unionsWith Set.union $ +connect (AM x) (AM y) = AM $ Map.unionsWith Set.union [ x, y, Map.fromSet (const $ Map.keysSet y) (Map.keysSet x) ] {-# NOINLINE [1] connect #-} @@ -290,12 +300,13 @@ -- @ -- vertices [] == 'empty' -- vertices [x] == 'vertex' x +-- vertices == 'overlays' . map 'vertex' -- 'hasVertex' x . vertices == 'elem' x -- 'vertexCount' . vertices == 'length' . 'Data.List.nub' -- 'vertexSet' . vertices == Set.'Set.fromList' -- @ vertices :: Ord a => [a] -> AdjacencyMap a -vertices = AM . Map.fromList . map (\x -> (x, Set.empty)) +vertices = AM . Map.fromList . map (, Set.empty) {-# NOINLINE [1] vertices #-} -- | Construct the graph from a list of edges. @@ -467,7 +478,7 @@ edgeSet = Set.fromAscList . edgeList -- | The sorted /adjacency list/ of a graph. --- Complexity: /O(n + m)/ time and /O(m)/ memory. +-- Complexity: /O(n + m)/ time and memory. -- -- @ -- adjacencyList 'empty' == [] @@ -681,7 +692,7 @@ -- | Merge vertices satisfying a given predicate into a given vertex. -- Complexity: /O((n + m) * log(n))/ time, assuming that the predicate takes --- /O(1)/ to be evaluated. +-- constant time. -- -- @ -- mergeVertices ('const' False) x == id @@ -739,8 +750,7 @@ -- | Construct the /induced subgraph/ of a given graph by removing the -- vertices that do not satisfy a given predicate. --- Complexity: /O(n + m)/ time, assuming that the predicate takes /O(1)/ to --- be evaluated. +-- Complexity: /O(n + m)/ time, assuming that the predicate takes constant time. -- -- @ -- induce ('const' True ) x == x @@ -797,7 +807,7 @@ vs = vertexSet x `Set.union` vertexSet y -- | Compute the /Cartesian product/ of graphs. --- Complexity: /O(n * m * log(n)^2)/ time. +-- Complexity: /O((n + m) * log(n))/ time and O(n + m) memory. -- -- @ -- box ('path' [0,1]) ('path' "ab") == 'edges' [ ((0,\'a\'), (0,\'b\')) @@ -806,10 +816,10 @@ -- , ((1,\'a\'), (1,\'b\')) ] -- @ -- --- Up to an isomorphism between the resulting vertex types, this operation --- is /commutative/, /associative/, /distributes/ over 'overlay', has singleton +-- Up to isomorphism between the resulting vertex types, this operation is +-- /commutative/, /associative/, /distributes/ over 'overlay', has singleton -- graphs as /identities/ and 'empty' as the /annihilating zero/. Below @~~@ --- stands for the equality up to an isomorphism, e.g. @(x, ()) ~~ x@. +-- stands for equality up to an isomorphism, e.g. @(x,@ @()) ~~ x@. -- -- @ -- box x y ~~ box y x @@ -860,7 +870,7 @@ -- reflexiveClosure . reflexiveClosure == reflexiveClosure -- @ reflexiveClosure :: Ord a => AdjacencyMap a -> AdjacencyMap a -reflexiveClosure (AM m) = AM $ Map.mapWithKey (\k -> Set.insert k) m +reflexiveClosure (AM m) = AM $ Map.mapWithKey Set.insert m -- | Compute the /symmetric closure/ of a graph by overlaying it with its own -- transpose. diff --git a/src/Algebra/Graph/AdjacencyMap/Algorithm.hs b/src/Algebra/Graph/AdjacencyMap/Algorithm.hs --- a/src/Algebra/Graph/AdjacencyMap/Algorithm.hs +++ b/src/Algebra/Graph/AdjacencyMap/Algorithm.hs @@ -3,7 +3,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.AdjacencyMap.Algorithm --- Copyright : (c) Andrey Mokhov 2016-2018 +-- Copyright : (c) Andrey Mokhov 2016-2021 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : unstable @@ -329,15 +329,15 @@ initialState = SCC 0 0 [] [] Map.empty Map.empty [] [] [] data StateSCC a - = SCC { preorder :: {-# unpack #-} !Int - , component :: {-# unpack #-} !Int + = SCC { _preorder :: {-# unpack #-} !Int + , _component :: {-# unpack #-} !Int , boundaryStack :: [(Int,a)] - , pathStack :: [a] + , _pathStack :: [a] , preorders :: Map.Map a Int , components :: Map.Map a Int - , innerGraphs :: [AdjacencyMap a] - , innerEdges :: [(Int,(a,a))] - , outerEdges :: [(a,a)] + , _innerGraphs :: [AdjacencyMap a] + , _innerEdges :: [(Int,(a,a))] + , _outerEdges :: [(a,a)] } deriving (Show) gabowSCC :: Ord a => AdjacencyMap a -> State (StateSCC a) () diff --git a/src/Algebra/Graph/Bipartite/AdjacencyMap.hs b/src/Algebra/Graph/Bipartite/AdjacencyMap.hs new file mode 100644 --- /dev/null +++ b/src/Algebra/Graph/Bipartite/AdjacencyMap.hs @@ -0,0 +1,977 @@ +---------------------------------------------------------------------------- +-- | +-- Module : Algebra.Graph.Bipartite.AdjacencyMap +-- Copyright : (c) Andrey Mokhov 2016-2021 +-- License : MIT (see the file LICENSE) +-- Maintainer : andrey.mokhov@gmail.com +-- Stability : experimental +-- +-- __Alga__ is a library for algebraic construction and manipulation of graphs +-- in Haskell. See for +-- the motivation behind the library, the underlying theory, and +-- implementation details. +-- +-- This module defines the 'AdjacencyMap' data type for undirected bipartite +-- graphs and associated functions. See +-- "Algebra.Graph.Bipartite.AdjacencyMap.Algorithm" for basic bipartite graph +-- algorithms. +-- +-- To avoid name clashes with "Algebra.Graph.AdjacencyMap", this module can be +-- imported qualified: +-- +-- @ +-- import qualified Algebra.Graph.Bipartite.AdjacencyMap as Bipartite +-- @ +---------------------------------------------------------------------------- +module Algebra.Graph.Bipartite.AdjacencyMap ( + -- * Data structure + AdjacencyMap, leftAdjacencyMap, rightAdjacencyMap, + + -- * Basic graph construction primitives + empty, leftVertex, rightVertex, vertex, edge, overlay, connect, vertices, + edges, overlays, connects, swap, + + -- * Conversion functions + toBipartite, toBipartiteWith, fromBipartite, fromBipartiteWith, + + -- * Graph properties + isEmpty, hasLeftVertex, hasRightVertex, hasVertex, hasEdge, leftVertexCount, + rightVertexCount, vertexCount, edgeCount, leftVertexList, rightVertexList, + vertexList, edgeList, leftVertexSet, rightVertexSet, vertexSet, edgeSet, + leftAdjacencyList, rightAdjacencyList, + + -- * Standard families of graphs + List (..), evenList, oddList, path, circuit, biclique, star, stars, mesh, + + -- * Graph transformation + removeLeftVertex, removeRightVertex, removeEdge, bimap, + + -- * Graph composition + box, boxWith, + + -- * Miscellaneous + consistent + ) where + +import Control.Monad +import Control.Monad.Trans.Maybe +import Control.Monad.State +import Data.Either +import Data.Foldable (asum) +import Data.List ((\\), sort) +import Data.Map.Strict (Map) +import Data.Maybe +import Data.Set (Set) +import GHC.Exts (IsList(..)) +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 parameters determine the types of vertices of each part. If +the types coincide, the vertices of the left part are still treated as disjoint +from the vertices of the right part. 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]) +@ + +__Note:__ the 'Num' instance does not satisfy several "customary laws" of 'Num', +which dictate that 'fromInteger' @0@ and 'fromInteger' @1@ should act as +additive and multiplicative identities, and 'negate' as additive inverse. +Nevertheless, overloading 'fromInteger', '+' and '*' is very convenient when +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 '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)" +@ + +The 'Eq' instance satisfies all axioms of undirected bipartite algebraic graphs: + + * 'overlay' is commutative and associative: + + > x + y == y + x + > x + (y + z) == (x + y) + z + + * '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': + + > x * (y + z) == x * y + x * z + > (x + y) * z == x * z + y * z + + * 'connect' can be decomposed: + + > x * y * z == x * y + x * z + y * z + + * 'connect' has the same effect as 'overlay' on vertices of the same part: + + > 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: + + > x + empty == x + > empty + x == x + > x + x == x + + * Absorption and saturation of 'connect': + + > x * y + x + y == x * y + > x * x * x == x * x + +When specifying the time and memory complexity of graph algorithms, /n/ and /m/ +will denote the number of vertices and edges of the graph, respectively. In +addition, /l/ and /r/ will denote the number of vertices in the left and right +parts of the graph, respectively. +-} +data AdjacencyMap a b = BAM { + -- | 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' 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 a (Set b), + + -- | The /adjacency map/ of the right part of the graph: each right vertex + -- is associated with a set of its left neighbours. + -- Complexity: /O(1)/ time and memory. + -- + -- @ + -- 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 b (Set a) + } deriving Generic + +-- | __Note:__ this does not satisfy the usual ring laws; see 'AdjacencyMap' +-- for more details. +instance (Ord a, Ord b, Num b) => Num (AdjacencyMap a b) where + fromInteger = rightVertex . fromInteger + (+) = overlay + (*) = connect + signum = const empty + abs = id + negate = id + +instance (Ord a, Ord b) => Eq (AdjacencyMap a b) where + BAM ab1 ba1 == BAM ab2 ba2 = ab1 == ab2 && Map.keysSet ba1 == Map.keysSet ba2 + +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 g + | null as && null bs = showString "empty" + | null es = showParen (p > 10) $ vShow as bs + | (as == aUsed) && (bs == bUsed) = showParen (p > 10) $ eShow es + | otherwise = showParen (p > 10) + $ showString "overlay (" + . veShow (vs \\ used) + . showString ") (" + . eShow es + . showString ")" + where + as = leftVertexList g + bs = rightVertexList g + vs = vertexList g + es = edgeList g + aUsed = Set.toAscList $ Set.fromAscList [ a | (a, _) <- edgeList g ] + bUsed = Set.toAscList $ Set.fromAscList [ b | (b, _) <- edgeList (swap g) ] + used = map Left aUsed ++ map Right bUsed + vShow [a] [] = showString "leftVertex " . showsPrec 11 a + vShow [] [b] = showString "rightVertex " . showsPrec 11 b + vShow as bs = showString "vertices " . showsPrec 11 as + . showString " " . showsPrec 11 bs + eShow [(a, b)] = showString "edge " . showsPrec 11 a + . showString " " . showsPrec 11 b + eShow es = showString "edges " . showsPrec 11 es + veShow xs = vShow (lefts xs) (rights xs) + +-- | Defined via 'overlay'. +instance (Ord a, Ord b) => Semigroup (AdjacencyMap a b) where + (<>) = overlay + +-- | Defined via 'overlay' and 'empty'. +instance (Ord a, Ord b) => Monoid (AdjacencyMap a b) where + mempty = empty + +-- | Construct the /empty graph/. +-- +-- @ +-- 'isEmpty' empty == True +-- 'leftAdjacencyMap' empty == Map.'Map.empty' +-- 'rightAdjacencyMap' empty == Map.'Map.empty' +-- 'hasVertex' x empty == False +-- @ +empty :: AdjacencyMap a b +empty = BAM Map.empty Map.empty + +-- | Construct the graph comprising /a single isolated vertex/ in the left part. +-- +-- @ +-- '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 +-- @ +leftVertex :: a -> AdjacencyMap a b +leftVertex a = BAM (Map.singleton a Set.empty) Map.empty + +-- | Construct the graph comprising /a single isolated vertex/ in the right part. +-- +-- @ +-- 'leftAdjacencyMap' (rightVertex x) == Map.'Map.empty' +-- 'rightAdjacencyMap' (rightVertex x) == Map.'Map.singleton' x Set.'Set.empty' +-- 'hasLeftVertex' x (rightVertex y) == False +-- 'hasRightVertex' x (rightVertex y) == (x == y) +-- 'hasEdge' x y (rightVertex z) == False +-- @ +rightVertex :: b -> AdjacencyMap a b +rightVertex b = BAM Map.empty (Map.singleton b Set.empty) + +-- | Construct the graph comprising /a single isolated vertex/. +-- +-- @ +-- vertex . Left == 'leftVertex' +-- vertex . Right == 'rightVertex' +-- @ +vertex :: Either a b -> AdjacencyMap a b +vertex (Left a) = leftVertex a +vertex (Right b) = rightVertex b + +-- | Construct the graph comprising /a single edge/. +-- +-- @ +-- 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 2 (edge 2 1) == False +-- @ +edge :: a -> b -> AdjacencyMap a b +edge a b = + BAM (Map.singleton a (Set.singleton b)) (Map.singleton b (Set.singleton a)) + +-- | /Overlay/ two graphs. This is a commutative, associative and idempotent +-- operation with the identity 'empty'. +-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. +-- +-- @ +-- 'isEmpty' (overlay x y) == 'isEmpty' x && 'isEmpty' y +-- 'hasVertex' z (overlay x y) == 'hasVertex' z x || 'hasVertex' z y +-- 'vertexCount' (overlay x y) >= 'vertexCount' x +-- 'vertexCount' (overlay x y) <= 'vertexCount' x + 'vertexCount' y +-- 'edgeCount' (overlay x y) >= 'edgeCount' x +-- 'edgeCount' (overlay x y) <= 'edgeCount' x + 'edgeCount' y +-- @ +overlay :: (Ord a, Ord b) => AdjacencyMap a b -> AdjacencyMap a b -> AdjacencyMap a b +overlay (BAM ab1 ba1) (BAM ab2 ba2) = + BAM (Map.unionWith Set.union ab1 ab2) (Map.unionWith Set.union ba1 ba2) + +-- | /Connect/ two graphs, filtering out the edges between vertices of the same +-- part. This is a commutative and associative operation with the identity +-- 'empty', which distributes over 'overlay' and obeys the decomposition axiom. +-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. Note that the +-- number of edges in the resulting graph is quadratic with respect to the +-- number of vertices in the arguments: /O(m1 + m2 + l1 * r2 + l2 * r1)/. +-- +-- @ +-- 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) >= '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 ab1 ba1) (BAM ab2 ba2) = BAM ab ba + where + a1 = Map.keysSet ab1 + a2 = Map.keysSet ab2 + b1 = Map.keysSet ba1 + b2 = Map.keysSet ba2 + ab = Map.unionsWith Set.union + [ ab1, ab2, Map.fromSet (const b2) a1, Map.fromSet (const b1) a2 ] + ba = Map.unionsWith Set.union + [ ba1, ba2, Map.fromSet (const a2) b1, Map.fromSet (const a1) b2 ] + +-- | Construct the graph comprising given lists of isolated vertices in each +-- part. +-- Complexity: /O(L * log(L))/ time and /O(L)/ memory, where /L/ is the total +-- length of two lists. +-- +-- @ +-- vertices [] [] == 'empty' +-- vertices [x] [] == 'leftVertex' x +-- vertices [] [x] == 'rightVertex' x +-- vertices xs ys == 'overlays' ('map' 'leftVertex' xs ++ 'map' 'rightVertex' ys) +-- '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 as bs = BAM (Map.fromList [ (a, Set.empty) | a <- as ]) + (Map.fromList [ (b, Set.empty) | b <- bs ]) + +-- | 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 +-- 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 [ (a, Set.singleton b) | (a, b) <- es ]) + (Map.fromListWith Set.union [ (b, Set.singleton a) | (a, b) <- es ]) + +-- | Overlay a given list of graphs. +-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. +-- +-- @ +-- overlays [] == 'empty' +-- overlays [x] == x +-- overlays [x,y] == 'overlay' x y +-- overlays == 'foldr' 'overlay' 'empty' +-- 'isEmpty' . overlays == 'all' 'isEmpty' +-- @ +overlays :: (Ord a, Ord b) => [AdjacencyMap a b] -> AdjacencyMap a b +overlays xs = BAM (Map.unionsWith Set.union (map leftAdjacencyMap xs)) + (Map.unionsWith Set.union (map rightAdjacencyMap xs)) + +-- | Connect a given list of graphs. +-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. +-- +-- @ +-- connects [] == 'empty' +-- connects [x] == x +-- connects [x,y] == connect x y +-- connects == 'foldr' 'connect' 'empty' +-- 'isEmpty' . connects == 'all' 'isEmpty' +-- @ +connects :: (Ord a, Ord b) => [AdjacencyMap a b] -> AdjacencyMap a b +connects = foldr connect empty + +-- | Swap the parts of a given graph. +-- Complexity: /O(1)/ time and memory. +-- +-- @ +-- 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 ab ba) = BAM ba ab + +-- | Construct a bipartite 'AdjacencyMap' from an "Algebra.Graph.AdjacencyMap", +-- adding any missing edges to make the graph undirected and filtering out the +-- edges within the same parts. +-- Complexity: /O(m * log(n))/. +-- +-- @ +-- 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' == 'uncurry' 'biclique' . 'partitionEithers' +-- toBipartite . 'fromBipartite' == 'id' +-- @ +toBipartite :: (Ord a, Ord b) => AM.AdjacencyMap (Either a b) -> AdjacencyMap a b +toBipartite g = BAM (Map.fromAscList [ (a, getRights vs) | (Left a, vs) <- am ]) + (Map.fromAscList [ (b, getLefts vs) | (Right b, vs) <- am ]) + where + getRights = Set.fromAscList . rights . Set.toAscList + getLefts = Set.fromAscList . lefts . Set.toAscList + am = Map.toAscList $ AM.adjacencyMap $ AM.symmetricClosure g + +-- | Construct a bipartite 'AdjacencyMap' from an "Algebra.Graph.AdjacencyMap", +-- where the two parts are identified by a separate function, adding any missing +-- edges to make the graph undirected and filtering out the edges within the +-- same parts. +-- Complexity: /O(m * log(n))/. +-- +-- @ +-- 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 "Algebra.Graph.AdjacencyMap" from a bipartite 'AdjacencyMap'. +-- Complexity: /O(m * log(n))/. +-- +-- @ +-- fromBipartite 'empty' == 'Algebra.Graph.AdjacencyMap.empty' +-- 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 ab ba) = AM.fromAdjacencySets $ + [ (Left a, Set.mapMonotonic Right bs) | (a, bs) <- Map.toAscList ab ] ++ + [ (Right b, Set.mapMonotonic Left as) | (b, as) <- Map.toAscList ba ] + +-- | Construct an "Algebra.Graph.AdjacencyMap" from a bipartite 'AdjacencyMap' +-- given a way to inject vertices of the two parts into the resulting vertex +-- type. +-- Complexity: /O(m * log(n))/. +-- +-- @ +-- 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' +-- @ +fromBipartiteWith :: Ord c => (a -> c) -> (b -> c) -> AdjacencyMap a b -> AM.AdjacencyMap c +fromBipartiteWith f g (BAM ab ba) = AM.fromAdjacencySets $ + [ (f a, Set.map g bs) | (a, bs) <- Map.toAscList ab ] ++ + [ (g b, Set.map f as) | (b, as) <- Map.toAscList ba ] + +-- | Check if a graph is empty. +-- Complexity: /O(1)/ time. +-- +-- @ +-- isEmpty 'empty' == True +-- isEmpty ('overlay' 'empty' 'empty') == True +-- isEmpty ('vertex' x) == False +-- isEmpty == (==) 'empty' +-- @ +isEmpty :: AdjacencyMap a b -> Bool +isEmpty (BAM ab ba) = Map.null ab && Map.null ba + +-- | Check if a graph contains a given vertex in the left part. +-- Complexity: /O(log(l))/ time. +-- +-- @ +-- hasLeftVertex x 'empty' == False +-- hasLeftVertex x ('leftVertex' y) == (x == y) +-- hasLeftVertex x ('rightVertex' y) == False +-- @ +hasLeftVertex :: Ord a => a -> AdjacencyMap a b -> Bool +hasLeftVertex a (BAM ab _) = Map.member a ab + +-- | Check if a graph contains a given vertex in the right part. +-- Complexity: /O(log(r))/ time. +-- +-- @ +-- hasRightVertex x 'empty' == False +-- hasRightVertex x ('leftVertex' y) == False +-- hasRightVertex x ('rightVertex' y) == (x == y) +-- @ +hasRightVertex :: Ord b => b -> AdjacencyMap a b -> Bool +hasRightVertex b (BAM _ ba) = Map.member b ba + +-- | Check if a graph contains a given vertex. +-- Complexity: /O(log(n))/ time. +-- +-- @ +-- hasVertex . Left == 'hasLeftVertex' +-- hasVertex . Right == 'hasRightVertex' +-- @ +hasVertex :: (Ord a, Ord b) => Either a b -> AdjacencyMap a b -> Bool +hasVertex (Left a) = hasLeftVertex a +hasVertex (Right b) = hasRightVertex b + +-- | 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 a b (BAM ab _) = (Set.member b <$> Map.lookup a ab) == Just True + +-- | The number of vertices in the left part of a graph. +-- Complexity: /O(1)/ time. +-- +-- @ +-- leftVertexCount 'empty' == 0 +-- leftVertexCount ('leftVertex' x) == 1 +-- leftVertexCount ('rightVertex' x) == 0 +-- leftVertexCount ('edge' x y) == 1 +-- leftVertexCount . 'edges' == 'length' . 'nub' . 'map' 'fst' +-- @ +leftVertexCount :: AdjacencyMap a b -> Int +leftVertexCount = Map.size . leftAdjacencyMap + +-- | The number of vertices in the right part of a graph. +-- Complexity: /O(1)/ time. +-- +-- @ +-- rightVertexCount 'empty' == 0 +-- rightVertexCount ('leftVertex' x) == 0 +-- rightVertexCount ('rightVertex' x) == 1 +-- rightVertexCount ('edge' x y) == 1 +-- rightVertexCount . 'edges' == 'length' . 'nub' . 'map' 'snd' +-- @ +rightVertexCount :: AdjacencyMap a b -> Int +rightVertexCount = Map.size . rightAdjacencyMap + +-- | The number of vertices in a graph. +-- Complexity: /O(1)/ time. +-- +-- @ +-- 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 + +-- | The number of edges in a graph. +-- Complexity: /O(l)/ time. +-- +-- @ +-- edgeCount 'empty' == 0 +-- edgeCount ('vertex' x) == 0 +-- edgeCount ('edge' x y) == 1 +-- edgeCount . 'edges' == 'length' . 'nub' +-- @ +edgeCount :: AdjacencyMap a b -> Int +edgeCount = Map.foldr ((+) . Set.size) 0 . leftAdjacencyMap + +-- | The sorted list of vertices of the left part of a graph. +-- Complexity: /O(l)/ time and memory. +-- +-- @ +-- leftVertexList 'empty' == [] +-- leftVertexList ('leftVertex' x) == [x] +-- leftVertexList ('rightVertex' x) == [] +-- leftVertexList . 'flip' 'vertices' [] == 'nub' . 'sort' +-- @ +leftVertexList :: AdjacencyMap a b -> [a] +leftVertexList = Map.keys . leftAdjacencyMap + +-- | The sorted list of vertices of the right part of a graph. +-- Complexity: /O(r)/ time and memory. +-- +-- @ +-- rightVertexList 'empty' == [] +-- rightVertexList ('leftVertex' x) == [] +-- rightVertexList ('rightVertex' x) == [x] +-- rightVertexList . 'vertices' [] == 'nub' . 'sort' +-- @ +rightVertexList :: AdjacencyMap a b -> [b] +rightVertexList = Map.keys . rightAdjacencyMap + +-- | The sorted list of vertices of a graph. +-- Complexity: /O(n)/ time and memory +-- +-- @ +-- vertexList 'empty' == [] +-- vertexList ('vertex' x) == [x] +-- 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) + +-- | The sorted list of edges of a graph. +-- Complexity: /O(n + m)/ time and /O(m)/ memory. +-- +-- @ +-- edgeList 'empty' == [] +-- edgeList ('vertex' x) == [] +-- edgeList ('edge' x y) == [(x,y)] +-- edgeList . 'edges' == 'nub' . 'sort' +-- @ +edgeList :: AdjacencyMap a b -> [(a, b)] +edgeList (BAM ab _) = [ (a, b) | (a, bs) <- Map.toAscList ab, b <- Set.toAscList bs ] + +-- | The set of vertices of the left part of a graph. +-- Complexity: /O(l)/ time and memory. +-- +-- @ +-- 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 a +leftVertexSet = Map.keysSet . leftAdjacencyMap + +-- | The set of vertices of the right part of a graph. +-- Complexity: /O(r)/ time and memory. +-- +-- @ +-- 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 b +rightVertexSet = Map.keysSet . rightAdjacencyMap + +-- TODO: Check if implementing this via 'Set.mapMonotonic' would be faster. +-- | The set of vertices of a graph. +-- Complexity: /O(n)/ time and memory. +-- +-- @ +-- 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 (Either a b) +vertexSet = Set.fromAscList . vertexList + +-- | The set of edges of a graph. +-- Complexity: /O(n + m)/ time and /O(m)/ memory. +-- +-- @ +-- edgeSet 'empty' == Set.'Data.Set.empty' +-- edgeSet ('vertex' x) == Set.'Data.Set.empty' +-- 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 (a, b) +edgeSet = Set.fromAscList . edgeList + +-- | The sorted /adjacency list/ of the left part of a graph. +-- Complexity: /O(n + m)/ time and memory. +-- +-- @ +-- leftAdjacencyList 'empty' == [] +-- leftAdjacencyList ('vertices' [] xs) == [] +-- leftAdjacencyList ('vertices' xs []) == [(x, []) | x <- 'nub' ('sort' xs)] +-- leftAdjacencyList ('edge' x y) == [(x, [y])] +-- leftAdjacencyList ('star' x ys) == [(x, 'nub' ('sort' ys))] +-- @ +leftAdjacencyList :: AdjacencyMap a b -> [(a, [b])] +leftAdjacencyList (BAM ab _) = fmap Set.toAscList <$> Map.toAscList ab + +-- | The sorted /adjacency list/ of the right part of a graph. +-- Complexity: /O(n + m)/ time and memory. +-- +-- @ +-- rightAdjacencyList 'empty' == [] +-- rightAdjacencyList ('vertices' [] xs) == [(x, []) | x <- 'nub' ('sort' xs)] +-- rightAdjacencyList ('vertices' xs []) == [] +-- rightAdjacencyList ('edge' x y) == [(y, [x])] +-- rightAdjacencyList ('star' x ys) == [(y, [x]) | y <- 'nub' ('sort' ys)] +-- @ +rightAdjacencyList :: AdjacencyMap a b -> [(b, [a])] +rightAdjacencyList (BAM _ ba) = fmap Set.toAscList <$> Map.toAscList ba + +-- | A list of values of two alternating types. The first type argument denotes +-- the type of the value at the head. +-- +-- With the @OverloadedLists@ extension it is possible to use the standard list +-- notation to construct a 'List' where the two types coincide, for example: +-- +-- @ +-- [1, 2, 3, 4, 5] :: List Int Int +-- @ +-- +-- We make use of this shorthand notation in the examples below. +data List a b = Nil | Cons a (List b a) deriving (Eq, Generic, Ord, Show) + +instance IsList (List a a) where + type Item (List a a) = a + + fromList = foldr Cons Nil + + toList Nil = [] + toList (Cons a as) = a : toList as + +-- | Construct a 'List' of even length from a list of pairs. +-- +-- @ +-- evenList [] == 'Nil' +-- evenList [(1,2), (3,4)] == [1, 2, 3, 4] :: 'List' Int Int +-- evenList [(1,\'a\'), (2,\'b\')] == 'Cons' 1 ('Cons' \'a\' ('Cons' 2 ('Cons' \'b\' 'Nil'))) +-- @ +evenList :: [(a, b)] -> List a b +evenList = foldr (\(a, b) -> Cons a . Cons b) Nil + +-- | Construct a 'List' of odd length given the first element and a list of pairs. +-- +-- @ +-- oddList 1 [] == 'Cons' 1 'Nil' +-- oddList 1 [(2,3), (4,5)] == [1, 2, 3, 4, 5] :: 'List' Int Int +-- oddList 1 [(\'a\',2), (\'b\',3)] == 'Cons' 1 ('Cons' \'a\' ('Cons' 2 ('Cons' \'b\' ('Cons' 3 'Nil')))) +-- @ +oddList :: a -> [(b, a)] -> List a b +oddList a = Cons a . evenList + +-- | The /path/ on a 'List' of vertices. +-- Complexity: /O(L * log(L))/ time, where /L/ is the length of the given list. +-- +-- @ +-- path 'Nil' == 'empty' +-- path ('Cons' x 'Nil') == 'leftVertex' x +-- path ('Cons' x ('Cons' y 'Nil')) == 'edge' x y +-- path [1, 2, 3, 4, 5] == 'edges' [(1,2), (3,2), (3,4), (5,4)] +-- @ +path :: (Ord a, Ord b) => List a b -> AdjacencyMap a b +path Nil = empty +path (Cons a Nil) = leftVertex a +path abs = edges (zip as bs ++ zip (drop 1 as) bs) + where + (as, bs) = split abs + + split :: List a b -> ([a], [b]) + split xs = case xs of + Nil -> ([], []) + Cons a Nil -> ([a], []) + Cons a (Cons b abs) -> (a : as, b : bs) where (as, bs) = split abs + +-- | The /circuit/ on a list of pairs of vertices. +-- Complexity: /O(L * log(L))/ time, where L is the length of the given list. +-- +-- @ +-- circuit [] == 'empty' +-- circuit [(x,y)] == 'edge' x y +-- 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 + +-- | The /biclique/ on two lists of vertices. +-- Complexity: /O(n * log(n) + m)/ time and /O(n + m)/ memory. +-- +-- @ +-- biclique [] [] == 'empty' +-- biclique xs [] == 'vertices' xs [] +-- biclique [] ys == 'vertices' [] ys +-- biclique xs ys == 'connect' ('vertices' xs []) ('vertices' [] ys) +-- @ +biclique :: (Ord a, Ord b) => [a] -> [b] -> AdjacencyMap a b +biclique xs ys = BAM (Map.fromSet (const sys) sxs) (Map.fromSet (const sxs) sys) + where + sxs = Set.fromList xs + sys = Set.fromList ys + +-- | The /star/ formed by a center vertex connected to a list of leaves. +-- Complexity: /O(L * log(L))/ time, where /L/ is the length of the given list. +-- +-- @ +-- star x [] == 'leftVertex' x +-- star x [y] == 'edge' x y +-- star x [y,z] == 'edges' [(x,y), (x,z)] +-- star x ys == 'connect' ('leftVertex' x) ('vertices' [] ys) +-- @ +star :: (Ord a, Ord b) => a -> [b] -> AdjacencyMap a b +star x ys = connect (leftVertex x) (vertices [] ys) + +-- | The /stars/ formed by overlaying a list of 'star's. +-- Complexity: /O(L * log(L))/ time, where /L/ is the total size of the input. +-- +-- @ +-- stars [] == 'empty' +-- stars [(x, [])] == 'leftVertex' x +-- stars [(x, [y])] == 'edge' x y +-- stars [(x, ys)] == 'star' x ys +-- stars == 'overlays' . 'map' ('uncurry' 'star') +-- 'overlay' (stars xs) (stars ys) == stars (xs ++ ys) +-- @ +stars :: (Ord a, Ord b) => [(a, [b])] -> AdjacencyMap a b +stars = overlays . map (uncurry star) + +-- | Remove a vertex from the left part of a given graph. +-- Complexity: /O(r * log(l))/ time. +-- +-- @ +-- removeLeftVertex x ('leftVertex' x) == 'empty' +-- removeLeftVertex 1 ('leftVertex' 2) == 'leftVertex' 2 +-- removeLeftVertex x ('rightVertex' y) == 'rightVertex' y +-- removeLeftVertex x ('edge' x y) == 'rightVertex' y +-- removeLeftVertex x . removeLeftVertex x == removeLeftVertex x +-- @ +removeLeftVertex :: Ord a => a -> AdjacencyMap a b -> AdjacencyMap a b +removeLeftVertex a (BAM ab ba) = BAM (Map.delete a ab) (Map.map (Set.delete a) ba) + +-- | Remove a vertex from the right part of a given graph. +-- Complexity: /O(l * log(r))/ time. +-- +-- @ +-- removeRightVertex x ('rightVertex' x) == 'empty' +-- removeRightVertex 1 ('rightVertex' 2) == 'rightVertex' 2 +-- removeRightVertex x ('leftVertex' y) == 'leftVertex' y +-- removeRightVertex y ('edge' x y) == 'leftVertex' x +-- removeRightVertex x . removeRightVertex x == removeRightVertex x +-- @ +removeRightVertex :: Ord b => b -> AdjacencyMap a b -> AdjacencyMap a b +removeRightVertex b (BAM ab ba) = BAM (Map.map (Set.delete b) ab) (Map.delete b ba) + +-- | Remove an edge from a given graph. +-- Complexity: /O(log(l) + log(r))/ time. +-- +-- @ +-- removeEdge x y ('edge' x y) == 'vertices' [x] [y] +-- removeEdge x y . removeEdge x y == removeEdge x y +-- removeEdge x y . 'removeLeftVertex' x == 'removeLeftVertex' x +-- removeEdge x y . 'removeRightVertex' y == 'removeRightVertex' y +-- @ +removeEdge :: (Ord a, Ord b) => a -> b -> AdjacencyMap a b -> AdjacencyMap a b +removeEdge a b (BAM ab ba) = + BAM (Map.adjust (Set.delete b) a ab) (Map.adjust (Set.delete a) b ba) + +-- | Transform a graph by applying given functions to the vertices of each part. +-- Complexity: /O((n + m) * log(n))/ time. +-- +-- @ +-- bimap f g 'empty' == 'empty' +-- bimap f g . 'vertex' == 'vertex' . Data.Bifunctor.'Data.Bifunctor.bimap' f g +-- bimap f g ('edge' x y) == 'edge' (f x) (g y) +-- bimap 'id' 'id' == 'id' +-- bimap f1 g1 . bimap f2 g2 == bimap (f1 . f2) (g1 . g2) +-- @ +bimap :: (Ord a, Ord b, Ord c, Ord d) => (a -> c) -> (b -> d) -> AdjacencyMap a b -> AdjacencyMap c d +bimap f g (BAM ab ba) = BAM cd dc + where + cd = Map.map (Set.map g) $ Map.mapKeysWith Set.union f ab + dc = Map.map (Set.map f) $ Map.mapKeysWith Set.union g ba + +-- TODO: Add torus? +-- | Construct a /mesh/ graph from two lists of vertices. +-- Complexity: /O(L1 * L2 * log(L1 * L2))/ time, where /L1/ and /L2/ are the +-- lengths of the given lists. +-- +-- @ +-- mesh xs [] == 'empty' +-- mesh [] ys == 'empty' +-- mesh [x] [y] == 'leftVertex' (x,y) +-- mesh [1,1] [\'a\',\'b\'] == 'biclique' [(1,\'a\'), (1,\'b\')] [(1,\'a\'), (1,\'b\')] +-- mesh [1,2] [\'a\',\'b\'] == 'biclique' [(1,\'a\'), (2,\'b\')] [(1,\'b\'), (2,\'a\')] +-- @ +mesh :: (Ord a, Ord b) => [a] -> [b] -> AdjacencyMap (a, b) (a, b) +mesh as bs = box (path $ fromList as) (path $ fromList bs) + +-- | Compute the /Cartesian product/ of two graphs. +-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. +-- +-- @ +-- 'box' ('path' [0,1]) ('path' [\'a\',\'b\']) == 'edges' [ ((0,\'a\'), (0,\'b\')) +-- , ((0,\'a\'), (1,\'a\')) +-- , ((1,\'b\'), (0,\'b\')) +-- , ((1,\'b\'), (1,\'a\')) ] +-- @ +-- Up to isomorphism between the resulting vertex types, this operation is +-- /commutative/, /associative/, /distributes/ over 'overlay', has singleton +-- graphs as /identities/ and /swapping identities/, and 'empty' as the +-- /annihilating zero/. Below @~~@ stands for equality up to an isomorphism, +-- e.g. @(x,@ @()) ~~ x@. +-- +-- @ +-- box x y ~~ box y x +-- box x (box y z) ~~ box (box x y) z +-- box x ('overlay' y z) == 'overlay' (box x y) (box x z) +-- box x ('leftVertex' ()) ~~ x +-- box x ('rightVertex' ()) ~~ 'swap' x +-- box x 'empty' ~~ 'empty' +-- 'vertexCount' (box x y) == 'vertexCount' x * 'vertexCount' y +-- 'edgeCount' (box x y) == 'vertexCount' x * 'edgeCount' y + 'edgeCount' x * 'vertexCount' y +-- @ +box :: (Ord a, Ord b) => AdjacencyMap a a -> AdjacencyMap b b -> AdjacencyMap (a, b) (a, b) +box = boxWith (,) (,) (,) (,) + +-- | Compute the generalised /Cartesian product/ of two graphs. The resulting +-- vertices are obtained using the given vertex combinators. +-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. +-- +-- See 'box' for some examples. +-- +-- @ +-- box == boxWith (,) (,) (,) (,) +-- @ +boxWith :: (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f) + => (a -> c -> e) -> (b -> d -> e) -> (a -> d -> f) -> (b -> c -> f) + -> AdjacencyMap a b -> AdjacencyMap c d -> AdjacencyMap e f +boxWith ac bd ad bc x y = toBipartite (AM.gmap combine ambox) + where + -- ambox :: AM.AdjacencyMap (Either a b, Either c d) + ambox = AM.box (fromBipartite x) (fromBipartite y) + + -- combine :: (Either a b, Either c d) -> Either e f + combine (Left a, Left c) = Left (ac a c) + combine (Left a, Right d) = Right (ad a d) + combine (Right b, Left c) = Right (bc b c) + combine (Right b, Right d) = Left (bd b d) + +-- | Check that the internal graph representation is consistent, i.e. that all +-- 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 ('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) = 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/Bipartite/AdjacencyMap/Algorithm.hs b/src/Algebra/Graph/Bipartite/AdjacencyMap/Algorithm.hs new file mode 100644 --- /dev/null +++ b/src/Algebra/Graph/Bipartite/AdjacencyMap/Algorithm.hs @@ -0,0 +1,528 @@ +{-# LANGUAGE LambdaCase #-} +---------------------------------------------------------------------------- +-- | +-- Module : Algebra.Graph.Bipartite.AdjacencyMap.Algorithm +-- Copyright : (c) Andrey Mokhov 2016-2021 +-- License : MIT (see the file LICENSE) +-- Maintainer : andrey.mokhov@gmail.com +-- Stability : experimental +-- +-- __Alga__ is a library for algebraic construction and manipulation of graphs +-- in Haskell. See for +-- the motivation behind the library, the underlying theory, and +-- implementation details. +-- +-- This module provides several basic algorithms on undirected bipartite graphs. +---------------------------------------------------------------------------- +module Algebra.Graph.Bipartite.AdjacencyMap.Algorithm ( + -- * Bipartiteness test + OddCycle, detectParts, + + -- * Matchings + Matching, pairOfLeft, pairOfRight, matching, isMatchingOf, matchingSize, + maxMatching, + + -- * Vertex covers + VertexCover, isVertexCoverOf, vertexCoverSize, minVertexCover, + + -- * Independent sets + IndependentSet, isIndependentSetOf, independentSetSize, maxIndependentSet, + + -- * Miscellaneous + augmentingPath, consistentMatching + ) where + +import Algebra.Graph.Bipartite.AdjacencyMap + +import Control.Monad (guard, when) +import Control.Monad.Trans.Maybe (MaybeT(..)) +import Control.Monad.State (MonadState(..), State, runState, modify) +import Control.Monad.ST (ST, runST) +import Data.Either (fromLeft) +import Data.Foldable (asum, foldl') +import Data.Functor (($>)) +import Data.List (sort) +import Data.Maybe (fromJust) +import Data.STRef (STRef, newSTRef, readSTRef, writeSTRef, modifySTRef) +import GHC.Generics + +import qualified Algebra.Graph.AdjacencyMap as AM + +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set +import qualified Data.Sequence as Seq + +import Data.Map.Strict (Map) +import Data.Set (Set) +import Data.Sequence (Seq, ViewL (..), (|>)) + +-- TODO: Make this representation type-safe +-- | A cycle of odd length. For example, @[1,2,3]@ represents the cycle +-- @1@ @->@ @2@ @->@ @3@ @->@ @1@. +type OddCycle a = [a] + +data Part = LeftPart | RightPart deriving (Show, Eq) + +otherPart :: Part -> Part +otherPart LeftPart = RightPart +otherPart RightPart = LeftPart + +-- | Test the bipartiteness of a given "Algebra.Graph.AdjacencyMap". 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 cycle of +-- odd length in the graph. +-- +-- The returned partition is lexicographically smallest, assuming that vertices +-- of the left part precede all the vertices of the right part. +-- +-- The returned cycle is optimal in the following sense: 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 smallest among all such pairs of +-- paths and cycles. +-- +-- /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. +-- +-- 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 ('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.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, partMap) -> Right $ toBipartiteWith (toEither partMap) 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 partMap <- get + guard (Map.notMember v partMap) + inVertex LeftPart v + + -- inVertex :: Part -> a -> PartMonad a + inVertex vertexPart v = (v :) <$> do + modify (Map.insert v vertexPart) + let otherVertexPart = otherPart vertexPart + asum [ onEdge otherVertexPart u | u <- Set.toAscList (AM.postSet v g) ] + + {-# INLINE onEdge #-} + -- onEdge :: Part -> a -> PartMonad a + onEdge vertexPart v = do partMap <- get + case Map.lookup v partMap of + Nothing -> inVertex vertexPart v + Just part -> do guard (vertexPart /= part) + return [v] -- found a cycle! + + -- toEither :: PartMap a -> a -> Either a a + toEither partMap v = case fromJust (Map.lookup v partMap) of + LeftPart -> Left v + RightPart -> Right v + + -- oddCycle :: [a] -> [a] + oddCycle pathToCycle = init $ dropWhile (/= lastVertex) pathToCycle + where + lastVertex = last pathToCycle + +-- | A /matching/ is a set of pairwise non-adjacent edges between the two parts +-- of a bipartite graph. +-- +-- The 'Show' instance is defined using the 'matching' function, with the edges +-- listed in the ascending order of left vertices. +-- +-- @ +-- show ('matching' []) == "matching []" +-- show ('matching' [(2,\'a\'), (1,\'b\')]) == "matching [(1,\'b\'),(2,\'a\')]" +-- @ +data Matching a b = Matching { + -- | The map of vertices covered by the matching in the left part to their + -- neighbours in the right part. + -- Complexity: /O(1)/ time. + -- + -- @ + -- pairOfLeft ('matching' []) == Map.'Data.Map.Strict.empty' + -- pairOfLeft ('matching' [(2,\'a\'), (1,\'b\')]) == Map.'Data.Map.Strict.fromList' [(1,\'b\'), (2,\'a\')] + -- Map.'Map.size' . pairOfLeft == Map.'Map.size' . pairOfRight + -- @ + pairOfLeft :: Map a b, + + -- | The map of vertices covered by the matching in the right part to their + -- neighbours in the left part. + -- Complexity: /O(1)/. + -- + -- @ + -- pairOfRight ('matching' []) == Map.'Data.Map.Strict.empty' + -- pairOfRight ('matching' [(2,\'a\'), (1,\'b\')]) == Map.'Data.Map.Strict.fromList' [(\'a\',2), (\'b\',1)] + -- Map.'Map.size' . pairOfRight == Map.'Map.size' . pairOfLeft + -- @ + pairOfRight :: Map b a +} deriving Generic + +instance (Show a, Show b) => Show (Matching a b) where + showsPrec _ m = showString "matching " . showList (Map.toAscList $ pairOfLeft m) + +instance (Eq a, Eq b) => Eq (Matching a b) where + x == y = pairOfLeft x == pairOfLeft y + +instance (Ord a, Ord b) => Ord (Matching a b) where + compare x y = compare (pairOfLeft x) (pairOfLeft y) + +addEdgeUnsafe :: (Ord a, Ord b) => a -> b -> Matching a b -> Matching a b +addEdgeUnsafe a b (Matching ab ba) = Matching (Map.insert a b ab) (Map.insert b a ba) + +addEdge :: (Ord a, Ord b) => a -> b -> Matching a b -> Matching a b +addEdge a b (Matching ab ba) = addEdgeUnsafe a b (Matching ab' ba') + where + ab' = case b `Map.lookup` ba of + Nothing -> Map.delete a ab + Just a' -> Map.delete a (Map.delete a' ab) + ba' = case a `Map.lookup` ab of + Nothing -> Map.delete b ba + Just b' -> Map.delete b (Map.delete b' ba) + +leftCovered :: Ord a => a -> Matching a b -> Bool +leftCovered a = Map.member a . pairOfLeft + +-- | Construct a 'Matching' from a list of edges. +-- Complexity: /O(L * log(L))/ time, where /L/ is the length of the given list. +-- +-- Edges that appear closer to the end of the list supersede all previous edges. +-- That is, if two edges from the list share a vertex, the one that appears +-- closer to the beginning is ignored. +-- +-- @ +-- 'pairOfLeft' (matching []) == Map.'Data.Map.Strict.empty' +-- 'pairOfRight' (matching []) == Map.'Data.Map.Strict.empty' +-- 'pairOfLeft' (matching [(2,\'a\'), (1,\'b\')]) == Map.'Data.Map.Strict.fromList' [(2,\'a\'), (1,\'b\')] +-- 'pairOfLeft' (matching [(1,\'a\'), (1,\'b\')]) == Map.'Data.Map.Strict.singleton' 1 \'b\' +-- matching [(1,\'a\'), (1,\'b\'), (2,\'b\'), (2,\'a\')] == matching [(2,\'a\')] +-- @ +matching :: (Ord a, Ord b) => [(a, b)] -> Matching a b +matching = foldl' (flip (uncurry addEdge)) (Matching Map.empty Map.empty) + +-- | Check if a given 'Matching' is a valid /matching/ of a bipartite graph. +-- Complexity: /O(S * log(n))/, where /S/ is the size of the matching. +-- +-- @ +-- isMatchingOf ('matching' []) x == True +-- isMatchingOf ('matching' xs) 'empty' == 'null' xs +-- isMatchingOf ('matching' [(x,y)]) ('edge' x y) == True +-- isMatchingOf ('matching' [(1,2)]) ('edge' 2 1) == False +-- @ +isMatchingOf :: (Ord a, Ord b) => Matching a b -> AdjacencyMap a b -> Bool +isMatchingOf m@(Matching ab _) g = consistentMatching m + && and [ hasEdge a b g | (a, b) <- Map.toList ab ] + +-- | The number of edges in a matching. +-- Complexity: /O(1)/ time. +-- +-- @ +-- matchingSize ('matching' []) == 0 +-- matchingSize ('matching' [(2,\'a\'), (1,\'b\')]) == 2 +-- matchingSize ('matching' [(1,\'a\'), (1,\'b\')]) == 1 +-- matchingSize ('matching' xs) <= 'length' xs +-- matchingSize == Map.'Data.Map.Strict.size' . 'pairOfLeft' +-- @ +matchingSize :: Matching a b -> Int +matchingSize = Map.size . pairOfLeft + +-- | Find a /maximum matching/ in a bipartite graph. A matching is maximum if it +-- has the largest possible size. +-- Complexity: /O(m * sqrt(n) * log(n))/ time. +-- +-- @ +-- maxMatching 'empty' == 'matching' [] +-- maxMatching ('vertices' xs ys) == 'matching' [] +-- maxMatching ('path' [1,2,3,4]) == 'matching' [(1,2), (3,4)] +-- 'matchingSize' (maxMatching ('circuit' [(1,2), (3,4), (5,6)])) == 3 +-- 'matchingSize' (maxMatching ('star' x (y:ys))) == 1 +-- 'matchingSize' (maxMatching ('biclique' xs ys)) == 'min' ('length' ('Data.List.nub' xs)) ('length' ('Data.List.nub' ys)) +-- 'isMatchingOf' (maxMatching x) x == True +-- @ +maxMatching :: (Ord a, Ord b) => AdjacencyMap a b -> Matching a b +maxMatching graph = runST (maxMatchingHK graph) + +-- TODO: Should we use a more efficient data structure for the queue? +-- TODO: We could try speeding this up by representing vertices with 'Int's. +-- The state maintained by the Hopcroft-Karp algorithm implemented below +data HKState s a b = HKState + { distance :: STRef s (Map a Int) + , curMatching :: STRef s (Matching a b) + , queue :: STRef s (Seq a) + , visited :: STRef s (Set a) } + +-- See https://en.wikipedia.org/wiki/Hopcroft-Karp_algorithm +maxMatchingHK :: forall a b s. (Ord a, Ord b) => AdjacencyMap a b -> ST s (Matching a b) +maxMatchingHK g = do + distance <- newSTRef Map.empty + curMatching <- newSTRef (Matching Map.empty Map.empty) + queue <- newSTRef Seq.empty + visited <- newSTRef Set.empty + runHK (HKState distance curMatching queue visited) + readSTRef curMatching + where + runHK :: HKState s a b -> ST s () + runHK state = do writeSTRef (distance state) Map.empty + foundAugmentingPath <- bfs state + when foundAugmentingPath $ do + writeSTRef (visited state) Set.empty + dfs state + runHK state + + currentlyUncovered :: HKState s a b -> ST s [a] + currentlyUncovered state = do + m <- readSTRef (curMatching state) + return [ v | v <- leftVertexList g, not (leftCovered v m) ] + + + bfs :: HKState s a b -> ST s Bool + bfs state = do + uncovered <- currentlyUncovered state + mapM_ (enqueue state 1) uncovered + bfsLoop state + + enqueue :: HKState s a b -> Int -> a -> ST s () + enqueue state d v = do modifySTRef (distance state) (Map.insert v d) + modifySTRef (queue state) (|> v) + + dequeue :: HKState s a b -> ST s (Maybe a) + dequeue state = do q <- readSTRef (queue state) + case Seq.viewl q of + a :< q -> writeSTRef (queue state) q $> Just a + EmptyL -> return Nothing + + bfsLoop :: HKState s a b -> ST s Bool + bfsLoop state = dequeue state >>= \case + Just v -> do p <- bfsVertex state v + q <- bfsLoop state + return (p || q) + Nothing -> return False + + bfsVertex :: HKState s a b -> a -> ST s Bool + bfsVertex state v = do dist <- readSTRef (distance state) + let d = fromJust (v `Map.lookup` dist) + 1 + or <$> mapM (bfsEdge state d) (neighbours v) + + checkEnqueue :: HKState s a b -> Int -> a -> ST s () + checkEnqueue state d v = do dist <- readSTRef (distance state) + when (v `Map.notMember` dist) (enqueue state d v) + + bfsEdge :: HKState s a b -> Int -> b -> ST s Bool + bfsEdge state d u = do m <- readSTRef (curMatching state) + case u `Map.lookup` pairOfRight m of + Just v -> checkEnqueue state d v $> False + Nothing -> return True + + dfs :: HKState s a b -> ST s () + dfs state = currentlyUncovered state >>= mapM_ (dfsVertex state 0) + + dfsVertex :: HKState s a b -> Int -> a -> ST s Bool + dfsVertex state d v = do dist <- readSTRef (distance state) + vis <- readSTRef (visited state) + let dv = fromJust (v `Map.lookup` dist) + case (d + 1 == dv) && (v `Set.notMember` vis) of + False -> return False + True -> do modifySTRef (visited state) (Set.insert v) + dfsEdges state dv v (neighbours v) + + dfsEdges :: HKState s a b -> Int -> a -> [b] -> ST s Bool + dfsEdges _ _ _ [] = return False + dfsEdges state d a (b:bs) = do m <- readSTRef (curMatching state) + case b `Map.lookup` pairOfRight m of + Nothing -> addEdge state a b $> True + Just w -> dfsVertex state d w >>= \case + True -> addEdge state a b $> True + False -> dfsEdges state d a bs + + addEdge :: HKState s a b -> a -> b -> ST s () + addEdge state a b = modifySTRef (curMatching state) (addEdgeUnsafe a b) + + neighbours :: a -> [b] + neighbours a = Set.toAscList $ fromJust $ Map.lookup a $ leftAdjacencyMap g + +-- | A /vertex cover/ of a bipartite graph. +-- +-- A /vertex cover/ is a subset of vertices such that every edge is incident to +-- some vertex in the subset. We represent vertex covers by storing two sets of +-- vertices, one for each part. An equivalent representation, which is slightly +-- less memory efficient, is @Set@ @(Either@ @a@ @b)@. +type VertexCover a b = (Set a, Set b) + +-- | Check if a given pair of sets is a /vertex cover/ of a bipartite graph. +-- Complexity: /O(m * log(n))/. +-- +-- @ +-- isVertexCoverOf (xs , ys ) 'empty' == Set.'Set.null' xs && Set.'Set.null' ys +-- isVertexCoverOf (xs , ys ) ('leftVertex' x) == Set.'Set.isSubsetOf' xs (Set.'Set.singleton' x) && Set.'Set.null' ys +-- isVertexCoverOf (Set.'Set.empty' , Set.'Set.empty' ) ('edge' x y) == False +-- isVertexCoverOf (Set.'Set.singleton' x, ys ) ('edge' x y) == Set.'Set.isSubsetOf' ys (Set.'Set.singleton' y) +-- isVertexCoverOf (xs , Set.'Set.singleton' y) ('edge' x y) == Set.'Set.isSubsetOf' xs (Set.'Set.singleton' x) +-- @ +isVertexCoverOf :: (Ord a, Ord b) => (Set a, Set b) -> AdjacencyMap a b -> Bool +isVertexCoverOf (as, bs) g = as `Set.isSubsetOf` leftVertexSet g + && bs `Set.isSubsetOf` rightVertexSet g + && and [ a `Set.member` as || b `Set.member` bs | (a, b) <- edgeList g ] + +-- | The number of vertices in a vertex cover. +-- Complexity: /O(1)/ time. +vertexCoverSize :: VertexCover a b -> Int +vertexCoverSize (as, bs) = Set.size as + Set.size bs + +-- | Find a /minimum vertex cover/ in a bipartite graph. A vertex cover is +-- minimum if it has the smallest possible size. +-- Complexity: /O(m * sqrt(n) * log(n))/. +-- +-- @ +-- minVertexCover 'empty' == (Set.'Set.empty', Set.'Set.empty') +-- minVertexCover ('vertices' xs ys) == (Set.'Set.empty', Set.'Set.empty') +-- minVertexCover ('path' [1,2,3]) == (Set.'Set.empty', Set.'Set.singleton' 2) +-- minVertexCover ('star' x (1:2:ys)) == (Set.'Set.singleton' x, Set.'Set.empty') +-- 'vertexCoverSize' (minVertexCover ('biclique' xs ys)) == 'min' ('length' ('Data.List.nub' xs)) ('length' ('Data.List.nub' ys)) +-- 'vertexCoverSize' . minVertexCover == 'matchingSize' . 'maxMatching' +-- 'isVertexCoverOf' (minVertexCover x) x == True +-- @ +minVertexCover :: (Ord a, Ord b) => AdjacencyMap a b -> VertexCover a b +minVertexCover g = fromLeft panic $ augmentingPath (maxMatching g) g + where + panic = error "minVertexCover: internal error (found augmenting path)" + +-- | An /independent set/ of a bipartite graph. +-- +-- An /independent set/ is a subset of vertices such that no two of them are +-- adjacent. We represent independent sets by storing two sets of vertices, one +-- for each part. An equivalent representation, which is slightly less memory +-- efficient, is @Set@ @(Either@ @a@ @b)@. +type IndependentSet a b = (Set a, Set b) + +-- | Check if a given pair of sets is an /independent set/ of a bipartite graph. +-- Complexity: /O(m * log(n))/. +-- +-- @ +-- isIndependentSetOf (xs , ys ) 'empty' == Set.'Set.null' xs && Set.'Set.null' ys +-- isIndependentSetOf (xs , ys ) ('leftVertex' x) == Set.'Set.isSubsetOf' xs (Set.'Set.singleton' x) && Set.'Set.null' ys +-- isIndependentSetOf (Set.'Set.empty' , Set.'Set.empty' ) ('edge' x y) == True +-- isIndependentSetOf (Set.'Set.singleton' x, ys ) ('edge' x y) == Set.'Set.null' ys +-- isIndependentSetOf (xs , Set.'Set.singleton' y) ('edge' x y) == Set.'Set.null' xs +-- @ +isIndependentSetOf :: (Ord a, Ord b) => (Set a, Set b) -> AdjacencyMap a b -> Bool +isIndependentSetOf (as, bs) g = as `Set.isSubsetOf` leftVertexSet g + && bs `Set.isSubsetOf` rightVertexSet g + && and [ not (a `Set.member` as && b `Set.member` bs) | (a, b) <- edgeList g ] + +-- | The number of vertices in an independent set. +-- Complexity: /O(1)/ time. +independentSetSize :: IndependentSet a b -> Int +independentSetSize (as, bs) = Set.size as + Set.size bs + +-- | Find a /maximum independent set/ in a bipartite graph. An independent set +-- is maximum if it has the largest possible size. +-- Complexity: /O(m * sqrt(n) * log(n))/. +-- +-- @ +-- maxIndependentSet 'empty' == (Set.'Set.empty', Set.'Set.empty') +-- maxIndependentSet ('vertices' xs ys) == (Set.'Set.fromList' xs, Set.'Set.fromList' ys) +-- maxIndependentSet ('path' [1,2,3]) == (Set.'Set.fromList' [1,3], Set.'Set.empty') +-- maxIndependentSet ('star' x (1:2:ys)) == (Set.'Set.empty', Set.'Set.fromList' (1:2:ys)) +-- 'independentSetSize' (maxIndependentSet ('biclique' xs ys)) == 'max' ('length' ('Data.List.nub' xs)) ('length' ('Data.List.nub' ys)) +-- 'independentSetSize' (maxIndependentSet x) == 'vertexCount' x - 'vertexCoverSize' ('minVertexCover' x) +-- 'isIndependentSetOf' (maxIndependentSet x) x == True +-- @ +maxIndependentSet :: (Ord a, Ord b) => AdjacencyMap a b -> IndependentSet a b +maxIndependentSet g = + (leftVertexSet g `Set.difference` as, rightVertexSet g `Set.difference` bs) + where + (as, bs) = minVertexCover g + +-- | Given a matching in a bipartite graph, find either a /vertex cover/ of the +-- same size or an /augmenting path/ with respect to the matching, thereby +-- demonstrating that the matching is not maximum. +-- Complexity: /O((m + n) * log(n))/. +-- +-- An /alternating path/ is a path whose edges belong alternately to the +-- matching and not to the matching. An /augmenting path/ is an alternating path +-- that starts from and ends on the vertices that are not covered by the +-- matching. A matching is maximum if and only if there is no augmenting path +-- with respect to it. +-- +-- @ +-- augmentingPath ('matching' []) 'empty' == Left (Set.'Set.empty', Set.'Set.empty') +-- augmentingPath ('matching' []) ('edge' 1 2) == Right [1,2] +-- augmentingPath ('matching' [(1,2)]) ('path' [1,2,3]) == Left (Set.'Set.empty', Set.'Set.singleton' 2) +-- augmentingPath ('matching' [(3,2)]) ('path' [1,2,3,4]) == Right [1,2,3,4] +-- isLeft (augmentingPath ('maxMatching' x) x) == True +-- @ +augmentingPath :: (Ord a, Ord b) => Matching a b -> AdjacencyMap a b -> Either (VertexCover a b) (List a b) +augmentingPath = augmentingPathImpl + +type AugPathMonad a b = MaybeT (State (VertexCover a b)) (List a b) + +-- The implementation is in a separate function to avoid the "forall" in docs. +augmentingPathImpl :: forall a b. (Ord a, Ord b) => Matching a b -> AdjacencyMap a b -> Either (VertexCover a b) (List a b) +augmentingPathImpl m g = case runState (runMaybeT dfs) (leftVertexSet g, Set.empty) of + (Nothing , cover) -> Left cover + (Just path, _ ) -> Right path + where + dfs :: AugPathMonad a b + dfs = asum [ inVertex v | v <- leftVertexList g, not (leftCovered v m) ] + + inVertex :: a -> AugPathMonad a b + inVertex a = do (as, bs) <- get + guard (a `Set.member` as) + put (Set.delete a as, bs) + asum [ onEdge a b | b <- neighbours a ] + + onEdge :: a -> b -> AugPathMonad a b + onEdge a b = addEdge a b <$> do (as, bs) <- get + put (as, Set.insert b bs) + case b `Map.lookup` pairOfRight m of + Just a -> inVertex a + Nothing -> return Nil + + addEdge :: a -> b -> List a b -> List a b + addEdge a b = Cons a . Cons b + + neighbours :: a -> [b] + neighbours a = Set.toAscList $ fromJust $ Map.lookup a $ leftAdjacencyMap g + +-- | Check if the internal representation of a matching is consistent, i.e. that +-- every edge that is present in 'pairOfLeft' is also present in 'pairOfRight'. +-- Complexity: /O(S * log(S))/, where /S/ is the size of the matching. +-- +-- @ +-- consistentMatching ('matching' xs) == True +-- consistentMatching ('maxMatching' x) == True +-- @ +consistentMatching :: (Ord a, Ord b) => Matching a b -> Bool +consistentMatching (Matching ab ba) = + Map.toAscList ab == sort [ (a, b) | (b, a) <- Map.toAscList ba ] diff --git a/src/Algebra/Graph/Bipartite/Undirected/AdjacencyMap.hs b/src/Algebra/Graph/Bipartite/Undirected/AdjacencyMap.hs deleted file mode 100644 --- a/src/Algebra/Graph/Bipartite/Undirected/AdjacencyMap.hs +++ /dev/null @@ -1,836 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} ----------------------------------------------------------------------------- --- | --- 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 --- --- __Alga__ is a library for algebraic construction and manipulation of graphs --- in Haskell. See for --- the motivation behind the library, the underlying theory, and --- implementation details. --- --- 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.Undirected.AdjacencyMap ( - -- * Data structure - AdjacencyMap, leftAdjacencyMap, rightAdjacencyMap, - - -- * Basic graph construction primitives - empty, leftVertex, rightVertex, vertex, edge, overlay, connect, vertices, - edges, overlays, connects, swap, - - -- * Conversion functions - toBipartite, toBipartiteWith, fromBipartite, fromBipartiteWith, - - -- * Graph properties - isEmpty, hasLeftVertex, hasRightVertex, hasVertex, hasEdge, leftVertexCount, - rightVertexCount, vertexCount, edgeCount, leftVertexList, rightVertexList, - vertexList, edgeList, leftVertexSet, rightVertexSet, vertexSet, edgeSet, - - -- * Standard families of graphs - circuit, biclique, - - -- * Algorithms - OddCycle, detectParts, - - -- * Miscellaneous - consistent - ) where - -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.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. - -__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]) -@ - -__Note:__ the 'Num' instance does not satisfy several "customary laws" of 'Num', -which dictate that 'fromInteger' @0@ and 'fromInteger' @1@ should act as -additive and multiplicative identities, and 'negate' as additive inverse. -Nevertheless, overloading 'fromInteger', '+' and '*' is very convenient when -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 '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)" -@ - -The 'Eq' instance satisfies all axioms of algebraic graphs: - - * 'overlay' is commutative and associative: - - > x + y == y + x - > x + (y + z) == (x + y) + z - - * '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': - - > x * (y + z) == x * y + x * z - > (x + y) * z == x * z + y * z - - * 'connect' can be decomposed: - - > x * y * z == x * y + x * z + y * z - - * '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 - -The following useful theorems can be proved from the above set of axioms. - - * 'overlay' has 'empty' as the identity and is idempotent: - - > x + empty == x - > empty + x == x - > x + x == x - - * Absorption and saturation of 'connect': - - > x * y + x + y == x * y - > x * x * x == x * x - -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 left vertex is - -- associated with a set of its right neighbours. - -- Complexity: /O(1)/ time and memory. - -- - -- @ - -- 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 a (Set b), - - -- | 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' 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 b (Set a) - } deriving Generic - --- | __Note:__ this does not satisfy the usual ring laws; see 'AdjacencyMap' --- for more details. -instance (Ord a, Ord b, Num b) => Num (AdjacencyMap a b) where - fromInteger = rightVertex . fromInteger - (+) = overlay - (*) = connect - signum = const empty - abs = id - 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 - -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 ")" - where - lvs = leftVertexList bam - rvs = rightVertexList 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 - 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 - --- | 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 --- @ -empty :: AdjacencyMap a b -empty = BAM Map.empty Map.empty - --- | Construct the bipartite graph comprising /a single isolated vertex/ in --- the left part. --- Complexity: /O(1)/ time and memory. --- --- @ --- '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 --- @ -leftVertex :: a -> AdjacencyMap a b -leftVertex x = BAM (Map.singleton x Set.empty) Map.empty - --- | Construct the bipartite graph comprising /a single isolated vertex/ in --- the right part. --- Complexity: /O(1)/ time and memory. --- --- @ --- 'leftAdjacencyMap' (rightVertex x) == Map.'Map.empty' --- 'rightAdjacencyMap' (rightVertex x) == Map.'Map.singleton' x Set.'Set.empty' --- '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) - --- | Construct the bipartite graph comprising /a single isolated vertex/. --- Complexity: /O(1)/ time and memory. --- --- @ --- vertex . Left == 'leftVertex' --- vertex . Right == 'rightVertex' --- @ -vertex :: Either a b -> AdjacencyMap a b -vertex (Left x) = leftVertex x -vertex (Right y) = rightVertex y - --- | Construct the bipartite graph comprising /a single edge/. --- 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 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)) - --- | /Overlay/ two bipartite graphs. This is a commutative, associative and --- idempotent operation with the identity 'empty'. --- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. --- --- @ --- 'isEmpty' (overlay x y) == 'isEmpty' x && 'isEmpty' y --- 'hasVertex' z (overlay x y) == 'hasVertex' z x || 'hasVertex' z y --- 'vertexCount' (overlay x y) >= 'vertexCount' x --- 'vertexCount' (overlay x y) <= 'vertexCount' x + 'vertexCount' y --- 'edgeCount' (overlay x y) >= 'edgeCount' x --- 'edgeCount' (overlay x y) <= 'edgeCount' x + 'edgeCount' y --- @ -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) - --- | /Connect/ two bipartite graphs, not adding the edges between vertices in --- the same part. This is a commutative and associative operation with the --- identity 'empty', which distributes over 'overlay' and obeys the --- decomposition axiom. --- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. Note that the --- number of edges in the resulting graph is quadratic with respect to the --- number of vertices in the arguments: /O(m1 + m2 + l1 * r2 + l2 * r1)/. --- --- @ --- 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) >= '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 - 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. --- Complexity: /O(L * log(L))/ time and /O(L)/ memory, where /L/ is the total --- length of two lists. --- --- @ --- 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 [ (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 --- 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 [ (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. --- --- @ --- overlays [] == 'empty' --- overlays [x] == x --- overlays [x,y] == 'overlay' x y --- overlays == 'foldr' 'overlay' 'empty' --- '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)) - --- | Connect a given list of graphs. --- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. --- --- @ --- connects [] == 'empty' --- connects [x] == x --- connects [x,y] == connect x y --- connects == 'foldr' 'connect' 'empty' --- 'isEmpty' . connects == 'all' 'isEmpty' --- @ -connects :: (Ord a, Ord b) => [AdjacencyMap a b] -> AdjacencyMap a b -connects = foldr connect empty - --- | Swap parts of a given graph. --- Complexity: /O(1)/ time and memory. --- --- @ --- 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 an "Algebra.Graph.AdjacencyMap" --- with given part identifiers, adding all needed edges to make the graph --- undirected and removing all edges within the same parts. --- Complexity: /O(m * log(n))/. --- --- @ --- 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 [ (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 within the same --- parts. --- Complexity: /O(m * log(n))/. --- --- @ --- 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))/. --- --- @ --- fromBipartite 'empty' == 'Algebra.Graph.AdjacencyMap.empty' --- 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 x, Set.mapMonotonic Right ys) | (x, ys) <- Map.toAscList lr ] ++ - [ (Right y, Set.mapMonotonic Left xs) | (y, xs) <- Map.toAscList rl ] - --- | 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))/. --- --- @ --- 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' --- @ -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. --- --- @ --- isEmpty 'empty' == True --- isEmpty ('overlay' 'empty' 'empty') == True --- isEmpty ('vertex' x) == False --- isEmpty == (==) 'empty' --- @ -isEmpty :: AdjacencyMap a b -> Bool -isEmpty (BAM lr rl) = Map.null lr && Map.null rl - --- | Check if a graph contains a given vertex in the left part. --- Complexity: /O(log(n))/ time. --- --- @ --- hasLeftVertex x 'empty' == False --- hasLeftVertex x ('leftVertex' y) == (x == y) --- hasLeftVertex x ('rightVertex' y) == False --- @ -hasLeftVertex :: Ord a => a -> AdjacencyMap a b -> Bool -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 ('leftVertex' y) == False --- hasRightVertex x ('rightVertex' y) == (x == y) --- @ -hasRightVertex :: Ord b => b -> AdjacencyMap a b -> Bool -hasRightVertex y (BAM _ rl) = Map.member y rl - --- | Check if a graph contains a given vertex. --- Complexity: /O(log(n))/ time. --- --- @ --- 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. --- --- @ --- leftVertexCount 'empty' == 0 --- leftVertexCount ('leftVertex' x) == 1 --- leftVertexCount ('rightVertex' x) == 0 --- leftVertexCount ('edge' x y) == 1 --- leftVertexCount . 'edges' == 'length' . 'nub' . 'map' 'fst' --- @ -leftVertexCount :: AdjacencyMap a b -> Int -leftVertexCount = Map.size . leftAdjacencyMap - --- | The number of vertices in the right part in a graph. --- Complexity: /O(1)/ time. --- --- @ --- rightVertexCount 'empty' == 0 --- rightVertexCount ('leftVertex' x) == 0 --- rightVertexCount ('rightVertex' x) == 1 --- rightVertexCount ('edge' x y) == 1 --- rightVertexCount . 'edges' == 'length' . 'nub' . 'map' 'snd' --- @ -rightVertexCount :: AdjacencyMap a b -> Int -rightVertexCount = Map.size . rightAdjacencyMap - --- | The number of vertices in a graph. --- Complexity: /O(1)/ time. --- --- @ --- 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 - --- | The number of edges in a graph. --- Complexity: /O(n)/ time. --- --- @ --- edgeCount 'empty' == 0 --- edgeCount ('vertex' x) == 0 --- edgeCount ('edge' x y) == 1 --- edgeCount . 'edges' == 'length' . 'nub' --- @ -edgeCount :: AdjacencyMap a b -> Int -edgeCount = Map.foldr ((+) . Set.size) 0 . leftAdjacencyMap - --- | The sorted list of vertices of the left part of a given graph. --- Complexity: /O(l)/ time and memory. --- --- @ --- leftVertexList 'empty' == [] --- leftVertexList ('leftVertex' x) == [x] --- leftVertexList ('rightVertex' x) == [] --- leftVertexList . 'flip' 'vertices' [] == 'nub' . 'sort' --- @ -leftVertexList :: AdjacencyMap a b -> [a] -leftVertexList = Map.keys . leftAdjacencyMap - --- | The sorted list of vertices of the right part of a given graph. --- Complexity: /O(r)/ time and memory. --- --- @ --- rightVertexList 'empty' == [] --- rightVertexList ('leftVertex' x) == [] --- rightVertexList ('rightVertex' x) == [x] --- rightVertexList . 'vertices' [] == 'nub' . 'sort' --- @ -rightVertexList :: AdjacencyMap a b -> [b] -rightVertexList = Map.keys . rightAdjacencyMap - --- | The sorted list of vertices of a given graph. --- Complexity: /O(n)/ time and memory --- --- @ --- vertexList 'empty' == [] --- vertexList ('vertex' x) == [x] --- 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) - --- | The sorted list of edges of a graph. --- Complexity: /O(n + m)/ time and /O(m)/ memory. --- --- @ --- edgeList 'empty' == [] --- edgeList ('vertex' x) == [] --- edgeList ('edge' x y) == [(x,y)] --- edgeList . 'edges' == 'nub' . 'sort' --- @ -edgeList :: AdjacencyMap a b -> [(a, b)] -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.'Set.empty' --- leftVertexSet . 'leftVertex' == Set.'Set.singleton' --- leftVertexSet . 'rightVertex' == 'const' Set.'Set.empty' --- leftVertexSet . 'flip' 'vertices' [] == Set.'Set.fromList' --- @ -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.'Set.empty' --- rightVertexSet . 'leftVertex' == 'const' Set.'Set.empty' --- rightVertexSet . 'rightVertex' == Set.'Set.singleton' --- rightVertexSet . 'vertices' [] == Set.'Set.fromList' --- @ -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.'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 (Either a b) -vertexSet = Set.fromAscList . vertexList - --- | The set of edges of a given graph. --- Complexity: /O(n + m)/ time and /O(m)/ memory. --- --- @ --- edgeSet 'empty' == Set.'Data.Set.empty' --- edgeSet ('vertex' x) == Set.'Data.Set.empty' --- 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 (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 [(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 - --- | The /biclique/ on two lists of vertices. --- Complexity: /O(n * log(n) + m)/ time and /O(n + m)/ memory. --- --- @ --- biclique [] [] == 'empty' --- biclique xs [] == 'vertices' xs [] --- biclique [] ys == 'vertices' [] ys --- biclique xs ys == 'connect' ('vertices' xs []) ('vertices' [] ys) --- @ -biclique :: (Ord a, Ord b) => [a] -> [b] -> AdjacencyMap a b -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) - -otherPart :: Part -> Part -otherPart LeftPart = RightPart -otherPart RightPart = LeftPart - --- | 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 - --- | 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 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, --- considering that the identifier of the left part is less then the identifier --- of the right part, this string is lexicographically minimal of all such --- strings for all partitions. --- --- 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 paths --- and cycles. --- --- /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. --- --- @ --- detectParts 'Algebra.Graph.AdjacencyMap.empty' == Right 'empty' --- detectParts ('Algebra.Graph.AdjacencyMap.vertex' x) == Right ('leftVertex' x) --- 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.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 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 ('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) = 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/Class.hs b/src/Algebra/Graph/Class.hs --- a/src/Algebra/Graph/Class.hs +++ b/src/Algebra/Graph/Class.hs @@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Class --- Copyright : (c) Andrey Mokhov 2016-2019 +-- Copyright : (c) Andrey Mokhov 2016-2021 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental @@ -281,7 +281,6 @@ instance (Preorder g, Preorder h, Preorder i) => Preorder (g, h, i) -- | Construct the graph comprising a single edge. --- Complexity: /O(1)/ time, memory and size. -- -- @ -- edge x y == 'connect' ('vertex' x) ('vertex' y) @@ -296,6 +295,7 @@ -- @ -- vertices [] == 'empty' -- vertices [x] == 'vertex' x +-- vertices == 'overlays' . map 'vertex' -- @ vertices :: Graph g => [Vertex g] -> g vertices = overlays . map vertex diff --git a/src/Algebra/Graph/Export.hs b/src/Algebra/Graph/Export.hs --- a/src/Algebra/Graph/Export.hs +++ b/src/Algebra/Graph/Export.hs @@ -2,7 +2,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Export --- Copyright : (c) Andrey Mokhov 2016-2019 +-- Copyright : (c) Andrey Mokhov 2016-2021 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental @@ -26,7 +26,6 @@ ) where import Data.Foldable (fold) -import Data.Semigroup import Data.String hiding (unlines) import Prelude hiding (unlines) diff --git a/src/Algebra/Graph/Export/Dot.hs b/src/Algebra/Graph/Export/Dot.hs --- a/src/Algebra/Graph/Export/Dot.hs +++ b/src/Algebra/Graph/Export/Dot.hs @@ -2,7 +2,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Export.Dot --- Copyright : (c) Andrey Mokhov 2016-2018 +-- Copyright : (c) Andrey Mokhov 2016-2021 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental @@ -15,13 +15,13 @@ ----------------------------------------------------------------------------- module Algebra.Graph.Export.Dot ( -- * Graph attributes and style - Attribute (..), Style (..), defaultStyle, defaultStyleViaShow, + Attribute (..), Quoting (..), Style (..), defaultStyle, defaultStyleViaShow, -- * Export functions export, exportAsIs, exportViaShow ) where -import Data.List hiding (unlines) +import Data.List (map, null, intersperse) import Data.Monoid import Data.String hiding (unlines) import Prelude hiding (unlines) @@ -34,12 +34,18 @@ -- Attributes are used to specify the style of graph elements during export. data Attribute s = (:=) s s +-- TODO: Do we need other quoting styles, for example, 'SingleQuotes'? +-- TODO: Shall we use 'Quoting' for vertex names too? +-- | The style of quoting used when exporting attributes; 'DoubleQuotes' is the +-- default. +data Quoting = DoubleQuotes | NoQuotes + -- | The record 'Style' @a@ @s@ specifies the style to use when exporting a -- graph in the DOT format. Here @a@ is the type of the graph vertices, and @s@ -- is the type of string to represent the resulting DOT document (e.g. String, --- Text, etc.). Most fields can be empty. The only field that has no obvious --- default value is 'vertexName', which holds a function of type @a -> s@ to --- compute vertex names. See the example for the function 'export'. +-- Text, etc.). The only field that has no obvious default value is +-- 'vertexName', which holds a function of type @a -> s@ to compute vertex +-- names. See the function 'export' for an example. data Style a s = Style { graphName :: s -- ^ Name of the graph. @@ -57,16 +63,18 @@ -- ^ Attributes of a specific vertex. , edgeAttributes :: a -> a -> [Attribute s] -- ^ Attributes of a specific edge. + , attributeQuoting :: Quoting + -- ^ The quoting style used for attributes. } --- | Default style for exporting graphs. All style settings are empty except for --- 'vertexName', which is provided as the only argument. +-- | Default style for exporting graphs. The 'vertexName' field is provided as +-- the only argument; the other fields are set to trivial defaults. defaultStyle :: Monoid s => (a -> s) -> Style a s -defaultStyle v = Style mempty [] [] [] [] v (\_ -> []) (\_ _ -> []) +defaultStyle v = Style mempty [] [] [] [] v (const []) (\_ _ -> []) DoubleQuotes --- | Default style for exporting graphs whose vertices are 'Show'-able. All --- style settings are empty except for 'vertexName', which is computed from --- 'show'. +-- | Default style for exporting graphs with 'Show'-able vertices. The +-- 'vertexName' field is computed using 'show'; the other fields are set to +-- trivial defaults. -- -- @ -- defaultStyleViaShow = 'defaultStyle' ('fromString' . 'show') @@ -88,7 +96,8 @@ -- , 'defaultEdgeAttributes' = 'mempty' -- , 'vertexName' = \\x -> "v" ++ 'show' x -- , 'vertexAttributes' = \\x -> ["color" := "blue" | 'odd' x ] --- , 'edgeAttributes' = \\x y -> ["style" := "dashed" | 'odd' (x * y)] } +-- , 'edgeAttributes' = \\x y -> ["style" := "dashed" | 'odd' (x * y)] +-- , 'attributeQuoting' = 'DoubleQuotes' } -- -- > putStrLn $ export style (1 * 2 + 3 * 4 * 5 :: 'Graph' Int) -- @@ -113,7 +122,7 @@ export Style {..} g = render $ header <> body <> "}\n" where header = "digraph" <+> literal graphName <> "\n{\n" - with x as = if null as then mempty else line (x <+> attributes as) + with x as = if null as then mempty else line (x <+> attributes attributeQuoting as) line s = indent 2 s <> "\n" body = unlines (map literal preamble) <> ("graph" `with` graphAttributes) @@ -121,17 +130,20 @@ <> ("edge" `with` defaultEdgeAttributes) <> E.export vDoc eDoc g label = doubleQuotes . literal . vertexName - vDoc x = line $ label x <+> attributes (vertexAttributes x) - eDoc x y = line $ label x <> " -> " <> label y <+> attributes (edgeAttributes x y) + vDoc x = line $ label x <+> attributes attributeQuoting (vertexAttributes x) + eDoc x y = line $ label x <> " -> " <> label y <+> attributes attributeQuoting (edgeAttributes x y) --- | A list of attributes formatted as a DOT document. --- Example: @attributes ["label" := "A label", "shape" := "box"]@ --- corresponds to document: @ [label="A label" shape="box"]@. -attributes :: IsString s => [Attribute s] -> Doc s -attributes [] = mempty -attributes as = brackets . mconcat . intersperse " " $ map dot as +-- | Export a list of attributes using a specified quoting style. +-- Example: @attributes DoubleQuotes ["label" := "A label", "shape" := "box"]@ +-- corresponds to document: @[label="A label" shape="box"]@. +attributes :: IsString s => Quoting -> [Attribute s] -> Doc s +attributes _ [] = mempty +attributes q as = brackets . mconcat . intersperse " " $ map dot as where - dot (k := v) = literal k <> "=" <> doubleQuotes (literal v) + dot (k := v) = literal k <> "=" <> quote (literal v) + quote = case q of + DoubleQuotes -> doubleQuotes + NoQuotes -> id -- | Export a graph whose vertices are represented simply by their names. -- diff --git a/src/Algebra/Graph/HigherKinded/Class.hs b/src/Algebra/Graph/HigherKinded/Class.hs --- a/src/Algebra/Graph/HigherKinded/Class.hs +++ b/src/Algebra/Graph/HigherKinded/Class.hs @@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.HigherKinded.Class --- Copyright : (c) Andrey Mokhov 2016-2019 +-- Copyright : (c) Andrey Mokhov 2016-2021 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental @@ -176,7 +176,6 @@ class (Reflexive g, Transitive g) => Preorder g -- | Construct the graph comprising a single edge. --- Complexity: /O(1)/ time, memory and size. -- -- @ -- edge x y == 'connect' ('vertex' x) ('vertex' y) @@ -193,6 +192,7 @@ -- @ -- vertices [] == 'empty' -- vertices [x] == 'vertex' x +-- vertices == 'overlays' . map 'vertex' -- 'hasVertex' x . vertices == 'elem' x -- 'vertexCount' . vertices == 'length' . 'Data.List.nub' -- 'vertexSet' . vertices == Set.'Set.fromList' @@ -464,7 +464,7 @@ -- | Construct the /induced subgraph/ of a given graph by removing the -- vertices that do not satisfy a given predicate. -- Complexity: /O(s)/ time, memory and size, assuming that the predicate takes --- /O(1)/ to be evaluated. +-- constant time. -- -- @ -- induce ('const' True ) x == x @@ -503,7 +503,7 @@ -- | Merge vertices satisfying a given predicate into a given vertex. -- Complexity: /O(s)/ time, memory and size, assuming that the predicate takes --- /O(1)/ to be evaluated. +-- constant time. -- -- @ -- mergeVertices ('const' False) x == id diff --git a/src/Algebra/Graph/Internal.hs b/src/Algebra/Graph/Internal.hs --- a/src/Algebra/Graph/Internal.hs +++ b/src/Algebra/Graph/Internal.hs @@ -1,8 +1,7 @@ -{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Internal --- Copyright : (c) Andrey Mokhov 2016-2020 +-- Copyright : (c) Andrey Mokhov 2016-2021 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental @@ -17,26 +16,26 @@ ----------------------------------------------------------------------------- module Algebra.Graph.Internal ( -- * Data structures - List (..), + List, -- * Graph traversal Focus (..), emptyFocus, vertexFocus, overlayFoci, connectFoci, foldr1Safe, maybeF, -- * Utilities - setProduct, setProductWith, forEach, forEachInt, coerce00, coerce10, - coerce20, coerce01, coerce11, coerce21 + cartesianProductWith, forEach, coerce00, coerce10, coerce20, coerce01, + coerce11, coerce21 ) where import Data.Coerce import Data.Foldable -import Data.Semigroup import Data.IntSet (IntSet) +import Data.Semigroup (Endo (..)) import Data.Set (Set) import qualified Data.IntSet as IntSet -import qualified Data.Set as Set -import qualified GHC.Exts as Exts +import qualified Data.Set as Set +import qualified GHC.Exts as Exts -- | An abstract list data type with /O(1)/ time concatenation (the current -- implementation uses difference lists). Here @a@ is the type of list elements. @@ -80,7 +79,7 @@ return = pure x >>= f = Exts.fromList (toList x >>= toList . f) --- | The /focus/ of a graph expression is a flattened represenentation of the +-- | The /focus/ of a graph expression is a flattened representation of the -- subgraph under focus, its context, as well as the list of all encountered -- vertices. See 'Algebra.Graph.removeEdge' for a use-case example. data Focus a = Focus @@ -120,26 +119,16 @@ maybeF f x = Just . maybe x (f x) {-# INLINE maybeF #-} --- | Compute the Cartesian product of two sets. -setProduct :: Set a -> Set b -> Set (a, b) -#if MIN_VERSION_containers(0,5,11) -setProduct = Set.cartesianProduct -#else -setProduct x y = Set.fromDistinctAscList [ (a, b) | a <- Set.toAscList x, b <- Set.toAscList y ] -#endif - +-- TODO: Can we implement this faster via 'Set.cartesianProduct'? -- | Compute the Cartesian product of two sets, applying a function to each -- resulting pair. -setProductWith :: Ord c => (a -> b -> c) -> Set a -> Set b -> Set c -setProductWith f x y = Set.fromList [ f a b | a <- Set.toAscList x, b <- Set.toAscList y ] +cartesianProductWith :: Ord c => (a -> b -> c) -> Set a -> Set b -> Set c +cartesianProductWith f x y = + Set.fromList [ f a b | a <- Set.toAscList x, b <- Set.toAscList y ] --- | Perform an applicative action for each member of a Set. +-- | Perform an applicative action for each element of a set. forEach :: Applicative f => Set a -> (a -> f b) -> f () 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. diff --git a/src/Algebra/Graph/Label.hs b/src/Algebra/Graph/Label.hs --- a/src/Algebra/Graph/Label.hs +++ b/src/Algebra/Graph/Label.hs @@ -1,8 +1,7 @@ -{-# LANGUAGE DeriveFunctor, OverloadedLists #-} ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Label --- Copyright : (c) Andrey Mokhov 2016-2019 +-- Copyright : (c) Andrey Mokhov 2016-2021 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental @@ -34,7 +33,7 @@ import Data.Coerce import Data.Maybe import Data.Monoid (Any (..), Monoid (..), Sum (..)) -import Data.Semigroup (Max (..), Min (..), Semigroup (..)) +import Data.Semigroup (Max (..), Min (..)) import Data.Set (Set) import GHC.Exts (IsList (..)) @@ -328,8 +327,7 @@ (<>) = min instance (Monoid a, Ord a) => Monoid (Minimum a) where - mempty = noMinimum - mappend = (<>) + mempty = noMinimum instance (Monoid a, Ord a) => Semiring (Minimum a) where one = pure mempty @@ -355,14 +353,14 @@ -- 'zero' = PowerSet Set.'Set.empty' -- 'one' = PowerSet $ Set.'Set.singleton' 'mempty' -- x '<+>' y = PowerSet $ Set.'Set.union' (getPowerSet x) (getPowerSet y) --- x '<.>' y = PowerSet $ 'setProductWith' 'mappend' (getPowerSet x) (getPowerSet y) +-- x '<.>' y = PowerSet $ 'cartesianProductWith' 'mappend' (getPowerSet x) (getPowerSet y) -- @ newtype PowerSet a = PowerSet { getPowerSet :: Set a } deriving (Eq, Monoid, Ord, Semigroup, Show) instance (Monoid a, Ord a) => Semiring (PowerSet a) where one = PowerSet (Set.singleton mempty) - PowerSet x <.> PowerSet y = PowerSet (setProductWith mappend x y) + PowerSet x <.> PowerSet y = PowerSet (cartesianProductWith mappend x y) instance (Monoid a, Ord a) => Dioid (PowerSet a) where @@ -402,8 +400,7 @@ x <> y = x :+: y instance Monoid (Label a) where - mempty = Zero - mappend = (<>) + mempty = Zero instance Semiring (Label a) where one = One @@ -458,8 +455,7 @@ -- TODO: Add tests. instance (Eq o, Monoid a, Monoid o) => Monoid (Optimum o a) where - mempty = Optimum mempty mempty - mappend = (<>) + mempty = Optimum mempty mempty -- TODO: Add tests. instance (Eq o, Semiring a, Semiring o) => Semiring (Optimum o a) where diff --git a/src/Algebra/Graph/Labelled.hs b/src/Algebra/Graph/Labelled.hs --- a/src/Algebra/Graph/Labelled.hs +++ b/src/Algebra/Graph/Labelled.hs @@ -1,8 +1,7 @@ -{-# LANGUAGE DeriveFunctor, DeriveGeneric, FlexibleInstances #-} ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Labelled --- Copyright : (c) Andrey Mokhov 2016-2019 +-- Copyright : (c) Andrey Mokhov 2016-2021 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental @@ -20,7 +19,7 @@ edges, overlays, -- * Graph folding - foldg, + foldg, buildg, -- * Relations on graphs isSubgraphOf, @@ -45,10 +44,11 @@ import Data.Bifunctor import Data.Monoid +import Data.String import Control.DeepSeq import GHC.Generics -import Algebra.Graph.Internal (List (..)) +import Algebra.Graph.Internal (List) import Algebra.Graph.Label import qualified Algebra.Graph.Labelled.AdjacencyMap as AM @@ -81,14 +81,25 @@ abs = id negate = id +instance IsString a => IsString (Graph e a) where + fromString = Vertex . fromString + instance Bifunctor Graph where - bimap f g = foldg Empty (Vertex . g) (Connect . f) + bimap f g = foldg Empty (Vertex . g) (Connect . f) instance (NFData e, NFData a) => NFData (Graph e a) where rnf Empty = () rnf (Vertex x ) = rnf x rnf (Connect e x y) = e `seq` rnf x `seq` rnf y +-- | Defined via 'overlay'. +instance Monoid e => Semigroup (Graph e a) where + (<>) = overlay + +-- | Defined via 'overlay' and 'empty'. +instance Monoid e => Monoid (Graph e a) where + mempty = empty + -- TODO: This is a very inefficient implementation. Find a way to construct an -- adjacency map directly, without building intermediate representations for all -- subgraphs. @@ -105,8 +116,8 @@ -- | 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 and connect. --- Complexity: /O(s)/ applications of given functions. As an example, the --- complexity of 'size' is /O(s)/, since all functions have cost /O(1)/. +-- Complexity: /O(s)/ applications of the given functions. As an example, the +-- complexity of 'size' is /O(s)/, since 'const' and '+' have constant costs. -- -- @ -- foldg 'empty' 'vertex' 'connect' == 'id' @@ -123,6 +134,22 @@ go (Vertex x ) = v x go (Connect e x y) = c e (go x) (go y) +-- | Build a graph given an interpretation of the three graph construction +-- primitives 'empty', 'vertex' and 'connect', in this order. See examples for +-- further clarification. +-- +-- @ +-- buildg f == f 'empty' 'vertex' 'connect' +-- buildg (\\e _ _ -> e) == 'empty' +-- buildg (\\_ v _ -> v x) == 'vertex' x +-- buildg (\\e v c -> c l ('foldg' e v c x) ('foldg' e v c y)) == 'connect' l x y +-- buildg (\\e v c -> 'foldr' (c 'zero') e ('map' v xs)) == 'vertices' xs +-- buildg (\\e v c -> 'foldg' e v ('flip' . c) g) == 'transpose' g +-- 'foldg' e v c (buildg f) == f e v c +-- @ +buildg :: (forall r. r -> (a -> r) -> (e -> r -> r -> r) -> r) -> Graph e a +buildg f = f Empty Vertex Connect + -- | The 'isSubgraphOf' function takes two graphs and returns 'True' if the -- first graph is a /subgraph/ of the second. -- Complexity: /O(s + m * log(m))/ time. Note that the number of edges /m/ of a @@ -139,7 +166,6 @@ isSubgraphOf x y = overlay x y == y -- | Construct the /empty graph/. An alias for the constructor 'Empty'. --- Complexity: /O(1)/ time, memory and size. -- -- @ -- 'isEmpty' empty == True @@ -152,7 +178,6 @@ -- | Construct the graph comprising /a single isolated vertex/. An alias for the -- constructor 'Vertex'. --- Complexity: /O(1)/ time, memory and size. -- -- @ -- 'isEmpty' (vertex x) == False @@ -164,7 +189,6 @@ vertex = Vertex -- | Construct the graph comprising /a single labelled edge/. --- Complexity: /O(1)/ time, memory and size. -- -- @ -- edge e x y == 'connect' e ('vertex' x) ('vertex' y) @@ -256,6 +280,7 @@ -- @ -- vertices [] == 'empty' -- vertices [x] == 'vertex' x +-- vertices == 'overlays' . map 'vertex' -- 'hasVertex' x . vertices == 'elem' x -- 'Algebra.Graph.ToGraph.vertexCount' . vertices == 'length' . 'Data.List.nub' -- 'Algebra.Graph.ToGraph.vertexSet' . vertices == Set.'Set.fromList' @@ -490,11 +515,10 @@ emap :: (e -> f) -> Graph e a -> Graph f a emap f = foldg Empty Vertex (Connect . f) --- TODO: Implement via 'induceJust' to reduce code duplication. -- | Construct the /induced subgraph/ of a given graph by removing the -- vertices that do not satisfy a given predicate. -- Complexity: /O(s)/ time, memory and size, assuming that the predicate takes --- /O(1)/ to be evaluated. +-- constant time. -- -- @ -- induce ('const' True ) x == x @@ -504,11 +528,7 @@ -- 'isSubgraphOf' (induce p x) x == True -- @ induce :: (a -> Bool) -> Graph e a -> Graph e a -induce p = foldg Empty (\x -> if p x then Vertex x else Empty) c - where - c _ x Empty = x -- Constant folding to get rid of Empty leaves - c _ Empty y = y - c e x y = Connect e x y +induce p = induceJust . fmap (\a -> if p a then Just a else Nothing) -- | Construct the /induced subgraph/ of a given graph by removing the vertices -- that are 'Nothing'. @@ -602,7 +622,7 @@ , edges [ (e, v, s) | (e, v) <- is, i v ] , edges [ (e, s, v) | (e, v) <- os, o v ] ] --- The /focus/ of a graph expression is a flattened represenentation of the +-- The /focus/ of a graph expression is a flattened representation of the -- subgraph under focus, its context, as well as the list of all encountered -- vertices. See 'removeEdge' for a use-case example. data Focus e a = Focus diff --git a/src/Algebra/Graph/Labelled/AdjacencyMap.hs b/src/Algebra/Graph/Labelled/AdjacencyMap.hs --- a/src/Algebra/Graph/Labelled/AdjacencyMap.hs +++ b/src/Algebra/Graph/Labelled/AdjacencyMap.hs @@ -1,8 +1,7 @@ -{-# LANGUAGE DeriveGeneric #-} ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Labelled.AdjacencyMap --- Copyright : (c) Andrey Mokhov 2016-2019 +-- Copyright : (c) Andrey Mokhov 2016-2021 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental @@ -47,6 +46,7 @@ import Data.Map (Map) import Data.Monoid (Sum (..)) import Data.Set (Set, (\\)) +import Data.String import GHC.Generics import Algebra.Graph.Label @@ -110,8 +110,18 @@ abs = id negate = id +instance IsString a => IsString (AdjacencyMap e a) where + fromString = vertex . fromString + +-- | Defined via 'overlay'. +instance (Ord a, Eq e, Monoid e) => Semigroup (AdjacencyMap e a) where + (<>) = overlay + +-- | Defined via 'overlay' and 'empty'. +instance (Ord a, Eq e, Monoid e) => Monoid (AdjacencyMap e a) where + mempty = empty + -- | Construct the /empty graph/. --- Complexity: /O(1)/ time and memory. -- -- @ -- 'isEmpty' empty == True @@ -123,7 +133,6 @@ empty = AM Map.empty -- | Construct the graph comprising /a single isolated vertex/. --- Complexity: /O(1)/ time and memory. -- -- @ -- 'isEmpty' (vertex x) == False @@ -135,7 +144,6 @@ vertex x = AM $ Map.singleton x Map.empty -- | Construct the graph comprising /a single edge/. --- Complexity: /O(1)/ time, memory. -- -- @ -- edge e x y == 'connect' e ('vertex' x) ('vertex' y) @@ -244,6 +252,7 @@ -- @ -- vertices [] == 'empty' -- vertices [x] == 'vertex' x +-- vertices == 'overlays' . map 'vertex' -- 'hasVertex' x . vertices == 'elem' x -- 'vertexCount' . vertices == 'length' . 'Data.List.nub' -- 'vertexSet' . vertices == Set.'Set.fromList' @@ -340,7 +349,7 @@ -- hasEdge x y == 'not' . 'null' . 'filter' (\\(_,ex,ey) -> ex == x && ey == y) . 'edgeList' -- @ hasEdge :: Ord a => a -> a -> AdjacencyMap e a -> Bool -hasEdge x y (AM m) = fromMaybe False (Map.member y <$> Map.lookup x m) +hasEdge x y (AM m) = maybe False (Map.member y) (Map.lookup x m) -- | Extract the label of a specified edge in a graph. -- Complexity: /O(log(n))/ time. @@ -584,8 +593,7 @@ -- | Construct the /induced subgraph/ of a given graph by removing the -- vertices that do not satisfy a given predicate. --- Complexity: /O(n + m)/ time, assuming that the predicate takes /O(1)/ to --- be evaluated. +-- Complexity: /O(n + m)/ time, assuming that the predicate takes constant time. -- -- @ -- induce ('const' True ) x == x diff --git a/src/Algebra/Graph/Labelled/Example/Automaton.hs b/src/Algebra/Graph/Labelled/Example/Automaton.hs --- a/src/Algebra/Graph/Labelled/Example/Automaton.hs +++ b/src/Algebra/Graph/Labelled/Example/Automaton.hs @@ -2,7 +2,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Labelled.Example.Automaton --- Copyright : (c) Andrey Mokhov 2016-2018 +-- Copyright : (c) Andrey Mokhov 2016-2021 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental diff --git a/src/Algebra/Graph/Labelled/Example/Network.hs b/src/Algebra/Graph/Labelled/Example/Network.hs --- a/src/Algebra/Graph/Labelled/Example/Network.hs +++ b/src/Algebra/Graph/Labelled/Example/Network.hs @@ -2,7 +2,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Labelled.Example.Network --- Copyright : (c) Andrey Mokhov 2016-2018 +-- Copyright : (c) Andrey Mokhov 2016-2021 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental diff --git a/src/Algebra/Graph/NonEmpty.hs b/src/Algebra/Graph/NonEmpty.hs --- a/src/Algebra/Graph/NonEmpty.hs +++ b/src/Algebra/Graph/NonEmpty.hs @@ -1,8 +1,7 @@ -{-# LANGUAGE DeriveFunctor #-} ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.NonEmpty --- Copyright : (c) Andrey Mokhov 2016-2019 +-- Copyright : (c) Andrey Mokhov 2016-2021 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental @@ -54,9 +53,10 @@ ) where import Control.DeepSeq +import Control.Monad import Control.Monad.State import Data.List.NonEmpty (NonEmpty (..)) -import Data.Semigroup ((<>)) +import Data.String import Algebra.Graph.Internal @@ -77,11 +77,13 @@ We define a 'Num' instance as a convenient notation for working with graphs: - > 0 == vertex 0 - > 1 + 2 == overlay (vertex 1) (vertex 2) - > 1 * 2 == connect (vertex 1) (vertex 2) - > 1 + 2 * 3 == overlay (vertex 1) (connect (vertex 2) (vertex 3)) - > 1 * (2 + 3) == connect (vertex 1) (overlay (vertex 2) (vertex 3)) +@ +0 == 'vertex' 0 +1 + 2 == 'overlay' ('vertex' 1) ('vertex' 2) +1 * 2 == 'connect' ('vertex' 1) ('vertex' 2) +1 + 2 * 3 == 'overlay' ('vertex' 1) ('connect' ('vertex' 2) ('vertex' 3)) +1 * (2 + 3) == 'connect' ('vertex' 1) ('overlay' ('vertex' 2) ('vertex' 3)) +@ __Note:__ the 'signum' method of the type class 'Num' cannot be implemented and will throw an error. Furthermore, the 'Num' instance does not satisfy several @@ -184,12 +186,19 @@ abs = id negate = id +instance IsString a => IsString (Graph a) where + fromString = Vertex . fromString + instance Ord a => Eq (Graph a) where (==) = eq instance Ord a => Ord (Graph a) where compare = ord +-- | Defined via 'overlay'. +instance Semigroup (Graph a) where + (<>) = overlay + -- TODO: Find a more efficient equality check. -- | Check if two graphs are equal by converting them to their adjacency maps. eq :: Ord a => Graph a -> Graph a -> Bool @@ -237,7 +246,6 @@ -- | Construct the graph comprising /a single isolated vertex/. An alias for the -- constructor 'Vertex'. --- Complexity: /O(1)/ time, memory and size. -- -- @ -- 'hasVertex' x (vertex y) == (x == y) @@ -250,7 +258,6 @@ {-# INLINE vertex #-} -- | Construct the graph comprising /a single edge/. --- Complexity: /O(1)/ time, memory and size. -- -- @ -- edge x y == 'connect' ('vertex' x) ('vertex' y) @@ -372,8 +379,8 @@ -- | 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: vertex, overlay and connect. --- Complexity: /O(s)/ applications of given functions. As an example, the --- complexity of 'size' is /O(s)/, since all functions have cost /O(1)/. +-- Complexity: /O(s)/ applications of the given functions. As an example, the +-- complexity of 'size' is /O(s)/, since 'const' and '+' have constant costs. -- -- @ -- foldg1 'vertex' 'overlay' 'connect' == id @@ -674,27 +681,16 @@ -- , ((3,\'a\'),(3,\'b\')) ] -- @ mesh1 :: NonEmpty a -> NonEmpty b -> Graph (a, b) -mesh1 xx@(x:|xs) yy@(y:|ys) = - case NonEmpty.nonEmpty ipxs of - Nothing -> - case NonEmpty.nonEmpty ipys of - Nothing -> vertex (x,y) - Just ipys' -> - stars1 $ fmap (\(y1,y2) -> ((x,y1), [(x,y2)]) ) ipys' - Just ipxs' -> - case NonEmpty.nonEmpty ipys of - Nothing -> - stars1 $ fmap (\(x1,x2) -> ((x1,y), [(x2,y)]) ) ipxs' - Just ipys' -> - stars1 $ - appendNonEmpty (fmap (\((a1,a2),(b1,b2)) -> ((a1, b1), [(a1, b2), (a2, b1)])) $ liftM2 (,) ipxs' ipys') $ - [ ((lx,y1), [(lx,y2)]) | (y1,y2) <- ipys] - ++ [ ((x1,ly), [(x2,ly)]) | (x1,x2) <- ipxs] - where - lx = last xs - ly = last ys - ipxs = NonEmpty.init (pairs1 xx) - ipys = NonEmpty.init (pairs1 yy) +mesh1 (x :| []) ys = (x, ) <$> path1 ys +mesh1 xs (y :| []) = (, y) <$> path1 xs +mesh1 xs@(x1 :| x2 : xt) ys@(y1 :| y2 : yt) = + let star i j o = (vertex i `overlay` vertex j) `connect` vertex o + innerStars = overlays1 $ do + (x1, x2) <- NonEmpty.zip xs (x2 :| xt) + (y1, y2) <- NonEmpty.zip ys (y2 :| yt) + return $ star (x1, y2) (x2, y1) (x2, y2) + in + ((x1, ) <$> path1 ys) `overlay` ((, y1) <$> path1 xs) `overlay` innerStars -- | Construct a /torus graph/ from two lists of vertices. -- Complexity: /O(L1 * L2)/ time, memory and size, where /L1/ and /L2/ are the @@ -709,16 +705,18 @@ -- , ((2,\'b\'),(1,\'b\')), ((2,\'b\'),(2,\'a\')) ] -- @ torus1 :: NonEmpty a -> NonEmpty b -> Graph (a, b) -torus1 xs ys = stars1 $ fmap (\((a1,a2),(b1,b2)) -> ((a1, b1), [(a1, b2), (a2, b1)])) - $ liftM2 (,) (pairs1 xs) (pairs1 ys) - --- Auxiliary function for 'mesh1' and 'torus1' -pairs1 :: NonEmpty a -> NonEmpty (a, a) -pairs1 as@(x:|xs) = NonEmpty.zip as $ maybe (x :| []) (`appendNonEmpty` [x]) $ NonEmpty.nonEmpty xs - --- Append a list to a non-empty one -appendNonEmpty :: NonEmpty a -> [a] -> NonEmpty a -appendNonEmpty (w:|ws) zs = w :| (ws++zs) +torus1 xs ys = stars1 $ do + (x1, x2) <- pairs1 xs + (y1, y2) <- pairs1 ys + return ((x1, y1), [(x1, y2), (x2, y1)]) + where + -- Turn a non-empty list into a cycle and return pairs of neighbours + pairs1 :: NonEmpty a -> NonEmpty (a, a) + pairs1 as@(x :| xs) = NonEmpty.zip as $ + maybe (x :| []) (`append1` [x]) (NonEmpty.nonEmpty xs) + -- Append a list to a non-empty one + append1 :: NonEmpty a -> [a] -> NonEmpty a + append1 (x :| xs) ys = x :| (xs ++ ys) -- | Remove a vertex from a given graph. Returns @Nothing@ if the resulting -- graph is empty. @@ -772,7 +770,7 @@ -- | Merge vertices satisfying a given predicate into a given vertex. -- Complexity: /O(s)/ time, memory and size, assuming that the predicate takes --- /O(1)/ to be evaluated. +-- constant time. -- -- @ -- mergeVertices ('const' False) x == id @@ -823,12 +821,11 @@ "transpose/clique1" forall xs. transpose (clique1 xs) = clique1 (NonEmpty.reverse xs) #-} --- TODO: Implement via 'induceJust1' to reduce code duplication. -- | Construct the /induced subgraph/ of a given graph by removing the -- vertices that do not satisfy a given predicate. Returns @Nothing@ if the -- resulting graph is empty. -- Complexity: /O(s)/ time, memory and size, assuming that the predicate takes --- /O(1)/ to be evaluated. +-- constant time. -- -- @ -- induce1 ('const' True ) x == Just x @@ -837,12 +834,7 @@ -- induce1 p '>=>' induce1 q == induce1 (\\x -> p x && q x) -- @ induce1 :: (a -> Bool) -> Graph a -> Maybe (Graph a) -induce1 p = foldg1 - (\x -> if p x then Just (Vertex x) else Nothing) (k Overlay) (k Connect) - where - k _ Nothing a = a - k _ a Nothing = a - k f (Just a) (Just b) = Just (f a b) +induce1 p = induceJust1 . fmap (\a -> if p a then Just a else Nothing) -- | Construct the /induced subgraph/ of a given graph by removing the vertices -- that are 'Nothing'. Returns 'Nothing' if the resulting graph is empty. @@ -899,10 +891,10 @@ -- , ((0,\'b\'), (1,\'b\')) -- , ((1,\'a\'), (1,\'b\')) ] -- @ --- Up to an isomorphism between the resulting vertex types, this operation --- is /commutative/, /associative/, /distributes/ over 'overlay', and has --- singleton graphs as /identities/. Below @~~@ stands for the equality up to an --- isomorphism, e.g. @(x, ()) ~~ x@. +-- Up to isomorphism between the resulting vertex types, this operation is +-- /commutative/, /associative/, /distributes/ over 'overlay', and has +-- singleton graphs as /identities/. Below @~~@ stands for equality up to an +-- isomorphism, e.g. @(x,@ @()) ~~ x@. -- -- @ -- box x y ~~ box y x diff --git a/src/Algebra/Graph/NonEmpty/AdjacencyMap.hs b/src/Algebra/Graph/NonEmpty/AdjacencyMap.hs --- a/src/Algebra/Graph/NonEmpty/AdjacencyMap.hs +++ b/src/Algebra/Graph/NonEmpty/AdjacencyMap.hs @@ -1,8 +1,7 @@ -{-# LANGUAGE DeriveGeneric #-} ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.NonEmpty.AdjacencyMap --- Copyright : (c) Andrey Mokhov 2016-2019 +-- Copyright : (c) Andrey Mokhov 2016-2021 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental @@ -58,6 +57,7 @@ import Data.List.NonEmpty (NonEmpty (..), nonEmpty, toList, reverse) import Data.Maybe import Data.Set (Set) +import Data.String import Data.Tree import GHC.Generics @@ -68,11 +68,13 @@ their adjacency sets. We define a 'Num' instance as a convenient notation for working with graphs: - > 0 == vertex 0 - > 1 + 2 == overlay (vertex 1) (vertex 2) - > 1 * 2 == connect (vertex 1) (vertex 2) - > 1 + 2 * 3 == overlay (vertex 1) (connect (vertex 2) (vertex 3)) - > 1 * (2 + 3) == connect (vertex 1) (overlay (vertex 2) (vertex 3)) +@ +0 == 'vertex' 0 +1 + 2 == 'overlay' ('vertex' 1) ('vertex' 2) +1 * 2 == 'connect' ('vertex' 1) ('vertex' 2) +1 + 2 * 3 == 'overlay' ('vertex' 1) ('connect' ('vertex' 2) ('vertex' 3)) +1 * (2 + 3) == 'connect' ('vertex' 1) ('overlay' ('vertex' 2) ('vertex' 3)) +@ __Note:__ the 'signum' method of the type class 'Num' cannot be implemented and will throw an error. Furthermore, the 'Num' instance does not satisfy several @@ -148,7 +150,7 @@ x + y <= x * y@ -} newtype AdjacencyMap a = NAM { am :: AM.AdjacencyMap a } - deriving (Eq, Generic, NFData, Ord) + deriving (Eq, Generic, IsString, NFData, Ord) -- | __Note:__ this does not satisfy the usual ring laws; see 'AdjacencyMap' for -- more details. @@ -178,6 +180,10 @@ eshow xs = showString "edges1 " . showsPrec 11 xs used = Set.toAscList $ Set.fromList $ uncurry (++) $ unzip es +-- | Defined via 'overlay'. +instance Ord a => Semigroup (AdjacencyMap a) where + (<>) = overlay + -- Unsafe creation of a NonEmpty list. unsafeNonEmpty :: [a] -> NonEmpty a unsafeNonEmpty = fromMaybe (error msg) . nonEmpty @@ -208,7 +214,6 @@ fromNonEmpty = am -- | Construct the graph comprising /a single isolated vertex/. --- Complexity: /O(1)/ time and memory. -- -- @ -- 'hasVertex' x (vertex y) == (x == y) @@ -219,6 +224,18 @@ vertex = coerce AM.vertex {-# NOINLINE [1] vertex #-} +-- | Construct the graph comprising /a single edge/. +-- +-- @ +-- edge x y == 'connect' ('vertex' x) ('vertex' y) +-- 'hasEdge' x y (edge x y) == True +-- 'edgeCount' (edge x y) == 1 +-- 'vertexCount' (edge 1 1) == 1 +-- 'vertexCount' (edge 1 2) == 2 +-- @ +edge :: Ord a => a -> a -> AdjacencyMap a +edge = coerce AM.edge + -- | /Overlay/ two graphs. This is a commutative, associative and idempotent -- operation with the identity 'empty'. -- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. @@ -257,19 +274,6 @@ connect = coerce AM.connect {-# NOINLINE [1] connect #-} --- | Construct the graph comprising /a single edge/. --- Complexity: /O(1)/ time, memory. --- --- @ --- edge x y == 'connect' ('vertex' x) ('vertex' y) --- 'hasEdge' x y (edge x y) == True --- 'edgeCount' (edge x y) == 1 --- 'vertexCount' (edge 1 1) == 1 --- 'vertexCount' (edge 1 2) == 2 --- @ -edge :: Ord a => a -> a -> AdjacencyMap a -edge = coerce AM.edge - -- | Construct the graph comprising a given list of isolated vertices. -- Complexity: /O(L * log(L))/ time and /O(L)/ memory, where /L/ is the length -- of the given list. @@ -565,7 +569,7 @@ -- | Merge vertices satisfying a given predicate into a given vertex. -- Complexity: /O((n + m) * log(n))/ time, assuming that the predicate takes --- /O(1)/ to be evaluated. +-- constant time. -- -- @ -- mergeVertices ('const' False) x == id @@ -617,8 +621,7 @@ -- | Construct the /induced subgraph/ of a given graph by removing the -- vertices that do not satisfy a given predicate. --- Complexity: /O(m)/ time, assuming that the predicate takes /O(1)/ to --- be evaluated. +-- Complexity: /O(m)/ time, assuming that the predicate takes constant time. -- -- @ -- induce1 ('const' True ) x == Just x @@ -640,7 +643,7 @@ -- induceJust1 . 'gmap' (\\x -> if p x then 'Just' x else 'Nothing') == 'induce1' p -- @ induceJust1 :: Ord a => AdjacencyMap (Maybe a) -> Maybe (AdjacencyMap a) -induceJust1 m = toNonEmpty (AM.induceJust (coerce m)) +induceJust1 = toNonEmpty . AM.induceJust . coerce -- | Compute the /reflexive and transitive closure/ of a graph. -- Complexity: /O(n * m * log(n)^2)/ time. diff --git a/src/Algebra/Graph/Relation.hs b/src/Algebra/Graph/Relation.hs --- a/src/Algebra/Graph/Relation.hs +++ b/src/Algebra/Graph/Relation.hs @@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Relation --- Copyright : (c) Andrey Mokhov 2016-2019 +-- Copyright : (c) Andrey Mokhov 2016-2021 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental @@ -43,7 +43,9 @@ ) where import Control.DeepSeq +import Data.Bifunctor import Data.Set (Set, union) +import Data.String import Data.Tree import Data.Tuple @@ -56,11 +58,13 @@ {-| The 'Relation' data type represents a graph as a /binary relation/. We define a 'Num' instance as a convenient notation for working with graphs: - > 0 == vertex 0 - > 1 + 2 == overlay (vertex 1) (vertex 2) - > 1 * 2 == connect (vertex 1) (vertex 2) - > 1 + 2 * 3 == overlay (vertex 1) (connect (vertex 2) (vertex 3)) - > 1 * (2 + 3) == connect (vertex 1) (overlay (vertex 2) (vertex 3)) +@ +0 == 'vertex' 0 +1 + 2 == 'overlay' ('vertex' 1) ('vertex' 2) +1 * 2 == 'connect' ('vertex' 1) ('vertex' 2) +1 + 2 * 3 == 'overlay' ('vertex' 1) ('connect' ('vertex' 2) ('vertex' 3)) +1 * (2 + 3) == 'connect' ('vertex' 1) ('overlay' ('vertex' 2) ('vertex' 3)) +@ __Note:__ the 'Num' instance does not satisfy several "customary laws" of 'Num', which dictate that 'fromInteger' @0@ and 'fromInteger' @1@ should act as @@ -178,7 +182,7 @@ , compare (edgeSet x) (edgeSet y) ] instance NFData a => NFData (Relation a) where - rnf (Relation d r) = rnf d `seq` rnf r `seq` () + rnf (Relation d r) = rnf d `seq` rnf r -- | __Note:__ this does not satisfy the usual ring laws; see 'Relation' for -- more details. @@ -190,8 +194,18 @@ abs = id negate = id +instance IsString a => IsString (Relation a) where + fromString = vertex . fromString + +-- | Defined via 'overlay'. +instance Ord a => Semigroup (Relation a) where + (<>) = overlay + +-- | Defined via 'overlay' and 'empty'. +instance Ord a => Monoid (Relation a) where + mempty = empty + -- | Construct the /empty graph/. --- Complexity: /O(1)/ time and memory. -- -- @ -- 'isEmpty' empty == True @@ -203,7 +217,6 @@ empty = Relation Set.empty Set.empty -- | Construct the graph comprising /a single isolated vertex/. --- Complexity: /O(1)/ time and memory. -- -- @ -- 'isEmpty' (vertex x) == False @@ -214,6 +227,18 @@ vertex :: a -> Relation a vertex x = Relation (Set.singleton x) Set.empty +-- | Construct the graph comprising /a single edge/. +-- +-- @ +-- edge x y == 'connect' ('vertex' x) ('vertex' y) +-- 'hasEdge' x y (edge x y) == True +-- 'edgeCount' (edge x y) == 1 +-- 'vertexCount' (edge 1 1) == 1 +-- 'vertexCount' (edge 1 2) == 2 +-- @ +edge :: Ord a => a -> a -> Relation a +edge x y = Relation (Set.fromList [x, y]) (Set.singleton (x, y)) + -- | /Overlay/ two graphs. This is a commutative, associative and idempotent -- operation with the identity 'empty'. -- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. @@ -251,20 +276,7 @@ -- @ connect :: Ord a => Relation a -> Relation a -> Relation a connect x y = Relation (domain x `union` domain y) - (relation x `union` relation y `union` (domain x `setProduct` domain y)) - --- | Construct the graph comprising /a single edge/. --- Complexity: /O(1)/ time, memory and size. --- --- @ --- edge x y == 'connect' ('vertex' x) ('vertex' y) --- 'hasEdge' x y (edge x y) == True --- 'edgeCount' (edge x y) == 1 --- 'vertexCount' (edge 1 1) == 1 --- 'vertexCount' (edge 1 2) == 2 --- @ -edge :: Ord a => a -> a -> Relation a -edge x y = Relation (Set.fromList [x, y]) (Set.singleton (x, y)) + (relation x `union` relation y `union` (domain x `Set.cartesianProduct` domain y)) -- | Construct the graph comprising a given list of isolated vertices. -- Complexity: /O(L * log(L))/ time and /O(L)/ memory, where /L/ is the length @@ -273,6 +285,7 @@ -- @ -- vertices [] == 'empty' -- vertices [x] == 'vertex' x +-- vertices == 'overlays' . map 'vertex' -- 'hasVertex' x . vertices == 'elem' x -- 'vertexCount' . vertices == 'length' . 'Data.List.nub' -- 'vertexSet' . vertices == Set.'Set.fromList' @@ -444,7 +457,7 @@ edgeSet = relation -- | The sorted /adjacency list/ of a graph. --- Complexity: /O(n + m)/ time and /O(m)/ memory. +-- Complexity: /O(n + m)/ time and memory. -- -- @ -- adjacencyList 'empty' == [] @@ -457,7 +470,7 @@ adjacencyList r = go (Set.toAscList $ domain r) (Set.toAscList $ relation r) where go [] _ = [] - go vs [] = map ((,[])) vs + go vs [] = map (, []) vs go (x:vs) es = let (ys, zs) = span ((==x) . fst) es in (x, map snd ys) : go vs zs -- | The /preset/ of an element @x@ is the set of elements that are related to @@ -545,7 +558,7 @@ -- biclique xs ys == 'connect' ('vertices' xs) ('vertices' ys) -- @ biclique :: Ord a => [a] -> [a] -> Relation a -biclique xs ys = Relation (x `Set.union` y) (x `setProduct` y) +biclique xs ys = Relation (x `Set.union` y) (x `Set.cartesianProduct` y) where x = Set.fromList xs y = Set.fromList ys @@ -652,7 +665,7 @@ -- | Merge vertices satisfying a given predicate into a given vertex. -- Complexity: /O((n + m) * log(n))/ time, assuming that the predicate takes --- /O(1)/ to be evaluated. +-- constant time. -- -- @ -- mergeVertices ('const' False) x == id @@ -689,12 +702,11 @@ -- gmap f . gmap g == gmap (f . g) -- @ gmap :: Ord b => (a -> b) -> Relation a -> Relation b -gmap f (Relation d r) = Relation (Set.map f d) (Set.map (\(x, y) -> (f x, f y)) r) +gmap f (Relation d r) = Relation (Set.map f d) (Set.map (bimap f f) r) -- | Construct the /induced subgraph/ of a given graph by removing the -- vertices that do not satisfy a given predicate. --- Complexity: /O(n + m)/ time, assuming that the predicate takes /O(1)/ to --- be evaluated. +-- Complexity: /O(n + m)/ time, assuming that the predicate takes constant time. -- -- @ -- induce ('const' True ) x == x @@ -722,7 +734,7 @@ induceJust (Relation d r) = Relation (catMaybesSet d) (catMaybesSet2 r) where catMaybesSet = Set.mapMonotonic Maybe.fromJust . Set.delete Nothing - catMaybesSet2 = Set.mapMonotonic (\(x, y) -> (Maybe.fromJust x, Maybe.fromJust y)) + catMaybesSet2 = Set.mapMonotonic (bimap Maybe.fromJust Maybe.fromJust) . Set.filter p p (Nothing, _) = False p (_, Nothing) = False @@ -751,8 +763,8 @@ compose :: Ord a => Relation a -> Relation a -> Relation a compose x y = Relation (referredToVertexSet r) r where - d = domain x `Set.union` domain y - r = Set.unions [ preSet v x `setProduct` postSet v y | v <- Set.toAscList d ] + vs = Set.toAscList (domain x `Set.union` domain y) + r = Set.unions [ preSet v x `Set.cartesianProduct` postSet v y | v <- vs ] -- | Compute the /reflexive and transitive closure/ of a graph. -- Complexity: /O(n * m * log(n) * log(m))/ time. diff --git a/src/Algebra/Graph/Relation/Preorder.hs b/src/Algebra/Graph/Relation/Preorder.hs --- a/src/Algebra/Graph/Relation/Preorder.hs +++ b/src/Algebra/Graph/Relation/Preorder.hs @@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Relation.Preorder --- Copyright : (c) Andrey Mokhov 2016-2019 +-- Copyright : (c) Andrey Mokhov 2016-2021 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental @@ -14,8 +14,9 @@ PreorderRelation, fromRelation, toRelation ) where -import Control.DeepSeq import Algebra.Graph.Relation +import Control.DeepSeq +import Data.String import qualified Algebra.Graph.Class as C @@ -41,7 +42,7 @@ show (1 * 2 + 2 * 3 :: PreorderRelation Int) == "edges [(1,1),(1,2),(1,3),(2,2),(2,3),(3,3)]"@ -} newtype PreorderRelation a = PreorderRelation { fromPreorder :: Relation a } - deriving (Num, NFData) + deriving (IsString, NFData, Num) instance (Ord a, Show a) => Show (PreorderRelation a) where show = show . toRelation diff --git a/src/Algebra/Graph/Relation/Reflexive.hs b/src/Algebra/Graph/Relation/Reflexive.hs --- a/src/Algebra/Graph/Relation/Reflexive.hs +++ b/src/Algebra/Graph/Relation/Reflexive.hs @@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Relation.Reflexive --- Copyright : (c) Andrey Mokhov 2016-2019 +-- Copyright : (c) Andrey Mokhov 2016-2021 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental @@ -14,8 +14,9 @@ ReflexiveRelation, fromRelation, toRelation ) where -import Control.DeepSeq import Algebra.Graph.Relation +import Control.DeepSeq +import Data.String import qualified Algebra.Graph.Class as C @@ -31,7 +32,7 @@ show (1 * 2 :: ReflexiveRelation Int) == "edges [(1,1),(1,2),(2,2)]"@ -} newtype ReflexiveRelation a = ReflexiveRelation { fromReflexive :: Relation a } - deriving (Num, NFData) + deriving (IsString, NFData, Num) instance Ord a => Eq (ReflexiveRelation a) where x == y = toRelation x == toRelation y diff --git a/src/Algebra/Graph/Relation/Symmetric.hs b/src/Algebra/Graph/Relation/Symmetric.hs --- a/src/Algebra/Graph/Relation/Symmetric.hs +++ b/src/Algebra/Graph/Relation/Symmetric.hs @@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Relation.Symmetric --- Copyright : (c) Andrey Mokhov 2016-2019 +-- Copyright : (c) Andrey Mokhov 2016-2021 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental @@ -44,6 +44,7 @@ import Control.DeepSeq import Data.Coerce import Data.Set (Set) +import Data.String import Data.Tree import qualified Data.Set as Set @@ -105,7 +106,7 @@ -- 'R.edgeCount' . fromSymmetric <= (*2) . 'edgeCount' -- @ fromSymmetric :: R.Relation a - } deriving (Eq, NFData) + } deriving (Eq, IsString, NFData) instance (Ord a, Show a) => Show (Relation a) where show = show . toRelation @@ -129,6 +130,14 @@ abs = id negate = id +-- | Defined via 'overlay'. +instance Ord a => Semigroup (Relation a) where + (<>) = overlay + +-- | Defined via 'overlay' and 'empty'. +instance Ord a => Monoid (Relation a) where + mempty = empty + -- | Construct a symmetric relation from a given "Algebra.Graph.Relation". -- Complexity: /O(m*log(m))/ time. -- @@ -143,7 +152,6 @@ toSymmetric = SR . R.symmetricClosure -- | Construct the /empty graph/. --- Complexity: /O(1)/ time and memory. -- -- @ -- 'isEmpty' empty == True @@ -155,7 +163,6 @@ empty = coerce R.empty -- | Construct the graph comprising /a single isolated vertex/. --- Complexity: /O(1)/ time and memory. -- -- @ -- 'isEmpty' (vertex x) == False @@ -166,6 +173,20 @@ vertex :: a -> Relation a vertex = coerce R.vertex +-- | Construct the graph comprising /a single edge/. +-- +-- @ +-- edge x y == 'connect' ('vertex' x) ('vertex' y) +-- edge x y == 'edge' y x +-- edge x y == 'edges' [(x,y), (y,x)] +-- 'hasEdge' x y (edge x y) == True +-- 'edgeCount' (edge x y) == 1 +-- 'vertexCount' (edge 1 1) == 1 +-- 'vertexCount' (edge 1 2) == 2 +-- @ +edge :: Ord a => a -> a -> Relation a +edge x y = SR $ R.edges [(x,y), (y,x)] + -- | /Overlay/ two graphs. This is a commutative, associative and idempotent -- operation with the identity 'empty'. -- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. @@ -205,21 +226,6 @@ connect :: Ord a => Relation a -> Relation a -> Relation a connect x y = coerce R.connect x y `overlay` biclique (vertexList y) (vertexList x) --- | Construct the graph comprising /a single edge/. --- Complexity: /O(1)/ time, memory and size. --- --- @ --- edge x y == 'connect' ('vertex' x) ('vertex' y) --- edge x y == 'edge' y x --- edge x y == 'edges' [(x,y), (y,x)] --- 'hasEdge' x y (edge x y) == True --- 'edgeCount' (edge x y) == 1 --- 'vertexCount' (edge 1 1) == 1 --- 'vertexCount' (edge 1 2) == 2 --- @ -edge :: Ord a => a -> a -> Relation a -edge x y = SR $ R.edges [(x,y), (y,x)] - -- | Construct the graph comprising a given list of isolated vertices. -- Complexity: /O(L * log(L))/ time and /O(L)/ memory, where /L/ is the length -- of the given list. @@ -227,6 +233,7 @@ -- @ -- vertices [] == 'empty' -- vertices [x] == 'vertex' x +-- vertices == 'overlays' . map 'vertex' -- 'hasVertex' x . vertices == 'elem' x -- 'vertexCount' . vertices == 'length' . 'Data.List.nub' -- 'vertexSet' . vertices == Set.'Set.fromList' @@ -406,7 +413,7 @@ edgeSet = Set.filter (uncurry (<=)) . R.edgeSet . fromSymmetric -- | The sorted /adjacency list/ of a graph. --- Complexity: /O(n + m)/ time and /O(m)/ memory. +-- Complexity: /O(n + m)/ time and memory. -- -- @ -- adjacencyList 'empty' == [] @@ -566,7 +573,7 @@ -- | Merge vertices satisfying a given predicate into a given vertex. -- Complexity: /O((n + m) * log(n))/ time, assuming that the predicate takes --- /O(1)/ to be evaluated. +-- constant time. -- -- @ -- mergeVertices ('const' False) x == id @@ -594,8 +601,7 @@ -- | Construct the /induced subgraph/ of a given graph by removing the -- vertices that do not satisfy a given predicate. --- Complexity: /O(n + m)/ time, assuming that the predicate takes /O(1)/ to --- be evaluated. +-- Complexity: /O(n + m)/ time, assuming that the predicate takes constant time. -- -- @ -- induce ('const' True ) x == x diff --git a/src/Algebra/Graph/Relation/Transitive.hs b/src/Algebra/Graph/Relation/Transitive.hs --- a/src/Algebra/Graph/Relation/Transitive.hs +++ b/src/Algebra/Graph/Relation/Transitive.hs @@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Relation.Transitive --- Copyright : (c) Andrey Mokhov 2016-2019 +-- Copyright : (c) Andrey Mokhov 2016-2021 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental @@ -14,8 +14,9 @@ TransitiveRelation, fromRelation, toRelation ) where -import Control.DeepSeq import Algebra.Graph.Relation +import Control.DeepSeq +import Data.String import qualified Algebra.Graph.Class as C @@ -36,7 +37,7 @@ show (1 * 2 + 2 * 3 :: TransitiveRelation Int) == "edges [(1,2),(1,3),(2,3)]"@ -} newtype TransitiveRelation a = TransitiveRelation { fromTransitive :: Relation a } - deriving (Num, NFData) + deriving (IsString, NFData, Num) instance Ord a => Eq (TransitiveRelation a) where x == y = toRelation x == toRelation y diff --git a/src/Algebra/Graph/ToGraph.hs b/src/Algebra/Graph/ToGraph.hs --- a/src/Algebra/Graph/ToGraph.hs +++ b/src/Algebra/Graph/ToGraph.hs @@ -2,7 +2,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.ToGraph --- Copyright : (c) Andrey Mokhov 2016-2019 +-- Copyright : (c) Andrey Mokhov 2016-2021 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental diff --git a/src/Algebra/Graph/Undirected.hs b/src/Algebra/Graph/Undirected.hs --- a/src/Algebra/Graph/Undirected.hs +++ b/src/Algebra/Graph/Undirected.hs @@ -1,8 +1,7 @@ -{-# LANGUAGE DeriveGeneric #-} ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Undirected --- Copyright : (c) Andrey Mokhov 2016-2020 +-- Copyright : (c) Andrey Mokhov 2016-2021 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental @@ -54,10 +53,11 @@ import Control.DeepSeq import Control.Monad import Data.Coerce -import Data.List +import Data.List (tails) import GHC.Generics import Data.Set (Set) import Data.Tree (Tree, Forest) +import Data.String import qualified Algebra.Graph as G import qualified Algebra.Graph.Relation.Symmetric as R @@ -72,11 +72,13 @@ /commutative/. We define a 'Num' instance as a convenient notation for working with undirected graphs: - > 0 == vertex 0 - > 1 + 2 == vertices [1,2] - > 1 * 2 == edge 1 2 - > 1 + 2 * 3 == overlay (vertex 1) (edge 2 3) - > 1 * (2 + 3) == edges [(1,2),(1,3)] +@ +0 == 'vertex' 0 +1 + 2 == 'overlay' ('vertex' 1) ('vertex' 2) +1 * 2 == 'connect' ('vertex' 1) ('vertex' 2) +1 + 2 * 3 == 'overlay' ('vertex' 1) ('connect' ('vertex' 2) ('vertex' 3)) +1 * (2 + 3) == 'connect' ('vertex' 1) ('overlay' ('vertex' 2) ('vertex' 3)) +@ __Note:__ the 'Num' instance does not satisfy several "customary laws" of 'Num', which dictate that 'fromInteger' @0@ and 'fromInteger' @1@ should act as @@ -174,7 +176,8 @@ x + y <= x * y@ -} newtype Graph a = UG (G.Graph a) - deriving (Alternative, Applicative, Functor, Generic, Monad, MonadPlus, NFData) + deriving ( Alternative, Applicative, Functor, Generic, IsString, Monad + , MonadPlus, NFData ) instance (Show a, Ord a) => Show (Graph a) where show = show . toRelation @@ -195,6 +198,14 @@ instance Ord a => Ord (Graph a) where compare = ordR +-- | Defined via 'overlay'. +instance Semigroup (Graph a) where + (<>) = overlay + +-- | Defined via 'overlay' and 'empty'. +instance Monoid (Graph a) where + mempty = empty + -- TODO: Find a more efficient equality check. -- Check if two graphs are equal by converting them to symmetric relations. eqR :: Ord a => Graph a -> Graph a -> Bool @@ -230,7 +241,6 @@ fromUndirected = toGraph . toRelation -- | Construct the /empty graph/. --- Complexity: /O(1)/ time, memory and size. -- -- @ -- 'isEmpty' empty == True @@ -244,7 +254,6 @@ {-# INLINE empty #-} -- | Construct the graph comprising /a single isolated vertex/. --- Complexity: /O(1)/ time, memory and size. -- -- @ -- 'isEmpty' (vertex x) == False @@ -258,7 +267,6 @@ {-# INLINE vertex #-} -- | Construct the graph comprising /a single edge/. --- Complexity: /O(1)/ time, memory and size. -- -- @ -- edge x y == 'connect' ('vertex' x) ('vertex' y) @@ -324,6 +332,7 @@ -- @ -- vertices [] == 'empty' -- vertices [x] == 'vertex' x +-- vertices == 'overlays' . map 'vertex' -- 'hasVertex' x . vertices == 'elem' x -- 'vertexCount' . vertices == 'length' . 'Data.List.nub' -- 'vertexSet' . vertices == Set . 'Set.fromList' @@ -379,8 +388,8 @@ -- | 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 --- complexity of 'size' is /O(s)/, since all functions have cost /O(1)/. +-- Complexity: /O(s)/ applications of the given functions. As an example, the +-- complexity of 'size' is /O(s)/, since 'const' and '+' have constant costs. -- -- @ -- foldg 'empty' 'vertex' 'overlay' 'connect' == id @@ -561,7 +570,7 @@ {-# INLINE [1] edgeSet #-} -- | The sorted /adjacency list/ of a graph. --- Complexity: /O(n + m)/ time and /O(m)/ memory. +-- Complexity: /O(n + m)/ time and memory. -- -- @ -- adjacencyList 'empty' == [] @@ -754,7 +763,7 @@ -- | Merge vertices satisfying a given predicate into a given vertex. -- Complexity: /O(s)/ time, memory and size, assuming that the predicate takes --- /O(1)/ to be evaluated. +-- constant time. -- -- @ -- mergeVertices ('const' False) x == id @@ -766,11 +775,10 @@ mergeVertices = coerce21 G.mergeVertices {-# INLINE mergeVertices #-} --- TODO: Implement via 'induceJust' to reduce code duplication. -- | Construct the /induced subgraph/ of a given graph by removing the -- vertices that do not satisfy a given predicate. -- Complexity: /O(s)/ time, memory and size, assuming that the predicate takes --- /O(1)/ to be evaluated. +-- constant time. -- -- @ -- induce ('const' True ) x == x diff --git a/src/Data/Graph/Typed.hs b/src/Data/Graph/Typed.hs --- a/src/Data/Graph/Typed.hs +++ b/src/Data/Graph/Typed.hs @@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Data.Graph.Typed --- Copyright : (c) Anton Lorenzen, Andrey Mokhov 2016-2018 +-- Copyright : (c) Anton Lorenzen, Andrey Mokhov 2016-2021 -- License : MIT (see the file LICENSE) -- Maintainer : anfelor@posteo.de, andrey.mokhov@gmail.com -- Stability : unstable diff --git a/test/Algebra/Graph/Test.hs b/test/Algebra/Graph/Test.hs --- a/test/Algebra/Graph/Test.hs +++ b/test/Algebra/Graph/Test.hs @@ -1,8 +1,7 @@ -{-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Test --- Copyright : (c) Andrey Mokhov 2016-2020 +-- Copyright : (c) Andrey Mokhov 2016-2021 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental diff --git a/test/Algebra/Graph/Test/API.hs b/test/Algebra/Graph/Test/API.hs --- a/test/Algebra/Graph/Test/API.hs +++ b/test/Algebra/Graph/Test/API.hs @@ -1,9 +1,9 @@ -{-# LANGUAGE ConstraintKinds, GADTs, RankNTypes, RecordWildCards #-} +{-# LANGUAGE ConstraintKinds, RecordWildCards #-} {-# OPTIONS_GHC -Wno-missing-fields #-} ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Test.API --- Copyright : (c) Andrey Mokhov 2016-2019 +-- Copyright : (c) Andrey Mokhov 2016-2021 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental diff --git a/test/Algebra/Graph/Test/Acyclic/AdjacencyMap.hs b/test/Algebra/Graph/Test/Acyclic/AdjacencyMap.hs --- a/test/Algebra/Graph/Test/Acyclic/AdjacencyMap.hs +++ b/test/Algebra/Graph/Test/Acyclic/AdjacencyMap.hs @@ -1,8 +1,8 @@ -{-# LANGUAGE OverloadedLists, ViewPatterns #-} +{-# LANGUAGE ViewPatterns #-} ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Test.Acyclic.AdjacencyMap --- Copyright : (c) Andrey Mokhov 2016-2019 +-- Copyright : (c) Andrey Mokhov 2016-2021 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental @@ -12,7 +12,6 @@ module Algebra.Graph.Test.Acyclic.AdjacencyMap (testAcyclicAdjacencyMap) where import Algebra.Graph.Acyclic.AdjacencyMap -import Algebra.Graph.Internal import Algebra.Graph.Test hiding (shrink) import Data.Bifunctor @@ -22,6 +21,7 @@ import qualified Algebra.Graph.AdjacencyMap.Algorithm as AM import qualified Algebra.Graph.NonEmpty.AdjacencyMap as NonEmpty import qualified Data.Set as Set +import qualified GHC.Exts as Exts type AAI = AdjacencyMap Int type AI = AM.AdjacencyMap Int @@ -30,22 +30,22 @@ testAcyclicAdjacencyMap :: IO () testAcyclicAdjacencyMap = do putStrLn "\n============ Acyclic.AdjacencyMap.Show ============" - test "show empty == \"empty\"" $ - show (empty :: AAI) == "empty" + test "show empty == \"empty\"" $ + show (empty :: AAI) == "empty" - test "show (shrink 1) == \"vertex 1\"" $ - show (shrink 1 :: AAI) == "vertex 1" + test "show (shrink 1) == \"vertex 1\"" $ + show (shrink 1 :: AAI) == "vertex 1" - test "show (shrink $ 1 + 2) == \"vertices [1,2]\"" $ - show (shrink $ 1 + 2 :: AAI) == "vertices [1,2]" + test "show (shrink $ 1 + 2) == \"vertices [1,2]\"" $ + show (shrink $ 1 + 2 :: AAI) == "vertices [1,2]" - test "show (shrink $ 1 * 2) == \"(fromJust . toAcyclic) (edge 1 2)\"" $ - show (shrink $ 1 * 2 :: AAI) == "(fromJust . toAcyclic) (edge 1 2)" + test "show (shrink $ 1 * 2) == \"(fromJust . toAcyclic) (edge 1 2)\"" $ + show (shrink $ 1 * 2 :: AAI) == "(fromJust . toAcyclic) (edge 1 2)" - test "show (shrink $ 1 * 2 * 3) == \"(fromJust . toAcyclic) (edges [(1,2),(1,3),(2,3)])\"" $ + test "show (shrink $ 1 * 2 * 3) == \"(fromJust . toAcyclic) (edges [(1,2),(1,3),(2,3)])\"" $ show (shrink $ 1 * 2 * 3 :: AAI) == "(fromJust . toAcyclic) (edges [(1,2),(1,3),(2,3)])" - test "show (shrink $ 1 * 2 + 3) == \"(fromJust . toAcyclic) (overlay (vertex 3) (edge 1 2))\"" $ + test "show (shrink $ 1 * 2 + 3) == \"(fromJust . toAcyclic) (overlay (vertex 3) (edge 1 2))\"" $ show (shrink $ 1 * 2 + 3 :: AAI) == "(fromJust . toAcyclic) (overlay (vertex 3) (edge 1 2))" putStrLn "\n============ Acyclic.AdjacencyMap.fromAcyclic ============" @@ -68,16 +68,16 @@ (AM.isAcyclic . fromAcyclic) x == const True x putStrLn "\n============ Acyclic.AdjacencyMap.empty ============" - test "isEmpty empty == True" $ + test "isEmpty empty == True" $ isEmpty (empty :: AAI) == True - test "hasVertex x empty == False" $ \x -> + test "hasVertex x empty == False" $ \x -> hasVertex x (empty :: AAI) == False - test "vertexCount empty == 0" $ + test "vertexCount empty == 0" $ vertexCount (empty :: AAI) == 0 - test "edgeCount empty == 0" $ + test "edgeCount empty == 0" $ edgeCount (empty :: AAI) == 0 putStrLn "\n============ Acyclic.AdjacencyMap.vertex ============" @@ -94,249 +94,250 @@ edgeCount (vertex x) == 0 putStrLn "\n============ Acyclic.AdjacencyMap.vertices ============" - test "vertices [] == empty" $ - vertices [] == (empty :: AAI) + test "vertices [] == empty" $ + vertices [] == (empty :: AAI) - test "vertices [x] == vertex x" $ \(x :: Int) -> - vertices [x] == vertex x + test "vertices [x] == vertex x" $ \(x :: Int) -> + vertices [x] == vertex x - test "hasVertex x . vertices == elem x" $ \(x :: Int) xs -> + test "hasVertex x . vertices == elem x" $ \(x :: Int) xs -> (hasVertex x . vertices) xs == elem x xs - test "vertexCount . vertices == length . nub" $ \(xs :: [Int]) -> + test "vertexCount . vertices == length . nub" $ \(xs :: [Int]) -> (vertexCount . vertices) xs == (length . nubOrd) xs - test "vertexSet . vertices == Set.fromList" $ \(xs :: [Int]) -> + test "vertexSet . vertices == Set.fromList" $ \(xs :: [Int]) -> (vertexSet . vertices) xs == Set.fromList xs putStrLn "\n============ Acyclic.AdjacencyMap.union ============" test "vertexSet (union x y) == " $ \(x :: AAI) (y :: AAI) -> - vertexSet (union x y) == Set.unions ([ Set.map Left (vertexSet x) - , Set.map Right (vertexSet y) ] ++ []) + vertexSet (union x y) == Set.unions [ Set.map Left (vertexSet x) + , Set.map Right (vertexSet y) ] test "edgeSet (union x y) == " $ \(x :: AAI) (y :: AAI) -> - edgeSet (union x y) == Set.unions ([ Set.map (bimap Left Left ) (edgeSet x) - , Set.map (bimap Right Right) (edgeSet y) ] ++ []) + edgeSet (union x y) == Set.unions [ Set.map (bimap Left Left ) (edgeSet x) + , Set.map (bimap Right Right) (edgeSet y) ] putStrLn "\n============ Acyclic.AdjacencyMap.join ============" test "vertexSet (join x y) == " $ \(x :: AAI) (y :: AAI) -> - vertexSet (join x y) == Set.unions ([ Set.map Left (vertexSet x) - , Set.map Right (vertexSet y) ] ++ []) + vertexSet (join x y) == Set.unions [ Set.map Left (vertexSet x) + , Set.map Right (vertexSet y) ] test "edgeSet (join x y) == " $ \(x :: AAI) (y :: AAI) -> - edgeSet (join x y) == Set.unions ([ Set.map (bimap Left Left ) (edgeSet x) - , Set.map (bimap Right Right) (edgeSet y) - , Set.map (bimap Left Right) (setProduct (vertexSet x) (vertexSet y)) ] ++ []) + edgeSet (join x y) == Set.unions + [ Set.map (bimap Left Left ) (edgeSet x) + , Set.map (bimap Right Right) (edgeSet y) + , Set.map (bimap Left Right) (Set.cartesianProduct (vertexSet x) (vertexSet y)) ] putStrLn "\n============ Acyclic.AdjacencyMap.isSubgraphOf ============" - test "isSubgraphOf empty x == True" $ \(x :: AAI) -> - isSubgraphOf empty x == True + test "isSubgraphOf empty x == True" $ \(x :: AAI) -> + isSubgraphOf empty x == True - test "isSubgraphOf (vertex x) empty == False" $ \(x :: Int) -> - isSubgraphOf (vertex x) empty == False + test "isSubgraphOf (vertex x) empty == False" $ \(x :: Int) -> + isSubgraphOf (vertex x) empty == False - test "isSubgraphOf (induce p x) x == True" $ \(x :: AAI) (apply -> p) -> - isSubgraphOf (induce p x) x == True + test "isSubgraphOf (induce p x) x == True" $ \(x :: AAI) (apply -> p) -> + isSubgraphOf (induce p x) x == True - test "isSubgraphOf x (transitiveClosure x) == True" $ \(x :: AAI) -> - isSubgraphOf x (transitiveClosure x) == True + test "isSubgraphOf x (transitiveClosure x) == True" $ \(x :: AAI) -> + isSubgraphOf x (transitiveClosure x) == True test "isSubgraphOf x y ==> x <= y" $ \(x :: AAI) z -> let connect x y = shrink $ fromAcyclic x + fromAcyclic y -- TODO: Make the precondition stronger y = connect x (vertices z) -- Make sure we hit the precondition - in isSubgraphOf x y ==> x <= y + in isSubgraphOf x y ==> x <= y putStrLn "\n============ Acyclic.AdjacencyMap.isEmpty ============" - test "isEmpty empty == True" $ - isEmpty (empty :: AAI) == True + test "isEmpty empty == True" $ + isEmpty (empty :: AAI) == True - test "isEmpty (vertex x) == False" $ \(x :: Int) -> - isEmpty (vertex x) == False + test "isEmpty (vertex x) == False" $ \(x :: Int) -> + isEmpty (vertex x) == False - test "isEmpty (removeVertex x $ vertex x) == True" $ \(x :: Int) -> - isEmpty (removeVertex x $ vertex x) == True + test "isEmpty (removeVertex x $ vertex x) == True" $ \(x :: Int) -> + isEmpty (removeVertex x $ vertex x) == True - test "isEmpty (removeEdge 1 2 $ shrink $ 1 * 2) == False" $ + test "isEmpty (removeEdge 1 2 $ shrink $ 1 * 2) == False" $ isEmpty (removeEdge 1 2 $ shrink $ 1 * 2 :: AAI) == False putStrLn "\n============ Acyclic.AdjacencyMap.hasVertex ============" - test "hasVertex x empty == False" $ \(x :: Int) -> - hasVertex x empty == False + test "hasVertex x empty == False" $ \(x :: Int) -> + hasVertex x empty == False - test "hasVertex x (vertex y) == (x == y)" $ \(x :: Int) y -> - hasVertex x (vertex y) == (x == y) + 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 -> + test "hasVertex x . removeVertex x == const False" $ \(x :: Int) y -> (hasVertex x . removeVertex x) y == const False y putStrLn "\n============ Acyclic.AdjacencyMap.hasEdge ============" - test "hasEdge x y empty == False" $ \(x :: Int) y -> - hasEdge x y empty == False + test "hasEdge x y empty == False" $ \(x :: Int) y -> + hasEdge x y empty == False - test "hasEdge x y (vertex z) == False" $ \(x :: Int) y z -> - hasEdge x y (vertex z) == False + test "hasEdge x y (vertex z) == False" $ \(x :: Int) y z -> + hasEdge x y (vertex z) == False - test "hasEdge 1 2 (shrink $ 1 * 2) == True" $ + test "hasEdge 1 2 (shrink $ 1 * 2) == True" $ hasEdge 1 2 (shrink $ 1 * 2 :: AAI) == True - test "hasEdge x y . removeEdge x y == const False" $ \(x :: Int) y z -> - (hasEdge x y . removeEdge x y) z == const False z + test "hasEdge x y . removeEdge x y == const False" $ \(x :: Int) y z -> + (hasEdge x y . removeEdge x y) z == const False z - test "hasEdge x y == elem (x,y) . edgeList" $ \(x :: Int) y z -> do + test "hasEdge x y == elem (x,y) . edgeList" $ \(x :: Int) y z -> do (u, v) <- elements ((x, y) : edgeList z) - return $ hasEdge u v z == elem (u, v) (edgeList z) + return $ hasEdge u v z == elem (u, v) (edgeList z) putStrLn "\n============ Acyclic.AdjacencyMap.vertexCount ============" - test "vertexCount empty == 0" $ - vertexCount (empty :: AAI) == 0 + test "vertexCount empty == 0" $ + vertexCount (empty :: AAI) == 0 - test "vertexCount (vertex x) == 1" $ \(x :: Int) -> - vertexCount (vertex x) == 1 + test "vertexCount (vertex x) == 1" $ \(x :: Int) -> + vertexCount (vertex x) == 1 - test "vertexCount == length . vertexList" $ \(x :: AAI) -> - vertexCount x == (length . vertexList) x + test "vertexCount == length . vertexList" $ \(x :: AAI) -> + vertexCount x == (length . vertexList) x - test "vertexCount x < vertexCount y ==> x < y" $ \(x :: AAI) y -> + test "vertexCount x < vertexCount y ==> x < y" $ \(x :: AAI) y -> if vertexCount x < vertexCount y then property (x < y) else (vertexCount x > vertexCount y ==> x > y) putStrLn "\n============ Acyclic.AdjacencyMap.edgeCount ============" - test "edgeCount empty == 0" $ - edgeCount (empty :: AAI) == 0 + test "edgeCount empty == 0" $ + edgeCount (empty :: AAI) == 0 - test "edgeCount (vertex x) == 0" $ \(x :: Int) -> - edgeCount (vertex x) == 0 + test "edgeCount (vertex x) == 0" $ \(x :: Int) -> + edgeCount (vertex x) == 0 - test "edgeCount (shrink $ 1 * 2) == 1" $ + test "edgeCount (shrink $ 1 * 2) == 1" $ edgeCount (shrink $ 1 * 2 :: AAI) == 1 - test "edgeCount == length . edgeList" $ \(x :: AAI) -> - edgeCount x == (length . edgeList) x + test "edgeCount == length . edgeList" $ \(x :: AAI) -> + edgeCount x == (length . edgeList) x putStrLn "\n============ Acyclic.AdjacencyMap.vertexList ============" - test "vertexList empty == []" $ + test "vertexList empty == []" $ vertexList (empty :: AAI) == [] - test "vertexList (vertex x) == [x]" $ \(x :: Int) -> - vertexList (vertex x) == [x] + test "vertexList (vertex x) == [x]" $ \(x :: Int) -> + vertexList (vertex x) == [x] - test "vertexList . vertices == nub . sort" $ \(xs :: [Int]) -> + test "vertexList . vertices == nub . sort" $ \(xs :: [Int]) -> (vertexList . vertices) xs == (nubOrd . sort) xs putStrLn "\n============ Acyclic.AdjacencyMap.edgeList ============" - test "edgeList empty == []" $ - edgeList (empty :: AAI) == [] + test "edgeList empty == []" $ + edgeList (empty :: AAI) == [] - test "edgeList (vertex x) == []" $ \(x :: Int) -> - edgeList (vertex x) == [] + test "edgeList (vertex x) == []" $ \(x :: Int) -> + edgeList (vertex x) == [] - test "edgeList (shrink $ 2 * 1) == [(2,1)]" $ + test "edgeList (shrink $ 2 * 1) == [(2,1)]" $ edgeList (shrink $ 2 * 1 :: AAI) == [(2,1)] - test "edgeList . transpose == sort . map swap . edgeList" $ \(x :: AAI) -> - (edgeList . transpose) x == (sort . map swap . edgeList) x + test "edgeList . transpose == sort . map swap . edgeList" $ \(x :: AAI) -> + (edgeList . transpose) x == (sort . map swap . edgeList) x putStrLn "\n============ Acyclic.AdjacencyMap.adjacencyList ============" - test "adjacencyList empty == []" $ - adjacencyList (empty :: AAI) == [] + test "adjacencyList empty == []" $ + adjacencyList (empty :: AAI) == [] - test "adjacencyList (vertex x) == [(x, [])]" $ \(x :: Int) -> - adjacencyList (vertex x) == [(x, [])] + test "adjacencyList (vertex x) == [(x, [])]" $ \(x :: Int) -> + adjacencyList (vertex x) == [(x, [])] - test "adjacencyList (shrink $ 1 * 2) == [(1, [2]), (2, [])]" $ + test "adjacencyList (shrink $ 1 * 2) == [(1, [2]), (2, [])]" $ adjacencyList (shrink $ 1 * 2 :: AAI) == [(1, [2]), (2, [])] putStrLn "\n============ Acyclic.AdjacencyMap.vertexSet ============" - test "vertexSet empty == Set.empty" $ + test "vertexSet empty == Set.empty" $ vertexSet (empty :: AAI) == Set.empty - test "vertexSet . vertex == Set.singleton" $ \(x :: Int) -> - (vertexSet . vertex) x == Set.singleton x + test "vertexSet . vertex == Set.singleton" $ \(x :: Int) -> + (vertexSet . vertex) x == Set.singleton x - test "vertexSet . vertices == Set.fromList" $ \(xs :: [Int]) -> + test "vertexSet . vertices == Set.fromList" $ \(xs :: [Int]) -> (vertexSet . vertices) xs == Set.fromList xs putStrLn "\n============ Acyclic.AdjacencyMap.edgeSet ============" - test "edgeSet empty == Set.empty" $ - edgeSet (empty :: AAI) == Set.empty + test "edgeSet empty == Set.empty" $ + edgeSet (empty :: AAI) == Set.empty - test "edgeSet (vertex x) == Set.empty" $ \(x :: Int) -> - edgeSet (vertex x) == Set.empty + test "edgeSet (vertex x) == Set.empty" $ \(x :: Int) -> + edgeSet (vertex x) == Set.empty - test "edgeSet (shrink $ 1 * 2) == Set.singleton (1,2)" $ + test "edgeSet (shrink $ 1 * 2) == Set.singleton (1,2)" $ edgeSet (shrink $ 1 * 2 :: AAI) == Set.singleton (1,2) putStrLn "\n============ Acyclic.AdjacencyMap.preSet ============" - test "preSet x empty == Set.empty" $ \(x :: Int) -> - preSet x empty == Set.empty + test "preSet x empty == Set.empty" $ \(x :: Int) -> + preSet x empty == Set.empty - test "preSet x (vertex x) == Set.empty" $ \(x :: Int) -> - preSet x (vertex x) == Set.empty + test "preSet x (vertex x) == Set.empty" $ \(x :: Int) -> + preSet x (vertex x) == Set.empty - test "preSet 1 (shrink $ 1 * 2) == Set.empty" $ + test "preSet 1 (shrink $ 1 * 2) == Set.empty" $ preSet 1 (shrink $ 1 * 2 :: AAI) == Set.empty - test "preSet 2 (shrink $ 1 * 2) == Set.fromList [1]" $ + test "preSet 2 (shrink $ 1 * 2) == Set.fromList [1]" $ preSet 2 (shrink $ 1 * 2 :: AAI) == Set.fromList [1] - test "Set.member x . preSet x == const False" $ \(x :: Int) y -> - (Set.member x . preSet x) y == const False y + test "Set.member x . preSet x == const False" $ \(x :: Int) y -> + (Set.member x . preSet x) y == const False y putStrLn "\n============ Acyclic.AdjacencyMap.postSet ============" - test "postSet x empty == Set.empty" $ \(x :: Int) -> - postSet x empty == Set.empty + test "postSet x empty == Set.empty" $ \(x :: Int) -> + postSet x empty == Set.empty - test "postSet x (vertex x) == Set.empty" $ \(x :: Int) -> - postSet x (vertex x) == Set.empty + test "postSet x (vertex x) == Set.empty" $ \(x :: Int) -> + postSet x (vertex x) == Set.empty - test "postSet 1 (shrink $ 1 * 2) == Set.fromList [2]" $ + test "postSet 1 (shrink $ 1 * 2) == Set.fromList [2]" $ postSet 1 (shrink $ 1 * 2 :: AAI) == Set.fromList [2] - test "postSet 2 (shrink $ 1 * 2) == Set.empty" $ + test "postSet 2 (shrink $ 1 * 2) == Set.empty" $ postSet 2 (shrink $ 1 * 2 :: AAI) == Set.empty - test "Set.member x . postSet x == const False" $ \(x :: Int) y -> - (Set.member x . postSet x) y == const False y + test "Set.member x . postSet x == const False" $ \(x :: Int) y -> + (Set.member x . postSet x) y == const False y putStrLn "\n============ Acyclic.AdjacencyMap.removeVertex ============" - test "removeVertex x (vertex x) == empty" $ \(x :: Int) -> - removeVertex x (vertex x) == empty + test "removeVertex x (vertex x) == empty" $ \(x :: Int) -> + removeVertex x (vertex x) == empty - test "removeVertex 1 (vertex 2) == vertex 2" $ - removeVertex 1 (vertex 2 :: AAI) == vertex 2 + test "removeVertex 1 (vertex 2) == vertex 2" $ + removeVertex 1 (vertex 2 :: AAI) == vertex 2 - test "removeVertex 1 (shrink $ 1 * 2) == vertex 2" $ + test "removeVertex 1 (shrink $ 1 * 2) == vertex 2" $ removeVertex 1 (shrink $ 1 * 2 :: AAI) == vertex 2 - test "removeVertex x . removeVertex x == removeVertex x" $ \(x :: Int) y -> - (removeVertex x . removeVertex x) y == removeVertex x y + test "removeVertex x . removeVertex x == removeVertex x" $ \(x :: Int) y -> + (removeVertex x . removeVertex x) y == removeVertex x y putStrLn "\n============ Acyclic.AdjacencyMap.removeEdge ============" - test "removeEdge 1 2 (shrink $ 1 * 2) == vertices [1,2]" $ - removeEdge 1 2 (shrink $ 1 * 2 :: AAI) == vertices [1,2] + test "removeEdge 1 2 (shrink $ 1 * 2) == vertices [1,2]" $ + removeEdge 1 2 (shrink $ 1 * 2 :: AAI) == vertices [1,2] - test "removeEdge x y . removeEdge x y == removeEdge x y" $ \(x :: Int) y z -> - (removeEdge x y . removeEdge x y) z == removeEdge x y z + test "removeEdge x y . removeEdge x y == removeEdge x y" $ \(x :: Int) y z -> + (removeEdge x y . removeEdge x y) z == removeEdge x y z - test "removeEdge x y . removeVertex x == removeVertex x" $ \(x :: Int) y z -> - (removeEdge x y . removeVertex x) z == removeVertex x z + test "removeEdge x y . removeVertex x == removeVertex x" $ \(x :: Int) y z -> + (removeEdge x y . removeVertex x) z == removeVertex x z - test "removeEdge 1 2 (shrink $ 1 * 2 * 3) == shrink ((1 + 2) * 3)" $ + test "removeEdge 1 2 (shrink $ 1 * 2 * 3) == shrink ((1 + 2) * 3)" $ removeEdge 1 2 (shrink $ 1 * 2 * 3 :: AAI) == shrink ((1 + 2) * 3) putStrLn "\n============ Acyclic.AdjacencyMap.transpose ============" - test "transpose empty == empty" $ + test "transpose empty == empty" $ transpose (empty :: AAI) == empty - test "transpose (vertex x) == vertex x" $ \(x :: Int) -> - transpose (vertex x) == vertex x + test "transpose (vertex x) == vertex x" $ \(x :: Int) -> + transpose (vertex x) == vertex x - test "transpose . transpose == id" $ size10 $ \(x :: AAI) -> + test "transpose . transpose == id" $ size10 $ \(x :: AAI) -> (transpose . transpose) x == id x - test "edgeList . transpose == sort . map swap . edgeList" $ \(x :: AAI) -> + test "edgeList . transpose == sort . map swap . edgeList" $ \(x :: AAI) -> (edgeList . transpose) x == (sort . map swap . edgeList) x putStrLn "\n============ Acyclic.AdjacencyMap.induce ============" @@ -356,10 +357,10 @@ isSubgraphOf (induce p x) x == True putStrLn "\n============ Acyclic.AdjacencyMap.induceJust ============" - test "induceJust (vertex Nothing) == empty" $ - induceJust (vertex Nothing) == (empty :: AAI) + test "induceJust (vertex Nothing) == empty" $ + induceJust (vertex Nothing) == (empty :: AAI) - test "induceJust . vertex . Just == vertex" $ \(x :: Int) -> + test "induceJust . vertex . Just == vertex" $ \(x :: Int) -> (induceJust . vertex . Just) x == vertex x putStrLn "\n============ Acyclic.AdjacencyMap.box ============" @@ -395,17 +396,17 @@ edgeCount (box x y) <= vertexCount x * edgeCount y + edgeCount x * vertexCount y putStrLn "\n============ Acyclic.AdjacencyMap.transitiveClosure ============" - test "transitiveClosure empty == empty" $ - transitiveClosure empty == (empty :: AAI) + test "transitiveClosure empty == empty" $ + transitiveClosure empty == (empty :: AAI) - test "transitiveClosure (vertex x) == vertex x" $ \(x :: Int) -> - transitiveClosure (vertex x) == vertex x + test "transitiveClosure (vertex x) == vertex x" $ \(x :: Int) -> + transitiveClosure (vertex x) == vertex x - test "transitiveClosure (shrink $ 1 * 2 + 2 * 3) == shrink (1 * 2 + 1 * 3 + 2 * 3)" $ + test "transitiveClosure (shrink $ 1 * 2 + 2 * 3) == shrink (1 * 2 + 1 * 3 + 2 * 3)" $ transitiveClosure (shrink $ 1 * 2 + 2 * 3 :: AAI) == shrink (1 * 2 + 1 * 3 + 2 * 3) - test "transitiveClosure . transitiveClosure == transitiveClosure" $ \(x :: AAI) -> - (transitiveClosure . transitiveClosure) x == transitiveClosure x + test "transitiveClosure . transitiveClosure == transitiveClosure" $ \(x :: AAI) -> + (transitiveClosure . transitiveClosure) x == transitiveClosure x putStrLn "\n============ Acyclic.AdjacencyMap.topSort ============" test "topSort empty == []" $ @@ -433,58 +434,58 @@ test " scc (edge 1 1) == vertex (NonEmpty.edge 1 1)" $ scc (AM.edge 1 1 :: AI) == vertex (NonEmpty.edge 1 1) - test "edgeList $ scc (edge 1 2) == [ (NonEmpty.vertex 1 , NonEmpty.vertex 2 ) ]" $ - edgeList (scc (AM.edge 1 2 :: AI)) == [ (NonEmpty.vertex 1 , NonEmpty.vertex 2 ) ] + test "edgeList $ scc (edge 1 2) == [ (NonEmpty.vertex 1, NonEmpty.vertex 2) ]" $ + edgeList (scc (AM.edge 1 2 :: AI)) == [ (NonEmpty.vertex 1, NonEmpty.vertex 2) ] test "edgeList $ scc (3 * 1 * 4 * 1 * 5) == " $ - edgeList (scc (3 * 1 * 4 * 1 * 5)) == [ (NonEmpty.vertex 3 , NonEmpty.vertex (5 :: Int)) - , (NonEmpty.vertex 3 , NonEmpty.clique1 [1,4,1]) - , (NonEmpty.clique1 [1,4,1], NonEmpty.vertex 5 ) ] + edgeList (scc (3 * 1 * 4 * 1 * 5)) == [ (NonEmpty.vertex 3, NonEmpty.vertex (5 :: Int)) + , (NonEmpty.vertex 3, NonEmpty.clique1 (Exts.fromList [1,4,1])) + , (NonEmpty.clique1 (Exts.fromList [1,4,1]), NonEmpty.vertex 5) ] putStrLn "\n============ Acyclic.AdjacencyMap.toAcyclic ============" - test "toAcyclic (path [1,2,3]) == Just (shrink $ 1 * 2 + 2 * 3)" $ - toAcyclic (AM.path [1,2,3]) == Just (shrink $ 1 * 2 + 2 * 3 :: AAI) + test "toAcyclic (path [1,2,3]) == Just (shrink $ 1 * 2 + 2 * 3)" $ + toAcyclic (AM.path [1,2,3]) == Just (shrink $ 1 * 2 + 2 * 3 :: AAI) - test "toAcyclic (clique [3,2,1]) == Just (transpose (shrink $ 1 * 2 * 3))" $ - toAcyclic (AM.clique [3,2,1]) == Just (transpose (shrink $ 1 * 2 * 3 :: AAI)) + test "toAcyclic (clique [3,2,1]) == Just (transpose (shrink $ 1 * 2 * 3))" $ + toAcyclic (AM.clique [3,2,1]) == Just (transpose (shrink $ 1 * 2 * 3 :: AAI)) - test "toAcyclic (circuit [1,2,3]) == Nothing" $ + test "toAcyclic (circuit [1,2,3]) == Nothing" $ toAcyclic (AM.circuit [1,2,3 :: Int]) == Nothing - test "toAcyclic . fromAcyclic == Just" $ \(x :: AAI) -> - (toAcyclic . fromAcyclic) x == Just x + test "toAcyclic . fromAcyclic == Just" $ \(x :: AAI) -> + (toAcyclic . fromAcyclic) x == Just x putStrLn "\n============ Acyclic.AdjacencyMap.toAcyclicOrd ============" - test "toAcyclicOrd empty == empty" $ - toAcyclicOrd AM.empty == (empty :: AAI) + test "toAcyclicOrd empty == empty" $ + toAcyclicOrd AM.empty == (empty :: AAI) - test "toAcyclicOrd . vertex == vertex" $ \(x :: Int) -> + test "toAcyclicOrd . vertex == vertex" $ \(x :: Int) -> (toAcyclicOrd . AM.vertex) x == vertex x - test "toAcyclicOrd (1 + 2) == shrink (1 + 2)" $ - toAcyclicOrd (1 + 2) == (shrink $ 1 + 2 :: AAI) + test "toAcyclicOrd (1 + 2) == shrink (1 + 2)" $ + toAcyclicOrd (1 + 2) == (shrink $ 1 + 2 :: AAI) - test "toAcyclicOrd (1 * 2) == shrink (1 * 2)" $ - toAcyclicOrd (1 * 2) == (shrink $ 1 * 2 :: AAI) + test "toAcyclicOrd (1 * 2) == shrink (1 * 2)" $ + toAcyclicOrd (1 * 2) == (shrink $ 1 * 2 :: AAI) - test "toAcyclicOrd (2 * 1) == shrink (1 + 2)" $ - toAcyclicOrd (2 * 1) == (shrink $ 1 + 2 :: AAI) + test "toAcyclicOrd (2 * 1) == shrink (1 + 2)" $ + toAcyclicOrd (2 * 1) == (shrink $ 1 + 2 :: AAI) - test "toAcyclicOrd (1 * 2 * 1) == shrink (1 * 2)" $ - toAcyclicOrd (1 * 2 * 1) == (shrink $ 1 * 2 :: AAI) + test "toAcyclicOrd (1 * 2 * 1) == shrink (1 * 2)" $ + toAcyclicOrd (1 * 2 * 1) == (shrink $ 1 * 2 :: AAI) - test "toAcyclicOrd (1 * 2 * 3) == shrink (1 * 2 * 3)" $ - toAcyclicOrd (1 * 2 * 3) == (shrink $ 1 * 2 * 3 :: AAI) + test "toAcyclicOrd (1 * 2 * 3) == shrink (1 * 2 * 3)" $ + toAcyclicOrd (1 * 2 * 3) == (shrink $ 1 * 2 * 3 :: AAI) putStrLn "\n============ Acyclic.AdjacencyMap.shrink ============" - test "shrink . AM.vertex == vertex" $ \x -> - (shrink . AM.vertex) x == (vertex x :: AAI) + test "shrink . AM.vertex == vertex" $ \x -> + (shrink . AM.vertex) x == (vertex x :: AAI) - test "shrink . AM.vertices == vertices" $ \x -> + test "shrink . AM.vertices == vertices" $ \x -> (shrink . AM.vertices) x == (vertices x :: AAI) - test "shrink . fromAcyclic == id" $ \(x :: AAI) -> + test "shrink . fromAcyclic == id" $ \(x :: AAI) -> (shrink . fromAcyclic) x == id x putStrLn "\n============ Acyclic.AdjacencyMap.consistent ============" @@ -498,5 +499,5 @@ test "box" $ size10 $ \(x :: AAI) (y :: AAI) -> consistent (box x y) test "transitiveClosure" $ \(x :: AAI) -> consistent (transitiveClosure x) test "scc" $ \(x :: AI) -> consistent (scc x) - test "toAcyclic" $ \(x :: AI) -> fmap consistent (toAcyclic x) /= Just False + test "toAcyclic" $ \(x :: AI) -> fmap consistent (toAcyclic x) /= Just False test "toAcyclicOrd" $ \(x :: AI) -> consistent (toAcyclicOrd x) diff --git a/test/Algebra/Graph/Test/AdjacencyIntMap.hs b/test/Algebra/Graph/Test/AdjacencyIntMap.hs --- a/test/Algebra/Graph/Test/AdjacencyIntMap.hs +++ b/test/Algebra/Graph/Test/AdjacencyIntMap.hs @@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Test.AdjacencyIntMap --- Copyright : (c) Andrey Mokhov 2016-2020 +-- Copyright : (c) Andrey Mokhov 2016-2021 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental @@ -26,7 +26,7 @@ testAdjacencyIntMap :: IO () testAdjacencyIntMap = do putStrLn "\n============ AdjacencyIntMap ============" - test "Axioms of graphs" (axioms @ AdjacencyIntMap) + test "Axioms of graphs" (axioms @AdjacencyIntMap) putStrLn $ "\n============ AdjacencyIntMap.fromAdjacencyMap ============" test "fromAdjacencyMap == stars . AdjacencyMap.adjacencyList" $ \x -> diff --git a/test/Algebra/Graph/Test/AdjacencyMap.hs b/test/Algebra/Graph/Test/AdjacencyMap.hs --- a/test/Algebra/Graph/Test/AdjacencyMap.hs +++ b/test/Algebra/Graph/Test/AdjacencyMap.hs @@ -2,7 +2,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Test.AdjacencyMap --- Copyright : (c) Andrey Mokhov 2016-2020 +-- Copyright : (c) Andrey Mokhov 2016-2021 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental @@ -36,7 +36,7 @@ testAdjacencyMap :: IO () testAdjacencyMap = do putStrLn "\n============ AdjacencyMap ============" - test "Axioms of graphs" (axioms @ AI) + test "Axioms of graphs" (axioms @AI) testConsistent t testShow t diff --git a/test/Algebra/Graph/Test/Arbitrary.hs b/test/Algebra/Graph/Test/Arbitrary.hs --- a/test/Algebra/Graph/Test/Arbitrary.hs +++ b/test/Algebra/Graph/Test/Arbitrary.hs @@ -1,8 +1,9 @@ +{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-orphans #-} ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Test.Arbitrary --- Copyright : (c) Andrey Mokhov 2016-2019 +-- Copyright : (c) Andrey Mokhov 2016-2021 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental @@ -24,21 +25,22 @@ 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.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 +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.Bipartite.AdjacencyMap.Algorithm as BAMA +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 @@ -217,21 +219,6 @@ shrink (LG.Connect e x y) = [LG.Empty, x, y, LG.Connect mempty x y] ++ [LG.Connect e x' y' | (x', y') <- shrink (x, y) ] -instance Arbitrary a => Arbitrary (Tree a) where - arbitrary = sized go - where - go 0 = do - root <- arbitrary - return $ Node root [] - go n = do - subTrees <- choose (0, n - 1) - let subSize = (n - 1) `div` subTrees - root <- arbitrary - children <- replicateM subTrees (go subSize) - return $ Node root children - - shrink (Node r fs) = [Node r fs' | fs' <- shrink fs] - -- TODO: Implement a custom shrink method. instance Arbitrary s => Arbitrary (Doc s) where arbitrary = mconcat . map literal <$> arbitrary @@ -257,3 +244,16 @@ instance (Arbitrary a, Arbitrary b, Ord a, Ord b) => Arbitrary (BAM.AdjacencyMap a b) where arbitrary = BAM.toBipartite <$> arbitrary shrink = map BAM.toBipartite . shrink . BAM.fromBipartite + +instance (Arbitrary a, Arbitrary b) => Arbitrary (BAM.List a b) where + arbitrary = sized go + where + go 0 = return BAM.Nil + go 1 = do h <- arbitrary + return $ BAM.Cons h BAM.Nil + go n = do f <- arbitrary + s <- arbitrary + (BAM.Cons f . BAM.Cons s) <$> go (n - 2) + +instance (Arbitrary a, Arbitrary b, Ord a, Ord b) => Arbitrary (BAMA.Matching a b) where + arbitrary = BAMA.matching <$> arbitrary diff --git a/test/Algebra/Graph/Test/Bipartite/AdjacencyMap.hs b/test/Algebra/Graph/Test/Bipartite/AdjacencyMap.hs new file mode 100644 --- /dev/null +++ b/test/Algebra/Graph/Test/Bipartite/AdjacencyMap.hs @@ -0,0 +1,976 @@ +{-# LANGUAGE OverloadedLists, ViewPatterns #-} +----------------------------------------------------------------------------- +-- | +-- Module : Algebra.Graph.Test.Bipartite.AdjacencyMap +-- Copyright : (c) Andrey Mokhov 2016-2021 +-- 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, + testBipartiteAdjacencyMapAlgorithm + ) where + +import Algebra.Graph.Bipartite.AdjacencyMap +import Algebra.Graph.Bipartite.AdjacencyMap.Algorithm +import Algebra.Graph.Test +import Data.Either +import Data.Either.Extra +import Data.List (nub, sort) +import Data.Map.Strict (Map) +import Data.Set (Set) + +import qualified Algebra.Graph.AdjacencyMap as AM +import qualified Algebra.Graph.Bipartite.AdjacencyMap as B +import qualified Data.Bifunctor as Bifunctor +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set +import qualified Data.Tuple +import qualified Algebra.Graph.Bipartite.AdjacencyMap as B + +type AI = AM.AdjacencyMap Int +type AII = AM.AdjacencyMap (Either Int Int) +type BAII = AdjacencyMap Int Int +type MII = Matching Int Int +type MIC = Matching Int Char +type LII = List Int Int + +testBipartiteAdjacencyMap :: IO () +testBipartiteAdjacencyMap = 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) + rightAdjacencyMap = B.rightAdjacencyMap + leftAdjacencyList :: BAII -> [(Int, [Int])] + leftAdjacencyList = B.leftAdjacencyList + rightAdjacencyList :: BAII -> [(Int, [Int])] + rightAdjacencyList = B.rightAdjacencyList + 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 + 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 + star :: Int -> [Int] -> BAII + star = B.star + stars :: [(Int, [Int])] -> BAII + stars = B.stars + removeLeftVertex :: Int -> BAII -> BAII + removeLeftVertex = B.removeLeftVertex + removeRightVertex :: Int -> BAII -> BAII + removeRightVertex = B.removeRightVertex + removeEdge :: Int -> Int -> BAII -> BAII + removeEdge = B.removeEdge + + putStrLn "\n============ Bipartite.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.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.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 y -> + leftVertex x * leftVertex y == leftVertex x + leftVertex y + test "rightVertex x * rightVertex y == rightVertex x + rightVertex y" $ \x y -> + rightVertex x * rightVertex y == rightVertex x + rightVertex y + + putStrLn "\n============ Bipartite.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.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.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.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.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.AdjacencyMap.vertex ============" + test "vertex . Left == leftVertex" $ \x -> + (vertex . Left) x == leftVertex x + test "vertex . Right == rightVertex" $ \x -> + (vertex . Right) x == rightVertex x + + putStrLn "\n============ Bipartite.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.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.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.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 "vertices xs ys == overlays (map leftVertex xs ++ map rightVertex ys)" $ \xs ys -> + vertices xs ys == overlays (map leftVertex xs ++ map rightVertex ys) + 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.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.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.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.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.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 == uncurry biclique . partitionEithers" $ \xs -> + (toBipartite . AM.clique) xs == (uncurry biclique . partitionEithers) xs + test "toBipartite . fromBipartite == id" $ \x -> + (toBipartite . fromBipartite) x == x + + putStrLn "\n============ Bipartite.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.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)] + + putStrLn "\n============ Bipartite.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 == symmetricClosure . edges" $ \xs -> + (fromBipartiteWith id id . edges) xs == (AM.symmetricClosure . AM.edges) xs + + putStrLn "\n============ Bipartite.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.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.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.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.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.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.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.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.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.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.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.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.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.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.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.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.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.AdjacencyMap.leftAdjacencyList ============" + test "leftAdjacencyList empty == []" $ + leftAdjacencyList empty == [] + test "leftAdjacencyList (vertices [] xs) == []" $ \xs -> + leftAdjacencyList (vertices [] xs) == [] + test "leftAdjacencyList (vertices xs []) == []" $ \xs -> + leftAdjacencyList (vertices xs []) == [(x, []) | x <- nubOrd (sort xs)] + test "leftAdjacencyList (edge x y) == [(x, [y])]" $ \x y -> + leftAdjacencyList (edge x y) == [(x, [y])] + test "leftAdjacencyList (star x ys) == [(x, nub (sort ys))]" $ \x ys -> + leftAdjacencyList (star x ys) == [(x, nubOrd (sort ys))] + + putStrLn "\n============ Bipartite.AdjacencyMap.rightAdjacencyList ============" + test "rightAdjacencyList empty == []" $ + rightAdjacencyList empty == [] + test "rightAdjacencyList (vertices [] xs) == [(x, []) | x <- nub (sort xs)]" $ \xs -> + rightAdjacencyList (vertices [] xs) == [(x, []) | x <- nubOrd (sort xs)] + test "rightAdjacencyList (vertices xs []) == []" $ \xs -> + rightAdjacencyList (vertices xs []) == [] + test "rightAdjacencyList (edge x y) == [(y, [x])]" $ \x y -> + rightAdjacencyList (edge x y) == [(y, [x])] + test "rightAdjacencyList (star x ys) == [(y, [x]) | y <- nub (sort ys)]" $ \x ys -> + rightAdjacencyList (star x ys) == [(y, [x]) | y <- nubOrd (sort ys)] + + putStrLn "\n============ Bipartite.AdjacencyMap.evenList ============" + test "evenList [] == Nil" $ + evenList [] == Nil @Int @Int + test "evenList [(1,2), (3,4)] == [1, 2, 3, 4] :: List Int Int" $ + evenList [(1,2), (3,4)] == ([1, 2, 3, 4] :: List Int Int) + test "evenList [(1,'a'), (2,'b')] == Cons 1 (Cons 'a' (Cons 2 (Cons 'b' Nil)))" $ + evenList [(1,'a'), (2 :: Int,'b')] == Cons 1 (Cons 'a' (Cons 2 (Cons 'b' Nil))) + + putStrLn "\n============ Bipartite.AdjacencyMap.oddList ============" + test "oddList 1 [] == Cons 1 Nil" $ + oddList 1 [] == Cons 1 (Nil @Int @Int) + test "oddList 1 [(2,3), (4,5)] == [1, 2, 3, 4, 5] :: List Int Int" $ + oddList 1 [(2,3), (4,5)] ==([1, 2, 3, 4, 5] :: List Int Int) + test "oddList 1 [('a',2), ('b',3)] == Cons 1 (Cons 'a' (Cons 2 (Cons 'b' (Cons 3 Nil))))" $ + oddList 1 [('a',2), ('b',3)] == Cons 1 (Cons 'a' (Cons 2 (Cons 'b' (Cons @Int 3 Nil)))) + + putStrLn "\n============ Bipartite.AdjacencyMap.path ============" + test "path Nil == empty" $ + path Nil == empty + test "path (Cons x Nil) == leftVertex x" $ \x -> + path (Cons x Nil) == leftVertex x + test "path (Cons x (Cons y Nil)) == edge x y" $ \x y -> + path (Cons x (Cons y Nil)) == edge x y + test "path [1, 2, 3, 4, 5] == edges [(1,2), (3,2), (3,4), (5,4)]" $ + path [1, 2, 3, 4, 5] == edges [(1,2), (3,2), (3,4), (5,4)] + + putStrLn "\n============ Bipartite.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), (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.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.AdjacencyMap.star ============" + test "star x [] == leftVertex x" $ \x -> + star x [] == leftVertex x + test "star x [y] == edge x y" $ \x y -> + star x [y] == edge x y + test "star x [y,z] == edges [(x,y), (x,z)]" $ \x y z -> + star x [y,z] == edges [(x,y), (x,z)] + test "star x ys == connect (leftVertex x) (vertices [] ys)" $ \x ys -> + star x ys == connect (leftVertex x) (vertices [] ys) + + putStrLn "\n============ Bipartite.AdjacencyMap.stars ============" + test "stars [] == empty" $ + stars [] == empty + test "stars [(x, [])] == leftVertex x" $ \x -> + stars [(x, [])] == leftVertex x + test "stars [(x, [y])] == edge x y" $ \x y -> + stars [(x, [y])] == edge x y + test "stars [(x, ys)] == star x ys" $ \x ys -> + stars [(x, ys)] == star x ys + test "star x [y,z] == edges [(x,y), (x,z)]" $ \x y z -> + star x [y,z] == edges [(x,y), (x,z)] + test "stars == overlays . map (uncurry star)" $ \xs -> + stars xs == (overlays . map (uncurry star)) xs + test "overlay (stars xs) (stars ys) == stars (xs ++ ys)" $ \xs ys -> + overlay (stars xs) (stars ys) == stars (xs ++ ys) + + putStrLn "\n============ Bipartite.AdjacencyMap.mesh ============" + test "mesh xs [] == empty" $ \xs -> + mesh xs [] == B.empty @(Int,Int) + test "mesh [] ys == empty" $ \ys -> + mesh [] ys == B.empty @(Int,Int) + test "mesh [x] [y] == leftVertex (x,y)" $ \x y -> + mesh [x] [y] == B.leftVertex @(Int,Int) (x,y) + test "mesh [1,1] ['a','b'] == biclique [(1,'a'), (1,'b')] [(1,'a'), (1,'b')]" $ + mesh [1,1] ['a','b'] == B.biclique @(Int,Char) [(1,'a'), (1,'b')] [(1,'a'), (1,'b')] + test "mesh [1,2] ['a','b'] == biclique [(1,'a'), (2,'b')] [(1,'b'), (2,'a')]" $ + mesh [1,2] ['a','b'] == B.biclique @(Int,Char) [(1,'a'), (2,'b')] [(1,'b'), (2,'a')] + + putStrLn "\n============ Bipartite.AdjacencyMap.removeLeftVertex ============" + test "removeLeftVertex x (leftVertex x) == empty" $ \x -> + removeLeftVertex x (leftVertex x) == empty + test "removeLeftVertex 1 (leftVertex 2) == leftVertex 2" $ + removeLeftVertex 1 (leftVertex 2) ==(leftVertex 2 :: BAII) + test "removeLeftVertex x (rightVertex y) == rightVertex y" $ \x y -> + removeLeftVertex x (rightVertex y) == rightVertex y + test "removeLeftVertex x (edge x y) == rightVertex y" $ \x y -> + removeLeftVertex x (edge x y) == rightVertex y + test "removeLeftVertex x . removeLeftVertex x == removeLeftVertex x" $ \x (g :: BAII)-> + (removeLeftVertex x . removeLeftVertex x) g == removeLeftVertex x g + + putStrLn "\n============ Bipartite.AdjacencyMap.removeRightVertex ============" + test "removeRightVertex x (rightVertex x) == empty" $ \x -> + removeRightVertex x (rightVertex x) == empty + test "removeRightVertex 1 (rightVertex 2) == rightVertex 2" $ + removeRightVertex 1 (rightVertex 2) ==(rightVertex 2 :: BAII) + test "removeRightVertex x (leftVertex y) == leftVertex y" $ \x y -> + removeRightVertex x (leftVertex y) == leftVertex y + test "removeRightVertex y (edge x y) == leftVertex x" $ \x y -> + removeRightVertex y (edge x y) == leftVertex x + test "removeRightVertex x . removeRightVertex x == removeRightVertex x" $ \x (y :: BAII)-> + (removeRightVertex x . removeRightVertex x) y == removeRightVertex x y + + putStrLn "\n============ Bipartite.AdjacencyMap.removeEdge ============" + test "removeEdge x y (edge x y) == vertices [x] [y]" $ \x y -> + removeEdge x y (edge x y) == vertices [x] [y] + test "removeEdge x y . removeEdge x y == removeEdge x y" $ \x y z -> + (removeEdge x y . removeEdge x y) z == removeEdge x y z + test "removeEdge x y . removeLeftVertex x == removeLeftVertex x" $ \x y z -> + (removeEdge x y . removeLeftVertex x) z == removeLeftVertex x z + test "removeEdge x y . removeRightVertex y == removeRightVertex y" $ \x y z -> + (removeEdge x y . removeRightVertex y) z == removeRightVertex y z + + putStrLn "\n============ Bipartite.AdjacencyMap.bimap ============" + test "bimap f g empty == empty" $ \(apply -> f) (apply -> g) -> + bimap f g empty == empty + test "bimap f g . vertex == vertex . Data.Bifunctor.bimap f g" $ \(apply -> f) (apply -> g) x -> + (bimap f g . vertex) x ==(vertex . Bifunctor.bimap f g) x + test "bimap f g (edge x y) == edge (f x) (g y)" $ \(apply -> f) (apply -> g) x y -> + bimap f g (edge x y) == edge (f x) (g y) + test "bimap id id == id" $ \(x :: BAII) -> + bimap id id x == id x + test "bimap f1 g1 . bimap f2 g2 == bimap (f1 . f2) (g1 . g2)" $ \(apply -> f1 :: Int -> Int) (apply -> g1 :: Int -> Int) (apply -> f2 :: Int -> Int) (apply -> g2 :: Int -> Int) x -> + (bimap f1 g1 . bimap f2 g2) x == bimap (f1 . f2) (g1 . g2) x + + putStrLn "\n============ Bipartite.AdjacencyMap.box ============" + test "box (path [0,1]) (path ['a','b']) == " $ + box (path [0,1]) (path ['a','b']) == B.edges @(Int,Char) [ ((0,'a'), (0,'b')) + , ((0,'a'), (1,'a')) + , ((1,'b'), (0,'b')) + , ((1,'b'), (1,'a')) ] + let unit x = (x, ()) + biunit = B.bimap unit unit + comm (x, y) = (y, x) + bicomm = B.bimap comm comm + assoc ((x, y), z) = (x, (y, z)) + biassoc = B.bimap assoc assoc + + putStrLn "" + test "box x y ~~ box y x" $ size10 $ \(x :: BAII) (y :: BAII) -> + box x y == bicomm (box y x) + test "box x (box y z) ~~ box (box x y) z" $ size10 $ \(x :: BAII) (y :: BAII) (z :: BAII) -> + box x (box y z) == biassoc (box (box x y) z) + test "box x (box y z) ~~ box (box x y) z" $ mapSize (min 3) $ \(x :: BAII) (y :: BAII) (z :: BAII) -> + box x (box y z) == biassoc (box (box x y) z) + test "box x (leftVertex ()) ~~ x" $ size10 $ \(x :: BAII) -> + box x (B.leftVertex ()) == biunit x + test "box x (rightVertex ()) ~~ swap x" $ size10 $ \(x :: BAII) -> + box x (B.rightVertex ()) == biunit (B.swap x) + test "box x empty ~~ empty" $ size10 $ \(x :: BAII) -> + box x B.empty == biunit empty + test "vertexCount (box x y) <= vertexCount x * vertexCount y" $ size10 $ \(x :: BAII) (y :: BAII) -> + B.vertexCount (box x y) <= vertexCount x * vertexCount y + test "edgeCount (box x y) <= vertexCount x * edgeCount y + edgeCount x * vertexCount y" $ size10 $ \(x :: BAII) (y :: BAII) -> + B.edgeCount (box x y) <= vertexCount x * edgeCount y + edgeCount x * vertexCount y + + putStrLn "" + test "box == boxWith (,) (,) (,) (,)" $ size10 $ \(x :: BAII) (y :: BAII) -> + box x y == boxWith (,) (,) (,) (,) x y + + putStrLn "\n============ Bipartite.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 (circuit xs) == True" $ \xs -> + consistent (circuit xs) == True + test "consistent (biclique xs ys) == True" $ \xs ys -> + consistent (biclique xs ys) == True + +testBipartiteAdjacencyMapAlgorithm :: IO () +testBipartiteAdjacencyMapAlgorithm = do + putStrLn "\n============ Bipartite.AdjacencyMap.Algorithm.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))) == True + + -- TODO: Clean up these tests + putStrLn "" + 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 (Bifunctor.bimap ((flip Set.isSubsetOf) (vertexSet x) . Set.fromList) (const True) (detectParts x)) == True" $ \(x :: AI) -> + fromEither (Bifunctor.bimap ((flip Set.isSubsetOf) (AM.vertexSet x) . Set.fromList) (const True) (detectParts x)) + test "fromEither (Bifunctor.bimap ((flip Set.isSubsetOf) (edgeSet (symmetricClosure x)) . AM.edgeSet . circuit) (const True) (detectParts x)) == True" $ \(x :: AI) -> + fromEither (Bifunctor.bimap ((flip Set.isSubsetOf) (AM.edgeSet (AM.symmetricClosure x)) . AM.edgeSet . AM.circuit) (const True) (detectParts x)) + test "fromEither (Bifunctor.bimap (((==) 1) . ((flip mod) 2) . length) (const True) (detectParts x)) == True" $ \(x :: AI) -> + fromEither (Bifunctor.bimap (((==) 1) . ((flip mod) 2) . length) (const True) (detectParts x)) + + putStrLn "\n============ Show (Bipartite.AdjacencyMap.Algorithm.Matching a b) ============" + test "show (matching []) == \"matching []\"" $ + show (matching [] :: MII) == "matching []" + test "show (matching [(2,'a'),(1,'b')]) == \"matching [(1,'b'),(2,'a')]\"" $ + show (matching [(2,'a'),(1,'b')] :: MIC) == "matching [(1,'b'),(2,'a')]" + + putStrLn "\n============ Eq (Bipartite.AdjacencyMap.Algorithm.Matching a b) ============" + test "(x == y) == ((pairOfLeft x == pairOfLeft y) && (pairOfRight x == pairOfRight y))" $ \(x :: MII) (y :: MII) -> + (x == y) == ((pairOfLeft x == pairOfLeft y) && (pairOfRight x == pairOfRight y)) + + putStrLn "\n============ Bipartite.AdjacencyMap.Algorithm.pairOfLeft ============" + test "pairOfLeft (matching []) == Map.empty" $ + pairOfLeft (matching [] :: MII) == Map.empty + test "pairOfLeft (matching [(2,'a'), (1,'b')]) == Map.fromList [(2,'a'), (1,'b')]" $ + pairOfLeft (matching [(2,'a'), (1,'b')] :: MIC) == Map.fromList [(2,'a'), (1,'b')] + test "Map.size . pairOfLeft == Map.size . pairOfRight" $ \(x :: MII) -> + (Map.size . pairOfLeft) x ==(Map.size . pairOfRight) x + + putStrLn "\n============ Bipartite.AdjacencyMap.Algorithm.pairOfRight ============" + test "pairOfRight (matching []) == Map.empty" $ + pairOfRight (matching [] :: MII) == Map.empty + test "pairOfRight (matching [(2,'a'), (1,'b')]) == Map.fromList [('a',2), ('b',1)]" $ + pairOfRight (matching [(2,'a'), (1,'b')] :: MIC) == Map.fromList [('a',2), ('b',1)] + test "Map.size . pairOfRight == Map.size . pairOfLeft" $ \(x :: MII) -> + (Map.size . pairOfRight) x ==(Map.size . pairOfLeft) x + + putStrLn "\n============ Bipartite.AdjacencyMap.Algorithm.matching ============" + test "matching [(1,'a'), (1,'b')] == matching [(1,'b')]" $ + matching [(1,'a'), (1,'b')] == (matching [(1,'b')] :: MIC) + test "matching [(1,'a'), (1,'b'), (2,'b'), (2,'a')] == matching [(2,'a')]" $ + matching [(1,'a'), (1,'b'), (2,'b'), (2,'a')] == (matching [(2,'a')] :: MIC) + + putStrLn "\n============ Bipartite.AdjacencyMap.Algorithm.isMatchingOf ============" + test "isMatchingOf (matching []) x == True" $ \(x :: BAII) -> + isMatchingOf (matching []) x == True + test "isMatchingOf (matching xs) empty == null xs" $ \(xs :: [(Int, Int)]) -> + isMatchingOf (matching xs) empty == null xs + test "isMatchingOf (matching [(x,y)]) (edge x y) == True" $ \(x :: Int) (y :: Int) -> + isMatchingOf (matching [(x,y)]) (edge x y) == True + test "isMatchingOf (matching [(1,2)]) (edge 2 1) == False" $ + isMatchingOf (matching [(1,2)]) (edge 2 1 :: BAII) == False + + putStrLn "\n============ Bipartite.AdjacencyMap.Algorithm.matchingSize ============" + test "matchingSize (matching []) == 0" $ + matchingSize (matching [] :: MII) == 0 + test "matchingSize (matching [(2,'a'), (1,'b')]) == 2" $ + matchingSize (matching [(2,'a'), (1,'b')] :: MIC) == 2 + test "matchingSize (matching [(1,'a'), (1,'b')]) == 1" $ + matchingSize (matching [(1,'a'), (1,'b')] :: MIC) == 1 + test "matchingSize (matching xs) <= length xs" $ \(xs :: [(Int, Int)]) -> + matchingSize (matching xs) <= length xs + test "matchingSize x == Map.size . pairOfLeft" $ \(x :: MII) -> + matchingSize x ==(Map.size . pairOfLeft) x + + putStrLn "\n============ Bipartite.AdjacencyMap.Algorithm.maxMatching ============" + test "maxMatching empty == matching []" $ + maxMatching (empty :: BAII) == matching [] + test "maxMatching (vertices xs ys) == matching []" $ \(xs :: [Int]) (ys :: [Int]) -> + maxMatching (vertices xs ys) == matching [] + test "maxMatching (path [1,2,3,4]) == matching [(1,2), (3,4)]" $ + maxMatching (path ([1,2,3,4] :: LII)) == matching [(1,2), (3,4)] + test "matchingSize (maxMatching (circuit [(1,2), (3,4), (5,6)])) == 3" $ + matchingSize (maxMatching (circuit [(1,2), (3,4), (5,6)] :: BAII)) == 3 + test "matchingSize (maxMatching (star x (y:ys))) == 1" $ \(x :: Int) (y :: Int) (ys :: [Int]) -> + matchingSize (maxMatching (star x (y:ys))) == 1 + test "matchingSize (maxMatching (biclique xs ys)) == min (length (nub xs)) (length (nub ys))" $ \(xs :: [Int]) (ys :: [Int]) -> + matchingSize (maxMatching (biclique xs ys)) == min (length (nub xs)) (length (nub ys)) + test "isMatchingOf (maxMatching x) x == True" $ \(x :: BAII) -> + isMatchingOf (maxMatching x) x == True + + putStrLn "\n============ Bipartite.AdjacencyMap.Algorithm.isVertexCoverOf ============" + test "isVertexCoverOf (xs , ys ) empty == Set.null xs && Set.null ys" $ \(xs :: Set Int) (ys :: Set Int) -> + isVertexCoverOf (xs , ys ) empty ==(Set.null xs && Set.null ys) + test "isVertexCoverOf (xs , ys ) (leftVertex x) == Set.isSubsetOf xs (Set.singleton x) && Set.null ys" $ \(x :: Int) (xs :: Set Int) (ys :: Set Int) -> + isVertexCoverOf (xs , ys ) (leftVertex x) ==(Set.isSubsetOf xs (Set.singleton x) && Set.null ys) + test "isVertexCoverOf (Set.empty , Set.empty ) (edge x y) == False" $ \(x :: Int) (y :: Int) -> + isVertexCoverOf (Set.empty , Set.empty ) (edge x y) == False + test "isVertexCoverOf (Set.singleton x, ys ) (edge x y) == Set.isSubsetOf ys (Set.singleton y)" $ \(x :: Int) (y :: Int) (ys :: Set Int) -> + isVertexCoverOf (Set.singleton x, ys ) (edge x y) == Set.isSubsetOf ys (Set.singleton y) + test "isVertexCoverOf (xs , Set.singleton y) (edge x y) == Set.isSubsetOf xs (Set.singleton x)" $ \(x :: Int) (y :: Int) (xs :: Set Int) -> + isVertexCoverOf (xs , Set.singleton y) (edge x y) == Set.isSubsetOf xs (Set.singleton x) + + putStrLn "\n============ Bipartite.AdjacencyMap.Algorithm.minVertexCover ============" + test "minVertexCover empty == (Set.empty, Set.empty)" $ + minVertexCover (empty :: BAII) == (Set.empty, Set.empty) + test "minVertexCover (vertices xs ys) == (Set.empty, Set.empty)" $ \(xs :: [Int]) (ys :: [Int]) -> + minVertexCover (vertices xs ys) == (Set.empty, Set.empty) + test "minVertexCover (path [1,2,3]) == (Set.empty, Set.singleton 2)" $ + minVertexCover (path [1,2,3] :: BAII) == (Set.empty, Set.singleton 2) + test "minVertexCover (star x (1:2:ys)) == (Set.singleton x, Set.empty)" $ \(x :: Int) (ys :: [Int]) -> + minVertexCover (star x (1:2:ys) :: BAII) == (Set.singleton x, Set.empty) + test "vertexCoverSize (minVertexCover (biclique xs ys)) == min (length (nub xs)) (length (nub ys))" $ size10 $ \(xs :: [Int]) (ys :: [Int]) -> + vertexCoverSize (minVertexCover (biclique xs ys)) == min (length (nub xs)) (length (nub ys)) + test "vertexCoverSize . minVertexCover == matchingSize . maxMatching" $ \(x :: BAII) -> + (vertexCoverSize . minVertexCover) x ==(matchingSize . maxMatching) x + test "isVertexCoverOf (minVertexCover x) x == True" $ \(x :: BAII) -> + isVertexCoverOf (minVertexCover x) x == True + + putStrLn "\n============ Bipartite.AdjacencyMap.Algorithm.isIndependentSetOf ============" + test "isIndependentSetOf (xs , ys ) empty == Set.null xs && Set.null ys" $ \(xs :: Set Int) (ys :: Set Int) -> + isIndependentSetOf (xs , ys ) empty ==(Set.null xs && Set.null ys) + test "isIndependentSetOf (xs , ys ) (leftVertex x) == Set.isSubsetOf xs (Set.singleton x) && Set.null ys" $ \(x :: Int) (xs :: Set Int) (ys :: Set Int) -> + isIndependentSetOf (xs , ys ) (leftVertex x) ==(Set.isSubsetOf xs (Set.singleton x) && Set.null ys) + test "isIndependentSetOf (Set.empty , Set.empty ) (edge x y) == True" $ \(x :: Int) (y :: Int) -> + isIndependentSetOf (Set.empty , Set.empty ) (edge x y) == True + test "isIndependentSetOf (Set.singleton x, ys ) (edge x y) == Set.null ys" $ \(x :: Int) (y :: Int) (ys :: Set Int) -> + isIndependentSetOf (Set.singleton x, ys ) (edge x y) == Set.null ys + test "isIndependentSetOf (xs , Set.singleton y) (edge x y) == Set.null xs" $ \(x :: Int) (y :: Int) (xs :: Set Int) -> + isIndependentSetOf (xs , Set.singleton y) (edge x y) == Set.null xs + + putStrLn "\n============ Bipartite.AdjacencyMap.Algorithm.maxIndependentSet ============" + test "maxIndependentSet empty == (Set.empty, Set.empty)" $ + maxIndependentSet (empty :: BAII) == (Set.empty, Set.empty) + test "maxIndependentSet (vertices xs ys) == (Set.fromList xs, Set.fromList ys)" $ \(xs :: [Int]) (ys :: [Int]) -> + maxIndependentSet (vertices xs ys) == (Set.fromList xs, Set.fromList ys) + test "maxIndependentSet (path [1,2,3]) == (Set.fromList [1,3], Set.empty)" $ + maxIndependentSet (path [1,2,3] :: BAII) == (Set.fromList [1,3], Set.empty) + test "maxIndependentSet (star x (1:2:ys)) == (Set.empty, Set.fromList (1:2:ys))" $ \(x :: Int) (ys :: [Int]) -> + maxIndependentSet (star x (1:2:ys)) == (Set.empty, Set.fromList (1:2:ys)) + test "independentSetSize (maxIndependentSet (biclique xs ys)) == max (length (nub xs)) (length (nub ys))" $ \(xs :: [Int]) (ys :: [Int]) -> + independentSetSize (maxIndependentSet (biclique xs ys)) == max (length (nub xs)) (length (nub ys)) + test "independentSetSize (maxIndependentSet x) == vertexCount x - vertexCoverSize (minVertexCover x)" $ \(x :: BAII) -> + independentSetSize (maxIndependentSet x) == vertexCount x - vertexCoverSize (minVertexCover x) + test "isIndependentSetOf (maxIndependentSet x) x == True" $ \(x :: BAII) -> + isIndependentSetOf (maxIndependentSet x) x == True + + putStrLn "\n============ Bipartite.AdjacencyMap.Algorithm.augmentingPath ============" + test "augmentingPath (matching []) empty == Left (Set.empty, Set.empty)" $ + augmentingPath (matching []) (empty :: BAII) == Left (Set.empty, Set.empty) + test "augmentingPath (matching []) (edge 1 2) == Right [1,2]" $ + augmentingPath (matching []) (edge 1 2) == Right ([1,2] :: LII) + test "augmentingPath (matching [(1,2)]) (path [1,2,3]) == Left (Set.empty, Set.singleton 2)" $ + augmentingPath (matching [(1,2)]) (path [1,2,3] :: BAII) == Left (Set.empty, Set.singleton 2) + test "augmentingPath (matching [(3,2)]) (path [1,2,3,4]) == Right [1,2,3,4]" $ + augmentingPath (matching [(3,2)]) (path [1,2,3,4]) == Right ([1,2,3,4] :: LII) + test "isLeft (augmentingPath (maxMatching x) x) == True" $ \(x :: BAII) -> + isLeft (augmentingPath (maxMatching x) x) == True + + putStrLn "\n============ Bipartite.AdjacencyMap.Algorithm.consistentMatching ============" + test "consistentMatching (matching xs) == True" $ \(xs :: [(Int,Int)]) -> + consistentMatching (matching xs) == True + test "consistentMatching (maxMatching x) == True" $ \(x :: BAII) -> + consistentMatching (maxMatching x) == True diff --git a/test/Algebra/Graph/Test/Bipartite/Undirected/AdjacencyMap.hs b/test/Algebra/Graph/Test/Bipartite/Undirected/AdjacencyMap.hs deleted file mode 100644 --- a/test/Algebra/Graph/Test/Bipartite/Undirected/AdjacencyMap.hs +++ /dev/null @@ -1,628 +0,0 @@ -{-# 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/Export.hs b/test/Algebra/Graph/Test/Export.hs --- a/test/Algebra/Graph/Test/Export.hs +++ b/test/Algebra/Graph/Test/Export.hs @@ -2,7 +2,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Test.Export --- Copyright : (c) Andrey Mokhov 2016-2018 +-- Copyright : (c) Andrey Mokhov 2016-2021 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental @@ -18,7 +18,6 @@ import Algebra.Graph.Export hiding (unlines) import Algebra.Graph.Export.Dot (Attribute (..)) import Algebra.Graph.Test -import Data.Semigroup ((<>)) import qualified Algebra.Graph.Export as E import qualified Algebra.Graph.Export.Dot as ED @@ -125,7 +124,8 @@ , ED.defaultEdgeAttributes = mempty , ED.vertexName = \x -> "v" ++ show x , ED.vertexAttributes = \x -> ["color" := "blue" | odd x ] - , ED.edgeAttributes = \x y -> ["style" := "dashed" | odd (x * y)] } + , ED.edgeAttributes = \x y -> ["style" := "dashed" | odd (x * y)] + , ED.attributeQuoting = ED.DoubleQuotes } test "export style (1 * 2 + 3 * 4 * 5 :: Graph Int)" $ (ED.export style (1 * 2 + 3 * 4 * 5 :: Graph Int) :: String) == unlines [ "digraph Example" @@ -142,6 +142,27 @@ , " \"v1\" -> \"v2\"" , " \"v3\" -> \"v4\"" , " \"v3\" -> \"v5\" [style=\"dashed\"]" + , " \"v4\" -> \"v5\"" + , "}" ] + + putStrLn "\n=========== Export.Dot.attributeQuoting ============" + let style' = style { ED.attributeQuoting = ED.NoQuotes } + test "export style' (1 * 2 + 3 * 4 * 5 :: Graph Int)" $ + (ED.export style' (1 * 2 + 3 * 4 * 5 :: Graph Int) :: String) == + unlines [ "digraph Example" + , "{" + , " // This is an example" + , "" + , " graph [label=Example labelloc=top]" + , " node [shape=circle]" + , " \"v1\" [color=blue]" + , " \"v2\"" + , " \"v3\" [color=blue]" + , " \"v4\"" + , " \"v5\" [color=blue]" + , " \"v1\" -> \"v2\"" + , " \"v3\" -> \"v4\"" + , " \"v3\" -> \"v5\" [style=dashed]" , " \"v4\" -> \"v5\"" , "}" ] diff --git a/test/Algebra/Graph/Test/Generic.hs b/test/Algebra/Graph/Test/Generic.hs --- a/test/Algebra/Graph/Test/Generic.hs +++ b/test/Algebra/Graph/Test/Generic.hs @@ -1,8 +1,8 @@ -{-# LANGUAGE RecordWildCards, GADTs, ViewPatterns #-} +{-# LANGUAGE RecordWildCards, ViewPatterns #-} ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Test.Generic --- Copyright : (c) Andrey Mokhov 2016-2019 +-- Copyright : (c) Andrey Mokhov 2016-2021 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental @@ -13,11 +13,13 @@ import Control.Monad (when) import Data.Either -import Data.List as List +import Data.List (nub, sort) import Data.List.NonEmpty (NonEmpty (..)) import Data.Tree import Data.Tuple +import qualified Data.List as List + import Algebra.Graph.Test import Algebra.Graph.Test.API @@ -444,6 +446,9 @@ test "vertices [x] == vertex x" $ \x -> vertices [x] == vertex x + + test "vertices == overlays . map vertex" $ \xs -> + vertices xs ==(overlays . map vertex) xs test "hasVertex x . vertices == elem x" $ \x xs -> (hasVertex x . vertices) xs == elem x xs diff --git a/test/Algebra/Graph/Test/Graph.hs b/test/Algebra/Graph/Test/Graph.hs --- a/test/Algebra/Graph/Test/Graph.hs +++ b/test/Algebra/Graph/Test/Graph.hs @@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Test.Graph --- Copyright : (c) Andrey Mokhov 2016-2020 +-- Copyright : (c) Andrey Mokhov 2016-2021 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental @@ -35,8 +35,8 @@ testGraph :: IO () testGraph = do putStrLn "\n============ Graph ============" - test "Axioms of graphs" (axioms @ G) - test "Theorems of graphs" (theorems @ G) + test "Axioms of graphs" (axioms @G) + test "Theorems of graphs" (theorems @G) testBasicPrimitives t testIsSubgraphOf t diff --git a/test/Algebra/Graph/Test/Internal.hs b/test/Algebra/Graph/Test/Internal.hs --- a/test/Algebra/Graph/Test/Internal.hs +++ b/test/Algebra/Graph/Test/Internal.hs @@ -2,7 +2,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Test.Internal --- Copyright : (c) Andrey Mokhov 2016-2019 +-- Copyright : (c) Andrey Mokhov 2016-2021 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental @@ -16,7 +16,6 @@ import Algebra.Graph.Internal import Algebra.Graph.Test -import Data.Semigroup ((<>)) testInternal :: IO () testInternal = do diff --git a/test/Algebra/Graph/Test/Label.hs b/test/Algebra/Graph/Test/Label.hs --- a/test/Algebra/Graph/Test/Label.hs +++ b/test/Algebra/Graph/Test/Label.hs @@ -2,7 +2,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Test.Label --- Copyright : (c) Andrey Mokhov 2016-2020 +-- Copyright : (c) Andrey Mokhov 2016-2021 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental diff --git a/test/Algebra/Graph/Test/Labelled/AdjacencyMap.hs b/test/Algebra/Graph/Test/Labelled/AdjacencyMap.hs --- a/test/Algebra/Graph/Test/Labelled/AdjacencyMap.hs +++ b/test/Algebra/Graph/Test/Labelled/AdjacencyMap.hs @@ -2,7 +2,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Test.Labelled.AdjacencyMap --- Copyright : (c) Andrey Mokhov 2016-2019 +-- Copyright : (c) Andrey Mokhov 2016-2021 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental @@ -14,7 +14,7 @@ testLabelledAdjacencyMap ) where -import Data.Monoid +import Data.Monoid (Any, Sum (..)) import Algebra.Graph.Label import Algebra.Graph.Labelled.AdjacencyMap diff --git a/test/Algebra/Graph/Test/Labelled/Graph.hs b/test/Algebra/Graph/Test/Labelled/Graph.hs --- a/test/Algebra/Graph/Test/Labelled/Graph.hs +++ b/test/Algebra/Graph/Test/Labelled/Graph.hs @@ -2,7 +2,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Test.Labelled.Graph --- Copyright : (c) Andrey Mokhov 2016-2018 +-- Copyright : (c) Andrey Mokhov 2016-2021 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental @@ -14,7 +14,7 @@ testLabelledGraph ) where -import Data.Monoid +import Data.Monoid (Any, Sum (..)) import Algebra.Graph.Label import Algebra.Graph.Labelled @@ -40,25 +40,6 @@ testLabelledGraph :: IO () testLabelledGraph = do - putStrLn "\n============ Labelled.Graph.foldg ============" - test "foldg empty vertex connect == id" $ \(x :: LAS) -> - foldg empty vertex connect x == id x - - test "foldg empty vertex (fmap flip connect) == transpose" $ \(x :: LAS) -> - foldg empty vertex (fmap flip connect) x == transpose x - - test "foldg 1 (const 1) (const (+)) == size" $ \(x :: LAS) -> - foldg 1 (const 1) (const (+)) x == size x - - test "foldg True (const False) (const (&&)) == isEmpty" $ \(x :: LAS) -> - foldg True (const False) (const (&&)) x == isEmpty x - - test "foldg False (== x) (const (||)) == hasVertex x" $ \x (y :: LAS) -> - foldg False (== x) (const (||)) y == hasVertex x y - - test "foldg Set.empty Set.singleton (const Set.union) == vertexSet" $ \(x :: LAS) -> - foldg Set.empty Set.singleton (const Set.union) x == vertexSet x - testEmpty t testVertex t @@ -139,6 +120,41 @@ testOverlays t + putStrLn "\n============ Labelled.Graph.foldg ============" + test "foldg empty vertex connect == id" $ \(x :: LAS) -> + foldg empty vertex connect x == id x + + test "foldg empty vertex (fmap flip connect) == transpose" $ \(x :: LAS) -> + foldg empty vertex (fmap flip connect) x == transpose x + + test "foldg 1 (const 1) (const (+)) == size" $ \(x :: LAS) -> + foldg 1 (const 1) (const (+)) x == size x + + test "foldg True (const False) (const (&&)) == isEmpty" $ \(x :: LAS) -> + foldg True (const False) (const (&&)) x == isEmpty x + + test "foldg False (== x) (const (||)) == hasVertex x" $ \x (y :: LAS) -> + foldg False (== x) (const (||)) y == hasVertex x y + + test "foldg Set.empty Set.singleton (const Set.union) == vertexSet" $ \(x :: LAS) -> + foldg Set.empty Set.singleton (const Set.union) x == vertexSet x + + putStrLn "\n============ Labelled.Graph.buildg ============" + test "buildg (\\e _ _ -> e) == empty" $ + buildg ( \e _ _ -> e) == (empty :: LAS) + + test "buildg (\\_ v _ -> v x) == vertex x" $ \x -> + buildg ( \_ v _ -> v x) == (vertex x :: LAS) + + test "buildg (\\e v c -> c l (foldg e v c x) (foldg e v c y)) == connect l x y" $ \l (x :: LAS) y -> + buildg ( \e v c -> c l (foldg e v c x) (foldg e v c y)) == connect l x y + + test "buildg (\\e v c -> foldr (c zero) e (map v xs)) == vertices xs" $ \xs -> + buildg ( \e v c -> foldr (c zero) e (map v xs)) == (vertices xs :: LAS) + + test "buildg (\\e v c -> foldg e v (flip c) g) == transpose g" $ \(g :: LAS) -> + buildg ( \e v c -> foldg e v (flip . c) g) == transpose g + putStrLn "\n============ Labelled.Graph.isSubgraphOf ============" test "isSubgraphOf empty x == True" $ \(x :: LAS) -> isSubgraphOf empty x == True @@ -166,6 +182,7 @@ test "isEmpty (removeEdge x y $ edge e x y) == False" $ \(e :: S) (x :: Int) y -> isEmpty (removeEdge x y $ edge e x y) == False + testSize t testHasVertex t putStrLn "\n============ Labelled.Graph.hasEdge ============" diff --git a/test/Algebra/Graph/Test/NonEmpty/AdjacencyMap.hs b/test/Algebra/Graph/Test/NonEmpty/AdjacencyMap.hs --- a/test/Algebra/Graph/Test/NonEmpty/AdjacencyMap.hs +++ b/test/Algebra/Graph/Test/NonEmpty/AdjacencyMap.hs @@ -2,7 +2,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Test.NonEmpty.AdjacencyMap --- Copyright : (c) Andrey Mokhov 2016-2019 +-- Copyright : (c) Andrey Mokhov 2016-2021 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental @@ -15,7 +15,6 @@ ) where import Control.Monad -import Data.Semigroup ((<>)) import Data.Tree import Data.Tuple diff --git a/test/Algebra/Graph/Test/NonEmpty/Graph.hs b/test/Algebra/Graph/Test/NonEmpty/Graph.hs --- a/test/Algebra/Graph/Test/NonEmpty/Graph.hs +++ b/test/Algebra/Graph/Test/NonEmpty/Graph.hs @@ -2,7 +2,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Test.NonEmpty.Graph --- Copyright : (c) Andrey Mokhov 2016-2019 +-- Copyright : (c) Andrey Mokhov 2016-2021 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental @@ -17,7 +17,6 @@ import Control.Monad import Data.Either import Data.Maybe -import Data.Semigroup ((<>)) import Data.Tree import Data.Tuple diff --git a/test/Algebra/Graph/Test/Relation.hs b/test/Algebra/Graph/Test/Relation.hs --- a/test/Algebra/Graph/Test/Relation.hs +++ b/test/Algebra/Graph/Test/Relation.hs @@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Test.Relation --- Copyright : (c) Andrey Mokhov 2016-2020 +-- Copyright : (c) Andrey Mokhov 2016-2021 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental @@ -34,7 +34,7 @@ testRelation :: IO () testRelation = do putStrLn "\n============ Relation ============" - test "Axioms of graphs" $ size10 $ axioms @ RI + test "Axioms of graphs" $ size10 $ axioms @RI testConsistent t testShow t @@ -48,18 +48,18 @@ putStrLn "\n============ ReflexiveRelation ============" test "Axioms of reflexive graphs" $ size10 $ - reflexiveAxioms @ (ReflexiveRelation Int) + reflexiveAxioms @(ReflexiveRelation Int) putStrLn "\n============ TransitiveRelation ============" test "Axioms of transitive graphs" $ size10 $ - transitiveAxioms @ (TransitiveRelation Int) + transitiveAxioms @(TransitiveRelation Int) test "path xs == (clique xs :: TransitiveRelation Int)" $ size10 $ \xs -> C.path xs == (C.clique xs :: TransitiveRelation Int) putStrLn "\n============ PreorderRelation ============" test "Axioms of preorder graphs" $ size10 $ - preorderAxioms @ (PreorderRelation Int) + preorderAxioms @(PreorderRelation Int) test "path xs == (clique xs :: PreorderRelation Int)" $ size10 $ \xs -> C.path xs == (C.clique xs :: PreorderRelation Int) diff --git a/test/Algebra/Graph/Test/Relation/SymmetricRelation.hs b/test/Algebra/Graph/Test/Relation/SymmetricRelation.hs --- a/test/Algebra/Graph/Test/Relation/SymmetricRelation.hs +++ b/test/Algebra/Graph/Test/Relation/SymmetricRelation.hs @@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Test.Relation.SymmetricRelation --- Copyright : (c) Andrey Mokhov 2016-2020 +-- Copyright : (c) Andrey Mokhov 2016-2021 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental @@ -32,7 +32,7 @@ testSymmetricRelation :: IO () testSymmetricRelation = do putStrLn "\n============ Symmetric.Relation ============" - test "Axioms of undirected graphs" $ size10 $ undirectedAxioms @ SRI + test "Axioms of undirected graphs" $ size10 $ undirectedAxioms @SRI testConsistent t testSymmetricShow t @@ -69,4 +69,3 @@ testSymmetricGraphFamilies t testSymmetricTransformations t testInduceJust tPoly - diff --git a/test/Algebra/Graph/Test/RewriteRules.hs b/test/Algebra/Graph/Test/RewriteRules.hs --- a/test/Algebra/Graph/Test/RewriteRules.hs +++ b/test/Algebra/Graph/Test/RewriteRules.hs @@ -1,9 +1,8 @@ -{-# LANGUAGE TemplateHaskell, RankNTypes #-} - +{-# LANGUAGE TemplateHaskell #-} ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Test.RewriteRules --- Copyright : (c) Andrey Mokhov 2016-2018 +-- Copyright : (c) Andrey Mokhov 2016-2021 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental @@ -27,13 +26,14 @@ type Build a = forall b. (a -> b -> b) -> b -> b type Buildg a = forall b. b -> (a -> b) -> (b -> b ->b ) -> (b -> b-> b) -> b --- Naming convention ---- We use: ---- * the suffix "R" to indicate the desired outcome of rewrite rules. ---- * the suffix "C" when testing the "good consumer" property. ---- * the suffix "P" when testing the "good producer" property. ---- * the suffix "I" when testing inlining. ---- * the suffix "T" when testing specialisation for a type +{- We suffix various values using the following convention: + + * "R": the desired outcome of a rewrite rule + * "C": the "good consumer" property + * "P": the "good producer" property + * "I": inlining + * "T": specialisation for a type +-} -- 'foldg' emptyI, emptyIR :: b -> (a -> b) -> (b -> b -> b) -> (b -> b -> b) -> b diff --git a/test/Algebra/Graph/Test/Undirected.hs b/test/Algebra/Graph/Test/Undirected.hs --- a/test/Algebra/Graph/Test/Undirected.hs +++ b/test/Algebra/Graph/Test/Undirected.hs @@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Test.Undirected --- Copyright : (c) Andrey Mokhov 2016-2020 +-- Copyright : (c) Andrey Mokhov 2016-2021 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental @@ -34,7 +34,7 @@ testUndirected :: IO () testUndirected = do putStrLn "\n============ Graph.Undirected ============" - test "Axioms of undirected graphs" $ size10 $ undirectedAxioms @ G + test "Axioms of undirected graphs" $ size10 $ undirectedAxioms @G testSymmetricShow t diff --git a/test/Data/Graph/Test/Typed.hs b/test/Data/Graph/Test/Typed.hs --- a/test/Data/Graph/Test/Typed.hs +++ b/test/Data/Graph/Test/Typed.hs @@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Data.Graph.Test.Typed --- Copyright : (c) Andrey Mokhov 2016-2018 +-- Copyright : (c) Andrey Mokhov 2016-2021 -- License : MIT (see the file LICENSE) -- Maintainer : anfelor@posteo.de, andrey.mokhov@gmail.com -- Stability : experimental @@ -19,7 +19,7 @@ import Data.Array (array) import Data.Graph.Typed import Data.Tree -import Data.List +import Data.List (nub, sort) import qualified Data.Graph as KL import qualified Data.IntSet as IntSet diff --git a/test/Main.hs b/test/Main.hs --- 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.Undirected.AdjacencyMap +import Algebra.Graph.Test.Bipartite.AdjacencyMap import Algebra.Graph.Test.Export import Algebra.Graph.Test.Graph import Algebra.Graph.Test.Internal @@ -29,19 +29,20 @@ 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.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 + go "Acyclic.AdjacencyMap" testAcyclicAdjacencyMap + go "AdjacencyIntMap" testAdjacencyIntMap + go "AdjacencyMap" testAdjacencyMap + go "Bipartite.AdjacencyMap" testBipartiteAdjacencyMap + go "Bipartite.AdjacencyMap.Algorithm" testBipartiteAdjacencyMapAlgorithm + 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