| 1 | module ProposalMatcher where |
| 2 | import Data.Array.IArray |
| 3 | import Data.Graph.Inductive.Graph |
| 4 | import Data.Graph.Inductive.Tree |
| 5 | import Data.List |
| 6 | |
| 7 | import PMInstance |
| 8 | import IMinCostFlow |
| 9 | |
| 10 | data PMConfig = PMConfig { |
| 11 | minCostFlow :: MinCostFlowImpl, |
| 12 | reviewsEachProposal :: Int, |
| 13 | prefIsExpert :: Wt -> Bool, |
| 14 | prefIsKnowledgeable :: Wt -> Bool, |
| 15 | prefIsBoring :: Wt -> Bool, |
| 16 | prefIsVeryBoring :: Wt -> Bool, |
| 17 | prefIsConflict :: Wt -> Bool, |
| 18 | loadTolerance :: Int, |
| 19 | marginalLoadCost :: Wt -> Wt, |
| 20 | marginalBoringCost :: Wt -> Wt, |
| 21 | marginalVeryBoringCost :: Wt -> Wt, |
| 22 | assignmentCost :: Wt -> Wt, |
| 23 | knowledgeableBonus :: Wt, |
| 24 | expertBonus :: Wt |
| 25 | } |
| 26 | |
| 27 | prefBoringness cfg p = if prefIsVeryBoring cfg p then 2 |
| 28 | else if prefIsBoring cfg p then 1 else 0 |
| 29 | prefExpertness cfg p = if prefIsExpert cfg p then 2 |
| 30 | else if prefIsKnowledgeable cfg p then 1 else 0 |
| 31 | |
| 32 | data REdge = REdge { |
| 33 | reIdx :: Int, |
| 34 | reCap :: Int, |
| 35 | reCost :: Wt |
| 36 | } |
| 37 | |
| 38 | instance Show REdge where |
| 39 | show (REdge idx cap cost) = "#" ++ (show idx) ++ ": " |
| 40 | ++ (show cap) ++ " @ " ++ (show cost) |
| 41 | |
| 42 | data ReductionResult = ReductionResult { |
| 43 | rrGraph :: Gr () REdge, |
| 44 | rrSource :: Node, |
| 45 | rrSink :: Node, |
| 46 | rrEIdxBounds :: (Int, Int), |
| 47 | rrEDIdx :: (Int, Int) -> Int |
| 48 | } |
| 49 | |
| 50 | -- Hack: show as much of the reduction result as we easily can |
| 51 | data RR1 = RR1 (Gr () REdge) Node Node (Int, Int) deriving Show |
| 52 | instance Show ReductionResult where |
| 53 | show (ReductionResult g so si eib _) = show (RR1 g so si eib) |
| 54 | |
| 55 | indexEdges :: Int -> [(Int, Int, REdge)] -> (Int, [(Int, Int, REdge)]) |
| 56 | indexEdges i [] = (i, []) |
| 57 | indexEdges i ((v1, v2, re):es) = |
| 58 | let (imax, ies) = indexEdges (i+1) es in |
| 59 | (imax, (v1, v2, re{ reIdx = i }) : ies) |
| 60 | |
| 61 | doReduction :: PMConfig -> PMInstance -> ReductionResult |
| 62 | doReduction cfg (PMInstance numRvrs numProps rloadA prefA) = |
| 63 | let |
| 64 | source = 0 |
| 65 | sink = 1 |
| 66 | rvrNode i boringness = 2 + 3*i + boringness |
| 67 | propNode j expertness = 2 + 3*numRvrs + 3*j + expertness |
| 68 | numNodes = 2 + 3*numRvrs + 3*numProps |
| 69 | edIdx (i, j) = i*numProps + j |
| 70 | in |
| 71 | let |
| 72 | totalReviews = (reviewsEachProposal cfg) * numProps |
| 73 | totalRelativeLoad = foldl (+) 0 (map (rloadA !) [0 .. numRvrs - 1]) |
| 74 | targetLoad i = ceiling (numAsWt totalReviews * (rloadA ! i) / totalRelativeLoad) |
| 75 | -- A...H refer to idea book p.429 |
| 76 | edgesABC = do |
| 77 | i <- [0 .. numRvrs - 1] |
| 78 | let tl = targetLoad i |
| 79 | let freeEdgeA = (source, rvrNode i 0, REdge undefined tl 0) |
| 80 | let nonfreeEdgesA = do |
| 81 | l <- [tl .. tl + (loadTolerance cfg) - 1] |
| 82 | let costA = marginalLoadCost cfg ((numAsWt (l - tl) + 1/2) / numAsWt (loadTolerance cfg)) |
| 83 | [(source, rvrNode i 0, REdge undefined 1 costA)] |
| 84 | let edgesBC = do |
| 85 | l <- [0 .. tl + (loadTolerance cfg) - 1] |
| 86 | let costB = marginalBoringCost cfg ((numAsWt l + 1/2) / numAsWt tl) |
| 87 | let edgeB = (rvrNode i 0, rvrNode i 1, REdge undefined 1 costB) |
| 88 | let costC = marginalVeryBoringCost cfg ((numAsWt l + 1/2) / numAsWt tl) |
| 89 | let edgeC = (rvrNode i 1, rvrNode i 2, REdge undefined 1 costC) |
| 90 | [edgeB, edgeC] |
| 91 | [freeEdgeA] ++ nonfreeEdgesA ++ edgesBC |
| 92 | edgesD = do |
| 93 | i <- [0 .. numRvrs - 1] |
| 94 | j <- [0 .. numProps - 1] |
| 95 | let pref = prefA ! (i, j) |
| 96 | -- We must generate an edge even if there is a conflict |
| 97 | -- of interest; otherwise we'll fail to read its flow |
| 98 | -- value in doMatching. |
| 99 | [(rvrNode i (prefBoringness cfg pref), |
| 100 | propNode j (prefExpertness cfg pref), |
| 101 | REdge (edIdx (i, j)) |
| 102 | (if prefIsConflict cfg pref then 0 else 1) |
| 103 | (assignmentCost cfg pref))] |
| 104 | edgesEFGH = do |
| 105 | j <- [0 .. numProps - 1] |
| 106 | let edgeE = (propNode j 2, propNode j 0, REdge undefined 1 (-(expertBonus cfg))) |
| 107 | let edgeF = (propNode j 2, propNode j 1, REdge undefined (reviewsEachProposal cfg) 0) |
| 108 | let edgeGFirst = (propNode j 1, propNode j 0, REdge undefined 1 (-(knowledgeableBonus cfg))) |
| 109 | let edgeGRest = (propNode j 1, propNode j 0, REdge undefined (reviewsEachProposal cfg - 1) 0) |
| 110 | let edgeH = (propNode j 0, sink, REdge undefined (reviewsEachProposal cfg) 0) |
| 111 | [edgeE, edgeF, edgeGFirst, edgeGRest, edgeH] |
| 112 | theNodes = [(x, ()) | x <- [0 .. numNodes - 1]] |
| 113 | -- Index the non-D edges |
| 114 | unindexedEdges = edgesABC ++ edgesEFGH |
| 115 | (imax, reindexedEdges) = indexEdges (numRvrs*numProps) unindexedEdges |
| 116 | theEdges = edgesD ++ reindexedEdges |
| 117 | in |
| 118 | ReductionResult (mkGraph theNodes theEdges) source sink (0, imax-1) edIdx |
| 119 | |
| 120 | -- Returns a list of reviews as ordered pairs (reviewer#, proposal#). |
| 121 | doMatching :: PMConfig -> PMInstance -> PMatching |
| 122 | doMatching cfg inst@(PMInstance numRvrs numProps _ _) = |
| 123 | let ReductionResult graph source sink idxBounds edIdx = doReduction cfg inst in |
| 124 | let flowArray = minCostFlow cfg idxBounds reIdx reCap reCost graph (source, sink) in |
| 125 | let pairs = do |
| 126 | i <- [0 .. numRvrs - 1] |
| 127 | j <- [0 .. numProps - 1] |
| 128 | if flowArray ! edIdx (i, j) == 1 |
| 129 | then [(i, j)] |
| 130 | else [] |
| 131 | in |
| 132 | sort pairs -- for prettiness |