New monads/MonadRandom

From HaskellWiki
< New monads
Revision as of 18:07, 26 October 2006 by ChrisKuklewicz (talk | contribs) (add category:code)
Jump to navigation Jump to search
The printable version is no longer supported and may have rendering errors. Please update your browser bookmarks and please use the default browser print function instead.

From New monads, copied from old wiki.

MonadRandom

A simple monad transformer to allow computations in the transformed monad to generate random values.

"CaleGibbard/BSDLicense"


{-# OPTIONS_GHC -fglasgow-exts #-}

module MonadRandom (
    MonadRandom,
    getRandom,
    getRandomR,
    evalRandomT,
    evalRand,
    evalRandIO,
    fromList,
    Rand, RandomT -- but not the data constructors
    ) where

import System.Random
import Control.Monad.State
import Control.Monad.Identity

class (Monad m) => MonadRandom m where
    getRandom :: (Random a) => m a
    getRandomR :: (Random a) => (a,a) -> m a

newtype (RandomGen g) => RandomT g m a = RandomT { unRT :: StateT g m a }
    deriving (Functor, Monad, MonadTrans, MonadIO)

liftState :: (MonadState s m) => (s -> (a,s)) -> m a
liftState t = do v <- get
                 let (x, v') = t v
                 put v'
                 return x

instance (Monad m, RandomGen g) => MonadRandom (RandomT g m) where
    getRandom = (RandomT . liftState) random
    getRandomR (x,y) = (RandomT . liftState) (randomR (x,y))

evalRandomT :: (Monad m, RandomGen g) => RandomT g m a -> g -> m a
evalRandomT x g = evalStateT (unRT x) g

-- Boring random monad :)
newtype Rand g a = Rand { unRand :: RandomT g Identity a }
    deriving (Functor, Monad, MonadRandom)

evalRand :: (RandomGen g) => Rand g a -> g -> a
evalRand x g = runIdentity (evalRandomT (unRand x) g)

evalRandIO :: Rand StdGen a -> IO a
evalRandIO x = getStdRandom (runIdentity . runStateT (unRT (unRand x)))

fromList :: (MonadRandom m) => [(a,Rational)] -> m a
fromList [] = error "MonadRandom.fromList called with empty list"
fromList [(x,_)] = return x
fromList xs = do let s = fromRational $ sum (map snd xs) -- total weight
                     cs = scanl1 (\(x,q) (y,s) -> (y, s+q)) xs -- cumulative weight
                 p <- liftM toRational $ getRandomR (0.0,s)
                 return $ fst $ head $ dropWhile (\(x,q) -> q < p) cs