- Implement CS2 min-cost-flow adaptor and generalize common min-cost-flow stuff

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

diff --git a/program/CS2MinCostFlow.hs b/program/CS2MinCostFlow.hs
new file mode 100644 (file)
index 0000000..47a73f5
--- /dev/null
+++ b/program/CS2MinCostFlow.hs
@@ -0,0 +1,89 @@
+module CS2MinCostFlow (minCostFlow) where
+import IMinCostFlow
+import IOStuff
+import System.IO.Unsafe
+import Data.Graph.Inductive.Graph
+import Data.Array.IArray
+import Data.List
+import Data.Function
+
+-- Configure the path to cs2.exe relative to the program/ directory here.
+cs2cmd = "./cs2.exe"
+
+runCS2 :: String -> String
+-- Using unsafePerformIO is non-ideal, but it gives a consistent interface
+-- for the min-cost flow function.
+runCS2 inData = unsafePerformIO (interactWithCommand cs2cmd inData)
+
+data MCFEdge i f c = MCFEdge {
+       eFrom :: Node,
+       eTo   :: Node,
+       eCost :: c,
+       eMIdx :: Maybe i,
+       eCap  :: f
+} deriving (Eq, Ord)
+
+round2 :: Real a => a -> Int
+round2 x = fromInteger (round (toRational x))
+
+minCostFlow :: MinCostFlowImpl
+minCostFlow idxBounds edgeIdx edgeCap edgeCost theGraph (source, sink) =
+       let
+               (nLo, nHi) = nodeRange theGraph
+               theEdges = labEdges theGraph
+               -- HACK: Add a highly negative-cost edge from sink to
+               -- source to get CS2 to compute a max flow.
+               edges2 = MCFEdge sink source (-100000) Nothing 10000 :
+                       map (\(n1, n2, l) -> MCFEdge n1 n2 (edgeCost l) (Just (edgeIdx l)) (edgeCap l))
+                       theEdges
+               -- HACK: Round capacities and costs to integers so CS2 can
+               -- handle them.  The proposal matcher's capacities are integers,
+               -- and its costs are so large that the error should be insignificant.
+               inData = "p min " ++ show (nHi + 1 - nLo) ++ " " ++ show (length edges2) ++ "\n"
+                       ++ "n 1 0\n" -- Dummy node description to make CS2 parser happy.
+                       ++ concatMap (\(MCFEdge n1 n2 cost _ cap) ->
+                               "a " ++ show (n1 - nLo + 1) ++ " " ++ show (n2 - nLo + 1)
+                               ++ " 0 " ++ show (round2 cap)
+                               ++ " " ++ show (round2 cost) ++ "\n")
+                       edges2
+               outData = runCS2 inData
+               -- Unfortunately CS2 doesn't support edge ID numbers, so we
+               -- have to manually apply the "flow items" it produced to the
+               -- appropriate edges in order of increasing cost.
+               -- Extract ((n1, n2), f) tuples from the output.
+               flowItems = concatMap (\l -> let w:ws = words l in
+                       if w == "f"
+                               then let
+                                       [n1s, n2s, fs] = ws
+                                       n1 = (read n1s :: Int) - 1 + nLo
+                                       n2 = (read n2s :: Int) - 1 + nLo
+                                       fv = fromInteger (toInteger (read fs :: Int))
+                                       in [((n1, n2), fv)]
+                               else []
+                       ) (lines outData)
+               -- Total the flow for each node pair (n1, n2) to simplify matters.
+               flowGroups = groupBy ((==) `on` fst) (sort flowItems)
+               npFlows = map (\l@((n12, _):_) ->
+                       (n12, sum $ map snd l)) flowGroups
+               applyFlows fis [] = case fis of
+                       [] -> []
+                       _ -> error "CS2MinCostFlow: some flow items could not be applied"
+               applyFlows fis es@(e@(MCFEdge n1 n2 _ mi cap):moreEs) =
+                       let (ef, fisLeft) = case fis of
+                               -- Note to self: One can't test equality in a
+                               -- pattern by reusing a variable name.  Use a
+                               -- guard instead.
+                               ((fn1, fn2), fv):moreFis | fn1 == n1 && fn2 == n2 ->
+                                       -- This edge gets (min f cap) flow.
+                                       (min fv cap, if fv > cap
+                                               then ((n1, n2), fv - cap) : moreFis
+                                               else moreFis)
+                               _ -> (0, fis) -- No flow for this edge.
+                       in (mi, ef) : applyFlows fisLeft moreEs
+               theEdgeFlows = applyFlows npFlows (sort edges2)
+               -- Get rid of the flow on our hack edge.
+               realEdgeFlows = concatMap (\(mi, ef) -> case mi of
+                               Just i -> [(i, ef)]
+                               Nothing -> []
+                       ) theEdgeFlows
+       in array idxBounds realEdgeFlows