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
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 )
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' :: 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