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 | ||
05a6f0ed | 7 | import PMInstance |
bc14b3b3 | 8 | import PMConfig |
8c5ee850 MM |
9 | |
10 | prefBoringness cfg p = if prefIsVeryBoring cfg p then 2 | |
11 | else if prefIsBoring cfg p then 1 else 0 | |
12 | prefExpertness cfg p = if prefIsExpert cfg p then 2 | |
13 | else if prefIsKnowledgeable cfg p then 1 else 0 | |
2e7d5426 | 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 | ||
05a6f0ed MM |
44 | doReduction :: PMConfig -> PMInstance -> ReductionResult |
45 | doReduction cfg (PMInstance 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 | |
8c5ee850 | 55 | totalReviews = (reviewsEachProposal cfg) * numProps |
967c39ef | 56 | totalRelativeLoad = foldl (+) 0 (map (rloadA !) [0 .. numRvrs - 1]) |
96fe6497 | 57 | targetLoad i = ceiling (widenInteger 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 | |
8c5ee850 | 64 | l <- [tl .. tl + (loadTolerance cfg) - 1] |
96fe6497 | 65 | let costA = marginalLoadCost cfg ((widenInteger (l - tl) + 1/2) / widenInteger (loadTolerance cfg)) |
5a07db44 MM |
66 | [(source, rvrNode i 0, REdge undefined 1 costA)] |
67 | let edgesBC = do | |
8c5ee850 | 68 | l <- [0 .. tl + (loadTolerance cfg) - 1] |
96fe6497 | 69 | let costB = marginalBoringCost cfg ((widenInteger l + 1/2) / widenInteger tl) |
5a07db44 | 70 | let edgeB = (rvrNode i 0, rvrNode i 1, REdge undefined 1 costB) |
96fe6497 | 71 | let costC = marginalVeryBoringCost cfg ((widenInteger l + 1/2) / widenInteger tl) |
5a07db44 MM |
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. | |
8c5ee850 MM |
82 | [(rvrNode i (prefBoringness cfg pref), |
83 | propNode j (prefExpertness cfg pref), | |
fd0d2377 | 84 | REdge (edIdx (i, j)) |
8c5ee850 MM |
85 | (if prefIsConflict cfg pref then 0 else 1) |
86 | (assignmentCost cfg pref))] | |
5a07db44 | 87 | edgesEFGH = do |
d7d9561e | 88 | j <- [0 .. numProps - 1] |
8c5ee850 MM |
89 | let edgeE = (propNode j 2, propNode j 0, REdge undefined 1 (-(expertBonus cfg))) |
90 | let edgeF = (propNode j 2, propNode j 1, REdge undefined (reviewsEachProposal cfg) 0) | |
91 | let edgeGFirst = (propNode j 1, propNode j 0, REdge undefined 1 (-(knowledgeableBonus cfg))) | |
92 | let edgeGRest = (propNode j 1, propNode j 0, REdge undefined (reviewsEachProposal cfg - 1) 0) | |
93 | let edgeH = (propNode j 0, sink, REdge undefined (reviewsEachProposal cfg) 0) | |
5a07db44 | 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 | 102 | |
d7d9561e | 103 | -- Returns a list of reviews as ordered pairs (reviewer#, proposal#). |
05a6f0ed MM |
104 | doMatching :: PMConfig -> PMInstance -> PMatching |
105 | doMatching cfg inst@(PMInstance numRvrs numProps _ _) = | |
8c5ee850 MM |
106 | let ReductionResult graph source sink idxBounds edIdx = doReduction cfg inst in |
107 | let flowArray = minCostFlow cfg idxBounds reIdx reCap reCost graph (source, sink) in | |
d7d9561e MM |
108 | let pairs = do |
109 | i <- [0 .. numRvrs - 1] | |
5a07db44 MM |
110 | j <- [0 .. numProps - 1] |
111 | if flowArray ! edIdx (i, j) == 1 | |
112 | then [(i, j)] | |
2e7d5426 MM |
113 | else [] |
114 | in | |
d7d9561e | 115 | sort pairs -- for prettiness |