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 Data.Maybe

data LinkageInstance a = 
  LinkageInstance
  { LinkageInstance a -> Map Int (a, a)
liTerminalPairs :: M.Map Int (a,a)
  , LinkageInstance a -> Map a Int
liLinkage       :: M.Map a Int
  , LinkageInstance a -> Map Int [a]
liPath          :: M.Map Int [a]
  }

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 (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, (a, a))] -> Map Int (a, a))
-> [(Int, (a, a))] -> Map Int (a, a)
forall a b. (a -> b) -> a -> b
$ [ (Int
i, (a
v, a
t))
                                    | (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 (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (t a -> a -> [a]
forall (t :: * -> *) a. Adjacency t => t a -> a -> [a]
outneighbors t a
d a
s)
                                    ] [(Int, (a, a))] -> [(Int, (a, a))] -> [(Int, (a, a))]
forall a. [a] -> [a] -> [a]
++
                                    [ (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 (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (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)
      in t a -> LinkageInstance a -> Maybe (LinkageInstance a)
extendLinkage t a
d LinkageInstance a
inst{liTerminalPairs :: Map Int (a, a)
liTerminalPairs = Map Int (a, a)
st', liLinkage :: Map a Int
liLinkage = Map a Int
link'}
  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 (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 (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
      | Bool -> (Int -> Bool) -> Maybe Int -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (Int
iInt -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/=) (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)]
      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 (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr 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 (t :: * -> *) a. DirectedGraph t => t a -> [a]
vertices t a
d
                   , 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. [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 :: 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 (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 (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. [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. [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 :: t a -> [(a, a)] -> Maybe [((a, a), [a])]
linkageI t a
d [(a, a)]
st = LinkageInstance a -> Maybe [((a, a), [a])]
linkage' LinkageInstance a
inst0
  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 :: forall a.
Map Int (a, a) -> Map a Int -> Map Int [a] -> LinkageInstance a
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 -> Maybe [((a, a), [a])]
linkage' LinkageInstance a
inst
      | 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. [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
$ Maybe Int -> Bool
forall a. Maybe a -> Bool
isJust (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 (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, Adjacency t, Integral a) =>
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 :: Map Int (a, a)
liTerminalPairs = Int -> (a, a) -> Map Int (a, a) -> Map Int (a, a)
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Int
i (a
s,a
v) (LinkageInstance a -> Map Int (a, a)
forall a. LinkageInstance a -> Map Int (a, a)
liTerminalPairs LinkageInstance a
inst)
                          , liPath :: Map Int [a]
liPath = ([a] -> [a] -> [a]) -> Int -> [a] -> Map Int [a] -> Map Int [a]
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
(++) Int
i [a
v] (Map Int [a] -> Map Int [a]) -> Map Int [a] -> Map 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
                          , liLinkage :: Map a Int
liLinkage = 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 -> Map a Int) -> Map a Int -> Map a Int
forall a b. (a -> b) -> a -> b
$ LinkageInstance a -> Map a Int
forall a. LinkageInstance a -> Map a Int
liLinkage LinkageInstance a
inst
                          }
              case (LinkageInstance a -> Maybe [((a, a), [a])])
-> Maybe (LinkageInstance a) -> Maybe (Maybe [((a, a), [a])])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap LinkageInstance a -> Maybe [((a, a), [a])]
linkage' Maybe (LinkageInstance a)
inst' of
                Just (Just [((a, a), [a])]
r) -> [((a, a), [a])] -> [[((a, a), [a])]]
forall (m :: * -> *) a. Monad m => a -> m a
return [((a, a), [a])]
r
                Maybe (Maybe [((a, a), [a])])
Nothing -> []
        in [[((a, a), [a])]] -> Maybe [((a, a), [a])]
forall a. [a] -> Maybe a
mhead [[((a, a), [a])]]
tries