program/RandomizedMonad.hs

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