From 8c5ee850714e315aabbdcd173728e60811206b2c Mon Sep 17 00:00:00 2001 From: Matt McCutchen Date: Mon, 28 Jul 2008 10:50:13 -0400 Subject: [PATCH] Make proposal-matcher configuration non-global to make it more practical to compare multiple configurations for the experimentation. --- program/Instance.hs | 6 +- ...ProposalMatcherConfig.hs => PMDefaults.hs} | 48 +++++++------ program/ProposalMatcher.hs | 70 ++++++++++++------- program/Test.hs | 12 ++-- 4 files changed, 78 insertions(+), 58 deletions(-) rename program/{ProposalMatcherConfig.hs => PMDefaults.hs} (57%) diff --git a/program/Instance.hs b/program/Instance.hs index 384666f..145a8f3 100644 --- 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 --- 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 --- 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 --- 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! -- 2.34.1