| 1 | module ProposalMatcher where |
| 2 | import UnitMinCostFlow |
| 3 | import Data.Array.IArray |
| 4 | import Data.Graph.Inductive.Graph |
| 5 | import Data.Graph.Inductive.Tree |
| 6 | import Data.List |
| 7 | |
| 8 | import Instance |
| 9 | import ProposalMatcherConfig |
| 10 | |
| 11 | prefBoringness p = if prefIsVeryBoring p then 2 |
| 12 | else if prefIsBoring p then 1 else 0 |
| 13 | prefExpertness p = if prefIsExpert p then 2 |
| 14 | else if prefIsKnowledgeable p then 1 else 0 |
| 15 | |
| 16 | doReduction :: Instance -> Gr () Wt |
| 17 | doReduction (Instance numRvrs numProps rloadA prefA) = |
| 18 | let |
| 19 | source = 0 |
| 20 | sink = 1 |
| 21 | rvrNode i boringness = 2 + 3*i + boringness |
| 22 | propNode j expertness = 2 + 3*numRvrs + 3*j + expertness |
| 23 | numNodes = 2 + 3*numRvrs + 3*numProps |
| 24 | in |
| 25 | let |
| 26 | totalReviews = reviewsEachProposal * numProps |
| 27 | totalRelativeLoad = foldl (+) 0 (map (rloadA !) [0 .. numRvrs - 1]) |
| 28 | targetLoad i = ceiling (numAsWt totalReviews * (rloadA ! i) / totalRelativeLoad) |
| 29 | -- A...H refer to idea book p.429 |
| 30 | edgesABC = do |
| 31 | i <- [0 .. numRvrs - 1] |
| 32 | let tl = targetLoad i |
| 33 | l <- [0 .. tl + loadTolerance - 1] |
| 34 | let costA = if l < tl |
| 35 | then 0 |
| 36 | else marginalLoadCost ((numAsWt (l - tl) + 1/2) / numAsWt loadTolerance) |
| 37 | let edgeA = (source, rvrNode i 0, costA) |
| 38 | let costB = marginalBoringCost ((numAsWt l + 1/2) / numAsWt tl) |
| 39 | let edgeB = (rvrNode i 0, rvrNode i 1, costB) |
| 40 | let costC = marginalVeryBoringCost ((numAsWt l + 1/2) / numAsWt tl) |
| 41 | let edgeC = (rvrNode i 1, rvrNode i 2, costC) |
| 42 | [edgeA, edgeB, edgeC] |
| 43 | edgesD = do |
| 44 | i <- [0 .. numRvrs - 1] |
| 45 | j <- [0 .. numProps - 1] |
| 46 | let pref = prefA ! (i, j) |
| 47 | if prefIsConflict pref |
| 48 | then [] |
| 49 | else [(rvrNode i (prefBoringness pref), |
| 50 | propNode j (prefExpertness pref), |
| 51 | assignmentCost pref)] |
| 52 | edgesE = do |
| 53 | j <- [0 .. numProps - 1] |
| 54 | [(propNode j 2, propNode j 0, -expertBonus)] |
| 55 | edgesFGH = do |
| 56 | j <- [0 .. numProps - 1] |
| 57 | l <- [0 .. reviewsEachProposal - 1] |
| 58 | let edgeF = (propNode j 2, propNode j 1, 0) |
| 59 | let edgeG = (propNode j 1, propNode j 0, |
| 60 | if l == 0 then -knowledgeableBonus else 0) |
| 61 | let edgeH = (propNode j 0, sink, 0) |
| 62 | [edgeF, edgeG, edgeH] |
| 63 | theNodes = [(x, ()) | x <- [0 .. numNodes - 1]] |
| 64 | theEdges = edgesABC ++ edgesD ++ edgesE ++ edgesFGH |
| 65 | in |
| 66 | mkGraph theNodes theEdges |
| 67 | |
| 68 | todo = undefined |
| 69 | -- Returns a list of reviews as ordered pairs (reviewer#, proposal#). |
| 70 | doMatching :: Instance -> [(Int, Int)] |
| 71 | doMatching inst@(Instance numRvrs numProps _ _) = |
| 72 | -- Copied from doReduction. There should be a better way to get these here. |
| 73 | let |
| 74 | source = 0 |
| 75 | sink = 1 |
| 76 | rvrNode i boringness = 2 + 3*i + boringness |
| 77 | propNode j expertness = 2 + 3*numRvrs + 3*j + expertness |
| 78 | firstPropNode = propNode 0 0 |
| 79 | idPropNode n = (n - (2 + 3*numRvrs)) `div` 3 |
| 80 | numNodes = 2 + 3*numRvrs + 3*numProps |
| 81 | in |
| 82 | let graph1 = doReduction inst in |
| 83 | let flow1 = flowDiff graph1 (snd (umcf source sink graph1)) in |
| 84 | let pairs = do |
| 85 | i <- [0 .. numRvrs - 1] |
| 86 | boringness <- [0, 1, 2] |
| 87 | n <- suc flow1 (rvrNode i boringness) |
| 88 | if n >= firstPropNode |
| 89 | then [(i, idPropNode n)] |
| 90 | else [] |
| 91 | in |
| 92 | sort pairs -- for prettiness |