Commit | Line | Data |
---|---|---|
d7d9561e MM |
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 |