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 Real wt => Instance wt = Instance Int Int (Int -> Int -> wt)
  11
  12 doReduction :: Real wt => Instance wt -> (Int -> Int) -> Gr () wt
  13 doReduction (Instance numRvrs numProps prefF) expertCapF =
  14         let
  15                 source = 0
  16                 sink = 1
  17                 rvrNode i = 2 + i
  18                 propNode j isExpert = 2 + numRvrs + 2*j + (if isExpert then 1 else 0)
  19                 numNodes = 2 + numRvrs + 2*numProps
  20                 theNodes = [(x, ()) | x <- [0 .. numNodes - 1]]
  21                 in
  22         let
  23                 loadEdges = do
  24                         i <- [0 .. numRvrs - 1]
  25                         l <- [1 .. maxReviewerLoad]
  26                         return (source, rvrNode i, marginalLoadCost l)
  27                 prefEdges = do
  28                         i <- [0 .. numRvrs - 1]
  29                         j <- [0 .. numProps - 1]
  30                         let pref = prefF i j
  31                         if prefIsConflict pref
  32                                 then fail "Conflict of interest"
  33                                 else return (rvrNode i, propNode j (prefIsExpert pref),
  34                                         prefToCost pref)
  35                 wantEdges = do
  36                         j <- [0 .. numProps - 1]
  37                         let wExpert = expertCapF j
  38                         -- Yuck, too many kinds of integers.
  39                         let wGeneral = fromInteger wantGeneralReviews +
  40                                 fromInteger wantReviewsSubstForExpert *
  41                                 (fromInteger wantExpertReviews - wExpert)
  42                         let expertEdges = replicate wExpert (propNode j True, sink, 0)
  43                         let rolloverEdges = replicate wGeneral (propNode j True, propNode j False, 0)
  44                         let generalEdges = replicate wGeneral (propNode j False, sink, 0)
  45                         expertEdges ++ rolloverEdges ++ generalEdges
  46                 theEdges = loadEdges ++ prefEdges ++ wantEdges
  47                 in
  48         mkGraph theNodes theEdges
  49
  50 todo = undefined
  51 -- Returns a list of reviews as ordered pairs (reviewer#, proposal#).
  52 doMatching :: Real wt => Instance wt -> [(Int, Int)]
  53 doMatching inst@(Instance numRvrs numProps prefF) =
  54         -- Copied from doReduction.  There should be a better way to get these here.
  55         let
  56                 source = 0
  57                 sink = 1
  58                 rvrNode i = 2 + i
  59                 propNode j isExpert = 2 + numRvrs + 2*j + (if isExpert then 1 else 0)
  60                 idPropNode n = (n - (2 + numRvrs)) `div` 2
  61                 numNodes = 2 + numRvrs + 2*numProps
  62                 in
  63         let graph1 = doReduction inst (const (fromInteger wantExpertReviews)) in
  64         let flow1 = flowDiff graph1 (snd (umcf source sink graph1)) in
  65         let expertCapF j = outdeg flow1 (propNode j True) in
  66         let graph2 = doReduction inst expertCapF in
  67         let flow2 = flowDiff graph2 (snd (umcf source sink graph2)) in
  68         let pairs = do
  69                 i <- [0 .. numRvrs - 1]
  70                 map (\n -> (i, idPropNode n)) (suc flow2 (rvrNode i)) in
  71         sort pairs -- for prettiness