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

module ProposalMatch where
import UnitMinCostFlow
import Data.Array.IArray
import Data.Graph.Inductive.Graph
import Data.Graph.Inductive.Tree
import Data.List

import ProposalMatchConfig

data Instance = Instance
	Int                -- numReviewers
	Int                -- numProposals
	(Int -> Wt)        -- reviewer -> relative load
	(Int -> Int -> Wt) -- reviewer -> proposal -> pref

prefBoringness p = if prefIsVeryBoring p then 2
	else if prefIsBoring p then 1 else 0
prefExpertness p = if prefIsExpert p then 2
	else if prefIsKnowledgeable p then 1 else 0

doReduction :: Instance -> Gr () Wt
doReduction (Instance numRvrs numProps rloadF prefF) =
	let
		source = 0
		sink = 1
		rvrNode i boringness = 2 + 3*i + boringness
		propNode j expertness = 2 + 3*numRvrs + 3*j + expertness
		numNodes = 2 + 3*numRvrs + 3*numProps
		in
	let
		totalReviews = reviewsEachProposal * numProps
		totalRelativeLoad = foldl (+) 0 (map rloadF [0 .. numRvrs - 1])
		targetLoad i = ceiling (numAsWt totalReviews * rloadF i / totalRelativeLoad)
		-- A...H refer to idea book p.429
		edgesABC = do
			i <- [0 .. numRvrs - 1]
			let tl = targetLoad i
			l <- [0 .. tl + loadTolerance - 1]
			let costA = if l < tl
				then 0
				else marginalLoadCost ((numAsWt (l - tl) + 1/2) / numAsWt loadTolerance)
			let edgeA = (source, rvrNode i 0, costA)
			let costB = marginalBoringCost ((numAsWt l + 1/2) / numAsWt tl)
			let edgeB = (rvrNode i 0, rvrNode i 1, costB)
			let costC = marginalVeryBoringCost ((numAsWt l + 1/2) / numAsWt tl)
			let edgeC = (rvrNode i 1, rvrNode i 2, costC)
			[edgeA, edgeB, edgeC]
		edgesD = do
			i <- [0 .. numRvrs - 1]
			j <- [0 .. numProps - 1]
			let pref = prefF i j
			if prefIsConflict pref
				then []
				else [(rvrNode i (prefBoringness pref),
					propNode j (prefExpertness pref),
					assignmentCost pref)]
		edgesE = do
			j <- [0 .. numProps - 1]
			[(propNode j 2, propNode j 0, -expertBonus)]
		edgesFGH = do
			j <- [0 .. numProps - 1]
			l <- [0 .. reviewsEachProposal - 1]
			let edgeF = (propNode j 2, propNode j 1, 0)
			let edgeG = (propNode j 1, propNode j 0,
				if l == 0 then -knowledgeableBonus else 0)
			let edgeH = (propNode j 0, sink, 0)
			[edgeF, edgeG, edgeH]
		theNodes = [(x, ()) | x <- [0 .. numNodes - 1]]
		theEdges = edgesABC ++ edgesD ++ edgesE ++ edgesFGH
		in
	mkGraph theNodes theEdges

todo = undefined
-- Returns a list of reviews as ordered pairs (reviewer#, proposal#).
doMatching :: Instance -> [(Int, Int)]
doMatching inst@(Instance numRvrs numProps rloadF prefF) =
	-- Copied from doReduction.  There should be a better way to get these here.
	let
		source = 0
		sink = 1
		rvrNode i boringness = 2 + 3*i + boringness
		propNode j expertness = 2 + 3*numRvrs + 3*j + expertness
		firstPropNode = propNode 0 0
		idPropNode n = (n - (2 + 3*numRvrs)) `div` 3
		numNodes = 2 + 3*numRvrs + 3*numProps
		in
	let graph1 = doReduction inst in
	let flow1 = flowDiff graph1 (snd (umcf source sink graph1)) in
	let pairs = do
		i <- [0 .. numRvrs - 1]
		boringness <- [0, 1, 2]
		n <- suc flow1 (rvrNode i boringness)
		if n >= firstPropNode
			then [(i, idPropNode n)]
			else []
		in
	sort pairs -- for prettiness
Commit	Line	Data
d7d9561e MM	1	module ProposalMatch where
	2	import UnitMinCostFlow
	3	import Data.Array.IArray
	4	import Data.Graph.Inductive.Graph
	5	import Data.Graph.Inductive.Tree
	6	import Data.List
	7
	8	import ProposalMatchConfig
	9
2e7d5426 MM	10	data Instance = Instance
	11	Int -- numReviewers
	12	Int -- numProposals
	13	(Int -> Wt) -- reviewer -> relative load
	14	(Int -> Int -> Wt) -- reviewer -> proposal -> pref
d7d9561e	15
2e7d5426 MM	16	prefBoringness p = if prefIsVeryBoring p then 2
	17	else if prefIsBoring p then 1 else 0
	18	prefExpertness p = if prefIsExpert p then 2
	19	else if prefIsKnowledgeable p then 1 else 0
	20
	21	doReduction :: Instance -> Gr () Wt
	22	doReduction (Instance numRvrs numProps rloadF prefF) =
d7d9561e MM	23	let
	24	source = 0
	25	sink = 1
2e7d5426 MM	26	rvrNode i boringness = 2 + 3*i + boringness
	27	propNode j expertness = 2 + 3numRvrs + 3j + expertness
	28	numNodes = 2 + 3numRvrs + 3numProps
d7d9561e MM	29	in
d7d9561e MM	30	let
2e7d5426 MM	31	totalReviews = reviewsEachProposal * numProps
	32	totalRelativeLoad = foldl (+) 0 (map rloadF [0 .. numRvrs - 1])
	33	targetLoad i = ceiling (numAsWt totalReviews * rloadF i / totalRelativeLoad)
	34	-- A...H refer to idea book p.429
	35	edgesABC = do
d7d9561e	36	i <- [0 .. numRvrs - 1]
2e7d5426 MM	37	let tl = targetLoad i
	38	l <- [0 .. tl + loadTolerance - 1]
	39	let costA = if l < tl
	40	then 0
	41	else marginalLoadCost ((numAsWt (l - tl) + 1/2) / numAsWt loadTolerance)
	42	let edgeA = (source, rvrNode i 0, costA)
	43	let costB = marginalBoringCost ((numAsWt l + 1/2) / numAsWt tl)
	44	let edgeB = (rvrNode i 0, rvrNode i 1, costB)
	45	let costC = marginalVeryBoringCost ((numAsWt l + 1/2) / numAsWt tl)
	46	let edgeC = (rvrNode i 1, rvrNode i 2, costC)
	47	[edgeA, edgeB, edgeC]
	48	edgesD = do
d7d9561e MM	49	i <- [0 .. numRvrs - 1]
	50	j <- [0 .. numProps - 1]
	51	let pref = prefF i j
	52	if prefIsConflict pref
2e7d5426 MM	53	then []
	54	else [(rvrNode i (prefBoringness pref),
	55	propNode j (prefExpertness pref),
	56	assignmentCost pref)]
	57	edgesE = do
	58	j <- [0 .. numProps - 1]
	59	[(propNode j 2, propNode j 0, -expertBonus)]
	60	edgesFGH = do
d7d9561e	61	j <- [0 .. numProps - 1]
2e7d5426 MM	62	l <- [0 .. reviewsEachProposal - 1]
	63	let edgeF = (propNode j 2, propNode j 1, 0)
	64	let edgeG = (propNode j 1, propNode j 0,
	65	if l == 0 then -knowledgeableBonus else 0)
	66	let edgeH = (propNode j 0, sink, 0)
	67	[edgeF, edgeG, edgeH]
	68	theNodes = [(x, ()) \| x <- [0 .. numNodes - 1]]
	69	theEdges = edgesABC ++ edgesD ++ edgesE ++ edgesFGH
d7d9561e MM	70	in
	71	mkGraph theNodes theEdges
	72
	73	todo = undefined
	74	-- Returns a list of reviews as ordered pairs (reviewer#, proposal#).
2e7d5426 MM	75	doMatching :: Instance -> [(Int, Int)]
2e7d5426 MM	76	doMatching inst@(Instance numRvrs numProps rloadF prefF) =
d7d9561e MM	77	-- Copied from doReduction. There should be a better way to get these here.
	78	let
	79	source = 0
	80	sink = 1
2e7d5426 MM	81	rvrNode i boringness = 2 + 3*i + boringness
	82	propNode j expertness = 2 + 3numRvrs + 3j + expertness
	83	firstPropNode = propNode 0 0
	84	idPropNode n = (n - (2 + 3*numRvrs)) `div` 3
	85	numNodes = 2 + 3numRvrs + 3numProps
d7d9561e	86	in
2e7d5426	87	let graph1 = doReduction inst in
d7d9561e	88	let flow1 = flowDiff graph1 (snd (umcf source sink graph1)) in
d7d9561e MM	89	let pairs = do
d7d9561e MM	90	i <- [0 .. numRvrs - 1]
2e7d5426 MM	91	boringness <- [0, 1, 2]
	92	n <- suc flow1 (rvrNode i boringness)
	93	if n >= firstPropNode
	94	then [(i, idPropNode n)]
	95	else []
	96	in
d7d9561e	97	sort pairs -- for prettiness