{-|
Module      : Data.Graph.AdjacencyList.PushRelabel.Pure
Description : Tide algorithm — a push-pull-relabel max-flow solver
Copyright   : Thodoris Papakonstantinou, 2017-2026
License     : LGPL-3
Maintainer  : dev@tpapak.com
Stability   : experimental
Portability : POSIX

= Tide — Push (Pull) Relabel

The Tide algorithm is a push-relabel variant for solving the
<https://en.wikipedia.org/wiki/Maximum_flow_problem maximum flow problem>
on directed graphs.

== Definitions

A network \( N = (G, s, t, C) \) consists of a directed graph \( G \),
source \( s \), sink \( t \), and capacities \( C : E \to \mathbb{R}^+ \).

The /residual graph/ \( R \) contains both forward edges (with residual
capacity \( c - f \)) and backward edges (with capacity \( f \)).
Each vertex carries:

* __Height__ \( h(v) \): determines whether flow can be pushed along an edge
  (flow moves from higher to lower height).
* __Excess__ \( x(v) \): records the net surplus of flow at \( v \).
  At termination all excesses are zero and the preflow is a valid max flow.
* __Level__ \( \ell(v) \): the BFS distance from source in the /original/
  graph \( G \).  Constant throughout the algorithm.  Determines the
  sweep order.

== Operations

The key difference from classical push-relabel is that the push operation
is split into two:

* __Push__ (on forward edges): increases flow towards the sink.
* __Pull__ (on reverse edges): decreases flow, effectively pulling excess
  backwards towards the source.

== Algorithm

Each iteration (\"tide\") consists of three global sweeps:

1. __globalRelabel__: BFS from sink (and source) on the residual graph to
   recompute vertex heights.  Source-side vertices get
   \( h = |V| + d_s(v) \); sink-side vertices get \( h = d_t(v) \).

2. __globalPull__: /right fold/ over overflowing vertices in descending
   level order, pulling flow on reverse edges (from sink towards source).

3. __globalPush__: /left fold/ over overflowing vertices in ascending
   level order, pushing flow on forward edges (from source towards sink).

The algorithm terminates when both the net flow and the set of overflowing
vertices are unchanged between consecutive tides.

=== Skip-globalRelabel optimization

When no edge crosses a saturation boundary during push\/pull (the
'topologyChanged' flag is 'False'), the residual graph topology is
unchanged and globalRelabel is skipped.  This saves 1.25--1.61x in
practice.

== Complexity

* Per-tide cost: \( O((V+E) \log V) \) with IntMap data structures.
* Number of tides: \( O(V^2) \) worst case (requires exponential capacity
  ratios); \( O(V) \) in practice on non-pathological graphs.
* Total: \( O(V^2 (V+E) \log V) \) worst case;
  \( O(V (V+E) \log V) \) practical.

See also the Rust implementation @tide-maxflow@ which achieves \( O(VE) \)
practical complexity using O(1) array-based data structures.
 -}

{-# LANGUAGE BangPatterns #-}

module Data.Graph.AdjacencyList.PushRelabel.Pure
  ( -- * Main entry point
    pushRelabel
    -- * Algorithm internals (exported for testing)
  , tide
  , globalPush
  , globalPull
  , globalRelabel
  ) where

import Data.List
import Data.Maybe
import qualified Data.Map.Lazy as M
import qualified Data.IntMap.Lazy as IM
import qualified Data.IntSet as Set
import Control.Monad

import Data.Graph.AdjacencyList
import Data.Graph.AdjacencyList.Network
import Data.Graph.AdjacencyList.PushRelabel.Internal
import qualified Data.Graph.AdjacencyList.BFS as BFS

-- | Solve the maximum flow problem on a 'Network' using the Tide algorithm.
--
-- Returns @Right rg@ on success, where @rg@ is the 'ResidualGraph' at
-- termination.  The maximum flow value is @netFlow rg@ and per-edge flows
-- are available via @edgeFlow rg e@ or via @flow (network rg)@.
--
-- Returns @Left msg@ if an internal invariant is violated (should not happen
-- on valid inputs).
--
-- ==== Example
--
-- @
-- let g   = graphFromEdges [Edge 0 1, Edge 0 2, Edge 1 3, Edge 2 3]
--     caps = M.fromList [(Edge 0 1, 10), (Edge 0 2, 10), (Edge 1 3, 10), (Edge 2 3, 10)]
--     net  = Network g 0 3 caps (M.fromList [(e, 0) | e <- edges g])
-- case pushRelabel net of
--   Right rg -> print (netFlow rg)   -- 20
--   Left err -> putStrLn err
-- @
pushRelabel :: Network -> Either String ResidualGraph
pushRelabel :: Network -> Either String ResidualGraph
pushRelabel Network
net =
  let initg :: ResidualGraph
initg = Network -> ResidualGraph
initializeResidualGraph Network
net
      res :: ResidualGraph
res = ResidualGraph -> Vertex -> ResidualGraph
tide ResidualGraph
initg Vertex
0
      nvs :: [Vertex]
nvs = Graph -> [Vertex]
vertices (Graph -> [Vertex]) -> Graph -> [Vertex]
forall a b. (a -> b) -> a -> b
$ Network -> Graph
graph (Network -> Graph) -> Network -> Graph
forall a b. (a -> b) -> a -> b
$ ResidualGraph -> Network
network ResidualGraph
res
      s :: Vertex
s = Network -> Vertex
source Network
net
      t :: Vertex
t = Network -> Vertex
sink Network
net
      insouts :: [Vertex]
insouts = (Vertex -> Bool) -> [Vertex] -> [Vertex]
forall a. (a -> Bool) -> [a] -> [a]
filter (\Vertex
v -> Vertex
v Vertex -> Vertex -> Bool
forall a. Eq a => a -> a -> Bool
/= Vertex
s Bool -> Bool -> Bool
&& Vertex
v Vertex -> Vertex -> Bool
forall a. Eq a => a -> a -> Bool
/= Vertex
t Bool -> Bool -> Bool
&& ResidualGraph -> Vertex -> Flow
inflow ResidualGraph
res Vertex
v Flow -> Flow -> Bool
forall a. Ord a => a -> a -> Bool
< ResidualGraph -> Vertex -> Flow
outflow ResidualGraph
res Vertex
v) [Vertex]
nvs
      xsflows :: [Vertex]
xsflows = (Vertex -> Bool) -> [Vertex] -> [Vertex]
forall a. (a -> Bool) -> [a] -> [a]
filter (\Vertex
v -> Vertex
v Vertex -> Vertex -> Bool
forall a. Eq a => a -> a -> Bool
/= Vertex
s Bool -> Bool -> Bool
&& Vertex
v Vertex -> Vertex -> Bool
forall a. Eq a => a -> a -> Bool
/= Vertex
t Bool -> Bool -> Bool
&& ResidualGraph -> Vertex -> Flow
inflow ResidualGraph
res Vertex
v Flow -> Flow -> Flow
forall a. Num a => a -> a -> a
- ResidualGraph -> Vertex -> Flow
outflow ResidualGraph
res Vertex
v Flow -> Flow -> Bool
forall a. Eq a => a -> a -> Bool
/= ResidualGraph -> Vertex -> Flow
excess ResidualGraph
res Vertex
v) [Vertex]
nvs
      ofvs :: IntSet
ofvs = (IntSet -> IntSet -> IntSet) -> IntSet -> Overflowing -> IntSet
forall a b. (a -> b -> b) -> b -> IntMap a -> b
IM.foldr (\IntSet
ovs IntSet
ac -> IntSet -> IntSet -> IntSet
Set.union IntSet
ac IntSet
ovs) IntSet
Set.empty (Overflowing -> IntSet) -> Overflowing -> IntSet
forall a b. (a -> b) -> a -> b
$ ResidualGraph -> Overflowing
overflowing ResidualGraph
res
      notofvs :: [Vertex]
notofvs = (Vertex -> Bool) -> [Vertex] -> [Vertex]
forall a. (a -> Bool) -> [a] -> [a]
filter (\ Vertex
ov -> 
                          let (ResidualVertex Vertex
v Vertex
l Vertex
h Flow
x) = Maybe ResidualVertex -> ResidualVertex
forall a. HasCallStack => Maybe a -> a
fromJust (Vertex -> ResidualVertices -> Maybe ResidualVertex
forall a. Vertex -> IntMap a -> Maybe a
IM.lookup Vertex
ov (ResidualGraph -> ResidualVertices
netVertices ResidualGraph
res)) 
                              ml :: Maybe IntSet
ml = (Vertex -> Overflowing -> Maybe IntSet
forall a. Vertex -> IntMap a -> Maybe a
IM.lookup Vertex
l (ResidualGraph -> Overflowing
overflowing ResidualGraph
res)) 
                           in case Maybe IntSet
ml of
                                Maybe IntSet
Nothing -> Bool
True
                                Just IntSet
os -> Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Vertex -> IntSet -> Bool
Set.member Vertex
ov IntSet
os
                       ) ([Vertex] -> [Vertex]) -> [Vertex] -> [Vertex]
forall a b. (a -> b) -> a -> b
$ IntSet -> [Vertex]
Set.toList (IntSet -> [Vertex]) -> IntSet -> [Vertex]
forall a b. (a -> b) -> a -> b
$ ResidualVertices -> IntSet
getOverflowing (ResidualVertices -> IntSet) -> ResidualVertices -> IntSet
forall a b. (a -> b) -> a -> b
$ ResidualGraph -> ResidualVertices
netVertices ResidualGraph
res
      errovfs :: IntSet
errovfs = (Vertex -> Bool) -> IntSet -> IntSet
Set.filter (\Vertex
v -> ResidualGraph -> Vertex -> Flow
excess ResidualGraph
res Vertex
v Flow -> Flow -> Bool
forall a. Eq a => a -> a -> Bool
== Flow
0) IntSet
ofvs
   in if [Vertex] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Vertex]
insouts Bool -> Bool -> Bool
&& [Vertex] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Vertex]
xsflows Bool -> Bool -> Bool
&& IntSet -> Bool
Set.null IntSet
errovfs Bool -> Bool -> Bool
&& [Vertex] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Vertex]
notofvs
      then ResidualGraph -> Either String ResidualGraph
forall a b. b -> Either a b
Right ResidualGraph
res
      else 
        if Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [Vertex] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Vertex]
insouts 
              then String -> Either String ResidualGraph
forall a b. a -> Either a b
Left (String -> Either String ResidualGraph)
-> String -> Either String ResidualGraph
forall a b. (a -> b) -> a -> b
$ String
"Error Inflow < Outflow " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Vertex] -> String
forall a. Show a => a -> String
show [Vertex]
insouts
              else
                if Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [Vertex] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Vertex]
xsflows 
                  then String -> Either String ResidualGraph
forall a b. a -> Either a b
Left (String -> Either String ResidualGraph)
-> String -> Either String ResidualGraph
forall a b. (a -> b) -> a -> b
$ String
"Error vertex excess " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Vertex] -> String
forall a. Show a => a -> String
show [Vertex]
xsflows
                  else
                    if Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ IntSet -> Bool
Set.null IntSet
errovfs 
                      then String -> Either String ResidualGraph
forall a b. a -> Either a b
Left (String -> Either String ResidualGraph)
-> String -> Either String ResidualGraph
forall a b. (a -> b) -> a -> b
$ String
"Error not really overflowing " String -> String -> String
forall a. [a] -> [a] -> [a]
++ IntSet -> String
forall a. Show a => a -> String
show IntSet
errovfs
                      else String -> Either String ResidualGraph
forall a b. a -> Either a b
Left (String -> Either String ResidualGraph)
-> String -> Either String ResidualGraph
forall a b. (a -> b) -> a -> b
$ String
"Error not in overflowing " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Vertex] -> String
forall a. Show a => a -> String
show [Vertex]
notofvs
                        String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" overflowings are " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Overflowing -> String
forall a. Show a => a -> String
show (ResidualGraph -> Overflowing
overflowing ResidualGraph
res)
                        String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" nevertices are " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ResidualVertices -> String
forall a. Show a => a -> String
show (ResidualGraph -> ResidualVertices
netVertices ResidualGraph
res)

-- | Core recursive loop of the Tide algorithm.
--
-- Each call performs one tide: globalRelabel (unless skipped), then
-- globalPull, then globalPush.  Recurses until convergence (net flow
-- and overflowing set unchanged).
--
-- The @steps@ parameter counts completed iterations.
tide :: ResidualGraph -> Int -> ResidualGraph 
tide :: ResidualGraph -> Vertex -> ResidualGraph
tide ResidualGraph
rg Vertex
steps = 
  let g :: Graph
g = ResidualGraph
rg ResidualGraph -> Graph -> Graph
forall a b. a -> b -> b
`seq` (Network -> Graph
graph (Network -> Graph) -> Network -> Graph
forall a b. (a -> b) -> a -> b
$ ResidualGraph -> Network
network ResidualGraph
rg)
      s :: Vertex
s = Network -> Vertex
source (Network -> Vertex) -> Network -> Vertex
forall a b. (a -> b) -> a -> b
$ ResidualGraph -> Network
network ResidualGraph
rg
      t :: Vertex
t = Network -> Vertex
sink (Network -> Vertex) -> Network -> Vertex
forall a b. (a -> b) -> a -> b
$ ResidualGraph -> Network
network ResidualGraph
rg
      es :: [Edge]
es = Graph -> [Edge]
edges Graph
g
      vs :: [Vertex]
vs = Graph -> [Vertex]
vertices Graph
g
      olf :: Flow
olf = ResidualGraph -> Flow
netFlow ResidualGraph
rg
      -- Only run globalRelabel if the residual topology changed
      relabeled :: ResidualGraph
relabeled = if ResidualGraph -> Bool
topologyChanged ResidualGraph
rg
                  then ResidualGraph -> ResidualGraph
globalRelabel ResidualGraph
rg
                  else ResidualGraph
rg
      -- Reset flag before push/pull so we detect new changes
      rg0 :: ResidualGraph
rg0 = ResidualGraph
relabeled { topologyChanged = False }
      rg' :: ResidualGraph
rg' = ResidualGraph -> ResidualGraph
globalPush (ResidualGraph -> ResidualGraph) -> ResidualGraph -> ResidualGraph
forall a b. (a -> b) -> a -> b
$ ResidualGraph -> ResidualGraph
globalPull ResidualGraph
rg0 -- then global push and then global pull
      nfl :: Flow
nfl = ResidualGraph -> Flow
netFlow ResidualGraph
rg'
      steps' :: Vertex
steps' = Vertex
steps Vertex -> Vertex -> Vertex
forall a. Num a => a -> a -> a
+ Vertex
1
      oovfls :: Overflowing
oovfls = ResidualGraph -> Overflowing
overflowing ResidualGraph
rg
      novfls :: Overflowing
novfls = ResidualGraph -> Overflowing
overflowing ResidualGraph
rg'
   in if Flow
nfl Flow -> Flow -> Bool
forall a. Eq a => a -> a -> Bool
== Flow
olf -- if new flow == old flow 
         then 
           if Overflowing
oovfls Overflowing -> Overflowing -> Bool
forall a. Eq a => a -> a -> Bool
== Overflowing
novfls -- and the overflowing nodes didn't change
              then ResidualGraph
rg' { network = networkFromResidual rg' -- algorithm ends
                       , steps = steps'}
              else ResidualGraph -> Vertex -> ResidualGraph
tide ResidualGraph
rg' Vertex
steps'
         else ResidualGraph -> Vertex -> ResidualGraph
tide ResidualGraph
rg' Vertex
steps'

-- | Global push: sweep overflowing vertices from source to sink.
--
-- Iterates over overflowing vertices in /ascending level order/ (left fold
-- on the 'Overflowing' IntMap), pushing flow on all eligible /forward/
-- edges from each vertex.
--
-- This moves excess flow from source-side vertices towards the sink.
globalPush :: ResidualGraph -> ResidualGraph 
globalPush :: ResidualGraph -> ResidualGraph
globalPush ResidualGraph
rg = 
  let ovfs :: Overflowing
ovfs = ResidualGraph -> Overflowing
overflowing ResidualGraph
rg
   in (ResidualGraph -> IntSet -> ResidualGraph)
-> ResidualGraph -> Overflowing -> ResidualGraph
forall a b. (a -> b -> a) -> a -> IntMap b -> a
IM.foldl' (\ResidualGraph
ac IntSet
lset -> 
         (ResidualGraph -> Vertex -> ResidualGraph)
-> ResidualGraph -> IntSet -> ResidualGraph
forall a. (a -> Vertex -> a) -> a -> IntSet -> a
Set.foldl' (\ResidualGraph
ac' Vertex
v -> ResidualGraph -> Vertex -> ResidualGraph
pushNeighbors ResidualGraph
ac' Vertex
v)
         ResidualGraph
ac IntSet
lset
      ) ResidualGraph
rg Overflowing
ovfs

-- | Global pull: sweep overflowing vertices from sink to source.
--
-- Iterates over overflowing vertices in /descending level order/ (right fold
-- on the 'Overflowing' IntMap), pulling flow on all eligible /reverse/
-- edges to each vertex.
--
-- This moves excess flow from sink-side vertices back towards the source.
globalPull :: ResidualGraph -> ResidualGraph
globalPull :: ResidualGraph -> ResidualGraph
globalPull ResidualGraph
rg = 
  let ovfs :: Overflowing
ovfs = ResidualGraph -> Overflowing
overflowing ResidualGraph
rg
   in (IntSet -> ResidualGraph -> ResidualGraph)
-> ResidualGraph -> Overflowing -> ResidualGraph
forall a b. (a -> b -> b) -> b -> IntMap a -> b
IM.foldr' (\IntSet
lset ResidualGraph
ac -> 
         (ResidualGraph -> Vertex -> ResidualGraph)
-> ResidualGraph -> IntSet -> ResidualGraph
forall a. (a -> Vertex -> a) -> a -> IntSet -> a
Set.foldl' (\ResidualGraph
ac' Vertex
v -> ResidualGraph -> Vertex -> ResidualGraph
pullNeighbors ResidualGraph
ac' Vertex
v)
         ResidualGraph
ac IntSet
lset
               ) ResidualGraph
rg Overflowing
ovfs

-- | Push flow through all forward residual neighbors of a vertex.
pushNeighbors :: ResidualGraph -> Vertex -> ResidualGraph
pushNeighbors :: ResidualGraph -> Vertex -> ResidualGraph
pushNeighbors ResidualGraph
g Vertex
v =
  let neimap :: NeighborsMap
neimap = ResidualGraph -> NeighborsMap
netNeighborsMap ResidualGraph
g
      (IntMap Vertex
fwdMap, IntMap Vertex
_) = Maybe (IntMap Vertex, IntMap Vertex)
-> (IntMap Vertex, IntMap Vertex)
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe (IntMap Vertex, IntMap Vertex)
 -> (IntMap Vertex, IntMap Vertex))
-> Maybe (IntMap Vertex, IntMap Vertex)
-> (IntMap Vertex, IntMap Vertex)
forall a b. (a -> b) -> a -> b
$ Vertex -> NeighborsMap -> Maybe (IntMap Vertex, IntMap Vertex)
forall a. Vertex -> IntMap a -> Maybe a
IM.lookup Vertex
v NeighborsMap
neimap
      feds :: [Edge]
feds = (Vertex -> Edge) -> [Vertex] -> [Edge]
forall a b. (a -> b) -> [a] -> [b]
map (\Vertex
n -> (Vertex, Vertex) -> Edge
fromTuple (Vertex
v,Vertex
n)) ([Vertex] -> [Edge]) -> [Vertex] -> [Edge]
forall a b. (a -> b) -> a -> b
$ IntMap Vertex -> [Vertex]
forall a. IntMap a -> [Vertex]
IM.keys IntMap Vertex
fwdMap
   in (ResidualGraph -> Edge -> ResidualGraph)
-> ResidualGraph -> [Edge] -> ResidualGraph
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\ResidualGraph
ac Edge
e -> 
                let mv :: Maybe ResidualGraph
mv = ResidualGraph -> Edge -> Maybe ResidualGraph
push ResidualGraph
ac Edge
e
                in case Maybe ResidualGraph
mv of 
                    Maybe ResidualGraph
Nothing -> ResidualGraph
ac
                    Just ResidualGraph
g'' -> ResidualGraph
g'') ResidualGraph
g [Edge]
feds

-- | Pull flow through all reverse residual neighbors of a vertex.
pullNeighbors :: ResidualGraph -> Vertex -> ResidualGraph
pullNeighbors :: ResidualGraph -> Vertex -> ResidualGraph
pullNeighbors ResidualGraph
g Vertex
v =
  let neimap :: NeighborsMap
neimap = ResidualGraph -> NeighborsMap
netNeighborsMap ResidualGraph
g
      (IntMap Vertex
_, IntMap Vertex
revMap) = Maybe (IntMap Vertex, IntMap Vertex)
-> (IntMap Vertex, IntMap Vertex)
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe (IntMap Vertex, IntMap Vertex)
 -> (IntMap Vertex, IntMap Vertex))
-> Maybe (IntMap Vertex, IntMap Vertex)
-> (IntMap Vertex, IntMap Vertex)
forall a b. (a -> b) -> a -> b
$ Vertex -> NeighborsMap -> Maybe (IntMap Vertex, IntMap Vertex)
forall a. Vertex -> IntMap a -> Maybe a
IM.lookup Vertex
v NeighborsMap
neimap
      reds :: [Edge]
reds = (Vertex -> Edge) -> [Vertex] -> [Edge]
forall a b. (a -> b) -> [a] -> [b]
map (\Vertex
n -> (Vertex, Vertex) -> Edge
fromTuple (Vertex
n,Vertex
v)) ([Vertex] -> [Edge]) -> [Vertex] -> [Edge]
forall a b. (a -> b) -> a -> b
$ IntMap Vertex -> [Vertex]
forall a. IntMap a -> [Vertex]
IM.keys IntMap Vertex
revMap
   in (ResidualGraph -> Edge -> ResidualGraph)
-> ResidualGraph -> [Edge] -> ResidualGraph
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\ResidualGraph
ac Edge
e -> 
                let mv :: Maybe ResidualGraph
mv = ResidualGraph -> Edge -> Maybe ResidualGraph
pull ResidualGraph
ac Edge
e
                 in case Maybe ResidualGraph
mv of 
                      Maybe ResidualGraph
Nothing -> ResidualGraph
ac
                      Just ResidualGraph
g'' -> ResidualGraph
g'') ResidualGraph
g [Edge]
reds

-- | Global relabel: recompute vertex heights via BFS on the residual graph.
--
-- Runs BFS from both source and sink on the residual graph to compute
-- distances.  Sets vertex heights:
--
-- * Sink-side vertices: @height = distance_from_sink@
-- * Source-side vertices: @height = |V| + distance_from_source@
--
-- The height gap between source-side and sink-side vertices ensures
-- that flow can only move from source-side to sink-side (downhill).
globalRelabel :: ResidualGraph -> ResidualGraph
globalRelabel :: ResidualGraph -> ResidualGraph
globalRelabel ResidualGraph
rg =
  let g :: Graph
g = Network -> Graph
graph (Network -> Graph) -> Network -> Graph
forall a b. (a -> b) -> a -> b
$ ResidualGraph -> Network
network ResidualGraph
rg
      sh :: Vertex
sh = Graph -> Vertex
numVertices Graph
g
      s :: Vertex
s = Network -> Vertex
source (Network -> Vertex) -> Network -> Vertex
forall a b. (a -> b) -> a -> b
$ ResidualGraph -> Network
network ResidualGraph
rg
      t :: Vertex
t = Network -> Vertex
sink (Network -> Vertex) -> Network -> Vertex
forall a b. (a -> b) -> a -> b
$ ResidualGraph -> Network
network ResidualGraph
rg
      (IntMap Vertex
slvs, IntMap Vertex
tlvs) = ResidualGraph -> (IntMap Vertex, IntMap Vertex)
residualDistances ResidualGraph
rg
      -- Vertices not reached by either BFS get height 2*|V| so their
      -- excess drains back to the source via pull operations.
      allVs :: IntSet
allVs = [Vertex] -> IntSet
Set.fromList (Graph -> [Vertex]
vertices Graph
g)
      reachedS :: IntSet
reachedS = [Vertex] -> IntSet
Set.fromList (IntMap Vertex -> [Vertex]
forall a. IntMap a -> [Vertex]
IM.keys IntMap Vertex
slvs)
      reachedT :: IntSet
reachedT = [Vertex] -> IntSet
Set.fromList (IntMap Vertex -> [Vertex]
forall a. IntMap a -> [Vertex]
IM.keys IntMap Vertex
tlvs)
      reached :: IntSet
reached = IntSet -> IntSet -> IntSet
Set.union IntSet
reachedS IntSet
reachedT
      unreached :: IntSet
unreached = IntSet -> IntSet -> IntSet
Set.difference IntSet
allVs IntSet
reached
      deadHeight :: Vertex
deadHeight = Vertex
2 Vertex -> Vertex -> Vertex
forall a. Num a => a -> a -> a
* Vertex
sh
      rg0 :: ResidualGraph
rg0 = (ResidualGraph -> Vertex -> ResidualGraph)
-> ResidualGraph -> IntSet -> ResidualGraph
forall a. (a -> Vertex -> a) -> a -> IntSet -> a
Set.foldl' (\ResidualGraph
ac Vertex
v -> ResidualGraph -> Vertex -> Vertex -> ResidualGraph
updateHeight ResidualGraph
ac Vertex
v Vertex
deadHeight) ResidualGraph
rg IntSet
unreached
      rg' :: ResidualGraph
rg' = (Vertex -> Vertex -> ResidualGraph -> ResidualGraph)
-> ResidualGraph -> IntMap Vertex -> ResidualGraph
forall a b. (Vertex -> a -> b -> b) -> b -> IntMap a -> b
IM.foldrWithKey 
              (\ Vertex
v Vertex
l ResidualGraph
ac -> 
                 -- Heights for the source partition vertices is N + their distance to the source
                let h :: Vertex
h = Vertex
sh Vertex -> Vertex -> Vertex
forall a. Num a => a -> a -> a
+ Vertex
l 
                  in ResidualGraph -> Vertex -> Vertex -> ResidualGraph
updateHeight ResidualGraph
ac Vertex
v Vertex
h
              ) ResidualGraph
rg0 IntMap Vertex
slvs 
   in (Vertex -> Vertex -> ResidualGraph -> ResidualGraph)
-> ResidualGraph -> IntMap Vertex -> ResidualGraph
forall a b. (Vertex -> a -> b -> b) -> b -> IntMap a -> b
IM.foldrWithKey (\ Vertex
v Vertex
h ResidualGraph
ac
       -- Heights for the sink partition vertices equals the distance from sink
       -> ResidualGraph -> Vertex -> Vertex -> ResidualGraph
updateHeight ResidualGraph
ac Vertex
v Vertex
h) 
       ResidualGraph
rg' IntMap Vertex
tlvs