module ProposalMatcher where
-import UnitMinCostFlow
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
-doReduction :: Instance -> Gr () Wt
-doReduction (Instance numRvrs numProps rloadA prefA) =
+data REdge = REdge {
+ reIdx :: Int,
+ reCap :: Int,
+ reCost :: Wt
+}
+
+instance Show REdge where
+ show (REdge idx cap cost) = "#" ++ (show idx) ++ ": "
+ ++ (show cap) ++ " @ " ++ (show cost)
+
+data ReductionResult = ReductionResult {
+ rrGraph :: Gr () REdge,
+ rrSource :: Node,
+ rrSink :: Node,
+ rrEIdxBounds :: (Int, Int),
+ rrEDIdx :: (Int, Int) -> Int
+}
+
+-- Hack: show as much of the reduction result as we easily can
+data RR1 = RR1 (Gr () REdge) Node Node (Int, Int) deriving Show
+instance Show ReductionResult where
+ show (ReductionResult g so si eib _) = show (RR1 g so si eib)
+
+indexEdges :: Int -> [(Int, Int, REdge)] -> (Int, [(Int, Int, REdge)])
+indexEdges i [] = (i, [])
+indexEdges i ((v1, v2, re):es) =
+ let (imax, ies) = indexEdges (i+1) es in
+ (imax, (v1, v2, re{ reIdx = i }) : ies)
+
+doReduction :: PMConfig -> PMInstance -> ReductionResult
+doReduction cfg (PMInstance numRvrs numProps rloadA prefA) =
let
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
+ 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
- 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]
+ 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))
+ [(source, rvrNode i 0, REdge undefined 1 costA)]
+ let edgesBC = do
+ 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 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
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),
- assignmentCost pref)]
- edgesE = do
- j <- [0 .. numProps - 1]
- [(propNode j 2, propNode j 0, -expertBonus)]
- edgesFGH = do
+ -- 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]
- 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]
+ 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]]
- theEdges = edgesABC ++ edgesD ++ edgesE ++ edgesFGH
+ -- Index the non-D edges
+ unindexedEdges = edgesABC ++ edgesEFGH
+ (imax, reindexedEdges) = indexEdges (numRvrs*numProps) unindexedEdges
+ theEdges = edgesD ++ reindexedEdges
in
- mkGraph theNodes theEdges
+ 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 graph1 = doReduction inst in
- let flow1 = flowDiff graph1 (snd (umcf source sink graph1)) 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]
- boringness <- [0, 1, 2]
- n <- suc flow1 (rvrNode i boringness)
- if n >= firstPropNode
- then [(i, idPropNode n)]
+ j <- [0 .. numProps - 1]
+ if flowArray ! edIdx (i, j) == 1
+ then [(i, j)]
else []
in
- sort pairs -- for prettiness
+ PMatching (sort pairs) -- for prettiness
Matt McCutchen's Web Site / match / match.git / blobdiff