| 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) |