--- /dev/null
+<?xml version="1.0" encoding="UTF-8" standalone="no"?>
+<launchConfiguration type="org.eclipse.ui.externaltools.ProgramBuilderLaunchConfigurationType">
+<stringAttribute key="org.eclipse.debug.core.ATTR_REFRESH_SCOPE" value="${working_set:<?xml version="1.0" encoding="UTF-8"?> <launchConfigurationWorkingSet factoryID="org.eclipse.ui.internal.WorkingSetFactory" label="make match outputs" name="make match outputs"> <item factoryID="org.eclipse.ui.internal.model.ResourceFactory" path="/match" type="4"/> </launchConfigurationWorkingSet>}"/>
+<booleanAttribute key="org.eclipse.debug.ui.ATTR_LAUNCH_IN_BACKGROUND" value="false"/>
+<stringAttribute key="org.eclipse.ui.externaltools.ATTR_BUILD_SCOPE" value="${working_set:<?xml version="1.0" encoding="UTF-8"?> <launchConfigurationWorkingSet factoryID="org.eclipse.ui.internal.WorkingSetFactory" label="make match inputs" name="make match inputs"> <item factoryID="org.eclipse.ui.internal.model.ResourceFactory" path="/match" type="4"/> </launchConfigurationWorkingSet>}"/>
+<stringAttribute key="org.eclipse.ui.externaltools.ATTR_LOCATION" value="/usr/bin/make"/>
+<stringAttribute key="org.eclipse.ui.externaltools.ATTR_RUN_BUILD_KINDS" value="full,incremental,auto,"/>
+<booleanAttribute key="org.eclipse.ui.externaltools.ATTR_TRIGGERS_CONFIGURED" value="true"/>
+<stringAttribute key="org.eclipse.ui.externaltools.ATTR_WORKING_DIRECTORY" value="${workspace_loc:/match}"/>
+</launchConfiguration>
--- /dev/null
+/*.hi
+/*.o
+/debugdir
--- /dev/null
+<?xml version="1.0" encoding="UTF-8"?>
+<projectDescription>
+ <name>match</name>
+ <comment></comment>
+ <projects>
+ </projects>
+ <buildSpec>
+ <buildCommand>
+ <name>org.eclipse.ui.externaltools.ExternalToolBuilder</name>
+ <triggers>auto,full,incremental,</triggers>
+ <arguments>
+ <dictionary>
+ <key>LaunchConfigHandle</key>
+ <value><project>/.externalToolBuilders/make match.launch</value>
+ </dictionary>
+ </arguments>
+ </buildCommand>
+ </buildSpec>
+ <natures>
+ </natures>
+</projectDescription>
--- /dev/null
+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
--- /dev/null
+# Let's keep it simple for now.
+all:
+ ghc --make -c *.hs
+clean:
+ rm -f *.hi *.o
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+#!/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
--- /dev/null
+#!/bin/bash
+make && exec ghci Test
Matt McCutchen's Web Site / match / match.git / commitdiff