module HGraph.Directed.Connectivity.Flow
       ( isWellLinkedTo
       , maxDisjointPaths
       , maxArcDisjointPaths
       , maxFlow
       , maxFlowValue
       , minCut
       , minCutI
       , separableSets
       , separableSetsI
       , cuttableSubsetI
       , findWellLinkedSetI
       )
where

import Data.List
import HGraph.Directed
import HGraph.Directed.Connectivity.Basic
import HGraph.Utils
import qualified Data.Map as M
import qualified Data.Set as S
import Data.Maybe

maxFlow :: (Ord a, Adjacency t, DirectedGraph t) => t a -> a -> a -> M.Map (a, a) Bool
maxFlow :: forall a (t :: * -> *).
(Ord a, Adjacency t, DirectedGraph t) =>
t a -> a -> a -> Map (a, a) Bool
maxFlow t a
d a
s a
t = Map (a, a) Bool -> Map (a, a) Bool
maxFlow' (Map (a, a) Bool -> Map (a, a) Bool)
-> Map (a, a) Bool -> Map (a, a) Bool
forall a b. (a -> b) -> a -> b
$ ((a, a) -> Map (a, a) Bool -> Map (a, a) Bool)
-> Map (a, a) Bool -> [(a, a)] -> Map (a, a) Bool
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(a, a)
a -> (a, a) -> Bool -> Map (a, a) Bool -> Map (a, a) Bool
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert (a, a)
a Bool
False) Map (a, a) Bool
forall k a. Map k a
M.empty (t a -> [(a, a)]
forall a. t a -> [(a, a)]
forall (t :: * -> *) a. DirectedGraph t => t a -> [(a, a)]
arcs t a
d)
  where
    maxFlow' :: Map (a, a) Bool -> Map (a, a) Bool
maxFlow' Map (a, a) Bool
flow 
      | [a] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
p = Map (a, a) Bool
flow
      | Bool
otherwise = Map (a, a) Bool -> Map (a, a) Bool
maxFlow' Map (a, a) Bool
flow'
      where
        p :: [a]
p = t a -> a -> a -> Map (a, a) Bool -> [a]
forall {t :: * -> *} {a}.
(Adjacency t, Ord a) =>
t a -> a -> a -> Map (a, a) Bool -> [a]
shortestPathResidual t a
d a
s a
t Map (a, a) Bool
flow
        flow' :: Map (a, a) Bool
flow' = ((a, a) -> Map (a, a) Bool -> Map (a, a) Bool)
-> Map (a, a) Bool -> [(a, a)] -> Map (a, a) Bool
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((Bool -> Bool) -> (a, a) -> Map (a, a) Bool -> Map (a, a) Bool
forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
M.adjust Bool -> Bool
not) Map (a, a) Bool
flow ([(a, a)] -> Map (a, a) Bool) -> [(a, a)] -> Map (a, a) Bool
forall a b. (a -> b) -> a -> b
$ [a] -> [a] -> [(a, a)]
forall a b. [a] -> [b] -> [(a, b)]
zip [a]
p ([a] -> [a]
forall a. HasCallStack => [a] -> [a]
tail [a]
p)

maxFlowValue :: t a -> a -> a -> Int
maxFlowValue t a
d a
s a
t = Map (a, a) Bool -> Int
forall k a. Map k a -> Int
M.size (Map (a, a) Bool -> Int) -> Map (a, a) Bool -> Int
forall a b. (a -> b) -> a -> b
$ ((a, a) -> Bool -> Bool) -> Map (a, a) Bool -> Map (a, a) Bool
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
M.filterWithKey (\(a, a)
k Bool
f -> Bool
f Bool -> Bool -> Bool
&& ((a, a) -> a
forall a b. (a, b) -> b
snd (a, a)
k a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
t)) (Map (a, a) Bool -> Map (a, a) Bool)
-> Map (a, a) Bool -> Map (a, a) Bool
forall a b. (a -> b) -> a -> b
$ t a -> a -> a -> Map (a, a) Bool
forall a (t :: * -> *).
(Ord a, Adjacency t, DirectedGraph t) =>
t a -> a -> a -> Map (a, a) Bool
maxFlow t a
d a
s a
t

shortestPathResidual :: t a -> a -> a -> Map (a, a) Bool -> [a]
shortestPathResidual t a
d a
s a
t Map (a, a) Bool
flow = Set a -> Map a a -> [a]
path (a -> Set a
forall a. a -> Set a
S.singleton a
s) Map a a
forall k a. Map k a
M.empty
  where
    path :: Set a -> Map a a -> [a]
path Set a
active Map a a
preds
      | a
t a -> Map a a -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`M.member` Map a a
preds = [a] -> [a]
forall a. [a] -> [a]
reverse ([a] -> [a]) -> [a] -> [a]
forall a b. (a -> b) -> a -> b
$ Map a a -> a -> [a]
makePath Map a a
preds a
t
      | Set a -> Bool
forall a. Set a -> Bool
S.null Set a
active = []
      | Bool
otherwise = Set a -> Map a a -> [a]
path ([a] -> Set a
forall a. Ord a => [a] -> Set a
S.fromList ([a] -> Set a) -> [a] -> Set a
forall a b. (a -> b) -> a -> b
$ Map a a -> [a]
forall k a. Map k a -> [k]
M.keys Map a a
newPred) (Map a a
preds Map a a -> Map a a -> Map a a
forall k a. Ord k => Map k a -> Map k a -> Map k a
`M.union` Map a a
newPred)
        where
          newPred :: Map a a
newPred = [(a, a)] -> Map a a
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(a, a)] -> Map a a) -> [(a, a)] -> Map a a
forall a b. (a -> b) -> a -> b
$ [ (a
u,a
v)
                                 | a
v <- Set a -> [a]
forall a. Set a -> [a]
S.toList Set a
active
                                 , a
u <- t a -> a -> [a]
forall a. t a -> a -> [a]
forall (t :: * -> *) a. Adjacency t => t a -> a -> [a]
outneighbors t a
d a
v
                                 , (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Map (a, a) Bool
flow Map (a, a) Bool -> (a, a) -> Bool
forall k a. Ord k => Map k a -> k -> a
M.! (a
v,a
u)) Bool -> Bool -> Bool
&& (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ a
u a -> Map a a -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`M.member` Map a a
preds) Bool -> Bool -> Bool
&& a
u a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
s
                                 ]
                                 [(a, a)] -> [(a, a)] -> [(a, a)]
forall a. [a] -> [a] -> [a]
++
                                 [ (a
u,a
v)
                                 | a
v <- Set a -> [a]
forall a. Set a -> [a]
S.toList Set a
active
                                 , a
u <- t a -> a -> [a]
forall a. t a -> a -> [a]
forall (t :: * -> *) a. Adjacency t => t a -> a -> [a]
inneighbors t a
d a
v
                                 , Map (a, a) Bool
flow Map (a, a) Bool -> (a, a) -> Bool
forall k a. Ord k => Map k a -> k -> a
M.! (a
u, a
v) Bool -> Bool -> Bool
&& (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ a
u a -> Map a a -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`M.member` Map a a
preds Bool -> Bool -> Bool
&& a
u a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
s)
                                 ]
    makePath :: Map a a -> a -> [a]
makePath Map a a
preds a
v
      | a
v a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
s = [a
v]
      | Bool
otherwise = a
v a -> [a] -> [a]
forall a. a -> [a] -> [a]
: Map a a -> a -> [a]
makePath Map a a
preds (Map a a
preds Map a a -> a -> a
forall k a. Ord k => Map k a -> k -> a
M.! a
v)


maxArcDisjointPaths :: (Mutable t, DirectedGraph t, Adjacency t, Integral a) => t a -> a -> a -> [[a]]
maxArcDisjointPaths :: forall (t :: * -> *) a.
(Mutable t, DirectedGraph t, Adjacency t, Integral a) =>
t a -> a -> a -> [[a]]
maxArcDisjointPaths t a
d a
s a
t = [a
s a -> [a] -> [a]
forall a. a -> [a] -> [a]
: a -> [a]
makePath a
v | a
v <- t a -> a -> [a]
forall a. t a -> a -> [a]
forall (t :: * -> *) a. Adjacency t => t a -> a -> [a]
outneighbors t a
d a
s, a
v a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
t Bool -> Bool -> Bool
|| a
v a -> Map a a -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`M.member` Map a a
succs]
  where
    succs :: Map a a
succs = [(a, a)] -> Map a a
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(a, a)] -> Map a a) -> [(a, a)] -> Map a a
forall a b. (a -> b) -> a -> b
$ Map (a, a) Bool -> [(a, a)]
forall k a. Map k a -> [k]
M.keys (Map (a, a) Bool -> [(a, a)]) -> Map (a, a) Bool -> [(a, a)]
forall a b. (a -> b) -> a -> b
$ (Bool -> Bool) -> Map (a, a) Bool -> Map (a, a) Bool
forall a k. (a -> Bool) -> Map k a -> Map k a
M.filter (Bool -> Bool
forall a. a -> a
id) (Map (a, a) Bool -> Map (a, a) Bool)
-> Map (a, a) Bool -> Map (a, a) Bool
forall a b. (a -> b) -> a -> b
$ t a -> a -> a -> Map (a, a) Bool
forall a (t :: * -> *).
(Ord a, Adjacency t, DirectedGraph t) =>
t a -> a -> a -> Map (a, a) Bool
maxFlow t a
d a
s a
t
    makePath :: a -> [a]
makePath a
v
      | a
v a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
t = [a
t]
      | Bool
otherwise = a
v a -> [a] -> [a]
forall a. a -> [a] -> [a]
: a -> [a]
makePath (Map a a
succs Map a a -> a -> a
forall k a. Ord k => Map k a -> k -> a
M.! a
v)

maxDisjointPaths :: (Mutable t, DirectedGraph t, Adjacency t, Integral a) => t a -> a -> a -> [[a]]
maxDisjointPaths :: forall (t :: * -> *) a.
(Mutable t, DirectedGraph t, Adjacency t, Integral a) =>
t a -> a -> a -> [[a]]
maxDisjointPaths t a
d a
s a
t = [a
s a -> [a] -> [a]
forall a. a -> [a] -> [a]
: a -> [a]
makePath a
v | a
v <- t a -> a -> [a]
forall a. t a -> a -> [a]
forall (t :: * -> *) a. Adjacency t => t a -> a -> [a]
outneighbors t a
d a
s, (a
2a -> a -> a
forall a. Num a => a -> a -> a
*a
v a -> a -> a
forall a. Num a => a -> a -> a
+ a
1) a -> Map a a -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`M.member` Map a a
succs]
  where
    d' :: t a
d'  = (a -> t a -> t a) -> t a -> [a] -> t a
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr a -> t a -> t a
forall a. a -> t a -> t a
forall (t :: * -> *) a. Mutable t => a -> t a -> t a
addVertex (t a -> t a
forall a. t a -> t a
forall (t :: * -> *) a. DirectedGraph t => t a -> t a
empty t a
d) ([[a]] -> [a]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[a
2a -> a -> a
forall a. Num a => a -> a -> a
*a
v, a
2a -> a -> a
forall a. Num a => a -> a -> a
*a
va -> a -> a
forall a. Num a => a -> a -> a
+a
1] | a
v <- t a -> [a]
forall a. t a -> [a]
forall (t :: * -> *) a. DirectedGraph t => t a -> [a]
vertices t a
d])
    d'' :: t a
d'' = ((a, a) -> t a -> t a) -> t a -> [(a, a)] -> t a
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (a, a) -> t a -> t a
forall a. (a, a) -> t a -> t a
forall (t :: * -> *) a. Mutable t => (a, a) -> t a -> t a
addArc t a
d' ([(a
2a -> a -> a
forall a. Num a => a -> a -> a
*a
v, a
2a -> a -> a
forall a. Num a => a -> a -> a
*a
v a -> a -> a
forall a. Num a => a -> a -> a
+ a
1) | a
v <- t a -> [a]
forall a. t a -> [a]
forall (t :: * -> *) a. DirectedGraph t => t a -> [a]
vertices t a
d] [(a, a)] -> [(a, a)] -> [(a, a)]
forall a. [a] -> [a] -> [a]
++ [(a
2a -> a -> a
forall a. Num a => a -> a -> a
*a
va -> a -> a
forall a. Num a => a -> a -> a
+a
1, a
2a -> a -> a
forall a. Num a => a -> a -> a
*a
u) | (a
v,a
u) <- t a -> [(a, a)]
forall a. t a -> [(a, a)]
forall (t :: * -> *) a. DirectedGraph t => t a -> [(a, a)]
arcs t a
d])
    succs :: Map a a
succs = [(a, a)] -> Map a a
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(a, a)] -> Map a a) -> [(a, a)] -> Map a a
forall a b. (a -> b) -> a -> b
$ Map (a, a) Bool -> [(a, a)]
forall k a. Map k a -> [k]
M.keys (Map (a, a) Bool -> [(a, a)]) -> Map (a, a) Bool -> [(a, a)]
forall a b. (a -> b) -> a -> b
$ (Bool -> Bool) -> Map (a, a) Bool -> Map (a, a) Bool
forall a k. (a -> Bool) -> Map k a -> Map k a
M.filter (Bool -> Bool
forall a. a -> a
id) (Map (a, a) Bool -> Map (a, a) Bool)
-> Map (a, a) Bool -> Map (a, a) Bool
forall a b. (a -> b) -> a -> b
$ t a -> a -> a -> Map (a, a) Bool
forall a (t :: * -> *).
(Ord a, Adjacency t, DirectedGraph t) =>
t a -> a -> a -> Map (a, a) Bool
maxFlow t a
d'' (a
2a -> a -> a
forall a. Num a => a -> a -> a
*a
sa -> a -> a
forall a. Num a => a -> a -> a
+a
1) (a
2a -> a -> a
forall a. Num a => a -> a -> a
*a
t)
    makePath :: a -> [a]
makePath a
v
      | a
v a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
t = [a
t]
      | Bool
otherwise = a
v a -> [a] -> [a]
forall a. a -> [a] -> [a]
: a -> [a]
makePath ((Map a a
succs Map a a -> a -> a
forall k a. Ord k => Map k a -> k -> a
M.! (a
2a -> a -> a
forall a. Num a => a -> a -> a
*a
v a -> a -> a
forall a. Num a => a -> a -> a
+ a
1)) a -> a -> a
forall a. Integral a => a -> a -> a
`div` a
2)

minCut :: (Mutable t, DirectedGraph t, Adjacency t, Eq a) => t a -> a -> a -> [a]
minCut :: forall (t :: * -> *) a.
(Mutable t, DirectedGraph t, Adjacency t, Eq a) =>
t a -> a -> a -> [a]
minCut t a
d a
s a
t = (Int -> a) -> [Int] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (Map Int a
iToV Map Int a -> Int -> a
forall k a. Ord k => Map k a -> k -> a
M.!) ([Int] -> [a]) -> [Int] -> [a]
forall a b. (a -> b) -> a -> b
$ t Int -> Int -> Int -> [Int]
forall (t :: * -> *) a.
(Mutable t, DirectedGraph t, Adjacency t, Integral a) =>
t a -> a -> a -> [a]
minCutI t Int
di Int
si Int
ti
  where
    (t Int
di, [(Int, a)]
itova) = t a -> (t Int, [(Int, a)])
forall a. t a -> (t Int, [(Int, a)])
forall (t :: * -> *) a.
DirectedGraph t =>
t a -> (t Int, [(Int, a)])
linearizeVertices t a
d
    iToV :: Map Int a
iToV = [(Int, a)] -> Map Int a
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(Int, a)]
itova
    Just Int
si = ((Int, a) -> Int) -> Maybe (Int, a) -> Maybe Int
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int, a) -> Int
forall a b. (a, b) -> a
fst (Maybe (Int, a) -> Maybe Int) -> Maybe (Int, a) -> Maybe Int
forall a b. (a -> b) -> a -> b
$ ((Int, a) -> Bool) -> [(Int, a)] -> Maybe (Int, a)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((a -> a -> Bool
forall a. Eq a => a -> a -> Bool
==a
s) (a -> Bool) -> ((Int, a) -> a) -> (Int, a) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, a) -> a
forall a b. (a, b) -> b
snd) [(Int, a)]
itova
    Just Int
ti = ((Int, a) -> Int) -> Maybe (Int, a) -> Maybe Int
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int, a) -> Int
forall a b. (a, b) -> a
fst (Maybe (Int, a) -> Maybe Int) -> Maybe (Int, a) -> Maybe Int
forall a b. (a -> b) -> a -> b
$ ((Int, a) -> Bool) -> [(Int, a)] -> Maybe (Int, a)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((a -> a -> Bool
forall a. Eq a => a -> a -> Bool
==a
t) (a -> Bool) -> ((Int, a) -> a) -> (Int, a) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, a) -> a
forall a b. (a, b) -> b
snd) [(Int, a)]
itova

minCutI :: (Mutable t, DirectedGraph t, Adjacency t, Integral a) => t a -> a -> a -> [a]
minCutI :: forall (t :: * -> *) a.
(Mutable t, DirectedGraph t, Adjacency t, Integral a) =>
t a -> a -> a -> [a]
minCutI t a
d a
s a
t = [a
u a -> a -> a
forall a. Integral a => a -> a -> a
`div` a
2 | a
v <- Set a -> [a]
forall a. Set a -> [a]
S.toList (Set a -> [a]) -> Set a -> [a]
forall a b. (a -> b) -> a -> b
$ Set a
reachS, a
u <- t a -> a -> [a]
forall a. t a -> a -> [a]
forall (t :: * -> *) a. Adjacency t => t a -> a -> [a]
outneighbors t a
d'' a
v, Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ a
u a -> Set a -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set a
reachS]
  where
    d' :: t a
d'  = (a -> t a -> t a) -> t a -> [a] -> t a
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr a -> t a -> t a
forall a. a -> t a -> t a
forall (t :: * -> *) a. Mutable t => a -> t a -> t a
addVertex (t a -> t a
forall a. t a -> t a
forall (t :: * -> *) a. DirectedGraph t => t a -> t a
empty t a
d) ([[a]] -> [a]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[a
2a -> a -> a
forall a. Num a => a -> a -> a
*a
v, a
2a -> a -> a
forall a. Num a => a -> a -> a
*a
va -> a -> a
forall a. Num a => a -> a -> a
+a
1] | a
v <- t a -> [a]
forall a. t a -> [a]
forall (t :: * -> *) a. DirectedGraph t => t a -> [a]
vertices t a
d])
    d'' :: t a
d'' = ((a, a) -> t a -> t a) -> t a -> [(a, a)] -> t a
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (a, a) -> t a -> t a
forall a. (a, a) -> t a -> t a
forall (t :: * -> *) a. Mutable t => (a, a) -> t a -> t a
addArc t a
d' ([(a
2a -> a -> a
forall a. Num a => a -> a -> a
*a
v, a
2a -> a -> a
forall a. Num a => a -> a -> a
*a
v a -> a -> a
forall a. Num a => a -> a -> a
+ a
1) | a
v <- t a -> [a]
forall a. t a -> [a]
forall (t :: * -> *) a. DirectedGraph t => t a -> [a]
vertices t a
d] [(a, a)] -> [(a, a)] -> [(a, a)]
forall a. [a] -> [a] -> [a]
++ [(a
2a -> a -> a
forall a. Num a => a -> a -> a
*a
va -> a -> a
forall a. Num a => a -> a -> a
+a
1, a
2a -> a -> a
forall a. Num a => a -> a -> a
*a
u) | (a
v,a
u) <- t a -> [(a, a)]
forall a. t a -> [(a, a)]
forall (t :: * -> *) a. DirectedGraph t => t a -> [(a, a)]
arcs t a
d])
    flow :: Map (a, a) Bool
flow = (Bool -> Bool) -> Map (a, a) Bool -> Map (a, a) Bool
forall a k. (a -> Bool) -> Map k a -> Map k a
M.filter (Bool -> Bool
forall a. a -> a
id) (Map (a, a) Bool -> Map (a, a) Bool)
-> Map (a, a) Bool -> Map (a, a) Bool
forall a b. (a -> b) -> a -> b
$ t a -> a -> a -> Map (a, a) Bool
forall a (t :: * -> *).
(Ord a, Adjacency t, DirectedGraph t) =>
t a -> a -> a -> Map (a, a) Bool
maxFlow t a
d'' (a
2a -> a -> a
forall a. Num a => a -> a -> a
*a
sa -> a -> a
forall a. Num a => a -> a -> a
+a
1) (a
2a -> a -> a
forall a. Num a => a -> a -> a
*a
t)
    reachS :: Set a
reachS = Set a -> Set a -> Set a
bfs (a -> Set a
forall a. a -> Set a
S.singleton (a
2a -> a -> a
forall a. Num a => a -> a -> a
*a
sa -> a -> a
forall a. Num a => a -> a -> a
+a
1)) (a -> Set a
forall a. a -> Set a
S.singleton (a
2a -> a -> a
forall a. Num a => a -> a -> a
*a
sa -> a -> a
forall a. Num a => a -> a -> a
+a
1))
    bfs :: Set a -> Set a -> Set a
bfs Set a
active Set a
reached
      | Set a -> Bool
forall a. Set a -> Bool
S.null Set a
active = Set a
reached
      | Bool
otherwise = Set a -> Set a -> Set a
bfs Set a
new (Set a -> Set a -> Set a
forall a. Ord a => Set a -> Set a -> Set a
S.union Set a
reached Set a
new)
        where
          new :: Set a
new = [a] -> Set a
forall a. Ord a => [a] -> Set a
S.fromList ([a] -> Set a) -> [a] -> Set a
forall a b. (a -> b) -> a -> b
$ [ a
u
                             | a
v <- Set a -> [a]
forall a. Set a -> [a]
S.toList Set a
active
                             , a
u <- t a -> a -> [a]
forall a. t a -> a -> [a]
forall (t :: * -> *) a. Adjacency t => t a -> a -> [a]
outneighbors t a
d'' a
v
                             , (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ (a
v,a
u) (a, a) -> Map (a, a) Bool -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`M.member` Map (a, a) Bool
flow) Bool -> Bool -> Bool
&& (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ a
u a -> Set a -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set a
reached)
                             ]
                             [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++
                             [ a
u
                             | a
v <- Set a -> [a]
forall a. Set a -> [a]
S.toList Set a
active
                             , a
u <- t a -> a -> [a]
forall a. t a -> a -> [a]
forall (t :: * -> *) a. Adjacency t => t a -> a -> [a]
inneighbors t a
d'' a
v
                             , (a
u,a
v) (a, a) -> Map (a, a) Bool -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`M.member` Map (a, a) Bool
flow Bool -> Bool -> Bool
&& (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ a
u a -> Set a -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set a
reached)
                             ]

-- | Is the vertex set `A` well-linked to the vertex set `B`?
-- That is, is there, for every subset `A'` of `A`, some subset `B'` of `B` of the same size such that
-- there is a linkage from `A'` to `B'` containing as many paths as there are vertices in `A'`?
isWellLinkedTo :: t k -> [k] -> [k] -> Bool
isWellLinkedTo t k
d [k]
va [k]
vb = Maybe ([Int], [Int]) -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe ([Int], [Int]) -> Bool) -> Maybe ([Int], [Int]) -> Bool
forall a b. (a -> b) -> a -> b
$ t k -> [k] -> [k] -> Maybe ([Int], [Int])
forall {k} {t :: * -> *}.
(Ord k, Mutable t, DirectedGraph t, Adjacency t) =>
t k -> [k] -> [k] -> Maybe ([Int], [Int])
separableSets t k
d [k]
va [k]
vb

-- | Search for a subset `A'` of `va` and a subset `B'` of `vb` of the same size
-- such that no linkage from `A'` to `B'` connecting all vertices in both sets exist.
separableSets :: t k -> [k] -> [k] -> Maybe ([Int], [Int])
separableSets t k
d [k]
va [k]
vb = t Int -> [Int] -> [Int] -> Int -> Maybe ([Int], [Int])
forall {b} {t :: * -> *}.
(Mutable t, DirectedGraph t, Integral b, Adjacency t) =>
t b -> [b] -> [b] -> Int -> Maybe ([b], [b])
separableSetsI t Int
di [Int]
vai [Int]
vbi Int
k
  where
    (t Int
di, [(Int, k)]
itova) = t k -> (t Int, [(Int, k)])
forall a. t a -> (t Int, [(Int, a)])
forall (t :: * -> *) a.
DirectedGraph t =>
t a -> (t Int, [(Int, a)])
linearizeVertices t k
d
    vToI :: Map k Int
vToI = [(k, Int)] -> Map k Int
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(k, Int)] -> Map k Int) -> [(k, Int)] -> Map k Int
forall a b. (a -> b) -> a -> b
$ ((Int, k) -> (k, Int)) -> [(Int, k)] -> [(k, Int)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Int
i,k
v) -> (k
v,Int
i)) [(Int, k)]
itova
    vai :: [Int]
vai = [ Map k Int
vToI Map k Int -> k -> Int
forall k a. Ord k => Map k a -> k -> a
M.! k
v | k
v <- [k]
va]
    vbi :: [Int]
vbi = [ Map k Int
vToI Map k Int -> k -> Int
forall k a. Ord k => Map k a -> k -> a
M.! k
v | k
v <- [k]
vb]
    k :: Int
k = [Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
vai
    
separableSetsI :: t b -> [b] -> [b] -> Int -> Maybe ([b], [b])
separableSetsI t b
di [b]
va [b]
vb Int
k =
  let splitD :: t b
splitD = t b -> t b
forall {t :: * -> *} {a}.
(Mutable t, DirectedGraph t, Num a) =>
t a -> t a
splitVertices t b
di
      va' :: [b]
va' = (b -> b) -> [b] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map (b
2b -> b -> b
forall a. Num a => a -> a -> a
*) [b]
va
      vb' :: [b]
vb' = (b -> b) -> [b] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map (\b
v -> b
2b -> b -> b
forall a. Num a => a -> a -> a
*b
v b -> b -> b
forall a. Num a => a -> a -> a
+ b
1) [b]
vb
      vbSet :: Set b
vbSet = [b] -> Set b
forall a. Ord a => [a] -> Set a
S.fromList [b]
vb'
  in (([b], [b]) -> ([b], [b])) -> Maybe ([b], [b]) -> Maybe ([b], [b])
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\([b]
a,[b]
b) -> 
             ( (b -> b) -> [b] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map (\b
v -> b
v b -> b -> b
forall a. Integral a => a -> a -> a
`div` b
2) [b]
a
             , (b -> b) -> [b] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map (\b
v -> (b
v b -> b -> b
forall a. Num a => a -> a -> a
- b
1) b -> b -> b
forall a. Integral a => a -> a -> a
`div` b
2) [b]
b
             )
          ) (Maybe ([b], [b]) -> Maybe ([b], [b]))
-> Maybe ([b], [b]) -> Maybe ([b], [b])
forall a b. (a -> b) -> a -> b
$
          t b -> [b] -> [b] -> Int -> Maybe ([b], [b])
forall {a} {t :: * -> *}.
(Adjacency t, DirectedGraph t, Integral a, Mutable t) =>
t a -> [a] -> [a] -> Int -> Maybe ([a], [a])
cuttableSubsetI t b
splitD [b]
va' [b]
vb' Int
k

cuttableSubsetI :: t a -> [a] -> [a] -> Int -> Maybe ([a], [a])
cuttableSubsetI t a
di [a]
va [a]
vb Int
k =
  let vbSet :: Set a
vbSet = [a] -> Set a
forall a. Ord a => [a] -> Set a
S.fromList [a]
vb
  in [([a], [a])] -> Maybe ([a], [a])
forall {a}. [a] -> Maybe a
mhead ([([a], [a])] -> Maybe ([a], [a]))
-> [([a], [a])] -> Maybe ([a], [a])
forall a b. (a -> b) -> a -> b
$
        [ ([a
a], [Int -> Set a -> a
forall a. Int -> Set a -> a
S.elemAt Int
0 Set a
nonReachB])
        | a
a <- [a]
va
        , let reachA :: [a]
reachA = t a -> a -> [a]
forall {t :: * -> *} {a}. (Adjacency t, Ord a) => t a -> a -> [a]
reach t a
di a
a
        , let nonReachB :: Set a
nonReachB = (a -> Set a -> Set a) -> Set a -> [a] -> Set a
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr 
                            (\a
u Set a
vbSet' -> 
                              if a
u a -> Set a -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set a
vbSet' then
                                a -> Set a -> Set a
forall a. Ord a => a -> Set a -> Set a
S.delete a
u Set a
vbSet' 
                              else
                                Set a
vbSet')
                            Set a
vbSet
                            [a]
reachA
        , Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Set a -> Bool
forall a. Set a -> Bool
S.null Set a
nonReachB
        ]
        [([a], [a])] -> [([a], [a])] -> [([a], [a])]
forall a. [a] -> [a] -> [a]
++
        [ ([a]
a', [a]
b')
        | Int
k' <- [Int
k,Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1..Int
1]
        , [a]
a' <- Int -> [a] -> [[a]]
forall {t} {a}. (Eq t, Num t) => t -> [a] -> [[a]]
choose Int
k' [a]
va
        , let s :: a
s = t a -> a
forall b a. Integral b => t a -> b
forall (t :: * -> *) b a. (DirectedGraph t, Integral b) => t a -> b
numVertices t a
di
        , let t :: a
t = a
s a -> a -> a
forall a. Num a => a -> a -> a
+ a
1
        , let d1 :: t a
d1 = ((a, a) -> t a -> t a) -> t a -> [(a, a)] -> t a
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (a, a) -> t a -> t a
forall a. (a, a) -> t a -> t a
forall (t :: * -> *) a. Mutable t => (a, a) -> t a -> t a
addArc (a -> t a -> t a
forall a. a -> t a -> t a
forall (t :: * -> *) a. Mutable t => a -> t a -> t a
addVertex a
s t a
di)
                                [(a
s, a
a) | a
a <- [a]
a']
        , let b0 :: [a]
b0 = Set a -> [a]
forall a. Set a -> [a]
S.toList (Set a -> [a]) -> Set a -> [a]
forall a b. (a -> b) -> a -> b
$ ([a] -> Set a
forall a. Ord a => [a] -> Set a
S.fromList [a]
vb)
                              Set a -> Set a -> Set a
forall a. Ord a => Set a -> Set a -> Set a
`S.intersection` 
                              ( ([a] -> Set a
forall a. Ord a => [a] -> Set a
S.fromList ([a] -> Set a) -> [a] -> Set a
forall a b. (a -> b) -> a -> b
$ t a -> a -> [a]
forall {t :: * -> *} {a}. (Adjacency t, Ord a) => t a -> a -> [a]
reach t a
d1 a
s) 
                                Set a -> Set a -> Set a
forall a. Ord a => Set a -> Set a -> Set a
`S.difference` 
                                ([a] -> Set a
forall a. Ord a => [a] -> Set a
S.fromList [a]
a'))
        , [a]
b' <- Int -> [a] -> [[a]]
forall {t} {a}. (Eq t, Num t) => t -> [a] -> [[a]]
choose Int
k' [a]
b0
        , let d' :: t a
d' = ((a, a) -> t a -> t a) -> t a -> [(a, a)] -> t a
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (a, a) -> t a -> t a
forall a. (a, a) -> t a -> t a
forall (t :: * -> *) a. Mutable t => (a, a) -> t a -> t a
addArc t a
d1
                                [(a
b, a
t) | a
b <- [a]
b']
        , t a -> a -> a -> Int
forall {a} {t :: * -> *}.
(Ord a, Adjacency t, DirectedGraph t) =>
t a -> a -> a -> Int
maxFlowValue t a
d' a
s a
t Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
k'
        ]

findWellLinkedSetI :: t a -> Int -> Maybe ([a], [a])
findWellLinkedSetI t a
d Int
k =
  let dSplit :: t a
dSplit = t a -> t a
forall {t :: * -> *} {a}.
(Mutable t, DirectedGraph t, Num a) =>
t a -> t a
splitVertices t a
d
  in
  [([a], [a])] -> Maybe ([a], [a])
forall {a}. [a] -> Maybe a
mhead [ ([a]
va, [a]
vb)
        | [a]
va <- Int -> [a] -> [[a]]
forall {t} {a}. (Eq t, Num t) => t -> [a] -> [[a]]
choose Int
k (t a -> [a]
forall a. t a -> [a]
forall (t :: * -> *) a. DirectedGraph t => t a -> [a]
vertices t a
d)
        , let reachA :: [a]
reachA = Set a -> [a]
forall a. Set a -> [a]
S.toList (Set a -> [a]) -> Set a -> [a]
forall a b. (a -> b) -> a -> b
$ ((Set a -> Set a -> Set a) -> [Set a] -> Set a
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 Set a -> Set a -> Set a
forall a. Ord a => Set a -> Set a -> Set a
S.intersection ([Set a] -> Set a) -> [Set a] -> Set a
forall a b. (a -> b) -> a -> b
$ (a -> Set a) -> [a] -> [Set a]
forall a b. (a -> b) -> [a] -> [b]
map (\a
v -> [a] -> Set a
forall a. Ord a => [a] -> Set a
S.fromList ([a] -> Set a) -> [a] -> Set a
forall a b. (a -> b) -> a -> b
$ t a -> a -> [a]
forall {t :: * -> *} {a}. (Adjacency t, Ord a) => t a -> a -> [a]
reach t a
d a
v) [a]
va) Set a -> Set a -> Set a
forall a. Ord a => Set a -> Set a -> Set a
`S.difference` ([a] -> Set a
forall a. Ord a => [a] -> Set a
S.fromList [a]
va)
        , [a]
vb <- Int -> [a] -> [[a]]
forall {t} {a}. (Eq t, Num t) => t -> [a] -> [[a]]
choose Int
k [a]
reachA
        , Maybe ([a], [a]) -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe ([a], [a]) -> Bool) -> Maybe ([a], [a]) -> Bool
forall a b. (a -> b) -> a -> b
$ t a -> [a] -> [a] -> Int -> Maybe ([a], [a])
forall {a} {t :: * -> *}.
(Adjacency t, DirectedGraph t, Integral a, Mutable t) =>
t a -> [a] -> [a] -> Int -> Maybe ([a], [a])
cuttableSubsetI t a
dSplit ((a -> a) -> [a] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (a
2a -> a -> a
forall a. Num a => a -> a -> a
*) [a]
va) ((a -> a) -> [a] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (\a
v -> a
2a -> a -> a
forall a. Num a => a -> a -> a
*a
v a -> a -> a
forall a. Num a => a -> a -> a
+ a
1) [a]
vb) Int
k
        ]