First attempt at evaluating the quality of matchings.

diff --git a/program/ArrayStuff.hs b/program/ArrayStuff.hs
index 8fcced9..ceb7516 100644 (file)
--- a/program/ArrayStuff.hs
+++ b/program/ArrayStuff.hs
@@ -18,3 +18,6 @@ array2DtoListOfLists arr =
 -- 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))
+
+-- Like amap2 but the mapping function is also passed the index.
+aixmap f arr = funcArray (bounds arr) (\i -> f i (arr ! i))

diff --git a/program/Evaluation.hs b/program/Evaluation.hs
new file mode 100644 (file)
index 0000000..2b1fdaf
--- /dev/null
+++ b/program/Evaluation.hs
@@ -0,0 +1,40 @@
+module Evaluation where
+import PMInstance
+import ProposalMatcher
+
+import Data.Array.IArray
+import Data.List
+import ArrayStuff
+
+type MatchingEvaluation = Array Int Wt
+
+evaluateMatching :: PMConfig -> PMInstance -> PMatching -> MatchingEvaluation
+evaluateMatching cfg inst@(PMInstance numRvrs numProps rloadA prefA) matching =
+       let reviewersByProposal = accumArray (flip (:)) []
+               (0, numProps-1) $ map (\(i,j) -> (j,i)) matching
+               :: Array Int [Int] in
+       aixmap (\j rl ->
+               -- Sort this proposal's reviews, best first.
+               let jPrefsInc = sort $ map (\i -> prefA ! (i,j)) rl in
+               -- Charge each review's assignmentCost.
+               sum $ zipWith (\wt prf -> (numAsWt wt) * assignmentCost cfg prf)
+                       -- The assignment costs are weighted by
+                       -- reviewsEachProposal, ..., 1 from best to worst.
+                       -- (It's most important for the best to be good.)
+                       (take (reviewsEachProposal cfg) $
+                               iterate (subtract 1) (reviewsEachProposal cfg))
+                       -- A missing review counts as a preference of 50 (really bad).
+                       (jPrefsInc ++ repeat 50)
+                       )
+               reviewersByProposal
+
+doEvaluateMatching :: PMConfig -> PMInstance -> MatchingEvaluation
+doEvaluateMatching cfg inst =
+       let matching = doMatching cfg inst in
+       evaluateMatching cfg inst matching
+
+-- Sorted from negative cost changes (better in e2)
+-- to positive cost changes (worse in e2).
+sortedDiffEvaluations :: MatchingEvaluation -> MatchingEvaluation -> [Wt]
+sortedDiffEvaluations e1 e2 =
+       sort $ zipWith (-) (elems e1) (elems e2)

diff --git a/program/Test.hs b/program/Test.hs
index 8307e38..1530aa9 100644 (file)
--- a/program/Test.hs
+++ b/program/Test.hs
@@ -13,7 +13,10 @@ module Test (
        
        -- Run randomized things.
        module System.Random,
-       module RandomizedMonad
+       module RandomizedMonad,
+       
+       -- Evaluate.
+       module Evaluation
 ) where
 import TestUtils
 import PMInstance
@@ -22,6 +25,7 @@ import ProposalMatcher
 import PMDefaults
 import System.Random
 import RandomizedMonad
+import Evaluation
 
 -- Other imports we need
 import BellmanFord
@@ -71,3 +75,8 @@ rrg2 = flowAnnotate rrg rdnFlowArray
 myMatching = doMatching pmDefaults myInst
 
 iGraph = showInstanceAsGraph myInst myMatching -- Visualize me!
+
+-- Evaluation!
+eInst = runRandom myGen $ randomInstance 20 50
+eval1 = doEvaluateMatching pmDefaults eInst
+eval2 = doEvaluateMatching pmDefaults{loadTolerance = 2} eInst