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

module ProposalMatcher where
import NaiveMinCostFlow
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

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)

doReduction :: Instance -> ReductionResult
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
		edIdx (i, j) = i*numProps + j
		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
			let freeEdgeA = (source, rvrNode i 0, REdge undefined tl 0)
			let nonfreeEdgesA = do
				l <- [tl .. tl + loadTolerance - 1]
				let costA = marginalLoadCost ((numAsWt (l - tl) + 1/2) / numAsWt loadTolerance)
				[(source, rvrNode i 0, REdge undefined 1 costA)]
			let edgesBC = do
				l <- [0 .. tl + loadTolerance - 1]
				let costB = marginalBoringCost ((numAsWt l + 1/2) / numAsWt tl)
				let edgeB = (rvrNode i 0, rvrNode i 1, REdge undefined 1 costB)
				let costC = marginalVeryBoringCost ((numAsWt l + 1/2) / numAsWt tl)
				let edgeC = (rvrNode i 1, rvrNode i 2, REdge undefined 1 costC)
				[edgeB, edgeC]
			[freeEdgeA] ++ nonfreeEdgesA ++ edgesBC
		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),
					REdge (edIdx (i, j)) 1 (assignmentCost pref))]
		edgesEFGH = do
			j <- [0 .. numProps - 1]
			let edgeE = (propNode j 2, propNode j 0, REdge undefined 1 (-expertBonus))
			let edgeF = (propNode j 2, propNode j 1, REdge undefined reviewsEachProposal 0)
			let edgeGFirst = (propNode j 1, propNode j 0, REdge undefined 1 (-knowledgeableBonus))
			let edgeGRest = (propNode j 1, propNode j 0, REdge undefined (reviewsEachProposal-1) 0)
			let edgeH = (propNode j 0, sink, REdge undefined reviewsEachProposal 0)
			[edgeE, edgeF, edgeGFirst, edgeGRest, edgeH]
		theNodes = [(x, ()) | x <- [0 .. numNodes - 1]]
		-- Index the non-D edges
		unindexedEdges = edgesABC ++ edgesEFGH
		(imax, reindexedEdges) = indexEdges (numRvrs*numProps) unindexedEdges
		theEdges = edgesD ++ reindexedEdges
		in
	ReductionResult (mkGraph theNodes theEdges) source sink (0, imax-1) edIdx

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 ReductionResult graph source sink idxBounds edIdx = doReduction inst in
	let flowArray = minCostFlow idxBounds reIdx reCap reCost graph (source, sink) in
	let pairs = do
		i <- [0 .. numRvrs - 1]
		j <- [0 .. numProps - 1]
		if flowArray ! edIdx (i, j) == 1
			then [(i, j)]
			else []
		in
	sort pairs -- for prettiness
Commit	Line	Data
967c39ef	1	module ProposalMatcher where
5a07db44	2	import NaiveMinCostFlow
d7d9561e MM	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
5a07db44 MM	16	data REdge = REdge {
	17	reIdx :: Int,
	18	reCap :: Int,
	19	reCost :: Wt
	20	}
	21
	22	instance Show REdge where
	23	show (REdge idx cap cost) = "#" ++ (show idx) ++ ": "
	24	++ (show cap) ++ " @ " ++ (show cost)
	25
	26	data ReductionResult = ReductionResult {
	27	rrGraph :: Gr () REdge,
	28	rrSource :: Node,
	29	rrSink :: Node,
	30	rrEIdxBounds :: (Int, Int),
	31	rrEDIdx :: (Int, Int) -> Int
	32	}
	33
	34	-- Hack: show as much of the reduction result as we easily can
	35	data RR1 = RR1 (Gr () REdge) Node Node (Int, Int) deriving Show
	36	instance Show ReductionResult where
	37	show (ReductionResult g so si eib _) = show (RR1 g so si eib)
	38
	39	indexEdges :: Int -> [(Int, Int, REdge)] -> (Int, [(Int, Int, REdge)])
	40	indexEdges i [] = (i, [])
	41	indexEdges i ((v1, v2, re):es) =
	42	let (imax, ies) = indexEdges (i+1) es in
	43	(imax, (v1, v2, re{ reIdx = i }) : ies)
	44
	45	doReduction :: Instance -> ReductionResult
967c39ef	46	doReduction (Instance numRvrs numProps rloadA prefA) =
d7d9561e MM	47	let
	48	source = 0
	49	sink = 1
2e7d5426 MM	50	rvrNode i boringness = 2 + 3*i + boringness
	51	propNode j expertness = 2 + 3numRvrs + 3j + expertness
	52	numNodes = 2 + 3numRvrs + 3numProps
5a07db44	53	edIdx (i, j) = i*numProps + j
d7d9561e MM	54	in
d7d9561e MM	55	let
2e7d5426	56	totalReviews = reviewsEachProposal * numProps
967c39ef MM	57	totalRelativeLoad = foldl (+) 0 (map (rloadA !) [0 .. numRvrs - 1])
967c39ef MM	58	targetLoad i = ceiling (numAsWt totalReviews * (rloadA ! i) / totalRelativeLoad)
2e7d5426 MM	59	-- A...H refer to idea book p.429
2e7d5426 MM	60	edgesABC = do
d7d9561e	61	i <- [0 .. numRvrs - 1]
2e7d5426	62	let tl = targetLoad i
5a07db44 MM	63	let freeEdgeA = (source, rvrNode i 0, REdge undefined tl 0)
	64	let nonfreeEdgesA = do
	65	l <- [tl .. tl + loadTolerance - 1]
	66	let costA = marginalLoadCost ((numAsWt (l - tl) + 1/2) / numAsWt loadTolerance)
	67	[(source, rvrNode i 0, REdge undefined 1 costA)]
	68	let edgesBC = do
	69	l <- [0 .. tl + loadTolerance - 1]
	70	let costB = marginalBoringCost ((numAsWt l + 1/2) / numAsWt tl)
	71	let edgeB = (rvrNode i 0, rvrNode i 1, REdge undefined 1 costB)
	72	let costC = marginalVeryBoringCost ((numAsWt l + 1/2) / numAsWt tl)
	73	let edgeC = (rvrNode i 1, rvrNode i 2, REdge undefined 1 costC)
	74	[edgeB, edgeC]
	75	[freeEdgeA] ++ nonfreeEdgesA ++ edgesBC
2e7d5426	76	edgesD = do
d7d9561e MM	77	i <- [0 .. numRvrs - 1]
d7d9561e MM	78	j <- [0 .. numProps - 1]
967c39ef	79	let pref = prefA ! (i, j)
d7d9561e	80	if prefIsConflict pref
2e7d5426 MM	81	then []
	82	else [(rvrNode i (prefBoringness pref),
	83	propNode j (prefExpertness pref),
5a07db44 MM	84	REdge (edIdx (i, j)) 1 (assignmentCost pref))]
5a07db44 MM	85	edgesEFGH = do
d7d9561e	86	j <- [0 .. numProps - 1]
5a07db44 MM	87	let edgeE = (propNode j 2, propNode j 0, REdge undefined 1 (-expertBonus))
	88	let edgeF = (propNode j 2, propNode j 1, REdge undefined reviewsEachProposal 0)
	89	let edgeGFirst = (propNode j 1, propNode j 0, REdge undefined 1 (-knowledgeableBonus))
	90	let edgeGRest = (propNode j 1, propNode j 0, REdge undefined (reviewsEachProposal-1) 0)
	91	let edgeH = (propNode j 0, sink, REdge undefined reviewsEachProposal 0)
	92	[edgeE, edgeF, edgeGFirst, edgeGRest, edgeH]
2e7d5426	93	theNodes = [(x, ()) \| x <- [0 .. numNodes - 1]]
5a07db44 MM	94	-- Index the non-D edges
	95	unindexedEdges = edgesABC ++ edgesEFGH
	96	(imax, reindexedEdges) = indexEdges (numRvrs*numProps) unindexedEdges
	97	theEdges = edgesD ++ reindexedEdges
d7d9561e	98	in
5a07db44	99	ReductionResult (mkGraph theNodes theEdges) source sink (0, imax-1) edIdx
d7d9561e MM	100
	101	todo = undefined
	102	-- Returns a list of reviews as ordered pairs (reviewer#, proposal#).
2e7d5426	103	doMatching :: Instance -> [(Int, Int)]
967c39ef	104	doMatching inst@(Instance numRvrs numProps _ _) =
d7d9561e MM	105	-- Copied from doReduction. There should be a better way to get these here.
	106	let
	107	source = 0
	108	sink = 1
2e7d5426 MM	109	rvrNode i boringness = 2 + 3*i + boringness
	110	propNode j expertness = 2 + 3numRvrs + 3j + expertness
	111	firstPropNode = propNode 0 0
	112	idPropNode n = (n - (2 + 3*numRvrs)) `div` 3
	113	numNodes = 2 + 3numRvrs + 3numProps
d7d9561e	114	in
5a07db44 MM	115	let ReductionResult graph source sink idxBounds edIdx = doReduction inst in
5a07db44 MM	116	let flowArray = minCostFlow idxBounds reIdx reCap reCost graph (source, sink) in
d7d9561e MM	117	let pairs = do
d7d9561e MM	118	i <- [0 .. numRvrs - 1]
5a07db44 MM	119	j <- [0 .. numProps - 1]
	120	if flowArray ! edIdx (i, j) == 1
	121	then [(i, j)]
2e7d5426 MM	122	else []
2e7d5426 MM	123	in
d7d9561e	124	sort pairs -- for prettiness