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 IMinCostFlow
-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
+data PMConfig = PMConfig {
+ minCostFlow :: MinCostFlowImpl,
+ reviewsEachProposal :: Int,
+ prefIsExpert :: Wt -> Bool,
+ prefIsKnowledgeable :: Wt -> Bool,
+ prefIsBoring :: Wt -> Bool,
+ prefIsVeryBoring :: Wt -> Bool,
+ prefIsConflict :: Wt -> Bool,
+ loadTolerance :: Int,
+ marginalLoadCost :: Wt -> Wt,
+ marginalBoringCost :: Wt -> Wt,
+ marginalVeryBoringCost :: Wt -> Wt,
+ assignmentCost :: Wt -> Wt,
+ knowledgeableBonus :: Wt,
+ expertBonus :: Wt
+}
+
+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,
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 -> Instance -> ReductionResult
+doReduction cfg (Instance numRvrs numProps rloadA prefA) =
let
source = 0
sink = 1
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)
-- A...H refer to idea book p.429
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 ((numAsWt (l - tl) + 1/2) / numAsWt (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 ((numAsWt l + 1/2) / numAsWt 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 ((numAsWt l + 1/2) / numAsWt tl)
let edgeC = (rvrNode i 1, rvrNode i 2, REdge undefined 1 costC)
[edgeB, edgeC]
[freeEdgeA] ++ nonfreeEdgesA ++ edgesBC
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
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 _ _) =
- let ReductionResult graph source sink idxBounds edIdx = doReduction inst in
- let flowArray = minCostFlow idxBounds reIdx reCap reCost graph (source, sink) in
+doMatching :: PMConfig -> Instance -> [(Int, Int)]
+doMatching cfg inst@(Instance 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]