/usr/lib/hugs/packages/fgl/Data/Graph/Inductive/Query/MaxFlow2.hs is in libhugs-fgl-bundled 98.200609.21-5.3.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 | -- | Alternative Maximum Flow
module Data.Graph.Inductive.Query.MaxFlow2(
Network,
ekSimple, ekFused, ekList,
) where
-- ekSimple, ekFused, ekList) where
import Data.List
import Data.Maybe
import Data.Graph.Inductive.Graph
import Data.Graph.Inductive.Tree
import Data.Graph.Inductive.Internal.FiniteMap
import Data.Graph.Inductive.Internal.Queue
import Data.Graph.Inductive.Query.BFS (bft)
------------------------------------------------------------------------------
-- 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 (Eq, Show)
-- Data type for edge with direction of traversal
type DirEdge b = (Node, Node, b, Direction)
type DirPath=[(Node, Direction)]
type DirRTree=[DirPath]
pathFromDirPath = map (\(n,_)->n)
------------------------------------------------------------------------------
-- 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 g s t = listToMaybe $ map reverse $
filter (\((u,_):_) -> u==t) tree
where tree = bftForEK s g
-- Breadth First Search wrapper function
bftForEK :: Node -> Network -> DirRTree
bftForEK v = bfForEK (queuePut [(v,Forward)] mkQueue)
-- Breadth First Search, tailored for Edmonds & Karp
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
-- Insert successor nodes (with path to root) into queue
q2 = queuePutList suc1 $ queuePutList suc2 q1
-- Traverse edges in reverse if flow positive
suc1 = [ (preNode, Backward):p
| ((_, f), preNode) <- preAdj, f>0]
-- Traverse edges forwards if flow less than capacity
suc2 = [ (sucNode,Forward):p
| ((c, f), sucNode) <- sucAdj, c>f]
where (p@((v,_):_), q1)=queueGet 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 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 :: EKStepFunc
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
-- ENDEXTRACT
-----------------------------------------------------------------------------
-- Alternative implementation: Use an explicit residual graph
-- EXTRACT fglEdmondsSimple.txt
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)
-- 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 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))
-- 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 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'))
-- 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 [] _ = (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
-- ENDEXTRACT
-----------------------------------------------------------------------------
-- Alternative implementation: Process list of edges to extract path instead
-- of operating on graph structure
-- EXTRACT fglEdmondsList.txt
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
-- ENDEXTRACT
|