program/RandomizedMonad.hs

   1 module RandomizedMonad (
   2         Randomized,
   3         runRandom, runRandomStd, runRandomNewStd,
   4         mrandomR, mrandom,
   5         withProb,
   6         filterRandomized
   7 ) where
   8 import System.Random
   9
  10 -- Needs -XRank2Types
  11 newtype Randomized a = Randomized (forall g. RandomGen g => (g -> a))
  12
  13 -- This implementation splits the RandomGen over and over.
  14 -- It would also be possible to serialize everything and use a single RandomGen.
  15 instance Monad Randomized where
  16         ma >>= amb = Randomized (\g -> let
  17                         (g1, g2) = split g
  18                         Randomized fa = ma
  19                         a = fa g1
  20                         Randomized fb = amb a
  21                         in fb g2
  22                 )
  23         return x = Randomized (const x)
  24
  25 runRandom :: RandomGen g => g -> Randomized a -> a
  26 runRandom g (Randomized fa) = fa g
  27
  28 -- Conveniences
  29 runRandomStd :: Randomized a -> IO a
  30 runRandomStd ra = do
  31         g <- getStdGen
  32         return $ runRandom g ra
  33
  34 runRandomNewStd :: Randomized a -> IO a
  35 runRandomNewStd ra = do
  36         g <- newStdGen
  37         return $ runRandom g ra
  38
  39 -- Monadic versions of random and randomR (to generate primitive-ish values)
  40 mrandomR :: Random a => (a, a) -> Randomized a
  41 mrandomR lohi = Randomized (\g -> fst (randomR lohi g))
  42 mrandom :: Random a => Randomized a
  43 mrandom = Randomized (\g -> fst (random g))
  44
  45 chooseCase :: Double -> [(Double, a)] -> a -> a
  46 chooseCase val ifCs elseR = case ifCs of
  47         [] -> elseR
  48         (cutoff, theR):ifCt -> if val < cutoff
  49                 then theR
  50                 else chooseCase (val - cutoff) ifCt elseR
  51
  52 withProb :: [(Double, Randomized a)] -> Randomized a -> Randomized a
  53 withProb ifCs elseR = do
  54         val <- mrandom
  55         chooseCase val ifCs elseR
  56
  57 -- Keep trying until we get what we want.
  58 filterRandomized :: (a -> Bool) -> Randomized a -> Randomized a
  59 filterRandomized f ra = do
  60         a <- ra
  61         if f a then return a else filterRandomized f ra