The random instance generator and other improvements.

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

diff --git a/program/ProposalMatcher.hs b/program/ProposalMatcher.hs
new file mode 100644 (file)
index 0000000..c0bd7a0
--- /dev/null
+++ b/program/ProposalMatcher.hs
@@ -0,0 +1,92 @@
+module ProposalMatcher where
+import UnitMinCostFlow
+import Data.Array.IArray
+import Data.Graph.Inductive.Graph
+import Data.Graph.Inductive.Tree
+import Data.List
+
+import Instance
+import ProposalMatcherConfig
+
+prefBoringness p = if prefIsVeryBoring p then 2
+       else if prefIsBoring p then 1 else 0
+prefExpertness p = if prefIsExpert p then 2
+       else if prefIsKnowledgeable p then 1 else 0
+
+doReduction :: Instance -> Gr () Wt
+doReduction (Instance numRvrs numProps rloadA prefA) =
+       let
+               source = 0
+               sink = 1
+               rvrNode i boringness = 2 + 3*i + boringness
+               propNode j expertness = 2 + 3*numRvrs + 3*j + expertness
+               numNodes = 2 + 3*numRvrs + 3*numProps
+               in
+       let
+               totalReviews = reviewsEachProposal * numProps
+               totalRelativeLoad = foldl (+) 0 (map (rloadA !) [0 .. numRvrs - 1])
+               targetLoad i = ceiling (numAsWt totalReviews * (rloadA ! i) / totalRelativeLoad)
+               -- A...H refer to idea book p.429
+               edgesABC = do
+                       i <- [0 .. numRvrs - 1]
+                       let tl = targetLoad i
+                       l <- [0 .. tl + loadTolerance - 1]
+                       let costA = if l < tl
+                               then 0
+                               else marginalLoadCost ((numAsWt (l - tl) + 1/2) / numAsWt loadTolerance)
+                       let edgeA = (source, rvrNode i 0, costA)
+                       let costB = marginalBoringCost ((numAsWt l + 1/2) / numAsWt tl)
+                       let edgeB = (rvrNode i 0, rvrNode i 1, costB)
+                       let costC = marginalVeryBoringCost ((numAsWt l + 1/2) / numAsWt tl)
+                       let edgeC = (rvrNode i 1, rvrNode i 2, costC)
+                       [edgeA, edgeB, edgeC]
+               edgesD = do
+                       i <- [0 .. numRvrs - 1]
+                       j <- [0 .. numProps - 1]
+                       let pref = prefA ! (i, j)
+                       if prefIsConflict pref
+                               then []
+                               else [(rvrNode i (prefBoringness pref),
+                                       propNode j (prefExpertness pref),
+                                       assignmentCost pref)]
+               edgesE = do
+                       j <- [0 .. numProps - 1]
+                       [(propNode j 2, propNode j 0, -expertBonus)]
+               edgesFGH = do
+                       j <- [0 .. numProps - 1]
+                       l <- [0 .. reviewsEachProposal - 1]
+                       let edgeF = (propNode j 2, propNode j 1, 0)
+                       let edgeG = (propNode j 1, propNode j 0,
+                               if l == 0 then -knowledgeableBonus else 0)
+                       let edgeH = (propNode j 0, sink, 0)
+                       [edgeF, edgeG, edgeH]
+               theNodes = [(x, ()) | x <- [0 .. numNodes - 1]]
+               theEdges = edgesABC ++ edgesD ++ edgesE ++ edgesFGH
+               in
+       mkGraph theNodes theEdges
+
+todo = undefined
+-- Returns a list of reviews as ordered pairs (reviewer#, proposal#).
+doMatching :: Instance -> [(Int, Int)]
+doMatching inst@(Instance numRvrs numProps _ _) =
+       -- Copied from doReduction.  There should be a better way to get these here.
+       let
+               source = 0
+               sink = 1
+               rvrNode i boringness = 2 + 3*i + boringness
+               propNode j expertness = 2 + 3*numRvrs + 3*j + expertness
+               firstPropNode = propNode 0 0
+               idPropNode n = (n - (2 + 3*numRvrs)) `div` 3
+               numNodes = 2 + 3*numRvrs + 3*numProps
+               in
+       let graph1 = doReduction inst in
+       let flow1 = flowDiff graph1 (snd (umcf source sink graph1)) in
+       let pairs = do
+               i <- [0 .. numRvrs - 1]
+               boringness <- [0, 1, 2]
+               n <- suc flow1 (rvrNode i boringness)
+               if n >= firstPropNode
+                       then [(i, idPropNode n)]
+                       else []
+               in
+       sort pairs -- for prettiness