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

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

import Instance
import ProposalMatcherConfig

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