- Add the notes Samir emailed me on 2008-07-06.

[match/match.git] / program / UnitMinCostFlow.hs

diff --git a/program/UnitMinCostFlow.hs b/program/UnitMinCostFlow.hs
new file mode 100644 (file)
index 0000000..24e44bc
--- /dev/null
+++ b/program/UnitMinCostFlow.hs
@@ -0,0 +1,60 @@
+module UnitMinCostFlow (umcf, flowDiff) where
+import BellmanFord
+import Data.Graph.Inductive.Graph
+import Data.Graph.Inductive.Internal.RootPath
+import Data.List
+
+maybeDelete :: Eq a => a -> [a] -> Maybe [a]
+maybeDelete _ [] = Nothing
+maybeDelete e (h:t) = if e == h
+       then return t
+       else do t1 <- maybeDelete e t; return (h:t1)
+
+-- If the edge occurs in the graph, return Just the graph with one occurrence
+-- deleted; otherwise return Nothing.  (delLEdge deletes all occurrences.)
+maybeDelOneLEdge :: (DynGraph gr, Eq b) => LEdge b -> gr a b -> Maybe (gr a b)
+maybeDelOneLEdge (src, dest, lbl) theGraph =
+       let (mc, moreGraph) = match src theGraph in do
+               (p, v, l, s) <- mc
+               s2 <- maybeDelete (lbl, dest) s
+               return ((p, v, l, s2) & moreGraph)
+
+flipEdge (src, dest, lbl) = (dest, src, -lbl)
+
+flipEdgeIn :: (DynGraph gr, Real b) => LEdge b -> gr a b -> gr a b
+flipEdgeIn edge theGraph =
+       let Just graph1 = maybeDelOneLEdge edge theGraph in
+       insEdge (flipEdge edge) graph1
+
+augment :: (DynGraph gr, Real b) => [LNode b] -> gr a b -> gr a b
+augment augPath@((v1, d1) : t1) theGraph =
+       case t1 of
+       [] -> theGraph
+       (v2, d2) : t2 -> augment (tail augPath)
+               (flipEdgeIn (v1, v2, d2 - d1) theGraph)
+
+-- Find a min-cost flow from s to t in theGraph.
+-- Each edge of the input graph has unit capacity and cost given by its label.
+-- Returns: flow value, residual graph.
+umcf :: (DynGraph gr, Real b) => Node -> Node -> gr a b -> (b, gr a b)
+umcf s t theGraph =
+       -- Use Bellman-Ford to find an augmenting path from s to t, if one exists.
+       -- NOTE: getLPath reverses it into s-to-t order!
+       let LP augPath = getLPath t (spTree s theGraph) in
+       if null augPath then
+               -- Finished.
+               (0, theGraph)
+       else
+               -- Augment, and continue flowing in the resulting graph.
+               let graph2 = augment augPath theGraph in
+               let (fval1, resid) = umcf s t graph2 in (fval1 + 1, resid)
+
+-- Diffs an original graph and a residual graph, producing the flow graph.
+flowDiff :: (DynGraph gr, Real b) => gr a b -> gr a b -> gr a b
+flowDiff ograph rgraph = case labEdges ograph of
+       [] -> mkGraph (labNodes ograph) []
+       oedge:_ -> let Just ograph2 = maybeDelOneLEdge oedge ograph in
+               case maybeDelOneLEdge oedge rgraph of
+                       Just rgraph2 -> flowDiff ograph2 rgraph2
+                       Nothing -> let Just rgraph2 = maybeDelOneLEdge (flipEdge oedge) rgraph in
+                               insEdge oedge (flowDiff ograph2 rgraph2)
\ No newline at end of file