import Data.Graph.Inductive.Graph
import Data.Graph.Inductive.Tree
import Data.List
+import Data.Either
import ArrayStuff
+import MonadStuff
import PMInstance
import PMConfig
x `implies` y = (not x) || y
doReduction :: PMConfig -> PMInstance -> ReductionResult
-doReduction cfg (PMInstance numRvrs numProps rloadA prefA expA) =
+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
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])
-- floor goes best with loadTolerance 2
targetLoad i = floor (widenInteger totalReviews * (rloadA ! i) / totalRelativeLoad) - 1
- -- A...H refer to idea book p.429
+ -- 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 ((widenInteger (l - tl) + 1/2) / widenInteger (loadTolerance cfg))
+ 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]
+ 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 ((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)
-- of interest; otherwise we'll fail to read its flow
-- value in doMatching.
let xp_ = expExpertness cfg xp
- let k = if (isPC ! i)
+ let pn = propNode j $ if (isPC ! i)
then xp_ + 3 -- Can assume it is a PC paper, otherwise it would conflict anyway.
else xp_
- [(rvrNode i (prefBoringness cfg pref),
- propNode j k,
- REdge (edIdx (i, j))
+ 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]
-- 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 (reviewsEachProposal cfg - 1) 0)
+ 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 (reviewsEachProposal cfg - 2) 0)
+ 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 (reviewsEachProposal cfg - 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 (reviewsEachProposal cfg - 1) 0) | k <- [4 .. 5]]
- let edgesR = [(propNode j k, propNode j (k - 3), REdge undefined 1 0) | k <- [4 .. 5]]
+ 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 1 (-(expertBonus cfg)))
- let edgeH1 = (propNode j 1, sink, REdge undefined 1 0)
+ 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 (reviewsEachProposal cfg - 2) 0)
- let edgeH = (propNode j 3, sink, REdge undefined (reviewsEachProposal cfg - 1) 0)
+ 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
-- 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
Matt McCutchen's Web Site / match / match.git / blobdiff