Rename "desirability" to "preference" (much less awkward), with the

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

module CS2MinCostFlow (minCostFlow) where
import IMinCostFlow
import IOStuff
import System.IO.Unsafe
import Data.Graph.Inductive.Graph
import Data.Array.IArray
import Data.List

#if __GLASGOW_HASKELL__ <= 606
(*) `on` f = \x y -> f x * f y
#else
import Data.Function
#endif

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