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 Instance = Instance
	Int                -- numReviewers
	Int                -- numProposals
	(Int -> Wt)        -- reviewer -> relative load
	(Int -> Int -> Wt) -- reviewer -> proposal -> pref

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 boringness = 2 + 3*i + boringness
		propNode j expertness = 2 + 3*numRvrs + 3*j + expertness
		numNodes = 2 + 3*numRvrs + 3*numProps
		in
	let
		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]
			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 []
				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]
			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 :: 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 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 in
	let flow1 = flowDiff graph1 (snd (umcf source sink graph1)) in
	let pairs = do
		i <- [0 .. numRvrs - 1]
		boringness <- [0, 1, 2]
		n <- suc flow1 (rvrNode i boringness)
		if n >= firstPropNode
			then [(i, idPropNode n)]
			else []
		in
	sort pairs -- for prettiness