X-Git-Url: https://mattmccutchen.net/match/match.git/blobdiff_plain/bc14b3b3a9345cb74bc7d8f3808a1d8cdd0bf479..1a8dd46727a20bad8164af908ad027eac6abc6cc:/program/ProposalMatcher.hs

diff --git a/program/ProposalMatcher.hs b/program/ProposalMatcher.hs
index 96c2c32..e093a13 100644
--- a/program/ProposalMatcher.hs
+++ b/program/ProposalMatcher.hs
@@ -3,14 +3,17 @@ import Data.Array.IArray
 import Data.Graph.Inductive.Graph
 import Data.Graph.Inductive.Tree
 import Data.List
+import Data.Either
 
+import ArrayStuff
+import MonadStuff
 import PMInstance
 import PMConfig
 
 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
+expExpertness cfg x = if expIsExpert cfg x then 2
+	else if expIsKnowledgeable cfg x then 1 else 0
 
 data REdge = REdge {
 	reIdx  :: Int,
@@ -41,60 +44,102 @@ indexEdges i ((v1, v2, re):es) =
 	let (imax, ies) = indexEdges (i+1) es in
 	(imax, (v1, v2, re{ reIdx = i }) : ies)
 
+implies :: Bool -> Bool -> Bool
+x `implies` y = (not x) || y
+
 doReduction :: PMConfig -> PMInstance -> ReductionResult
-doReduction cfg (PMInstance numRvrs numProps rloadA prefA) =
+doReduction cfg (PMInstance numRvrs numProps rloadA prefA expA fixA pnrA) =
 	let
+		-- Need to figure out who is PC/ERC
+		isPC = (funcArray (0, numRvrs-1) (\i -> (rloadA ! i) == 1)) :: Array Int Bool
+		isPCPaper = (funcArray (0, numProps-1) (\j -> all (\i -> (isPC ! i) `implies` (prefIsConflict cfg $ (prefA ! (i, j)))) [0 .. numRvrs - 1])) :: Array Int Bool
 		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
+		-- We will waste a lot of nodes.  Who cares, no one will visit them.
+		propNode j k = 2 + 3*numRvrs + 7*j + k
+		numNodes = 2 + 3*numRvrs + 7*numProps
 		edIdx (i, j) = i*numProps + j
 		in
 	let
-		totalReviews = (reviewsEachProposal cfg) * numProps
+		totalReviews = sum $ elems pnrA    -- (reviewsEachProposal cfg) * 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
+		-- floor goes best with loadTolerance 2
+		targetLoad i = floor (widenInteger totalReviews * (rloadA ! i) / totalRelativeLoad) - 1
+		-- Edge groups A through H are indicated in the figure in the paper.
 		edgesABC = do
 			i <- [0 .. numRvrs - 1]
 			let tl = targetLoad i
+			let lt = if isPC ! i then loadTolerance cfg else ercLoadTolerance cfg
 			let freeEdgeA = (source, rvrNode i 0, REdge undefined tl 0)
 			let nonfreeEdgesA = do
-				l <- [tl .. tl + (loadTolerance cfg) - 1]
-				let costA = marginalLoadCost cfg ((numAsWt (l - tl) + 1/2) / numAsWt (loadTolerance cfg))
-				[(source, rvrNode i 0, REdge undefined 1 costA)]
+				l <- [tl .. tl + lt - 1]
+				let costA = marginalLoadCost cfg ((widenInteger (l - tl) + 1/2) / widenInteger lt)
+				return (source, rvrNode i 0, REdge undefined 1 costA)
 			let edgesBC = do
-				l <- [0 .. tl + (loadTolerance cfg) - 1]
-				let costB = marginalBoringCost cfg ((numAsWt l + 1/2) / numAsWt tl)
+				l <- [0 .. tl + lt - 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 cfg ((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
-		edgesD = do
+		edgesDFix = do
 			i <- [0 .. numRvrs - 1]
 			j <- [0 .. numProps - 1]
 			let pref = prefA ! (i, j)
+			let xp = expA ! (i, j)
 			-- 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))
+			let xp_ = expExpertness cfg xp
+			let pn = propNode j $ if (isPC ! i)
+				then xp_ + 3  -- Can assume it is a PC paper, otherwise it would conflict anyway.
+				else xp_
+			let rn = rvrNode i (prefBoringness cfg pref)
+			if fixA ! (i, j)
+				-- Max flow will emulate one unit of flow through the edge,
+				-- at a cost of increasing the total flow value by 1.
+				then [Right (rn, sink, REdge undefined 1 0),
+					Right (source, pn, REdge undefined 1 0)]
+				else [Left (rn, pn, REdge (edIdx (i, j))
 					(if prefIsConflict cfg pref then 0 else 1)
 					(assignmentCost cfg pref))]
+		edgesD = lefts edgesDFix
+		edgesFix = rights edgesDFix
 		edgesEFGH = do
 			j <- [0 .. numProps - 1]
-			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]
+			-- This is now different...
+			let numReviews = pnrA ! j
+			if isPCPaper ! j
+				then do -- Mostly traditional.
+					-- Expert bonus
+					let edgeFFirst = (propNode j 2, propNode j 1, REdge undefined 1 (-(expertBonus cfg)))
+					let edgeFRest = (propNode j 2, propNode j 1, REdge undefined (numReviews - 1) 0)
+					-- Second kowledgeable bonus
+					let edgeGFirst = (propNode j 1, propNode j 0, REdge undefined 1 (-(knowledgeableBonus cfg)))
+					let edgeGRest = (propNode j 1, propNode j 0, REdge undefined (numReviews - 2) 0)
+					-- Require one knowledgeable
+					let edgeH1 = (propNode j 1, sink, REdge undefined 1 0)
+					let edgeH = (propNode j 0, sink, REdge undefined (numReviews - 1) 0)
+					[edgeFFirst, edgeFRest, edgeGFirst, edgeGRest, edgeH1, edgeH]
+				else do -- New gadget; man, a lot of edges
+					let numPCReviews = pcReviewsEachProposal cfg
+					if numReviews < numPCReviews then fail "numReviews for paper < numPCReviews" else nop
+					-- Structure to distribute knowledgeable PC members
+					let edgesP = [(propNode j k, propNode j 6, REdge undefined numPCReviews 0) | k <- [4 .. 5]]
+					let edgesR = [(propNode j k, propNode j (k - 3), REdge undefined (numReviews - numPCReviews) 0) | k <- [4 .. 5]]
+					-- "Designated knowledgeable" with expert bonus
+					let edgeF = (propNode j 2, propNode j 1, REdge undefined (numReviews - numPCReviews) (-(expertBonus cfg)))
+					let edgeH1 = (propNode j 1, sink, REdge undefined (numReviews - numPCReviews) 0)
+					-- "Designated PC" with knowledgeable bonus
+					let edgeGFirst = (propNode j 6, propNode j 3, REdge undefined 1 (-(knowledgeableBonus cfg)))
+					let edgeGRest = (propNode j 6, propNode j 3, REdge undefined (numPCReviews - 1) 0)
+					let edgeH = (propNode j 3, sink, REdge undefined (numPCReviews) 0)
+					edgesP ++ edgesR ++ [edgeF, edgeH1, edgeGFirst, edgeGRest, edgeH]
 		theNodes = [(x, ()) | x <- [0 .. numNodes - 1]]
 		-- Index the non-D edges
-		unindexedEdges = edgesABC ++ edgesEFGH
+		unindexedEdges = edgesABC ++ edgesFix ++ edgesEFGH
 		(imax, reindexedEdges) = indexEdges (numRvrs*numProps) unindexedEdges
 		theEdges = edgesD ++ reindexedEdges
 		in
@@ -102,14 +147,14 @@ doReduction cfg (PMInstance numRvrs numProps rloadA prefA) =
 
 -- Returns a list of reviews as ordered pairs (reviewer#, proposal#).
 doMatching :: PMConfig -> PMInstance -> PMatching
-doMatching cfg inst@(PMInstance numRvrs numProps _ _) =
+doMatching cfg inst@(PMInstance numRvrs numProps _ _ _ fixA _) =
 	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]
-		if flowArray ! edIdx (i, j) == 1
+		if fixA ! (i, j) || flowArray ! edIdx (i, j) == 1
 			then [(i, j)]
 			else []
 		in
-	sort pairs -- for prettiness
+	PMatching (sort pairs) -- for prettiness