From d7d9561e4e2ddcae1dfd413e6753ddb890ebc23f Mon Sep 17 00:00:00 2001 From: Matt McCutchen Date: Mon, 23 Jun 2008 17:55:09 -0400 Subject: [PATCH] The proposal matcher. It works on a small example. --- .externalToolBuilders/make match.launch | 10 ++++ .gitignore | 3 ++ .project | 21 ++++++++ BellmanFord.hs | 69 ++++++++++++++++++++++++ Makefile | 5 ++ ProposalMatch.hs | 71 +++++++++++++++++++++++++ ProposalMatchConfig.hs | 29 ++++++++++ Test.hs | 42 +++++++++++++++ UnitMinCostFlow.hs | 60 +++++++++++++++++++++ debug | 5 ++ run | 2 + 11 files changed, 317 insertions(+) create mode 100644 .externalToolBuilders/make match.launch create mode 100644 .gitignore create mode 100644 .project create mode 100644 BellmanFord.hs create mode 100644 Makefile create mode 100644 ProposalMatch.hs create mode 100644 ProposalMatchConfig.hs create mode 100644 Test.hs create mode 100644 UnitMinCostFlow.hs create mode 100755 debug create mode 100755 run 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 -- 2.34.1