1 module ProposalMatcher where
2 import Data.Array.IArray
3 import Data.Graph.Inductive.Graph
4 import Data.Graph.Inductive.Tree
11 prefBoringness cfg p = if prefIsVeryBoring cfg p then 2
12 else if prefIsBoring cfg p then 1 else 0
13 expExpertness cfg x = if expIsExpert cfg x then 2
14 else if expIsKnowledgeable cfg x then 1 else 0
22 instance Show REdge where
23 show (REdge idx cap cost) = "#" ++ (show idx) ++ ": "
24 ++ (show cap) ++ " @ " ++ (show cost)
26 data ReductionResult = ReductionResult {
27 rrGraph :: Gr () REdge,
30 rrEIdxBounds :: (Int, Int),
31 rrEDIdx :: (Int, Int) -> Int
34 -- Hack: show as much of the reduction result as we easily can
35 data RR1 = RR1 (Gr () REdge) Node Node (Int, Int) deriving Show
36 instance Show ReductionResult where
37 show (ReductionResult g so si eib _) = show (RR1 g so si eib)
39 indexEdges :: Int -> [(Int, Int, REdge)] -> (Int, [(Int, Int, REdge)])
40 indexEdges i [] = (i, [])
41 indexEdges i ((v1, v2, re):es) =
42 let (imax, ies) = indexEdges (i+1) es in
43 (imax, (v1, v2, re{ reIdx = i }) : ies)
45 implies :: Bool -> Bool -> Bool
46 x `implies` y = (not x) || y
48 doReduction :: PMConfig -> PMInstance -> ReductionResult
49 doReduction cfg (PMInstance numRvrs numProps rloadA prefA expA) =
51 -- Need to figure out who is PC/ERC
52 isPC = (funcArray (0, numRvrs-1) (\i -> (rloadA ! i) == 1)) :: Array Int Bool
53 isPCPaper = (funcArray (0, numProps-1) (\j -> all (\i -> (isPC ! i) `implies` (prefIsConflict cfg $ (prefA ! (i, j)))) [0 .. numRvrs - 1])) :: Array Int Bool
56 rvrNode i boringness = 2 + 3*i + boringness
57 -- We will waste a lot of nodes. Who cares, no one will visit them.
58 propNode j k = 2 + 3*numRvrs + 7*j + k
59 numNodes = 2 + 3*numRvrs + 7*numProps
60 edIdx (i, j) = i*numProps + j
63 totalReviews = (reviewsEachProposal cfg) * numProps
64 totalRelativeLoad = foldl (+) 0 (map (rloadA !) [0 .. numRvrs - 1])
65 -- floor goes best with loadTolerance 2
66 targetLoad i = floor (widenInteger totalReviews * (rloadA ! i) / totalRelativeLoad) - 1
67 -- A...H refer to idea book p.429
69 i <- [0 .. numRvrs - 1]
71 let freeEdgeA = (source, rvrNode i 0, REdge undefined tl 0)
72 let nonfreeEdgesA = do
73 l <- [tl .. tl + (loadTolerance cfg) - 1]
74 let costA = marginalLoadCost cfg ((widenInteger (l - tl) + 1/2) / widenInteger (loadTolerance cfg))
75 return (source, rvrNode i 0, REdge undefined 1 costA)
77 l <- [0 .. tl + (loadTolerance cfg) - 1]
78 let costB = marginalBoringCost cfg ((widenInteger l + 1/2) / widenInteger tl)
79 let edgeB = (rvrNode i 0, rvrNode i 1, REdge undefined 1 costB)
80 let costC = marginalVeryBoringCost cfg ((widenInteger l + 1/2) / widenInteger tl)
81 let edgeC = (rvrNode i 1, rvrNode i 2, REdge undefined 1 costC)
83 [freeEdgeA] ++ nonfreeEdgesA ++ edgesBC
85 i <- [0 .. numRvrs - 1]
86 j <- [0 .. numProps - 1]
87 let pref = prefA ! (i, j)
88 let xp = expA ! (i, j)
89 -- We must generate an edge even if there is a conflict
90 -- of interest; otherwise we'll fail to read its flow
91 -- value in doMatching.
92 let xp_ = expExpertness cfg xp
94 then xp_ + 3 -- Can assume it is a PC paper, otherwise it would conflict anyway.
96 [(rvrNode i (prefBoringness cfg pref),
99 (if prefIsConflict cfg pref then 0 else 1)
100 (assignmentCost cfg pref))]
102 j <- [0 .. numProps - 1]
103 -- This is now different...
105 then do -- Mostly traditional.
107 let edgeFFirst = (propNode j 2, propNode j 1, REdge undefined 1 (-(expertBonus cfg)))
108 let edgeFRest = (propNode j 2, propNode j 1, REdge undefined (reviewsEachProposal cfg - 1) 0)
109 -- Second kowledgeable bonus
110 let edgeGFirst = (propNode j 1, propNode j 0, REdge undefined 1 (-(knowledgeableBonus cfg)))
111 let edgeGRest = (propNode j 1, propNode j 0, REdge undefined (reviewsEachProposal cfg - 2) 0)
112 -- Require one knowledgeable
113 let edgeH1 = (propNode j 1, sink, REdge undefined 1 0)
114 let edgeH = (propNode j 0, sink, REdge undefined (reviewsEachProposal cfg - 1) 0)
115 [edgeFFirst, edgeFRest, edgeGFirst, edgeGRest, edgeH1, edgeH]
116 else do -- New gadget; man, a lot of edges
117 -- Structure to distribute knowledgeable PC members
118 let edgesP = [(propNode j k, propNode j 6, REdge undefined (reviewsEachProposal cfg - 1) 0) | k <- [4 .. 5]]
119 let edgesR = [(propNode j k, propNode j (k - 3), REdge undefined 1 0) | k <- [4 .. 5]]
120 -- "Designated knowledgeable" with expert bonus
121 let edgeF = (propNode j 2, propNode j 1, REdge undefined 1 (-(expertBonus cfg)))
122 let edgeH1 = (propNode j 1, sink, REdge undefined 1 0)
123 -- "Designated PC" with knowledgeable bonus
124 let edgeGFirst = (propNode j 6, propNode j 3, REdge undefined 1 (-(knowledgeableBonus cfg)))
125 let edgeGRest = (propNode j 6, propNode j 3, REdge undefined (reviewsEachProposal cfg - 2) 0)
126 let edgeH = (propNode j 3, sink, REdge undefined (reviewsEachProposal cfg - 1) 0)
127 edgesP ++ edgesR ++ [edgeF, edgeH1, edgeGFirst, edgeGRest, edgeH]
128 theNodes = [(x, ()) | x <- [0 .. numNodes - 1]]
129 -- Index the non-D edges
130 unindexedEdges = edgesABC ++ edgesEFGH
131 (imax, reindexedEdges) = indexEdges (numRvrs*numProps) unindexedEdges
132 theEdges = edgesD ++ reindexedEdges
134 ReductionResult (mkGraph theNodes theEdges) source sink (0, imax-1) edIdx
136 -- Returns a list of reviews as ordered pairs (reviewer#, proposal#).
137 doMatching :: PMConfig -> PMInstance -> PMatching
138 doMatching cfg inst@(PMInstance numRvrs numProps _ _ _) =
139 let ReductionResult graph source sink idxBounds edIdx = doReduction cfg inst in
140 let flowArray = minCostFlow cfg idxBounds reIdx reCap reCost graph (source, sink) in
142 i <- [0 .. numRvrs - 1]
143 j <- [0 .. numProps - 1]
144 if flowArray ! edIdx (i, j) == 1
148 PMatching (sort pairs) -- for prettiness