{-# OPTIONS_GHC -Wall #-}
{-# OPTIONS_HADDOCK show-extensions #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ScopedTypeVariables #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  ToySolver.Combinatorial.BipartiteMatching
-- Copyright   :  (c) Masahiro Sakai 2016
-- License     :  BSD-style
--
-- Maintainer  :  masahiro.sakai@gmail.com
-- Stability   :  experimental
-- Portability :  non-portable
--
-- This module provides functions for computing several kind of bipartite
-- matching.
--
-- Reference:
--
-- * Friedrich Eisenbrand. “Linear and Discrete Optimization”.
--   <https://www.coursera.org/course/linearopt>
--
-----------------------------------------------------------------------------
module ToySolver.Combinatorial.BipartiteMatching
  (
  -- * Maximum cardinality bipartite matching
    maximumCardinalityMatching

  -- * Maximum weight bipartite matching
  , maximumWeightMatching
  , maximumWeightMatchingComplete

  -- * Maximum/Minimum weight bipartite perfect matching
  , maximumWeightPerfectMatching
  , minimumWeightPerfectMatching
  , maximumWeightPerfectMatchingComplete
  , minimumWeightPerfectMatchingComplete

  -- * Misc
  , minimumCardinalityEdgeCover
  , minimumWeightEdgeCover
  , minimumWeightEdgeCoverComplete
  ) where

import Control.Monad
import qualified Data.Foldable as F
import Data.IntMap.Strict (IntMap, (!))
import qualified Data.IntMap.Strict as IntMap
import Data.IntSet (IntSet)
import qualified Data.IntSet as IntSet
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Maybe

-- -----------------------------------------------------------------------------

-- | Maximum cardinality matching on a bipartite graph (A+B, E).
maximumCardinalityMatching
  :: IntSet      -- ^ vertex set A
  -> IntSet      -- ^ vertex set B
  -> [(Int,Int)] -- ^ set of edges E⊆A×B
  -> IntMap Int
maximumCardinalityMatching :: IntSet -> IntSet -> [(Int, Int)] -> IntMap Int
maximumCardinalityMatching IntSet
_as IntSet
bs [(Int, Int)]
es =
  case IntSet
-> (Int -> IntSet) -> IntMap Int -> (IntMap Int, IntSet, IntSet)
maximumCardinalityMatching' IntSet
bs (\Int
b -> forall a. a -> Int -> IntMap a -> a
IntMap.findWithDefault IntSet
IntSet.empty Int
b IntMap IntSet
e_b2a) forall a. IntMap a
IntMap.empty of
    (IntMap Int
m, IntSet
_, IntSet
_) -> IntMap Int
m
  where
    e_b2a :: IntMap IntSet
    e_b2a :: IntMap IntSet
e_b2a = forall a. (a -> a -> a) -> [(Int, a)] -> IntMap a
IntMap.fromListWith IntSet -> IntSet -> IntSet
IntSet.union [(Int
b, Int -> IntSet
IntSet.singleton Int
a) | (Int
a,Int
b) <- [(Int, Int)]
es]

-- | Alternating path b_0, a_0, …, b_{n-1}, a_{n-1}, b_n is represented as
-- (b_n, [(a_{n-1}, b_{n-1}) .. (a_0, b_0)], b_0).
type AlternatingPath = (Int, [(Int,Int)], Int)

-- | Augmenting path b_0, a_0, …, b_n, a_n is represented as
-- ([(a_n, b_n) .. (a_0, b_0)], b_0).
type AugmentingPath = ([(Int,Int)], Int)

-- | Internal low-level routine for maximum cardinality bipartite matching.
--
-- It returns a maximum cardinality matching M together with sets of
-- vertexes reachable from exposed B vertexes (b∈B such that ∀a∈A. (a,b)∉M)
-- on a directed graph (A+B, {a→b|(a,b)∈M}∪{b→a|(a,b)⊆E\\M}).
maximumCardinalityMatching'
  :: IntSet          -- ^ vertex set B
  -> (Int -> IntSet) -- ^ set of edges E⊆A×B represented as a mapping from B to 2^A.
  -> IntMap Int      -- ^ partial matching represented as an injective mapping from A to B
  -> (IntMap Int, IntSet, IntSet)
maximumCardinalityMatching' :: IntSet
-> (Int -> IntSet) -> IntMap Int -> (IntMap Int, IntSet, IntSet)
maximumCardinalityMatching' IntSet
bs Int -> IntSet
e_b2a IntMap Int
m0 = IntMap Int -> IntSet -> (IntMap Int, IntSet, IntSet)
loop IntMap Int
m0 IntSet
m0_b_exposed
  where
    m0_b_exposed :: IntSet
m0_b_exposed = IntSet
bs IntSet -> IntSet -> IntSet
`IntSet.difference` [Int] -> IntSet
IntSet.fromList (forall a. IntMap a -> [a]
IntMap.elems IntMap Int
m0)

    loop :: IntMap Int -> IntSet -> (IntMap Int, IntSet, IntSet)
    loop :: IntMap Int -> IntSet -> (IntMap Int, IntSet, IntSet)
loop IntMap Int
m IntSet
m_b_exposed =
      case IntSet -> (IntSet, IntSet, [AugmentingPath])
search IntSet
m_b_exposed of
        (IntSet
l_a, IntSet
l_b, []) -> (IntMap Int
m, IntSet
l_a, IntSet
l_b)
        (IntSet
_, IntSet
_, [AugmentingPath]
ds) ->
          let -- Note that IntMap.union is left-biased
              ds2 :: [IntMap Int]
ds2 = [forall a. [(Int, a)] -> IntMap a
IntMap.fromList [(Int, Int)]
d2 | ([(Int, Int)]
d2,Int
_) <- [AugmentingPath]
ds]
              m' :: IntMap Int
m' = forall (f :: * -> *) a. Foldable f => f (IntMap a) -> IntMap a
IntMap.unions [IntMap Int]
ds2 forall a. IntMap a -> IntMap a -> IntMap a
`IntMap.union` IntMap Int
m
              m_b_exposed' :: IntSet
m_b_exposed' = IntSet
m_b_exposed IntSet -> IntSet -> IntSet
`IntSet.difference` [Int] -> IntSet
IntSet.fromList [Int
b0 | ([(Int, Int)]
_, Int
b0) <- [AugmentingPath]
ds]
          in IntMap Int -> IntSet -> (IntMap Int, IntSet, IntSet)
loop IntMap Int
m' IntSet
m_b_exposed'
      where
        search :: IntSet -> (IntSet, IntSet, [AugmentingPath])
        search :: IntSet -> (IntSet, IntSet, [AugmentingPath])
search IntSet
b_exposed = IntSet
-> IntSet
-> [AlternatingPath]
-> [AlternatingPath]
-> [AugmentingPath]
-> (IntSet, IntSet, [AugmentingPath])
loopB IntSet
IntSet.empty IntSet
b_exposed [(Int
b, [], Int
b) | Int
b <- IntSet -> [Int]
IntSet.toList IntSet
b_exposed] [] []
          where
            loopB :: IntSet -> IntSet -> [AlternatingPath] -> [AlternatingPath] -> [AugmentingPath] -> (IntSet, IntSet, [AugmentingPath])
            loopB :: IntSet
-> IntSet
-> [AlternatingPath]
-> [AlternatingPath]
-> [AugmentingPath]
-> (IntSet, IntSet, [AugmentingPath])
loopB !IntSet
visitedA !IntSet
visitedB [] [] [AugmentingPath]
result = (IntSet
visitedA, IntSet
visitedB, [AugmentingPath]
result)
            loopB !IntSet
visitedA !IntSet
visitedB [] [AlternatingPath]
nextB [AugmentingPath]
result = IntSet
-> IntSet
-> [AlternatingPath]
-> [AlternatingPath]
-> [AugmentingPath]
-> (IntSet, IntSet, [AugmentingPath])
loopB IntSet
visitedA IntSet
visitedB [AlternatingPath]
nextB [] [AugmentingPath]
result
            loopB !IntSet
visitedA !IntSet
visitedB ((Int
b, [(Int, Int)]
d2, Int
b0) : [AlternatingPath]
currB) [AlternatingPath]
nextB [AugmentingPath]
result = IntSet
-> IntSet
-> [Int]
-> [AlternatingPath]
-> [AlternatingPath]
-> [AugmentingPath]
-> (IntSet, IntSet, [AugmentingPath])
loopA IntSet
visitedA IntSet
visitedB (IntSet -> [Int]
IntSet.toList (Int -> IntSet
e_b2a Int
b)) [AlternatingPath]
currB [AlternatingPath]
nextB [AugmentingPath]
result
              where
                loopA :: IntSet
-> IntSet
-> [Int]
-> [AlternatingPath]
-> [AlternatingPath]
-> [AugmentingPath]
-> (IntSet, IntSet, [AugmentingPath])
loopA !IntSet
visitedA !IntSet
visitedB [] [AlternatingPath]
currB [AlternatingPath]
nextB [AugmentingPath]
result = IntSet
-> IntSet
-> [AlternatingPath]
-> [AlternatingPath]
-> [AugmentingPath]
-> (IntSet, IntSet, [AugmentingPath])
loopB IntSet
visitedA IntSet
visitedB [AlternatingPath]
currB [AlternatingPath]
nextB [AugmentingPath]
result
                loopA !IntSet
visitedA !IntSet
visitedB (Int
a:[Int]
as) [AlternatingPath]
currB [AlternatingPath]
nextB [AugmentingPath]
result
                  | Int
a Int -> IntSet -> Bool
`IntSet.member` IntSet
visitedA = IntSet
-> IntSet
-> [Int]
-> [AlternatingPath]
-> [AlternatingPath]
-> [AugmentingPath]
-> (IntSet, IntSet, [AugmentingPath])
loopA IntSet
visitedA IntSet
visitedB [Int]
as [AlternatingPath]
currB [AlternatingPath]
nextB [AugmentingPath]
result
                  | Bool
otherwise =
                      case forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
a IntMap Int
m of
                        Maybe Int
Nothing ->
                          IntSet
-> IntSet
-> [AlternatingPath]
-> [AlternatingPath]
-> [AugmentingPath]
-> (IntSet, IntSet, [AugmentingPath])
loopB (Int -> IntSet -> IntSet
IntSet.insert Int
a IntSet
visitedA) IntSet
visitedB (forall a. (a -> Bool) -> [a] -> [a]
filter (\(Int
_,[(Int, Int)]
_,Int
b0') -> Int
b0forall a. Eq a => a -> a -> Bool
/=Int
b0') [AlternatingPath]
currB) (forall a. (a -> Bool) -> [a] -> [a]
filter (\(Int
_,[(Int, Int)]
_,Int
b0') -> Int
b0forall a. Eq a => a -> a -> Bool
/=Int
b0') [AlternatingPath]
nextB) (((Int
a,Int
b) forall a. a -> [a] -> [a]
: [(Int, Int)]
d2, Int
b0) forall a. a -> [a] -> [a]
: [AugmentingPath]
result)
                        Just Int
b2
                          | Int
bforall a. Eq a => a -> a -> Bool
==Int
b2 -> IntSet
-> IntSet
-> [Int]
-> [AlternatingPath]
-> [AlternatingPath]
-> [AugmentingPath]
-> (IntSet, IntSet, [AugmentingPath])
loopA IntSet
visitedA IntSet
visitedB [Int]
as [AlternatingPath]
currB [AlternatingPath]
nextB [AugmentingPath]
result
                          | Int
b2 Int -> IntSet -> Bool
`IntSet.member` IntSet
visitedB -> IntSet
-> IntSet
-> [Int]
-> [AlternatingPath]
-> [AlternatingPath]
-> [AugmentingPath]
-> (IntSet, IntSet, [AugmentingPath])
loopA (Int -> IntSet -> IntSet
IntSet.insert Int
a IntSet
visitedA) IntSet
visitedB [Int]
as [AlternatingPath]
currB [AlternatingPath]
nextB [AugmentingPath]
result
                          | Bool
otherwise -> IntSet
-> IntSet
-> [Int]
-> [AlternatingPath]
-> [AlternatingPath]
-> [AugmentingPath]
-> (IntSet, IntSet, [AugmentingPath])
loopA (Int -> IntSet -> IntSet
IntSet.insert Int
a IntSet
visitedA) (Int -> IntSet -> IntSet
IntSet.insert Int
b2 IntSet
visitedB) [Int]
as [AlternatingPath]
currB ((Int
b2, (Int
a,Int
b)forall a. a -> [a] -> [a]
:[(Int, Int)]
d2, Int
b0) forall a. a -> [a] -> [a]
: [AlternatingPath]
nextB) [AugmentingPath]
result

-- -----------------------------------------------------------------------------

-- | Maximum weight matching of a complete bipartite graph (A+B,A×B).
maximumWeightMatchingComplete
  :: forall w. (Real w)
  => IntSet            -- ^ vertex set A
  -> IntSet            -- ^ vertex set B
  -> (Int -> Int -> w) -- ^ weight of edges A×B
  -> (w, IntMap Int)
maximumWeightMatchingComplete :: forall w.
Real w =>
IntSet -> IntSet -> (Int -> Int -> w) -> (w, IntMap Int)
maximumWeightMatchingComplete IntSet
as IntSet
bs Int -> Int -> w
w =
  case forall w.
Real w =>
IntSet -> IntSet -> (Int -> Int -> w) -> (w, IntMap Int)
maximumWeightMaximumMatchingComplete IntSet
as IntSet
bs (\Int
a Int
b -> forall a. Ord a => a -> a -> a
max w
0 (Int -> Int -> w
w Int
a Int
b)) of
    (w
_, IntMap Int
m) ->
      let m' :: IntMap Int
m' = forall a. (Int -> a -> Bool) -> IntMap a -> IntMap a
IntMap.filterWithKey (\Int
a Int
b -> Int -> Int -> w
w Int
a Int
b forall a. Ord a => a -> a -> Bool
> w
0) IntMap Int
m
      in (forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Int -> Int -> w
w Int
a Int
b | (Int
a,Int
b) <- forall a. IntMap a -> [(Int, a)]
IntMap.toList IntMap Int
m'], IntMap Int
m')

-- | Maximum weight matching of a bipartite graph (A+B,E).
maximumWeightMatching
  :: forall w. (Real w)
  => IntSet          -- ^ vertex set A
  -> IntSet          -- ^ vertex set B
  -> [(Int, Int, w)] -- ^ edges E⊆A×B and their weights
  -> (w, IntMap Int)
maximumWeightMatching :: forall w.
Real w =>
IntSet -> IntSet -> [(Int, Int, w)] -> (w, IntMap Int)
maximumWeightMatching IntSet
as IntSet
bs [(Int, Int, w)]
w =
  case forall w.
Real w =>
IntSet -> IntSet -> (Int -> Int -> w) -> (w, IntMap Int)
maximumWeightMaximumMatchingComplete IntSet
as IntSet
bs Int -> Int -> w
g of
    (w
_, IntMap Int
m) ->
      let m' :: IntMap Int
m' = forall a. (Int -> a -> Bool) -> IntMap a -> IntMap a
IntMap.filterWithKey (\Int
a Int
b -> forall a. Maybe a -> Bool
isJust (Int -> Int -> Maybe w
f Int
a Int
b)) IntMap Int
m
      in (forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Int -> Int -> w
g Int
a Int
b | (Int
a,Int
b) <- forall a. IntMap a -> [(Int, a)]
IntMap.toList IntMap Int
m'], IntMap Int
m')
  where
    tbl :: IntMap (IntMap w)
    tbl :: IntMap (IntMap w)
tbl = forall a. (a -> a -> a) -> [(Int, a)] -> IntMap a
IntMap.fromListWith forall a. IntMap a -> IntMap a -> IntMap a
IntMap.union [(Int
a, (forall a. Int -> a -> IntMap a
IntMap.singleton Int
b w
v)) | (Int
a,Int
b,w
v) <- [(Int, Int, w)]
w]
    f :: Int -> Int -> Maybe w
f Int
a Int
b = do
      IntMap w
t <- forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
a IntMap (IntMap w)
tbl
      w
v <- forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
b IntMap w
t
      forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ w
v forall a. Ord a => a -> a -> Bool
>= w
0
      forall (m :: * -> *) a. Monad m => a -> m a
return w
v
    g :: Int -> Int -> w
g Int
a Int
b = forall a. a -> Maybe a -> a
fromMaybe w
0 (Int -> Int -> Maybe w
f Int
a Int
b)

-- -----------------------------------------------------------------------------

-- | Maximum weight maximum matching of a complete bipartite graph (A+B,A×B).
maximumWeightMaximumMatchingComplete
  :: forall w. (Real w)
  => IntSet            -- ^ vertex set A
  -> IntSet            -- ^ vertex set B
  -> (Int -> Int -> w) -- ^ weight of edges A×B
  -> (w, IntMap Int)
maximumWeightMaximumMatchingComplete :: forall w.
Real w =>
IntSet -> IntSet -> (Int -> Int -> w) -> (w, IntMap Int)
maximumWeightMaximumMatchingComplete IntSet
as IntSet
bs Int -> Int -> w
w =
  case Int
as_size forall a. Ord a => a -> a -> Ordering
`compare` Int
bs_size of
    Ordering
EQ ->
      case forall w.
Real w =>
IntSet
-> IntSet
-> (Int -> Int -> w)
-> (w, IntMap Int, (IntMap w, IntMap w))
maximumWeightPerfectMatchingComplete IntSet
as IntSet
bs Int -> Int -> w
w of
        (w
obj, IntMap Int
sol, (IntMap w, IntMap w)
_) -> (w
obj, IntMap Int
sol)
    Ordering
GT ->
      let bs' :: IntSet
bs' = IntSet
bs IntSet -> IntSet -> IntSet
`IntSet.union` [Int] -> IntSet
IntSet.fromAscList (forall a. Int -> [a] -> [a]
take (Int
as_sizeforall a. Num a => a -> a -> a
-Int
bs_size) forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (Int -> IntSet -> Bool
`IntSet.notMember` IntSet
bs) [Int
0..])
          w' :: Int -> Int -> w
w' Int
a Int
b
            | Int
b Int -> IntSet -> Bool
`IntSet.member` IntSet
bs = Int -> Int -> w
w Int
a Int
b
            | Bool
otherwise = w
0
      in case forall w.
Real w =>
IntSet
-> IntSet
-> (Int -> Int -> w)
-> (w, IntMap Int, (IntMap w, IntMap w))
maximumWeightPerfectMatchingComplete IntSet
as IntSet
bs' Int -> Int -> w
w' of
           (w
obj, IntMap Int
sol, (IntMap w, IntMap w)
_) ->
             ( w
obj
             , forall a. (Int -> a -> Bool) -> IntMap a -> IntMap a
IntMap.filterWithKey (\Int
_ Int
b -> Int
b Int -> IntSet -> Bool
`IntSet.member` IntSet
bs) IntMap Int
sol
             )
    Ordering
LT ->
      let as' :: IntSet
as' = IntSet
as IntSet -> IntSet -> IntSet
`IntSet.union` [Int] -> IntSet
IntSet.fromAscList (forall a. Int -> [a] -> [a]
take (Int
bs_sizeforall a. Num a => a -> a -> a
-Int
as_size) forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (Int -> IntSet -> Bool
`IntSet.notMember` IntSet
as) [Int
0..])
          w' :: Int -> Int -> w
w' Int
a Int
b
            | Int
a Int -> IntSet -> Bool
`IntSet.member` IntSet
as = Int -> Int -> w
w Int
a Int
b
            | Bool
otherwise = w
0
      in case forall w.
Real w =>
IntSet
-> IntSet
-> (Int -> Int -> w)
-> (w, IntMap Int, (IntMap w, IntMap w))
maximumWeightPerfectMatchingComplete IntSet
as' IntSet
bs Int -> Int -> w
w' of
           (w
obj, IntMap Int
sol, (IntMap w, IntMap w)
_) ->
             ( w
obj
             , forall a. (Int -> a -> Bool) -> IntMap a -> IntMap a
IntMap.filterWithKey (\Int
a Int
_ -> Int
a Int -> IntSet -> Bool
`IntSet.member` IntSet
as) IntMap Int
sol
             )
  where
    as_size :: Int
as_size = IntSet -> Int
IntSet.size IntSet
as
    bs_size :: Int
bs_size = IntSet -> Int
IntSet.size IntSet
bs

-- -----------------------------------------------------------------------------

-- | Maximum weight perfect matching of a complete bipartite graph (A+B,A×B).
--
-- The two sets must be same size (\|A\| = \|B\|).
maximumWeightPerfectMatchingComplete
  :: forall w. (Real w)
  => IntSet            -- ^ vertex set A
  -> IntSet            -- ^ vertex set B
  -> (Int -> Int -> w) -- ^ weight of edges A×B
  -> (w, IntMap Int, (IntMap w, IntMap w))
maximumWeightPerfectMatchingComplete :: forall w.
Real w =>
IntSet
-> IntSet
-> (Int -> Int -> w)
-> (w, IntMap Int, (IntMap w, IntMap w))
maximumWeightPerfectMatchingComplete IntSet
as IntSet
bs Int -> Int -> w
w =
  case forall w.
Real w =>
IntSet
-> IntSet
-> (Int -> Int -> w)
-> (w, IntMap Int, (IntMap w, IntMap w))
minimumWeightPerfectMatchingComplete IntSet
as IntSet
bs (\Int
a Int
b -> - Int -> Int -> w
w Int
a Int
b) of
    (w
obj, IntMap Int
m, (IntMap w
ysA,IntMap w
ysB)) -> (- w
obj, IntMap Int
m, (forall a b. (a -> b) -> IntMap a -> IntMap b
IntMap.map forall a. Num a => a -> a
negate IntMap w
ysA, forall a b. (a -> b) -> IntMap a -> IntMap b
IntMap.map forall a. Num a => a -> a
negate IntMap w
ysB))

-- | Minimum weight perfect matching of a complete bipartite graph (A+B,A×B).
--
-- The two sets must be same size (\|A\| = \|B\|).
minimumWeightPerfectMatchingComplete
  :: forall w. (Real w)
  => IntSet            -- ^ vertex set A
  -> IntSet            -- ^ vertex set B
  -> (Int -> Int -> w) -- ^ weight of edges A×B
  -> (w, IntMap Int, (IntMap w, IntMap w))
minimumWeightPerfectMatchingComplete :: forall w.
Real w =>
IntSet
-> IntSet
-> (Int -> Int -> w)
-> (w, IntMap Int, (IntMap w, IntMap w))
minimumWeightPerfectMatchingComplete IntSet
as IntSet
bs Int -> Int -> w
w
  | Int
n forall a. Eq a => a -> a -> Bool
/= IntSet -> Int
IntSet.size IntSet
bs = forall a. HasCallStack => [Char] -> a
error [Char]
"minimumWeightPerfectMatchingComplete: two sets must be same size"
  | Bool
otherwise = IntMap Int
-> (IntMap w, IntMap w)
-> IntMap IntSet
-> (w, IntMap Int, (IntMap w, IntMap w))
loop forall a. IntMap a
m0 (IntMap w, IntMap w)
ys0 ((IntMap w, IntMap w) -> IntMap IntSet
equalityGraph (IntMap w, IntMap w)
ys0)
  where
    n :: Int
n = IntSet -> Int
IntSet.size IntSet
as

    ys0 :: (IntMap w, IntMap w)
    ys0 :: (IntMap w, IntMap w)
ys0 = ( forall a. (Int -> a) -> IntSet -> IntMap a
IntMap.fromSet (\Int
a -> forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum [Int -> Int -> w
w Int
a Int
b | Int
b <- IntSet -> [Int]
IntSet.toList IntSet
bs]) IntSet
as
          , forall a. (Int -> a) -> IntSet -> IntMap a
IntMap.fromSet (\Int
_ -> w
0) IntSet
bs
          )
    m0 :: IntMap a
m0 = forall a. IntMap a
IntMap.empty

    loop
      :: IntMap Int -> (IntMap w, IntMap w) -> IntMap IntSet
      -> (w, IntMap Int, (IntMap w, IntMap w))
    loop :: IntMap Int
-> (IntMap w, IntMap w)
-> IntMap IntSet
-> (w, IntMap Int, (IntMap w, IntMap w))
loop IntMap Int
m_pre ys :: (IntMap w, IntMap w)
ys@(IntMap w
ysA,IntMap w
ysB) IntMap IntSet
g_eq
      | forall a. IntMap a -> Int
IntMap.size IntMap Int
m forall a. Eq a => a -> a -> Bool
== Int
n = (forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
F.sum IntMap w
ysA forall a. Num a => a -> a -> a
+ forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
F.sum IntMap w
ysB, IntMap Int
m, (IntMap w, IntMap w)
ys)
      | Bool
otherwise = IntMap Int
-> (IntMap w, IntMap w)
-> IntMap IntSet
-> (w, IntMap Int, (IntMap w, IntMap w))
loop IntMap Int
m (IntMap w, IntMap w)
ys' IntMap IntSet
g_eq'
      where
        (IntMap Int
m, IntSet
l_a, IntSet
l_b) = IntSet
-> (Int -> IntSet) -> IntMap Int -> (IntMap Int, IntSet, IntSet)
maximumCardinalityMatching' IntSet
bs (IntMap IntSet
g_eq forall a. IntMap a -> Int -> a
!) IntMap Int
m_pre
        l_a' :: IntSet
l_a' = IntSet
as IntSet -> IntSet -> IntSet
`IntSet.difference` IntSet
l_a -- A \ L

        slack :: w
        slack :: w
slack = forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum
                [ Int -> Int -> w
w Int
a Int
b forall a. Num a => a -> a -> a
- (IntMap w
ysAforall a. IntMap a -> Int -> a
!Int
a forall a. Num a => a -> a -> a
+ IntMap w
ysBforall a. IntMap a -> Int -> a
!Int
b)
                | Int
a <- IntSet -> [Int]
IntSet.toList IntSet
l_a'
                , Int
b <- IntSet -> [Int]
IntSet.toList IntSet
l_b
                ]

        -- augmenting dual solution
        ys' :: (IntMap w, IntMap w)
        ys' :: (IntMap w, IntMap w)
ys' = (forall a b. (Int -> a -> b) -> IntMap a -> IntMap b
IntMap.mapWithKey Int -> w -> w
f IntMap w
ysA, forall a b. (Int -> a -> b) -> IntMap a -> IntMap b
IntMap.mapWithKey Int -> w -> w
g IntMap w
ysB)
          where
            f :: Int -> w -> w
f Int
a w
val
              | Int
a Int -> IntSet -> Bool
`IntSet.notMember` IntSet
l_a = w
val forall a. Num a => a -> a -> a
+ w
slack
              | Bool
otherwise = w
val
            g :: Int -> w -> w
g Int
b w
val
              | Int
b Int -> IntSet -> Bool
`IntSet.notMember` IntSet
l_b = w
val forall a. Num a => a -> a -> a
- w
slack
              | Bool
otherwise = w
val

        g_eq' :: IntMap IntSet
        g_eq' :: IntMap IntSet
g_eq' = forall a b. (Int -> a -> b) -> IntMap a -> IntMap b
IntMap.mapWithKey Int -> IntSet -> IntSet
f IntMap IntSet
g_eq
          where
            f :: Int -> IntSet -> IntSet
f Int
b IntSet
as3
              | Int
b Int -> IntSet -> Bool
`IntSet.member` IntSet
l_b =
                  IntSet
as3 IntSet -> IntSet -> IntSet
`IntSet.union` (Int -> Bool) -> IntSet -> IntSet
IntSet.filter (\Int
a -> Int -> Int -> w
w Int
a Int
b forall a. Eq a => a -> a -> Bool
== (forall a b. (a, b) -> a
fst (IntMap w, IntMap w)
ys' forall a. IntMap a -> Int -> a
! Int
a forall a. Num a => a -> a -> a
+ forall a b. (a, b) -> b
snd (IntMap w, IntMap w)
ys' forall a. IntMap a -> Int -> a
! Int
b)) IntSet
l_a'
              | Bool
otherwise = IntSet
as3 IntSet -> IntSet -> IntSet
`IntSet.difference` IntSet
l_a

    equalityGraph :: (IntMap w, IntMap w) -> IntMap IntSet
    equalityGraph :: (IntMap w, IntMap w) -> IntMap IntSet
equalityGraph (IntMap w
ysA,IntMap w
ysB) =
      forall a. (Int -> a) -> IntSet -> IntMap a
IntMap.fromSet (\Int
b -> (Int -> Bool) -> IntSet -> IntSet
IntSet.filter (\Int
a -> Int -> Int -> w
w Int
a Int
b forall a. Eq a => a -> a -> Bool
== IntMap w
ysAforall a. IntMap a -> Int -> a
!Int
a forall a. Num a => a -> a -> a
+ IntMap w
ysBforall a. IntMap a -> Int -> a
!Int
b) IntSet
as) IntSet
bs

-- -----------------------------------------------------------------------------

-- | Maximum weight perfect matching of a complete bipartite graph (A+B,E).
--
-- If no such matching exist, it returns @Nothing@.
maximumWeightPerfectMatching
  :: forall w. (Real w)
  => IntSet        -- ^ vertex set A
  -> IntSet        -- ^ vertex set B
  -> [(Int,Int,w)] -- ^ edges E⊆A×B and their weights
  -> Maybe (w, IntMap Int, (IntMap w, IntMap w))
maximumWeightPerfectMatching :: forall w.
Real w =>
IntSet
-> IntSet
-> [(Int, Int, w)]
-> Maybe (w, IntMap Int, (IntMap w, IntMap w))
maximumWeightPerfectMatching IntSet
as IntSet
bs [(Int, Int, w)]
es = do
  (w
obj, IntMap Int
m, (IntMap w
ysA,IntMap w
ysB)) <- forall w.
Real w =>
IntSet
-> IntSet
-> [(Int, Int, w)]
-> Maybe (w, IntMap Int, (IntMap w, IntMap w))
minimumWeightPerfectMatching IntSet
as IntSet
bs [(Int
a,Int
b,-w
w) |(Int
a,Int
b,w
w) <- [(Int, Int, w)]
es]
  forall (m :: * -> *) a. Monad m => a -> m a
return (- w
obj, IntMap Int
m, (forall a b. (a -> b) -> IntMap a -> IntMap b
IntMap.map forall a. Num a => a -> a
negate IntMap w
ysA, forall a b. (a -> b) -> IntMap a -> IntMap b
IntMap.map forall a. Num a => a -> a
negate IntMap w
ysB))

-- | Minimum weight perfect matching of a bipartite graph (A+B, E).
--
-- If no such matching exist, it returns @Nothing@.
minimumWeightPerfectMatching
  :: forall w. (Real w)
  => IntSet        -- ^ vertex set A
  -> IntSet        -- ^ vertex set B
  -> [(Int,Int,w)] -- ^ edges E⊆A×B and their weights
  -> Maybe (w, IntMap Int, (IntMap w, IntMap w))
minimumWeightPerfectMatching :: forall w.
Real w =>
IntSet
-> IntSet
-> [(Int, Int, w)]
-> Maybe (w, IntMap Int, (IntMap w, IntMap w))
minimumWeightPerfectMatching IntSet
as IntSet
bs [(Int, Int, w)]
es
  | Int
n forall a. Eq a => a -> a -> Bool
/= IntSet -> Int
IntSet.size IntSet
bs = forall a. Maybe a
Nothing
  | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
F.any forall a. IntMap a -> Bool
IntMap.null IntMap (IntMap w)
e_b2a = forall a. Maybe a
Nothing
  | Bool
otherwise = IntMap Int
-> (IntMap w, IntMap w)
-> IntMap IntSet
-> Maybe (w, IntMap Int, (IntMap w, IntMap w))
loop forall a. IntMap a
m0 (IntMap w, IntMap w)
ys0 ((IntMap w, IntMap w) -> IntMap IntSet
equalityGraph (IntMap w, IntMap w)
ys0)
  where
    n :: Int
n = IntSet -> Int
IntSet.size IntSet
as

    -- Note that IntMap.union is left-biased.
    e_b2a :: IntMap (IntMap w)
    e_b2a :: IntMap (IntMap w)
e_b2a = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. [(Int, a)] -> IntMap a
IntMap.fromList forall a b. (a -> b) -> a -> b
$ forall a. (a -> a -> a) -> [(Int, a)] -> IntMap a
IntMap.fromListWith forall a. [a] -> [a] -> [a]
(++) [(Int
b,[(Int
a,w
w)]) | (Int
a,Int
b,w
w) <- [(Int, Int, w)]
es]
              forall a. IntMap a -> IntMap a -> IntMap a
`IntMap.union` forall a. (Int -> a) -> IntSet -> IntMap a
IntMap.fromSet (\Int
_ -> []) IntSet
bs
{-
    e_b2a = IntMap.fromListWith IntMap.union [(b, IntMap.singleton a w) | (a,b,w) <- es]
              `IntMap.union` IntMap.fromList [(b, IntMap.empty) | b <- IntSet.toList bs]
-}

    ys0 :: (IntMap w, IntMap w)
    ys0 :: (IntMap w, IntMap w)
ys0 = ( forall a. (Int -> a) -> IntSet -> IntMap a
IntMap.fromSet (\Int
_ -> w
0) IntSet
as
          , forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
F.minimum IntMap (IntMap w)
e_b2a
          )
    m0 :: IntMap a
m0 = forall a. IntMap a
IntMap.empty

    loop
      :: IntMap Int -> (IntMap w, IntMap w) -> IntMap IntSet
      -> Maybe (w, IntMap Int, (IntMap w, IntMap w))
    loop :: IntMap Int
-> (IntMap w, IntMap w)
-> IntMap IntSet
-> Maybe (w, IntMap Int, (IntMap w, IntMap w))
loop IntMap Int
m_pre ys :: (IntMap w, IntMap w)
ys@(IntMap w
ysA,IntMap w
ysB) IntMap IntSet
g_eq
      | forall a. IntMap a -> Int
IntMap.size IntMap Int
m forall a. Eq a => a -> a -> Bool
== Int
n = forall a. a -> Maybe a
Just (forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
F.sum IntMap w
ysA forall a. Num a => a -> a -> a
+ forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
F.sum IntMap w
ysB, IntMap Int
m, (IntMap w, IntMap w)
ys)
      | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [w]
slacks = forall a. Maybe a
Nothing
      | Bool
otherwise = IntMap Int
-> (IntMap w, IntMap w)
-> IntMap IntSet
-> Maybe (w, IntMap Int, (IntMap w, IntMap w))
loop IntMap Int
m (IntMap w, IntMap w)
ys' IntMap IntSet
g_eq'
      where
        (IntMap Int
m, IntSet
l_a, IntSet
l_b) = IntSet
-> (Int -> IntSet) -> IntMap Int -> (IntMap Int, IntSet, IntSet)
maximumCardinalityMatching' IntSet
bs (IntMap IntSet
g_eq forall a. IntMap a -> Int -> a
!) IntMap Int
m_pre

        slacks :: [w]
        slacks :: [w]
slacks = [w
w forall a. Num a => a -> a -> a
- (IntMap w
ysAforall a. IntMap a -> Int -> a
!Int
a forall a. Num a => a -> a -> a
+ IntMap w
ysBforall a. IntMap a -> Int -> a
!Int
b) | Int
b <- IntSet -> [Int]
IntSet.toList IntSet
l_b, (Int
a,w
w) <- forall a. IntMap a -> [(Int, a)]
IntMap.toList (IntMap (IntMap w)
e_b2a forall a. IntMap a -> Int -> a
! Int
b), Int
a Int -> IntSet -> Bool
`IntSet.notMember` IntSet
l_a]

        slack :: w
        slack :: w
slack = forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum [w]
slacks

        -- augmenting dual solution
        ys' :: (IntMap w, IntMap w)
        ys' :: (IntMap w, IntMap w)
ys' = (forall a b. (Int -> a -> b) -> IntMap a -> IntMap b
IntMap.mapWithKey Int -> w -> w
f IntMap w
ysA, forall a b. (Int -> a -> b) -> IntMap a -> IntMap b
IntMap.mapWithKey Int -> w -> w
g IntMap w
ysB)
          where
            f :: Int -> w -> w
f Int
a w
val
              | Int
a Int -> IntSet -> Bool
`IntSet.notMember` IntSet
l_a = w
val forall a. Num a => a -> a -> a
+ w
slack
              | Bool
otherwise = w
val
            g :: Int -> w -> w
g Int
b w
val
              | Int
b Int -> IntSet -> Bool
`IntSet.notMember` IntSet
l_b = w
val forall a. Num a => a -> a -> a
- w
slack
              | Bool
otherwise = w
val

        g_eq' :: IntMap IntSet
        g_eq' :: IntMap IntSet
g_eq' = forall a b. (Int -> a -> b) -> IntMap a -> IntMap b
IntMap.mapWithKey Int -> IntSet -> IntSet
f IntMap IntSet
g_eq
          where
            f :: Int -> IntSet -> IntSet
f Int
b IntSet
as3
              | Int
b Int -> IntSet -> Bool
`IntSet.member` IntSet
l_b =
                  IntSet
as3 IntSet -> IntSet -> IntSet
`IntSet.union` [Int] -> IntSet
IntSet.fromAscList [Int
a | (Int
a,w
w) <- forall a. IntMap a -> [(Int, a)]
IntMap.toAscList (IntMap (IntMap w)
e_b2a forall a. IntMap a -> Int -> a
! Int
b), Int
a Int -> IntSet -> Bool
`IntSet.notMember` IntSet
l_a, w
w forall a. Eq a => a -> a -> Bool
== forall a b. (a, b) -> a
fst (IntMap w, IntMap w)
ys' forall a. IntMap a -> Int -> a
! Int
a forall a. Num a => a -> a -> a
+ forall a b. (a, b) -> b
snd (IntMap w, IntMap w)
ys' forall a. IntMap a -> Int -> a
! Int
b]
              | Bool
otherwise = IntSet
as3 IntSet -> IntSet -> IntSet
`IntSet.difference` IntSet
l_a

    equalityGraph :: (IntMap w, IntMap w) -> IntMap IntSet
    equalityGraph :: (IntMap w, IntMap w) -> IntMap IntSet
equalityGraph (IntMap w
ysA,IntMap w
ysB) = forall a b. (Int -> a -> b) -> IntMap a -> IntMap b
IntMap.mapWithKey Int -> IntMap w -> IntSet
f IntMap (IntMap w)
e_b2a
      where
        f :: Int -> IntMap w -> IntSet
f Int
b IntMap w
xs = [Int] -> IntSet
IntSet.fromAscList [Int
a | (Int
a,w
w) <- forall a. IntMap a -> [(Int, a)]
IntMap.toAscList IntMap w
xs, w
w forall a. Eq a => a -> a -> Bool
== IntMap w
ysAforall a. IntMap a -> Int -> a
!Int
a forall a. Num a => a -> a -> a
+ IntMap w
ysBforall a. IntMap a -> Int -> a
!Int
b]

-- -----------------------------------------------------------------------------

-- | Minimum cardinality edge cover of bipartite graph (A+B, E).
minimumCardinalityEdgeCover
  :: IntSet      -- ^ vertex set A
  -> IntSet      -- ^ vertex set B
  -> [(Int,Int)] -- ^ edges E⊆A×B
  -> Maybe (Set (Int,Int))
minimumCardinalityEdgeCover :: IntSet -> IntSet -> [(Int, Int)] -> Maybe (Set (Int, Int))
minimumCardinalityEdgeCover IntSet
as IntSet
bs [(Int, Int)]
es
  | forall a. IntMap a -> Int
IntMap.size IntMap Int
ca forall a. Eq a => a -> a -> Bool
/= IntSet -> Int
IntSet.size IntSet
as = forall a. Maybe a
Nothing
  | forall a. IntMap a -> Int
IntMap.size IntMap Int
cb forall a. Eq a => a -> a -> Bool
/= IntSet -> Int
IntSet.size IntSet
bs = forall a. Maybe a
Nothing
  | Bool
otherwise =
      case IntSet -> IntSet -> [(Int, Int)] -> IntMap Int
maximumCardinalityMatching IntSet
as IntSet
bs [(Int, Int)]
es of
        IntMap Int
m ->
          let ma :: IntSet
ma = forall a. IntMap a -> IntSet
IntMap.keysSet IntMap Int
m
              mb :: IntSet
mb = [Int] -> IntSet
IntSet.fromList forall a b. (a -> b) -> a -> b
$ forall a. IntMap a -> [a]
IntMap.elems IntMap Int
m
              m2 :: Set (Int, Int)
m2 = forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions
                   [ forall a. Ord a => [a] -> Set a
Set.fromList (forall a. IntMap a -> [(Int, a)]
IntMap.toList IntMap Int
m)
                   , forall a. Ord a => [a] -> Set a
Set.fromList [(Int
a,Int
b) | Int
a <- IntSet -> [Int]
IntSet.toList (IntSet
as IntSet -> IntSet -> IntSet
`IntSet.difference` IntSet
ma), let b :: Int
b = IntMap Int
ca forall a. IntMap a -> Int -> a
IntMap.! Int
a]
                   , forall a. Ord a => [a] -> Set a
Set.fromList [(Int
a,Int
b) | Int
b <- IntSet -> [Int]
IntSet.toList (IntSet
bs IntSet -> IntSet -> IntSet
`IntSet.difference` IntSet
mb), let a :: Int
a = IntMap Int
cb forall a. IntMap a -> Int -> a
IntMap.! Int
b]
                   ]
          in forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Set (Int, Int)
m2
  where
    ca :: IntMap Int
ca = forall a. [(Int, a)] -> IntMap a
IntMap.fromList [(Int, Int)]
es
    cb :: IntMap Int
cb = forall a. [(Int, a)] -> IntMap a
IntMap.fromList [(Int
b,Int
a) | (Int
a,Int
b) <- [(Int, Int)]
es]

-- | Minimum weight edge cover of bipartite graph (A+B, E).
minimumWeightEdgeCover
  :: forall w. (Real w)
  => IntSet        -- ^ vertex set A
  -> IntSet        -- ^ vertex set B
  -> [(Int,Int,w)] -- ^ edges E⊆A×B and their weights
  -> Maybe (Set (Int,Int))
minimumWeightEdgeCover :: forall w.
Real w =>
IntSet -> IntSet -> [(Int, Int, w)] -> Maybe (Set (Int, Int))
minimumWeightEdgeCover IntSet
as IntSet
bs [(Int, Int, w)]
es
  | forall a. IntMap a -> Int
IntMap.size IntMap (Int, w)
ca forall a. Eq a => a -> a -> Bool
/= IntSet -> Int
IntSet.size IntSet
as = forall a. Maybe a
Nothing
  | forall a. IntMap a -> Int
IntMap.size IntMap (Int, w)
cb forall a. Eq a => a -> a -> Bool
/= IntSet -> Int
IntSet.size IntSet
bs = forall a. Maybe a
Nothing
  | Bool
otherwise =
      case forall w.
Real w =>
IntSet -> IntSet -> [(Int, Int, w)] -> (w, IntMap Int)
maximumWeightMatching IntSet
as' IntSet
bs' [(Int, Int, w)]
es' of
        (w
_, IntMap Int
m) ->
          let ma :: IntSet
ma = forall a. IntMap a -> IntSet
IntMap.keysSet IntMap Int
m
              mb :: IntSet
mb = [Int] -> IntSet
IntSet.fromList forall a b. (a -> b) -> a -> b
$ forall a. IntMap a -> [a]
IntMap.elems IntMap Int
m
              m2 :: Set (Int, Int)
m2 = forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions
                   [ forall a. Ord a => [a] -> Set a
Set.fromList (forall a. IntMap a -> [(Int, a)]
IntMap.toList IntMap Int
m)
                   , forall a. Ord a => [a] -> Set a
Set.fromList [(Int
a,Int
b) | Int
a <- IntSet -> [Int]
IntSet.toList (IntSet
as IntSet -> IntSet -> IntSet
`IntSet.difference` IntSet
ma), let (Int
b,w
_) = IntMap (Int, w)
ca forall a. IntMap a -> Int -> a
IntMap.! Int
a]
                   , forall a. Ord a => [a] -> Set a
Set.fromList [(Int
a,Int
b) | Int
b <- IntSet -> [Int]
IntSet.toList (IntSet
bs IntSet -> IntSet -> IntSet
`IntSet.difference` IntSet
mb), let (Int
a,w
_) = IntMap (Int, w)
cb forall a. IntMap a -> Int -> a
IntMap.! Int
b]
                   , forall a. Ord a => [a] -> Set a
Set.fromList [(Int
a,Int
b) | (Int
a,Int
b,w
w) <- [(Int, Int, w)]
es, w
w forall a. Ord a => a -> a -> Bool
< w
0]
                   ]
          in forall a. a -> Maybe a
Just Set (Int, Int)
m2
  where
    minOnSnd :: (a, a) -> (a, a) -> (a, a)
minOnSnd xw1 :: (a, a)
xw1@(a
_,a
w1) xw2 :: (a, a)
xw2@(a
_,a
w2) = if a
w1 forall a. Ord a => a -> a -> Bool
<= a
w2 then (a, a)
xw1 else (a, a)
xw2
    ca :: IntMap (Int, w)
ca = forall a. (a -> a -> a) -> [(Int, a)] -> IntMap a
IntMap.fromListWith forall {a} {a}. Ord a => (a, a) -> (a, a) -> (a, a)
minOnSnd [(Int
a,(Int
b,w
w)) | (Int
a,Int
b,w
w) <- [(Int, Int, w)]
es]
    cb :: IntMap (Int, w)
cb = forall a. (a -> a -> a) -> [(Int, a)] -> IntMap a
IntMap.fromListWith forall {a} {a}. Ord a => (a, a) -> (a, a) -> (a, a)
minOnSnd [(Int
b,(Int
a,w
w)) | (Int
a,Int
b,w
w) <- [(Int, Int, w)]
es]
    as' :: IntSet
as' = [Int] -> IntSet
IntSet.fromAscList [Int
a | (Int
a,(Int
_,w
w)) <- forall a. IntMap a -> [(Int, a)]
IntMap.toAscList IntMap (Int, w)
ca, w
w forall a. Ord a => a -> a -> Bool
>= w
0]
    bs' :: IntSet
bs' = [Int] -> IntSet
IntSet.fromAscList [Int
b | (Int
b,(Int
_,w
w)) <- forall a. IntMap a -> [(Int, a)]
IntMap.toAscList IntMap (Int, w)
cb, w
w forall a. Ord a => a -> a -> Bool
>= w
0]
    es' :: [(Int, Int, w)]
es' = [(Int
a, Int
b, (forall a b. (a, b) -> b
snd (IntMap (Int, w)
ca forall a. IntMap a -> Int -> a
IntMap.! Int
a) forall a. Num a => a -> a -> a
+ forall a b. (a, b) -> b
snd (IntMap (Int, w)
cb forall a. IntMap a -> Int -> a
IntMap.! Int
b)) forall a. Num a => a -> a -> a
- w
w) | (Int
a,Int
b,w
w) <- [(Int, Int, w)]
es, w
w forall a. Ord a => a -> a -> Bool
>= w
0]

-- | Minimum weight edge cover of complete bipartite graph (A+B, A×B).
minimumWeightEdgeCoverComplete
  :: forall w. (Real w)
  => IntSet            -- ^ vertex set A
  -> IntSet            -- ^ vertex set B
  -> (Int -> Int -> w) -- ^ weight of edges A×B
  -> Maybe (Set (Int,Int))
minimumWeightEdgeCoverComplete :: forall w.
Real w =>
IntSet -> IntSet -> (Int -> Int -> w) -> Maybe (Set (Int, Int))
minimumWeightEdgeCoverComplete IntSet
as IntSet
bs Int -> Int -> w
w
  | forall a. IntMap a -> Int
IntMap.size IntMap (Int, w)
ca forall a. Eq a => a -> a -> Bool
/= IntSet -> Int
IntSet.size IntSet
as = forall a. Maybe a
Nothing
  | forall a. IntMap a -> Int
IntMap.size IntMap (Int, w)
cb forall a. Eq a => a -> a -> Bool
/= IntSet -> Int
IntSet.size IntSet
bs = forall a. Maybe a
Nothing
  | Bool
otherwise =
      case forall w.
Real w =>
IntSet -> IntSet -> [(Int, Int, w)] -> (w, IntMap Int)
maximumWeightMatching IntSet
as' IntSet
bs' [(Int, Int, w)]
es' of
        (w
_, IntMap Int
m) ->
          let ma :: IntSet
ma = forall a. IntMap a -> IntSet
IntMap.keysSet IntMap Int
m
              mb :: IntSet
mb = [Int] -> IntSet
IntSet.fromList forall a b. (a -> b) -> a -> b
$ forall a. IntMap a -> [a]
IntMap.elems IntMap Int
m
              m2 :: Set (Int, Int)
m2 = forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions
                   [ forall a. Ord a => [a] -> Set a
Set.fromList (forall a. IntMap a -> [(Int, a)]
IntMap.toList IntMap Int
m)
                   , forall a. Ord a => [a] -> Set a
Set.fromList [(Int
a,Int
b) | Int
a <- IntSet -> [Int]
IntSet.toList (IntSet
as IntSet -> IntSet -> IntSet
`IntSet.difference` IntSet
ma), let (Int
b,w
_) = IntMap (Int, w)
ca forall a. IntMap a -> Int -> a
IntMap.! Int
a]
                   , forall a. Ord a => [a] -> Set a
Set.fromList [(Int
a,Int
b) | Int
b <- IntSet -> [Int]
IntSet.toList (IntSet
bs IntSet -> IntSet -> IntSet
`IntSet.difference` IntSet
mb), let (Int
a,w
_) = IntMap (Int, w)
cb forall a. IntMap a -> Int -> a
IntMap.! Int
b]
                   , forall a. Ord a => [a] -> Set a
Set.fromList [(Int
a,Int
b) | Int
a <- IntSet -> [Int]
IntSet.toList IntSet
as, Int
b <- IntSet -> [Int]
IntSet.toList IntSet
bs, let w' :: w
w' = Int -> Int -> w
w Int
a Int
b, w
w' forall a. Ord a => a -> a -> Bool
< w
0]
                   ]
          in forall a. a -> Maybe a
Just Set (Int, Int)
m2
  where
    minOnSnd :: (a, a) -> (a, a) -> (a, a)
minOnSnd xw1 :: (a, a)
xw1@(a
_,a
w1) xw2 :: (a, a)
xw2@(a
_,a
w2) = if a
w1 forall a. Ord a => a -> a -> Bool
<= a
w2 then (a, a)
xw1 else (a, a)
xw2
    ca :: IntMap (Int, w)
ca = forall a. (a -> a -> a) -> [(Int, a)] -> IntMap a
IntMap.fromListWith forall {a} {a}. Ord a => (a, a) -> (a, a) -> (a, a)
minOnSnd [(Int
a, (Int
b, Int -> Int -> w
w Int
a Int
b)) | Int
a <- IntSet -> [Int]
IntSet.toList IntSet
as, Int
b <- IntSet -> [Int]
IntSet.toList IntSet
bs]
    cb :: IntMap (Int, w)
cb = forall a. (a -> a -> a) -> [(Int, a)] -> IntMap a
IntMap.fromListWith forall {a} {a}. Ord a => (a, a) -> (a, a) -> (a, a)
minOnSnd [(Int
b, (Int
a, Int -> Int -> w
w Int
a Int
b)) | Int
a <- IntSet -> [Int]
IntSet.toList IntSet
as, Int
b <- IntSet -> [Int]
IntSet.toList IntSet
bs]
    as' :: IntSet
as' = [Int] -> IntSet
IntSet.fromAscList [Int
a | (Int
a,(Int
_,w
w)) <- forall a. IntMap a -> [(Int, a)]
IntMap.toAscList IntMap (Int, w)
ca, w
w forall a. Ord a => a -> a -> Bool
>= w
0]
    bs' :: IntSet
bs' = [Int] -> IntSet
IntSet.fromAscList [Int
b | (Int
b,(Int
_,w
w)) <- forall a. IntMap a -> [(Int, a)]
IntMap.toAscList IntMap (Int, w)
cb, w
w forall a. Ord a => a -> a -> Bool
>= w
0]
    es' :: [(Int, Int, w)]
es' = [ (Int
a, Int
b, (forall a b. (a, b) -> b
snd (IntMap (Int, w)
ca forall a. IntMap a -> Int -> a
IntMap.! Int
a) forall a. Num a => a -> a -> a
+ forall a b. (a, b) -> b
snd (IntMap (Int, w)
cb forall a. IntMap a -> Int -> a
IntMap.! Int
b)) forall a. Num a => a -> a -> a
- w
w')
          | Int
a <- IntSet -> [Int]
IntSet.toList IntSet
as, Int
b <- IntSet -> [Int]
IntSet.toList IntSet
bs, let w' :: w
w' = Int -> Int -> w
w Int
a Int
b, w
w' forall a. Ord a => a -> a -> Bool
>= w
0 ]

-- -----------------------------------------------------------------------------