{-# 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 <https://github.com/snowleopard/alga-paper this paper> for
-- the motivation behind the library, the underlying theory, and
-- implementation details.
--
-- This module defines the 'AdjacencyMap' data type 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)
    -- @
    AdjacencyMap a b -> Map a (Set b)
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)
    -- @
    AdjacencyMap a b -> Map b (Set a)
rightAdjacencyMap :: Map b (Set a)
    } deriving (forall x. AdjacencyMap a b -> Rep (AdjacencyMap a b) x)
-> (forall x. Rep (AdjacencyMap a b) x -> AdjacencyMap a b)
-> Generic (AdjacencyMap a b)
forall x. Rep (AdjacencyMap a b) x -> AdjacencyMap a b
forall x. AdjacencyMap a b -> Rep (AdjacencyMap a b) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a b x. Rep (AdjacencyMap a b) x -> AdjacencyMap a b
forall a b x. AdjacencyMap a b -> Rep (AdjacencyMap a b) x
$cto :: forall a b x. Rep (AdjacencyMap a b) x -> AdjacencyMap a b
$cfrom :: forall a b x. AdjacencyMap a b -> Rep (AdjacencyMap a b) x
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 :: Integer -> AdjacencyMap a b
fromInteger = b -> AdjacencyMap a b
forall b a. b -> AdjacencyMap a b
rightVertex (b -> AdjacencyMap a b)
-> (Integer -> b) -> Integer -> AdjacencyMap a b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> b
forall a. Num a => Integer -> a
fromInteger
    + :: AdjacencyMap a b -> AdjacencyMap a b -> AdjacencyMap a b
(+)         = AdjacencyMap a b -> AdjacencyMap a b -> AdjacencyMap a b
forall a b.
(Ord a, Ord b) =>
AdjacencyMap a b -> AdjacencyMap a b -> AdjacencyMap a b
overlay
    * :: AdjacencyMap a b -> AdjacencyMap a b -> AdjacencyMap a b
(*)         = AdjacencyMap a b -> AdjacencyMap a b -> AdjacencyMap a b
forall a b.
(Ord a, Ord b) =>
AdjacencyMap a b -> AdjacencyMap a b -> AdjacencyMap a b
connect
    signum :: AdjacencyMap a b -> AdjacencyMap a b
signum      = AdjacencyMap a b -> AdjacencyMap a b -> AdjacencyMap a b
forall a b. a -> b -> a
const AdjacencyMap a b
forall a b. AdjacencyMap a b
empty
    abs :: AdjacencyMap a b -> AdjacencyMap a b
abs         = AdjacencyMap a b -> AdjacencyMap a b
forall a. a -> a
id
    negate :: AdjacencyMap a b -> AdjacencyMap a b
negate      = AdjacencyMap a b -> AdjacencyMap a b
forall a. a -> a
id

instance (Ord a, Ord b) => Eq (AdjacencyMap a b) where
    BAM Map a (Set b)
lr1 Map b (Set a)
rl1 == :: AdjacencyMap a b -> AdjacencyMap a b -> Bool
== BAM Map a (Set b)
lr2 Map b (Set a)
rl2 = Map a (Set b)
lr1 Map a (Set b) -> Map a (Set b) -> Bool
forall a. Eq a => a -> a -> Bool
== Map a (Set b)
lr2 Bool -> Bool -> Bool
&& Map b (Set a) -> Set b
forall k a. Map k a -> Set k
Map.keysSet Map b (Set a)
rl1 Set b -> Set b -> Bool
forall a. Eq a => a -> a -> Bool
== Map b (Set a) -> Set b
forall k a. Map k a -> Set k
Map.keysSet Map b (Set a)
rl2

instance (Ord a, Ord b) => Ord (AdjacencyMap a b) where
    compare :: AdjacencyMap a b -> AdjacencyMap a b -> Ordering
compare AdjacencyMap a b
x AdjacencyMap a b
y = [Ordering] -> Ordering
forall a. Monoid a => [a] -> a
mconcat
        [ Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (AdjacencyMap a b -> Int
forall a b. AdjacencyMap a b -> Int
vertexCount AdjacencyMap a b
x) (AdjacencyMap a b -> Int
forall a b. AdjacencyMap a b -> Int
vertexCount  AdjacencyMap a b
y)
        , Set (Either a b) -> Set (Either a b) -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (AdjacencyMap a b -> Set (Either a b)
forall a b. (Ord a, Ord b) => AdjacencyMap a b -> Set (Either a b)
vertexSet   AdjacencyMap a b
x) (AdjacencyMap a b -> Set (Either a b)
forall a b. (Ord a, Ord b) => AdjacencyMap a b -> Set (Either a b)
vertexSet    AdjacencyMap a b
y)
        , Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (AdjacencyMap a b -> Int
forall a b. AdjacencyMap a b -> Int
edgeCount   AdjacencyMap a b
x) (AdjacencyMap a b -> Int
forall a b. AdjacencyMap a b -> Int
edgeCount    AdjacencyMap a b
y)
        , Set (a, b) -> Set (a, b) -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (AdjacencyMap a b -> Set (a, b)
forall a b. (Ord a, Ord b) => AdjacencyMap a b -> Set (a, b)
edgeSet     AdjacencyMap a b
x) (AdjacencyMap a b -> Set (a, b)
forall a b. (Ord a, Ord b) => AdjacencyMap a b -> Set (a, b)
edgeSet      AdjacencyMap a b
y) ]

instance (Ord a, Ord b, Show a, Show b) => Show (AdjacencyMap a b) where
    showsPrec :: Int -> AdjacencyMap a b -> ShowS
showsPrec Int
p AdjacencyMap a b
bam
        | [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
lvs Bool -> Bool -> Bool
&& [b] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [b]
rvs             = String -> ShowS
showString String
"empty"
        | [(a, b)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(a, b)]
es                          = Bool -> ShowS -> ShowS
showParen (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ [a] -> [b] -> ShowS
forall a a. (Show a, Show a) => [a] -> [a] -> ShowS
vshow [a]
lvs [b]
rvs
        | ([a]
lvs [a] -> [a] -> Bool
forall a. Eq a => a -> a -> Bool
== [a]
lused) Bool -> Bool -> Bool
&& ([b]
rvs [b] -> [b] -> Bool
forall a. Eq a => a -> a -> Bool
== [b]
rused) = Bool -> ShowS -> ShowS
showParen (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ [(a, b)] -> ShowS
forall a a. (Show a, Show a) => [(a, a)] -> ShowS
eshow [(a, b)]
es
        | Bool
otherwise                        = Bool -> ShowS -> ShowS
showParen (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10)
                                           (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ String -> ShowS
showString String
"overlay ("
                                           ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Either a b] -> ShowS
forall a a. (Show a, Show a) => [Either a a] -> ShowS
veshow ([Either a b]
vs [Either a b] -> [Either a b] -> [Either a b]
forall a. Eq a => [a] -> [a] -> [a]
\\ [Either a b]
used)
                                           ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
") ("
                                           ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(a, b)] -> ShowS
forall a a. (Show a, Show a) => [(a, a)] -> ShowS
eshow [(a, b)]
es
                                           ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
")"
      where
        lvs :: [a]
lvs = AdjacencyMap a b -> [a]
forall a b. AdjacencyMap a b -> [a]
leftVertexList AdjacencyMap a b
bam
        rvs :: [b]
rvs = AdjacencyMap a b -> [b]
forall a b. AdjacencyMap a b -> [b]
rightVertexList AdjacencyMap a b
bam
        vs :: [Either a b]
vs  = AdjacencyMap a b -> [Either a b]
forall a b. AdjacencyMap a b -> [Either a b]
vertexList AdjacencyMap a b
bam
        es :: [(a, b)]
es  = AdjacencyMap a b -> [(a, b)]
forall a b. AdjacencyMap a b -> [(a, b)]
edgeList AdjacencyMap a b
bam
        vshow :: [a] -> [a] -> ShowS
vshow [a
x] [] = String -> ShowS
showString String
"leftVertex " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> a -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 a
x
        vshow [] [a
x] = String -> ShowS
showString String
"rightVertex " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> a -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 a
x
        vshow [a]
xs [a]
ys  = String -> ShowS
showString String
"vertices " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [a] -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 [a]
xs
                     ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
" " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [a] -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 [a]
ys
        veshow :: [Either a a] -> ShowS
veshow [Either a a]
xs      = [a] -> [a] -> ShowS
forall a a. (Show a, Show a) => [a] -> [a] -> ShowS
vshow ([Either a a] -> [a]
forall a b. [Either a b] -> [a]
lefts [Either a a]
xs) ([Either a a] -> [a]
forall a b. [Either a b] -> [b]
rights [Either a a]
xs)
        eshow :: [(a, a)] -> ShowS
eshow [(a
x, a
y)] = String -> ShowS
showString String
"edge " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> a -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 a
x
                       ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
" " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> a -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 a
y
        eshow [(a, a)]
es       = String -> ShowS
showString String
"edges " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [(a, a)] -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 [(a, a)]
es
        lused :: [a]
lused = Set a -> [a]
forall a. Set a -> [a]
Set.toAscList (Set a -> [a]) -> Set a -> [a]
forall a b. (a -> b) -> a -> b
$ [a] -> Set a
forall a. Eq a => [a] -> Set a
Set.fromAscList [ a
u | (a
u, b
_) <- AdjacencyMap a b -> [(a, b)]
forall a b. AdjacencyMap a b -> [(a, b)]
edgeList AdjacencyMap a b
bam ]
        rused :: [b]
rused = Set b -> [b]
forall a. Set a -> [a]
Set.toAscList (Set b -> [b]) -> Set b -> [b]
forall a b. (a -> b) -> a -> b
$ [b] -> Set b
forall a. Ord a => [a] -> Set a
Set.fromList    [ b
v | (a
_, b
v) <- AdjacencyMap a b -> [(a, b)]
forall a b. AdjacencyMap a b -> [(a, b)]
edgeList AdjacencyMap a b
bam ]
        used :: [Either a b]
used  = (a -> Either a b) -> [a] -> [Either a b]
forall a b. (a -> b) -> [a] -> [b]
map a -> Either a b
forall a b. a -> Either a b
Left [a]
lused [Either a b] -> [Either a b] -> [Either a b]
forall a. [a] -> [a] -> [a]
++ (b -> Either a b) -> [b] -> [Either a b]
forall a b. (a -> b) -> [a] -> [b]
map b -> Either a b
forall a b. b -> Either a b
Right [b]
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 :: AdjacencyMap a b
empty = Map a (Set b) -> Map b (Set a) -> AdjacencyMap a b
forall a b. Map a (Set b) -> Map b (Set a) -> AdjacencyMap a b
BAM Map a (Set b)
forall k a. Map k a
Map.empty Map b (Set a)
forall k a. Map k a
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 :: a -> AdjacencyMap a b
leftVertex a
x = Map a (Set b) -> Map b (Set a) -> AdjacencyMap a b
forall a b. Map a (Set b) -> Map b (Set a) -> AdjacencyMap a b
BAM (a -> Set b -> Map a (Set b)
forall k a. k -> a -> Map k a
Map.singleton a
x Set b
forall a. Set a
Set.empty) Map b (Set a)
forall k a. Map k a
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 :: b -> AdjacencyMap a b
rightVertex b
y = Map a (Set b) -> Map b (Set a) -> AdjacencyMap a b
forall a b. Map a (Set b) -> Map b (Set a) -> AdjacencyMap a b
BAM Map a (Set b)
forall k a. Map k a
Map.empty (b -> Set a -> Map b (Set a)
forall k a. k -> a -> Map k a
Map.singleton b
y Set a
forall a. Set a
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 :: Either a b -> AdjacencyMap a b
vertex (Left a
x)  = a -> AdjacencyMap a b
forall a b. a -> AdjacencyMap a b
leftVertex a
x
vertex (Right b
y) = b -> AdjacencyMap a b
forall b a. b -> AdjacencyMap a b
rightVertex b
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 :: a -> b -> AdjacencyMap a b
edge a
x b
y =
    Map a (Set b) -> Map b (Set a) -> AdjacencyMap a b
forall a b. Map a (Set b) -> Map b (Set a) -> AdjacencyMap a b
BAM (a -> Set b -> Map a (Set b)
forall k a. k -> a -> Map k a
Map.singleton a
x (b -> Set b
forall a. a -> Set a
Set.singleton b
y)) (b -> Set a -> Map b (Set a)
forall k a. k -> a -> Map k a
Map.singleton b
y (a -> Set a
forall a. a -> Set a
Set.singleton a
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 :: AdjacencyMap a b -> AdjacencyMap a b -> AdjacencyMap a b
overlay (BAM Map a (Set b)
lr1 Map b (Set a)
rl1) (BAM Map a (Set b)
lr2 Map b (Set a)
rl2) =
    Map a (Set b) -> Map b (Set a) -> AdjacencyMap a b
forall a b. Map a (Set b) -> Map b (Set a) -> AdjacencyMap a b
BAM ((Set b -> Set b -> Set b)
-> Map a (Set b) -> Map a (Set b) -> Map a (Set b)
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith Set b -> Set b -> Set b
forall a. Ord a => Set a -> Set a -> Set a
Set.union Map a (Set b)
lr1 Map a (Set b)
lr2) ((Set a -> Set a -> Set a)
-> Map b (Set a) -> Map b (Set a) -> Map b (Set a)
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith Set a -> Set a -> Set a
forall a. Ord a => Set a -> Set a -> Set a
Set.union Map b (Set a)
rl1 Map b (Set a)
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 :: AdjacencyMap a b -> AdjacencyMap a b -> AdjacencyMap a b
connect (BAM Map a (Set b)
lr1 Map b (Set a)
rl1) (BAM Map a (Set b)
lr2 Map b (Set a)
rl2) = Map a (Set b) -> Map b (Set a) -> AdjacencyMap a b
forall a b. Map a (Set b) -> Map b (Set a) -> AdjacencyMap a b
BAM Map a (Set b)
lr Map b (Set a)
rl
  where
    l1 :: Set a
l1 = Map a (Set b) -> Set a
forall k a. Map k a -> Set k
Map.keysSet Map a (Set b)
lr1
    l2 :: Set a
l2 = Map a (Set b) -> Set a
forall k a. Map k a -> Set k
Map.keysSet Map a (Set b)
lr2
    r1 :: Set b
r1 = Map b (Set a) -> Set b
forall k a. Map k a -> Set k
Map.keysSet Map b (Set a)
rl1
    r2 :: Set b
r2 = Map b (Set a) -> Set b
forall k a. Map k a -> Set k
Map.keysSet Map b (Set a)
rl2
    lr :: Map a (Set b)
lr = (Set b -> Set b -> Set b) -> [Map a (Set b)] -> Map a (Set b)
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
(a -> a -> a) -> f (Map k a) -> Map k a
Map.unionsWith Set b -> Set b -> Set b
forall a. Ord a => Set a -> Set a -> Set a
Set.union
        [ Map a (Set b)
lr1, Map a (Set b)
lr2, (a -> Set b) -> Set a -> Map a (Set b)
forall k a. (k -> a) -> Set k -> Map k a
Map.fromSet (Set b -> a -> Set b
forall a b. a -> b -> a
const Set b
r2) Set a
l1, (a -> Set b) -> Set a -> Map a (Set b)
forall k a. (k -> a) -> Set k -> Map k a
Map.fromSet (Set b -> a -> Set b
forall a b. a -> b -> a
const Set b
r1) Set a
l2 ]
    rl :: Map b (Set a)
rl = (Set a -> Set a -> Set a) -> [Map b (Set a)] -> Map b (Set a)
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
(a -> a -> a) -> f (Map k a) -> Map k a
Map.unionsWith Set a -> Set a -> Set a
forall a. Ord a => Set a -> Set a -> Set a
Set.union
        [ Map b (Set a)
rl1, Map b (Set a)
rl2, (b -> Set a) -> Set b -> Map b (Set a)
forall k a. (k -> a) -> Set k -> Map k a
Map.fromSet (Set a -> b -> Set a
forall a b. a -> b -> a
const Set a
l2) Set b
r1, (b -> Set a) -> Set b -> Map b (Set a)
forall k a. (k -> a) -> Set k -> Map k a
Map.fromSet (Set a -> b -> Set a
forall a b. a -> b -> a
const Set a
l1) Set b
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 :: [a] -> [b] -> AdjacencyMap a b
vertices [a]
ls [b]
rs = Map a (Set b) -> Map b (Set a) -> AdjacencyMap a b
forall a b. Map a (Set b) -> Map b (Set a) -> AdjacencyMap a b
BAM ([(a, Set b)] -> Map a (Set b)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [ (a
l, Set b
forall a. Set a
Set.empty) | a
l <- [a]
ls ])
                     ([(b, Set a)] -> Map b (Set a)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [ (b
r, Set a
forall a. Set a
Set.empty) | b
r <- [b]
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 :: [(a, b)] -> AdjacencyMap a b
edges [(a, b)]
es = Map a (Set b) -> Map b (Set a) -> AdjacencyMap a b
forall a b. Map a (Set b) -> Map b (Set a) -> AdjacencyMap a b
BAM ((Set b -> Set b -> Set b) -> [(a, Set b)] -> Map a (Set b)
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith Set b -> Set b -> Set b
forall a. Ord a => Set a -> Set a -> Set a
Set.union [ (a
x, b -> Set b
forall a. a -> Set a
Set.singleton b
y) | (a
x, b
y) <- [(a, b)]
es ])
               ((Set a -> Set a -> Set a) -> [(b, Set a)] -> Map b (Set a)
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith Set a -> Set a -> Set a
forall a. Ord a => Set a -> Set a -> Set a
Set.union [ (b
y, a -> Set a
forall a. a -> Set a
Set.singleton a
x) | (a
x, b
y) <- [(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 :: [AdjacencyMap a b] -> AdjacencyMap a b
overlays [AdjacencyMap a b]
ams = Map a (Set b) -> Map b (Set a) -> AdjacencyMap a b
forall a b. Map a (Set b) -> Map b (Set a) -> AdjacencyMap a b
BAM ((Set b -> Set b -> Set b) -> [Map a (Set b)] -> Map a (Set b)
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
(a -> a -> a) -> f (Map k a) -> Map k a
Map.unionsWith Set b -> Set b -> Set b
forall a. Ord a => Set a -> Set a -> Set a
Set.union ((AdjacencyMap a b -> Map a (Set b))
-> [AdjacencyMap a b] -> [Map a (Set b)]
forall a b. (a -> b) -> [a] -> [b]
map AdjacencyMap a b -> Map a (Set b)
forall a b. AdjacencyMap a b -> Map a (Set b)
leftAdjacencyMap  [AdjacencyMap a b]
ams))
                   ((Set a -> Set a -> Set a) -> [Map b (Set a)] -> Map b (Set a)
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
(a -> a -> a) -> f (Map k a) -> Map k a
Map.unionsWith Set a -> Set a -> Set a
forall a. Ord a => Set a -> Set a -> Set a
Set.union ((AdjacencyMap a b -> Map b (Set a))
-> [AdjacencyMap a b] -> [Map b (Set a)]
forall a b. (a -> b) -> [a] -> [b]
map AdjacencyMap a b -> Map b (Set a)
forall a b. AdjacencyMap a b -> Map b (Set a)
rightAdjacencyMap [AdjacencyMap a b]
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 :: [AdjacencyMap a b] -> AdjacencyMap a b
connects = (AdjacencyMap a b -> AdjacencyMap a b -> AdjacencyMap a b)
-> AdjacencyMap a b -> [AdjacencyMap a b] -> AdjacencyMap a b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr AdjacencyMap a b -> AdjacencyMap a b -> AdjacencyMap a b
forall a b.
(Ord a, Ord b) =>
AdjacencyMap a b -> AdjacencyMap a b -> AdjacencyMap a b
connect AdjacencyMap a b
forall a b. AdjacencyMap a b
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 :: AdjacencyMap a b -> AdjacencyMap b a
swap (BAM Map a (Set b)
lr Map b (Set a)
rl) = Map b (Set a) -> Map a (Set b) -> AdjacencyMap b a
forall a b. Map a (Set b) -> Map b (Set a) -> AdjacencyMap a b
BAM Map b (Set a)
rl Map a (Set b)
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 :: AdjacencyMap (Either a b) -> AdjacencyMap a b
toBipartite AdjacencyMap (Either a b)
m = Map a (Set b) -> Map b (Set a) -> AdjacencyMap a b
forall a b. Map a (Set b) -> Map b (Set a) -> AdjacencyMap a b
BAM ([(a, Set b)] -> Map a (Set b)
forall k a. Eq k => [(k, a)] -> Map k a
Map.fromAscList [ (a
x, Set (Either a b) -> Set b
forall a. Set (Either a b) -> Set b
setRights Set (Either a b)
ys) | (Left  a
x, Set (Either a b)
ys) <- [(Either a b, Set (Either a b))]
symmetricList ])
                    ([(b, Set a)] -> Map b (Set a)
forall k a. Eq k => [(k, a)] -> Map k a
Map.fromAscList [ (b
x, Set (Either a b) -> Set a
forall b. Set (Either a b) -> Set a
setLefts  Set (Either a b)
ys) | (Right b
x, Set (Either a b)
ys) <- [(Either a b, Set (Either a b))]
symmetricList ])
  where
    setRights :: Set (Either a b) -> Set b
setRights     = [b] -> Set b
forall a. Eq a => [a] -> Set a
Set.fromAscList ([b] -> Set b)
-> (Set (Either a b) -> [b]) -> Set (Either a b) -> Set b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Either a b] -> [b]
forall a b. [Either a b] -> [b]
rights ([Either a b] -> [b])
-> (Set (Either a b) -> [Either a b]) -> Set (Either a b) -> [b]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set (Either a b) -> [Either a b]
forall a. Set a -> [a]
Set.toAscList
    setLefts :: Set (Either a b) -> Set a
setLefts      = [a] -> Set a
forall a. Eq a => [a] -> Set a
Set.fromAscList ([a] -> Set a)
-> (Set (Either a b) -> [a]) -> Set (Either a b) -> Set a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Either a b] -> [a]
forall a b. [Either a b] -> [a]
lefts  ([Either a b] -> [a])
-> (Set (Either a b) -> [Either a b]) -> Set (Either a b) -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set (Either a b) -> [Either a b]
forall a. Set a -> [a]
Set.toAscList
    symmetricList :: [(Either a b, Set (Either a b))]
symmetricList = Map (Either a b) (Set (Either a b))
-> [(Either a b, Set (Either a b))]
forall k a. Map k a -> [(k, a)]
Map.toAscList (Map (Either a b) (Set (Either a b))
 -> [(Either a b, Set (Either a b))])
-> Map (Either a b) (Set (Either a b))
-> [(Either a b, Set (Either a b))]
forall a b. (a -> b) -> a -> b
$ AdjacencyMap (Either a b) -> Map (Either a b) (Set (Either a b))
forall a. AdjacencyMap a -> Map a (Set a)
AM.adjacencyMap (AdjacencyMap (Either a b) -> Map (Either a b) (Set (Either a b)))
-> AdjacencyMap (Either a b) -> Map (Either a b) (Set (Either a b))
forall a b. (a -> b) -> a -> b
$ AdjacencyMap (Either a b) -> AdjacencyMap (Either a b)
forall a. Ord a => AdjacencyMap a -> AdjacencyMap a
AM.symmetricClosure AdjacencyMap (Either a b)
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 :: (a -> Either b c) -> AdjacencyMap a -> AdjacencyMap b c
toBipartiteWith a -> Either b c
f = AdjacencyMap (Either b c) -> AdjacencyMap b c
forall a b.
(Ord a, Ord b) =>
AdjacencyMap (Either a b) -> AdjacencyMap a b
toBipartite (AdjacencyMap (Either b c) -> AdjacencyMap b c)
-> (AdjacencyMap a -> AdjacencyMap (Either b c))
-> AdjacencyMap a
-> AdjacencyMap b c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Either b c) -> AdjacencyMap a -> AdjacencyMap (Either b c)
forall a b.
(Ord a, Ord b) =>
(a -> b) -> AdjacencyMap a -> AdjacencyMap b
AM.gmap a -> Either b c
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 :: AdjacencyMap a b -> AdjacencyMap (Either a b)
fromBipartite (BAM Map a (Set b)
lr Map b (Set a)
rl) = [(Either a b, Set (Either a b))] -> AdjacencyMap (Either a b)
forall a. Ord a => [(a, Set a)] -> AdjacencyMap a
AM.fromAdjacencySets ([(Either a b, Set (Either a b))] -> AdjacencyMap (Either a b))
-> [(Either a b, Set (Either a b))] -> AdjacencyMap (Either a b)
forall a b. (a -> b) -> a -> b
$
    [ (a -> Either a b
forall a b. a -> Either a b
Left  a
x, (b -> Either a b) -> Set b -> Set (Either a b)
forall a b. (a -> b) -> Set a -> Set b
Set.mapMonotonic b -> Either a b
forall a b. b -> Either a b
Right Set b
ys) | (a
x, Set b
ys) <- Map a (Set b) -> [(a, Set b)]
forall k a. Map k a -> [(k, a)]
Map.toAscList Map a (Set b)
lr ] [(Either a b, Set (Either a b))]
-> [(Either a b, Set (Either a b))]
-> [(Either a b, Set (Either a b))]
forall a. [a] -> [a] -> [a]
++
    [ (b -> Either a b
forall a b. b -> Either a b
Right b
y, (a -> Either a b) -> Set a -> Set (Either a b)
forall a b. (a -> b) -> Set a -> Set b
Set.mapMonotonic a -> Either a b
forall a b. a -> Either a b
Left  Set a
xs) | (b
y, Set a
xs) <- Map b (Set a) -> [(b, Set a)]
forall k a. Map k a -> [(k, a)]
Map.toAscList Map b (Set a)
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 :: (a -> c) -> (b -> c) -> AdjacencyMap a b -> AdjacencyMap c
fromBipartiteWith a -> c
f b -> c
g (BAM Map a (Set b)
lr Map b (Set a)
rl) = [(c, Set c)] -> AdjacencyMap c
forall a. Ord a => [(a, Set a)] -> AdjacencyMap a
AM.fromAdjacencySets ([(c, Set c)] -> AdjacencyMap c) -> [(c, Set c)] -> AdjacencyMap c
forall a b. (a -> b) -> a -> b
$
    [ (a -> c
f a
x, (b -> c) -> Set b -> Set c
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map b -> c
g Set b
ys) | (a
x, Set b
ys) <- Map a (Set b) -> [(a, Set b)]
forall k a. Map k a -> [(k, a)]
Map.toAscList Map a (Set b)
lr ] [(c, Set c)] -> [(c, Set c)] -> [(c, Set c)]
forall a. [a] -> [a] -> [a]
++
    [ (b -> c
g b
y, (a -> c) -> Set a -> Set c
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map a -> c
f Set a
xs) | (b
y, Set a
xs) <- Map b (Set a) -> [(b, Set a)]
forall k a. Map k a -> [(k, a)]
Map.toAscList Map b (Set a)
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 :: AdjacencyMap a b -> Bool
isEmpty (BAM Map a (Set b)
lr Map b (Set a)
rl) = Map a (Set b) -> Bool
forall k a. Map k a -> Bool
Map.null Map a (Set b)
lr Bool -> Bool -> Bool
&& Map b (Set a) -> Bool
forall k a. Map k a -> Bool
Map.null Map b (Set a)
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 :: a -> AdjacencyMap a b -> Bool
hasLeftVertex a
x (BAM Map a (Set b)
lr Map b (Set a)
_) = a -> Map a (Set b) -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member a
x Map a (Set b)
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 :: b -> AdjacencyMap a b -> Bool
hasRightVertex b
y (BAM Map a (Set b)
_ Map b (Set a)
rl) = b -> Map b (Set a) -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member b
y Map b (Set a)
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 :: Either a b -> AdjacencyMap a b -> Bool
hasVertex (Left a
x)  = a -> AdjacencyMap a b -> Bool
forall a b. Ord a => a -> AdjacencyMap a b -> Bool
hasLeftVertex a
x
hasVertex (Right b
y) = b -> AdjacencyMap a b -> Bool
forall b a. Ord b => b -> AdjacencyMap a b -> Bool
hasRightVertex b
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 :: a -> b -> AdjacencyMap a b -> Bool
hasEdge a
x b
y (BAM Map a (Set b)
m Map b (Set a)
_) = (b -> Set b -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member b
y (Set b -> Bool) -> Maybe (Set b) -> Maybe Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> Map a (Set b) -> Maybe (Set b)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup a
x Map a (Set b)
m) Maybe Bool -> Maybe Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
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 :: AdjacencyMap a b -> Int
leftVertexCount = Map a (Set b) -> Int
forall k a. Map k a -> Int
Map.size (Map a (Set b) -> Int)
-> (AdjacencyMap a b -> Map a (Set b)) -> AdjacencyMap a b -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AdjacencyMap a b -> Map a (Set b)
forall a b. AdjacencyMap a b -> Map a (Set b)
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 :: AdjacencyMap a b -> Int
rightVertexCount = Map b (Set a) -> Int
forall k a. Map k a -> Int
Map.size (Map b (Set a) -> Int)
-> (AdjacencyMap a b -> Map b (Set a)) -> AdjacencyMap a b -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AdjacencyMap a b -> Map b (Set a)
forall a b. AdjacencyMap a b -> Map b (Set a)
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 :: AdjacencyMap a b -> Int
vertexCount AdjacencyMap a b
g = AdjacencyMap a b -> Int
forall a b. AdjacencyMap a b -> Int
leftVertexCount AdjacencyMap a b
g Int -> Int -> Int
forall a. Num a => a -> a -> a
+ AdjacencyMap a b -> Int
forall a b. AdjacencyMap a b -> Int
rightVertexCount AdjacencyMap a b
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 :: AdjacencyMap a b -> Int
edgeCount = (Set b -> Int -> Int) -> Int -> Map a (Set b) -> Int
forall a b k. (a -> b -> b) -> b -> Map k a -> b
Map.foldr (Int -> Int -> Int
forall a. Num a => a -> a -> a
(+) (Int -> Int -> Int) -> (Set b -> Int) -> Set b -> Int -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set b -> Int
forall a. Set a -> Int
Set.size) Int
0 (Map a (Set b) -> Int)
-> (AdjacencyMap a b -> Map a (Set b)) -> AdjacencyMap a b -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AdjacencyMap a b -> Map a (Set b)
forall a b. AdjacencyMap a b -> Map a (Set b)
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 :: AdjacencyMap a b -> [a]
leftVertexList = Map a (Set b) -> [a]
forall k a. Map k a -> [k]
Map.keys (Map a (Set b) -> [a])
-> (AdjacencyMap a b -> Map a (Set b)) -> AdjacencyMap a b -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AdjacencyMap a b -> Map a (Set b)
forall a b. AdjacencyMap a b -> Map a (Set b)
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 :: AdjacencyMap a b -> [b]
rightVertexList = Map b (Set a) -> [b]
forall k a. Map k a -> [k]
Map.keys (Map b (Set a) -> [b])
-> (AdjacencyMap a b -> Map b (Set a)) -> AdjacencyMap a b -> [b]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AdjacencyMap a b -> Map b (Set a)
forall a b. AdjacencyMap a b -> Map b (Set a)
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 :: AdjacencyMap a b -> [Either a b]
vertexList AdjacencyMap a b
g = (a -> Either a b) -> [a] -> [Either a b]
forall a b. (a -> b) -> [a] -> [b]
map a -> Either a b
forall a b. a -> Either a b
Left (AdjacencyMap a b -> [a]
forall a b. AdjacencyMap a b -> [a]
leftVertexList AdjacencyMap a b
g) [Either a b] -> [Either a b] -> [Either a b]
forall a. [a] -> [a] -> [a]
++ (b -> Either a b) -> [b] -> [Either a b]
forall a b. (a -> b) -> [a] -> [b]
map b -> Either a b
forall a b. b -> Either a b
Right (AdjacencyMap a b -> [b]
forall a b. AdjacencyMap a b -> [b]
rightVertexList AdjacencyMap a b
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 :: AdjacencyMap a b -> [(a, b)]
edgeList (BAM Map a (Set b)
lr Map b (Set a)
_) = [ (a
x, b
y) | (a
x, Set b
ys) <- Map a (Set b) -> [(a, Set b)]
forall k a. Map k a -> [(k, a)]
Map.toAscList Map a (Set b)
lr, b
y <- Set b -> [b]
forall a. Set a -> [a]
Set.toAscList Set b
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 :: AdjacencyMap a b -> Set a
leftVertexSet = Map a (Set b) -> Set a
forall k a. Map k a -> Set k
Map.keysSet (Map a (Set b) -> Set a)
-> (AdjacencyMap a b -> Map a (Set b)) -> AdjacencyMap a b -> Set a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AdjacencyMap a b -> Map a (Set b)
forall a b. AdjacencyMap a b -> Map a (Set b)
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 :: AdjacencyMap a b -> Set b
rightVertexSet = Map b (Set a) -> Set b
forall k a. Map k a -> Set k
Map.keysSet (Map b (Set a) -> Set b)
-> (AdjacencyMap a b -> Map b (Set a)) -> AdjacencyMap a b -> Set b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AdjacencyMap a b -> Map b (Set a)
forall a b. AdjacencyMap a b -> Map b (Set a)
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 :: AdjacencyMap a b -> Set (Either a b)
vertexSet = [Either a b] -> Set (Either a b)
forall a. Eq a => [a] -> Set a
Set.fromAscList ([Either a b] -> Set (Either a b))
-> (AdjacencyMap a b -> [Either a b])
-> AdjacencyMap a b
-> Set (Either a b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AdjacencyMap a b -> [Either a b]
forall a b. AdjacencyMap a b -> [Either a b]
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 :: AdjacencyMap a b -> Set (a, b)
edgeSet = [(a, b)] -> Set (a, b)
forall a. Eq a => [a] -> Set a
Set.fromAscList ([(a, b)] -> Set (a, b))
-> (AdjacencyMap a b -> [(a, b)]) -> AdjacencyMap a b -> Set (a, b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AdjacencyMap a b -> [(a, b)]
forall a b. AdjacencyMap a b -> [(a, b)]
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 :: [(a, b)] -> AdjacencyMap a b
circuit [] = AdjacencyMap a b
forall a b. AdjacencyMap a b
empty
circuit [(a, b)]
xs = [(a, b)] -> AdjacencyMap a b
forall a b. (Ord a, Ord b) => [(a, b)] -> AdjacencyMap a b
edges ([(a, b)] -> AdjacencyMap a b) -> [(a, b)] -> AdjacencyMap a b
forall a b. (a -> b) -> a -> b
$ [(a, b)]
xs [(a, b)] -> [(a, b)] -> [(a, b)]
forall a. [a] -> [a] -> [a]
++ [a] -> [b] -> [(a, b)]
forall a b. [a] -> [b] -> [(a, b)]
zip (Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
drop Int
1 ([a] -> [a]) -> [a] -> [a]
forall a b. (a -> b) -> a -> b
$ [a] -> [a]
forall a. [a] -> [a]
cycle [a]
as) [b]
bs
  where
    ([a]
as, [b]
bs) = [(a, b)] -> ([a], [b])
forall a b. [(a, b)] -> ([a], [b])
unzip [(a, b)]
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 :: [a] -> [b] -> AdjacencyMap a b
biclique [a]
xs [b]
ys = Map a (Set b) -> Map b (Set a) -> AdjacencyMap a b
forall a b. Map a (Set b) -> Map b (Set a) -> AdjacencyMap a b
BAM ((a -> Set b) -> Set a -> Map a (Set b)
forall k a. (k -> a) -> Set k -> Map k a
Map.fromSet (Set b -> a -> Set b
forall a b. a -> b -> a
const Set b
sys) Set a
sxs) ((b -> Set a) -> Set b -> Map b (Set a)
forall k a. (k -> a) -> Set k -> Map k a
Map.fromSet (Set a -> b -> Set a
forall a b. a -> b -> a
const Set a
sxs) Set b
sys)
  where
    sxs :: Set a
sxs = [a] -> Set a
forall a. Ord a => [a] -> Set a
Set.fromList [a]
xs
    sys :: Set b
sys = [b] -> Set b
forall a. Ord a => [a] -> Set a
Set.fromList [b]
ys

data Part = LeftPart | RightPart deriving (Int -> Part -> ShowS
[Part] -> ShowS
Part -> String
(Int -> Part -> ShowS)
-> (Part -> String) -> ([Part] -> ShowS) -> Show Part
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Part] -> ShowS
$cshowList :: [Part] -> ShowS
show :: Part -> String
$cshow :: Part -> String
showsPrec :: Int -> Part -> ShowS
$cshowsPrec :: Int -> Part -> ShowS
Show, Part -> Part -> Bool
(Part -> Part -> Bool) -> (Part -> Part -> Bool) -> Eq Part
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Part -> Part -> Bool
$c/= :: Part -> Part -> Bool
== :: Part -> Part -> Bool
$c== :: Part -> Part -> Bool
Eq)

otherPart :: Part -> Part
otherPart :: Part -> Part
otherPart Part
LeftPart  = Part
RightPart
otherPart Part
RightPart = Part
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 :: AdjacencyMap a -> Either (OddCycle a) (AdjacencyMap a a)
detectParts AdjacencyMap a
x = case State (Map a Part) (Maybe (OddCycle a))
-> Map a Part -> (Maybe (OddCycle a), Map a Part)
forall s a. State s a -> s -> (a, s)
runState (MaybeT (StateT (Map a Part) Identity) (OddCycle a)
-> State (Map a Part) (Maybe (OddCycle a))
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT MaybeT (StateT (Map a Part) Identity) (OddCycle a)
dfs) Map a Part
forall k a. Map k a
Map.empty of
    (Maybe (OddCycle a)
Nothing, Map a Part
m) -> AdjacencyMap a a -> Either (OddCycle a) (AdjacencyMap a a)
forall a b. b -> Either a b
Right (AdjacencyMap a a -> Either (OddCycle a) (AdjacencyMap a a))
-> AdjacencyMap a a -> Either (OddCycle a) (AdjacencyMap a a)
forall a b. (a -> b) -> a -> b
$ (a -> Either a a) -> AdjacencyMap a -> AdjacencyMap a a
forall a b c.
(Ord a, Ord b, Ord c) =>
(a -> Either b c) -> AdjacencyMap a -> AdjacencyMap b c
toBipartiteWith (Map a Part -> a -> Either a a
forall b. Ord b => Map b Part -> b -> Either b b
toEither Map a Part
m) AdjacencyMap a
g
    (Just OddCycle a
c,  Map a Part
_) -> OddCycle a -> Either (OddCycle a) (AdjacencyMap a a)
forall a b. a -> Either a b
Left  (OddCycle a -> Either (OddCycle a) (AdjacencyMap a a))
-> OddCycle a -> Either (OddCycle a) (AdjacencyMap a a)
forall a b. (a -> b) -> a -> b
$ OddCycle a -> OddCycle a
forall a. Eq a => [a] -> [a]
oddCycle OddCycle a
c
  where
    -- g :: AM.AdjacencyMap a
    g :: AdjacencyMap a
g = AdjacencyMap a -> AdjacencyMap a
forall a. Ord a => AdjacencyMap a -> AdjacencyMap a
AM.symmetricClosure AdjacencyMap a
x

    -- type PartMap a = Map a Part
    -- type PartMonad a = MaybeT (State (PartMap a)) [a]
    -- dfs :: PartMonad a
    dfs :: MaybeT (StateT (Map a Part) Identity) (OddCycle a)
dfs = [MaybeT (StateT (Map a Part) Identity) (OddCycle a)]
-> MaybeT (StateT (Map a Part) Identity) (OddCycle a)
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum [ a -> MaybeT (StateT (Map a Part) Identity) (OddCycle a)
processVertex a
v | a
v <- AdjacencyMap a -> OddCycle a
forall a. AdjacencyMap a -> [a]
AM.vertexList AdjacencyMap a
g ]

    -- processVertex :: a -> PartMonad a
    processVertex :: a -> MaybeT (StateT (Map a Part) Identity) (OddCycle a)
processVertex a
v = do Map a Part
m <- MaybeT (StateT (Map a Part) Identity) (Map a Part)
forall s (m :: * -> *). MonadState s m => m s
get
                         Bool -> MaybeT (StateT (Map a Part) Identity) ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (a -> Map a Part -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.notMember a
v Map a Part
m)
                         Part -> a -> MaybeT (StateT (Map a Part) Identity) (OddCycle a)
inVertex Part
LeftPart a
v

    -- inVertex :: Part -> a -> PartMonad a
    inVertex :: Part -> a -> MaybeT (StateT (Map a Part) Identity) (OddCycle a)
inVertex Part
p a
v = ((:) a
v) (OddCycle a -> OddCycle a)
-> MaybeT (StateT (Map a Part) Identity) (OddCycle a)
-> MaybeT (StateT (Map a Part) Identity) (OddCycle a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do (Map a Part -> Map a Part)
-> MaybeT (StateT (Map a Part) Identity) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (a -> Part -> Map a Part -> Map a Part
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert a
v Part
p)
                                  let q :: Part
q = Part -> Part
otherPart Part
p
                                  [MaybeT (StateT (Map a Part) Identity) (OddCycle a)]
-> MaybeT (StateT (Map a Part) Identity) (OddCycle a)
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum [ Part -> a -> MaybeT (StateT (Map a Part) Identity) (OddCycle a)
onEdge Part
q a
u | a
u <- Set a -> OddCycle a
forall a. Set a -> [a]
Set.toAscList (a -> AdjacencyMap a -> Set a
forall a. Ord a => a -> AdjacencyMap a -> Set a
AM.postSet a
v AdjacencyMap a
g) ]

    {-# INLINE onEdge #-}
    -- onEdge :: Part -> a -> PartMonad a
    onEdge :: Part -> a -> MaybeT (StateT (Map a Part) Identity) (OddCycle a)
onEdge Part
p a
v = do Map a Part
m <- MaybeT (StateT (Map a Part) Identity) (Map a Part)
forall s (m :: * -> *). MonadState s m => m s
get
                    case a -> Map a Part -> Maybe Part
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup a
v Map a Part
m of
                        Maybe Part
Nothing -> Part -> a -> MaybeT (StateT (Map a Part) Identity) (OddCycle a)
inVertex Part
p a
v
                        Just Part
q  -> do Bool -> MaybeT (StateT (Map a Part) Identity) ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Part
p Part -> Part -> Bool
forall a. Eq a => a -> a -> Bool
/= Part
q)
                                      OddCycle a -> MaybeT (StateT (Map a Part) Identity) (OddCycle a)
forall (m :: * -> *) a. Monad m => a -> m a
return [a
v]

    -- toEither :: PartMap a -> a -> Either a a
    toEither :: Map b Part -> b -> Either b b
toEither Map b Part
m b
v = case Maybe Part -> Part
forall a. HasCallStack => Maybe a -> a
fromJust (b -> Map b Part -> Maybe Part
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup b
v Map b Part
m) of
                       Part
LeftPart  -> b -> Either b b
forall a b. a -> Either a b
Left  b
v
                       Part
RightPart -> b -> Either b b
forall a b. b -> Either a b
Right b
v

    -- oddCycle :: [a] -> [a]
    oddCycle :: [a] -> [a]
oddCycle [a]
c = [a] -> [a]
forall a. [a] -> [a]
init ([a] -> [a]) -> [a] -> [a]
forall a b. (a -> b) -> a -> b
$ (a -> Bool) -> [a] -> [a]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= [a] -> a
forall a. [a] -> a
last [a]
c) [a]
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 :: AdjacencyMap a b -> Bool
consistent (BAM Map a (Set b)
lr Map b (Set a)
rl) = Map a (Set b) -> [(a, b)]
forall a b. Map a (Set b) -> [(a, b)]
edgeList Map a (Set b)
lr [(a, b)] -> [(a, b)] -> Bool
forall a. Eq a => a -> a -> Bool
== [(a, b)] -> [(a, b)]
forall a. Ord a => [a] -> [a]
sort (((b, a) -> (a, b)) -> [(b, a)] -> [(a, b)]
forall a b. (a -> b) -> [a] -> [b]
map (b, a) -> (a, b)
forall a b. (a, b) -> (b, a)
Data.Tuple.swap ([(b, a)] -> [(a, b)]) -> [(b, a)] -> [(a, b)]
forall a b. (a -> b) -> a -> b
$ Map b (Set a) -> [(b, a)]
forall a b. Map a (Set b) -> [(a, b)]
edgeList Map b (Set a)
rl)
  where
    edgeList :: Map a (Set b) -> [(a, b)]
edgeList Map a (Set b)
lr = [ (a
u, b
v) | (a
u, Set b
vs) <- Map a (Set b) -> [(a, Set b)]
forall k a. Map k a -> [(k, a)]
Map.toAscList Map a (Set b)
lr, b
v <- Set b -> [b]
forall a. Set a -> [a]
Set.toAscList Set b
vs ]