let ((xlo, ylo), (xhi, yhi)) = bounds arr in
map (\x -> map (\y -> arr ! (x, y)) $ range (ylo, yhi)) $ range (xlo, xhi)
+listOfListsToArray2D ll =
+ listArray ((0, 0), (length ll - 1, length (head ll) - 1)) $ concat ll
+
-- Use instead of amap when the array implementation needs to change.
-- E.g., mapping an unboxed array to an array whose elements must be boxed.
amap2 f arr = funcArray (bounds arr) (\i -> f (arr ! i))
type MatchingEvaluation = Array Int Wt
+-- FIXME this is not really ported to separate preference and expertise
+
evaluateMatching :: PMConfig -> PMInstance -> PMatching -> MatchingEvaluation
-evaluateMatching cfg inst@(PMInstance numRvrs numProps rloadA prefA) matching =
+evaluateMatching cfg inst@(PMInstance numRvrs numProps rloadA prefA _) (PMatching matching) =
let reviewersByProposal = accumArray (flip (:)) []
(0, numProps-1) $ map (\(i,j) -> (j,i)) matching
:: Array Int [Int] in
--- /dev/null
+import PMInstance
+import PMDefaults
+import ProposalMatcher
+import System.IO
+import Data.Array.IArray
+import ArrayStuff
+import Text.CSV
+
+-- pretty silly but it does the job
+swapTabCommaIn s = map (\c -> if c == '\t' then ',' else if c == ',' then '\t' else c) s
+removeQuotes s = filter (\c -> not (c == '"')) s
+parseTSV fname str = case parseCSV fname (swapTabCommaIn str) of
+ Left pe -> Left pe
+ Right ll -> Right $ map (map swapTabCommaIn) ll
+printTSV ll = removeQuotes $ swapTabCommaIn $ printCSV $ map (map swapTabCommaIn) ll
+
+main = do
+ incsv <- hGetContents stdin
+ -- handle errors another day, or let the platform do it
+ let Right inll = parseTSV "standard input" incsv
+ let loadList = head inll
+ let numRvrs = length loadList
+ let loadA = listArray (0, numRvrs-1) (map read loadList)
+ let numProps = length (tail inll) `div` 2
+ -- explicit type on the next line appears to be necessary
+ let pxarr = listOfListsToArray2D (tail inll) :: Array (Int,Int) String
+ -- careful, we end up transposing the array in here
+ let prefA = funcArray ((0,0), (numRvrs-1,numProps-1)) (\(i,j) -> read $ pxarr ! (2*j, i))
+ let expA = funcArray ((0,0), (numRvrs-1,numProps-1)) (\(i,j) -> read $ pxarr ! (2*j+1, i))
+ let theInst = PMInstance numRvrs numProps loadA prefA expA
+ let PMatching theMatching = doMatching pmDefaults theInst
+ hPutStr stdout $ printTSV $ map (\(i, j) -> map show [i, j]) theMatching
# -cpp: Handle GHC 6.6.1 compatibility checks.
# -fglasgow-exts: Handle rank-2 type of RandomizedMonad, among other things.
all:
- ghc -cpp -fglasgow-exts --make -c *.hs
+# ghc -cpp -fglasgow-exts --make -c *.hs
+ ghc -cpp -fglasgow-exts --make *.hs -o match
all-optimized:
- ghc -cpp -fglasgow-exts --make -O -hisuf O.hi -osuf O.o -c *.hs
+# ghc -cpp -fglasgow-exts --make -O -hisuf O.hi -osuf O.o -c *.hs
+ ghc -cpp -fglasgow-exts --make -O -hisuf O.hi -osuf O.o *.hs -o match.O
clean:
rm -f *.hi *.o
+
+# Necessary libraries (on Fedora): ghc-fgl, ghc-csv. Others I miss?
data PMConfig = PMConfig {
minCostFlow :: MinCostFlowImpl,
reviewsEachProposal :: Int,
- prefIsExpert :: Wt -> Bool,
- prefIsKnowledgeable :: Wt -> Bool,
+ expIsExpert :: Wt -> Bool,
+ expIsKnowledgeable :: Wt -> Bool,
prefIsBoring :: Wt -> Bool,
prefIsVeryBoring :: Wt -> Bool,
prefIsConflict :: Wt -> Bool,
-- === Interpretation of the preference values ===
-prefIsExpert = \p -> p <= 10,
-prefIsKnowledgeable = \p -> p <= 20,
+expIsExpert = \x -> x >= 3,
+expIsKnowledgeable = \x -> x >= 2,
-prefIsBoring = \p -> p > 15,
-prefIsVeryBoring = \p -> p > 25,
+prefIsBoring = \p -> p < 50,
+prefIsVeryBoring = \p -> p < 0,
-prefIsConflict = \p -> p >= 40,
+prefIsConflict = \p -> p <= -100,
-- === Tuning parameters for the matcher ===
-- Cost to make a review. Used by the evaluator too.
-- I'm using quadratic cost functions as a first attempt.
-assignmentCost = \pref -> (widenInteger 10 + pref) ^ 2,
+assignmentCost = \pref -> (widenInteger 10 + prefNewToOld pref) ^ 2,
-- Bonus for a first knowledgeable or expert review.
knowledgeableBonus = 1000,
type Wt = Double -- Can be any RealFrac.
widenInteger x = fromInteger (toInteger x)
-data PMInstance = PMInstance
- Int -- numReviewers
- Int -- numProposals
- (UArray Int Wt) -- ! reviewer -> relative load
- (UArray (Int, Int) Wt) -- ! (reviewer, proposal) -> pref
- deriving Eq
+data PMInstance = PMInstance {
+ -- I feel like I am in C, having to namespace these! I guess one
+ -- solution would be to have a typeclass for every field name. A
+ -- specialized solution might desugar to that.
+ pmiNumReviewers :: Int,
+ pmiNumProposals :: Int,
+ pmiRLoad :: UArray Int Wt,
+ pmiRPPref :: UArray (Int, Int) Wt, -- preference: -100 (COI), -99 to 100
+ pmiRPExp :: UArray (Int, Int) Wt -- expertise: 0 to 3
+}
+
+-- Let us shoehorn in the new pref scale.
+prefOldToNew p' = 100 - 5 * p'
+prefNewToOld p = 20 - 0.2 * p
instance Show PMInstance where
- show (PMInstance numRvrs numProps loadA prefA) =
- let theRvrs = [0..numRvrs-1]; theProps = [0..numProps-1] in
- "Instance with " ++ show numRvrs ++ " reviewers and " ++ show numProps ++ " proposals:\n" ++ formatTable (
+ show pmi =
+ let theRvrs = [0..pmiNumReviewers pmi - 1]; theProps = [0..pmiNumProposals pmi - 1] in
+ "Instance with " ++ show (pmiNumReviewers pmi) ++ " reviewers and " ++ show (pmiNumProposals pmi) ++ " proposals:\n" ++ formatTable (
( "" : map (\i -> "R#" ++ show i ) theRvrs) :
- ( "RLoad" : map (\i -> show (loadA ! i) ) theRvrs) :
- map (\j -> ("P#" ++ show j) : map (\i -> show (prefA ! (i, j))) theRvrs) theProps
+ ( "RLoad" : map (\i -> show (pmiRLoad pmi ! i) ) theRvrs) :
+ map (\j -> ("P#" ++ show j) : map (\i -> show (pmiRPPref pmi ! (i, j)) ++ ":" ++ show (pmiRPExp pmi ! (i, j))) theRvrs) theProps
)
-type PMatching = [(Int, Int)]
+newtype PMatching = PMatching [(Int, Int)]
+ deriving Show
PTopic1 jt1 -> expertnessToPref (iTE ! jt1)
PTopic2 jt1 jt2 -> (expertnessToPref (iTE ! jt1)
+ expertnessToPref (iTE ! jt2)) / 2
- in if isConflict then 40 else topicPref * jD - 4)
- return $ PMInstance numRvrs numProps loadA prefA
+ -- Use a formula designed for the old pref scale with the new.
+ in if isConflict then -100 else prefOldToNew (topicPref * jD - 4))
+ let expA = funcArray ((0, 0), (numRvrs-1, numProps-1)) (\(i,j) ->
+ let
+ ReviewerInfo iTE iC = reviewerInfos ! i
+ ProposalInfo jT jD = proposalInfos ! j
+ isConflict = elem j iC
+ topicExp = case jT of
+ PTopic1 jt1 -> 1 + (iTE ! jt1)
+ PTopic2 jt1 jt2 -> 1 + ((iTE ! jt1)
+ + (iTE ! jt2)) / 2
+ in topicExp)
+ return $ PMInstance numRvrs numProps loadA prefA expA
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
+expExpertness cfg x = if expIsExpert cfg x then 2
+ else if expIsKnowledgeable cfg x then 1 else 0
data REdge = REdge {
reIdx :: Int,
(imax, (v1, v2, re{ reIdx = i }) : ies)
doReduction :: PMConfig -> PMInstance -> ReductionResult
-doReduction cfg (PMInstance numRvrs numProps rloadA prefA) =
+doReduction cfg (PMInstance numRvrs numProps rloadA prefA expA) =
let
source = 0
sink = 1
i <- [0 .. numRvrs - 1]
j <- [0 .. numProps - 1]
let pref = prefA ! (i, j)
+ let xp = expA ! (i, j)
-- 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 cfg pref),
- propNode j (prefExpertness cfg pref),
+ propNode j (expExpertness cfg xp),
REdge (edIdx (i, j))
(if prefIsConflict cfg pref then 0 else 1)
(assignmentCost cfg pref))]
-- Returns a list of reviews as ordered pairs (reviewer#, proposal#).
doMatching :: PMConfig -> PMInstance -> PMatching
-doMatching cfg inst@(PMInstance numRvrs numProps _ _) =
+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
then [(i, j)]
else []
in
- sort pairs -- for prettiness
+ PMatching (sort pairs) -- for prettiness
(myNumRvrs, myNumProps) = (5, 3)
-myPrefs = transposeArray $ listArray ((0,0), (myNumProps-1,myNumRvrs-1)) [
+myPrefs = transposeArray $ listArray ((0,0), (myNumProps-1,myNumRvrs-1)) $
+ map prefOldToNew [
15, 10, 15, 40, 20,
30, 7, 10, 15, 15,
15, 25, 20, 20, 15
] :: UArray (Int, Int) Wt
-myInst = PMInstance myNumRvrs myNumProps (constArray (0, myNumRvrs-1) 1) myPrefs
+-- This data is pretty made-up... ~ 2011-07-11
+myExps = transposeArray $ listArray ((0,0), (myNumProps-1,myNumRvrs-1)) [
+ 2, 2, 1, 3, 1,
+ 0, 3, 2, 2, 2,
+ 2, 1, 1, 2, 2
+ ] :: UArray (Int, Int) Wt
+
+myInst = PMInstance myNumRvrs myNumProps (constArray (0, myNumRvrs-1) 1) myPrefs myExps
rdnResult = doReduction pmDefaults myInst
ReductionResult rrg rrso rrsi rreib rredi = rdnResult
(n1, n2, REdgeF i ca (fa ! i) co)) $ labEdges g) :: Gr () REdgeF
showInstanceAsGraph :: PMInstance -> PMatching -> Gr String String
-showInstanceAsGraph (PMInstance numRvrs numProps rloadA prefA) matchedPairs =
+showInstanceAsGraph (PMInstance numRvrs numProps rloadA prefA expA) (PMatching matchedPairs) =
let
rvrNode i = i
propNode j = numRvrs + j
i <- [0..numRvrs-1]
j <- [0..numProps-1]
return (rvrNode i, propNode j,
- parenthesizeIf (elem (i, j) matchedPairs) $ show (prefA ! (i, j)))
+ parenthesizeIf (elem (i, j) matchedPairs) $ show (prefA ! (i, j)) ++ ":" ++ show (expA ! (i, j)))
in mkGraph theNodes theEdges
goFile :: String -> IO ()
runEvaluation cfg nr np = do
let inst = runRandom myGen $ randomInstance cfg nr np
putStr (show inst ++ "\n")
- let m0 = doMatching cfg{loadTolerance = 0} inst
+ let PMatching m0 = doMatching cfg{loadTolerance = 0} inst
putStr ("Matching with load tolerance 0:\n" ++ show m0 ++ "\n")
- let m1 = doMatching cfg{loadTolerance = 1} inst
+ let PMatching m1 = doMatching cfg{loadTolerance = 1} inst
putStr ("Matching with load tolerance 1:\n" ++ show m1 ++ "\n")
putStr ("Differences:\n" ++ show (m0 /\ m1) ++ "\n")
- let e0 = evaluateMatching cfg{loadTolerance = 0} inst m0
+ let e0 = evaluateMatching cfg{loadTolerance = 0} inst (PMatching m0)
putStr ("Evaluation of first matching:\n" ++ show e0 ++ "\n")
- let e1 = evaluateMatching cfg{loadTolerance = 1} inst m1
+ let e1 = evaluateMatching cfg{loadTolerance = 1} inst (PMatching m1)
putStr ("Evaluation of second matching:\n" ++ show e1 ++ "\n")
putStr ("Evaluation differences:\n" ++
show (sortedDiffEvaluations e0 e1) ++ "\n")
--- /dev/null
+1 1 1 1 1
+25 50 25 -100 0
+2 2 1 3 1
+-50 65 50 25 25
+0 3 2 2 2
+25 -25 0 0 25
+2 1 1 2 2
Matt McCutchen's Web Site / match / match.git / commitdiff