module HGraph.Directed.Connectivity
       ( reachable
       , allPaths
       , allLinkages
       , allMaximalPaths
       , LinkageInstance(..)
       , module F
       , module IL
       )
where

import Data.List
import HGraph.Directed
import HGraph.Directed.Connectivity.Flow as F
import HGraph.Directed.Connectivity.IntegralLinkage as IL
import qualified Data.Map as M
import qualified Data.Set as S

--data LinkageInstance a = 
--  LinkageInstance
--  { liTerminalPairs :: M.Map Int (a,a)
--  , liCapacities :: M.Map a Int
--  , liLinkage :: M.Map a (S.Set Int)
--  }

--extendLinkage d inst = 
--  case extendLinkage' $ M.keys $ liTerminalPairs inst of
--    Nothing -> Nothing
--    Just [] -> Just inst
--    Just ext ->
--      let link' = M.union (foldr (\(v,i) -> 
--                                   M.insertWith S.union v (S.singleton i))
--                                 M.empty ext)
--                          (liLinkage inst)
--          st' = M.union (M.fromList $ [ (i, (v, t))
--                                    | (v,i) <- ext
--                                    , let (s,t) = (liTerminalPairs inst) M.! i
--                                    , v `elem` (outneighbors d s)
--                                    ] ++
--                                    [ (i, (s, v))
--                                    | (v,i) <- ext
--                                    , let (s,t) = (liTerminalPairs inst) M.! i
--                                    , v `elem` (inneighbors d t)
--                                    ]
--                        )
--                        (liTerminalPairs inst)
--      in extendLinkage d inst{liTerminalPairs = st', liLinkage = link'}
--  where
--    extendLinkage' [] = Just []
--    extendLinkage' (i:is)
--      | s == t  = extendLinkage' is
--      | null cut = Nothing
--      | not $ null $ drop 1 cut = extendLinkage' is
--      | not $ i `S.member` ((liLinkage inst) M.! cv)  = Just [(cv,i)]
--      where
--        (s,t) = (liTerminalPairs inst) M.! i
--        d' = foldr removeVertex d
--                   [ v
--                   | (v,w) <- M.assocs $ liCapacities inst
--                   , (not $ i `elem` (liLinkage inst) M.! v) && w == (S.size $ (liLinkage inst) M.! v)
--                   ]
--        cut = minCutI d' s t
--        cv = head cut

reachable :: t a -> a -> a -> Bool
reachable t a
d a
s a
t = a
t a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (t a -> a -> ([a] -> [a]) -> ([a] -> [a]) -> [a]
forall (t :: * -> *) a.
(Adjacency t, Ord a) =>
t a -> a -> ([a] -> [a]) -> ([a] -> [a]) -> [a]
metaBfs t a
d a
s (\[a]
_ -> []) [a] -> [a]
forall a. a -> a
id)

allPaths :: t t -> t -> t -> [[t]]
allPaths t t
d t
s0 t
t = Set t -> t -> [[t]]
allPaths' Set t
forall a. Set a
S.empty t
s0
  where
    allPaths' :: Set t -> t -> [[t]]
allPaths' Set t
visited t
s
      | t
s t -> t -> Bool
forall a. Eq a => a -> a -> Bool
== t
t = [[t
t]]
      | Bool
otherwise = do
        t
v <- (t -> Bool) -> [t] -> [t]
forall a. (a -> Bool) -> [a] -> [a]
filter (\t
u -> Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ t
u t -> Set t -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set t
visited) ([t] -> [t]) -> [t] -> [t]
forall a b. (a -> b) -> a -> b
$ t t -> t -> [t]
forall (t :: * -> *) a. Adjacency t => t a -> a -> [a]
outneighbors t t
d t
s
        ([t] -> [t]) -> [[t]] -> [[t]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (t
st -> [t] -> [t]
forall a. a -> [a] -> [a]
:) ([[t]] -> [[t]]) -> [[t]] -> [[t]]
forall a b. (a -> b) -> a -> b
$ Set t -> t -> [[t]]
allPaths' (t -> Set t -> Set t
forall a. Ord a => a -> Set a -> Set a
S.insert t
v Set t
visited) t
v

allLinkages
  :: (DirectedGraph t1, Adjacency t1, Eq b, Eq t2, Num t2)
  => t1 b -> t2 -> b -> b -> [[[b]]]
allLinkages :: t1 b -> t2 -> b -> b -> [[[b]]]
allLinkages t1 b
d t2
k b
s b
t = do
  [Int]
s0 <- t2 -> [Int] -> [[Int]]
forall t a. (Eq t, Num t) => t -> [a] -> [[a]]
choose t2
k (t1 Int -> Int -> [Int]
forall (t :: * -> *) a. Adjacency t => t a -> a -> [a]
outneighbors t1 Int
di Int
si)
  ([[Int]] -> [[b]]) -> [[[Int]]] -> [[[b]]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([Int] -> [b]) -> [[Int]] -> [[b]]
forall a b. (a -> b) -> [a] -> [b]
map ((b
s b -> [b] -> [b]
forall a. a -> [a] -> [a]
:) ([b] -> [b]) -> ([Int] -> [b]) -> [Int] -> [b]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> b) -> [Int] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map (Map Int b
iToV Map Int b -> Int -> b
forall k a. Ord k => Map k a -> k -> a
M.!))) ([[[Int]]] -> [[[b]]]) -> [[[Int]]] -> [[[b]]]
forall a b. (a -> b) -> a -> b
$ [Int] -> Set Int -> [[[Int]]]
allLinkages' [Int]
s0 ([Int] -> Set Int
forall a. Ord a => [a] -> Set a
S.fromList ([Int] -> Set Int) -> [Int] -> Set Int
forall a b. (a -> b) -> a -> b
$ Int
si Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: [Int]
s0)
  where
    (t1 Int
di, [(Int, b)]
itova) = t1 b -> (t1 Int, [(Int, b)])
forall (t :: * -> *) a.
DirectedGraph t =>
t a -> (t Int, [(Int, a)])
linearizeVertices t1 b
d
    Just Int
si = ((Int, b) -> Int) -> Maybe (Int, b) -> Maybe Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int, b) -> Int
forall a b. (a, b) -> a
fst (Maybe (Int, b) -> Maybe Int) -> Maybe (Int, b) -> Maybe Int
forall a b. (a -> b) -> a -> b
$ ((Int, b) -> Bool) -> [(Int, b)] -> Maybe (Int, b)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((b -> b -> Bool
forall a. Eq a => a -> a -> Bool
==b
s) (b -> Bool) -> ((Int, b) -> b) -> (Int, b) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, b) -> b
forall a b. (a, b) -> b
snd) [(Int, b)]
itova
    Just Int
ti = ((Int, b) -> Int) -> Maybe (Int, b) -> Maybe Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int, b) -> Int
forall a b. (a, b) -> a
fst (Maybe (Int, b) -> Maybe Int) -> Maybe (Int, b) -> Maybe Int
forall a b. (a -> b) -> a -> b
$ ((Int, b) -> Bool) -> [(Int, b)] -> Maybe (Int, b)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((b -> b -> Bool
forall a. Eq a => a -> a -> Bool
==b
t) (b -> Bool) -> ((Int, b) -> b) -> (Int, b) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, b) -> b
forall a b. (a, b) -> b
snd) [(Int, b)]
itova
    iToV :: Map Int b
iToV = [(Int, b)] -> Map Int b
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(Int, b)]
itova
    allLinkages' :: [Int] -> Set Int -> [[[Int]]]
allLinkages' [Int]
sj Set Int
visited
      | (Int -> Bool) -> [Int] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==Int
ti) [Int]
sj = [[Int]] -> [[[Int]]]
forall (m :: * -> *) a. Monad m => a -> m a
return ([[Int]] -> [[[Int]]]) -> [[Int]] -> [[[Int]]]
forall a b. (a -> b) -> a -> b
$ (Int -> [Int]) -> [Int] -> [[Int]]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:[]) [Int]
sj
      | Bool
otherwise = do
      ([Int]
step, Set Int
visited') <- t1 Int -> Set Int -> [Int] -> Int -> [([Int], Set Int)]
forall a (t :: * -> *).
(Ord a, Adjacency t) =>
t a -> Set a -> [a] -> a -> [([a], Set a)]
linkageSteps t1 Int
di Set Int
visited [Int]
sj Int
ti
      ([[Int]] -> [[Int]]) -> [[[Int]]] -> [[[Int]]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Int -> [Int] -> [Int]) -> [Int] -> [[Int]] -> [[Int]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (:) [Int]
sj) ([[[Int]]] -> [[[Int]]]) -> [[[Int]]] -> [[[Int]]]
forall a b. (a -> b) -> a -> b
$ [Int] -> Set Int -> [[[Int]]]
allLinkages' [Int]
step Set Int
visited'

linkageSteps :: t a -> Set a -> [a] -> a -> [([a], Set a)]
linkageSteps t a
_ Set a
visited [] a
_ = ([a], Set a) -> [([a], Set a)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([], Set a
visited)
linkageSteps t a
d Set a
visited (a
v:[a]
vs) a
t = do
  a
u <- if a
v a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
t then a -> [a]
forall (m :: * -> *) a. Monad m => a -> m a
return a
v else (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 -> Set a -> Bool
forall a. Ord a => a -> Set a -> Bool
S.member a
u Set a
visited) ([a] -> [a]) -> [a] -> [a]
forall a b. (a -> b) -> a -> b
$ t a -> a -> [a]
forall (t :: * -> *) a. Adjacency t => t a -> a -> [a]
outneighbors t a
d a
v
  (([a], Set a) -> ([a], Set a)) -> [([a], Set a)] -> [([a], Set a)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\([a]
ws, Set a
visited') -> (a
ua -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
ws, Set a
visited')) ([([a], Set a)] -> [([a], Set a)])
-> [([a], Set a)] -> [([a], Set a)]
forall a b. (a -> b) -> a -> b
$ t a -> Set a -> [a] -> a -> [([a], Set a)]
linkageSteps t a
d (if a
u a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
t then a -> Set a -> Set a
forall a. Ord a => a -> Set a -> Set a
S.insert a
u Set a
visited else Set a
visited) [a]
vs a
t

-- | All maximal paths on a digraph, represented as a list of vertices.
-- | Cycles are also considered as maximal paths and their corresponding lists contain the initial vertex twice.
allMaximalPaths :: t b -> [[b]]
allMaximalPaths t b
d = ([Int] -> [b]) -> [[Int]] -> [[b]]
forall a b. (a -> b) -> [a] -> [b]
map ((Int -> b) -> [Int] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map (Map Int b
iToV Map Int b -> Int -> b
forall k a. Ord k => Map k a -> k -> a
M.!)) ([[Int]] -> [[b]]) -> [[Int]] -> [[b]]
forall a b. (a -> b) -> a -> b
$ [Int] -> Set Int -> [[Int]]
allMaximalPaths' (t Int -> [Int]
forall (t :: * -> *) a. DirectedGraph t => t a -> [a]
vertices t Int
di) Set Int
forall a. Set a
S.empty
  where
    (t Int
di, [(Int, b)]
itova) = t b -> (t Int, [(Int, b)])
forall (t :: * -> *) a.
DirectedGraph t =>
t a -> (t Int, [(Int, a)])
linearizeVertices t b
d
    iToV :: Map Int b
iToV = [(Int, b)] -> Map Int b
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(Int, b)]
itova
    allMaximalPaths' :: [Int] -> Set Int -> [[Int]]
allMaximalPaths' [] Set Int
_ = []
    allMaximalPaths' (Int
v:[Int]
vs) Set Int
blocked = [[Int]]
vPaths [[Int]] -> [[Int]] -> [[Int]]
forall a. [a] -> [a] -> [a]
++ [Int] -> Set Int -> [[Int]]
allMaximalPaths' [Int]
vs (Int -> Set Int -> Set Int
forall a. Ord a => a -> Set a -> Set a
S.insert Int
v Set Int
blocked)
      where
        vPaths :: [[Int]]
vPaths = ([Int] -> [[Int]]) -> [[Int]] -> [[Int]]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap [Int] -> [[Int]]
inExtensions ([[Int]] -> [[Int]]) -> [[Int]] -> [[Int]]
forall a b. (a -> b) -> a -> b
$ Bool -> (t Int -> Int -> [Int]) -> Set Int -> Int -> [[Int]]
uniPaths Bool
True t Int -> Int -> [Int]
forall (t :: * -> *) a. Adjacency t => t a -> a -> [a]
outneighbors Set Int
blocked Int
v
        uniPaths :: Bool -> (t Int -> Int -> [Int]) -> Set Int -> Int -> [[Int]]
uniPaths Bool
canClose t Int -> Int -> [Int]
neighborF Set Int
visited Int
u
          | [Int] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Int]
nu Bool -> Bool -> Bool
&& ([Int] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Int] -> Bool) -> [Int] -> Bool
forall a b. (a -> b) -> a -> b
$ (Int -> Bool) -> [Int] -> [Int]
forall a. (a -> Bool) -> [a] -> [a]
filter (Int -> Set Int -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set Int
blocked) ([Int] -> [Int]) -> [Int] -> [Int]
forall a b. (a -> b) -> a -> b
$ t Int -> Int -> [Int]
neighborF t Int
di Int
u) = [[Int
u]]
          | [Int] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Int]
nu Bool -> Bool -> Bool
&& [[Int]] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Int]]
vCycle = []
          | [Int] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Int]
nu = [[Int
u, Int
v]]
          | Bool
otherwise = ([Int] -> [Int]) -> [[Int]] -> [[Int]]
forall a b. (a -> b) -> [a] -> [b]
map (Int
uInt -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:) ([[Int]] -> [[Int]]) -> [[Int]] -> [[Int]]
forall a b. (a -> b) -> a -> b
$ [[Int]]
vCycle [[Int]] -> [[Int]] -> [[Int]]
forall a. [a] -> [a] -> [a]
++ (Int -> [[Int]]) -> [Int] -> [[Int]]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Bool -> (t Int -> Int -> [Int]) -> Set Int -> Int -> [[Int]]
uniPaths Bool
canClose t Int -> Int -> [Int]
neighborF (Int -> Set Int -> Set Int
forall a. Ord a => a -> Set a -> Set a
S.insert Int
u Set Int
visited)) [Int]
nu
          where
            nu :: [Int]
nu = (Int -> Bool) -> [Int] -> [Int]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Int -> Bool) -> Int -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Set Int -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set Int
visited)) ([Int] -> [Int]) -> [Int] -> [Int]
forall a b. (a -> b) -> a -> b
$ t Int -> Int -> [Int]
neighborF t Int
di Int
u
            vCycle :: [[Int]]
vCycle
              | Bool -> Bool
not Bool
canClose = []
              | Int
v Int -> [Int] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (t Int -> Int -> [Int]
neighborF t Int
di Int
u) = [[Int
v]]
              | Bool
otherwise = []
        inExtensions :: [Int] -> [[Int]]
inExtensions [Int]
p 
          | Int
p0 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
pn Bool -> Bool -> Bool
&& (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [Int] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Int] -> Bool) -> [Int] -> Bool
forall a b. (a -> b) -> a -> b
$ Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
drop Int
1 [Int]
p) = [[Int]
p] -- p is already a cycle
          | Bool
otherwise = ([Int] -> [Int]) -> [[Int]] -> [[Int]]
forall a b. (a -> b) -> [a] -> [b]
map [Int] -> [Int]
combine ([[Int]] -> [[Int]]) -> [[Int]] -> [[Int]]
forall a b. (a -> b) -> a -> b
$ Bool -> (t Int -> Int -> [Int]) -> Set Int -> Int -> [[Int]]
uniPaths Bool
canClose t Int -> Int -> [Int]
forall (t :: * -> *) a. Adjacency t => t a -> a -> [a]
inneighbors ((Int -> Set Int -> Set Int) -> Set Int -> [Int] -> Set Int
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Int -> Set Int -> Set Int
forall a. Ord a => a -> Set a -> Set a
S.insert Set Int
blocked [Int]
p) Int
v
          where
            canClose :: Bool
canClose = [Int] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Int] -> Bool) -> [Int] -> Bool
forall a b. (a -> b) -> a -> b
$ Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
drop Int
1 [Int]
p -- allow closing backwards cycles
            combine :: [Int] -> [Int]
combine [Int]
q
              | [Int] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Int]
q = []
              | t Int -> (Int, Int) -> Bool
forall (t :: * -> *) a. Adjacency t => t a -> (a, a) -> Bool
arcExists t Int
di (Int
pn, Int
q0) = Int
pn Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: [Int]
q' [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ [Int]
p
              | [Int] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Int]
q' = [Int]
p 
              | Bool
otherwise = [Int]
q' [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ [Int]
p
              where
                q' :: [Int]
q' = [Int] -> [Int]
forall a. [a] -> [a]
reverse ([Int] -> [Int]) -> [Int] -> [Int]
forall a b. (a -> b) -> a -> b
$ [Int] -> [Int]
forall a. [a] -> [a]
tail [Int]
q
                q0 :: Int
q0 = [Int] -> Int
forall a. [a] -> a
last [Int]
q
            pn :: Int
pn = [Int] -> Int
forall a. [a] -> a
last [Int]
p
            p0 :: Int
p0 = [Int] -> Int
forall a. [a] -> a
head [Int]
p

choose :: t -> [a] -> [[a]]
choose t
0 [a]
_  = [[]]
choose t
_ [] = []
choose t
k (a
x:[a]
xs) = ([a] -> [a]) -> [[a]] -> [[a]]
forall a b. (a -> b) -> [a] -> [b]
map (a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:) (t -> [a] -> [[a]]
choose (t
k t -> t -> t
forall a. Num a => a -> a -> a
- t
1) [a]
xs) [[a]] -> [[a]] -> [[a]]
forall a. [a] -> [a] -> [a]
++ t -> [a] -> [[a]]
choose t
k [a]
xs