Commit | Line | Data |
---|---|---|
d7d9561e MM |
1 | module UnitMinCostFlow (umcf, flowDiff) where |
2 | import BellmanFord | |
3 | import Data.Graph.Inductive.Graph | |
4 | import Data.Graph.Inductive.Internal.RootPath | |
5 | import Data.List | |
6 | ||
7 | maybeDelete :: Eq a => a -> [a] -> Maybe [a] | |
8 | maybeDelete _ [] = Nothing | |
9 | maybeDelete e (h:t) = if e == h | |
10 | then return t | |
11 | else do t1 <- maybeDelete e t; return (h:t1) | |
12 | ||
13 | -- If the edge occurs in the graph, return Just the graph with one occurrence | |
14 | -- deleted; otherwise return Nothing. (delLEdge deletes all occurrences.) | |
15 | maybeDelOneLEdge :: (DynGraph gr, Eq b) => LEdge b -> gr a b -> Maybe (gr a b) | |
16 | maybeDelOneLEdge (src, dest, lbl) theGraph = | |
17 | let (mc, moreGraph) = match src theGraph in do | |
18 | (p, v, l, s) <- mc | |
19 | s2 <- maybeDelete (lbl, dest) s | |
20 | return ((p, v, l, s2) & moreGraph) | |
21 | ||
22 | flipEdge (src, dest, lbl) = (dest, src, -lbl) | |
23 | ||
24 | flipEdgeIn :: (DynGraph gr, Real b) => LEdge b -> gr a b -> gr a b | |
25 | flipEdgeIn edge theGraph = | |
26 | let Just graph1 = maybeDelOneLEdge edge theGraph in | |
27 | insEdge (flipEdge edge) graph1 | |
28 | ||
29 | augment :: (DynGraph gr, Real b) => [LNode b] -> gr a b -> gr a b | |
30 | augment augPath@((v1, d1) : t1) theGraph = | |
31 | case t1 of | |
32 | [] -> theGraph | |
33 | (v2, d2) : t2 -> augment (tail augPath) | |
34 | (flipEdgeIn (v1, v2, d2 - d1) theGraph) | |
35 | ||
36 | -- Find a min-cost flow from s to t in theGraph. | |
37 | -- Each edge of the input graph has unit capacity and cost given by its label. | |
38 | -- Returns: flow value, residual graph. | |
39 | umcf :: (DynGraph gr, Real b) => Node -> Node -> gr a b -> (b, gr a b) | |
40 | umcf s t theGraph = | |
41 | -- Use Bellman-Ford to find an augmenting path from s to t, if one exists. | |
42 | -- NOTE: getLPath reverses it into s-to-t order! | |
43 | let LP augPath = getLPath t (spTree s theGraph) in | |
44 | if null augPath then | |
45 | -- Finished. | |
46 | (0, theGraph) | |
47 | else | |
48 | -- Augment, and continue flowing in the resulting graph. | |
49 | let graph2 = augment augPath theGraph in | |
50 | let (fval1, resid) = umcf s t graph2 in (fval1 + 1, resid) | |
51 | ||
52 | -- Diffs an original graph and a residual graph, producing the flow graph. | |
53 | flowDiff :: (DynGraph gr, Real b) => gr a b -> gr a b -> gr a b | |
54 | flowDiff ograph rgraph = case labEdges ograph of | |
55 | [] -> mkGraph (labNodes ograph) [] | |
56 | oedge:_ -> let Just ograph2 = maybeDelOneLEdge oedge ograph in | |
57 | case maybeDelOneLEdge oedge rgraph of | |
58 | Just rgraph2 -> flowDiff ograph2 rgraph2 | |
59 | Nothing -> let Just rgraph2 = maybeDelOneLEdge (flipEdge oedge) rgraph in | |
60 | insEdge oedge (flowDiff ograph2 rgraph2) |