program/UnitMinCostFlow.hs

   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)