-- | 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
$c== :: Direction -> Direction -> Bool
== :: Direction -> Direction -> Bool
$c/= :: Direction -> Direction -> Bool
/= :: 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
$ccompare :: Direction -> Direction -> Ordering
compare :: Direction -> Direction -> Ordering
$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
>= :: Direction -> Direction -> Bool
$cmax :: Direction -> Direction -> Direction
max :: Direction -> Direction -> Direction
$cmin :: Direction -> Direction -> Direction
min :: Direction -> Direction -> Direction
Ord, Node -> Direction -> ShowS
[Direction] -> ShowS
Direction -> String
(Node -> Direction -> ShowS)
-> (Direction -> String)
-> ([Direction] -> ShowS)
-> Show Direction
forall a.
(Node -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Node -> Direction -> ShowS
showsPrec :: Node -> Direction -> ShowS
$cshow :: Direction -> String
show :: Direction -> String
$cshowList :: [Direction] -> ShowS
showList :: [Direction] -> ShowS
Show, ReadPrec [Direction]
ReadPrec Direction
Node -> ReadS Direction
ReadS [Direction]
(Node -> ReadS Direction)
-> ReadS [Direction]
-> ReadPrec Direction
-> ReadPrec [Direction]
-> Read Direction
forall a.
(Node -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Node -> ReadS Direction
readsPrec :: Node -> ReadS Direction
$creadList :: ReadS [Direction]
readList :: ReadS [Direction]
$creadPrec :: ReadPrec Direction
readPrec :: ReadPrec Direction
$creadListPrec :: ReadPrec [Direction]
readListPrec :: ReadPrec [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 -> [Node]
pathFromDirPath = ((Node, Direction) -> Node) -> DirPath -> [Node]
forall a b. (a -> b) -> [a] -> [b]
map (Node, Direction) -> Node
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 -> Node -> Node -> Maybe DirPath
augPathFused Network
g Node
s Node
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 ((Node -> Node -> Bool
forall a. Eq a => a -> a -> Bool
==Node
t) (Node -> Bool) -> (DirPath -> Node) -> DirPath -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Node, Direction) -> Node
forall a b. (a, b) -> a
fst ((Node, Direction) -> Node)
-> (DirPath -> (Node, Direction)) -> DirPath -> Node
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DirPath -> (Node, Direction)
forall a. HasCallStack => [a] -> a
head) [DirPath]
tree
    where tree :: [DirPath]
tree = Node -> Network -> [DirPath]
bftForEK Node
s Network
g

-- Breadth First Search wrapper function
bftForEK :: Node -> Network -> DirRTree
bftForEK :: Node -> Network -> [DirPath]
bftForEK Node
v = Queue DirPath -> Network -> [DirPath]
bfForEK (DirPath -> Queue DirPath -> Queue DirPath
forall a. a -> Queue a -> Queue a
queuePut [(Node
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 a b. Gr a b -> Bool
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> Bool
isEmpty Network
g = []
  | Bool
otherwise                 =
     case Queue DirPath -> (DirPath, Queue DirPath)
forall a. Queue a -> (a, Queue a)
queueGet Queue DirPath
q of
      ([], Queue DirPath
_) -> []
      (p :: DirPath
p@((Node
v,Direction
_):DirPath
_), Queue DirPath
q1) ->
       case Node -> Network -> Decomp Gr () (Double, Double)
forall a b. Node -> Gr a b -> Decomp Gr a b
forall (gr :: * -> * -> *) a b.
Graph gr =>
Node -> gr a b -> Decomp gr a b
match Node
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, Node
_, ()
_, 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 = [ (Node
preNode, Direction
Backward)(Node, Direction) -> DirPath -> DirPath
forall a. a -> [a] -> [a]
:DirPath
p
                    | ((Double
_, Double
f), Node
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 = [ (Node
sucNode,Direction
Forward)(Node, Direction) -> DirPath -> DirPath
forall a. a -> [a] -> [a]
:DirPath
p
                    | ((Double
c, Double
f), Node
sucNode) <- Adj (Double, Double)
sucAdj, Double
cDouble -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>Double
f]

-- 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 [(Node
_,Direction
_)] = ([], Network
g)
extractPathFused Network
g ((Node
u,Direction
_):rest :: DirPath
rest@((Node
v,Direction
Forward):DirPath
_)) =
  case Network
-> Node
-> Node
-> ((Double, Double) -> Bool)
-> Maybe ((Double, Double), Network)
forall a b.
Gr a b -> Node -> Node -> (b -> Bool) -> Maybe (b, Gr a b)
extractEdge Network
g Node
u Node
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
(>)) of
    Just ((Double, Double)
l, Network
newg) ->
      let ([DirEdge (Double, Double)]
tailedges, Network
newerg) = Network -> DirPath -> ([DirEdge (Double, Double)], Network)
extractPathFused Network
newg DirPath
rest
      in ((Node
u, Node
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)
    Maybe ((Double, Double), Network)
Nothing -> String -> ([DirEdge (Double, Double)], Network)
forall a. HasCallStack => String -> a
error String
"extractPathFused Forward: invalid edge"
extractPathFused Network
g ((Node
u,Direction
_):rest :: DirPath
rest@((Node
v,Direction
Backward):DirPath
_)) =
  case Network
-> Node
-> Node
-> ((Double, Double) -> Bool)
-> Maybe ((Double, Double), Network)
forall a b.
Gr a b -> Node -> Node -> (b -> Bool) -> Maybe (b, Gr a b)
extractEdge Network
g Node
v Node
u (\(Double
_,Double
f)->(Double
fDouble -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>Double
0)) of
    Just ((Double, Double)
l, Network
newg) ->
      let ([DirEdge (Double, Double)]
tailedges, Network
newerg) = Network -> DirPath -> ([DirEdge (Double, Double)], Network)
extractPathFused Network
newg DirPath
rest
      in ((Node
v, Node
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)
    Maybe ((Double, Double), Network)
Nothing -> String -> ([DirEdge (Double, Double)], Network)
forall a. HasCallStack => String -> a
error String
"extractPathFused Backward: invalid edge"

ekFusedStep :: EKStepFunc
ekFusedStep :: EKStepFunc
ekFusedStep Network
g Node
s Node
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 -> Node -> Node -> Maybe DirPath
augPathFused Network
g Node
s Node
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 a. Ord a => [a] -> a
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 -> Node -> Node -> (Network, Double)
ekFused = EKStepFunc -> Network -> Node -> Node -> (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 a b. [LNode a] -> [LEdge b] -> Gr a b
forall (gr :: * -> * -> *) a b.
Graph gr =>
[LNode a] -> [LEdge b] -> gr a b
mkGraph (Network -> [LNode ()]
forall a b. Gr a b -> [LNode a]
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [LNode a]
labNodes Network
g)
        ([(Node
u, Node
v, Double
cDouble -> Double -> Double
forall a. Num a => a -> a -> a
-Double
f) | (Node
u, Node
v, (Double
c,Double
f)) <- Network -> [LEdge (Double, Double)]
forall a b. Gr a b -> [LEdge b]
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]
++
         [(Node
v, Node
u, Double
f) | (Node
u,Node
v,(Double
_,Double
f)) <- Network -> [LEdge (Double, Double)]
forall a b. Gr a b -> [LEdge b]
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 -> Node -> Node -> Maybe [Node]
augPath Network
g Node
s Node
t = [[Node]] -> Maybe [Node]
forall a. [a] -> Maybe a
listToMaybe ([[Node]] -> Maybe [Node]) -> [[Node]] -> Maybe [Node]
forall a b. (a -> b) -> a -> b
$ ([Node] -> [Node]) -> [[Node]] -> [[Node]]
forall a b. (a -> b) -> [a] -> [b]
map [Node] -> [Node]
forall a. [a] -> [a]
reverse ([[Node]] -> [[Node]]) -> [[Node]] -> [[Node]]
forall a b. (a -> b) -> a -> b
$ ([Node] -> Bool) -> [[Node]] -> [[Node]]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Node -> Node -> Bool
forall a. Eq a => a -> a -> Bool
==Node
t) (Node -> Bool) -> ([Node] -> Node) -> [Node] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Node] -> Node
forall a. HasCallStack => [a] -> a
head) [[Node]]
tree
    where tree :: [[Node]]
tree = Node -> Gr () Double -> [[Node]]
forall (gr :: * -> * -> *) a b.
Graph gr =>
Node -> gr a b -> [[Node]]
bft Node
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 -> [Node] -> ([DirEdge (Double, Double)], Network)
extractPath Network
g []  = ([], Network
g)
extractPath Network
g [Node
_] = ([], Network
g)
extractPath Network
g (Node
u:Node
v:[Node]
ws) =
    case Maybe ((Double, Double), Network)
fwdExtract of
        Just ((Double, Double)
l, Network
newg) -> ((Node
u, Node
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 -> [Node] -> ([DirEdge (Double, Double)], Network)
extractPath Network
newg (Node
vNode -> [Node] -> [Node]
forall a. a -> [a] -> [a]
:[Node]
ws)
        Maybe ((Double, Double), Network)
Nothing          ->
            case Maybe ((Double, Double), Network)
revExtract of
                Just ((Double, Double)
l, Network
newg) ->
                    ((Node
v, Node
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 -> [Node] -> ([DirEdge (Double, Double)], Network)
extractPath Network
newg (Node
vNode -> [Node] -> [Node]
forall a. a -> [a] -> [a]
:[Node]
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
-> Node
-> Node
-> ((Double, Double) -> Bool)
-> Maybe ((Double, Double), Network)
forall a b.
Gr a b -> Node -> Node -> (b -> Bool) -> Maybe (b, Gr a b)
extractEdge Network
g Node
u Node
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
-> Node
-> Node
-> ((Double, Double) -> Bool)
-> Maybe ((Double, Double), Network)
forall a b.
Gr a b -> Node -> Node -> (b -> Bool) -> Maybe (b, Gr a b)
extractEdge Network
g Node
v Node
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 :: forall a b.
Gr a b -> Node -> Node -> (b -> Bool) -> Maybe (b, Gr a b)
extractEdge Gr a b
g Node
u Node
v b -> Bool
p =
    case Node -> Gr a b -> Decomp Gr a b
forall a b. Node -> Gr a b -> Decomp Gr a b
forall (gr :: * -> * -> *) a b.
Graph gr =>
Node -> gr a b -> Decomp gr a b
match Node
u Gr a b
g of
      ((Just (Adj b
p', Node
node, a
l, Adj b
s), Gr a b
newg)) ->
        let (Maybe (b, Node)
adj, Adj b
rest)=Adj b -> ((b, Node) -> Bool) -> (Maybe (b, Node), Adj b)
forall b. Adj b -> ((b, Node) -> Bool) -> (Maybe (b, Node), Adj b)
extractAdj Adj b
s (\(b
l', Node
dest) -> Node
destNode -> Node -> Bool
forall a. Eq a => a -> a -> Bool
==Node
v Bool -> Bool -> Bool
&& b -> Bool
p b
l')
        in do (b
el, Node
_) <- Maybe (b, Node)
adj
              (b, Gr a b) -> Maybe (b, Gr a b)
forall a. a -> Maybe a
Just (b
el, (Adj b
p', Node
node, a
l, Adj b
rest) Context a b -> Gr a b -> Gr a b
forall a b. 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)
      Decomp Gr a b
_ -> Maybe (b, Gr a b)
forall a. Maybe a
Nothing

-- 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 :: forall b. Adj b -> ((b, Node) -> Bool) -> (Maybe (b, Node), Adj b)
extractAdj []         (b, Node) -> Bool
_ = (Maybe (b, Node)
forall a. Maybe a
Nothing, [])
extractAdj ((b, Node)
adj:[(b, Node)]
adjs) (b, Node) -> Bool
p
    | (b, Node) -> Bool
p (b, Node)
adj     = ((b, Node) -> Maybe (b, Node)
forall a. a -> Maybe a
Just (b, Node)
adj, [(b, Node)]
adjs)
    | Bool
otherwise = (Maybe (b, Node)
theone, (b, Node)
adj(b, Node) -> [(b, Node)] -> [(b, Node)]
forall a. a -> [a] -> [a]
:[(b, Node)]
rest)
        where (Maybe (b, Node)
theone, [(b, Node)]
rest)=[(b, Node)]
-> ((b, Node) -> Bool) -> (Maybe (b, Node), [(b, Node)])
forall b. Adj b -> ((b, Node) -> Bool) -> (Maybe (b, Node), Adj b)
extractAdj [(b, Node)]
adjs (b, Node) -> 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
    (Node
_, Node
_, (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
    (Node
_, Node
_, (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
    (Node
u, Node
v, (Double
c, Double
f), Direction
Forward) ->
        (Node
u, Node
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
    (Node
u, Node
v, (Double
c, Double
f), Direction
Backward) ->
        (Node
u, Node
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 Node
s Node
t = case Maybe [Node]
maybePath of
        Just [Node]
_ ->
            (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 [Node]
Nothing   -> Maybe (Network, Double)
forall a. Maybe a
Nothing
    where maybePath :: Maybe [Node]
maybePath  = Network -> Node -> Node -> Maybe [Node]
augPath Network
g Node
s Node
t
          ([DirEdge (Double, Double)]
es, Network
newg) = Network -> [Node] -> ([DirEdge (Double, Double)], Network)
extractPath Network
g (Maybe [Node] -> [Node]
forall a. HasCallStack => Maybe a -> a
fromJust Maybe [Node]
maybePath)
          delta :: Double
delta      = [Double] -> Double
forall a. Ord a => [a] -> a
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 -> Node -> Node -> (Network, Double)
ekWith EKStepFunc
stepfunc Network
g Node
s Node
t = case EKStepFunc
stepfunc Network
g Node
s Node
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 -> Node -> Node -> (Network, Double)
ekWith EKStepFunc
stepfunc Network
newg Node
s Node
t
    Maybe (Network, Double)
Nothing            -> (Network
g, Double
0)

ekSimple :: Network -> Node -> Node -> (Network, Double)
ekSimple :: Network -> Node -> Node -> (Network, Double)
ekSimple = EKStepFunc -> Network -> Node -> Node -> (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 (Node, Node)
-> ([DirEdge (Double, Double)], [LEdge (Double, Double)])
extractPathList []                 Set (Node, Node)
_ = ([], [])
extractPathList (edge :: LEdge (Double, Double)
edge@(Node
u,Node
v,l :: (Double, Double)
l@(Double
c,Double
f)):[LEdge (Double, Double)]
es) Set (Node, Node)
set
    | (Double
cDouble -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>Double
f) Bool -> Bool -> Bool
&& (Node, Node) -> Set (Node, Node) -> Bool
forall a. Ord a => a -> Set a -> Bool
S.member (Node
u,Node
v) Set (Node, Node)
set =
        let ([DirEdge (Double, Double)]
pathrest, [LEdge (Double, Double)]
notrest)=[LEdge (Double, Double)]
-> Set (Node, Node)
-> ([DirEdge (Double, Double)], [LEdge (Double, Double)])
extractPathList [LEdge (Double, Double)]
es ((Node, Node) -> Set (Node, Node) -> Set (Node, Node)
forall a. Ord a => a -> Set a -> Set a
S.delete (Node
u,Node
v) Set (Node, Node)
set)
            in ((Node
u,Node
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
&& (Node, Node) -> Set (Node, Node) -> Bool
forall a. Ord a => a -> Set a -> Bool
S.member (Node
v,Node
u) Set (Node, Node)
set =
        let ([DirEdge (Double, Double)]
pathrest, [LEdge (Double, Double)]
notrest)=[LEdge (Double, Double)]
-> Set (Node, Node)
-> ([DirEdge (Double, Double)], [LEdge (Double, Double)])
extractPathList [LEdge (Double, Double)]
es ((Node, Node) -> Set (Node, Node) -> Set (Node, Node)
forall a. Ord a => a -> Set a -> Set a
S.delete (Node
u,Node
v) Set (Node, Node)
set)
            in ((Node
u,Node
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 (Node, Node)
-> ([DirEdge (Double, Double)], [LEdge (Double, Double)])
extractPathList [LEdge (Double, Double)]
es Set (Node, Node)
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 Node
s Node
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 a b. [LNode a] -> [LEdge b] -> Gr a b
forall (gr :: * -> * -> *) a b.
Graph gr =>
[LNode a] -> [LEdge b] -> gr a b
mkGraph (Network -> [LNode ()]
forall a b. Gr a b -> [LNode a]
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 -> Node -> Node -> Maybe DirPath
augPathFused Network
g Node
s Node
t
          ([DirEdge (Double, Double)]
es, [LEdge (Double, Double)]
otheredges) = [LEdge (Double, Double)]
-> Set (Node, Node)
-> ([DirEdge (Double, Double)], [LEdge (Double, Double)])
extractPathList (Network -> [LEdge (Double, Double)]
forall a b. Gr a b -> [LEdge b]
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [LEdge b]
labEdges Network
g)
              ([(Node, Node)] -> Set (Node, Node)
forall a. Ord a => [a] -> Set a
S.fromList ([Node] -> [Node] -> [(Node, Node)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Node]
justPath ([Node] -> [Node]
forall a. HasCallStack => [a] -> [a]
tail [Node]
justPath)))
          delta :: Double
delta         = [Double] -> Double
forall a. Ord a => [a] -> a
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 :: [Node]
justPath      = DirPath -> [Node]
pathFromDirPath (Maybe DirPath -> DirPath
forall a. HasCallStack => Maybe a -> a
fromJust Maybe DirPath
maybePath)

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