{-# LANGUAGE LambdaCase #-}
----------------------------------------------------------------------------
-- |
-- Module     : Algebra.Graph.Bipartite.AdjacencyMap.Algorithm
-- Copyright  : (c) Andrey Mokhov 2016-2022
-- License    : MIT (see the file LICENSE)
-- Maintainer : [email protected]
-- 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
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
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 :: forall a.
Ord a =>
AdjacencyMap a -> Either (OddCycle a) (AdjacencyMap a a)
detectParts AdjacencyMap a
x = case forall s a. State s a -> s -> (a, s)
runState (forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT MaybeT (StateT (Map a Part) Identity) (OddCycle a)
dfs) forall k a. Map k a
Map.empty of
    (Maybe (OddCycle a)
Nothing, Map a Part
partMap) -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a b c.
(Ord a, Ord b, Ord c) =>
(a -> Either b c) -> AdjacencyMap a -> AdjacencyMap b c
toBipartiteWith (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
_      ) -> forall a b. a -> Either a b
Left  forall a b. (a -> b) -> a -> b
$ forall {a}. Eq a => [a] -> [a]
oddCycle OddCycle a
c
  where
    -- g :: AM.AdjacencyMap a
    g :: AdjacencyMap a
g = 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 = 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 <- 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 <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall (m :: * -> *) s. Monad m => StateT s m s
get
                         forall (f :: * -> *). Alternative f => Bool -> f ()
guard (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 forall a. a -> [a] -> [a]
:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
        forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify (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
        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 <- forall a. Set a -> [a]
Set.toAscList (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 <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall (m :: * -> *) s. Monad m => StateT s m s
get
                             case 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 forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Part
vertexPart forall a. Eq a => a -> a -> Bool
/= Part
part)
                                                 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 forall a. HasCallStack => Maybe a -> a
fromJust (forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup b
v Map b Part
partMap) of
                             Part
LeftPart  -> forall a b. a -> Either a b
Left  b
v
                             Part
RightPart -> forall a b. b -> Either a b
Right b
v

    -- oddCycle :: [a] -> [a]
    oddCycle :: [a] -> [a]
oddCycle [a]
pathToCycle = forall a. [a] -> [a]
init forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
dropWhile (forall a. Eq a => a -> a -> Bool
/= a
lastVertex) [a]
pathToCycle
      where
        lastVertex :: a
lastVertex = 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
    -- @
    forall a b. 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
    -- @
    forall a b. Matching a b -> Map b a
pairOfRight :: Map b a
} deriving 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 " forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => [a] -> ShowS
showList (forall k a. Map k a -> [(k, a)]
Map.toAscList forall a b. (a -> b) -> 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 = forall a b. Matching a b -> Map a b
pairOfLeft Matching a b
x forall a. Eq a => a -> a -> Bool
== 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 = forall a. Ord a => a -> a -> Ordering
compare (forall a b. Matching a b -> Map a b
pairOfLeft Matching a b
x) (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 :: forall a b.
(Ord a, Ord b) =>
a -> b -> Matching a b -> Matching a b
addEdgeUnsafe a
a b
b (Matching Map a b
ab Map b a
ba) = forall a b. Map a b -> Map b a -> Matching a b
Matching (forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert a
a b
b Map a b
ab) (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 :: forall a b.
(Ord a, Ord b) =>
a -> b -> Matching a b -> Matching a b
addEdge a
a b
b (Matching Map a b
ab Map b a
ba) = forall a b.
(Ord a, Ord b) =>
a -> b -> Matching a b -> Matching a b
addEdgeUnsafe a
a b
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 forall k a. Ord k => k -> Map k a -> Maybe a
`Map.lookup` Map b a
ba of
                  Maybe a
Nothing -> forall k a. Ord k => k -> Map k a -> Map k a
Map.delete a
a Map a b
ab
                  Just a
a' -> forall k a. Ord k => k -> Map k a -> Map k a
Map.delete a
a (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 forall k a. Ord k => k -> Map k a -> Maybe a
`Map.lookup` Map a b
ab of
                  Maybe b
Nothing -> forall k a. Ord k => k -> Map k a -> Map k a
Map.delete b
b Map b a
ba
                  Just b
b' -> forall k a. Ord k => k -> Map k a -> Map k a
Map.delete b
b (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 :: forall a b. Ord a => a -> Matching a b -> Bool
leftCovered a
a = forall k a. Ord k => k -> Map k a -> Bool
Map.member a
a forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 :: forall a b. (Ord a, Ord b) => [(a, b)] -> Matching a b
matching = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (forall a b c. (a -> b -> c) -> b -> a -> c
flip (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a b.
(Ord a, Ord b) =>
a -> b -> Matching a b -> Matching a b
addEdge)) (forall a b. Map a b -> Map b a -> Matching a b
Matching forall k a. Map k a
Map.empty 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 :: forall a b.
(Ord a, Ord b) =>
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 = forall a b. (Ord a, Ord b) => Matching a b -> Bool
consistentMatching Matching a b
m
    Bool -> Bool -> Bool
&& forall (t :: * -> *). Foldable t => t Bool -> Bool
and [ 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) <- 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 :: forall a b. Matching a b -> Int
matchingSize = forall k a. Map k a -> Int
Map.size forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 :: forall a b. (Ord a, Ord b) => AdjacencyMap a b -> Matching a b
maxMatching AdjacencyMap a b
graph = forall a. (forall s. ST s a) -> a
runST (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
    { forall s a b. HKState s a b -> STRef s (Map a Int)
distance    :: STRef s (Map a Int)
    , forall s a b. HKState s a b -> STRef s (Matching a b)
curMatching :: STRef s (Matching a b)
    , forall s a b. HKState s a b -> STRef s (Seq a)
queue       :: STRef s (Seq a)
    , forall s a b. 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 :: forall a b s.
(Ord a, Ord b) =>
AdjacencyMap a b -> ST s (Matching a b)
maxMatchingHK AdjacencyMap a b
g = do
    STRef s (Map a Int)
distance    <- forall a s. a -> ST s (STRef s a)
newSTRef forall k a. Map k a
Map.empty
    STRef s (Matching a b)
curMatching <- forall a s. a -> ST s (STRef s a)
newSTRef (forall a b. Map a b -> Map b a -> Matching a b
Matching forall k a. Map k a
Map.empty forall k a. Map k a
Map.empty)
    STRef s (Seq a)
queue       <- forall a s. a -> ST s (STRef s a)
newSTRef forall a. Seq a
Seq.empty
    STRef s (Set a)
visited     <- forall a s. a -> ST s (STRef s a)
newSTRef forall a. Set a
Set.empty
    HKState s a b -> ST s ()
runHK (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)
    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 forall s a. STRef s a -> a -> ST s ()
writeSTRef (forall s a b. HKState s a b -> STRef s (Map a Int)
distance HKState s a b
state) forall k a. Map k a
Map.empty
                     Bool
foundAugmentingPath <- HKState s a b -> ST s Bool
bfs HKState s a b
state
                     forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
foundAugmentingPath forall a b. (a -> b) -> a -> b
$ do
                         forall s a. STRef s a -> a -> ST s ()
writeSTRef (forall s a b. HKState s a b -> STRef s (Set a)
visited HKState s a b
state) 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 <- forall s a. STRef s a -> ST s a
readSTRef (forall s a b. HKState s a b -> STRef s (Matching a b)
curMatching HKState s a b
state)
        forall (m :: * -> *) a. Monad m => a -> m a
return [ a
v | a
v <- forall a b. AdjacencyMap a b -> [a]
leftVertexList AdjacencyMap a b
g, Bool -> Bool
not (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
        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 forall s a. STRef s a -> (a -> a) -> ST s ()
modifySTRef (forall s a b. HKState s a b -> STRef s (Map a Int)
distance HKState s a b
state) (forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert a
v Int
d)
                           forall s a. STRef s a -> (a -> a) -> ST s ()
modifySTRef (forall s a b. HKState s a b -> STRef s (Seq a)
queue    HKState s a b
state) (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 <- forall s a. STRef s a -> ST s a
readSTRef (forall s a b. HKState s a b -> STRef s (Seq a)
queue HKState s a b
state)
                       case forall a. Seq a -> ViewL a
Seq.viewl Seq a
q of
                           a
a :< Seq a
q -> forall s a. STRef s a -> a -> ST s ()
writeSTRef (forall s a b. HKState s a b -> STRef s (Seq a)
queue HKState s a b
state) Seq a
q forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> forall a. a -> Maybe a
Just a
a
                           ViewL a
EmptyL -> forall (m :: * -> *) a. Monad m => a -> m a
return 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 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
                                      forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
p Bool -> Bool -> Bool
|| Bool
q)
                        Maybe a
Nothing -> 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 <- forall s a. STRef s a -> ST s a
readSTRef (forall s a b. HKState s a b -> STRef s (Map a Int)
distance HKState s a b
state)
                           let d :: Int
d = forall a. HasCallStack => Maybe a -> a
fromJust (a
v forall k a. Ord k => k -> Map k a -> Maybe a
`Map.lookup` Map a Int
dist) forall a. Num a => a -> a -> a
+ Int
1
                           forall (t :: * -> *). Foldable t => t Bool -> Bool
or forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 <- forall s a. STRef s a -> ST s a
readSTRef (forall s a b. HKState s a b -> STRef s (Map a Int)
distance HKState s a b
state)
                                forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (a
v 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 <- forall s a. STRef s a -> ST s a
readSTRef (forall s a b. HKState s a b -> STRef s (Matching a b)
curMatching HKState s a b
state)
                           case b
u forall k a. Ord k => k -> Map k a -> Maybe a
`Map.lookup` 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 forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Bool
False
                               Maybe a
Nothing -> 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 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= 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 <- forall s a. STRef s a -> ST s a
readSTRef (forall s a b. HKState s a b -> STRef s (Map a Int)
distance HKState s a b
state)
                             Set a
vis  <- forall s a. STRef s a -> ST s a
readSTRef (forall s a b. HKState s a b -> STRef s (Set a)
visited HKState s a b
state)
                             let dv :: Int
dv = forall a. HasCallStack => Maybe a -> a
fromJust (a
v forall k a. Ord k => k -> Map k a -> Maybe a
`Map.lookup` Map a Int
dist)
                             case (Int
d forall a. Num a => a -> a -> a
+ Int
1 forall a. Eq a => a -> a -> Bool
== Int
dv) Bool -> Bool -> Bool
&& (a
v forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set a
vis) of
                                 Bool
False -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
                                 Bool
True  -> do forall s a. STRef s a -> (a -> a) -> ST s ()
modifySTRef (forall s a b. HKState s a b -> STRef s (Set a)
visited HKState s a b
state) (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
_ []     = 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 <- forall s a. STRef s a -> ST s a
readSTRef (forall s a b. HKState s a b -> STRef s (Matching a b)
curMatching HKState s a b
state)
                                   case b
b forall k a. Ord k => k -> Map k a -> Maybe a
`Map.lookup` 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 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 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 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 = forall s a. STRef s a -> (a -> a) -> ST s ()
modifySTRef (forall s a b. HKState s a b -> STRef s (Matching a b)
curMatching HKState s a b
state) (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 = forall a. Set a -> [a]
Set.toAscList forall a b. (a -> b) -> a -> b
$ forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup a
a forall a b. (a -> b) -> a -> 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 :: forall a b.
(Ord a, Ord b) =>
(Set a, Set b) -> AdjacencyMap a b -> Bool
isVertexCoverOf (Set a
as, Set b
bs) AdjacencyMap a b
g = Set a
as forall a. Ord a => Set a -> Set a -> Bool
`Set.isSubsetOf` forall a b. AdjacencyMap a b -> Set a
leftVertexSet AdjacencyMap a b
g
    Bool -> Bool -> Bool
&& Set b
bs forall a. Ord a => Set a -> Set a -> Bool
`Set.isSubsetOf` forall a b. AdjacencyMap a b -> Set b
rightVertexSet AdjacencyMap a b
g
    Bool -> Bool -> Bool
&& forall (t :: * -> *). Foldable t => t Bool -> Bool
and [ a
a forall a. Ord a => a -> Set a -> Bool
`Set.member` Set a
as Bool -> Bool -> Bool
|| b
b forall a. Ord a => a -> Set a -> Bool
`Set.member` Set b
bs | (a
a, b
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 :: forall a b. VertexCover a b -> Int
vertexCoverSize (Set a
as, Set b
bs) = forall a. Set a -> Int
Set.size Set a
as forall a. Num a => a -> a -> a
+ 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 :: forall a b. (Ord a, Ord b) => AdjacencyMap a b -> VertexCover a b
minVertexCover AdjacencyMap a b
g = forall a b. a -> Either a b -> a
fromLeft forall {a}. a
panic forall a b. (a -> b) -> a -> b
$ forall a b.
(Ord a, Ord b) =>
Matching a b
-> AdjacencyMap a b -> Either (VertexCover a b) (List a b)
augmentingPath (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 = 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 :: forall a b.
(Ord a, Ord b) =>
(Set a, Set b) -> AdjacencyMap a b -> Bool
isIndependentSetOf (Set a
as, Set b
bs) AdjacencyMap a b
g = Set a
as forall a. Ord a => Set a -> Set a -> Bool
`Set.isSubsetOf` forall a b. AdjacencyMap a b -> Set a
leftVertexSet AdjacencyMap a b
g
    Bool -> Bool -> Bool
&& Set b
bs forall a. Ord a => Set a -> Set a -> Bool
`Set.isSubsetOf` forall a b. AdjacencyMap a b -> Set b
rightVertexSet AdjacencyMap a b
g
    Bool -> Bool -> Bool
&& forall (t :: * -> *). Foldable t => t Bool -> Bool
and [ Bool -> Bool
not (a
a forall a. Ord a => a -> Set a -> Bool
`Set.member` Set a
as Bool -> Bool -> Bool
&& b
b forall a. Ord a => a -> Set a -> Bool
`Set.member` Set b
bs) | (a
a, b
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 :: forall a b. VertexCover a b -> Int
independentSetSize (Set a
as, Set b
bs) = forall a. Set a -> Int
Set.size Set a
as forall a. Num a => a -> a -> a
+ 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 :: forall a b. (Ord a, Ord b) => AdjacencyMap a b -> VertexCover a b
maxIndependentSet AdjacencyMap a b
g =
    (forall a b. AdjacencyMap a b -> Set a
leftVertexSet AdjacencyMap a b
g forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Set a
as, forall a b. AdjacencyMap a b -> Set b
rightVertexSet AdjacencyMap a b
g forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Set b
bs)
  where
    (Set a
as, Set b
bs) = 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 :: forall a b.
(Ord a, Ord b) =>
Matching a b
-> AdjacencyMap a b -> Either (VertexCover a b) (List a b)
augmentingPath = 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 :: forall a b.
(Ord a, Ord b) =>
Matching a b
-> AdjacencyMap a b -> Either (VertexCover a b) (List a b)
augmentingPathImpl Matching a b
m AdjacencyMap a b
g = case forall s a. State s a -> s -> (a, s)
runState (forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT AugPathMonad a b
dfs) (forall a b. AdjacencyMap a b -> Set a
leftVertexSet AdjacencyMap a b
g, forall a. Set a
Set.empty) of
    (Maybe (List a b)
Nothing  , VertexCover a b
cover) -> forall a b. a -> Either a b
Left VertexCover a b
cover
    (Just List a b
path, VertexCover a b
_    ) -> forall a b. b -> Either a b
Right List a b
path
  where
    dfs :: AugPathMonad a b
    dfs :: AugPathMonad a b
dfs = forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum [ a -> AugPathMonad a b
inVertex a
v | a
v <- forall a b. AdjacencyMap a b -> [a]
leftVertexList AdjacencyMap a b
g, Bool -> Bool
not (forall a b. Ord a => a -> Matching a b -> Bool
leftCovered a
v Matching a b
m) ]

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

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

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