module Control.Eff.Random (module System.Random,
Rand, Generator(..),
runRand, evalRand, evalRandIO,
getRandom, getRandomR, getRandoms, getRandomRs,
fromList, uniform,
getSplit) where
import Control.Arrow (first)
import Control.Arrow (second)
import Control.Eff
import Control.Eff.Lift (Lift, lift)
import Control.Monad (liftM)
import Data.Typeable (Typeable (..), mkTyCon3, mkTyConApp)
import System.Random
data Generator = forall g. RandomGen g => Generator g
#if MIN_VERSION_base(4,7,0)
deriving (Typeable)
#else
instance Typeable Generator where
typeOf _ = mkTyConApp gen []
where
gen = mkTyCon3 "random-eff" "Control.Eff.Random" "Generator"
#endif
instance RandomGen Generator where
next (Generator g) = second Generator $ next g
genRange (Generator g) = genRange g
split (Generator g) =
let (h, h') = split g
in (Generator h, Generator h')
data Rand a = Rand (Generator -> (a, Generator))
deriving (Typeable)
instance Functor Rand where
fmap g (Rand f) = Rand (first g . f)
getRandom :: forall a r. (Typeable a, Random a, Member Rand r) => Eff r a
getRandom = send $ \k ->
inj $ Rand (\(Generator g) -> let (a :: a, g') = random g
in (k a, Generator g'))
getRandoms :: (Random a, Typeable a, Member Rand r) => Eff r [a]
getRandoms = send $ \k ->
inj $ Rand (\(Generator g) -> let (g', g'') = split g
in (k (randoms g'), Generator g''))
getRandomR :: (Typeable a, Random a, Member Rand r) => (a, a) -> Eff r a
getRandomR bd = send $ \k ->
inj $ Rand (\(Generator g) -> let (a, g') = randomR bd g
in (k a, Generator g'))
getRandomRs :: (Typeable a, Random a, Member Rand r) => (a, a) -> Eff r [a]
getRandomRs bd = send $ \k ->
inj $ Rand (\(Generator g) -> let (g', g'') = split g in (k (randomRs bd g'), Generator g''))
fromList :: Member Rand r => [(a, Rational)] -> Eff r a
fromList [] = error "Eff.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 :: Member Rand r => [a] -> Eff r a
uniform xs = fromList $ map (flip (,) 1) xs
getSplit :: (Member Rand r) => Eff r Generator
getSplit = send $ \k ->
inj $ Rand (\(Generator g) -> let (g', g'') = split g in (k (Generator g''), Generator g'))
runRand :: RandomGen g
=> g
-> Eff (Rand :> r) w
-> Eff r (w, Generator)
runRand g0 = loop (Generator g0) . admin
where
loop g (Val x) = return (x, g)
loop g (E u) = handleRelay u (loop g) $ \(Rand f) ->
let (a, g') = f g
in loop g' a
evalRand :: RandomGen g => g -> Eff (Rand :> r) w -> Eff r w
evalRand g = liftM fst . runRand g
evalRandIO :: SetMember Lift (Lift IO) r => Eff (Rand :> r) w -> Eff r w
evalRandIO eff = do
g <- lift newStdGen
evalRand g eff