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