Matt McCutchen's Web Site - match/match.git/blame_incremental

... / ...

Commit	Line	Data
	1	module ProposalMatcher where
	2	import Data.Array.IArray
	3	import Data.Graph.Inductive.Graph
	4	import Data.Graph.Inductive.Tree
	5	import Data.List
	6
	7	import Instance
	8	import IMinCostFlow
	9
	10	data PMConfig = PMConfig {
	11	minCostFlow :: MinCostFlowImpl,
	12	reviewsEachProposal :: Int,
	13	prefIsExpert :: Wt -> Bool,
	14	prefIsKnowledgeable :: Wt -> Bool,
	15	prefIsBoring :: Wt -> Bool,
	16	prefIsVeryBoring :: Wt -> Bool,
	17	prefIsConflict :: Wt -> Bool,
	18	loadTolerance :: Int,
	19	marginalLoadCost :: Wt -> Wt,
	20	marginalBoringCost :: Wt -> Wt,
	21	marginalVeryBoringCost :: Wt -> Wt,
	22	assignmentCost :: Wt -> Wt,
	23	knowledgeableBonus :: Wt,
	24	expertBonus :: Wt
	25	}
	26
	27	prefBoringness cfg p = if prefIsVeryBoring cfg p then 2
	28	else if prefIsBoring cfg p then 1 else 0
	29	prefExpertness cfg p = if prefIsExpert cfg p then 2
	30	else if prefIsKnowledgeable cfg p then 1 else 0
	31
	32	data REdge = REdge {
	33	reIdx :: Int,
	34	reCap :: Int,
	35	reCost :: Wt
	36	}
	37
	38	instance Show REdge where
	39	show (REdge idx cap cost) = "#" ++ (show idx) ++ ": "
	40	++ (show cap) ++ " @ " ++ (show cost)
	41
	42	data ReductionResult = ReductionResult {
	43	rrGraph :: Gr () REdge,
	44	rrSource :: Node,
	45	rrSink :: Node,
	46	rrEIdxBounds :: (Int, Int),
	47	rrEDIdx :: (Int, Int) -> Int
	48	}
	49
	50	-- Hack: show as much of the reduction result as we easily can
	51	data RR1 = RR1 (Gr () REdge) Node Node (Int, Int) deriving Show
	52	instance Show ReductionResult where
	53	show (ReductionResult g so si eib _) = show (RR1 g so si eib)
	54
	55	indexEdges :: Int -> [(Int, Int, REdge)] -> (Int, [(Int, Int, REdge)])
	56	indexEdges i [] = (i, [])
	57	indexEdges i ((v1, v2, re):es) =
	58	let (imax, ies) = indexEdges (i+1) es in
	59	(imax, (v1, v2, re{ reIdx = i }) : ies)
	60
	61	doReduction :: PMConfig -> Instance -> ReductionResult
	62	doReduction cfg (Instance numRvrs numProps rloadA prefA) =
	63	let
	64	source = 0
	65	sink = 1
	66	rvrNode i boringness = 2 + 3*i + boringness
	67	propNode j expertness = 2 + 3numRvrs + 3j + expertness
	68	numNodes = 2 + 3numRvrs + 3numProps
	69	edIdx (i, j) = i*numProps + j
	70	in
	71	let
	72	totalReviews = (reviewsEachProposal cfg) * numProps
	73	totalRelativeLoad = foldl (+) 0 (map (rloadA !) [0 .. numRvrs - 1])
	74	targetLoad i = ceiling (numAsWt totalReviews * (rloadA ! i) / totalRelativeLoad)
	75	-- A...H refer to idea book p.429
	76	edgesABC = do
	77	i <- [0 .. numRvrs - 1]
	78	let tl = targetLoad i
	79	let freeEdgeA = (source, rvrNode i 0, REdge undefined tl 0)
	80	let nonfreeEdgesA = do
	81	l <- [tl .. tl + (loadTolerance cfg) - 1]
	82	let costA = marginalLoadCost cfg ((numAsWt (l - tl) + 1/2) / numAsWt (loadTolerance cfg))
	83	[(source, rvrNode i 0, REdge undefined 1 costA)]
	84	let edgesBC = do
	85	l <- [0 .. tl + (loadTolerance cfg) - 1]
	86	let costB = marginalBoringCost cfg ((numAsWt l + 1/2) / numAsWt tl)
	87	let edgeB = (rvrNode i 0, rvrNode i 1, REdge undefined 1 costB)
	88	let costC = marginalVeryBoringCost cfg ((numAsWt l + 1/2) / numAsWt tl)
	89	let edgeC = (rvrNode i 1, rvrNode i 2, REdge undefined 1 costC)
	90	[edgeB, edgeC]
	91	[freeEdgeA] ++ nonfreeEdgesA ++ edgesBC
	92	edgesD = do
	93	i <- [0 .. numRvrs - 1]
	94	j <- [0 .. numProps - 1]
	95	let pref = prefA ! (i, j)
	96	-- We must generate an edge even if there is a conflict
	97	-- of interest; otherwise we'll fail to read its flow
	98	-- value in doMatching.
	99	[(rvrNode i (prefBoringness cfg pref),
	100	propNode j (prefExpertness cfg pref),
	101	REdge (edIdx (i, j))
	102	(if prefIsConflict cfg pref then 0 else 1)
	103	(assignmentCost cfg pref))]
	104	edgesEFGH = do
	105	j <- [0 .. numProps - 1]
	106	let edgeE = (propNode j 2, propNode j 0, REdge undefined 1 (-(expertBonus cfg)))
	107	let edgeF = (propNode j 2, propNode j 1, REdge undefined (reviewsEachProposal cfg) 0)
	108	let edgeGFirst = (propNode j 1, propNode j 0, REdge undefined 1 (-(knowledgeableBonus cfg)))
	109	let edgeGRest = (propNode j 1, propNode j 0, REdge undefined (reviewsEachProposal cfg - 1) 0)
	110	let edgeH = (propNode j 0, sink, REdge undefined (reviewsEachProposal cfg) 0)
	111	[edgeE, edgeF, edgeGFirst, edgeGRest, edgeH]
	112	theNodes = [(x, ()) \| x <- [0 .. numNodes - 1]]
	113	-- Index the non-D edges
	114	unindexedEdges = edgesABC ++ edgesEFGH
	115	(imax, reindexedEdges) = indexEdges (numRvrs*numProps) unindexedEdges
	116	theEdges = edgesD ++ reindexedEdges
	117	in
	118	ReductionResult (mkGraph theNodes theEdges) source sink (0, imax-1) edIdx
	119
	120	-- Returns a list of reviews as ordered pairs (reviewer#, proposal#).
	121	doMatching :: PMConfig -> Instance -> [(Int, Int)]
	122	doMatching cfg inst@(Instance numRvrs numProps _ _) =
	123	let ReductionResult graph source sink idxBounds edIdx = doReduction cfg inst in
	124	let flowArray = minCostFlow cfg idxBounds reIdx reCap reCost graph (source, sink) in
	125	let pairs = do
	126	i <- [0 .. numRvrs - 1]
	127	j <- [0 .. numProps - 1]
	128	if flowArray ! edIdx (i, j) == 1
	129	then [(i, j)]
	130	else []
	131	in
	132	sort pairs -- for prettiness