module Control.Effect.Random
(module System.Random,
Rand,
runRand, evalRand, evalRandIO,
getRandom, getRandomR, getRandoms, getRandomRs,
fromList, uniform,
withSplit
) where
import Control.Arrow (first)
import Control.Effect (Effect, EffectLift, Is, MemberEffect, Row (..))
import Control.Effect (eliminate, intercept, lift, send)
import Control.Monad (liftM)
import Data.Data (Typeable)
import System.Random (Random (..), RandomGen (..), StdGen, newStdGen)
#ifdef MONADRANDOM
import qualified Control.Monad.Random.Class as C
#endif
data Rand g a = RandomGen g => Rand (g -> (a, g))
deriving (Typeable)
instance Functor (Rand g) where
fmap g (Rand f) = Rand (first g . f)
type instance Is Rand f = IsRand f
type family IsRand f where
IsRand (Rand g) = True
IsRand f = False
class (RandomGen g, MemberEffect Rand (Rand g) l) => EffectRandom g l
instance (RandomGen g, MemberEffect Rand (Rand g) l) => EffectRandom g l
#ifdef MONADRANDOM
instance EffectRandom g l => C.MonadRandom (Effect l) where
getRandom = getRandom
getRandoms = getRandoms
getRandomR = getRandomR
getRandomRs = getRandomRs
#endif
getRandom :: forall a g l . (Random a, EffectRandom g l) => Effect l a
getRandom = send $ Rand (random :: g -> (a, g))
getRandoms :: forall a g l. (Random a, EffectRandom g l) => Effect l [a]
getRandoms = send $ Rand $ \(g :: g) ->
first randoms $ split g
getRandomR :: forall a g l. (Random a, EffectRandom g l) => (a, a) -> Effect l a
getRandomR bd = send $ Rand $ \ (g :: g) -> randomR bd g
getRandomRs :: forall a g l. (Random a, EffectRandom g l) => (a, a) -> Effect l [a]
getRandomRs bd = send $ Rand $ \(g :: g) -> let (g', g'') = split g in (randomRs bd g', g'')
fromList :: EffectRandom g l => [(a, Rational)] -> Effect l a
fromList [] = error "Effect.Random.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
uniform :: (EffectRandom g l) => [a] -> Effect l a
uniform xs = fromList $ map (flip (,) 1) xs
runRand :: forall a l g. RandomGen g
=> g
-> Effect (Rand g :+ l) a
-> Effect l (a, g)
runRand g0 act = eliminate ret handle act g0
where
ret a g = return (a, g)
handle :: Rand g (g -> Effect l (a, g)) -> g -> Effect l (a, g)
handle (Rand tog) g = do
let (cont, g') = tog g
cont g'
evalRand :: RandomGen g => g -> Effect (Rand g :+ l) a -> Effect l a
evalRand g = liftM fst . runRand g
evalRandIO :: EffectLift IO l => Effect (Rand StdGen :+ l) a -> Effect l a
evalRandIO eff = do
g <- lift newStdGen
evalRand g eff
withSplit :: forall g l a. EffectRandom g l => Effect l a -> Effect l a
withSplit eff = do
g <- send $ Rand split
let run (Rand fromg) = fst $ fromg (g :: g)
intercept return run eff