From eb6c3c9f810799e3bfe8cd302dd9d00f97b4baf7 Mon Sep 17 00:00:00 2001
From: Matt McCutchen <matt@mattmccutchen.net>
Date: Mon, 28 Jul 2008 11:59:55 -0400
Subject: [PATCH] First attempt at evaluating the quality of matchings.

---
 program/ArrayStuff.hs |  3 +++
 program/Evaluation.hs | 40 ++++++++++++++++++++++++++++++++++++++++
 program/Test.hs       | 11 ++++++++++-
 3 files changed, 53 insertions(+), 1 deletion(-)
 create mode 100644 program/Evaluation.hs

diff --git a/program/ArrayStuff.hs b/program/ArrayStuff.hs
index 8fcced9..ceb7516 100644
--- 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
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
--- 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
-- 
2.34.1