module Data.Random.Source.StdGen where
import Data.Random.Internal.Words
import Data.Random.Internal.Primitives
import Data.Random.Source
import System.Random
import Control.Monad.Prompt
import Control.Monad.State
import qualified Control.Monad.ST.Strict as S
import qualified Control.Monad.State.Strict as S
import Data.StateRef
import Data.Word
instance (Monad m1, ModifyRef (Ref m2 StdGen) m1 StdGen) => RandomSource m1 (Ref m2 StdGen) where
getRandomPrimFrom = getRandomPrimFromRandomGenRef
instance (Monad m, ModifyRef (IORef StdGen) m StdGen) => RandomSource m (IORef StdGen) where
getRandomPrimFrom = getRandomPrimFromRandomGenRef
instance (Monad m, ModifyRef (STRef s StdGen) m StdGen) => RandomSource m (STRef s StdGen) where
getRandomPrimFrom = getRandomPrimFromRandomGenRef
getRandomPrimFromStdGenIO :: Prim a -> IO a
getRandomPrimFromStdGenIO prim
| supported prim = genPrim prim
| otherwise = runPromptM getRandomPrimFromStdGenIO (decomposePrimWhere supported prim)
where
supported :: Prim a -> Bool
supported PrimWord8 = True
supported PrimWord16 = True
supported PrimWord32 = True
supported PrimWord64 = True
supported PrimDouble = True
supported (PrimNByteInteger _) = True
supported _ = False
genPrim :: Prim a -> IO a
genPrim PrimWord8 = fmap fromIntegral (randomRIO (0, 0xff) :: IO Int)
genPrim PrimWord16 = fmap fromIntegral (randomRIO (0, 0xffff) :: IO Int)
genPrim PrimWord32 = fmap fromInteger (randomRIO (0, 0xffffffff))
genPrim PrimWord64 = fmap fromInteger (randomRIO (0, 0xffffffffffffffff))
genPrim PrimDouble = fmap (wordToDouble . fromInteger) (randomRIO (0, 0xffffffffffffffff))
genPrim (PrimNByteInteger n) = randomRIO (0, iterate (*256) 1 !! n)
genPrim p = error ("getRandomPrimFromStdGenIO: genPrim called for unsupported prim " ++ show p)
getRandomPrimFromRandomGenRef :: (Monad m, ModifyRef sr m g, RandomGen g) =>
sr -> Prim a -> m a
getRandomPrimFromRandomGenRef ref prim
| supported prim = genPrim prim getThing
| otherwise = runPromptM (getRandomPrimFromRandomGenRef ref) (decomposePrimWhere supported prim)
where
supported :: Prim a -> Bool
supported PrimWord8 = True
supported PrimWord16 = True
supported PrimWord32 = True
supported PrimWord64 = True
supported PrimDouble = True
supported (PrimNByteInteger _) = True
supported _ = False
genPrim :: (RandomGen g) => Prim a -> (forall b. (g -> (b, g)) -> (b -> a) -> c) -> c
genPrim PrimWord8 f = f (randomR (0, 0xff)) (fromIntegral :: Int -> Word8)
genPrim PrimWord16 f = f (randomR (0, 0xffff)) (fromIntegral :: Int -> Word16)
genPrim PrimWord32 f = f (randomR (0, 0xffffffff)) (fromInteger)
genPrim PrimWord64 f = f (randomR (0, 0xffffffffffffffff)) (fromInteger)
genPrim PrimDouble f = f (randomR (0, 0x000fffffffffffff)) (flip encodeFloat (52))
genPrim (PrimNByteInteger n) f = f (randomR (0, iterate (*256) 1 !! n)) (id :: Integer -> Integer)
genPrim p _ = error ("getRandomPrimFromRandomGenRef: genPrim called for unsupported prim " ++ show p)
getThing thing f = atomicModifyReference ref $ \(!oldMT) -> case thing oldMT of (!w, !newMT) -> (newMT, f w)
getRandomPrimFromRandomGenState :: (RandomGen g, MonadState g m) => Prim a -> m a
getRandomPrimFromRandomGenState prim
= runPromptM genSupported (decomposePrimWhere supported prim)
where
genSupported prim = genPrim prim getThing
supported :: Prim a -> Bool
supported PrimWord8 = True
supported PrimWord16 = True
supported PrimWord32 = True
supported PrimWord64 = True
supported PrimDouble = True
supported (PrimNByteInteger _) = True
supported _ = False
genPrim :: (RandomGen g) => Prim a -> (forall b. (g -> (b, g)) -> (b -> a) -> c) -> c
genPrim PrimWord8 f = f (randomR (0, 0xff)) (fromIntegral :: Int -> Word8)
genPrim PrimWord16 f = f (randomR (0, 0xffff)) (fromIntegral :: Int -> Word16)
genPrim PrimWord32 f = f (randomR (0, 0xffffffff)) (fromInteger)
genPrim PrimWord64 f = f (randomR (0, 0xffffffffffffffff)) (fromInteger)
genPrim PrimDouble f = f (randomR (0, 0x000fffffffffffff)) (flip encodeFloat (52))
genPrim (PrimNByteInteger n) f = f (randomR (0, iterate (*256) 1 !! n)) id
genPrim p _ = error ("getRandomPrimFromRandomGenState: genPrim called for unsupported prim " ++ show p)
getThing thing f = do
!oldGen <- get
case thing oldGen of
(!i,!newGen) -> do
put newGen
return (f $! i)
#ifndef MTL2
instance MonadRandom (State StdGen) where
getRandomPrim = getRandomPrimFromRandomGenState
instance MonadRandom (S.State StdGen) where
getRandomPrim = getRandomPrimFromRandomGenState
#endif
instance Monad m => MonadRandom (StateT StdGen m) where
getRandomPrim = getRandomPrimFromRandomGenState
instance Monad m => MonadRandom (S.StateT StdGen m) where
getRandomPrim = getRandomPrimFromRandomGenState