-- | Alternative Maximum Flow
module Data.Graph.Inductive.Query.MaxFlow2(
    Network,
    ekSimple, ekFused, ekList,
) where

--   ekSimple, ekFused, ekList) where


import Data.Maybe

import Data.Graph.Inductive.Graph
import Data.Graph.Inductive.Internal.Queue
import Data.Graph.Inductive.PatriciaTree
import Data.Graph.Inductive.Query.BFS      (bft)

import           Data.Set (Set)
import qualified Data.Set as S

------------------------------------------------------------------------------
-- Data types

-- Network data type
type Network = Gr () (Double, Double)

-- Data type for direction in which an edge is traversed
data Direction = Forward | Backward
    deriving (Direction -> Direction -> Bool
(Direction -> Direction -> Bool)
-> (Direction -> Direction -> Bool) -> Eq Direction
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Direction -> Direction -> Bool
$c/= :: Direction -> Direction -> Bool
== :: Direction -> Direction -> Bool
$c== :: Direction -> Direction -> Bool
Eq, Eq Direction
Eq Direction
-> (Direction -> Direction -> Ordering)
-> (Direction -> Direction -> Bool)
-> (Direction -> Direction -> Bool)
-> (Direction -> Direction -> Bool)
-> (Direction -> Direction -> Bool)
-> (Direction -> Direction -> Direction)
-> (Direction -> Direction -> Direction)
-> Ord Direction
Direction -> Direction -> Bool
Direction -> Direction -> Ordering
Direction -> Direction -> Direction
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Direction -> Direction -> Direction
$cmin :: Direction -> Direction -> Direction
max :: Direction -> Direction -> Direction
$cmax :: Direction -> Direction -> Direction
>= :: Direction -> Direction -> Bool
$c>= :: Direction -> Direction -> Bool
> :: Direction -> Direction -> Bool
$c> :: Direction -> Direction -> Bool
<= :: Direction -> Direction -> Bool
$c<= :: Direction -> Direction -> Bool
< :: Direction -> Direction -> Bool
$c< :: Direction -> Direction -> Bool
compare :: Direction -> Direction -> Ordering
$ccompare :: Direction -> Direction -> Ordering
$cp1Ord :: Eq Direction
Ord, Int -> Direction -> ShowS
[Direction] -> ShowS
Direction -> String
(Int -> Direction -> ShowS)
-> (Direction -> String)
-> ([Direction] -> ShowS)
-> Show Direction
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Direction] -> ShowS
$cshowList :: [Direction] -> ShowS
show :: Direction -> String
$cshow :: Direction -> String
showsPrec :: Int -> Direction -> ShowS
$cshowsPrec :: Int -> Direction -> ShowS
Show, ReadPrec [Direction]
ReadPrec Direction
Int -> ReadS Direction
ReadS [Direction]
(Int -> ReadS Direction)
-> ReadS [Direction]
-> ReadPrec Direction
-> ReadPrec [Direction]
-> Read Direction
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Direction]
$creadListPrec :: ReadPrec [Direction]
readPrec :: ReadPrec Direction
$creadPrec :: ReadPrec Direction
readList :: ReadS [Direction]
$creadList :: ReadS [Direction]
readsPrec :: Int -> ReadS Direction
$creadsPrec :: Int -> ReadS Direction
Read)

-- Data type for edge with direction of traversal
type DirEdge b = (Node, Node, b, Direction)

type DirPath=[(Node, Direction)]
type DirRTree=[DirPath]

pathFromDirPath :: DirPath -> [Node]
pathFromDirPath :: DirPath -> [Int]
pathFromDirPath = ((Int, Direction) -> Int) -> DirPath -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Int, Direction) -> Int
forall a b. (a, b) -> a
fst

------------------------------------------------------------------------------
-- Example networks

-- Example number 1
-- This network has a maximum flow of 2000
{-
exampleNetwork1 :: Network
exampleNetwork1=mkGraph [ (1,()), (2,()), (3,()), (4,()) ]
    [ (1,2,(1000,0)), (1,3,(1000,0)),
    (2,3,(1,0)), (2,4,(1000,0)), (3,4,(1000,0)) ]

-- Example number 2
-- Taken from "Introduction to Algorithms" (Cormen, Leiserson, Rivest)
-- This network has a maximum flow of 23
exampleNetwork2 :: Network
-- Names of nodes in "Introduction to Algorithms":
-- 1: s
-- 2: v1
-- 3: v2
-- 4: v3
-- 5: v4
-- 6: t
exampleNetwork2=mkGraph [ (1,()), (2,()), (3,()), (4,()), (5,()), (6,()) ]
    [ (1, 2, (16, 0)),
    (1, 3, (13, 0)),
    (2, 3, (10, 0)),
    (3, 2, (4, 0)),
    (2, 4, (12, 0)),
    (3, 5, (14, 0)),
    (4, 3, (9, 0)),
    (5, 4, (7, 0)),
    (4, 6, (20, 0)),
    (5, 6, (4, 0)) ]
-}
------------------------------------------------------------------------------
-- Implementation of Edmonds-Karp algorithm

-- EXTRACT fglEdmondsFused.txt
-- Compute an augmenting path
augPathFused :: Network -> Node -> Node -> Maybe DirPath
augPathFused :: Network -> Int -> Int -> Maybe DirPath
augPathFused Network
g Int
s Int
t = [DirPath] -> Maybe DirPath
forall a. [a] -> Maybe a
listToMaybe ([DirPath] -> Maybe DirPath) -> [DirPath] -> Maybe DirPath
forall a b. (a -> b) -> a -> b
$ (DirPath -> DirPath) -> [DirPath] -> [DirPath]
forall a b. (a -> b) -> [a] -> [b]
map DirPath -> DirPath
forall a. [a] -> [a]
reverse ([DirPath] -> [DirPath]) -> [DirPath] -> [DirPath]
forall a b. (a -> b) -> a -> b
$
    (DirPath -> Bool) -> [DirPath] -> [DirPath]
forall a. (a -> Bool) -> [a] -> [a]
filter (\((Int
u,Direction
_):DirPath
_) -> Int
uInt -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==Int
t) [DirPath]
tree
    where tree :: [DirPath]
tree = Int -> Network -> [DirPath]
bftForEK Int
s Network
g

-- Breadth First Search wrapper function
bftForEK :: Node -> Network -> DirRTree
bftForEK :: Int -> Network -> [DirPath]
bftForEK Int
v = Queue DirPath -> Network -> [DirPath]
bfForEK (DirPath -> Queue DirPath -> Queue DirPath
forall a. a -> Queue a -> Queue a
queuePut [(Int
v,Direction
Forward)] Queue DirPath
forall a. Queue a
mkQueue)

-- Breadth First Search, tailored for Edmonds & Karp
bfForEK :: Queue DirPath -> Network -> DirRTree
bfForEK :: Queue DirPath -> Network -> [DirPath]
bfForEK Queue DirPath
q Network
g
    | Queue DirPath -> Bool
forall a. Queue a -> Bool
queueEmpty Queue DirPath
q Bool -> Bool -> Bool
|| Network -> Bool
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> Bool
isEmpty Network
g = []
    | Bool
otherwise                 = case Int -> Network -> Decomp Gr () (Double, Double)
forall (gr :: * -> * -> *) a b.
Graph gr =>
Int -> gr a b -> Decomp gr a b
match Int
v Network
g of
        (Maybe (Context () (Double, Double))
Nothing, Network
g')                     -> Queue DirPath -> Network -> [DirPath]
bfForEK Queue DirPath
q1 Network
g'
        (Just (Adj (Double, Double)
preAdj, Int
_, ()
_, Adj (Double, Double)
sucAdj), Network
g') -> DirPath
pDirPath -> [DirPath] -> [DirPath]
forall a. a -> [a] -> [a]
:Queue DirPath -> Network -> [DirPath]
bfForEK Queue DirPath
q2 Network
g'
            where
                -- Insert successor nodes (with path to root) into queue
                q2 :: Queue DirPath
q2   = [DirPath] -> Queue DirPath -> Queue DirPath
forall a. [a] -> Queue a -> Queue a
queuePutList [DirPath]
suc1 (Queue DirPath -> Queue DirPath) -> Queue DirPath -> Queue DirPath
forall a b. (a -> b) -> a -> b
$ [DirPath] -> Queue DirPath -> Queue DirPath
forall a. [a] -> Queue a -> Queue a
queuePutList [DirPath]
suc2 Queue DirPath
q1
                -- Traverse edges in reverse if flow positive
                suc1 :: [DirPath]
suc1 = [ (Int
preNode, Direction
Backward)(Int, Direction) -> DirPath -> DirPath
forall a. a -> [a] -> [a]
:DirPath
p
                    | ((Double
_, Double
f), Int
preNode) <- Adj (Double, Double)
preAdj, Double
fDouble -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>Double
0]
                -- Traverse edges forwards if flow less than capacity
                suc2 :: [DirPath]
suc2 = [ (Int
sucNode,Direction
Forward)(Int, Direction) -> DirPath -> DirPath
forall a. a -> [a] -> [a]
:DirPath
p
                    | ((Double
c, Double
f), Int
sucNode) <- Adj (Double, Double)
sucAdj, Double
cDouble -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>Double
f]
    where (p :: DirPath
p@((Int
v,Direction
_):DirPath
_), Queue DirPath
q1)=Queue DirPath -> (DirPath, Queue DirPath)
forall a. Queue a -> (a, Queue a)
queueGet Queue DirPath
q

-- Extract augmenting path from network; return path as a sequence of
-- edges with direction of traversal, and new network with augmenting
-- path removed.
extractPathFused :: Network -> DirPath
    -> ([DirEdge (Double,Double)], Network)
extractPathFused :: Network -> DirPath -> ([DirEdge (Double, Double)], Network)
extractPathFused Network
g []  = ([], Network
g)
extractPathFused Network
g [(Int
_,Direction
_)] = ([], Network
g)
extractPathFused Network
g ((Int
u,Direction
_):rest :: DirPath
rest@((Int
v,Direction
Forward):DirPath
_)) =
    ((Int
u, Int
v, (Double, Double)
l, Direction
Forward)DirEdge (Double, Double)
-> [DirEdge (Double, Double)] -> [DirEdge (Double, Double)]
forall a. a -> [a] -> [a]
:[DirEdge (Double, Double)]
tailedges, Network
newerg)
        where ([DirEdge (Double, Double)]
tailedges, Network
newerg) = Network -> DirPath -> ([DirEdge (Double, Double)], Network)
extractPathFused Network
newg DirPath
rest
              Just ((Double, Double)
l, Network
newg)    = Network
-> Int
-> Int
-> ((Double, Double) -> Bool)
-> Maybe ((Double, Double), Network)
forall a b.
Gr a b -> Int -> Int -> (b -> Bool) -> Maybe (b, Gr a b)
extractEdge Network
g Int
u Int
v ((Double -> Double -> Bool) -> (Double, Double) -> Bool
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
(>))
extractPathFused Network
g ((Int
u,Direction
_):rest :: DirPath
rest@((Int
v,Direction
Backward):DirPath
_)) =
    ((Int
v, Int
u, (Double, Double)
l, Direction
Backward)DirEdge (Double, Double)
-> [DirEdge (Double, Double)] -> [DirEdge (Double, Double)]
forall a. a -> [a] -> [a]
:[DirEdge (Double, Double)]
tailedges, Network
newerg)
        where ([DirEdge (Double, Double)]
tailedges, Network
newerg) = Network -> DirPath -> ([DirEdge (Double, Double)], Network)
extractPathFused Network
newg DirPath
rest
              Just ((Double, Double)
l, Network
newg)    = Network
-> Int
-> Int
-> ((Double, Double) -> Bool)
-> Maybe ((Double, Double), Network)
forall a b.
Gr a b -> Int -> Int -> (b -> Bool) -> Maybe (b, Gr a b)
extractEdge Network
g Int
v Int
u (\(Double
_,Double
f)->(Double
fDouble -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>Double
0))

ekFusedStep :: EKStepFunc
ekFusedStep :: EKStepFunc
ekFusedStep Network
g Int
s Int
t = case Maybe DirPath
maybePath of
        Just DirPath
_          ->
            (Network, Double) -> Maybe (Network, Double)
forall a. a -> Maybe a
Just ([LEdge (Double, Double)] -> Network -> Network
forall (gr :: * -> * -> *) b a.
DynGraph gr =>
[LEdge b] -> gr a b -> gr a b
insEdges ([DirEdge (Double, Double)] -> Double -> [LEdge (Double, Double)]
integrateDelta [DirEdge (Double, Double)]
es Double
delta) Network
newg, Double
delta)
        Maybe DirPath
Nothing   -> Maybe (Network, Double)
forall a. Maybe a
Nothing
    where maybePath :: Maybe DirPath
maybePath     = Network -> Int -> Int -> Maybe DirPath
augPathFused Network
g Int
s Int
t
          ([DirEdge (Double, Double)]
es, Network
newg) = Network -> DirPath -> ([DirEdge (Double, Double)], Network)
extractPathFused Network
g (Maybe DirPath -> DirPath
forall a. HasCallStack => Maybe a -> a
fromJust Maybe DirPath
maybePath)
          delta :: Double
delta         = [Double] -> Double
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum ([Double] -> Double) -> [Double] -> Double
forall a b. (a -> b) -> a -> b
$ [DirEdge (Double, Double)] -> [Double]
getPathDeltas [DirEdge (Double, Double)]
es

ekFused :: Network -> Node -> Node -> (Network, Double)
ekFused :: Network -> Int -> Int -> (Network, Double)
ekFused = EKStepFunc -> Network -> Int -> Int -> (Network, Double)
ekWith EKStepFunc
ekFusedStep
-- ENDEXTRACT

-----------------------------------------------------------------------------
-- Alternative implementation: Use an explicit residual graph

-- EXTRACT fglEdmondsSimple.txt
residualGraph :: Network -> Gr () Double
residualGraph :: Network -> Gr () Double
residualGraph Network
g =
    [LNode ()] -> [LEdge Double] -> Gr () Double
forall (gr :: * -> * -> *) a b.
Graph gr =>
[LNode a] -> [LEdge b] -> gr a b
mkGraph (Network -> [LNode ()]
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [LNode a]
labNodes Network
g)
        ([(Int
u, Int
v, Double
cDouble -> Double -> Double
forall a. Num a => a -> a -> a
-Double
f) | (Int
u, Int
v, (Double
c,Double
f)) <- Network -> [LEdge (Double, Double)]
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [LEdge b]
labEdges Network
g, Double
cDouble -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>Double
f ] [LEdge Double] -> [LEdge Double] -> [LEdge Double]
forall a. [a] -> [a] -> [a]
++
         [(Int
v, Int
u, Double
f) | (Int
u,Int
v,(Double
_,Double
f)) <- Network -> [LEdge (Double, Double)]
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [LEdge b]
labEdges Network
g, Double
fDouble -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>Double
0])

augPath :: Network -> Node -> Node -> Maybe Path
augPath :: Network -> Int -> Int -> Maybe [Int]
augPath Network
g Int
s Int
t = [[Int]] -> Maybe [Int]
forall a. [a] -> Maybe a
listToMaybe ([[Int]] -> Maybe [Int]) -> [[Int]] -> Maybe [Int]
forall a b. (a -> b) -> a -> b
$ ([Int] -> [Int]) -> [[Int]] -> [[Int]]
forall a b. (a -> b) -> [a] -> [b]
map [Int] -> [Int]
forall a. [a] -> [a]
reverse ([[Int]] -> [[Int]]) -> [[Int]] -> [[Int]]
forall a b. (a -> b) -> a -> b
$ ([Int] -> Bool) -> [[Int]] -> [[Int]]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(Int
u:[Int]
_) -> Int
uInt -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==Int
t) [[Int]]
tree
    where tree :: [[Int]]
tree = Int -> Gr () Double -> [[Int]]
forall (gr :: * -> * -> *) a b.
Graph gr =>
Int -> gr a b -> [[Int]]
bft Int
s (Network -> Gr () Double
residualGraph Network
g)

-- Extract augmenting path from network; return path as a sequence of
-- edges with direction of traversal, and new network with augmenting
-- path removed.
extractPath :: Network -> Path -> ([DirEdge (Double,Double)], Network)
extractPath :: Network -> [Int] -> ([DirEdge (Double, Double)], Network)
extractPath Network
g []  = ([], Network
g)
extractPath Network
g [Int
_] = ([], Network
g)
extractPath Network
g (Int
u:Int
v:[Int]
ws) =
    case Maybe ((Double, Double), Network)
fwdExtract of
        Just ((Double, Double)
l, Network
newg) -> ((Int
u, Int
v, (Double, Double)
l, Direction
Forward)DirEdge (Double, Double)
-> [DirEdge (Double, Double)] -> [DirEdge (Double, Double)]
forall a. a -> [a] -> [a]
:[DirEdge (Double, Double)]
tailedges, Network
newerg)
            where ([DirEdge (Double, Double)]
tailedges, Network
newerg) = Network -> [Int] -> ([DirEdge (Double, Double)], Network)
extractPath Network
newg (Int
vInt -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:[Int]
ws)
        Maybe ((Double, Double), Network)
Nothing          ->
            case Maybe ((Double, Double), Network)
revExtract of
                Just ((Double, Double)
l, Network
newg) ->
                    ((Int
v, Int
u, (Double, Double)
l, Direction
Backward)DirEdge (Double, Double)
-> [DirEdge (Double, Double)] -> [DirEdge (Double, Double)]
forall a. a -> [a] -> [a]
:[DirEdge (Double, Double)]
tailedges, Network
newerg)
                    where ([DirEdge (Double, Double)]
tailedges, Network
newerg) = Network -> [Int] -> ([DirEdge (Double, Double)], Network)
extractPath Network
newg (Int
vInt -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:[Int]
ws)
                Maybe ((Double, Double), Network)
Nothing               -> String -> ([DirEdge (Double, Double)], Network)
forall a. HasCallStack => String -> a
error String
"extractPath: revExtract == Nothing"
    where fwdExtract :: Maybe ((Double, Double), Network)
fwdExtract = Network
-> Int
-> Int
-> ((Double, Double) -> Bool)
-> Maybe ((Double, Double), Network)
forall a b.
Gr a b -> Int -> Int -> (b -> Bool) -> Maybe (b, Gr a b)
extractEdge Network
g Int
u Int
v ((Double -> Double -> Bool) -> (Double, Double) -> Bool
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
(>))
          revExtract :: Maybe ((Double, Double), Network)
revExtract = Network
-> Int
-> Int
-> ((Double, Double) -> Bool)
-> Maybe ((Double, Double), Network)
forall a b.
Gr a b -> Int -> Int -> (b -> Bool) -> Maybe (b, Gr a b)
extractEdge Network
g Int
v Int
u ((Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>Double
0) (Double -> Bool)
-> ((Double, Double) -> Double) -> (Double, Double) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Double, Double) -> Double
forall a b. (a, b) -> b
snd)

-- Extract an edge from the graph that satisfies a given predicate
-- Return the label on the edge and the graph without the edge
extractEdge :: Gr a b -> Node -> Node -> (b->Bool) -> Maybe (b, Gr a b)
extractEdge :: Gr a b -> Int -> Int -> (b -> Bool) -> Maybe (b, Gr a b)
extractEdge Gr a b
g Int
u Int
v b -> Bool
p =
    case Maybe (b, Int)
adj of
        Just (b
el, Int
_) -> (b, Gr a b) -> Maybe (b, Gr a b)
forall a. a -> Maybe a
Just (b
el, (Adj b
p', Int
node, a
l, Adj b
rest) Context a b -> Gr a b -> Gr a b
forall (gr :: * -> * -> *) a b.
DynGraph gr =>
Context a b -> gr a b -> gr a b
& Gr a b
newg)
        Maybe (b, Int)
Nothing      -> Maybe (b, Gr a b)
forall a. Maybe a
Nothing
    where (Just (Adj b
p', Int
node, a
l, Adj b
s), Gr a b
newg) = Int -> Gr a b -> (Maybe (Context a b), Gr a b)
forall (gr :: * -> * -> *) a b.
Graph gr =>
Int -> gr a b -> Decomp gr a b
match Int
u Gr a b
g
          (Maybe (b, Int)
adj, Adj b
rest)=Adj b -> ((b, Int) -> Bool) -> (Maybe (b, Int), Adj b)
forall b. Adj b -> ((b, Int) -> Bool) -> (Maybe (b, Int), Adj b)
extractAdj Adj b
s
              (\(b
l', Int
dest) -> Int
destInt -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==Int
v Bool -> Bool -> Bool
&& b -> Bool
p b
l')

-- Extract an item from an adjacency list that satisfies a given
-- predicate. Return the item and the rest of the adjacency list
extractAdj :: Adj b -> ((b,Node)->Bool) -> (Maybe (b,Node), Adj b)
extractAdj :: Adj b -> ((b, Int) -> Bool) -> (Maybe (b, Int), Adj b)
extractAdj []         (b, Int) -> Bool
_ = (Maybe (b, Int)
forall a. Maybe a
Nothing, [])
extractAdj ((b, Int)
adj:Adj b
adjs) (b, Int) -> Bool
p
    | (b, Int) -> Bool
p (b, Int)
adj     = ((b, Int) -> Maybe (b, Int)
forall a. a -> Maybe a
Just (b, Int)
adj, Adj b
adjs)
    | Bool
otherwise = (Maybe (b, Int)
theone, (b, Int)
adj(b, Int) -> Adj b -> Adj b
forall a. a -> [a] -> [a]
:Adj b
rest)
        where (Maybe (b, Int)
theone, Adj b
rest)=Adj b -> ((b, Int) -> Bool) -> (Maybe (b, Int), Adj b)
forall b. Adj b -> ((b, Int) -> Bool) -> (Maybe (b, Int), Adj b)
extractAdj Adj b
adjs (b, Int) -> Bool
p

getPathDeltas :: [DirEdge (Double,Double)] -> [Double]
getPathDeltas :: [DirEdge (Double, Double)] -> [Double]
getPathDeltas []     = []
getPathDeltas (DirEdge (Double, Double)
e:[DirEdge (Double, Double)]
es) = case DirEdge (Double, Double)
e of
    (Int
_, Int
_, (Double
c,Double
f), Direction
Forward)  -> Double
cDouble -> Double -> Double
forall a. Num a => a -> a -> a
-Double
f Double -> [Double] -> [Double]
forall a. a -> [a] -> [a]
: [DirEdge (Double, Double)] -> [Double]
getPathDeltas [DirEdge (Double, Double)]
es
    (Int
_, Int
_, (Double
_,Double
f), Direction
Backward) -> Double
f Double -> [Double] -> [Double]
forall a. a -> [a] -> [a]
: [DirEdge (Double, Double)] -> [Double]
getPathDeltas [DirEdge (Double, Double)]
es

integrateDelta :: [DirEdge (Double,Double)] -> Double
    -> [LEdge (Double, Double)]
integrateDelta :: [DirEdge (Double, Double)] -> Double -> [LEdge (Double, Double)]
integrateDelta []          Double
_ = []
integrateDelta (DirEdge (Double, Double)
e:[DirEdge (Double, Double)]
es) Double
delta = case DirEdge (Double, Double)
e of
    (Int
u, Int
v, (Double
c, Double
f), Direction
Forward) ->
        (Int
u, Int
v, (Double
c, Double
fDouble -> Double -> Double
forall a. Num a => a -> a -> a
+Double
delta)) LEdge (Double, Double)
-> [LEdge (Double, Double)] -> [LEdge (Double, Double)]
forall a. a -> [a] -> [a]
: [DirEdge (Double, Double)] -> Double -> [LEdge (Double, Double)]
integrateDelta [DirEdge (Double, Double)]
es Double
delta
    (Int
u, Int
v, (Double
c, Double
f), Direction
Backward) ->
        (Int
u, Int
v, (Double
c, Double
fDouble -> Double -> Double
forall a. Num a => a -> a -> a
-Double
delta)) LEdge (Double, Double)
-> [LEdge (Double, Double)] -> [LEdge (Double, Double)]
forall a. a -> [a] -> [a]
: [DirEdge (Double, Double)] -> Double -> [LEdge (Double, Double)]
integrateDelta [DirEdge (Double, Double)]
es Double
delta

type EKStepFunc = Network -> Node -> Node -> Maybe (Network, Double)

ekSimpleStep :: EKStepFunc
ekSimpleStep :: EKStepFunc
ekSimpleStep Network
g Int
s Int
t = case Maybe [Int]
maybePath of
        Just [Int]
_ ->
            (Network, Double) -> Maybe (Network, Double)
forall a. a -> Maybe a
Just ([LEdge (Double, Double)] -> Network -> Network
forall (gr :: * -> * -> *) b a.
DynGraph gr =>
[LEdge b] -> gr a b -> gr a b
insEdges ([DirEdge (Double, Double)] -> Double -> [LEdge (Double, Double)]
integrateDelta [DirEdge (Double, Double)]
es Double
delta) Network
newg, Double
delta)
        Maybe [Int]
Nothing   -> Maybe (Network, Double)
forall a. Maybe a
Nothing
    where maybePath :: Maybe [Int]
maybePath  = Network -> Int -> Int -> Maybe [Int]
augPath Network
g Int
s Int
t
          ([DirEdge (Double, Double)]
es, Network
newg) = Network -> [Int] -> ([DirEdge (Double, Double)], Network)
extractPath Network
g (Maybe [Int] -> [Int]
forall a. HasCallStack => Maybe a -> a
fromJust Maybe [Int]
maybePath)
          delta :: Double
delta      = [Double] -> Double
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum ([Double] -> Double) -> [Double] -> Double
forall a b. (a -> b) -> a -> b
$ [DirEdge (Double, Double)] -> [Double]
getPathDeltas [DirEdge (Double, Double)]
es

ekWith :: EKStepFunc -> Network -> Node -> Node -> (Network, Double)
ekWith :: EKStepFunc -> Network -> Int -> Int -> (Network, Double)
ekWith EKStepFunc
stepfunc Network
g Int
s Int
t = case EKStepFunc
stepfunc Network
g Int
s Int
t of
    Just (Network
newg, Double
delta) -> (Network
finalg, Double
capacityDouble -> Double -> Double
forall a. Num a => a -> a -> a
+Double
delta)
        where (Network
finalg, Double
capacity) = EKStepFunc -> Network -> Int -> Int -> (Network, Double)
ekWith EKStepFunc
stepfunc Network
newg Int
s Int
t
    Maybe (Network, Double)
Nothing            -> (Network
g, Double
0)

ekSimple :: Network -> Node -> Node -> (Network, Double)
ekSimple :: Network -> Int -> Int -> (Network, Double)
ekSimple = EKStepFunc -> Network -> Int -> Int -> (Network, Double)
ekWith EKStepFunc
ekSimpleStep
-- ENDEXTRACT

-----------------------------------------------------------------------------
-- Alternative implementation: Process list of edges to extract path instead
-- of operating on graph structure

extractPathList :: [LEdge (Double, Double)] -> Set (Node,Node)
    -> ([DirEdge (Double, Double)], [LEdge (Double, Double)])
extractPathList :: [LEdge (Double, Double)]
-> Set (Int, Int)
-> ([DirEdge (Double, Double)], [LEdge (Double, Double)])
extractPathList []                 Set (Int, Int)
_ = ([], [])
extractPathList (edge :: LEdge (Double, Double)
edge@(Int
u,Int
v,l :: (Double, Double)
l@(Double
c,Double
f)):[LEdge (Double, Double)]
es) Set (Int, Int)
set
    | (Double
cDouble -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>Double
f) Bool -> Bool -> Bool
&& (Int, Int) -> Set (Int, Int) -> Bool
forall a. Ord a => a -> Set a -> Bool
S.member (Int
u,Int
v) Set (Int, Int)
set =
        let ([DirEdge (Double, Double)]
pathrest, [LEdge (Double, Double)]
notrest)=[LEdge (Double, Double)]
-> Set (Int, Int)
-> ([DirEdge (Double, Double)], [LEdge (Double, Double)])
extractPathList [LEdge (Double, Double)]
es ((Int, Int) -> Set (Int, Int) -> Set (Int, Int)
forall a. Ord a => a -> Set a -> Set a
S.delete (Int
u,Int
v) Set (Int, Int)
set)
            in ((Int
u,Int
v,(Double, Double)
l,Direction
Forward)DirEdge (Double, Double)
-> [DirEdge (Double, Double)] -> [DirEdge (Double, Double)]
forall a. a -> [a] -> [a]
:[DirEdge (Double, Double)]
pathrest, [LEdge (Double, Double)]
notrest)
    | (Double
fDouble -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>Double
0) Bool -> Bool -> Bool
&& (Int, Int) -> Set (Int, Int) -> Bool
forall a. Ord a => a -> Set a -> Bool
S.member (Int
v,Int
u) Set (Int, Int)
set =
        let ([DirEdge (Double, Double)]
pathrest, [LEdge (Double, Double)]
notrest)=[LEdge (Double, Double)]
-> Set (Int, Int)
-> ([DirEdge (Double, Double)], [LEdge (Double, Double)])
extractPathList [LEdge (Double, Double)]
es ((Int, Int) -> Set (Int, Int) -> Set (Int, Int)
forall a. Ord a => a -> Set a -> Set a
S.delete (Int
u,Int
v) Set (Int, Int)
set)
            in ((Int
u,Int
v,(Double, Double)
l,Direction
Backward)DirEdge (Double, Double)
-> [DirEdge (Double, Double)] -> [DirEdge (Double, Double)]
forall a. a -> [a] -> [a]
:[DirEdge (Double, Double)]
pathrest, [LEdge (Double, Double)]
notrest)
    | Bool
otherwise                        =
        let ([DirEdge (Double, Double)]
pathrest, [LEdge (Double, Double)]
notrest)=[LEdge (Double, Double)]
-> Set (Int, Int)
-> ([DirEdge (Double, Double)], [LEdge (Double, Double)])
extractPathList [LEdge (Double, Double)]
es Set (Int, Int)
set in
            ([DirEdge (Double, Double)]
pathrest, LEdge (Double, Double)
edgeLEdge (Double, Double)
-> [LEdge (Double, Double)] -> [LEdge (Double, Double)]
forall a. a -> [a] -> [a]
:[LEdge (Double, Double)]
notrest)

ekStepList :: EKStepFunc
ekStepList :: EKStepFunc
ekStepList Network
g Int
s Int
t = case Maybe DirPath
maybePath of
        Just DirPath
_  -> (Network, Double) -> Maybe (Network, Double)
forall a. a -> Maybe a
Just ([LNode ()] -> [LEdge (Double, Double)] -> Network
forall (gr :: * -> * -> *) a b.
Graph gr =>
[LNode a] -> [LEdge b] -> gr a b
mkGraph (Network -> [LNode ()]
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [LNode a]
labNodes Network
g) [LEdge (Double, Double)]
newEdges, Double
delta)
        Maybe DirPath
Nothing -> Maybe (Network, Double)
forall a. Maybe a
Nothing
    where newEdges :: [LEdge (Double, Double)]
newEdges      = [DirEdge (Double, Double)] -> Double -> [LEdge (Double, Double)]
integrateDelta [DirEdge (Double, Double)]
es Double
delta [LEdge (Double, Double)]
-> [LEdge (Double, Double)] -> [LEdge (Double, Double)]
forall a. [a] -> [a] -> [a]
++ [LEdge (Double, Double)]
otheredges
          maybePath :: Maybe DirPath
maybePath     = Network -> Int -> Int -> Maybe DirPath
augPathFused Network
g Int
s Int
t
          ([DirEdge (Double, Double)]
es, [LEdge (Double, Double)]
otheredges) = [LEdge (Double, Double)]
-> Set (Int, Int)
-> ([DirEdge (Double, Double)], [LEdge (Double, Double)])
extractPathList (Network -> [LEdge (Double, Double)]
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [LEdge b]
labEdges Network
g)
              ([(Int, Int)] -> Set (Int, Int)
forall a. Ord a => [a] -> Set a
S.fromList ([Int] -> [Int] -> [(Int, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int]
justPath ([Int] -> [Int]
forall a. [a] -> [a]
tail [Int]
justPath)))
          delta :: Double
delta         = [Double] -> Double
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum ([Double] -> Double) -> [Double] -> Double
forall a b. (a -> b) -> a -> b
$ [DirEdge (Double, Double)] -> [Double]
getPathDeltas [DirEdge (Double, Double)]
es
          justPath :: [Int]
justPath      = DirPath -> [Int]
pathFromDirPath (Maybe DirPath -> DirPath
forall a. HasCallStack => Maybe a -> a
fromJust Maybe DirPath
maybePath)

ekList :: Network -> Node -> Node -> (Network, Double)
ekList :: Network -> Int -> Int -> (Network, Double)
ekList = EKStepFunc -> Network -> Int -> Int -> (Network, Double)
ekWith EKStepFunc
ekStepList
-- ENDEXTRACT