Rewrite Bellman-Ford and min-cost flow, especially to stop the latter from crashing.

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

diff --git a/program/ProposalMatcher.hs b/program/ProposalMatcher.hs
index c0bd7a0..f523c27 100644 (file)
--- a/program/ProposalMatcher.hs
+++ b/program/ProposalMatcher.hs
@@ -1,5 +1,5 @@
 module ProposalMatcher where
-import UnitMinCostFlow
+import NaiveMinCostFlow
 import Data.Array.IArray
 import Data.Graph.Inductive.Graph
 import Data.Graph.Inductive.Tree
@@ -13,7 +13,36 @@ prefBoringness p = if prefIsVeryBoring p then 2
 prefExpertness p = if prefIsExpert p then 2
        else if prefIsKnowledgeable p then 1 else 0
 
-doReduction :: Instance -> Gr () Wt
+data REdge = REdge {
+       reIdx  :: Int,
+       reCap  :: Int,
+       reCost :: Wt
+}
+
+instance Show REdge where
+       show (REdge idx cap cost) = "#" ++ (show idx) ++ ": "
+               ++ (show cap) ++ " @ " ++ (show cost)
+
+data ReductionResult = ReductionResult {
+       rrGraph      :: Gr () REdge,
+       rrSource     :: Node,
+       rrSink       :: Node,
+       rrEIdxBounds :: (Int, Int),
+       rrEDIdx      :: (Int, Int) -> Int
+}
+
+-- Hack: show as much of the reduction result as we easily can
+data RR1 = RR1 (Gr () REdge) Node Node (Int, Int) deriving Show
+instance Show ReductionResult where
+       show (ReductionResult g so si eib _) = show (RR1 g so si eib)
+
+indexEdges :: Int -> [(Int, Int, REdge)] -> (Int, [(Int, Int, REdge)])
+indexEdges i [] = (i, [])
+indexEdges i ((v1, v2, re):es) =
+       let (imax, ies) = indexEdges (i+1) es in
+       (imax, (v1, v2, re{ reIdx = i }) : ies)
+
+doReduction :: Instance -> ReductionResult
 doReduction (Instance numRvrs numProps rloadA prefA) =
        let
                source = 0
@@ -21,6 +50,7 @@ doReduction (Instance numRvrs numProps rloadA prefA) =
                rvrNode i boringness = 2 + 3*i + boringness
                propNode j expertness = 2 + 3*numRvrs + 3*j + expertness
                numNodes = 2 + 3*numRvrs + 3*numProps
+               edIdx (i, j) = i*numProps + j
                in
        let
                totalReviews = reviewsEachProposal * numProps
@@ -30,16 +60,19 @@ doReduction (Instance numRvrs numProps rloadA prefA) =
                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]
+                       let freeEdgeA = (source, rvrNode i 0, REdge undefined tl 0)
+                       let nonfreeEdgesA = do
+                               l <- [tl .. tl + loadTolerance - 1]
+                               let costA = marginalLoadCost ((numAsWt (l - tl) + 1/2) / numAsWt loadTolerance)
+                               [(source, rvrNode i 0, REdge undefined 1 costA)]
+                       let edgesBC = do
+                               l <- [0 .. tl + loadTolerance - 1]
+                               let costB = marginalBoringCost ((numAsWt l + 1/2) / numAsWt tl)
+                               let edgeB = (rvrNode i 0, rvrNode i 1, REdge undefined 1 costB)
+                               let costC = marginalVeryBoringCost ((numAsWt l + 1/2) / numAsWt tl)
+                               let edgeC = (rvrNode i 1, rvrNode i 2, REdge undefined 1 costC)
+                               [edgeB, edgeC]
+                       [freeEdgeA] ++ nonfreeEdgesA ++ edgesBC
                edgesD = do
                        i <- [0 .. numRvrs - 1]
                        j <- [0 .. numProps - 1]
@@ -48,22 +81,22 @@ doReduction (Instance numRvrs numProps rloadA prefA) =
                                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
+                                       REdge (edIdx (i, j)) 1 (assignmentCost pref))]
+               edgesEFGH = 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]
+                       let edgeE = (propNode j 2, propNode j 0, REdge undefined 1 (-expertBonus))
+                       let edgeF = (propNode j 2, propNode j 1, REdge undefined reviewsEachProposal 0)
+                       let edgeGFirst = (propNode j 1, propNode j 0, REdge undefined 1 (-knowledgeableBonus))
+                       let edgeGRest = (propNode j 1, propNode j 0, REdge undefined (reviewsEachProposal-1) 0)
+                       let edgeH = (propNode j 0, sink, REdge undefined reviewsEachProposal 0)
+                       [edgeE, edgeF, edgeGFirst, edgeGRest, edgeH]
                theNodes = [(x, ()) | x <- [0 .. numNodes - 1]]
-               theEdges = edgesABC ++ edgesD ++ edgesE ++ edgesFGH
+               -- Index the non-D edges
+               unindexedEdges = edgesABC ++ edgesEFGH
+               (imax, reindexedEdges) = indexEdges (numRvrs*numProps) unindexedEdges
+               theEdges = edgesD ++ reindexedEdges
                in
-       mkGraph theNodes theEdges
+       ReductionResult (mkGraph theNodes theEdges) source sink (0, imax-1) edIdx
 
 todo = undefined
 -- Returns a list of reviews as ordered pairs (reviewer#, proposal#).
@@ -79,14 +112,13 @@ doMatching inst@(Instance numRvrs numProps _ _) =
                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 ReductionResult graph source sink idxBounds edIdx = doReduction inst in
+       let flowArray = minCostFlow idxBounds reIdx reCap reCost graph (source, sink) 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)]
+               j <- [0 .. numProps - 1]
+               if flowArray ! edIdx (i, j) == 1
+                       then [(i, j)]
                        else []
                in
        sort pairs -- for prettiness