X-Git-Url: https://mattmccutchen.net/match/match.git/blobdiff_plain/967c39efa10c8a2d74812741cd7a2a96602a6210..e95df3f5aa9099829c63bab4a5c5ea96808edeb0:/program/ProposalMatcher.hs diff --git a/program/ProposalMatcher.hs b/program/ProposalMatcher.hs index c0bd7a0..dcc757a 100644 --- a/program/ProposalMatcher.hs +++ b/program/ProposalMatcher.hs @@ -1,92 +1,115 @@ 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