program/ProposalMatcher.hs

   1 module ProposalMatcher where
   2 import Data.Array.IArray
   3 import Data.Graph.Inductive.Graph
   4 import Data.Graph.Inductive.Tree
   5 import Data.List
   6 import Data.Either
   7
   8 import ArrayStuff
   9 import MonadStuff
  10 import PMInstance
  11 import PMConfig
  12
  13 prefBoringness cfg p = if prefIsVeryBoring cfg p then 2
  14         else if prefIsBoring cfg p then 1 else 0
  15 expExpertness cfg x = if expIsExpert cfg x then 2
  16         else if expIsKnowledgeable cfg x then 1 else 0
  17
  18 data REdge = REdge {
  19         reIdx  :: Int,
  20         reCap  :: Int,
  21         reCost :: Wt
  22 }
  23
  24 instance Show REdge where
  25         show (REdge idx cap cost) = "#" ++ (show idx) ++ ": "
  26                 ++ (show cap) ++ " @ " ++ (show cost)
  27
  28 data ReductionResult = ReductionResult {
  29         rrGraph      :: Gr () REdge,
  30         rrSource     :: Node,
  31         rrSink       :: Node,
  32         rrEIdxBounds :: (Int, Int),
  33         rrEDIdx      :: (Int, Int) -> Int
  34 }
  35
  36 -- Hack: show as much of the reduction result as we easily can
  37 data RR1 = RR1 (Gr () REdge) Node Node (Int, Int) deriving Show
  38 instance Show ReductionResult where
  39         show (ReductionResult g so si eib _) = show (RR1 g so si eib)
  40
  41 indexEdges :: Int -> [(Int, Int, REdge)] -> (Int, [(Int, Int, REdge)])
  42 indexEdges i [] = (i, [])
  43 indexEdges i ((v1, v2, re):es) =
  44         let (imax, ies) = indexEdges (i+1) es in
  45         (imax, (v1, v2, re{ reIdx = i }) : ies)
  46
  47 implies :: Bool -> Bool -> Bool
  48 x `implies` y = (not x) || y
  49
  50 doReduction :: PMConfig -> PMInstance -> ReductionResult
  51 doReduction cfg (PMInstance numRvrs numProps rloadA prefA expA fixA pnrA) =
  52         let
  53                 -- Need to figure out who is PC/ERC
  54                 isPC = (funcArray (0, numRvrs-1) (\i -> (rloadA ! i) == 1)) :: Array Int Bool
  55                 isPCPaper = (funcArray (0, numProps-1) (\j -> all (\i -> (isPC ! i) `implies` (prefIsConflict cfg $ (prefA ! (i, j)))) [0 .. numRvrs - 1])) :: Array Int Bool
  56                 source = 0
  57                 sink = 1
  58                 rvrNode i boringness = 2 + 3*i + boringness
  59                 -- We will waste a lot of nodes.  Who cares, no one will visit them.
  60                 propNode j k = 2 + 3*numRvrs + 7*j + k
  61                 numNodes = 2 + 3*numRvrs + 7*numProps
  62                 edIdx (i, j) = i*numProps + j
  63                 in
  64         let
  65                 totalReviews = sum $ elems pnrA    -- (reviewsEachProposal cfg) * numProps
  66                 totalRelativeLoad = foldl (+) 0 (map (rloadA !) [0 .. numRvrs - 1])
  67                 -- floor goes best with loadTolerance 2
  68                 targetLoad i = floor (widenInteger totalReviews * (rloadA ! i) / totalRelativeLoad) - 1
  69                 -- Edge groups A through H are indicated in the figure in the paper.
  70                 edgesABC = do
  71                         i <- [0 .. numRvrs - 1]
  72                         let tl = targetLoad i
  73                         let lt = if isPC ! i then loadTolerance cfg else ercLoadTolerance cfg
  74                         let freeEdgeA = (source, rvrNode i 0, REdge undefined tl 0)
  75                         let nonfreeEdgesA = do
  76                                 l <- [tl .. tl + lt - 1]
  77                                 let costA = marginalLoadCost cfg ((widenInteger (l - tl) + 1/2) / widenInteger lt)
  78                                 return (source, rvrNode i 0, REdge undefined 1 costA)
  79                         let edgesBC = do
  80                                 l <- [0 .. tl + lt - 1]
  81                                 let costB = marginalBoringCost cfg ((widenInteger l + 1/2) / widenInteger tl)
  82                                 let edgeB = (rvrNode i 0, rvrNode i 1, REdge undefined 1 costB)
  83                                 let costC = marginalVeryBoringCost cfg ((widenInteger l + 1/2) / widenInteger tl)
  84                                 let edgeC = (rvrNode i 1, rvrNode i 2, REdge undefined 1 costC)
  85                                 [edgeB, edgeC]
  86                         [freeEdgeA] ++ nonfreeEdgesA ++ edgesBC
  87                 edgesDFix = do
  88                         i <- [0 .. numRvrs - 1]
  89                         j <- [0 .. numProps - 1]
  90                         let pref = prefA ! (i, j)
  91                         let xp = expA ! (i, j)
  92                         -- We must generate an edge even if there is a conflict
  93                         -- of interest; otherwise we'll fail to read its flow
  94                         -- value in doMatching.
  95                         let xp_ = expExpertness cfg xp
  96                         let pn = propNode j $ if (isPC ! i)
  97                                 then xp_ + 3  -- Can assume it is a PC paper, otherwise it would conflict anyway.
  98                                 else xp_
  99                         let rn = rvrNode i (prefBoringness cfg pref)
 100                         if fixA ! (i, j)
 101                                 -- Max flow will emulate one unit of flow through the edge,
 102                                 -- at a cost of increasing the total flow value by 1.
 103                                 then [Right (rn, sink, REdge undefined 1 0),
 104                                         Right (source, pn, REdge undefined 1 0)]
 105                                 else [Left (rn, pn, REdge (edIdx (i, j))
 106                                         (if prefIsConflict cfg pref then 0 else 1)
 107                                         (assignmentCost cfg pref))]
 108                 edgesD = lefts edgesDFix
 109                 edgesFix = rights edgesDFix
 110                 edgesEFGH = do
 111                         j <- [0 .. numProps - 1]
 112                         -- This is now different...
 113                         let numReviews = pnrA ! j
 114                         if isPCPaper ! j
 115                                 then do -- Mostly traditional.
 116                                         -- Expert bonus
 117                                         let edgeFFirst = (propNode j 2, propNode j 1, REdge undefined 1 (-(expertBonus cfg)))
 118                                         let edgeFRest = (propNode j 2, propNode j 1, REdge undefined (numReviews - 1) 0)
 119                                         -- Second kowledgeable bonus
 120                                         let edgeGFirst = (propNode j 1, propNode j 0, REdge undefined 1 (-(knowledgeableBonus cfg)))
 121                                         let edgeGRest = (propNode j 1, propNode j 0, REdge undefined (numReviews - 2) 0)
 122                                         -- Require one knowledgeable
 123                                         let edgeH1 = (propNode j 1, sink, REdge undefined 1 0)
 124                                         let edgeH = (propNode j 0, sink, REdge undefined (numReviews - 1) 0)
 125                                         [edgeFFirst, edgeFRest, edgeGFirst, edgeGRest, edgeH1, edgeH]
 126                                 else do -- New gadget; man, a lot of edges
 127                                         let numPCReviews = pcReviewsEachProposal cfg
 128                                         if numReviews < numPCReviews then fail "numReviews for paper < numPCReviews" else nop
 129                                         -- Structure to distribute knowledgeable PC members
 130                                         let edgesP = [(propNode j k, propNode j 6, REdge undefined numPCReviews 0) | k <- [4 .. 5]]
 131                                         let edgesR = [(propNode j k, propNode j (k - 3), REdge undefined (numReviews - numPCReviews) 0) | k <- [4 .. 5]]
 132                                         -- "Designated knowledgeable" with expert bonus
 133                                         let edgeF = (propNode j 2, propNode j 1, REdge undefined (numReviews - numPCReviews) (-(expertBonus cfg)))
 134                                         let edgeH1 = (propNode j 1, sink, REdge undefined (numReviews - numPCReviews) 0)
 135                                         -- "Designated PC" with knowledgeable bonus
 136                                         let edgeGFirst = (propNode j 6, propNode j 3, REdge undefined 1 (-(knowledgeableBonus cfg)))
 137                                         let edgeGRest = (propNode j 6, propNode j 3, REdge undefined (numPCReviews - 1) 0)
 138                                         let edgeH = (propNode j 3, sink, REdge undefined (numPCReviews) 0)
 139                                         edgesP ++ edgesR ++ [edgeF, edgeH1, edgeGFirst, edgeGRest, edgeH]
 140                 theNodes = [(x, ()) | x <- [0 .. numNodes - 1]]
 141                 -- Index the non-D edges
 142                 unindexedEdges = edgesABC ++ edgesFix ++ edgesEFGH
 143                 (imax, reindexedEdges) = indexEdges (numRvrs*numProps) unindexedEdges
 144                 theEdges = edgesD ++ reindexedEdges
 145                 in
 146         ReductionResult (mkGraph theNodes theEdges) source sink (0, imax-1) edIdx
 147
 148 -- Returns a list of reviews as ordered pairs (reviewer#, proposal#).
 149 doMatching :: PMConfig -> PMInstance -> PMatching
 150 doMatching cfg inst@(PMInstance numRvrs numProps _ _ _ fixA _) =
 151         let ReductionResult graph source sink idxBounds edIdx = doReduction cfg inst in
 152         let flowArray = minCostFlow cfg idxBounds reIdx reCap reCost graph (source, sink) in
 153         let pairs = do
 154                 i <- [0 .. numRvrs - 1]
 155                 j <- [0 .. numProps - 1]
 156                 if fixA ! (i, j) || flowArray ! edIdx (i, j) == 1
 157                         then [(i, j)]
 158                         else []
 159                 in
 160         PMatching (sort pairs) -- for prettiness