module HGraph.Directed.Connectivity.IntegralLinkage
       ( extendLinkage
       , linkage
       , linkageI
       , LinkageInstance(..)
       )
where

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

data LinkageInstance a = 
  LinkageInstance
  { forall a. LinkageInstance a -> Map Int (a, a)
liTerminalPairs :: M.Map Int (a,a)
  , forall a. LinkageInstance a -> Map a Int
liLinkage       :: M.Map a Int
  , forall a. LinkageInstance a -> Map Int [a]
liPath          :: M.Map Int [a]
  }
  deriving (LinkageInstance a -> LinkageInstance a -> Bool
(LinkageInstance a -> LinkageInstance a -> Bool)
-> (LinkageInstance a -> LinkageInstance a -> Bool)
-> Eq (LinkageInstance a)
forall a. Eq a => LinkageInstance a -> LinkageInstance a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => LinkageInstance a -> LinkageInstance a -> Bool
== :: LinkageInstance a -> LinkageInstance a -> Bool
$c/= :: forall a. Eq a => LinkageInstance a -> LinkageInstance a -> Bool
/= :: LinkageInstance a -> LinkageInstance a -> Bool
Eq, Int -> LinkageInstance a -> ShowS
[LinkageInstance a] -> ShowS
LinkageInstance a -> String
(Int -> LinkageInstance a -> ShowS)
-> (LinkageInstance a -> String)
-> ([LinkageInstance a] -> ShowS)
-> Show (LinkageInstance a)
forall a. Show a => Int -> LinkageInstance a -> ShowS
forall a. Show a => [LinkageInstance a] -> ShowS
forall a. Show a => LinkageInstance a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> LinkageInstance a -> ShowS
showsPrec :: Int -> LinkageInstance a -> ShowS
$cshow :: forall a. Show a => LinkageInstance a -> String
show :: LinkageInstance a -> String
$cshowList :: forall a. Show a => [LinkageInstance a] -> ShowS
showList :: [LinkageInstance a] -> ShowS
Show)

extendLinkage :: t a -> LinkageInstance a -> Maybe (LinkageInstance a)
extendLinkage t a
d LinkageInstance a
inst = 
  case [Int] -> Maybe [(a, Int)]
extendLinkage' ([Int] -> Maybe [(a, Int)]) -> [Int] -> Maybe [(a, Int)]
forall a b. (a -> b) -> a -> b
$ Map Int (a, a) -> [Int]
forall k a. Map k a -> [k]
M.keys (Map Int (a, a) -> [Int]) -> Map Int (a, a) -> [Int]
forall a b. (a -> b) -> a -> b
$ LinkageInstance a -> Map Int (a, a)
forall a. LinkageInstance a -> Map Int (a, a)
liTerminalPairs LinkageInstance a
inst of
    Maybe [(a, Int)]
Nothing -> Maybe (LinkageInstance a)
forall a. Maybe a
Nothing
    Just [] -> LinkageInstance a -> Maybe (LinkageInstance a)
forall a. a -> Maybe a
Just LinkageInstance a
inst
    Just [(a, Int)]
ext ->
      let link' :: Map a Int
link' = Map a Int -> Map a Int -> Map a Int
forall k a. Ord k => Map k a -> Map k a -> Map k a
M.union (((a, Int) -> Map a Int -> Map a Int)
-> Map a Int -> [(a, Int)] -> Map a Int
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(a
v,Int
i) -> 
                                   a -> Int -> Map a Int -> Map a Int
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert a
v Int
i)
                                 Map a Int
forall k a. Map k a
M.empty [(a, Int)]
ext)
                          (LinkageInstance a -> Map a Int
forall a. LinkageInstance a -> Map a Int
liLinkage LinkageInstance a
inst)
          st' :: Map Int (a, a)
st' = Map Int (a, a) -> Map Int (a, a) -> Map Int (a, a)
forall k a. Ord k => Map k a -> Map k a -> Map k a
M.union ([(Int, (a, a))] -> Map Int (a, a)
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [ (Int
i, (a
s, a
v))
                                    | (a
v,Int
i) <- [(a, Int)]
ext
                                    , let (a
s,a
t) = (LinkageInstance a -> Map Int (a, a)
forall a. LinkageInstance a -> Map Int (a, a)
liTerminalPairs LinkageInstance a
inst) Map Int (a, a) -> Int -> (a, a)
forall k a. Ord k => Map k a -> k -> a
M.! Int
i
                                    , a
v a -> [a] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (t a -> a -> [a]
forall a. t a -> a -> [a]
forall (t :: * -> *) a. Adjacency t => t a -> a -> [a]
inneighbors t a
d a
t)
                                    ]
                        )
                        (LinkageInstance a -> Map Int (a, a)
forall a. LinkageInstance a -> Map Int (a, a)
liTerminalPairs LinkageInstance a
inst)
          path' :: Map Int [a]
path' = ([a] -> [a] -> [a]) -> Map Int [a] -> Map Int [a] -> Map Int [a]
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
M.unionWith [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
(++) ([(Int, [a])] -> Map Int [a]
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Int, [a])] -> Map Int [a]) -> [(Int, [a])] -> Map Int [a]
forall a b. (a -> b) -> a -> b
$ 
                                    [ (Int
i, [a
t,a
v])
                                    | (a
v,Int
i) <- [(a, Int)]
ext
                                    , let (a
_,a
t) = (LinkageInstance a -> Map Int (a, a)
forall a. LinkageInstance a -> Map Int (a, a)
liTerminalPairs LinkageInstance a
inst) Map Int (a, a) -> Int -> (a, a)
forall k a. Ord k => Map k a -> k -> a
M.! Int
i
                                    , a
v a -> [a] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (t a -> a -> [a]
forall a. t a -> a -> [a]
forall (t :: * -> *) a. Adjacency t => t a -> a -> [a]
inneighbors t a
d a
t)
                                    ]
                        )
                        (LinkageInstance a -> Map Int [a]
forall a. LinkageInstance a -> Map Int [a]
liPath LinkageInstance a
inst)
      in t a -> LinkageInstance a -> Maybe (LinkageInstance a)
extendLinkage t a
d LinkageInstance a
inst{liTerminalPairs = st', liLinkage = link', liPath = path'}
  where
    extendLinkage' :: [Int] -> Maybe [(a, Int)]
extendLinkage' [] = [(a, Int)] -> Maybe [(a, Int)]
forall a. a -> Maybe a
Just []
    extendLinkage' (Int
i:[Int]
is)
      | a
s a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
t  = [Int] -> Maybe [(a, Int)]
extendLinkage' [Int]
is
      | [a] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
cut = Maybe [(a, Int)]
forall a. Maybe a
Nothing
      | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [a] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([a] -> Bool) -> [a] -> Bool
forall a b. (a -> b) -> a -> b
$ Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
drop Int
1 [a]
cut = [Int] -> Maybe [(a, Int)]
extendLinkage' [Int]
is
      | Maybe Int -> Bool
forall a. Maybe a -> Bool
isNothing (a
cv a -> Map a Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
`M.lookup` (LinkageInstance a -> Map a Int
forall a. LinkageInstance a -> Map a Int
liLinkage LinkageInstance a
inst)) = [(a, Int)] -> Maybe [(a, Int)]
forall a. a -> Maybe a
Just [(a
cv,Int
i)]
      | Bool
otherwise = [Int] -> Maybe [(a, Int)]
extendLinkage' [Int]
is
      where
        (a
s,a
t) = (LinkageInstance a -> Map Int (a, a)
forall a. LinkageInstance a -> Map Int (a, a)
liTerminalPairs LinkageInstance a
inst) Map Int (a, a) -> Int -> (a, a)
forall k a. Ord k => Map k a -> k -> a
M.! Int
i
        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
removeVertex t a
d
                   [ a
v
                   | a
v <- t a -> [a]
forall a. t a -> [a]
forall (t :: * -> *) a. DirectedGraph t => t a -> [a]
vertices t a
d
                   , a
v a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
s Bool -> Bool -> Bool
&& a
v a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
t Bool -> Bool -> Bool
&& Bool -> (Int -> Bool) -> Maybe Int -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/=) (a
v a -> Map a Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
`M.lookup` (LinkageInstance a -> Map a Int
forall a. LinkageInstance a -> Map a Int
liLinkage LinkageInstance a
inst))
                   ]
        cut :: [a]
cut = t a -> a -> a -> [a]
forall (t :: * -> *) a.
(Mutable t, DirectedGraph t, Adjacency t, Integral a) =>
t a -> a -> a -> [a]
minCutI t a
d' a
s a
t
        cv :: a
cv = [a] -> a
forall a. HasCallStack => [a] -> a
head [a]
cut

-- | Finds an integral linkaged connecting the given terminal pairs, if one exists.
linkage :: (DirectedGraph t, Adjacency t, Mutable t, Eq a) => t a -> [(a,a)] -> Maybe [((a,a), [a])]
linkage :: forall (t :: * -> *) a.
(DirectedGraph t, Adjacency t, Mutable t, Eq a) =>
t a -> [(a, a)] -> Maybe [((a, a), [a])]
linkage t a
d [(a, a)]
st = ([((Int, Int), [Int])] -> [((a, a), [a])])
-> Maybe [((Int, Int), [Int])] -> Maybe [((a, a), [a])]
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((((Int, Int), [Int]) -> ((a, a), [a]))
-> [((Int, Int), [Int])] -> [((a, a), [a])]
forall a b. (a -> b) -> [a] -> [b]
map ((Int, Int), [Int]) -> ((a, a), [a])
convertResult) (Maybe [((Int, Int), [Int])] -> Maybe [((a, a), [a])])
-> Maybe [((Int, Int), [Int])] -> Maybe [((a, a), [a])]
forall a b. (a -> b) -> a -> b
$ t Int -> [(Int, Int)] -> Maybe [((Int, Int), [Int])]
forall (t :: * -> *) a.
(DirectedGraph t, Adjacency t, Mutable t, Integral a, Ord a,
 Eq a) =>
t a -> [(a, a)] -> Maybe [((a, a), [a])]
linkageI t Int
di [(Int, Int)]
sti
  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
    sti :: [(Int, Int)]
sti = [ (Int
si, Int
ti)
          | (a
s,a
t) <- [(a, a)]
st
          , let si :: Int
si = (Int, a) -> Int
forall a b. (a, b) -> a
fst ((Int, a) -> Int) -> (Int, a) -> Int
forall a b. (a -> b) -> a -> b
$ [(Int, a)] -> (Int, a)
forall a. HasCallStack => [a] -> a
head ([(Int, a)] -> (Int, a)) -> [(Int, a)] -> (Int, a)
forall a b. (a -> b) -> a -> b
$ ((Int, a) -> Bool) -> [(Int, a)] -> [(Int, a)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(Int
_, a
v) -> a
v a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
s) [(Int, a)]
itova
          , let ti :: Int
ti = (Int, a) -> Int
forall a b. (a, b) -> a
fst ((Int, a) -> Int) -> (Int, a) -> Int
forall a b. (a -> b) -> a -> b
$ [(Int, a)] -> (Int, a)
forall a. HasCallStack => [a] -> a
head ([(Int, a)] -> (Int, a)) -> [(Int, a)] -> (Int, a)
forall a b. (a -> b) -> a -> b
$ ((Int, a) -> Bool) -> [(Int, a)] -> [(Int, a)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(Int
_, a
v) -> a
v a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
t) [(Int, a)]
itova
          ]
    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
    convertResult :: ((Int, Int), [Int]) -> ((a, a), [a])
convertResult ((Int
v,Int
u), [Int]
ps) = ((Map Int a
iToV Map Int a -> Int -> a
forall k a. Ord k => Map k a -> k -> a
M.! Int
v, Map Int a
iToV Map Int a -> Int -> a
forall k a. Ord k => Map k a -> k -> a
M.! Int
u), (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]
ps )

-- | Special case of `linkage` where vertices are of type `Int`.
-- | Faster than calling `linkage` if vertices of the digraph are already of type `Int`.
linkageI :: (DirectedGraph t, Adjacency t, Mutable t, Integral a, Ord a, Eq a) => t a -> [(a,a)] -> Maybe [((a,a), [a])]
linkageI :: forall (t :: * -> *) a.
(DirectedGraph t, Adjacency t, Mutable t, Integral a, Ord a,
 Eq a) =>
t a -> [(a, a)] -> Maybe [((a, a), [a])]
linkageI t a
d [(a, a)]
st = LinkageInstance a -> Set a -> Maybe [((a, a), [a])]
linkage' LinkageInstance a
inst0 Set a
forall a. Set a
S.empty
  where
    sti :: [(Int, (a, a))]
sti = [Int] -> [(a, a)] -> [(Int, (a, a))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] [(a, a)]
st
    terminalPairs0 :: Map Int (a, a)
terminalPairs0 = [(Int, (a, a))] -> Map Int (a, a)
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(Int, (a, a))]
sti
    inst0 :: LinkageInstance a
inst0 = LinkageInstance
            { liLinkage :: Map a Int
liLinkage = [(a, Int)] -> Map a Int
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(a, Int)] -> Map a Int) -> [(a, Int)] -> Map a Int
forall a b. (a -> b) -> a -> b
$ 
                ((Int, (a, a)) -> [(a, Int)]) -> [(Int, (a, a))] -> [(a, Int)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(Int
i, (a
s,a
t)) ->  [(a
s, Int
i), (a
t, Int
i)]) [(Int, (a, a))]
sti
            , liTerminalPairs :: Map Int (a, a)
liTerminalPairs = Map Int (a, a)
terminalPairs0
            , liPath :: Map Int [a]
liPath = Map Int [a]
forall k a. Map k a
M.empty
            }
    -- linkage' :: (Eq a, Ord a, Num a) => LinkageInstance a -> Maybe [((a,a), [a])]
    linkage' :: LinkageInstance a -> Set a -> Maybe [((a, a), [a])]
linkage' LinkageInstance a
inst Set a
blocked
      | Map Int (a, a) -> Bool
forall k a. Map k a -> Bool
M.null (Map Int (a, a) -> Bool) -> Map Int (a, a) -> Bool
forall a b. (a -> b) -> a -> b
$ LinkageInstance a -> Map Int (a, a)
forall a. LinkageInstance a -> Map Int (a, a)
liTerminalPairs LinkageInstance a
inst = [((a, a), [a])] -> Maybe [((a, a), [a])]
forall a. a -> Maybe a
Just [ (Map Int (a, a)
terminalPairs0 Map Int (a, a) -> Int -> (a, a)
forall k a. Ord k => Map k a -> k -> a
M.! Int
t, [a] -> [a]
forall a. [a] -> [a]
reverse [a]
ps) | (Int
t, [a]
ps) <- Map Int [a] -> [(Int, [a])]
forall k a. Map k a -> [(k, a)]
M.assocs (Map Int [a] -> [(Int, [a])]) -> Map Int [a] -> [(Int, [a])]
forall a b. (a -> b) -> a -> b
$ LinkageInstance a -> Map Int [a]
forall a. LinkageInstance a -> Map Int [a]
liPath LinkageInstance a
inst]
      | Bool
otherwise = 
        let (Int
i, (a
s,a
t)) = [(Int, (a, a))] -> (Int, (a, a))
forall a. HasCallStack => [a] -> a
head ([(Int, (a, a))] -> (Int, (a, a)))
-> [(Int, (a, a))] -> (Int, (a, a))
forall a b. (a -> b) -> a -> b
$ Map Int (a, a) -> [(Int, (a, a))]
forall k a. Map k a -> [(k, a)]
M.assocs (Map Int (a, a) -> [(Int, (a, a))])
-> Map Int (a, a) -> [(Int, (a, a))]
forall a b. (a -> b) -> a -> b
$ LinkageInstance a -> Map Int (a, a)
forall a. LinkageInstance a -> Map Int (a, a)
liTerminalPairs LinkageInstance a
inst
            tries :: [[((a, a), [a])]]
tries = do
              a
v <- (a -> Bool) -> [a] -> [a]
forall a. (a -> Bool) -> [a] -> [a]
filter (\a
u -> (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
blocked) Bool -> Bool -> Bool
&& (Bool -> (Int -> Bool) -> Maybe Int -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
i) (Maybe Int -> Bool) -> Maybe Int -> Bool
forall a b. (a -> b) -> a -> b
$ a -> Map a Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup a
u (Map a Int -> Maybe Int) -> Map a Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$ LinkageInstance a -> Map a Int
forall a. LinkageInstance a -> Map a Int
liLinkage LinkageInstance a
inst)) ([a] -> [a]) -> [a] -> [a]
forall a b. (a -> b) -> a -> b
$ t a -> a -> [a]
forall a. t a -> a -> [a]
forall (t :: * -> *) a. Adjacency t => t a -> a -> [a]
inneighbors t a
d a
t
              let inst' :: Maybe (LinkageInstance a)
inst' = t a -> LinkageInstance a -> Maybe (LinkageInstance a)
forall {t :: * -> *} {a}.
(Mutable t, DirectedGraph t, Integral a, Adjacency t) =>
t a -> LinkageInstance a -> Maybe (LinkageInstance a)
extendLinkage t a
d (LinkageInstance a -> Maybe (LinkageInstance a))
-> LinkageInstance a -> Maybe (LinkageInstance a)
forall a b. (a -> b) -> a -> b
$ LinkageInstance a
inst
                          { liTerminalPairs = M.insert i (s,v) (liTerminalPairs inst)
                          , liPath = M.insertWith (++) i [v] $ liPath inst
                          , liLinkage = M.insert v i $ liLinkage inst
                          }
              case (LinkageInstance a -> Maybe [((a, a), [a])])
-> Maybe (LinkageInstance a) -> Maybe (Maybe [((a, a), [a])])
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\LinkageInstance a
i' -> LinkageInstance a -> Set a -> Maybe [((a, a), [a])]
linkage' LinkageInstance a
i' (a -> Set a -> Set a
forall a. Ord a => a -> Set a -> Set a
S.insert a
v Set a
blocked)) Maybe (LinkageInstance a)
inst' of
                Just (Just [((a, a), [a])]
r) -> [((a, a), [a])] -> [[((a, a), [a])]]
forall a. a -> [a]
forall (m :: * -> *) a. Monad m => a -> m a
return [((a, a), [a])]
r
                Maybe (Maybe [((a, a), [a])])
_ -> []
        in 
        if t a -> (a, a) -> Bool
forall a. t a -> (a, a) -> Bool
forall (t :: * -> *) a. Adjacency t => t a -> (a, a) -> Bool
arcExists t a
d (a
s,a
t) then
          LinkageInstance a -> Set a -> Maybe [((a, a), [a])]
linkage' LinkageInstance a
inst
            { liTerminalPairs = M.delete i $ liTerminalPairs inst
            , liPath = M.insertWith (++) i [s] $ liPath inst
            }
            Set a
blocked
        else
          [[((a, a), [a])]] -> Maybe [((a, a), [a])]
forall {a}. [a] -> Maybe a
mhead [[((a, a), [a])]]
tries