X-Git-Url: https://mattmccutchen.net/match/match.git/blobdiff_plain/9ecd6424ffbf1305e7344b99517c4fbb04b26df2..2e7d542623d17554667ca0199dd988caf3c442ae:/program/ProposalMatch.hs

diff --git a/program/ProposalMatch.hs b/program/ProposalMatch.hs
index 07cb710..028f22c 100644
--- a/program/ProposalMatch.hs
+++ b/program/ProposalMatch.hs
@@ -7,65 +7,91 @@ import Data.List
 
 import ProposalMatchConfig
 
-data Real wt => Instance wt = Instance Int Int (Int -> Int -> wt)
+data Instance = Instance
+	Int                -- numReviewers
+	Int                -- numProposals
+	(Int -> Wt)        -- reviewer -> relative load
+	(Int -> Int -> Wt) -- reviewer -> proposal -> pref
 
-doReduction :: Real wt => Instance wt -> (Int -> Int) -> Gr () wt
-doReduction (Instance numRvrs numProps prefF) expertCapF =
+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 = 2 + i
-		propNode j isExpert = 2 + numRvrs + 2*j + (if isExpert then 1 else 0)
-		numNodes = 2 + numRvrs + 2*numProps
-		theNodes = [(x, ()) | x <- [0 .. numNodes - 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
-		loadEdges = do
+		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]
-			l <- [1 .. maxReviewerLoad]
-			return (source, rvrNode i, marginalLoadCost l)
-		prefEdges = do
+			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 fail "Conflict of interest"
-				else return (rvrNode i, propNode j (prefIsExpert pref),
-					prefToCost pref)
-		wantEdges = do
+				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]
-			let wExpert = expertCapF j
-			-- Yuck, too many kinds of integers.
-			let wGeneral = fromInteger wantGeneralReviews +
-				fromInteger wantReviewsSubstForExpert *
-				(fromInteger wantExpertReviews - wExpert) 
-			let expertEdges = replicate wExpert (propNode j True, sink, 0)
-			let rolloverEdges = replicate wGeneral (propNode j True, propNode j False, 0)
-			let generalEdges = replicate wGeneral (propNode j False, sink, 0)
-			expertEdges ++ rolloverEdges ++ generalEdges
-		theEdges = loadEdges ++ prefEdges ++ wantEdges
+			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 :: Real wt => Instance wt -> [(Int, Int)]
-doMatching inst@(Instance numRvrs numProps prefF) =
+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 = 2 + i
-		propNode j isExpert = 2 + numRvrs + 2*j + (if isExpert then 1 else 0)
-		idPropNode n = (n - (2 + numRvrs)) `div` 2
-		numNodes = 2 + numRvrs + 2*numProps
+		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 (const (fromInteger wantExpertReviews)) in
+	let graph1 = doReduction inst in
 	let flow1 = flowDiff graph1 (snd (umcf source sink graph1)) in
-	let expertCapF j = min (fromInteger wantExpertReviews) (outdeg flow1 (propNode j True)) in
-	let graph2 = doReduction inst expertCapF in
-	let flow2 = flowDiff graph2 (snd (umcf source sink graph2)) in
 	let pairs = do
 		i <- [0 .. numRvrs - 1]
-		map (\n -> (i, idPropNode n)) (suc flow2 (rvrNode i)) in
+		boringness <- [0, 1, 2]
+		n <- suc flow1 (rvrNode i boringness)
+		if n >= firstPropNode
+			then [(i, idPropNode n)]
+			else []
+		in
 	sort pairs -- for prettiness