Merge branch 'master' into popl2012

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

module ProposalMatcher where
import Data.Array.IArray
import Data.Graph.Inductive.Graph
import Data.Graph.Inductive.Tree
import Data.List
import Data.Either

import ArrayStuff
import MonadStuff
import PMInstance
import PMConfig

prefBoringness cfg p = if prefIsVeryBoring cfg p then 2
	else if prefIsBoring cfg p then 1 else 0
expExpertness cfg x = if expIsExpert cfg x then 2
	else if expIsKnowledgeable cfg x then 1 else 0

data REdge = REdge {
	reIdx  :: Int,
	reCap  :: Int,
	reCost :: Wt
}

instance Show REdge where
	show (REdge idx cap cost) = "#" ++ (show idx) ++ ": "
		++ (show cap) ++ " @ " ++ (show cost)

data ReductionResult = ReductionResult {
	rrGraph      :: Gr () REdge,
	rrSource     :: Node,
	rrSink       :: Node,
	rrEIdxBounds :: (Int, Int),
	rrEDIdx      :: (Int, Int) -> Int
}

-- Hack: show as much of the reduction result as we easily can
data RR1 = RR1 (Gr () REdge) Node Node (Int, Int) deriving Show
instance Show ReductionResult where
	show (ReductionResult g so si eib _) = show (RR1 g so si eib)

indexEdges :: Int -> [(Int, Int, REdge)] -> (Int, [(Int, Int, REdge)])
indexEdges i [] = (i, [])
indexEdges i ((v1, v2, re):es) =
	let (imax, ies) = indexEdges (i+1) es in
	(imax, (v1, v2, re{ reIdx = i }) : ies)

implies :: Bool -> Bool -> Bool
x `implies` y = (not x) || y

doReduction :: PMConfig -> PMInstance -> ReductionResult
doReduction cfg (PMInstance numRvrs numProps rloadA prefA expA fixA pnrA) =
	let
		-- Need to figure out who is PC/ERC
		isPC = (funcArray (0, numRvrs-1) (\i -> (rloadA ! i) == 1)) :: Array Int Bool
		isPCPaper = (funcArray (0, numProps-1) (\j -> all (\i -> (isPC ! i) `implies` (prefIsConflict cfg $ (prefA ! (i, j)))) [0 .. numRvrs - 1])) :: Array Int Bool
		source = 0
		sink = 1
		rvrNode i boringness = 2 + 3*i + boringness
		-- We will waste a lot of nodes.  Who cares, no one will visit them.
		propNode j k = 2 + 3*numRvrs + 7*j + k
		numNodes = 2 + 3*numRvrs + 7*numProps
		edIdx (i, j) = i*numProps + j
		in
	let
		totalReviews = sum $ elems pnrA    -- (reviewsEachProposal cfg) * numProps
		totalRelativeLoad = foldl (+) 0 (map (rloadA !) [0 .. numRvrs - 1])
		-- floor goes best with loadTolerance 2
		targetLoad i = floor (widenInteger totalReviews * (rloadA ! i) / totalRelativeLoad) - 1
		-- Edge groups A through H are indicated in the figure in the paper.
		edgesABC = do
			i <- [0 .. numRvrs - 1]
			let tl = targetLoad i
			let lt = if isPC ! i then loadTolerance cfg else ercLoadTolerance cfg
			let freeEdgeA = (source, rvrNode i 0, REdge undefined tl 0)
			let nonfreeEdgesA = do
				l <- [tl .. tl + lt - 1]
				let costA = marginalLoadCost cfg ((widenInteger (l - tl) + 1/2) / widenInteger lt)
				return (source, rvrNode i 0, REdge undefined 1 costA)
			let edgesBC = do
				l <- [0 .. tl + lt - 1]
				let costB = marginalBoringCost cfg ((widenInteger l + 1/2) / widenInteger tl)
				let edgeB = (rvrNode i 0, rvrNode i 1, REdge undefined 1 costB)
				let costC = marginalVeryBoringCost cfg ((widenInteger l + 1/2) / widenInteger tl)
				let edgeC = (rvrNode i 1, rvrNode i 2, REdge undefined 1 costC)
				[edgeB, edgeC]
			[freeEdgeA] ++ nonfreeEdgesA ++ edgesBC
		edgesDFix = do
			i <- [0 .. numRvrs - 1]
			j <- [0 .. numProps - 1]
			let pref = prefA ! (i, j)
			let xp = expA ! (i, j)
			-- We must generate an edge even if there is a conflict
			-- of interest; otherwise we'll fail to read its flow
			-- value in doMatching.
			let xp_ = expExpertness cfg xp
			let pn = propNode j $ if (isPC ! i)
				then xp_ + 3  -- Can assume it is a PC paper, otherwise it would conflict anyway.
				else xp_
			let rn = rvrNode i (prefBoringness cfg pref)
			if fixA ! (i, j)
				-- Max flow will emulate one unit of flow through the edge,
				-- at a cost of increasing the total flow value by 1.
				then [Right (rn, sink, REdge undefined 1 0),
					Right (source, pn, REdge undefined 1 0)]
				else [Left (rn, pn, REdge (edIdx (i, j))
					(if prefIsConflict cfg pref then 0 else 1)
					(assignmentCost cfg pref))]
		edgesD = lefts edgesDFix
		edgesFix = rights edgesDFix
		edgesEFGH = do
			j <- [0 .. numProps - 1]
			-- This is now different...
			let numReviews = pnrA ! j
			if isPCPaper ! j
				then do -- Mostly traditional.
					-- Expert bonus
					let edgeFFirst = (propNode j 2, propNode j 1, REdge undefined 1 (-(expertBonus cfg)))
					let edgeFRest = (propNode j 2, propNode j 1, REdge undefined (numReviews - 1) 0)
					-- Second kowledgeable bonus
					let edgeGFirst = (propNode j 1, propNode j 0, REdge undefined 1 (-(knowledgeableBonus cfg)))
					let edgeGRest = (propNode j 1, propNode j 0, REdge undefined (numReviews - 2) 0)
					-- Require one knowledgeable
					let edgeH1 = (propNode j 1, sink, REdge undefined 1 0)
					let edgeH = (propNode j 0, sink, REdge undefined (numReviews - 1) 0)
					[edgeFFirst, edgeFRest, edgeGFirst, edgeGRest, edgeH1, edgeH]
				else do -- New gadget; man, a lot of edges
					let numPCReviews = pcReviewsEachProposal cfg
					if numReviews < numPCReviews then fail "numReviews for paper < numPCReviews" else nop
					-- Structure to distribute knowledgeable PC members
					let edgesP = [(propNode j k, propNode j 6, REdge undefined numPCReviews 0) | k <- [4 .. 5]]
					let edgesR = [(propNode j k, propNode j (k - 3), REdge undefined (numReviews - numPCReviews) 0) | k <- [4 .. 5]]
					-- "Designated knowledgeable" with expert bonus
					let edgeF = (propNode j 2, propNode j 1, REdge undefined (numReviews - numPCReviews) (-(expertBonus cfg)))
					let edgeH1 = (propNode j 1, sink, REdge undefined (numReviews - numPCReviews) 0)
					-- "Designated PC" with knowledgeable bonus
					let edgeGFirst = (propNode j 6, propNode j 3, REdge undefined 1 (-(knowledgeableBonus cfg)))
					let edgeGRest = (propNode j 6, propNode j 3, REdge undefined (numPCReviews - 1) 0)
					let edgeH = (propNode j 3, sink, REdge undefined (numPCReviews) 0)
					edgesP ++ edgesR ++ [edgeF, edgeH1, edgeGFirst, edgeGRest, edgeH]
		theNodes = [(x, ()) | x <- [0 .. numNodes - 1]]
		-- Index the non-D edges
		unindexedEdges = edgesABC ++ edgesFix ++ edgesEFGH
		(imax, reindexedEdges) = indexEdges (numRvrs*numProps) unindexedEdges
		theEdges = edgesD ++ reindexedEdges
		in
	ReductionResult (mkGraph theNodes theEdges) source sink (0, imax-1) edIdx

-- Returns a list of reviews as ordered pairs (reviewer#, proposal#).
doMatching :: PMConfig -> PMInstance -> PMatching
doMatching cfg inst@(PMInstance numRvrs numProps _ _ _ fixA _) =
	let ReductionResult graph source sink idxBounds edIdx = doReduction cfg inst in
	let flowArray = minCostFlow cfg idxBounds reIdx reCap reCost graph (source, sink) in
	let pairs = do
		i <- [0 .. numRvrs - 1]
		j <- [0 .. numProps - 1]
		if fixA ! (i, j) || flowArray ! edIdx (i, j) == 1
			then [(i, j)]
			else []
		in
	PMatching (sort pairs) -- for prettiness