Make proposal-matcher configuration non-global to make it more practical to

compare multiple configurations for the experimentation.

diff --git a/program/Instance.hs b/program/Instance.hs
index 384666f..145a8f3 100644 (file)
--- a/program/Instance.hs
+++ b/program/Instance.hs
@@ -1,10 +1,12 @@
-module Instance (module Instance, Wt) where
-import ProposalMatcherConfig (Wt)
+module Instance where
 import Data.Array.IArray
 import Data.Array.Unboxed
 import ArrayStuff
 import Formatter
 
+type Wt = Double -- Can be any RealFrac.
+numAsWt x = fromInteger (toInteger x)
+
 data Instance = Instance
        Int                 -- numReviewers
        Int                 -- numProposals

diff --git a/program/ProposalMatcherConfig.hs b/program/PMDefaults.hs
similarity index 57%
rename from program/ProposalMatcherConfig.hs
rename to program/PMDefaults.hs
index 90bc9b1..5f9ede2 100644 (file)
--- a/program/ProposalMatcherConfig.hs
+++ b/program/PMDefaults.hs
@@ -1,53 +1,55 @@
-module ProposalMatcherConfig
-       (module ProposalMatcherConfig, minCostFlow) where
+module PMDefaults where
+import Instance
+import ProposalMatcher
+
+import qualified NaiveMinCostFlow
+import qualified CS2MinCostFlow
+
+pmDefaults = PMConfig {
 
 -- Choose a min-cost flow implementation (timings on mattlaptop2):
 
 -- A naive implementation that is slow for all but the smallest instances
 -- (30s on a 20x50 example).
-import NaiveMinCostFlow
+minCostFlow = NaiveMinCostFlow.minCostFlow,
 
 -- Uses CS2 (http://www.igsystems.com/cs2/), which requires a license for
 -- non-research use but is faster (<1s on a 20x50 example, 64s on a 60x500
 -- example).  Configure the path to cs2.exe in CS2MinCostFlow.hs.
---import CS2MinCostFlow
-
-type Wt = Double -- Can be any RealFrac.
+--minCostFlow = CS2MinCostFlow.minCostFlow,
 
-type Pref = Int
+reviewsEachProposal = 3,
 
-numAsWt x = fromInteger (toInteger x) :: Wt
+prefIsExpert = \p -> p <= 10,
+prefIsKnowledgeable = \p -> p <= 20,
 
-reviewsEachProposal = 3 :: Int
+prefIsBoring = \p -> p > 15,
+prefIsVeryBoring = \p -> p > 25,
 
-prefIsExpert p = p <= 10
-prefIsKnowledgeable p = p <= 20
-
-prefIsBoring p = p > 15
-prefIsVeryBoring p = p > 25
-
-prefIsConflict p = p >= 40
+prefIsConflict = \p -> p >= 40,
 
 -- For now this is absolute.  Later it might be proportional to a reviewer's
 -- target load.
-loadTolerance = 1 :: Int
+loadTolerance = 1,
 
 -- Cost to overload by one review.
 -- tx = 0 at target load, 1 at end of tolerance.
-marginalLoadCost tx = 1000 + tx*1000 :: Wt
+marginalLoadCost = \tx -> 1000 + tx*1000,
 
 -- Cost to review a boring (or very boring) proposal.
 -- lx = 0 at no load, 1 at target load.
-marginalBoringCost lx = 1000 + lx*1000 :: Wt
+marginalBoringCost = \lx -> 1000 + lx*1000,
 -- Additional cost to review a very boring proposal.
-marginalVeryBoringCost lx = 1000 + lx*1000 :: Wt
+marginalVeryBoringCost = \lx -> 1000 + lx*1000,
 
 -- Cost to make a review.
 -- I'm using quadratic cost functions as a first attempt.
-assignmentCost pref = (numAsWt 10 + pref) ^ 2 :: Wt
+assignmentCost = \pref -> (numAsWt 10 + pref) ^ 2,
 
 -- Bonus for a first knowledgeable or expert review.
-knowledgeableBonus = 1000 :: Wt
+knowledgeableBonus = 1000,
 
 -- Bonus for an additional expert review.
-expertBonus = 1000 :: Wt
+expertBonus = 1000
+
+}

diff --git a/program/ProposalMatcher.hs b/program/ProposalMatcher.hs
index 3720fab..86bbf88 100644 (file)
--- a/program/ProposalMatcher.hs
+++ b/program/ProposalMatcher.hs
@@ -5,12 +5,29 @@ import Data.Graph.Inductive.Tree
 import Data.List
 
 import Instance
-import ProposalMatcherConfig -- gives us minCostFlow
+import IMinCostFlow
 
-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
+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
+}
+
+prefBoringness cfg p = if prefIsVeryBoring cfg p then 2
+       else if prefIsBoring cfg p then 1 else 0
+prefExpertness cfg p = if prefIsExpert cfg p then 2
+       else if prefIsKnowledgeable cfg p then 1 else 0
 
 data REdge = REdge {
        reIdx  :: Int,
@@ -41,8 +58,8 @@ 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) =
+doReduction :: PMConfig -> Instance -> ReductionResult
+doReduction cfg (Instance numRvrs numProps rloadA prefA) =
        let
                source = 0
                sink = 1
@@ -52,7 +69,7 @@ doReduction (Instance numRvrs numProps rloadA prefA) =
                edIdx (i, j) = i*numProps + j
                in
        let
-               totalReviews = reviewsEachProposal * numProps
+               totalReviews = (reviewsEachProposal cfg) * 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
@@ -61,14 +78,14 @@ doReduction (Instance numRvrs numProps rloadA prefA) =
                        let tl = targetLoad i
                        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)
+                               l <- [tl .. tl + (loadTolerance cfg) - 1]
+                               let costA = marginalLoadCost cfg ((numAsWt (l - tl) + 1/2) / numAsWt (loadTolerance cfg))
                                [(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)
+                               l <- [0 .. tl + (loadTolerance cfg) - 1]
+                               let costB = marginalBoringCost cfg ((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 costC = marginalVeryBoringCost cfg ((numAsWt l + 1/2) / numAsWt tl)
                                let edgeC = (rvrNode i 1, rvrNode i 2, REdge undefined 1 costC)
                                [edgeB, edgeC]
                        [freeEdgeA] ++ nonfreeEdgesA ++ edgesBC
@@ -79,18 +96,18 @@ doReduction (Instance numRvrs numProps rloadA prefA) =
                        -- We must generate an edge even if there is a conflict
                        -- of interest; otherwise we'll fail to read its flow
                        -- value in doMatching.
-                       [(rvrNode i (prefBoringness pref),
-                               propNode j (prefExpertness pref),
+                       [(rvrNode i (prefBoringness cfg pref),
+                               propNode j (prefExpertness cfg pref),
                                REdge (edIdx (i, j))
-                                       (if prefIsConflict pref then 0 else 1)
-                                       (assignmentCost pref))]
+                                       (if prefIsConflict cfg pref then 0 else 1)
+                                       (assignmentCost cfg pref))]
                edgesEFGH = do
                        j <- [0 .. numProps - 1]
-                       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)
+                       let edgeE = (propNode j 2, propNode j 0, REdge undefined 1 (-(expertBonus cfg)))
+                       let edgeF = (propNode j 2, propNode j 1, REdge undefined (reviewsEachProposal cfg) 0)
+                       let edgeGFirst = (propNode j 1, propNode j 0, REdge undefined 1 (-(knowledgeableBonus cfg)))
+                       let edgeGRest = (propNode j 1, propNode j 0, REdge undefined (reviewsEachProposal cfg - 1) 0)
+                       let edgeH = (propNode j 0, sink, REdge undefined (reviewsEachProposal cfg) 0)
                        [edgeE, edgeF, edgeGFirst, edgeGRest, edgeH]
                theNodes = [(x, ()) | x <- [0 .. numNodes - 1]]
                -- Index the non-D edges
@@ -100,12 +117,11 @@ doReduction (Instance numRvrs numProps rloadA prefA) =
                in
        ReductionResult (mkGraph theNodes theEdges) source sink (0, imax-1) edIdx
 
-todo = undefined
 -- Returns a list of reviews as ordered pairs (reviewer#, proposal#).
-doMatching :: Instance -> [(Int, Int)]
-doMatching inst@(Instance numRvrs numProps _ _) =
-       let ReductionResult graph source sink idxBounds edIdx = doReduction inst in
-       let flowArray = minCostFlow idxBounds reIdx reCap reCost graph (source, sink) in
+doMatching :: PMConfig -> Instance -> [(Int, Int)]
+doMatching cfg inst@(Instance 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
                i <- [0 .. numRvrs - 1]
                j <- [0 .. numProps - 1]

diff --git a/program/Test.hs b/program/Test.hs
index e684859..4d715c4 100644 (file)
--- a/program/Test.hs
+++ b/program/Test.hs
@@ -9,7 +9,7 @@ module Test (
        
        -- Solve instances.
        module ProposalMatcher,
-       module ProposalMatcherConfig,
+       module PMDefaults,
        
        -- Run randomized things.
        module System.Random,
@@ -19,7 +19,7 @@ import TestUtils
 import Instance
 import InstanceGenerator
 import ProposalMatcher
-import ProposalMatcherConfig hiding (Wt)
+import PMDefaults
 import System.Random
 import RandomizedMonad
 
@@ -37,7 +37,7 @@ myGraph = mkGraph [(0, ()), (1, ()), (2, ())]
 
 bfResult = bellmanFord snd 0 myGraph
 
-flowArray = minCostFlow (0, 2) fst (const 1) snd myGraph (0, 1)
+flowArray = minCostFlow pmDefaults (0, 2) fst (const 1) snd myGraph (0, 1)
 
 myNCGraph = mkGraph [(0, ())] [(0, 0, -1)] :: Gr () Int
 bfNCResult = bellmanFord id 0 myNCGraph
@@ -64,10 +64,10 @@ myPrefs = transposeArray $ listArray ((0,0), (myNumProps-1,myNumRvrs-1)) [
 
 myInst = Instance myNumRvrs myNumProps (constArray (0, myNumRvrs-1) 1) myPrefs
 
-rdnResult = doReduction myInst
+rdnResult = doReduction pmDefaults myInst
 ReductionResult rrg rrso rrsi rreib rredi = rdnResult
-rdnFlowArray = minCostFlow rreib reIdx reCap reCost rrg (rrso, rrsi)
+rdnFlowArray = minCostFlow pmDefaults rreib reIdx reCap reCost rrg (rrso, rrsi)
 rrg2 = flowAnnotate rrg rdnFlowArray
-myMatching = doMatching myInst
+myMatching = doMatching pmDefaults myInst
 
 iGraph = showInstanceAsGraph myInst myMatching -- Visualize me!