program/ProposalMatcher.hs

   1 module ProposalMatcher where
   2 import NaiveMinCostFlow
   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 data REdge = REdge {
  17         reIdx  :: Int,
  18         reCap  :: Int,
  19         reCost :: Wt
  20 }
  21
  22 instance Show REdge where
  23         show (REdge idx cap cost) = "#" ++ (show idx) ++ ": "
  24                 ++ (show cap) ++ " @ " ++ (show cost)
  25
  26 data ReductionResult = ReductionResult {
  27         rrGraph      :: Gr () REdge,
  28         rrSource     :: Node,
  29         rrSink       :: Node,
  30         rrEIdxBounds :: (Int, Int),
  31         rrEDIdx      :: (Int, Int) -> Int
  32 }
  33
  34 -- Hack: show as much of the reduction result as we easily can
  35 data RR1 = RR1 (Gr () REdge) Node Node (Int, Int) deriving Show
  36 instance Show ReductionResult where
  37         show (ReductionResult g so si eib _) = show (RR1 g so si eib)
  38
  39 indexEdges :: Int -> [(Int, Int, REdge)] -> (Int, [(Int, Int, REdge)])
  40 indexEdges i [] = (i, [])
  41 indexEdges i ((v1, v2, re):es) =
  42         let (imax, ies) = indexEdges (i+1) es in
  43         (imax, (v1, v2, re{ reIdx = i }) : ies)
  44
  45 doReduction :: Instance -> ReductionResult
  46 doReduction (Instance numRvrs numProps rloadA prefA) =
  47         let
  48                 source = 0
  49                 sink = 1
  50                 rvrNode i boringness = 2 + 3*i + boringness
  51                 propNode j expertness = 2 + 3*numRvrs + 3*j + expertness
  52                 numNodes = 2 + 3*numRvrs + 3*numProps
  53                 edIdx (i, j) = i*numProps + j
  54                 in
  55         let
  56                 totalReviews = reviewsEachProposal * numProps
  57                 totalRelativeLoad = foldl (+) 0 (map (rloadA !) [0 .. numRvrs - 1])
  58                 targetLoad i = ceiling (numAsWt totalReviews * (rloadA ! i) / totalRelativeLoad)
  59                 -- A...H refer to idea book p.429
  60                 edgesABC = do
  61                         i <- [0 .. numRvrs - 1]
  62                         let tl = targetLoad i
  63                         let freeEdgeA = (source, rvrNode i 0, REdge undefined tl 0)
  64                         let nonfreeEdgesA = do
  65                                 l <- [tl .. tl + loadTolerance - 1]
  66                                 let costA = marginalLoadCost ((numAsWt (l - tl) + 1/2) / numAsWt loadTolerance)
  67                                 [(source, rvrNode i 0, REdge undefined 1 costA)]
  68                         let edgesBC = do
  69                                 l <- [0 .. tl + loadTolerance - 1]
  70                                 let costB = marginalBoringCost ((numAsWt l + 1/2) / numAsWt tl)
  71                                 let edgeB = (rvrNode i 0, rvrNode i 1, REdge undefined 1 costB)
  72                                 let costC = marginalVeryBoringCost ((numAsWt l + 1/2) / numAsWt tl)
  73                                 let edgeC = (rvrNode i 1, rvrNode i 2, REdge undefined 1 costC)
  74                                 [edgeB, edgeC]
  75                         [freeEdgeA] ++ nonfreeEdgesA ++ edgesBC
  76                 edgesD = do
  77                         i <- [0 .. numRvrs - 1]
  78                         j <- [0 .. numProps - 1]
  79                         let pref = prefA ! (i, j)
  80                         if prefIsConflict pref
  81                                 then []
  82                                 else [(rvrNode i (prefBoringness pref),
  83                                         propNode j (prefExpertness pref),
  84                                         REdge (edIdx (i, j)) 1 (assignmentCost pref))]
  85                 edgesEFGH = do
  86                         j <- [0 .. numProps - 1]
  87                         let edgeE = (propNode j 2, propNode j 0, REdge undefined 1 (-expertBonus))
  88                         let edgeF = (propNode j 2, propNode j 1, REdge undefined reviewsEachProposal 0)
  89                         let edgeGFirst = (propNode j 1, propNode j 0, REdge undefined 1 (-knowledgeableBonus))
  90                         let edgeGRest = (propNode j 1, propNode j 0, REdge undefined (reviewsEachProposal-1) 0)
  91                         let edgeH = (propNode j 0, sink, REdge undefined reviewsEachProposal 0)
  92                         [edgeE, edgeF, edgeGFirst, edgeGRest, edgeH]
  93                 theNodes = [(x, ()) | x <- [0 .. numNodes - 1]]
  94                 -- Index the non-D edges
  95                 unindexedEdges = edgesABC ++ edgesEFGH
  96                 (imax, reindexedEdges) = indexEdges (numRvrs*numProps) unindexedEdges
  97                 theEdges = edgesD ++ reindexedEdges
  98                 in
  99         ReductionResult (mkGraph theNodes theEdges) source sink (0, imax-1) edIdx
 100
 101 todo = undefined
 102 -- Returns a list of reviews as ordered pairs (reviewer#, proposal#).
 103 doMatching :: Instance -> [(Int, Int)]
 104 doMatching inst@(Instance numRvrs numProps _ _) =
 105         -- Copied from doReduction.  There should be a better way to get these here.
 106         let
 107                 source = 0
 108                 sink = 1
 109                 rvrNode i boringness = 2 + 3*i + boringness
 110                 propNode j expertness = 2 + 3*numRvrs + 3*j + expertness
 111                 firstPropNode = propNode 0 0
 112                 idPropNode n = (n - (2 + 3*numRvrs)) `div` 3
 113                 numNodes = 2 + 3*numRvrs + 3*numProps
 114                 in
 115         let ReductionResult graph source sink idxBounds edIdx = doReduction inst in
 116         let flowArray = minCostFlow idxBounds reIdx reCap reCost graph (source, sink) in
 117         let pairs = do
 118                 i <- [0 .. numRvrs - 1]
 119                 j <- [0 .. numProps - 1]
 120                 if flowArray ! edIdx (i, j) == 1
 121                         then [(i, j)]
 122                         else []
 123                 in
 124         sort pairs -- for prettiness