{-# LANGUAGE LambdaCase #-}
----------------------------------------------------------------------------
-- |
-- Module     : Algebra.Graph.Bipartite.AdjacencyMap.Algorithm
-- Copyright  : (c) Andrey Mokhov 2016-2022
-- 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 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.Class (lift)
import Control.Monad.Trans.Maybe (MaybeT(..))
import Control.Monad.Trans.State (State, runState, get, put, 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 (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

-- | 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 :: 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
partMap) -> 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
partMap) 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
partMap <- StateT (Map a Part) Identity (Map a Part)
-> MaybeT (StateT (Map a Part) Identity) (Map a Part)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift StateT (Map a Part) Identity (Map a Part)
forall (m :: * -> *) s. Monad m => StateT s 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
partMap)
                         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
vertexPart a
v = (a
v a -> OddCycle a -> OddCycle a
forall a. a -> [a] -> [a]
:) (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
        StateT (Map a Part) Identity ()
-> MaybeT (StateT (Map a Part) Identity) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT (Map a Part) Identity ()
 -> MaybeT (StateT (Map a Part) Identity) ())
-> StateT (Map a Part) Identity ()
-> MaybeT (StateT (Map a Part) Identity) ()
forall a b. (a -> b) -> a -> b
$ (Map a Part -> Map a Part) -> StateT (Map a Part) Identity ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT 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
vertexPart)
        let otherVertexPart :: Part
otherVertexPart = Part -> Part
otherPart Part
vertexPart
        [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
otherVertexPart 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
vertexPart a
v = do Map a Part
partMap <- StateT (Map a Part) Identity (Map a Part)
-> MaybeT (StateT (Map a Part) Identity) (Map a Part)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift StateT (Map a Part) Identity (Map a Part)
forall (m :: * -> *) s. Monad m => StateT s 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
partMap of
                                 Maybe Part
Nothing   -> Part -> a -> MaybeT (StateT (Map a Part) Identity) (OddCycle a)
inVertex Part
vertexPart a
v
                                 Just Part
part -> do Bool -> MaybeT (StateT (Map a Part) Identity) ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Part
vertexPart Part -> Part -> Bool
forall a. Eq a => a -> a -> Bool
/= Part
part)
                                                 OddCycle a -> MaybeT (StateT (Map a Part) Identity) (OddCycle a)
forall (m :: * -> *) a. Monad m => a -> m a
return [a
v] -- found a cycle!

    -- toEither :: PartMap a -> a -> Either a a
    toEither :: Map b Part -> b -> Either b b
toEither Map b Part
partMap 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
partMap) 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]
pathToCycle = [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
lastVertex) [a]
pathToCycle
      where
        lastVertex :: a
lastVertex = [a] -> a
forall a. [a] -> a
last [a]
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
    -- @
    Matching a b -> Map a b
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
    -- @
    Matching a b -> Map b a
pairOfRight :: Map b a
} deriving (forall x. Matching a b -> Rep (Matching a b) x)
-> (forall x. Rep (Matching a b) x -> Matching a b)
-> Generic (Matching a b)
forall x. Rep (Matching a b) x -> Matching a b
forall x. Matching a b -> Rep (Matching a b) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a b x. Rep (Matching a b) x -> Matching a b
forall a b x. Matching a b -> Rep (Matching a b) x
$cto :: forall a b x. Rep (Matching a b) x -> Matching a b
$cfrom :: forall a b x. Matching a b -> Rep (Matching a b) x
Generic

instance (Show a, Show b) => Show (Matching a b) where
    showsPrec :: Int -> Matching a b -> ShowS
showsPrec Int
_ Matching a b
m = String -> ShowS
showString String
"matching " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(a, b)] -> ShowS
forall a. Show a => [a] -> ShowS
showList (Map a b -> [(a, b)]
forall k a. Map k a -> [(k, a)]
Map.toAscList (Map a b -> [(a, b)]) -> Map a b -> [(a, b)]
forall a b. (a -> b) -> a -> b
$ Matching a b -> Map a b
forall a b. Matching a b -> Map a b
pairOfLeft Matching a b
m)

instance (Eq a, Eq b) => Eq (Matching a b) where
    Matching a b
x == :: Matching a b -> Matching a b -> Bool
== Matching a b
y = Matching a b -> Map a b
forall a b. Matching a b -> Map a b
pairOfLeft Matching a b
x Map a b -> Map a b -> Bool
forall a. Eq a => a -> a -> Bool
== Matching a b -> Map a b
forall a b. Matching a b -> Map a b
pairOfLeft Matching a b
y

instance (Ord a, Ord b) => Ord (Matching a b) where
    compare :: Matching a b -> Matching a b -> Ordering
compare Matching a b
x Matching a b
y = Map a b -> Map a b -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Matching a b -> Map a b
forall a b. Matching a b -> Map a b
pairOfLeft Matching a b
x) (Matching a b -> Map a b
forall a b. Matching a b -> Map a b
pairOfLeft Matching a b
y)

addEdgeUnsafe :: (Ord a, Ord b) => a -> b -> Matching a b -> Matching a b
addEdgeUnsafe :: a -> b -> Matching a b -> Matching a b
addEdgeUnsafe a
a b
b (Matching Map a b
ab Map b a
ba) = Map a b -> Map b a -> Matching a b
forall a b. Map a b -> Map b a -> Matching a b
Matching (a -> b -> Map a b -> Map a b
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert a
a b
b Map a b
ab) (b -> a -> Map b a -> Map b a
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert b
b a
a Map b a
ba)

addEdge :: (Ord a, Ord b) => a -> b -> Matching a b -> Matching a b
addEdge :: a -> b -> Matching a b -> Matching a b
addEdge a
a b
b (Matching Map a b
ab Map b a
ba) = a -> b -> Matching a b -> Matching a b
forall a b.
(Ord a, Ord b) =>
a -> b -> Matching a b -> Matching a b
addEdgeUnsafe a
a b
b (Map a b -> Map b a -> Matching a b
forall a b. Map a b -> Map b a -> Matching a b
Matching Map a b
ab' Map b a
ba')
    where
        ab' :: Map a b
ab' = case b
b b -> Map b a -> Maybe a
forall k a. Ord k => k -> Map k a -> Maybe a
`Map.lookup` Map b a
ba of
                  Maybe a
Nothing -> a -> Map a b -> Map a b
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete a
a Map a b
ab
                  Just a
a' -> a -> Map a b -> Map a b
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete a
a (a -> Map a b -> Map a b
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete a
a' Map a b
ab)
        ba' :: Map b a
ba' = case a
a a -> Map a b -> Maybe b
forall k a. Ord k => k -> Map k a -> Maybe a
`Map.lookup` Map a b
ab of
                  Maybe b
Nothing -> b -> Map b a -> Map b a
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete b
b Map b a
ba
                  Just b
b' -> b -> Map b a -> Map b a
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete b
b (b -> Map b a -> Map b a
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete b
b' Map b a
ba)

leftCovered :: Ord a => a -> Matching a b -> Bool
leftCovered :: a -> Matching a b -> Bool
leftCovered a
a = a -> Map a b -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member a
a (Map a b -> Bool)
-> (Matching a b -> Map a b) -> Matching a b -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Matching a b -> Map a b
forall a b. Matching a b -> Map a b
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 :: [(a, b)] -> Matching a b
matching = (Matching a b -> (a, b) -> Matching a b)
-> Matching a b -> [(a, b)] -> Matching a b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (((a, b) -> Matching a b -> Matching a b)
-> Matching a b -> (a, b) -> Matching a b
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((a -> b -> Matching a b -> Matching a b)
-> (a, b) -> Matching a b -> Matching a b
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry a -> b -> Matching a b -> Matching a b
forall a b.
(Ord a, Ord b) =>
a -> b -> Matching a b -> Matching a b
addEdge)) (Map a b -> Map b a -> Matching a b
forall a b. Map a b -> Map b a -> Matching a b
Matching Map a b
forall k a. Map k a
Map.empty Map b a
forall k a. Map k a
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 :: Matching a b -> AdjacencyMap a b -> Bool
isMatchingOf m :: Matching a b
m@(Matching Map a b
ab Map b a
_) AdjacencyMap a b
g = Matching a b -> Bool
forall a b. (Ord a, Ord b) => Matching a b -> Bool
consistentMatching Matching a b
m
    Bool -> Bool -> Bool
&& [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [ a -> b -> AdjacencyMap a b -> Bool
forall a b. (Ord a, Ord b) => a -> b -> AdjacencyMap a b -> Bool
hasEdge a
a b
b AdjacencyMap a b
g | (a
a, b
b) <- Map a b -> [(a, b)]
forall k a. Map k a -> [(k, a)]
Map.toList Map a b
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 :: Matching a b -> Int
matchingSize = Map a b -> Int
forall k a. Map k a -> Int
Map.size (Map a b -> Int)
-> (Matching a b -> Map a b) -> Matching a b -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Matching a b -> Map a b
forall a b. Matching a b -> Map a b
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 :: AdjacencyMap a b -> Matching a b
maxMatching AdjacencyMap a b
graph = (forall s. ST s (Matching a b)) -> Matching a b
forall a. (forall s. ST s a) -> a
runST (AdjacencyMap a b -> ST s (Matching a b)
forall a b s.
(Ord a, Ord b) =>
AdjacencyMap a b -> ST s (Matching a b)
maxMatchingHK AdjacencyMap a b
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
    { HKState s a b -> STRef s (Map a Int)
distance    :: STRef s (Map a Int)
    , HKState s a b -> STRef s (Matching a b)
curMatching :: STRef s (Matching a b)
    , HKState s a b -> STRef s (Seq a)
queue       :: STRef s (Seq a)
    , HKState s a b -> STRef s (Set 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 :: AdjacencyMap a b -> ST s (Matching a b)
maxMatchingHK AdjacencyMap a b
g = do
    STRef s (Map a Int)
distance    <- Map a Int -> ST s (STRef s (Map a Int))
forall a s. a -> ST s (STRef s a)
newSTRef Map a Int
forall k a. Map k a
Map.empty
    STRef s (Matching a b)
curMatching <- Matching a b -> ST s (STRef s (Matching a b))
forall a s. a -> ST s (STRef s a)
newSTRef (Map a b -> Map b a -> Matching a b
forall a b. Map a b -> Map b a -> Matching a b
Matching Map a b
forall k a. Map k a
Map.empty Map b a
forall k a. Map k a
Map.empty)
    STRef s (Seq a)
queue       <- Seq a -> ST s (STRef s (Seq a))
forall a s. a -> ST s (STRef s a)
newSTRef Seq a
forall a. Seq a
Seq.empty
    STRef s (Set a)
visited     <- Set a -> ST s (STRef s (Set a))
forall a s. a -> ST s (STRef s a)
newSTRef Set a
forall a. Set a
Set.empty
    HKState s a b -> ST s ()
runHK (STRef s (Map a Int)
-> STRef s (Matching a b)
-> STRef s (Seq a)
-> STRef s (Set a)
-> HKState s a b
forall s a b.
STRef s (Map a Int)
-> STRef s (Matching a b)
-> STRef s (Seq a)
-> STRef s (Set a)
-> HKState s a b
HKState STRef s (Map a Int)
distance STRef s (Matching a b)
curMatching STRef s (Seq a)
queue STRef s (Set a)
visited)
    STRef s (Matching a b) -> ST s (Matching a b)
forall s a. STRef s a -> ST s a
readSTRef STRef s (Matching a b)
curMatching
  where
    runHK :: HKState s a b -> ST s ()
    runHK :: HKState s a b -> ST s ()
runHK HKState s a b
state = do STRef s (Map a Int) -> Map a Int -> ST s ()
forall s a. STRef s a -> a -> ST s ()
writeSTRef (HKState s a b -> STRef s (Map a Int)
forall s a b. HKState s a b -> STRef s (Map a Int)
distance HKState s a b
state) Map a Int
forall k a. Map k a
Map.empty
                     Bool
foundAugmentingPath <- HKState s a b -> ST s Bool
bfs HKState s a b
state
                     Bool -> ST s () -> ST s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
foundAugmentingPath (ST s () -> ST s ()) -> ST s () -> ST s ()
forall a b. (a -> b) -> a -> b
$ do
                         STRef s (Set a) -> Set a -> ST s ()
forall s a. STRef s a -> a -> ST s ()
writeSTRef (HKState s a b -> STRef s (Set a)
forall s a b. HKState s a b -> STRef s (Set a)
visited HKState s a b
state) Set a
forall a. Set a
Set.empty
                         HKState s a b -> ST s ()
dfs HKState s a b
state
                         HKState s a b -> ST s ()
runHK HKState s a b
state

    currentlyUncovered :: HKState s a b -> ST s [a]
    currentlyUncovered :: HKState s a b -> ST s [a]
currentlyUncovered HKState s a b
state = do
        Matching a b
m <- STRef s (Matching a b) -> ST s (Matching a b)
forall s a. STRef s a -> ST s a
readSTRef (HKState s a b -> STRef s (Matching a b)
forall s a b. HKState s a b -> STRef s (Matching a b)
curMatching HKState s a b
state)
        [a] -> ST s [a]
forall (m :: * -> *) a. Monad m => a -> m a
return [ a
v | a
v <- AdjacencyMap a b -> [a]
forall a b. AdjacencyMap a b -> [a]
leftVertexList AdjacencyMap a b
g, Bool -> Bool
not (a -> Matching a b -> Bool
forall a b. Ord a => a -> Matching a b -> Bool
leftCovered a
v Matching a b
m) ]


    bfs :: HKState s a b -> ST s Bool
    bfs :: HKState s a b -> ST s Bool
bfs HKState s a b
state = do
        [a]
uncovered <- HKState s a b -> ST s [a]
currentlyUncovered HKState s a b
state
        (a -> ST s ()) -> [a] -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (HKState s a b -> Int -> a -> ST s ()
enqueue HKState s a b
state Int
1) [a]
uncovered
        HKState s a b -> ST s Bool
bfsLoop HKState s a b
state

    enqueue :: HKState s a b -> Int -> a -> ST s ()
    enqueue :: HKState s a b -> Int -> a -> ST s ()
enqueue HKState s a b
state Int
d a
v = do STRef s (Map a Int) -> (Map a Int -> Map a Int) -> ST s ()
forall s a. STRef s a -> (a -> a) -> ST s ()
modifySTRef (HKState s a b -> STRef s (Map a Int)
forall s a b. HKState s a b -> STRef s (Map a Int)
distance HKState s a b
state) (a -> Int -> Map a Int -> Map a Int
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert a
v Int
d)
                           STRef s (Seq a) -> (Seq a -> Seq a) -> ST s ()
forall s a. STRef s a -> (a -> a) -> ST s ()
modifySTRef (HKState s a b -> STRef s (Seq a)
forall s a b. HKState s a b -> STRef s (Seq a)
queue    HKState s a b
state) (Seq a -> a -> Seq a
forall a. Seq a -> a -> Seq a
|> a
v)

    dequeue :: HKState s a b -> ST s (Maybe a)
    dequeue :: HKState s a b -> ST s (Maybe a)
dequeue HKState s a b
state = do Seq a
q <- STRef s (Seq a) -> ST s (Seq a)
forall s a. STRef s a -> ST s a
readSTRef (HKState s a b -> STRef s (Seq a)
forall s a b. HKState s a b -> STRef s (Seq a)
queue HKState s a b
state)
                       case Seq a -> ViewL a
forall a. Seq a -> ViewL a
Seq.viewl Seq a
q of
                           a
a :< Seq a
q -> STRef s (Seq a) -> Seq a -> ST s ()
forall s a. STRef s a -> a -> ST s ()
writeSTRef (HKState s a b -> STRef s (Seq a)
forall s a b. HKState s a b -> STRef s (Seq a)
queue HKState s a b
state) Seq a
q ST s () -> Maybe a -> ST s (Maybe a)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> a -> Maybe a
forall a. a -> Maybe a
Just a
a
                           ViewL a
EmptyL -> Maybe a -> ST s (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing

    bfsLoop :: HKState s a b -> ST s Bool
    bfsLoop :: HKState s a b -> ST s Bool
bfsLoop HKState s a b
state = HKState s a b -> ST s (Maybe a)
dequeue HKState s a b
state ST s (Maybe a) -> (Maybe a -> ST s Bool) -> ST s Bool
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                        Just a
v  -> do Bool
p <- HKState s a b -> a -> ST s Bool
bfsVertex HKState s a b
state a
v
                                      Bool
q <- HKState s a b -> ST s Bool
bfsLoop HKState s a b
state
                                      Bool -> ST s Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
p Bool -> Bool -> Bool
|| Bool
q)
                        Maybe a
Nothing -> Bool -> ST s Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

    bfsVertex :: HKState s a b -> a -> ST s Bool
    bfsVertex :: HKState s a b -> a -> ST s Bool
bfsVertex HKState s a b
state a
v = do Map a Int
dist <- STRef s (Map a Int) -> ST s (Map a Int)
forall s a. STRef s a -> ST s a
readSTRef (HKState s a b -> STRef s (Map a Int)
forall s a b. HKState s a b -> STRef s (Map a Int)
distance HKState s a b
state)
                           let d :: Int
d = Maybe Int -> Int
forall a. HasCallStack => Maybe a -> a
fromJust (a
v a -> Map a Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
`Map.lookup` Map a Int
dist) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
                           [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or ([Bool] -> Bool) -> ST s [Bool] -> ST s Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (b -> ST s Bool) -> [b] -> ST s [Bool]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (HKState s a b -> Int -> b -> ST s Bool
bfsEdge HKState s a b
state Int
d) (a -> [b]
neighbours a
v)

    checkEnqueue :: HKState s a b -> Int -> a -> ST s ()
    checkEnqueue :: HKState s a b -> Int -> a -> ST s ()
checkEnqueue HKState s a b
state Int
d a
v = do Map a Int
dist <- STRef s (Map a Int) -> ST s (Map a Int)
forall s a. STRef s a -> ST s a
readSTRef (HKState s a b -> STRef s (Map a Int)
forall s a b. HKState s a b -> STRef s (Map a Int)
distance HKState s a b
state)
                                Bool -> ST s () -> ST s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (a
v a -> Map a Int -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`Map.notMember` Map a Int
dist) (HKState s a b -> Int -> a -> ST s ()
enqueue HKState s a b
state Int
d a
v)

    bfsEdge :: HKState s a b -> Int -> b -> ST s Bool
    bfsEdge :: HKState s a b -> Int -> b -> ST s Bool
bfsEdge HKState s a b
state Int
d b
u = do Matching a b
m <- STRef s (Matching a b) -> ST s (Matching a b)
forall s a. STRef s a -> ST s a
readSTRef (HKState s a b -> STRef s (Matching a b)
forall s a b. HKState s a b -> STRef s (Matching a b)
curMatching HKState s a b
state)
                           case b
u b -> Map b a -> Maybe a
forall k a. Ord k => k -> Map k a -> Maybe a
`Map.lookup` Matching a b -> Map b a
forall a b. Matching a b -> Map b a
pairOfRight Matching a b
m of
                               Just a
v  -> HKState s a b -> Int -> a -> ST s ()
checkEnqueue HKState s a b
state Int
d a
v ST s () -> Bool -> ST s Bool
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Bool
False
                               Maybe a
Nothing -> Bool -> ST s Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

    dfs :: HKState s a b -> ST s ()
    dfs :: HKState s a b -> ST s ()
dfs HKState s a b
state = HKState s a b -> ST s [a]
currentlyUncovered HKState s a b
state ST s [a] -> ([a] -> ST s ()) -> ST s ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (a -> ST s Bool) -> [a] -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (HKState s a b -> Int -> a -> ST s Bool
dfsVertex HKState s a b
state Int
0)

    dfsVertex :: HKState s a b -> Int -> a -> ST s Bool
    dfsVertex :: HKState s a b -> Int -> a -> ST s Bool
dfsVertex HKState s a b
state Int
d a
v = do Map a Int
dist <- STRef s (Map a Int) -> ST s (Map a Int)
forall s a. STRef s a -> ST s a
readSTRef (HKState s a b -> STRef s (Map a Int)
forall s a b. HKState s a b -> STRef s (Map a Int)
distance HKState s a b
state)
                             Set a
vis  <- STRef s (Set a) -> ST s (Set a)
forall s a. STRef s a -> ST s a
readSTRef (HKState s a b -> STRef s (Set a)
forall s a b. HKState s a b -> STRef s (Set a)
visited HKState s a b
state)
                             let dv :: Int
dv = Maybe Int -> Int
forall a. HasCallStack => Maybe a -> a
fromJust (a
v a -> Map a Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
`Map.lookup` Map a Int
dist)
                             case (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
dv) Bool -> Bool -> Bool
&& (a
v a -> Set a -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set a
vis) of
                                 Bool
False -> Bool -> ST s Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
                                 Bool
True  -> do STRef s (Set a) -> (Set a -> Set a) -> ST s ()
forall s a. STRef s a -> (a -> a) -> ST s ()
modifySTRef (HKState s a b -> STRef s (Set a)
forall s a b. HKState s a b -> STRef s (Set a)
visited HKState s a b
state) (a -> Set a -> Set a
forall a. Ord a => a -> Set a -> Set a
Set.insert a
v)
                                             HKState s a b -> Int -> a -> [b] -> ST s Bool
dfsEdges HKState s a b
state Int
dv a
v (a -> [b]
neighbours a
v)

    dfsEdges :: HKState s a b -> Int -> a -> [b] -> ST s Bool
    dfsEdges :: HKState s a b -> Int -> a -> [b] -> ST s Bool
dfsEdges HKState s a b
_     Int
_ a
_ []     = Bool -> ST s Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    dfsEdges HKState s a b
state Int
d a
a (b
b:[b]
bs) = do Matching a b
m <- STRef s (Matching a b) -> ST s (Matching a b)
forall s a. STRef s a -> ST s a
readSTRef (HKState s a b -> STRef s (Matching a b)
forall s a b. HKState s a b -> STRef s (Matching a b)
curMatching HKState s a b
state)
                                   case b
b b -> Map b a -> Maybe a
forall k a. Ord k => k -> Map k a -> Maybe a
`Map.lookup` Matching a b -> Map b a
forall a b. Matching a b -> Map b a
pairOfRight Matching a b
m of
                                       Maybe a
Nothing -> HKState s a b -> a -> b -> ST s ()
addEdge HKState s a b
state a
a b
b ST s () -> Bool -> ST s Bool
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Bool
True
                                       Just a
w  -> HKState s a b -> Int -> a -> ST s Bool
dfsVertex HKState s a b
state Int
d a
w ST s Bool -> (Bool -> ST s Bool) -> ST s Bool
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                                            Bool
True  -> HKState s a b -> a -> b -> ST s ()
addEdge HKState s a b
state a
a b
b ST s () -> Bool -> ST s Bool
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Bool
True
                                            Bool
False -> HKState s a b -> Int -> a -> [b] -> ST s Bool
dfsEdges HKState s a b
state Int
d a
a [b]
bs

    addEdge :: HKState s a b -> a -> b -> ST s ()
    addEdge :: HKState s a b -> a -> b -> ST s ()
addEdge HKState s a b
state a
a b
b = STRef s (Matching a b) -> (Matching a b -> Matching a b) -> ST s ()
forall s a. STRef s a -> (a -> a) -> ST s ()
modifySTRef (HKState s a b -> STRef s (Matching a b)
forall s a b. HKState s a b -> STRef s (Matching a b)
curMatching HKState s a b
state) (a -> b -> Matching a b -> Matching a b
forall a b.
(Ord a, Ord b) =>
a -> b -> Matching a b -> Matching a b
addEdgeUnsafe a
a b
b)

    neighbours :: a -> [b]
    neighbours :: a -> [b]
neighbours a
a = Set b -> [b]
forall a. Set a -> [a]
Set.toAscList (Set b -> [b]) -> Set b -> [b]
forall a b. (a -> b) -> a -> b
$ Maybe (Set b) -> Set b
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe (Set b) -> Set b) -> Maybe (Set b) -> Set b
forall a b. (a -> b) -> a -> b
$ a -> Map a (Set b) -> Maybe (Set b)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup a
a (Map a (Set b) -> Maybe (Set b)) -> Map a (Set b) -> Maybe (Set b)
forall a b. (a -> b) -> a -> b
$ AdjacencyMap a b -> Map a (Set b)
forall a b. AdjacencyMap a b -> Map a (Set b)
leftAdjacencyMap AdjacencyMap a b
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 :: (Set a, Set b) -> AdjacencyMap a b -> Bool
isVertexCoverOf (Set a
as, Set b
bs) AdjacencyMap a b
g = Set a
as Set a -> Set a -> Bool
forall a. Ord a => Set a -> Set a -> Bool
`Set.isSubsetOf` AdjacencyMap a b -> Set a
forall a b. AdjacencyMap a b -> Set a
leftVertexSet AdjacencyMap a b
g
    Bool -> Bool -> Bool
&& Set b
bs Set b -> Set b -> Bool
forall a. Ord a => Set a -> Set a -> Bool
`Set.isSubsetOf` AdjacencyMap a b -> Set b
forall a b. AdjacencyMap a b -> Set b
rightVertexSet AdjacencyMap a b
g
    Bool -> Bool -> Bool
&& [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [ a
a a -> Set a -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set a
as Bool -> Bool -> Bool
|| b
b b -> Set b -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set b
bs | (a
a, b
b) <- AdjacencyMap a b -> [(a, b)]
forall a b. AdjacencyMap a b -> [(a, b)]
edgeList AdjacencyMap a b
g ]

-- | The number of vertices in a vertex cover.
-- Complexity: /O(1)/ time.
vertexCoverSize :: VertexCover a b -> Int
vertexCoverSize :: VertexCover a b -> Int
vertexCoverSize (Set a
as, Set b
bs) = Set a -> Int
forall a. Set a -> Int
Set.size Set a
as Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Set b -> Int
forall a. Set a -> Int
Set.size Set b
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 :: AdjacencyMap a b -> VertexCover a b
minVertexCover AdjacencyMap a b
g = VertexCover a b
-> Either (VertexCover a b) (List a b) -> VertexCover a b
forall a b. a -> Either a b -> a
fromLeft VertexCover a b
forall a. a
panic (Either (VertexCover a b) (List a b) -> VertexCover a b)
-> Either (VertexCover a b) (List a b) -> VertexCover a b
forall a b. (a -> b) -> a -> b
$ Matching a b
-> AdjacencyMap a b -> Either (VertexCover a b) (List a b)
forall a b.
(Ord a, Ord b) =>
Matching a b
-> AdjacencyMap a b -> Either (VertexCover a b) (List a b)
augmentingPath (AdjacencyMap a b -> Matching a b
forall a b. (Ord a, Ord b) => AdjacencyMap a b -> Matching a b
maxMatching AdjacencyMap a b
g) AdjacencyMap a b
g
  where
    panic :: a
panic = String -> a
forall a. HasCallStack => String -> a
error String
"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 :: (Set a, Set b) -> AdjacencyMap a b -> Bool
isIndependentSetOf (Set a
as, Set b
bs) AdjacencyMap a b
g = Set a
as Set a -> Set a -> Bool
forall a. Ord a => Set a -> Set a -> Bool
`Set.isSubsetOf` AdjacencyMap a b -> Set a
forall a b. AdjacencyMap a b -> Set a
leftVertexSet AdjacencyMap a b
g
    Bool -> Bool -> Bool
&& Set b
bs Set b -> Set b -> Bool
forall a. Ord a => Set a -> Set a -> Bool
`Set.isSubsetOf` AdjacencyMap a b -> Set b
forall a b. AdjacencyMap a b -> Set b
rightVertexSet AdjacencyMap a b
g
    Bool -> Bool -> Bool
&& [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [ Bool -> Bool
not (a
a a -> Set a -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set a
as Bool -> Bool -> Bool
&& b
b b -> Set b -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set b
bs) | (a
a, b
b) <- AdjacencyMap a b -> [(a, b)]
forall a b. AdjacencyMap a b -> [(a, b)]
edgeList AdjacencyMap a b
g ]

-- | The number of vertices in an independent set.
-- Complexity: /O(1)/ time.
independentSetSize :: IndependentSet a b -> Int
independentSetSize :: IndependentSet a b -> Int
independentSetSize (Set a
as, Set b
bs) = Set a -> Int
forall a. Set a -> Int
Set.size Set a
as Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Set b -> Int
forall a. Set a -> Int
Set.size Set b
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 :: AdjacencyMap a b -> IndependentSet a b
maxIndependentSet AdjacencyMap a b
g =
    (AdjacencyMap a b -> Set a
forall a b. AdjacencyMap a b -> Set a
leftVertexSet AdjacencyMap a b
g Set a -> Set a -> Set a
forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Set a
as, AdjacencyMap a b -> Set b
forall a b. AdjacencyMap a b -> Set b
rightVertexSet AdjacencyMap a b
g Set b -> Set b -> Set b
forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Set b
bs)
  where
    (Set a
as, Set b
bs) = AdjacencyMap a b -> IndependentSet a b
forall a b. (Ord a, Ord b) => AdjacencyMap a b -> VertexCover a b
minVertexCover AdjacencyMap a b
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 :: Matching a b
-> AdjacencyMap a b -> Either (VertexCover a b) (List a b)
augmentingPath = Matching a b
-> AdjacencyMap a b -> Either (VertexCover a b) (List a b)
forall a b.
(Ord a, Ord b) =>
Matching a b
-> AdjacencyMap a b -> Either (VertexCover a b) (List a b)
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 :: Matching a b
-> AdjacencyMap a b -> Either (VertexCover a b) (List a b)
augmentingPathImpl Matching a b
m AdjacencyMap a b
g = case State (VertexCover a b) (Maybe (List a b))
-> VertexCover a b -> (Maybe (List a b), VertexCover a b)
forall s a. State s a -> s -> (a, s)
runState (MaybeT (State (VertexCover a b)) (List a b)
-> State (VertexCover a b) (Maybe (List a b))
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT MaybeT (State (VertexCover a b)) (List a b)
dfs) (AdjacencyMap a b -> Set a
forall a b. AdjacencyMap a b -> Set a
leftVertexSet AdjacencyMap a b
g, Set b
forall a. Set a
Set.empty) of
    (Maybe (List a b)
Nothing  , VertexCover a b
cover) -> VertexCover a b -> Either (VertexCover a b) (List a b)
forall a b. a -> Either a b
Left VertexCover a b
cover
    (Just List a b
path, VertexCover a b
_    ) -> List a b -> Either (VertexCover a b) (List a b)
forall a b. b -> Either a b
Right List a b
path
  where
    dfs :: AugPathMonad a b
    dfs :: MaybeT (State (VertexCover a b)) (List a b)
dfs = [MaybeT (State (VertexCover a b)) (List a b)]
-> MaybeT (State (VertexCover a b)) (List a b)
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum [ a -> MaybeT (State (VertexCover a b)) (List a b)
inVertex a
v | a
v <- AdjacencyMap a b -> [a]
forall a b. AdjacencyMap a b -> [a]
leftVertexList AdjacencyMap a b
g, Bool -> Bool
not (a -> Matching a b -> Bool
forall a b. Ord a => a -> Matching a b -> Bool
leftCovered a
v Matching a b
m) ]

    inVertex :: a -> AugPathMonad a b
    inVertex :: a -> MaybeT (State (VertexCover a b)) (List a b)
inVertex a
a = do (Set a
as, Set b
bs) <- StateT (VertexCover a b) Identity (VertexCover a b)
-> MaybeT (State (VertexCover a b)) (VertexCover a b)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift StateT (VertexCover a b) Identity (VertexCover a b)
forall (m :: * -> *) s. Monad m => StateT s m s
get
                    Bool -> MaybeT (State (VertexCover a b)) ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (a
a a -> Set a -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set a
as)
                    StateT (VertexCover a b) Identity ()
-> MaybeT (State (VertexCover a b)) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT (VertexCover a b) Identity ()
 -> MaybeT (State (VertexCover a b)) ())
-> StateT (VertexCover a b) Identity ()
-> MaybeT (State (VertexCover a b)) ()
forall a b. (a -> b) -> a -> b
$ VertexCover a b -> StateT (VertexCover a b) Identity ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put (a -> Set a -> Set a
forall a. Ord a => a -> Set a -> Set a
Set.delete a
a Set a
as, Set b
bs)
                    [MaybeT (State (VertexCover a b)) (List a b)]
-> MaybeT (State (VertexCover a b)) (List a b)
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum [ a -> b -> MaybeT (State (VertexCover a b)) (List a b)
onEdge a
a b
b | b
b <- a -> [b]
neighbours a
a ]

    onEdge :: a -> b -> AugPathMonad a b
    onEdge :: a -> b -> MaybeT (State (VertexCover a b)) (List a b)
onEdge a
a b
b = a -> b -> List a b -> List a b
addEdge a
a b
b (List a b -> List a b)
-> MaybeT (State (VertexCover a b)) (List a b)
-> MaybeT (State (VertexCover a b)) (List a b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do (Set a
as, Set b
bs) <- StateT (VertexCover a b) Identity (VertexCover a b)
-> MaybeT (State (VertexCover a b)) (VertexCover a b)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift StateT (VertexCover a b) Identity (VertexCover a b)
forall (m :: * -> *) s. Monad m => StateT s m s
get
                                    StateT (VertexCover a b) Identity ()
-> MaybeT (State (VertexCover a b)) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT (VertexCover a b) Identity ()
 -> MaybeT (State (VertexCover a b)) ())
-> StateT (VertexCover a b) Identity ()
-> MaybeT (State (VertexCover a b)) ()
forall a b. (a -> b) -> a -> b
$ VertexCover a b -> StateT (VertexCover a b) Identity ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put (Set a
as, b -> Set b -> Set b
forall a. Ord a => a -> Set a -> Set a
Set.insert b
b Set b
bs)
                                    case b
b b -> Map b a -> Maybe a
forall k a. Ord k => k -> Map k a -> Maybe a
`Map.lookup` Matching a b -> Map b a
forall a b. Matching a b -> Map b a
pairOfRight Matching a b
m of
                                        Just a
a  -> a -> MaybeT (State (VertexCover a b)) (List a b)
inVertex a
a
                                        Maybe a
Nothing -> List a b -> MaybeT (State (VertexCover a b)) (List a b)
forall (m :: * -> *) a. Monad m => a -> m a
return List a b
forall a b. List a b
Nil

    addEdge :: a -> b -> List a b -> List a b
    addEdge :: a -> b -> List a b -> List a b
addEdge a
a b
b = a -> List b a -> List a b
forall a b. a -> List b a -> List a b
Cons a
a (List b a -> List a b)
-> (List a b -> List b a) -> List a b -> List a b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> List a b -> List b a
forall a b. a -> List b a -> List a b
Cons b
b

    neighbours :: a -> [b]
    neighbours :: a -> [b]
neighbours a
a = Set b -> [b]
forall a. Set a -> [a]
Set.toAscList (Set b -> [b]) -> Set b -> [b]
forall a b. (a -> b) -> a -> b
$ Maybe (Set b) -> Set b
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe (Set b) -> Set b) -> Maybe (Set b) -> Set b
forall a b. (a -> b) -> a -> b
$ a -> Map a (Set b) -> Maybe (Set b)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup a
a (Map a (Set b) -> Maybe (Set b)) -> Map a (Set b) -> Maybe (Set b)
forall a b. (a -> b) -> a -> b
$ AdjacencyMap a b -> Map a (Set b)
forall a b. AdjacencyMap a b -> Map a (Set b)
leftAdjacencyMap AdjacencyMap a b
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 a b -> Bool
consistentMatching (Matching Map a b
ab Map b a
ba) =
    Map a b -> [(a, b)]
forall k a. Map k a -> [(k, a)]
Map.toAscList Map a b
ab [(a, b)] -> [(a, b)] -> Bool
forall a. Eq a => a -> a -> Bool
== [(a, b)] -> [(a, b)]
forall a. Ord a => [a] -> [a]
sort [ (a
a, b
b) | (b
b, a
a) <- Map b a -> [(b, a)]
forall k a. Map k a -> [(k, a)]
Map.toAscList Map b a
ba ]