X-Git-Url: https://mattmccutchen.net/match/match.git/blobdiff_plain/5a07db44406bad03321a90b0814cc4496c6b7d63..e95df3f5aa9099829c63bab4a5c5ea96808edeb0:/program/ProposalMatcher.hs

diff --git a/program/ProposalMatcher.hs b/program/ProposalMatcher.hs
index f523c27..dcc757a 100644
--- a/program/ProposalMatcher.hs
+++ b/program/ProposalMatcher.hs
@@ -1,17 +1,16 @@
 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
+import PMInstance
+import PMConfig
 
-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
+prefBoringness cfg p = if prefIsVeryBoring cfg p then 2
+	else if prefIsBoring cfg p then 1 else 0
+prefExpertness cfg p = if prefIsExpert cfg p then 2
+	else if prefIsKnowledgeable cfg p then 1 else 0
 
 data REdge = REdge {
 	reIdx  :: Int,
@@ -42,8 +41,8 @@ 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) =
+doReduction :: PMConfig -> PMInstance -> ReductionResult
+doReduction cfg (PMInstance numRvrs numProps rloadA prefA) =
 	let
 		source = 0
 		sink = 1
@@ -53,23 +52,23 @@ doReduction (Instance numRvrs numProps rloadA prefA) =
 		edIdx (i, j) = i*numProps + j
 		in
 	let
-		totalReviews = reviewsEachProposal * numProps
+		totalReviews = (reviewsEachProposal cfg) * numProps
 		totalRelativeLoad = foldl (+) 0 (map (rloadA !) [0 .. numRvrs - 1])
-		targetLoad i = ceiling (numAsWt totalReviews * (rloadA ! i) / totalRelativeLoad)
+		targetLoad i = ceiling (widenInteger 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)
+				l <- [tl .. tl + (loadTolerance cfg) - 1]
+				let costA = marginalLoadCost cfg ((widenInteger (l - tl) + 1/2) / widenInteger (loadTolerance cfg))
 				[(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)
+				l <- [0 .. tl + (loadTolerance cfg) - 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 ((numAsWt l + 1/2) / numAsWt tl)
+				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
@@ -77,18 +76,21 @@ doReduction (Instance numRvrs numProps rloadA prefA) =
 			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))]
+			-- We must generate an edge even if there is a conflict
+			-- of interest; otherwise we'll fail to read its flow
+			-- value in doMatching.
+			[(rvrNode i (prefBoringness cfg pref),
+				propNode j (prefExpertness cfg pref),
+				REdge (edIdx (i, j))
+					(if prefIsConflict cfg pref then 0 else 1)
+					(assignmentCost cfg 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)
+			let edgeE = (propNode j 2, propNode j 0, REdge undefined 1 (-(expertBonus cfg)))
+			let edgeF = (propNode j 2, propNode j 1, REdge undefined (reviewsEachProposal cfg) 0)
+			let edgeGFirst = (propNode j 1, propNode j 0, REdge undefined 1 (-(knowledgeableBonus cfg)))
+			let edgeGRest = (propNode j 1, propNode j 0, REdge undefined (reviewsEachProposal cfg - 1) 0)
+			let edgeH = (propNode j 0, sink, REdge undefined (reviewsEachProposal cfg) 0)
 			[edgeE, edgeF, edgeGFirst, edgeGRest, edgeH]
 		theNodes = [(x, ()) | x <- [0 .. numNodes - 1]]
 		-- Index the non-D edges
@@ -98,22 +100,11 @@ doReduction (Instance numRvrs numProps rloadA prefA) =
 		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
+doMatching :: PMConfig -> PMInstance -> PMatching
+doMatching cfg inst@(PMInstance numRvrs numProps _ _) =
+	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]
@@ -121,4 +112,4 @@ doMatching inst@(Instance numRvrs numProps _ _) =
 			then [(i, j)]
 			else []
 		in
-	sort pairs -- for prettiness
+	PMatching (sort pairs) -- for prettiness