| 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 | import Data.Either |
| 7 | |
| 8 | import ArrayStuff |
| 9 | import MonadStuff |
| 10 | import PMInstance |
| 11 | import PMConfig |
| 12 | |
| 13 | prefBoringness cfg p = if prefIsVeryBoring cfg p then 2 |
| 14 | else if prefIsBoring cfg p then 1 else 0 |
| 15 | expExpertness cfg x = if expIsExpert cfg x then 2 |
| 16 | else if expIsKnowledgeable cfg x then 1 else 0 |
| 17 | |
| 18 | data REdge = REdge { |
| 19 | reIdx :: Int, |
| 20 | reCap :: Int, |
| 21 | reCost :: Wt |
| 22 | } |
| 23 | |
| 24 | instance Show REdge where |
| 25 | show (REdge idx cap cost) = "#" ++ (show idx) ++ ": " |
| 26 | ++ (show cap) ++ " @ " ++ (show cost) |
| 27 | |
| 28 | data ReductionResult = ReductionResult { |
| 29 | rrGraph :: Gr () REdge, |
| 30 | rrSource :: Node, |
| 31 | rrSink :: Node, |
| 32 | rrEIdxBounds :: (Int, Int), |
| 33 | rrEDIdx :: (Int, Int) -> Int |
| 34 | } |
| 35 | |
| 36 | -- Hack: show as much of the reduction result as we easily can |
| 37 | data RR1 = RR1 (Gr () REdge) Node Node (Int, Int) deriving Show |
| 38 | instance Show ReductionResult where |
| 39 | show (ReductionResult g so si eib _) = show (RR1 g so si eib) |
| 40 | |
| 41 | indexEdges :: Int -> [(Int, Int, REdge)] -> (Int, [(Int, Int, REdge)]) |
| 42 | indexEdges i [] = (i, []) |
| 43 | indexEdges i ((v1, v2, re):es) = |
| 44 | let (imax, ies) = indexEdges (i+1) es in |
| 45 | (imax, (v1, v2, re{ reIdx = i }) : ies) |
| 46 | |
| 47 | implies :: Bool -> Bool -> Bool |
| 48 | x `implies` y = (not x) || y |
| 49 | |
| 50 | doReduction :: PMConfig -> PMInstance -> ReductionResult |
| 51 | doReduction cfg (PMInstance numRvrs numProps rloadA prefA expA fixA pnrA) = |
| 52 | let |
| 53 | -- Need to figure out who is PC/ERC |
| 54 | isPC = (funcArray (0, numRvrs-1) (\i -> (rloadA ! i) == 1)) :: Array Int Bool |
| 55 | isPCPaper = (funcArray (0, numProps-1) (\j -> all (\i -> (isPC ! i) `implies` (prefIsConflict cfg $ (prefA ! (i, j)))) [0 .. numRvrs - 1])) :: Array Int Bool |
| 56 | source = 0 |
| 57 | sink = 1 |
| 58 | rvrNode i boringness = 2 + 3*i + boringness |
| 59 | -- We will waste a lot of nodes. Who cares, no one will visit them. |
| 60 | propNode j k = 2 + 3*numRvrs + 7*j + k |
| 61 | numNodes = 2 + 3*numRvrs + 7*numProps |
| 62 | edIdx (i, j) = i*numProps + j |
| 63 | in |
| 64 | let |
| 65 | totalReviews = sum $ elems pnrA -- (reviewsEachProposal cfg) * numProps |
| 66 | totalRelativeLoad = foldl (+) 0 (map (rloadA !) [0 .. numRvrs - 1]) |
| 67 | -- floor goes best with loadTolerance 2 |
| 68 | targetLoad i = floor (widenInteger totalReviews * (rloadA ! i) / totalRelativeLoad) - 1 |
| 69 | -- Edge groups A through H are indicated in the figure in the paper. |
| 70 | edgesABC = do |
| 71 | i <- [0 .. numRvrs - 1] |
| 72 | let tl = targetLoad i |
| 73 | let lt = if isPC ! i then loadTolerance cfg else ercLoadTolerance cfg |
| 74 | let freeEdgeA = (source, rvrNode i 0, REdge undefined tl 0) |
| 75 | let nonfreeEdgesA = do |
| 76 | l <- [tl .. tl + lt - 1] |
| 77 | let costA = marginalLoadCost cfg ((widenInteger (l - tl) + 1/2) / widenInteger lt) |
| 78 | return (source, rvrNode i 0, REdge undefined 1 costA) |
| 79 | let edgesBC = do |
| 80 | l <- [0 .. tl + lt - 1] |
| 81 | let costB = marginalBoringCost cfg ((widenInteger l + 1/2) / widenInteger tl) |
| 82 | let edgeB = (rvrNode i 0, rvrNode i 1, REdge undefined 1 costB) |
| 83 | let costC = marginalVeryBoringCost cfg ((widenInteger l + 1/2) / widenInteger tl) |
| 84 | let edgeC = (rvrNode i 1, rvrNode i 2, REdge undefined 1 costC) |
| 85 | [edgeB, edgeC] |
| 86 | [freeEdgeA] ++ nonfreeEdgesA ++ edgesBC |
| 87 | edgesDFix = do |
| 88 | i <- [0 .. numRvrs - 1] |
| 89 | j <- [0 .. numProps - 1] |
| 90 | let pref = prefA ! (i, j) |
| 91 | let xp = expA ! (i, j) |
| 92 | -- We must generate an edge even if there is a conflict |
| 93 | -- of interest; otherwise we'll fail to read its flow |
| 94 | -- value in doMatching. |
| 95 | let xp_ = expExpertness cfg xp |
| 96 | let pn = propNode j $ if (isPC ! i) |
| 97 | then xp_ + 3 -- Can assume it is a PC paper, otherwise it would conflict anyway. |
| 98 | else xp_ |
| 99 | let rn = rvrNode i (prefBoringness cfg pref) |
| 100 | if fixA ! (i, j) |
| 101 | -- Max flow will emulate one unit of flow through the edge, |
| 102 | -- at a cost of increasing the total flow value by 1. |
| 103 | then [Right (rn, sink, REdge undefined 1 0), |
| 104 | Right (source, pn, REdge undefined 1 0)] |
| 105 | else [Left (rn, pn, REdge (edIdx (i, j)) |
| 106 | (if prefIsConflict cfg pref then 0 else 1) |
| 107 | (assignmentCost cfg pref))] |
| 108 | edgesD = lefts edgesDFix |
| 109 | edgesFix = rights edgesDFix |
| 110 | edgesEFGH = do |
| 111 | j <- [0 .. numProps - 1] |
| 112 | -- This is now different... |
| 113 | let numReviews = pnrA ! j |
| 114 | if isPCPaper ! j |
| 115 | then do -- Mostly traditional. |
| 116 | -- Expert bonus |
| 117 | let edgeFFirst = (propNode j 2, propNode j 1, REdge undefined 1 (-(expertBonus cfg))) |
| 118 | let edgeFRest = (propNode j 2, propNode j 1, REdge undefined (numReviews - 1) 0) |
| 119 | -- Second kowledgeable bonus |
| 120 | let edgeGFirst = (propNode j 1, propNode j 0, REdge undefined 1 (-(knowledgeableBonus cfg))) |
| 121 | let edgeGRest = (propNode j 1, propNode j 0, REdge undefined (numReviews - 2) 0) |
| 122 | -- Require one knowledgeable |
| 123 | let edgeH1 = (propNode j 1, sink, REdge undefined 1 0) |
| 124 | let edgeH = (propNode j 0, sink, REdge undefined (numReviews - 1) 0) |
| 125 | [edgeFFirst, edgeFRest, edgeGFirst, edgeGRest, edgeH1, edgeH] |
| 126 | else do -- New gadget; man, a lot of edges |
| 127 | let numPCReviews = pcReviewsEachProposal cfg |
| 128 | if numReviews < numPCReviews then fail "numReviews for paper < numPCReviews" else nop |
| 129 | -- Structure to distribute knowledgeable PC members |
| 130 | let edgesP = [(propNode j k, propNode j 6, REdge undefined numPCReviews 0) | k <- [4 .. 5]] |
| 131 | let edgesR = [(propNode j k, propNode j (k - 3), REdge undefined (numReviews - numPCReviews) 0) | k <- [4 .. 5]] |
| 132 | -- "Designated knowledgeable" with expert bonus |
| 133 | let edgeF = (propNode j 2, propNode j 1, REdge undefined (numReviews - numPCReviews) (-(expertBonus cfg))) |
| 134 | let edgeH1 = (propNode j 1, sink, REdge undefined (numReviews - numPCReviews) 0) |
| 135 | -- "Designated PC" with knowledgeable bonus |
| 136 | let edgeGFirst = (propNode j 6, propNode j 3, REdge undefined 1 (-(knowledgeableBonus cfg))) |
| 137 | let edgeGRest = (propNode j 6, propNode j 3, REdge undefined (numPCReviews - 1) 0) |
| 138 | let edgeH = (propNode j 3, sink, REdge undefined (numPCReviews) 0) |
| 139 | edgesP ++ edgesR ++ [edgeF, edgeH1, edgeGFirst, edgeGRest, edgeH] |
| 140 | theNodes = [(x, ()) | x <- [0 .. numNodes - 1]] |
| 141 | -- Index the non-D edges |
| 142 | unindexedEdges = edgesABC ++ edgesFix ++ edgesEFGH |
| 143 | (imax, reindexedEdges) = indexEdges (numRvrs*numProps) unindexedEdges |
| 144 | theEdges = edgesD ++ reindexedEdges |
| 145 | in |
| 146 | ReductionResult (mkGraph theNodes theEdges) source sink (0, imax-1) edIdx |
| 147 | |
| 148 | -- Returns a list of reviews as ordered pairs (reviewer#, proposal#). |
| 149 | doMatching :: PMConfig -> PMInstance -> PMatching |
| 150 | doMatching cfg inst@(PMInstance numRvrs numProps _ _ _ fixA _) = |
| 151 | let ReductionResult graph source sink idxBounds edIdx = doReduction cfg inst in |
| 152 | let flowArray = minCostFlow cfg idxBounds reIdx reCap reCost graph (source, sink) in |
| 153 | let pairs = do |
| 154 | i <- [0 .. numRvrs - 1] |
| 155 | j <- [0 .. numProps - 1] |
| 156 | if fixA ! (i, j) || flowArray ! edIdx (i, j) == 1 |
| 157 | then [(i, j)] |
| 158 | else [] |
| 159 | in |
| 160 | PMatching (sort pairs) -- for prettiness |