program/CS2MinCostFlow.hs

   1 module CS2MinCostFlow (minCostFlow) where
   2 import IMinCostFlow
   3 import IOStuff
   4 import System.IO.Unsafe
   5 import Data.Graph.Inductive.Graph
   6 import Data.Array.IArray
   7 import Data.List
   8
   9 #if __GLASGOW_HASKELL__ <= 606
  10 (*) `on` f = \x y -> f x * f y
  11 #else
  12 import Data.Function
  13 #endif
  14
  15 -- Configure the path to cs2.exe relative to the program/ directory here.
  16 cs2cmd = "./cs2.exe"
  17
  18 runCS2 :: String -> String
  19 -- Using unsafePerformIO is non-ideal, but it gives a consistent interface
  20 -- for the min-cost flow function.
  21 runCS2 inData = unsafePerformIO (interactWithCommand cs2cmd inData)
  22
  23 data MCFEdge i f c = MCFEdge {
  24         eFrom :: Node,
  25         eTo   :: Node,
  26         eCost :: c,
  27         eMIdx :: Maybe i,
  28         eCap  :: f
  29 } deriving (Eq, Ord)
  30
  31 round2 :: Real a => a -> Int
  32 round2 x = fromInteger (round (toRational x))
  33
  34 minCostFlow :: MinCostFlowImpl
  35 minCostFlow idxBounds edgeIdx edgeCap edgeCost theGraph (source, sink) =
  36         let
  37                 (nLo, nHi) = nodeRange theGraph
  38                 theEdges = labEdges theGraph
  39                 -- HACK: Add a highly negative-cost edge from sink to
  40                 -- source to get CS2 to compute a max flow.
  41                 edges2 = MCFEdge sink source (-100000) Nothing 10000 :
  42                         map (\(n1, n2, l) -> MCFEdge n1 n2 (edgeCost l) (Just (edgeIdx l)) (edgeCap l))
  43                         theEdges
  44                 -- HACK: Round capacities and costs to integers so CS2 can
  45                 -- handle them.  The proposal matcher's capacities are integers,
  46                 -- and its costs are so large that the error should be insignificant.
  47                 inData = "p min " ++ show (nHi + 1 - nLo) ++ " " ++ show (length edges2) ++ "\n"
  48                         ++ "n 1 0\n" -- Dummy node description to make CS2 parser happy.
  49                         ++ concatMap (\(MCFEdge n1 n2 cost _ cap) ->
  50                                 "a " ++ show (n1 - nLo + 1) ++ " " ++ show (n2 - nLo + 1)
  51                                 ++ " 0 " ++ show (round2 cap)
  52                                 ++ " " ++ show (round2 cost) ++ "\n")
  53                         edges2
  54                 outData = runCS2 inData
  55                 -- Unfortunately CS2 doesn't support edge ID numbers, so we
  56                 -- have to manually apply the "flow items" it produced to the
  57                 -- appropriate edges in order of increasing cost.
  58                 -- Extract ((n1, n2), f) tuples from the output.
  59                 flowItems = concatMap (\l -> let w:ws = words l in
  60                         if w == "f"
  61                                 then let
  62                                         [n1s, n2s, fs] = ws
  63                                         n1 = (read n1s :: Int) - 1 + nLo
  64                                         n2 = (read n2s :: Int) - 1 + nLo
  65                                         fv = fromInteger (toInteger (read fs :: Int))
  66                                         in [((n1, n2), fv)]
  67                                 else []
  68                         ) (lines outData)
  69                 -- Total the flow for each node pair (n1, n2) to simplify matters.
  70                 flowGroups = groupBy ((==) `on` fst) (sort flowItems)
  71                 npFlows = map (\l@((n12, _):_) ->
  72                         (n12, sum $ map snd l)) flowGroups
  73                 applyFlows fis [] = case fis of
  74                         [] -> []
  75                         _ -> error "CS2MinCostFlow: some flow items could not be applied"
  76                 applyFlows fis es@(e@(MCFEdge n1 n2 _ mi cap):moreEs) =
  77                         let (ef, fisLeft) = case fis of
  78                                 -- Note to self: One can't test equality in a
  79                                 -- pattern by reusing a variable name.  Use a
  80                                 -- guard instead.
  81                                 ((fn1, fn2), fv):moreFis | fn1 == n1 && fn2 == n2 ->
  82                                         -- This edge gets (min f cap) flow.
  83                                         (min fv cap, if fv > cap
  84                                                 then ((n1, n2), fv - cap) : moreFis
  85                                                 else moreFis)
  86                                 _ -> (0, fis) -- No flow for this edge.
  87                         in (mi, ef) : applyFlows fisLeft moreEs
  88                 theEdgeFlows = applyFlows npFlows (sort edges2)
  89                 -- Get rid of the flow on our hack edge.
  90                 realEdgeFlows = concatMap (\(mi, ef) -> case mi of
  91                                 Just i -> [(i, ef)]
  92                                 Nothing -> []
  93                         ) theEdgeFlows
  94         in array idxBounds realEdgeFlows