program/ProposalMatch.hs

   1 module ProposalMatch where
   2 import UnitMinCostFlow
   3 import Data.Array.IArray
   4 import Data.Graph.Inductive.Graph
   5 import Data.Graph.Inductive.Tree
   6 import Data.List
   7
   8 import ProposalMatchConfig
   9
  10 data Instance = Instance
  11         Int                -- numReviewers
  12         Int                -- numProposals
  13         (Int -> Wt)        -- reviewer -> relative load
  14         (Int -> Int -> Wt) -- reviewer -> proposal -> pref
  15
  16 prefBoringness p = if prefIsVeryBoring p then 2
  17         else if prefIsBoring p then 1 else 0
  18 prefExpertness p = if prefIsExpert p then 2
  19         else if prefIsKnowledgeable p then 1 else 0
  20
  21 doReduction :: Instance -> Gr () Wt
  22 doReduction (Instance numRvrs numProps rloadF prefF) =
  23         let
  24                 source = 0
  25                 sink = 1
  26                 rvrNode i boringness = 2 + 3*i + boringness
  27                 propNode j expertness = 2 + 3*numRvrs + 3*j + expertness
  28                 numNodes = 2 + 3*numRvrs + 3*numProps
  29                 in
  30         let
  31                 totalReviews = reviewsEachProposal * numProps
  32                 totalRelativeLoad = foldl (+) 0 (map rloadF [0 .. numRvrs - 1])
  33                 targetLoad i = ceiling (numAsWt totalReviews * rloadF i / totalRelativeLoad)
  34                 -- A...H refer to idea book p.429
  35                 edgesABC = do
  36                         i <- [0 .. numRvrs - 1]
  37                         let tl = targetLoad i
  38                         l <- [0 .. tl + loadTolerance - 1]
  39                         let costA = if l < tl
  40                                 then 0
  41                                 else marginalLoadCost ((numAsWt (l - tl) + 1/2) / numAsWt loadTolerance)
  42                         let edgeA = (source, rvrNode i 0, costA)
  43                         let costB = marginalBoringCost ((numAsWt l + 1/2) / numAsWt tl)
  44                         let edgeB = (rvrNode i 0, rvrNode i 1, costB)
  45                         let costC = marginalVeryBoringCost ((numAsWt l + 1/2) / numAsWt tl)
  46                         let edgeC = (rvrNode i 1, rvrNode i 2, costC)
  47                         [edgeA, edgeB, edgeC]
  48                 edgesD = do
  49                         i <- [0 .. numRvrs - 1]
  50                         j <- [0 .. numProps - 1]
  51                         let pref = prefF i j
  52                         if prefIsConflict pref
  53                                 then []
  54                                 else [(rvrNode i (prefBoringness pref),
  55                                         propNode j (prefExpertness pref),
  56                                         assignmentCost pref)]
  57                 edgesE = do
  58                         j <- [0 .. numProps - 1]
  59                         [(propNode j 2, propNode j 0, -expertBonus)]
  60                 edgesFGH = do
  61                         j <- [0 .. numProps - 1]
  62                         l <- [0 .. reviewsEachProposal - 1]
  63                         let edgeF = (propNode j 2, propNode j 1, 0)
  64                         let edgeG = (propNode j 1, propNode j 0,
  65                                 if l == 0 then -knowledgeableBonus else 0)
  66                         let edgeH = (propNode j 0, sink, 0)
  67                         [edgeF, edgeG, edgeH]
  68                 theNodes = [(x, ()) | x <- [0 .. numNodes - 1]]
  69                 theEdges = edgesABC ++ edgesD ++ edgesE ++ edgesFGH
  70                 in
  71         mkGraph theNodes theEdges
  72
  73 todo = undefined
  74 -- Returns a list of reviews as ordered pairs (reviewer#, proposal#).
  75 doMatching :: Instance -> [(Int, Int)]
  76 doMatching inst@(Instance numRvrs numProps rloadF prefF) =
  77         -- Copied from doReduction.  There should be a better way to get these here.
  78         let
  79                 source = 0
  80                 sink = 1
  81                 rvrNode i boringness = 2 + 3*i + boringness
  82                 propNode j expertness = 2 + 3*numRvrs + 3*j + expertness
  83                 firstPropNode = propNode 0 0
  84                 idPropNode n = (n - (2 + 3*numRvrs)) `div` 3
  85                 numNodes = 2 + 3*numRvrs + 3*numProps
  86                 in
  87         let graph1 = doReduction inst in
  88         let flow1 = flowDiff graph1 (snd (umcf source sink graph1)) in
  89         let pairs = do
  90                 i <- [0 .. numRvrs - 1]
  91                 boringness <- [0, 1, 2]
  92                 n <- suc flow1 (rvrNode i boringness)
  93                 if n >= firstPropNode
  94                         then [(i, idPropNode n)]
  95                         else []
  96                 in
  97         sort pairs -- for prettiness