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