From: Matt McCutchen Date: Thu, 10 Jul 2008 19:23:46 +0000 (-0400) Subject: The random instance generator and other improvements. X-Git-Url: https://mattmccutchen.net/match/match.git/commitdiff_plain/967c39efa10c8a2d74812741cd7a2a96602a6210 The random instance generator and other improvements. - Split Instance into its own file, change it to use arrays, and implement Show. - Add random InstanceGenerator using RandomizedMonad. - Make Test export more stuff for use from GHCi. --- diff --git a/program/ArrayStuff.hs b/program/ArrayStuff.hs new file mode 100644 index 0000000..abf14c7 --- /dev/null +++ b/program/ArrayStuff.hs @@ -0,0 +1,18 @@ +module ArrayStuff where +import Data.Ix +import Data.Array.IArray + +funcArray lohi f = listArray lohi $ map f $ range lohi + +transposeArray arr = + let swap (x, y) = (y, x) in + let (lo, hi) = bounds arr in + ixmap (swap lo, swap hi) swap arr + +array2DtoListOfLists arr = + let ((xlo, ylo), (xhi, yhi)) = bounds arr in + map (\x -> map (\y -> arr ! (x, y)) $ range (ylo, yhi)) $ range (xlo, xhi) + +-- Use instead of amap when the array implementation needs to change. +-- E.g., mapping an unboxed array to an array whose elements must be boxed. +amap2 f arr = funcArray (bounds arr) (\i -> f (arr ! i)) diff --git a/program/Formatter.hs b/program/Formatter.hs new file mode 100644 index 0000000..5ee5a00 --- /dev/null +++ b/program/Formatter.hs @@ -0,0 +1,17 @@ +module Formatter where +import Data.List + +padWith :: a -> Int -> [a] -> [a] +padWith _ 0 l = l +padWith e n [] = replicate n e +padWith e (n+1) (h:t) = h:(padWith e n t) + +formatTable :: [[String]] -> String +formatTable cells = + let columnWidths = map (\col -> maximum $ map length col) + $ transpose cells in + intercalate "\n" $ + map (\row -> + let rowCells = zipWith (padWith ' ') columnWidths row in + intercalate " " rowCells + ) cells diff --git a/program/Instance.hs b/program/Instance.hs new file mode 100644 index 0000000..95e00ee --- /dev/null +++ b/program/Instance.hs @@ -0,0 +1,21 @@ +module Instance where +import Data.Array.IArray +import Data.Array.Unboxed +import ArrayStuff +import Formatter + +type Wt = Double -- must implement RealFrac + +data Instance = Instance + Int -- numReviewers + Int -- numProposals + (UArray Int Wt) -- ! reviewer -> relative load + (UArray (Int, Int) Wt) -- ! (reviewer, proposal) -> pref + deriving Eq + +instance Show Instance where + show (Instance numRvrs numProps loadA prefA) = + "Instance: " ++ show numRvrs ++ " reviewers, " ++ show numProps ++ " proposals\n" + ++ "Reviewer relative load: " ++ show loadA ++ "\n" + ++ "Preferences:\n" + ++ formatTable (array2DtoListOfLists (amap2 show prefA :: Array (Int, Int) String)) diff --git a/program/InstanceGenerator.hs b/program/InstanceGenerator.hs new file mode 100644 index 0000000..cf61e6a --- /dev/null +++ b/program/InstanceGenerator.hs @@ -0,0 +1,78 @@ +module InstanceGenerator where +import Instance +import System.Random +import RandomizedMonad +import Data.Array.IArray +import ArrayStuff + +randomMap :: RandomGen g => g -> (g -> a -> b) -> [a] -> [b] +randomMap g f l = case l of + [] -> [] + h:t -> let (g1, g2) = split g in (f g1 h):(randomMap g2 f t) +randomRep :: RandomGen g => g -> (g -> a) -> Int -> [a] +randomRep g f n = if n == 0 then [] + else let (g1, g2) = split g in (f g1):(randomRep g2 f (n-1)) + +numTopics = 20 + +-- Expertise on each of the topics +type ReviewerInfo = Array Int Double + +randomReviewerInfo = do + list <- sequence $ replicate numTopics $ + withProb [(0.15, return 2), (0.4, return 1)] (return 0) + return $ listArray (0, numTopics-1) list + +-- One topic or two different topics +data ProposalTopics = PTopic1 Int | PTopic2 Int Int + +--type ProposalAuthors = Maybe Int + +type ProposalInfo = (ProposalTopics, Wt) + +randomProposalTopics = do + t1 <- mrandomR (0, numTopics-1) + withProb [(0.5, return $ PTopic1 t1)] (do + t2 <- filterRandomized (/= t1) $ mrandomR (0, numTopics-1) + return $ PTopic2 t1 t2 + ) + +-- Add conflict of interest later. +{-- +randomProposalAuthors = do + withProb [(0.5, return [])] (do + a1 <- mrandomR (0, numRvrs-1) + withProb [(0.5, return [a1])] (do + a2 <- filterRandomized (/= a1) $ mrandomR (0, numRvrs-1) + return [a1,a2] + ) + ) +--} + +randomProposalInfo = do + topics <- randomProposalTopics + diff <- mrandomR (3, 5) + return (topics, fromInteger diff) + +expertnessToPref expertness = if expertness == 0 then 7 + else if expertness == 1 then 5 + else 3 + +randomInstance :: Int -> Int -> Randomized Instance +randomInstance numRvrs numProps = do + reviewerInfosList <- sequence $ replicate numRvrs $ randomReviewerInfo + -- reviewerProfs is an array of arrays. + -- A pair-indexed array might be better... + let reviewerInfos = listArray (0, numRvrs-1) reviewerInfosList :: Array Int ReviewerInfo + proposalInfosList <- sequence $ replicate numProps $ randomProposalInfo + let proposalInfos = listArray (0, numProps-1) proposalInfosList :: Array Int ProposalInfo + let loadA = funcArray (0, numRvrs-1) $ const 1 + let prefA = funcArray ((0, 0), (numRvrs-1, numProps-1)) (\(i,j) -> + let + ii = reviewerInfos ! i + jj = proposalInfos ! j + topicPref = case fst jj of + PTopic1 t1 -> expertnessToPref (ii ! t1) + PTopic2 t1 t2 -> (expertnessToPref (ii ! t1) + expertnessToPref (ii ! t2)) / 2 + in topicPref * snd jj - 4) + return $ Instance numRvrs numProps loadA prefA diff --git a/program/Makefile b/program/Makefile index a86037f..eb0274a 100644 --- a/program/Makefile +++ b/program/Makefile @@ -1,5 +1,5 @@ # Let's keep it simple for now. all: - ghc --make -c *.hs + ghc -fglasgow-exts --make -c *.hs clean: rm -f *.hi *.o diff --git a/program/ProposalMatch.hs b/program/ProposalMatcher.hs similarity index 83% rename from program/ProposalMatch.hs rename to program/ProposalMatcher.hs index 028f22c..c0bd7a0 100644 --- a/program/ProposalMatch.hs +++ b/program/ProposalMatcher.hs @@ -1,17 +1,12 @@ -module ProposalMatch where +module ProposalMatcher 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 +import Instance +import ProposalMatcherConfig prefBoringness p = if prefIsVeryBoring p then 2 else if prefIsBoring p then 1 else 0 @@ -19,7 +14,7 @@ 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) = +doReduction (Instance numRvrs numProps rloadA prefA) = let source = 0 sink = 1 @@ -29,8 +24,8 @@ doReduction (Instance numRvrs numProps rloadF prefF) = in let totalReviews = reviewsEachProposal * numProps - totalRelativeLoad = foldl (+) 0 (map rloadF [0 .. numRvrs - 1]) - targetLoad i = ceiling (numAsWt totalReviews * rloadF i / totalRelativeLoad) + totalRelativeLoad = foldl (+) 0 (map (rloadA !) [0 .. numRvrs - 1]) + targetLoad i = ceiling (numAsWt totalReviews * (rloadA ! i) / totalRelativeLoad) -- A...H refer to idea book p.429 edgesABC = do i <- [0 .. numRvrs - 1] @@ -48,7 +43,7 @@ doReduction (Instance numRvrs numProps rloadF prefF) = edgesD = do i <- [0 .. numRvrs - 1] j <- [0 .. numProps - 1] - let pref = prefF i j + let pref = prefA ! (i, j) if prefIsConflict pref then [] else [(rvrNode i (prefBoringness pref), @@ -73,7 +68,7 @@ doReduction (Instance numRvrs numProps rloadF prefF) = todo = undefined -- Returns a list of reviews as ordered pairs (reviewer#, proposal#). doMatching :: Instance -> [(Int, Int)] -doMatching inst@(Instance numRvrs numProps rloadF prefF) = +doMatching inst@(Instance numRvrs numProps _ _) = -- Copied from doReduction. There should be a better way to get these here. let source = 0 diff --git a/program/ProposalMatchConfig.hs b/program/ProposalMatcherConfig.hs similarity index 92% rename from program/ProposalMatchConfig.hs rename to program/ProposalMatcherConfig.hs index 42b47f6..750cf1f 100644 --- a/program/ProposalMatchConfig.hs +++ b/program/ProposalMatcherConfig.hs @@ -1,7 +1,7 @@ -module ProposalMatchConfig where +module ProposalMatcherConfig where +import Instance type Pref = Int -type Wt = Double -- must implement RealFrac numAsWt x = fromInteger (toInteger x) :: Wt diff --git a/program/RandomizedMonad.hs b/program/RandomizedMonad.hs new file mode 100644 index 0000000..37f2b98 --- /dev/null +++ b/program/RandomizedMonad.hs @@ -0,0 +1,61 @@ +module RandomizedMonad ( + Randomized, + runRandom, runRandomStd, runRandomNewStd, + mrandomR, mrandom, + withProb, + filterRandomized +) where +import System.Random + +-- Needs -XRank2Types +newtype Randomized a = Randomized (forall g. RandomGen g => (g -> a)) + +-- This implementation splits the RandomGen over and over. +-- It would also be possible to serialize everything and use a single RandomGen. +instance Monad Randomized where + ma >>= amb = Randomized (\g -> let + (g1, g2) = split g + Randomized fa = ma + a = fa g1 + Randomized fb = amb a + in fb g2 + ) + return x = Randomized (const x) + +runRandom :: RandomGen g => g -> Randomized a -> a +runRandom g (Randomized fa) = fa g + +-- Conveniences +runRandomStd :: Randomized a -> IO a +runRandomStd ra = do + g <- getStdGen + return $ runRandom g ra + +runRandomNewStd :: Randomized a -> IO a +runRandomNewStd ra = do + g <- newStdGen + return $ runRandom g ra + +-- Monadic versions of random and randomR (to generate primitive-ish values) +mrandomR :: Random a => (a, a) -> Randomized a +mrandomR lohi = Randomized (\g -> fst (randomR lohi g)) +mrandom :: Random a => Randomized a +mrandom = Randomized (\g -> fst (random g)) + +chooseCase :: Double -> [(Double, a)] -> a -> a +chooseCase val ifCs elseR = case ifCs of + [] -> elseR + (cutoff, theR):ifCt -> if val < cutoff + then theR + else chooseCase (val - cutoff) ifCt elseR + +withProb :: [(Double, Randomized a)] -> Randomized a -> Randomized a +withProb ifCs elseR = do + val <- mrandom + chooseCase val ifCs elseR + +-- Keep trying until we get what we want. +filterRandomized :: (a -> Bool) -> Randomized a -> Randomized a +filterRandomized f ra = do + a <- ra + if f a then return a else filterRandomized f ra diff --git a/program/Test.hs b/program/Test.hs index 7840b5e..f8cb4ef 100644 --- a/program/Test.hs +++ b/program/Test.hs @@ -1,15 +1,40 @@ -module Test where +module Test ( + -- Export everything we need to have fun in GHCi: + + -- See the results of examples. + module Test, + + -- Generate instances. + module Instance, + module InstanceGenerator, + + -- Solve instances. + module ProposalMatcher, + module ProposalMatcherConfig, + + -- Run randomized things. + module System.Random, + module RandomizedMonad, + + -- Visualize graphs. + module Data.Graph.Inductive.Graphviz +) where +import Instance +import InstanceGenerator +import ProposalMatcher +import ProposalMatcherConfig +import System.Random +import RandomizedMonad +import Data.Graph.Inductive.Graphviz + +-- Other imports we need import BellmanFord import UnitMinCostFlow -import ProposalMatch -import ProposalMatchConfig -import Data.Array +import Data.Array.IArray +import Data.Array.Unboxed import Data.Graph.Inductive.Graph import Data.Graph.Inductive.Tree - --- So we can call graphviz' at the GHCi prompt -import Data.Graph.Inductive.Graphviz -graphviz' g = Data.Graph.Inductive.Graphviz.graphviz' g +import ArrayStuff myGraph = mkGraph [(0, ()), (1, ()), (2, ())] [(0, 1, 2), (0, 2, 3), (2, 1, -2)] :: Gr () Double @@ -31,14 +56,13 @@ myPrefsArray = array ((0,0), (myNumRvrs-1,myNumProps-1)) [ (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 = transposeArray $ listArray ((0,0), (myNumProps-1,myNumRvrs-1)) [ + 15, 10, 15, 40, 20, + 30, 7, 10, 15, 15, + 15, 25, 20, 20, 15 + ] :: UArray (Int, Int) Wt -myPrefs = \i j -> myPrefsArray ! (i, j) -myInst = Instance myNumRvrs myNumProps (const 1) myPrefs +myInst = Instance myNumRvrs myNumProps (funcArray (0, myNumRvrs-1) $ const 1) myPrefs rdnGraph = doReduction myInst (rdnFlowVal, rdnFlowResid) = umcf 0 1 rdnGraph