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
Matt McCutchen's Web Site / match / match.git / blobdiff