- Add the notes Samir emailed me on 2008-07-06.

[match/match.git] / program / ProposalMatch.hs

diff --git a/program/ProposalMatch.hs b/program/ProposalMatch.hs
new file mode 100644 (file)
index 0000000..0cddc9b
--- /dev/null
+++ b/program/ProposalMatch.hs
@@ -0,0 +1,71 @@
+module ProposalMatch where
+import UnitMinCostFlow
+import Data.Array.IArray
+import Data.Graph.Inductive.Graph
+import Data.Graph.Inductive.Tree
+import Data.List
+
+import ProposalMatchConfig
+
+data Real wt => Instance wt = Instance Int Int (Int -> Int -> wt)
+
+doReduction :: Real wt => Instance wt -> (Int -> Int) -> Gr () wt
+doReduction (Instance numRvrs numProps prefF) expertCapF =
+       let
+               source = 0
+               sink = 1
+               rvrNode i = 2 + i
+               propNode j isExpert = 2 + numRvrs + 2*j + (if isExpert then 1 else 0)
+               numNodes = 2 + numRvrs + 2*numProps
+               theNodes = [(x, ()) | x <- [0 .. numNodes - 1]]
+               in
+       let
+               loadEdges = do
+                       i <- [0 .. numRvrs - 1]
+                       l <- [1 .. maxReviewerLoad]
+                       return (source, rvrNode i, marginalLoadCost l)
+               prefEdges = do
+                       i <- [0 .. numRvrs - 1]
+                       j <- [0 .. numProps - 1]
+                       let pref = prefF i j
+                       if prefIsConflict pref
+                               then fail "Conflict of interest"
+                               else return (rvrNode i, propNode j (prefIsExpert pref),
+                                       prefToCost pref)
+               wantEdges = do
+                       j <- [0 .. numProps - 1]
+                       let wExpert = expertCapF j
+                       -- Yuck, too many kinds of integers.
+                       let wGeneral = fromInteger wantGeneralReviews +
+                               fromInteger wantReviewsSubstForExpert *
+                               (fromInteger wantExpertReviews - wExpert) 
+                       let expertEdges = replicate wExpert (propNode j True, sink, 0)
+                       let rolloverEdges = replicate wGeneral (propNode j True, propNode j False, 0)
+                       let generalEdges = replicate wGeneral (propNode j False, sink, 0)
+                       expertEdges ++ rolloverEdges ++ generalEdges
+               theEdges = loadEdges ++ prefEdges ++ wantEdges
+               in
+       mkGraph theNodes theEdges
+
+todo = undefined
+-- Returns a list of reviews as ordered pairs (reviewer#, proposal#).
+doMatching :: Real wt => Instance wt -> [(Int, Int)]
+doMatching inst@(Instance numRvrs numProps prefF) =
+       -- Copied from doReduction.  There should be a better way to get these here.
+       let
+               source = 0
+               sink = 1
+               rvrNode i = 2 + i
+               propNode j isExpert = 2 + numRvrs + 2*j + (if isExpert then 1 else 0)
+               idPropNode n = (n - (2 + numRvrs)) `div` 2
+               numNodes = 2 + numRvrs + 2*numProps
+               in
+       let graph1 = doReduction inst (const (fromInteger wantExpertReviews)) in
+       let flow1 = flowDiff graph1 (snd (umcf source sink graph1)) in
+       let expertCapF j = outdeg flow1 (propNode j True) in
+       let graph2 = doReduction inst expertCapF in
+       let flow2 = flowDiff graph2 (snd (umcf source sink graph2)) in
+       let pairs = do
+               i <- [0 .. numRvrs - 1]
+               map (\n -> (i, idPropNode n)) (suc flow2 (rvrNode i)) in
+       sort pairs -- for prettiness