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