program/ProposalMatcher.hs

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