Commit | Line | Data |
---|---|---|
fd0d2377 MM |
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 | |
7b8c0e4e MM |
8 | |
9 | #if __GLASGOW_HASKELL__ <= 606 | |
10 | (*) `on` f = \x y -> f x * f y | |
11 | #else | |
fd0d2377 | 12 | import Data.Function |
7b8c0e4e | 13 | #endif |
fd0d2377 MM |
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 |