- Add the notes Samir emailed me on 2008-07-06.

[match/match.git] / program / ProposalMatch.hs

module ProposalMatch where
import UnitMinCostFlow
import Data.Array.IArray
import Data.Graph.Inductive.Graph
import Data.Graph.Inductive.Tree
import Data.List

import ProposalMatchConfig

data Real wt => Instance wt = Instance Int Int (Int -> Int -> wt)

doReduction :: Real wt => Instance wt -> (Int -> Int) -> Gr () wt
doReduction (Instance numRvrs numProps prefF) expertCapF =
	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]]
		in
	let
		loadEdges = do
			i <- [0 .. numRvrs - 1]
			l <- [1 .. maxReviewerLoad]
			return (source, rvrNode i, marginalLoadCost l)
		prefEdges = 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
			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
		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) =
	-- 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
		in
	let graph1 = doReduction inst (const (fromInteger wantExpertReviews)) in
	let flow1 = flowDiff graph1 (snd (umcf source sink graph1)) in
	let expertCapF j = 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
	sort pairs -- for prettiness