| 1 | module ProposalMatch 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 ProposalMatchConfig |
| 9 | |
| 10 | data Real wt => Instance wt = Instance Int Int (Int -> Int -> wt) |
| 11 | |
| 12 | doReduction :: Real wt => Instance wt -> (Int -> Int) -> Gr () wt |
| 13 | doReduction (Instance numRvrs numProps prefF) expertCapF = |
| 14 | let |
| 15 | source = 0 |
| 16 | sink = 1 |
| 17 | rvrNode i = 2 + i |
| 18 | propNode j isExpert = 2 + numRvrs + 2*j + (if isExpert then 1 else 0) |
| 19 | numNodes = 2 + numRvrs + 2*numProps |
| 20 | theNodes = [(x, ()) | x <- [0 .. numNodes - 1]] |
| 21 | in |
| 22 | let |
| 23 | loadEdges = do |
| 24 | i <- [0 .. numRvrs - 1] |
| 25 | l <- [1 .. maxReviewerLoad] |
| 26 | return (source, rvrNode i, marginalLoadCost l) |
| 27 | prefEdges = do |
| 28 | i <- [0 .. numRvrs - 1] |
| 29 | j <- [0 .. numProps - 1] |
| 30 | let pref = prefF i j |
| 31 | if prefIsConflict pref |
| 32 | then fail "Conflict of interest" |
| 33 | else return (rvrNode i, propNode j (prefIsExpert pref), |
| 34 | prefToCost pref) |
| 35 | wantEdges = do |
| 36 | j <- [0 .. numProps - 1] |
| 37 | let wExpert = expertCapF j |
| 38 | -- Yuck, too many kinds of integers. |
| 39 | let wGeneral = fromInteger wantGeneralReviews + |
| 40 | fromInteger wantReviewsSubstForExpert * |
| 41 | (fromInteger wantExpertReviews - wExpert) |
| 42 | let expertEdges = replicate wExpert (propNode j True, sink, 0) |
| 43 | let rolloverEdges = replicate wGeneral (propNode j True, propNode j False, 0) |
| 44 | let generalEdges = replicate wGeneral (propNode j False, sink, 0) |
| 45 | expertEdges ++ rolloverEdges ++ generalEdges |
| 46 | theEdges = loadEdges ++ prefEdges ++ wantEdges |
| 47 | in |
| 48 | mkGraph theNodes theEdges |
| 49 | |
| 50 | todo = undefined |
| 51 | -- Returns a list of reviews as ordered pairs (reviewer#, proposal#). |
| 52 | doMatching :: Real wt => Instance wt -> [(Int, Int)] |
| 53 | doMatching inst@(Instance numRvrs numProps prefF) = |
| 54 | -- Copied from doReduction. There should be a better way to get these here. |
| 55 | let |
| 56 | source = 0 |
| 57 | sink = 1 |
| 58 | rvrNode i = 2 + i |
| 59 | propNode j isExpert = 2 + numRvrs + 2*j + (if isExpert then 1 else 0) |
| 60 | idPropNode n = (n - (2 + numRvrs)) `div` 2 |
| 61 | numNodes = 2 + numRvrs + 2*numProps |
| 62 | in |
| 63 | let graph1 = doReduction inst (const (fromInteger wantExpertReviews)) in |
| 64 | let flow1 = flowDiff graph1 (snd (umcf source sink graph1)) in |
| 65 | let expertCapF j = outdeg flow1 (propNode j True) in |
| 66 | let graph2 = doReduction inst expertCapF in |
| 67 | let flow2 = flowDiff graph2 (snd (umcf source sink graph2)) in |
| 68 | let pairs = do |
| 69 | i <- [0 .. numRvrs - 1] |
| 70 | map (\n -> (i, idPropNode n)) (suc flow2 (rvrNode i)) in |
| 71 | sort pairs -- for prettiness |