| 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 |