From: Matt McCutchen Date: Mon, 23 Jun 2008 21:55:09 +0000 (-0400) Subject: The proposal matcher. It works on a small example. X-Git-Url: https://mattmccutchen.net/match/match.git/commitdiff_plain/d7d9561e4e2ddcae1dfd413e6753ddb890ebc23f The proposal matcher. It works on a small example. --- d7d9561e4e2ddcae1dfd413e6753ddb890ebc23f diff --git a/.externalToolBuilders/make match.launch b/.externalToolBuilders/make match.launch new file mode 100644 index 0000000..0ff90ed --- /dev/null +++ b/.externalToolBuilders/make match.launch @@ -0,0 +1,10 @@ + + + + + + + + + + diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..ccd4172 --- /dev/null +++ b/.gitignore @@ -0,0 +1,3 @@ +/*.hi +/*.o +/debugdir diff --git a/.project b/.project new file mode 100644 index 0000000..b302f1b --- /dev/null +++ b/.project @@ -0,0 +1,21 @@ + + + match + + + + + + org.eclipse.ui.externaltools.ExternalToolBuilder + auto,full,incremental, + + + LaunchConfigHandle + <project>/.externalToolBuilders/make match.launch + + + + + + + diff --git a/BellmanFord.hs b/BellmanFord.hs new file mode 100644 index 0000000..506acd9 --- /dev/null +++ b/BellmanFord.hs @@ -0,0 +1,69 @@ +module BellmanFord {-(spTree)-} where +import Data.Graph.Inductive.Graph +import Data.Graph.Inductive.Internal.Queue +import Data.Graph.Inductive.Internal.RootPath +import Data.Array.Diff + +data NodeInfo b = NodeInfo { + path :: Maybe [LNode b], + changed :: Bool +} +data Graph gr => BFState gr a b = BFState { + theGraph :: gr a b, + nis :: DiffArray Node (NodeInfo b), + changedQ :: Queue Node +} + +nisToLRTree nis = do + ni <- elems nis + case path ni of + Just lnl -> return (LP lnl) + Nothing -> fail "Node is unreachable" + +offerPath :: (Graph gr, Real b) => BFState gr a b -> [LNode b] -> BFState gr a b +offerPath bfs newPath@((dest, newDist): _) = + -- Is newPath the first path to dest, or better than the previous one? + let adoptPath = + case path (nis bfs ! dest) of + Nothing -> True + Just ((_, oldDist) : _) -> newDist < oldDist + in + if adoptPath then + bfs{ + -- Update NodeInfo with the new path. + nis = nis bfs // [(dest, NodeInfo (Just newPath) True)], + changedQ = if changed (nis bfs ! dest) + then changedQ bfs -- Already on the queue; leave as is. + else queuePut dest (changedQ bfs) -- Add to queue. + } + else bfs -- Don't update anything. + +processEdge :: (Graph gr, Real b) => [LNode b] -> LEdge b -> BFState gr a b -> BFState gr a b +processEdge srcPath@((_, srcDist) : _) (_, dest, edgeLen) bfs = + let newPath = (dest, srcDist + edgeLen) : srcPath in + offerPath bfs newPath + +search :: (Graph gr, Real b) => BFState gr a b -> LRTree b +search bfs = + if queueEmpty (changedQ bfs) then + -- Finished. + nisToLRTree (nis bfs) + else + -- Process a changed node from the queue. + let (src, moreQ) = queueGet (changedQ bfs) in + let srcNI = nis bfs ! src in + -- Clear src's changed flag. + let bfs1 = bfs{nis = nis bfs // [(src, srcNI{changed = False})], changedQ = moreQ} in + let Just srcPath = path srcNI in + let outEdges = out (theGraph bfs) src in + let newBFS = foldr (processEdge srcPath) bfs1 outEdges in + search newBFS + +spTree :: (Graph gr, Real b) => Node -> gr a b -> LRTree b +spTree source theGraph = let theNodes = range (nodeRange theGraph) in + let emptyBFS = BFState theGraph + (array (nodeRange theGraph) (map (\n -> (n, NodeInfo Nothing False)) theNodes)) + mkQueue in + -- Start with a zero-length path to the source. + let initBFS = offerPath emptyBFS [(source, 0)] in + search initBFS diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..a86037f --- /dev/null +++ b/Makefile @@ -0,0 +1,5 @@ +# Let's keep it simple for now. +all: + ghc --make -c *.hs +clean: + rm -f *.hi *.o diff --git a/ProposalMatch.hs b/ProposalMatch.hs new file mode 100644 index 0000000..0cddc9b --- /dev/null +++ b/ProposalMatch.hs @@ -0,0 +1,71 @@ +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 diff --git a/ProposalMatchConfig.hs b/ProposalMatchConfig.hs new file mode 100644 index 0000000..39055c1 --- /dev/null +++ b/ProposalMatchConfig.hs @@ -0,0 +1,29 @@ +module ProposalMatchConfig where + +prefIsExpert p = p <= 10 +prefIsConflict p = p >= 40 + +{- +Each proposal should have 'wantExpertReviews' expert reviews plus +'wantGeneralReviews' general reviews (can be by experts). If we +fall short on expert reviews, we give 'wantReviewsSubstForExpert' +additional general reviews for each expert review we fell short. +Values 2, 1, 2 give the ">= 3 of which >= 1 is expert, failing that >= 4" +criterion that Samir indicated. +-} +wantGeneralReviews = 2 +wantExpertReviews = 1 +wantReviewsSubstForExpert = 2 + +-- A hard limit that we hope will never be hit. +maxReviewerLoad = 10 + +-- I'm using quadratic cost functions as a first attempt. +prefToCost p = p ^ 2 +{- +I chose the number 225 to make the preference difference between 20 and 25 +approximately equivalent to one unit of load imbalance (e.g., the difference +between (k, k) and (k+1, k-1)); that seemed reasonable to me. +Adjust the number as necessary. +-} +marginalLoadCost nr = 225 * fromInteger nr diff --git a/Test.hs b/Test.hs new file mode 100644 index 0000000..43f93a7 --- /dev/null +++ b/Test.hs @@ -0,0 +1,42 @@ +module Test where +import BellmanFord +import UnitMinCostFlow +import ProposalMatch +import ProposalMatchConfig +import Data.Array +import Data.Graph.Inductive.Graph +import Data.Graph.Inductive.Tree + +myGraph = mkGraph [(0, ()), (1, ()), (2, ())] + [(0, 1, 2), (0, 2, 3), (2, 1, -2)] :: Gr () Double + +spTree1 = spTree 0 myGraph + +(flowVal, flowResid) = umcf 0 1 myGraph + +-- Example from idea book p. 425 +{- +(myNumRvrs, myNumProps) = (4, 3) + +myPrefsArray = array ((0,0), (myNumRvrs-1,myNumProps-1)) [ + ((0, 0), 15), ((1, 0), 10), ((2, 0), 15), ((3, 0), 40), + ((0, 1), 30), ((1, 1), 7), ((2, 1), 10), ((3, 1), 15), + ((0, 2), 15), ((1, 2), 25), ((2, 2), 20), ((3, 2), 20) + ] +-} + +(myNumRvrs, myNumProps) = (5, 3) + +myPrefsArray = array ((0,0), (myNumRvrs-1,myNumProps-1)) [ + ((0, 0), 15), ((1, 0), 10), ((2, 0), 15), ((3, 0), 40), ((4, 0), 20), + ((0, 1), 30), ((1, 1), 7), ((2, 1), 10), ((3, 1), 15), ((4, 1), 15), + ((0, 2), 15), ((1, 2), 25), ((2, 2), 20), ((3, 2), 20), ((4, 2), 15) + ] + +myPrefs = \i j -> myPrefsArray ! (i, j) +myInst = Instance myNumRvrs myNumProps myPrefs + +--rdnGraph = doReduction myInst (const (fromInteger wantExpertReviews)) +--(rdnFlowVal, rdnFlowResid) = umcf 0 1 rdnGraph +--rdnFlow = flowDiff rdnGraph rdnFlowResid +myMatching = doMatching myInst diff --git a/UnitMinCostFlow.hs b/UnitMinCostFlow.hs new file mode 100644 index 0000000..24e44bc --- /dev/null +++ b/UnitMinCostFlow.hs @@ -0,0 +1,60 @@ +module UnitMinCostFlow (umcf, flowDiff) where +import BellmanFord +import Data.Graph.Inductive.Graph +import Data.Graph.Inductive.Internal.RootPath +import Data.List + +maybeDelete :: Eq a => a -> [a] -> Maybe [a] +maybeDelete _ [] = Nothing +maybeDelete e (h:t) = if e == h + then return t + else do t1 <- maybeDelete e t; return (h:t1) + +-- If the edge occurs in the graph, return Just the graph with one occurrence +-- deleted; otherwise return Nothing. (delLEdge deletes all occurrences.) +maybeDelOneLEdge :: (DynGraph gr, Eq b) => LEdge b -> gr a b -> Maybe (gr a b) +maybeDelOneLEdge (src, dest, lbl) theGraph = + let (mc, moreGraph) = match src theGraph in do + (p, v, l, s) <- mc + s2 <- maybeDelete (lbl, dest) s + return ((p, v, l, s2) & moreGraph) + +flipEdge (src, dest, lbl) = (dest, src, -lbl) + +flipEdgeIn :: (DynGraph gr, Real b) => LEdge b -> gr a b -> gr a b +flipEdgeIn edge theGraph = + let Just graph1 = maybeDelOneLEdge edge theGraph in + insEdge (flipEdge edge) graph1 + +augment :: (DynGraph gr, Real b) => [LNode b] -> gr a b -> gr a b +augment augPath@((v1, d1) : t1) theGraph = + case t1 of + [] -> theGraph + (v2, d2) : t2 -> augment (tail augPath) + (flipEdgeIn (v1, v2, d2 - d1) theGraph) + +-- Find a min-cost flow from s to t in theGraph. +-- Each edge of the input graph has unit capacity and cost given by its label. +-- Returns: flow value, residual graph. +umcf :: (DynGraph gr, Real b) => Node -> Node -> gr a b -> (b, gr a b) +umcf s t theGraph = + -- Use Bellman-Ford to find an augmenting path from s to t, if one exists. + -- NOTE: getLPath reverses it into s-to-t order! + let LP augPath = getLPath t (spTree s theGraph) in + if null augPath then + -- Finished. + (0, theGraph) + else + -- Augment, and continue flowing in the resulting graph. + let graph2 = augment augPath theGraph in + let (fval1, resid) = umcf s t graph2 in (fval1 + 1, resid) + +-- Diffs an original graph and a residual graph, producing the flow graph. +flowDiff :: (DynGraph gr, Real b) => gr a b -> gr a b -> gr a b +flowDiff ograph rgraph = case labEdges ograph of + [] -> mkGraph (labNodes ograph) [] + oedge:_ -> let Just ograph2 = maybeDelOneLEdge oedge ograph in + case maybeDelOneLEdge oedge rgraph of + Just rgraph2 -> flowDiff ograph2 rgraph2 + Nothing -> let Just rgraph2 = maybeDelOneLEdge (flipEdge oedge) rgraph in + insEdge oedge (flowDiff ograph2 rgraph2) \ No newline at end of file diff --git a/debug b/debug new file mode 100755 index 0000000..6ede1be --- /dev/null +++ b/debug @@ -0,0 +1,5 @@ +#!/bin/bash +# Let ghci see only the source so it loads the modules debuggably. +mkdir -p debugdir +(cd debugdir && ln -fs ../*.hs .) +exec ghci -i -idebugdir Test diff --git a/run b/run new file mode 100755 index 0000000..04362f3 --- /dev/null +++ b/run @@ -0,0 +1,2 @@ +#!/bin/bash +make && exec ghci Test