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
   7 import PMInstance
   8 import IMinCostFlow
   9
  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
  31
  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
  61 doReduction :: PMConfig -> PMInstance -> ReductionResult
  62 doReduction cfg (PMInstance numRvrs numProps rloadA prefA) =
  63         let
  64                 source = 0
  65                 sink = 1
  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
  69                 edIdx (i, j) = i*numProps + j
  70                 in
  71         let
  72                 totalReviews = (reviewsEachProposal cfg) * numProps
  73                 totalRelativeLoad = foldl (+) 0 (map (rloadA !) [0 .. numRvrs - 1])
  74                 targetLoad i = ceiling (numAsWt totalReviews * (rloadA ! i) / totalRelativeLoad)
  75                 -- A...H refer to idea book p.429
  76                 edgesABC = do
  77                         i <- [0 .. numRvrs - 1]
  78                         let tl = targetLoad i
  79                         let freeEdgeA = (source, rvrNode i 0, REdge undefined tl 0)
  80                         let nonfreeEdgesA = do
  81                                 l <- [tl .. tl + (loadTolerance cfg) - 1]
  82                                 let costA = marginalLoadCost cfg ((numAsWt (l - tl) + 1/2) / numAsWt (loadTolerance cfg))
  83                                 [(source, rvrNode i 0, REdge undefined 1 costA)]
  84                         let edgesBC = do
  85                                 l <- [0 .. tl + (loadTolerance cfg) - 1]
  86                                 let costB = marginalBoringCost cfg ((numAsWt l + 1/2) / numAsWt tl)
  87                                 let edgeB = (rvrNode i 0, rvrNode i 1, REdge undefined 1 costB)
  88                                 let costC = marginalVeryBoringCost cfg ((numAsWt l + 1/2) / numAsWt tl)
  89                                 let edgeC = (rvrNode i 1, rvrNode i 2, REdge undefined 1 costC)
  90                                 [edgeB, edgeC]
  91                         [freeEdgeA] ++ nonfreeEdgesA ++ edgesBC
  92                 edgesD = do
  93                         i <- [0 .. numRvrs - 1]
  94                         j <- [0 .. numProps - 1]
  95                         let pref = prefA ! (i, j)
  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.
  99                         [(rvrNode i (prefBoringness cfg pref),
 100                                 propNode j (prefExpertness cfg pref),
 101                                 REdge (edIdx (i, j))
 102                                         (if prefIsConflict cfg pref then 0 else 1)
 103                                         (assignmentCost cfg pref))]
 104                 edgesEFGH = do
 105                         j <- [0 .. numProps - 1]
 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)
 111                         [edgeE, edgeF, edgeGFirst, edgeGRest, edgeH]
 112                 theNodes = [(x, ()) | x <- [0 .. numNodes - 1]]
 113                 -- Index the non-D edges
 114                 unindexedEdges = edgesABC ++ edgesEFGH
 115                 (imax, reindexedEdges) = indexEdges (numRvrs*numProps) unindexedEdges
 116                 theEdges = edgesD ++ reindexedEdges
 117                 in
 118         ReductionResult (mkGraph theNodes theEdges) source sink (0, imax-1) edIdx
 119
 120 -- Returns a list of reviews as ordered pairs (reviewer#, proposal#).
 121 doMatching :: PMConfig -> PMInstance -> PMatching
 122 doMatching cfg inst@(PMInstance numRvrs numProps _ _) =
 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
 125         let pairs = do
 126                 i <- [0 .. numRvrs - 1]
 127                 j <- [0 .. numProps - 1]
 128                 if flowArray ! edIdx (i, j) == 1
 129                         then [(i, j)]
 130                         else []
 131                 in
 132         sort pairs -- for prettiness