Second version of the reduction.

Significant changes:
- Supports a per-reviewer relative load limit, which is hard with a tolerance.
- Split each reviewer into multiple nodes in order to charge a cost quadratic in
  the number of disliked proposals she has to review.  Previously, cost was
  simply additive.
- Require three reviews per proposal regardless of experts, but provide an
  incentive for a knowledgeable review and an additional expert review.

Also, add import and "show-graph" script for graph visualization.

diff --git a/program/ProposalMatch.hs b/program/ProposalMatch.hs
index 07cb710..028f22c 100644 (file)
--- a/program/ProposalMatch.hs
+++ b/program/ProposalMatch.hs
@@ -7,65 +7,91 @@ import Data.List
 
 import ProposalMatchConfig
 
-data Real wt => Instance wt = Instance Int Int (Int -> Int -> wt)
+data Instance = Instance
+       Int                -- numReviewers
+       Int                -- numProposals
+       (Int -> Wt)        -- reviewer -> relative load
+       (Int -> Int -> Wt) -- reviewer -> proposal -> pref
 
-doReduction :: Real wt => Instance wt -> (Int -> Int) -> Gr () wt
-doReduction (Instance numRvrs numProps prefF) expertCapF =
+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 rloadF prefF) =
        let
                source = 0
                sink = 1
-               rvrNode i = 2 + i
-               propNode j isExpert = 2 + numRvrs + 2*j + (if isExpert then 1 else 0)
-               numNodes = 2 + numRvrs + 2*numProps
-               theNodes = [(x, ()) | x <- [0 .. numNodes - 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
-               loadEdges = do
+               totalReviews = reviewsEachProposal * numProps
+               totalRelativeLoad = foldl (+) 0 (map rloadF [0 .. numRvrs - 1])
+               targetLoad i = ceiling (numAsWt totalReviews * rloadF i / totalRelativeLoad)
+               -- A...H refer to idea book p.429
+               edgesABC = do
                        i <- [0 .. numRvrs - 1]
-                       l <- [1 .. maxReviewerLoad]
-                       return (source, rvrNode i, marginalLoadCost l)
-               prefEdges = do
+                       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 = prefF i j
                        if prefIsConflict pref
-                               then fail "Conflict of interest"
-                               else return (rvrNode i, propNode j (prefIsExpert pref),
-                                       prefToCost pref)
-               wantEdges = do
+                               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]
-                       let wExpert = expertCapF j
-                       -- Yuck, too many kinds of integers.
-                       let wGeneral = fromInteger wantGeneralReviews +
-                               fromInteger wantReviewsSubstForExpert *
-                               (fromInteger wantExpertReviews - wExpert) 
-                       let expertEdges = replicate wExpert (propNode j True, sink, 0)
-                       let rolloverEdges = replicate wGeneral (propNode j True, propNode j False, 0)
-                       let generalEdges = replicate wGeneral (propNode j False, sink, 0)
-                       expertEdges ++ rolloverEdges ++ generalEdges
-               theEdges = loadEdges ++ prefEdges ++ wantEdges
+                       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 :: Real wt => Instance wt -> [(Int, Int)]
-doMatching inst@(Instance numRvrs numProps prefF) =
+doMatching :: Instance -> [(Int, Int)]
+doMatching inst@(Instance numRvrs numProps rloadF prefF) =
        -- Copied from doReduction.  There should be a better way to get these here.
        let
                source = 0
                sink = 1
-               rvrNode i = 2 + i
-               propNode j isExpert = 2 + numRvrs + 2*j + (if isExpert then 1 else 0)
-               idPropNode n = (n - (2 + numRvrs)) `div` 2
-               numNodes = 2 + numRvrs + 2*numProps
+               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 (const (fromInteger wantExpertReviews)) in
+       let graph1 = doReduction inst in
        let flow1 = flowDiff graph1 (snd (umcf source sink graph1)) in
-       let expertCapF j = min (fromInteger wantExpertReviews) (outdeg flow1 (propNode j True)) in
-       let graph2 = doReduction inst expertCapF in
-       let flow2 = flowDiff graph2 (snd (umcf source sink graph2)) in
        let pairs = do
                i <- [0 .. numRvrs - 1]
-               map (\n -> (i, idPropNode n)) (suc flow2 (rvrNode i)) in
+               boringness <- [0, 1, 2]
+               n <- suc flow1 (rvrNode i boringness)
+               if n >= firstPropNode
+                       then [(i, idPropNode n)]
+                       else []
+               in
        sort pairs -- for prettiness

diff --git a/program/ProposalMatchConfig.hs b/program/ProposalMatchConfig.hs
index 39055c1..42b47f6 100644 (file)
--- a/program/ProposalMatchConfig.hs
+++ b/program/ProposalMatchConfig.hs
@@ -1,29 +1,40 @@
 module ProposalMatchConfig where
 
+type Pref = Int
+type Wt = Double -- must implement RealFrac
+
+numAsWt x = fromInteger (toInteger x) :: Wt
+
+reviewsEachProposal = 3 :: Int
+
 prefIsExpert p = p <= 10
+prefIsKnowledgeable p = p <= 20
+
+prefIsBoring p = p > 15
+prefIsVeryBoring p = p > 25
+
 prefIsConflict p = p >= 40
 
-{-
-Each proposal should have 'wantExpertReviews' expert reviews plus
-'wantGeneralReviews' general reviews (can be by experts).  If we
-fall short on expert reviews, we give 'wantReviewsSubstForExpert'
-additional general reviews for each expert review we fell short.
-Values 2, 1, 2 give the ">= 3 of which >= 1 is expert, failing that >= 4"
-criterion that Samir indicated.
--}
-wantGeneralReviews = 2
-wantExpertReviews = 1
-wantReviewsSubstForExpert = 2
-
--- A hard limit that we hope will never be hit.
-maxReviewerLoad = 10
+-- For now this is absolute.  Later it might be proportional to a reviewer's
+-- target load.
+loadTolerance = 1 :: Int
 
+-- Cost to overload by one review.
+-- tx = 0 at target load, 1 at end of tolerance.
+marginalLoadCost tx = 1000 + tx*1000 :: Wt
+
+-- Cost to review a boring (or very boring) proposal.
+-- lx = 0 at no load, 1 at target load.
+marginalBoringCost lx = 1000 + lx*1000 :: Wt
+-- Additional cost to review a very boring proposal.
+marginalVeryBoringCost lx = 1000 + lx*1000 :: Wt
+
+-- Cost to make a review.
 -- I'm using quadratic cost functions as a first attempt.
-prefToCost p = p ^ 2
-{-
-I chose the number 225 to make the preference difference between 20 and 25
-approximately equivalent to one unit of load imbalance (e.g., the difference
-between (k, k) and (k+1, k-1)); that seemed reasonable to me.
-Adjust the number as necessary.
--}
-marginalLoadCost nr = 225 * fromInteger nr
+assignmentCost pref = (numAsWt 10 + pref) ^ 2 :: Wt
+
+-- Bonus for a first knowledgeable or expert review.
+knowledgeableBonus = 1000 :: Wt
+
+-- Bonus for an additional expert review.
+expertBonus = 1000 :: Wt

diff --git a/program/Test.hs b/program/Test.hs
index 43f93a7..7840b5e 100644 (file)
--- a/program/Test.hs
+++ b/program/Test.hs
@@ -7,6 +7,10 @@ import Data.Array
 import Data.Graph.Inductive.Graph
 import Data.Graph.Inductive.Tree
 
+-- So we can call graphviz' at the GHCi prompt
+import Data.Graph.Inductive.Graphviz
+graphviz' g = Data.Graph.Inductive.Graphviz.graphviz' g
+
 myGraph = mkGraph [(0, ()), (1, ()), (2, ())]
        [(0, 1, 2), (0, 2, 3), (2, 1, -2)] :: Gr () Double 
 
@@ -34,9 +38,9 @@ myPrefsArray = array ((0,0), (myNumRvrs-1,myNumProps-1)) [
        ]
 
 myPrefs = \i j -> myPrefsArray ! (i, j)
-myInst = Instance myNumRvrs myNumProps myPrefs
+myInst = Instance myNumRvrs myNumProps (const 1) myPrefs
 
---rdnGraph = doReduction myInst (const (fromInteger wantExpertReviews))
---(rdnFlowVal, rdnFlowResid) = umcf 0 1 rdnGraph
---rdnFlow = flowDiff rdnGraph rdnFlowResid
+rdnGraph = doReduction myInst
+(rdnFlowVal, rdnFlowResid) = umcf 0 1 rdnGraph
+rdnFlow = flowDiff rdnGraph rdnFlowResid
 myMatching = doMatching myInst

diff --git a/program/show-graph b/program/show-graph
new file mode 100755 (executable)
index 0000000..09133e5
--- /dev/null
+++ b/program/show-graph
@@ -0,0 +1,6 @@
+#!/bin/bash
+set -e
+echo "Paste the escaped graphviz string from ghci."
+IFS='' read -r egvinput
+eval "echo \$'$egvinput'" | dot -Tps -o thegraph.ps
+go thegraph.ps