module Control.Monad.Random (
module System.Random,
module Control.Monad.Random.Class,
evalRandT,
runRandT,
evalRand,
runRand,
evalRandIO,
fromList,
Rand, RandT
) where
import System.Random
import Control.Monad()
import Control.Monad.Identity
import Control.Monad.Random.Class
import Control.Monad.Reader
import Control.Monad.State
import Control.Monad.Trans()
import Control.Monad.Writer
import Control.Arrow
import Control.Applicative
newtype (RandomGen g) => RandT g m a = RandT (StateT g m a)
deriving (Functor, Monad, MonadTrans, MonadIO, MonadFix)
instance (Functor m,Monad m) => Applicative (RandT g m) where
pure = return
(<*>) = ap
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 (RandT g m) where
getRandom = RandT . liftState $ random
getRandoms = RandT . liftState $ first randoms . split
getRandomR (x,y) = RandT . liftState $ randomR (x,y)
getRandomRs (x,y) = RandT . liftState $
first (randomRs (x,y)) . split
instance (Monad m, RandomGen g) => MonadSplit g (RandT g m) where
getSplit = RandT . liftState $ split
evalRandT :: (Monad m, RandomGen g) => RandT g m a -> g -> m a
evalRandT (RandT x) g = evalStateT x g
runRandT :: (Monad m, RandomGen g) => RandT g m a -> g -> m (a, g)
runRandT (RandT x) g = runStateT x g
newtype Rand g a = Rand (RandT g Identity a)
deriving (Functor, Applicative, Monad, MonadRandom, MonadSplit g, MonadFix)
evalRand :: (RandomGen g) => Rand g a -> g -> a
evalRand (Rand x) g = runIdentity (evalRandT x g)
runRand :: (RandomGen g) => Rand g a -> g -> (a, g)
runRand (Rand x) g = runIdentity (runRandT x g)
evalRandIO :: Rand StdGen a -> IO a
evalRandIO (Rand (RandT x)) = getStdRandom (runIdentity . runStateT 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))) :: Double
cs = scanl1 (\(_,q) (y,s') -> (y, s'+q)) xs
p <- liftM toRational $ getRandomR (0.0,s)
return . fst . head $ dropWhile (\(_,q) -> q < p) cs
instance (MonadRandom m) => MonadRandom (StateT s m) where
getRandom = lift getRandom
getRandomR = lift . getRandomR
getRandoms = lift getRandoms
getRandomRs = lift . getRandomRs
instance (MonadRandom m, Monoid w) => MonadRandom (WriterT w m) where
getRandom = lift getRandom
getRandomR = lift . getRandomR
getRandoms = lift getRandoms
getRandomRs = lift . getRandomRs
instance (MonadRandom m) => MonadRandom (ReaderT r m) where
getRandom = lift getRandom
getRandomR = lift . getRandomR
getRandoms = lift getRandoms
getRandomRs = lift . getRandomRs
instance (MonadSplit g m) => MonadSplit g (StateT s m) where
getSplit = lift getSplit
instance (MonadSplit g m, Monoid w) => MonadSplit g (WriterT w m) where
getSplit = lift getSplit
instance (MonadSplit g m) => MonadSplit g (ReaderT r m) where
getSplit = lift getSplit
instance (MonadState s m, RandomGen g) => MonadState s (RandT g m) where
get = lift get
put = lift . put
instance (MonadReader r m, RandomGen g) => MonadReader r (RandT g m) where
ask = lift ask
local f (RandT m) = RandT $ local f m
instance (MonadWriter w m, RandomGen g, Monoid w) => MonadWriter w (RandT g m) where
tell = lift . tell
listen (RandT m) = RandT $ listen m
pass (RandT m) = RandT $ pass m
instance MonadRandom IO where
getRandom = randomIO
getRandomR = randomRIO
getRandoms = fmap randoms newStdGen
getRandomRs b = fmap (randomRs b) newStdGen
instance MonadSplit StdGen IO where
getSplit = newStdGen