Make PMatching a newtype for clarity.

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

diff --git a/program/ProposalMatcher.hs b/program/ProposalMatcher.hs
index 86bbf88..dcc757a 100644 (file)
--- a/program/ProposalMatcher.hs
+++ b/program/ProposalMatcher.hs
@@ -4,25 +4,8 @@ import Data.Graph.Inductive.Graph
 import Data.Graph.Inductive.Tree
 import Data.List
 
-import Instance
-import IMinCostFlow
-
-data PMConfig = PMConfig {
-       minCostFlow :: MinCostFlowImpl,
-       reviewsEachProposal :: Int,
-       prefIsExpert :: Wt -> Bool,
-       prefIsKnowledgeable :: Wt -> Bool,
-       prefIsBoring :: Wt -> Bool,
-       prefIsVeryBoring :: Wt -> Bool,
-       prefIsConflict :: Wt -> Bool,
-       loadTolerance :: Int,
-       marginalLoadCost :: Wt -> Wt,
-       marginalBoringCost :: Wt -> Wt,
-       marginalVeryBoringCost :: Wt -> Wt,
-       assignmentCost :: Wt -> Wt,
-       knowledgeableBonus :: Wt,
-       expertBonus :: Wt
-}
+import PMInstance
+import PMConfig
 
 prefBoringness cfg p = if prefIsVeryBoring cfg p then 2
        else if prefIsBoring cfg p then 1 else 0
@@ -58,8 +41,8 @@ indexEdges i ((v1, v2, re):es) =
        let (imax, ies) = indexEdges (i+1) es in
        (imax, (v1, v2, re{ reIdx = i }) : ies)
 
-doReduction :: PMConfig -> Instance -> ReductionResult
-doReduction cfg (Instance numRvrs numProps rloadA prefA) =
+doReduction :: PMConfig -> PMInstance -> ReductionResult
+doReduction cfg (PMInstance numRvrs numProps rloadA prefA) =
        let
                source = 0
                sink = 1
@@ -71,7 +54,7 @@ doReduction cfg (Instance numRvrs numProps rloadA prefA) =
        let
                totalReviews = (reviewsEachProposal cfg) * numProps
                totalRelativeLoad = foldl (+) 0 (map (rloadA !) [0 .. numRvrs - 1])
-               targetLoad i = ceiling (numAsWt totalReviews * (rloadA ! i) / totalRelativeLoad)
+               targetLoad i = ceiling (widenInteger totalReviews * (rloadA ! i) / totalRelativeLoad)
                -- A...H refer to idea book p.429
                edgesABC = do
                        i <- [0 .. numRvrs - 1]
@@ -79,13 +62,13 @@ doReduction cfg (Instance numRvrs numProps rloadA prefA) =
                        let freeEdgeA = (source, rvrNode i 0, REdge undefined tl 0)
                        let nonfreeEdgesA = do
                                l <- [tl .. tl + (loadTolerance cfg) - 1]
-                               let costA = marginalLoadCost cfg ((numAsWt (l - tl) + 1/2) / numAsWt (loadTolerance cfg))
+                               let costA = marginalLoadCost cfg ((widenInteger (l - tl) + 1/2) / widenInteger (loadTolerance cfg))
                                [(source, rvrNode i 0, REdge undefined 1 costA)]
                        let edgesBC = do
                                l <- [0 .. tl + (loadTolerance cfg) - 1]
-                               let costB = marginalBoringCost cfg ((numAsWt l + 1/2) / numAsWt tl)
+                               let costB = marginalBoringCost cfg ((widenInteger l + 1/2) / widenInteger tl)
                                let edgeB = (rvrNode i 0, rvrNode i 1, REdge undefined 1 costB)
-                               let costC = marginalVeryBoringCost cfg ((numAsWt l + 1/2) / numAsWt tl)
+                               let costC = marginalVeryBoringCost cfg ((widenInteger l + 1/2) / widenInteger tl)
                                let edgeC = (rvrNode i 1, rvrNode i 2, REdge undefined 1 costC)
                                [edgeB, edgeC]
                        [freeEdgeA] ++ nonfreeEdgesA ++ edgesBC
@@ -118,8 +101,8 @@ doReduction cfg (Instance numRvrs numProps rloadA prefA) =
        ReductionResult (mkGraph theNodes theEdges) source sink (0, imax-1) edIdx
 
 -- Returns a list of reviews as ordered pairs (reviewer#, proposal#).
-doMatching :: PMConfig -> Instance -> [(Int, Int)]
-doMatching cfg inst@(Instance numRvrs numProps _ _) =
+doMatching :: PMConfig -> PMInstance -> PMatching
+doMatching cfg inst@(PMInstance numRvrs numProps _ _) =
        let ReductionResult graph source sink idxBounds edIdx = doReduction cfg inst in
        let flowArray = minCostFlow cfg idxBounds reIdx reCap reCost graph (source, sink) in
        let pairs = do
@@ -129,4 +112,4 @@ doMatching cfg inst@(Instance numRvrs numProps _ _) =
                        then [(i, j)]
                        else []
                in
-       sort pairs -- for prettiness
+       PMatching (sort pairs) -- for prettiness