Flow.hs

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 d s t = maxFlow' $ foldr (\a -> M.insert a False) M.empty (arcs d)
  where
    maxFlow' flow 
      | null p = flow
      | otherwise = maxFlow' flow'
      where
        p = shortestPathResidual d s t flow
        flow' = foldr (M.adjust not) flow $ zip p (tail p)

maxFlowValue d s t = M.size $ M.filterWithKey (\k f -> f && (snd k == t)) $ maxFlow d s t

shortestPathResidual d s t flow = path (S.singleton s) M.empty
  where
    path active preds
      | t `M.member` preds = reverse $ makePath preds t
      | S.null active = []
      | otherwise = path (S.fromList $ M.keys newPred) (preds `M.union` newPred)
        where
          newPred = M.fromList $ [ (u,v)
                                 | v <- S.toList active
                                 , u <- outneighbors d v
                                 , (not $ flow M.! (v,u)) && (not $ u `M.member` preds) && u /= s
                                 ]
                                 ++
                                 [ (u,v)
                                 | v <- S.toList active
                                 , u <- inneighbors d v
                                 , flow M.! (u, v) && (not $ u `M.member` preds && u /= s)
                                 ]
    makePath preds v
      | v == s = [v]
      | otherwise = v : makePath preds (preds M.! v)


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

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

minCut :: (Mutable t, DirectedGraph t, Adjacency t, Eq a) => t a -> a -> a -> [a]
minCut d s t = map (iToV M.!) $ minCutI di si ti
  where
    (di, itova) = linearizeVertices d
    iToV = M.fromList itova
    Just si = fmap fst $ find ((==s) . snd) itova
    Just ti = fmap fst $ find ((==t) . snd) itova

minCutI :: (Mutable t, DirectedGraph t, Adjacency t, Integral a) => t a -> a -> a -> [a]
minCutI d s t = [u `div` 2 | v <- S.toList $ reachS, u <- outneighbors d'' v, not $ u `S.member` reachS]
  where
    d'  = foldr addVertex (empty d) (concat [[2*v, 2*v+1] | v <- vertices d])
    d'' = foldr addArc d' ([(2*v, 2*v + 1) | v <- vertices d] ++ [(2*v+1, 2*u) | (v,u) <- arcs d])
    flow = M.filter (id) $ maxFlow d'' (2*s+1) (2*t)
    reachS = bfs (S.singleton (2*s+1)) (S.singleton (2*s+1))
    bfs active reached
      | S.null active = reached
      | otherwise = bfs new (S.union reached new)
        where
          new = S.fromList $ [ u
                             | v <- S.toList active
                             , u <- outneighbors d'' v
                             , (not $ (v,u) `M.member` flow) && (not $ u `S.member` reached)
                             ]
                             ++
                             [ u
                             | v <- S.toList active
                             , u <- inneighbors d'' v
                             , (u,v) `M.member` flow && (not $ u `S.member` 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 d va vb = isNothing $ separableSets d va 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 d va vb = separableSetsI di vai vbi k
  where
    (di, itova) = linearizeVertices d
    vToI = M.fromList $ map (\(i,v) -> (v,i)) itova
    vai = [ vToI M.! v | v <- va]
    vbi = [ vToI M.! v | v <- vb]
    k = length vai
    
separableSetsI di va vb k =
  let splitD = splitVertices di
      va' = map (2*) va
      vb' = map (\v -> 2*v + 1) vb
      vbSet = S.fromList vb'
  in fmap (\(a,b) -> 
             ( map (\v -> v `div` 2) a
             , map (\v -> (v - 1) `div` 2) b
             )
          ) $
          cuttableSubsetI splitD va' vb' k

cuttableSubsetI di va vb k =
  let vbSet = S.fromList vb
  in mhead $
        [ ([a], [S.elemAt 0 nonReachB])
        | a <- va
        , let reachA = reach di a
        , let nonReachB = foldr 
                            (\u vbSet' -> 
                              if u `S.member` vbSet' then
                                S.delete u vbSet' 
                              else
                                vbSet')
                            vbSet
                            reachA
        , not $ S.null nonReachB
        ]
        ++
        [ (a', b')
        | k' <- [k,k - 1..1]
        , a' <- choose k' va
        , let s = numVertices di
        , let t = s + 1
        , let d1 = foldr addArc (addVertex s di)
                                [(s, a) | a <- a']
        , let b0 = S.toList $ (S.fromList vb)
                              `S.intersection` 
                              ( (S.fromList $ reach d1 s) 
                                `S.difference` 
                                (S.fromList a'))
        , b' <- choose k' b0
        , let d' = foldr addArc d1
                                [(b, t) | b <- b']
        , maxFlowValue d' s t /= k'
        ]

findWellLinkedSetI d k =
  let dSplit = splitVertices d
  in
  mhead [ (va, vb)
        | va <- choose k (vertices d)
        , let reachA = S.toList $ (foldr1 S.intersection $ map (\v -> S.fromList $ reach d v) va) `S.difference` (S.fromList va)
        , vb <- choose k reachA
        , isNothing $ cuttableSubsetI dSplit (map (2*) va) (map (\v -> 2*v + 1) vb) k
        ]