module Data.Graph.Inductive.Query.MaxFlow2(
Network,
ekSimple, ekFused, ekList,
) where
import Data.Maybe
import Data.Graph.Inductive.Graph
import Data.Graph.Inductive.PatriciaTree
import Data.Graph.Inductive.Internal.FiniteMap
import Data.Graph.Inductive.Internal.Queue
import Data.Graph.Inductive.Query.BFS (bft)
type Network = Gr () (Double, Double)
data Direction = Forward | Backward
deriving (Eq, Show)
type DirEdge b = (Node, Node, b, Direction)
type DirPath=[(Node, Direction)]
type DirRTree=[DirPath]
pathFromDirPath = map (\(n,_)->n)
augPathFused :: Network -> Node -> Node -> Maybe DirPath
augPathFused g s t = listToMaybe $ map reverse $
filter (\((u,_):_) -> u==t) tree
where tree = bftForEK s g
bftForEK :: Node -> Network -> DirRTree
bftForEK v = bfForEK (queuePut [(v,Forward)] mkQueue)
bfForEK :: Queue DirPath -> Network -> DirRTree
bfForEK q g
| queueEmpty q || isEmpty g = []
| otherwise = case match v g of
(Nothing, g') -> bfForEK q1 g'
(Just (preAdj, _, _, sucAdj), g') -> p:bfForEK q2 g'
where
q2 = queuePutList suc1 $ queuePutList suc2 q1
suc1 = [ (preNode, Backward):p
| ((_, f), preNode) <- preAdj, f>0]
suc2 = [ (sucNode,Forward):p
| ((c, f), sucNode) <- sucAdj, c>f]
where (p@((v,_):_), q1)=queueGet q
extractPathFused :: Network -> DirPath
-> ([DirEdge (Double,Double)], Network)
extractPathFused g [] = ([], g)
extractPathFused g [(_,_)] = ([], g)
extractPathFused g ((u,_):rest@((v,Forward):_)) =
((u, v, l, Forward):tailedges, newerg)
where (tailedges, newerg) = extractPathFused newg rest
Just (l, newg) = extractEdge g u v (\(c,f)->(c>f))
extractPathFused g ((u,_):rest@((v,Backward):_)) =
((v, u, l, Backward):tailedges, newerg)
where (tailedges, newerg) = extractPathFused newg rest
Just (l, newg) = extractEdge g v u (\(_,f)->(f>0))
ekFusedStep g s t = case maybePath of
Just _ ->
Just ((insEdges (integrateDelta es delta) newg), delta)
Nothing -> Nothing
where maybePath = augPathFused g s t
(es, newg) = extractPathFused g (fromJust maybePath)
delta = minimum $ getPathDeltas es
ekFused :: Network -> Node -> Node -> (Network, Double)
ekFused = ekWith ekFusedStep
residualGraph :: Network -> Gr () Double
residualGraph g =
mkGraph (labNodes g)
([(u, v, c-f) | (u, v, (c,f)) <- labEdges g, c>f ] ++
[(v, u, f) | (u,v,(_,f)) <- labEdges g, f>0])
augPath :: Network -> Node -> Node -> Maybe Path
augPath g s t = listToMaybe $ map reverse $ filter (\(u:_) -> u==t) tree
where tree = bft s (residualGraph g)
extractPath :: Network -> Path -> ([DirEdge (Double,Double)], Network)
extractPath g [] = ([], g)
extractPath g [_] = ([], g)
extractPath g (u:v:ws) =
case fwdExtract of
Just (l, newg) -> ((u, v, l, Forward):tailedges, newerg)
where (tailedges, newerg) = extractPath newg (v:ws)
Nothing ->
case revExtract of
Just (l, newg) ->
((v, u, l, Backward):tailedges, newerg)
where (tailedges, newerg) = extractPath newg (v:ws)
Nothing -> error "extractPath: revExtract == Nothing"
where fwdExtract = extractEdge g u v (\(c,f)->(c>f))
revExtract = extractEdge g v u (\(_,f)->(f>0))
extractEdge :: Gr a b -> Node -> Node -> (b->Bool) -> Maybe (b, Gr a b)
extractEdge g u v p =
case adj of
Just (el, _) -> Just (el, (p', node, l, rest) & newg)
Nothing -> Nothing
where (Just (p', node, l, s), newg) = match u g
(adj, rest)=extractAdj s
(\(l', dest) -> (dest==v) && (p l'))
extractAdj :: Adj b -> ((b,Node)->Bool) -> (Maybe (b,Node), Adj b)
extractAdj [] _ = (Nothing, [])
extractAdj (adj:adjs) p
| p adj = (Just adj, adjs)
| otherwise = (theone, adj:rest)
where (theone, rest)=extractAdj adjs p
getPathDeltas :: [DirEdge (Double,Double)] -> [Double]
getPathDeltas [] = []
getPathDeltas (e:es) = case e of
(_, _, (c,f), Forward) -> (c-f) : (getPathDeltas es)
(_, _, (_,f), Backward) -> f : (getPathDeltas es)
integrateDelta :: [DirEdge (Double,Double)] -> Double
-> [LEdge (Double, Double)]
integrateDelta [] _ = []
integrateDelta (e:es) delta = case e of
(u, v, (c, f), Forward) ->
(u, v, (c, f+delta)) : (integrateDelta es delta)
(u, v, (c, f), Backward) ->
(u, v, (c, f-delta)) : (integrateDelta es delta)
type EKStepFunc = Network -> Node -> Node -> Maybe (Network, Double)
ekSimpleStep :: EKStepFunc
ekSimpleStep g s t = case maybePath of
Just _ ->
Just ((insEdges (integrateDelta es delta) newg), delta)
Nothing -> Nothing
where maybePath = augPath g s t
(es, newg) = extractPath g (fromJust maybePath)
delta = minimum $ getPathDeltas es
ekWith :: EKStepFunc -> Network -> Node -> Node -> (Network, Double)
ekWith stepfunc g s t = case stepfunc g s t of
Just (newg, delta) -> (finalg, capacity+delta)
where (finalg, capacity) = (ekWith stepfunc newg s t)
Nothing -> (g, 0)
ekSimple :: Network -> Node -> Node -> (Network, Double)
ekSimple = ekWith ekSimpleStep
setFromList :: Ord a => [a] -> FiniteMap a ()
setFromList [] = emptyFM
setFromList (x:xs) = addToFM (setFromList xs) x ()
setContains :: Ord a => FiniteMap a () -> a -> Bool
setContains m i = case (lookupFM m i) of
Nothing -> False
Just () -> True
extractPathList :: [LEdge (Double, Double)] -> FiniteMap (Node,Node) ()
-> ([DirEdge (Double, Double)], [LEdge (Double, Double)])
extractPathList [] _ = ([], [])
extractPathList (edge@(u,v,l@(c,f)):es) set
| (c>f) && (setContains set (u,v)) =
let (pathrest, notrest)=extractPathList es (delFromFM set (u,v))
in ((u,v,l,Forward):pathrest, notrest)
| (f>0) && (setContains set (v,u)) =
let (pathrest, notrest)=extractPathList es (delFromFM set (u,v))
in ((u,v,l,Backward):pathrest, notrest)
| otherwise =
let (pathrest, notrest)=extractPathList es set in
(pathrest, edge:notrest)
ekStepList :: EKStepFunc
ekStepList g s t = case maybePath of
Just _ -> Just (mkGraph (labNodes g) newEdges, delta)
Nothing -> Nothing
where newEdges = (integrateDelta es delta) ++ otheredges
maybePath = augPathFused g s t
(es, otheredges) = extractPathList (labEdges g)
(setFromList (zip justPath (tail justPath)))
delta = minimum $ getPathDeltas es
justPath = pathFromDirPath (fromJust maybePath)
ekList :: Network -> Node -> Node -> (Network, Double)
ekList = ekWith ekStepList