{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE GHCForeignImportPrim #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UnboxedTuples #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE UnliftedFFITypes #-}
#if __GLASGOW_HASKELL__ >= 800
{-# LANGUAGE TypeFamilyDependencies #-}
#else
{-# LANGUAGE TypeFamilies #-}
#endif
{-# OPTIONS_HADDOCK hide, not-home #-}
module System.Random.Internal
(
RandomGen(..)
, StatefulGen(..)
, FrozenGen(..)
, StdGen(..)
, mkStdGen
, theStdGen
, StateGen(..)
, StateGenM(..)
, splitGen
, runStateGen
, runStateGen_
, runStateGenT
, runStateGenT_
, runStateGenST
, runStateGenST_
, Uniform(..)
, uniformViaFiniteM
, UniformRange(..)
, uniformByteStringM
, uniformDouble01M
, uniformDoublePositive01M
, uniformFloat01M
, uniformFloatPositive01M
, uniformEnumM
, uniformEnumRM
, genShortByteStringIO
, genShortByteStringST
) where
import Control.Arrow
import Control.DeepSeq (NFData)
import Control.Monad (when)
import Control.Monad.Cont (ContT, runContT)
import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad.ST
import Control.Monad.ST.Unsafe
import Control.Monad.State.Strict (MonadState(..), State, StateT(..), runState)
import Control.Monad.Trans (lift)
import Data.Bits
import Data.ByteString.Short.Internal (ShortByteString(SBS), fromShort)
import Data.IORef (IORef, newIORef)
import Data.Int
import Data.Word
import Foreign.C.Types
import Foreign.Storable (Storable)
import GHC.Exts
import GHC.Generics
import GHC.IO (IO(..))
import GHC.Word
import Numeric.Natural (Natural)
import System.IO.Unsafe (unsafePerformIO)
import System.Random.GFinite (Cardinality(..), GFinite(..))
import qualified System.Random.SplitMix as SM
import qualified System.Random.SplitMix32 as SM32
#if __GLASGOW_HASKELL__ >= 800
import Data.Kind
#endif
#if __GLASGOW_HASKELL__ >= 802
import Data.ByteString.Internal (ByteString(PS))
import GHC.ForeignPtr
#else
import Data.ByteString (ByteString)
#endif
#include "MachDeps.h"
{-# DEPRECATED next "No longer used" #-}
{-# DEPRECATED genRange "No longer used" #-}
class RandomGen g where
{-# MINIMAL split,(genWord32|genWord64|(next,genRange)) #-}
next :: g -> (Int, g)
next g = runStateGen g (uniformRM (genRange g))
genWord8 :: g -> (Word8, g)
genWord8 = first fromIntegral . genWord32
{-# INLINE genWord8 #-}
genWord16 :: g -> (Word16, g)
genWord16 = first fromIntegral . genWord32
{-# INLINE genWord16 #-}
genWord32 :: g -> (Word32, g)
genWord32 = randomIvalIntegral (minBound, maxBound)
{-# INLINE genWord32 #-}
genWord64 :: g -> (Word64, g)
genWord64 g =
case genWord32 g of
(l32, g') ->
case genWord32 g' of
(h32, g'') ->
((fromIntegral h32 `shiftL` 32) .|. fromIntegral l32, g'')
{-# INLINE genWord64 #-}
genWord32R :: Word32 -> g -> (Word32, g)
genWord32R m g = runStateGen g (unbiasedWordMult32 m)
{-# INLINE genWord32R #-}
genWord64R :: Word64 -> g -> (Word64, g)
genWord64R m g = runStateGen g (unsignedBitmaskWithRejectionM uniformWord64 m)
{-# INLINE genWord64R #-}
genShortByteString :: Int -> g -> (ShortByteString, g)
genShortByteString n g =
unsafePerformIO $ runStateGenT g (genShortByteStringIO n . uniformWord64)
{-# INLINE genShortByteString #-}
genRange :: g -> (Int, Int)
genRange _ = (minBound, maxBound)
split :: g -> (g, g)
class Monad m => StatefulGen g m where
{-# MINIMAL (uniformWord32|uniformWord64) #-}
uniformWord32R :: Word32 -> g -> m Word32
uniformWord32R = unsignedBitmaskWithRejectionM uniformWord32
{-# INLINE uniformWord32R #-}
uniformWord64R :: Word64 -> g -> m Word64
uniformWord64R = unsignedBitmaskWithRejectionM uniformWord64
{-# INLINE uniformWord64R #-}
uniformWord8 :: g -> m Word8
uniformWord8 = fmap fromIntegral . uniformWord32
{-# INLINE uniformWord8 #-}
uniformWord16 :: g -> m Word16
uniformWord16 = fmap fromIntegral . uniformWord32
{-# INLINE uniformWord16 #-}
uniformWord32 :: g -> m Word32
uniformWord32 = fmap fromIntegral . uniformWord64
{-# INLINE uniformWord32 #-}
uniformWord64 :: g -> m Word64
uniformWord64 g = do
l32 <- uniformWord32 g
h32 <- uniformWord32 g
pure (shiftL (fromIntegral h32) 32 .|. fromIntegral l32)
{-# INLINE uniformWord64 #-}
uniformShortByteString :: Int -> g -> m ShortByteString
default uniformShortByteString :: MonadIO m => Int -> g -> m ShortByteString
uniformShortByteString n = genShortByteStringIO n . uniformWord64
{-# INLINE uniformShortByteString #-}
class StatefulGen (MutableGen f m) m => FrozenGen f m where
#if __GLASGOW_HASKELL__ >= 800
type MutableGen f m = (g :: Type) | g -> f
#else
type MutableGen f m :: *
#endif
freezeGen :: MutableGen f m -> m f
thawGen :: f -> m (MutableGen f m)
data MBA = MBA (MutableByteArray# RealWorld)
genShortByteStringIO ::
MonadIO m
=> Int
-> m Word64
-> m ShortByteString
genShortByteStringIO n0 gen64 = do
let !n@(I# n#) = max 0 n0
!n64 = n `quot` 8
!nrem = n `rem` 8
mba@(MBA mba#) <-
liftIO $ IO $ \s# ->
case newByteArray# n# s# of
(# s'#, mba# #) -> (# s'#, MBA mba# #)
let go i =
when (i < n64) $ do
w64 <- gen64
liftIO $ writeWord64LE mba i w64
go (i + 1)
go 0
when (nrem > 0) $ do
w64 <- gen64
liftIO $ writeByteSliceWord64LE mba (n - nrem) n w64
liftIO $ IO $ \s# ->
case unsafeFreezeByteArray# mba# s# of
(# s'#, ba# #) -> (# s'#, SBS ba# #)
{-# INLINE genShortByteStringIO #-}
io_ :: (State# RealWorld -> State# RealWorld) -> IO ()
io_ m# = IO $ \s# -> (# m# s#, () #)
{-# INLINE io_ #-}
writeWord8 :: MBA -> Int -> Word8 -> IO ()
writeWord8 (MBA mba#) (I# i#) (W8# w#) = io_ (writeWord8Array# mba# i# w#)
{-# INLINE writeWord8 #-}
writeByteSliceWord64LE :: MBA -> Int -> Int -> Word64 -> IO ()
writeByteSliceWord64LE mba fromByteIx toByteIx = go fromByteIx
where
go !i !z =
when (i < toByteIx) $ do
writeWord8 mba i (fromIntegral z :: Word8)
go (i + 1) (z `shiftR` 8)
{-# INLINE writeByteSliceWord64LE #-}
writeWord64LE :: MBA -> Int -> Word64 -> IO ()
#ifdef WORDS_BIGENDIAN
writeWord64LE mba i w64 = do
let !i8 = i * 8
writeByteSliceWord64LE mba i8 (i8 + 8) w64
#else
writeWord64LE (MBA mba#) (I# i#) w64@(W64# w64#)
| wordSizeInBits == 64 = io_ (writeWord64Array# mba# i# w64#)
| otherwise = do
let !i32# = i# *# 2#
!(W32# w32l#) = fromIntegral w64
!(W32# w32u#) = fromIntegral (w64 `shiftR` 32)
io_ (writeWord32Array# mba# i32# w32l#)
io_ (writeWord32Array# mba# (i32# +# 1#) w32u#)
#endif
{-# INLINE writeWord64LE #-}
genShortByteStringST :: Int -> ST s Word64 -> ST s ShortByteString
genShortByteStringST n action =
unsafeIOToST (genShortByteStringIO n (unsafeSTToIO action))
{-# INLINE genShortByteStringST #-}
uniformByteStringM :: StatefulGen g m => Int -> g -> m ByteString
uniformByteStringM n g = do
ba <- uniformShortByteString n g
pure $
#if __GLASGOW_HASKELL__ < 802
fromShort ba
#else
let !(SBS ba#) = ba in
if isTrue# (isByteArrayPinned# ba#)
then pinnedByteArrayToByteString ba#
else fromShort ba
{-# INLINE uniformByteStringM #-}
pinnedByteArrayToByteString :: ByteArray# -> ByteString
pinnedByteArrayToByteString ba# =
PS (pinnedByteArrayToForeignPtr ba#) 0 (I# (sizeofByteArray# ba#))
{-# INLINE pinnedByteArrayToByteString #-}
pinnedByteArrayToForeignPtr :: ByteArray# -> ForeignPtr a
pinnedByteArrayToForeignPtr ba# =
ForeignPtr (byteArrayContents# ba#) (PlainPtr (unsafeCoerce# ba#))
{-# INLINE pinnedByteArrayToForeignPtr #-}
#endif
data StateGenM g = StateGenM
newtype StateGen g = StateGen { unStateGen :: g }
deriving (Eq, Ord, Show, RandomGen, Storable, NFData)
instance (RandomGen g, MonadState g m) => StatefulGen (StateGenM g) m where
uniformWord32R r _ = state (genWord32R r)
{-# INLINE uniformWord32R #-}
uniformWord64R r _ = state (genWord64R r)
{-# INLINE uniformWord64R #-}
uniformWord8 _ = state genWord8
{-# INLINE uniformWord8 #-}
uniformWord16 _ = state genWord16
{-# INLINE uniformWord16 #-}
uniformWord32 _ = state genWord32
{-# INLINE uniformWord32 #-}
uniformWord64 _ = state genWord64
{-# INLINE uniformWord64 #-}
uniformShortByteString n _ = state (genShortByteString n)
{-# INLINE uniformShortByteString #-}
instance (RandomGen g, MonadState g m) => FrozenGen (StateGen g) m where
type MutableGen (StateGen g) m = StateGenM g
freezeGen _ = fmap StateGen get
thawGen (StateGen g) = StateGenM <$ put g
splitGen :: (MonadState g m, RandomGen g) => m g
splitGen = state split
{-# INLINE splitGen #-}
runStateGen :: RandomGen g => g -> (StateGenM g -> State g a) -> (a, g)
runStateGen g f = runState (f StateGenM) g
{-# INLINE runStateGen #-}
runStateGen_ :: RandomGen g => g -> (StateGenM g -> State g a) -> a
runStateGen_ g = fst . runStateGen g
{-# INLINE runStateGen_ #-}
runStateGenT :: RandomGen g => g -> (StateGenM g -> StateT g m a) -> m (a, g)
runStateGenT g f = runStateT (f StateGenM) g
{-# INLINE runStateGenT #-}
runStateGenT_ :: (RandomGen g, Functor f) => g -> (StateGenM g -> StateT g f a) -> f a
runStateGenT_ g = fmap fst . runStateGenT g
{-# INLINE runStateGenT_ #-}
runStateGenST :: RandomGen g => g -> (forall s . StateGenM g -> StateT g (ST s) a) -> (a, g)
runStateGenST g action = runST $ runStateGenT g action
{-# INLINE runStateGenST #-}
runStateGenST_ :: RandomGen g => g -> (forall s . StateGenM g -> StateT g (ST s) a) -> a
runStateGenST_ g action = runST $ runStateGenT_ g action
{-# INLINE runStateGenST_ #-}
newtype StdGen = StdGen { unStdGen :: SM.SMGen }
deriving (Show, RandomGen, NFData)
instance Eq StdGen where
StdGen x1 == StdGen x2 = SM.unseedSMGen x1 == SM.unseedSMGen x2
instance RandomGen SM.SMGen where
next = SM.nextInt
{-# INLINE next #-}
genWord32 = SM.nextWord32
{-# INLINE genWord32 #-}
genWord64 = SM.nextWord64
{-# INLINE genWord64 #-}
split = SM.splitSMGen
{-# INLINE split #-}
instance RandomGen SM32.SMGen where
next = SM32.nextInt
{-# INLINE next #-}
genWord32 = SM32.nextWord32
{-# INLINE genWord32 #-}
genWord64 = SM32.nextWord64
{-# INLINE genWord64 #-}
split = SM32.splitSMGen
{-# INLINE split #-}
mkStdGen :: Int -> StdGen
mkStdGen = StdGen . SM.mkSMGen . fromIntegral
theStdGen :: IORef StdGen
theStdGen = unsafePerformIO $ SM.initSMGen >>= newIORef . StdGen
{-# NOINLINE theStdGen #-}
class Uniform a where
uniformM :: StatefulGen g m => g -> m a
default uniformM :: (StatefulGen g m, Generic a, GUniform (Rep a)) => g -> m a
uniformM = fmap to . (`runContT` pure) . guniformM
{-# INLINE uniformM #-}
class GUniform f where
guniformM :: StatefulGen g m => g -> ContT r m (f a)
instance GUniform f => GUniform (M1 i c f) where
guniformM = fmap M1 . guniformM
{-# INLINE guniformM #-}
instance Uniform a => GUniform (K1 i a) where
guniformM = fmap K1 . lift . uniformM
{-# INLINE guniformM #-}
instance GUniform U1 where
guniformM = const $ return U1
{-# INLINE guniformM #-}
instance (GUniform f, GUniform g) => GUniform (f :*: g) where
guniformM g = (:*:) <$> guniformM g <*> guniformM g
{-# INLINE guniformM #-}
instance (GFinite f, GFinite g) => GUniform (f :+: g) where
guniformM = lift . finiteUniformM
{-# INLINE guniformM #-}
finiteUniformM :: forall g m f a. (StatefulGen g m, GFinite f) => g -> m (f a)
finiteUniformM = fmap toGFinite . case gcardinality (proxy# :: Proxy# f) of
Shift n
| n <= 64 -> fmap toInteger . unsignedBitmaskWithRejectionM uniformWord64 (bit n - 1)
| otherwise -> boundedByPowerOf2ExclusiveIntegralM n
Card n
| n <= bit 64 -> fmap toInteger . unsignedBitmaskWithRejectionM uniformWord64 (fromInteger n - 1)
| otherwise -> boundedExclusiveIntegralM n
{-# INLINE finiteUniformM #-}
uniformViaFiniteM :: (StatefulGen g m, Generic a, GFinite (Rep a)) => g -> m a
uniformViaFiniteM = fmap to . finiteUniformM
{-# INLINE uniformViaFiniteM #-}
class UniformRange a where
uniformRM :: StatefulGen g m => (a, a) -> g -> m a
instance UniformRange Integer where
uniformRM = uniformIntegralM
{-# INLINE uniformRM #-}
instance UniformRange Natural where
uniformRM = uniformIntegralM
{-# INLINE uniformRM #-}
instance Uniform Int8 where
uniformM = fmap (fromIntegral :: Word8 -> Int8) . uniformWord8
{-# INLINE uniformM #-}
instance UniformRange Int8 where
uniformRM = signedBitmaskWithRejectionRM (fromIntegral :: Int8 -> Word8) fromIntegral
{-# INLINE uniformRM #-}
instance Uniform Int16 where
uniformM = fmap (fromIntegral :: Word16 -> Int16) . uniformWord16
{-# INLINE uniformM #-}
instance UniformRange Int16 where
uniformRM = signedBitmaskWithRejectionRM (fromIntegral :: Int16 -> Word16) fromIntegral
{-# INLINE uniformRM #-}
instance Uniform Int32 where
uniformM = fmap (fromIntegral :: Word32 -> Int32) . uniformWord32
{-# INLINE uniformM #-}
instance UniformRange Int32 where
uniformRM = signedBitmaskWithRejectionRM (fromIntegral :: Int32 -> Word32) fromIntegral
{-# INLINE uniformRM #-}
instance Uniform Int64 where
uniformM = fmap (fromIntegral :: Word64 -> Int64) . uniformWord64
{-# INLINE uniformM #-}
instance UniformRange Int64 where
uniformRM = signedBitmaskWithRejectionRM (fromIntegral :: Int64 -> Word64) fromIntegral
{-# INLINE uniformRM #-}
wordSizeInBits :: Int
wordSizeInBits = finiteBitSize (0 :: Word)
instance Uniform Int where
uniformM
| wordSizeInBits == 64 =
fmap (fromIntegral :: Word64 -> Int) . uniformWord64
| otherwise =
fmap (fromIntegral :: Word32 -> Int) . uniformWord32
{-# INLINE uniformM #-}
instance UniformRange Int where
uniformRM = signedBitmaskWithRejectionRM (fromIntegral :: Int -> Word) fromIntegral
{-# INLINE uniformRM #-}
instance Uniform Word where
uniformM
| wordSizeInBits == 64 =
fmap (fromIntegral :: Word64 -> Word) . uniformWord64
| otherwise =
fmap (fromIntegral :: Word32 -> Word) . uniformWord32
{-# INLINE uniformM #-}
instance UniformRange Word where
uniformRM = unsignedBitmaskWithRejectionRM
{-# INLINE uniformRM #-}
instance Uniform Word8 where
uniformM = uniformWord8
{-# INLINE uniformM #-}
instance UniformRange Word8 where
uniformRM = unbiasedWordMult32RM
{-# INLINE uniformRM #-}
instance Uniform Word16 where
uniformM = uniformWord16
{-# INLINE uniformM #-}
instance UniformRange Word16 where
uniformRM = unbiasedWordMult32RM
{-# INLINE uniformRM #-}
instance Uniform Word32 where
uniformM = uniformWord32
{-# INLINE uniformM #-}
instance UniformRange Word32 where
uniformRM = unbiasedWordMult32RM
{-# INLINE uniformRM #-}
instance Uniform Word64 where
uniformM = uniformWord64
{-# INLINE uniformM #-}
instance UniformRange Word64 where
uniformRM = unsignedBitmaskWithRejectionRM
{-# INLINE uniformRM #-}
#if __GLASGOW_HASKELL__ >= 802
instance Uniform CBool where
uniformM = fmap CBool . uniformM
{-# INLINE uniformM #-}
instance UniformRange CBool where
uniformRM (CBool b, CBool t) = fmap CBool . uniformRM (b, t)
{-# INLINE uniformRM #-}
#endif
instance Uniform CChar where
uniformM = fmap CChar . uniformM
{-# INLINE uniformM #-}
instance UniformRange CChar where
uniformRM (CChar b, CChar t) = fmap CChar . uniformRM (b, t)
{-# INLINE uniformRM #-}
instance Uniform CSChar where
uniformM = fmap CSChar . uniformM
{-# INLINE uniformM #-}
instance UniformRange CSChar where
uniformRM (CSChar b, CSChar t) = fmap CSChar . uniformRM (b, t)
{-# INLINE uniformRM #-}
instance Uniform CUChar where
uniformM = fmap CUChar . uniformM
{-# INLINE uniformM #-}
instance UniformRange CUChar where
uniformRM (CUChar b, CUChar t) = fmap CUChar . uniformRM (b, t)
{-# INLINE uniformRM #-}
instance Uniform CShort where
uniformM = fmap CShort . uniformM
{-# INLINE uniformM #-}
instance UniformRange CShort where
uniformRM (CShort b, CShort t) = fmap CShort . uniformRM (b, t)
{-# INLINE uniformRM #-}
instance Uniform CUShort where
uniformM = fmap CUShort . uniformM
{-# INLINE uniformM #-}
instance UniformRange CUShort where
uniformRM (CUShort b, CUShort t) = fmap CUShort . uniformRM (b, t)
{-# INLINE uniformRM #-}
instance Uniform CInt where
uniformM = fmap CInt . uniformM
{-# INLINE uniformM #-}
instance UniformRange CInt where
uniformRM (CInt b, CInt t) = fmap CInt . uniformRM (b, t)
{-# INLINE uniformRM #-}
instance Uniform CUInt where
uniformM = fmap CUInt . uniformM
{-# INLINE uniformM #-}
instance UniformRange CUInt where
uniformRM (CUInt b, CUInt t) = fmap CUInt . uniformRM (b, t)
{-# INLINE uniformRM #-}
instance Uniform CLong where
uniformM = fmap CLong . uniformM
{-# INLINE uniformM #-}
instance UniformRange CLong where
uniformRM (CLong b, CLong t) = fmap CLong . uniformRM (b, t)
{-# INLINE uniformRM #-}
instance Uniform CULong where
uniformM = fmap CULong . uniformM
{-# INLINE uniformM #-}
instance UniformRange CULong where
uniformRM (CULong b, CULong t) = fmap CULong . uniformRM (b, t)
{-# INLINE uniformRM #-}
instance Uniform CPtrdiff where
uniformM = fmap CPtrdiff . uniformM
{-# INLINE uniformM #-}
instance UniformRange CPtrdiff where
uniformRM (CPtrdiff b, CPtrdiff t) = fmap CPtrdiff . uniformRM (b, t)
{-# INLINE uniformRM #-}
instance Uniform CSize where
uniformM = fmap CSize . uniformM
{-# INLINE uniformM #-}
instance UniformRange CSize where
uniformRM (CSize b, CSize t) = fmap CSize . uniformRM (b, t)
{-# INLINE uniformRM #-}
instance Uniform CWchar where
uniformM = fmap CWchar . uniformM
{-# INLINE uniformM #-}
instance UniformRange CWchar where
uniformRM (CWchar b, CWchar t) = fmap CWchar . uniformRM (b, t)
{-# INLINE uniformRM #-}
instance Uniform CSigAtomic where
uniformM = fmap CSigAtomic . uniformM
{-# INLINE uniformM #-}
instance UniformRange CSigAtomic where
uniformRM (CSigAtomic b, CSigAtomic t) = fmap CSigAtomic . uniformRM (b, t)
{-# INLINE uniformRM #-}
instance Uniform CLLong where
uniformM = fmap CLLong . uniformM
{-# INLINE uniformM #-}
instance UniformRange CLLong where
uniformRM (CLLong b, CLLong t) = fmap CLLong . uniformRM (b, t)
{-# INLINE uniformRM #-}
instance Uniform CULLong where
uniformM = fmap CULLong . uniformM
{-# INLINE uniformM #-}
instance UniformRange CULLong where
uniformRM (CULLong b, CULLong t) = fmap CULLong . uniformRM (b, t)
{-# INLINE uniformRM #-}
instance Uniform CIntPtr where
uniformM = fmap CIntPtr . uniformM
{-# INLINE uniformM #-}
instance UniformRange CIntPtr where
uniformRM (CIntPtr b, CIntPtr t) = fmap CIntPtr . uniformRM (b, t)
{-# INLINE uniformRM #-}
instance Uniform CUIntPtr where
uniformM = fmap CUIntPtr . uniformM
{-# INLINE uniformM #-}
instance UniformRange CUIntPtr where
uniformRM (CUIntPtr b, CUIntPtr t) = fmap CUIntPtr . uniformRM (b, t)
{-# INLINE uniformRM #-}
instance Uniform CIntMax where
uniformM = fmap CIntMax . uniformM
{-# INLINE uniformM #-}
instance UniformRange CIntMax where
uniformRM (CIntMax b, CIntMax t) = fmap CIntMax . uniformRM (b, t)
{-# INLINE uniformRM #-}
instance Uniform CUIntMax where
uniformM = fmap CUIntMax . uniformM
{-# INLINE uniformM #-}
instance UniformRange CUIntMax where
uniformRM (CUIntMax b, CUIntMax t) = fmap CUIntMax . uniformRM (b, t)
{-# INLINE uniformRM #-}
instance UniformRange CFloat where
uniformRM (CFloat l, CFloat h) = fmap CFloat . uniformRM (l, h)
{-# INLINE uniformRM #-}
instance UniformRange CDouble where
uniformRM (CDouble l, CDouble h) = fmap CDouble . uniformRM (l, h)
{-# INLINE uniformRM #-}
word32ToChar :: Word32 -> Char
#if __GLASGOW_HASKELL__ < 902
word32ToChar (W32# w#) = C# (chr# (word2Int# w#))
#else
word32ToChar (W32# w#) = C# (chr# (word2Int# (word32ToWord# w#)))
#endif
{-# INLINE word32ToChar #-}
charToWord32 :: Char -> Word32
#if __GLASGOW_HASKELL__ < 902
charToWord32 (C# c#) = W32# (int2Word# (ord# c#))
#else
charToWord32 (C# c#) = W32# (wordToWord32# (int2Word# (ord# c#)))
#endif
{-# INLINE charToWord32 #-}
instance Uniform Char where
uniformM g = word32ToChar <$> unbiasedWordMult32 (charToWord32 maxBound) g
{-# INLINE uniformM #-}
instance UniformRange Char where
uniformRM (l, h) g =
word32ToChar <$> unbiasedWordMult32RM (charToWord32 l, charToWord32 h) g
{-# INLINE uniformRM #-}
instance Uniform () where
uniformM = const $ pure ()
{-# INLINE uniformM #-}
instance UniformRange () where
uniformRM = const $ const $ pure ()
{-# INLINE uniformRM #-}
instance Uniform Bool where
uniformM = fmap wordToBool . uniformWord8
where wordToBool w = (w .&. 1) /= 0
{-# INLINE wordToBool #-}
{-# INLINE uniformM #-}
instance UniformRange Bool where
uniformRM (False, False) _g = return False
uniformRM (True, True) _g = return True
uniformRM _ g = uniformM g
{-# INLINE uniformRM #-}
instance UniformRange Double where
uniformRM (l, h) g
| l == h = return l
| isInfinite l || isInfinite h =
return $! h + l
| otherwise = do
x <- uniformDouble01M g
return $ x * l + (1 -x) * h
{-# INLINE uniformRM #-}
uniformDouble01M :: forall g m. StatefulGen g m => g -> m Double
uniformDouble01M g = do
w64 <- uniformWord64 g
return $ fromIntegral w64 / m
where
m = fromIntegral (maxBound :: Word64) :: Double
{-# INLINE uniformDouble01M #-}
uniformDoublePositive01M :: forall g m. StatefulGen g m => g -> m Double
uniformDoublePositive01M g = (+ d) <$> uniformDouble01M g
where
d = 2.710505431213761e-20
{-# INLINE uniformDoublePositive01M #-}
instance UniformRange Float where
uniformRM (l, h) g
| l == h = return l
| isInfinite l || isInfinite h =
return $! h + l
| otherwise = do
x <- uniformFloat01M g
return $ x * l + (1 - x) * h
{-# INLINE uniformRM #-}
uniformFloat01M :: forall g m. StatefulGen g m => g -> m Float
uniformFloat01M g = do
w32 <- uniformWord32 g
return $ fromIntegral w32 / m
where
m = fromIntegral (maxBound :: Word32) :: Float
{-# INLINE uniformFloat01M #-}
uniformFloatPositive01M :: forall g m. StatefulGen g m => g -> m Float
uniformFloatPositive01M g = (+ d) <$> uniformFloat01M g
where
d = 1.1641532182693481e-10
{-# INLINE uniformFloatPositive01M #-}
uniformEnumM :: forall a g m. (Enum a, Bounded a, StatefulGen g m) => g -> m a
uniformEnumM g = toEnum <$> uniformRM (fromEnum (minBound :: a), fromEnum (maxBound :: a)) g
{-# INLINE uniformEnumM #-}
uniformEnumRM :: forall a g m. (Enum a, StatefulGen g m) => (a, a) -> g -> m a
uniformEnumRM (l, h) g = toEnum <$> uniformRM (fromEnum l, fromEnum h) g
{-# INLINE uniformEnumRM #-}
randomIvalIntegral :: (RandomGen g, Integral a) => (a, a) -> g -> (a, g)
randomIvalIntegral (l, h) = randomIvalInteger (toInteger l, toInteger h)
{-# SPECIALIZE randomIvalInteger :: (Num a) =>
(Integer, Integer) -> StdGen -> (a, StdGen) #-}
randomIvalInteger :: (RandomGen g, Num a) => (Integer, Integer) -> g -> (a, g)
randomIvalInteger (l, h) rng
| l > h = randomIvalInteger (h,l) rng
| otherwise = case f 1 0 rng of (v, rng') -> (fromInteger (l + v `mod` k), rng')
where
(genlo, genhi) = genRange rng
b = fromIntegral genhi - fromIntegral genlo + 1 :: Integer
q = 1000 :: Integer
k = h - l + 1
magtgt = k * q
f mag v g | mag >= magtgt = (v, g)
| otherwise = v' `seq`f (mag*b) v' g' where
(x,g') = next g
v' = v * b + (fromIntegral x - fromIntegral genlo)
uniformIntegralM :: forall a g m. (Bits a, Integral a, StatefulGen g m) => (a, a) -> g -> m a
uniformIntegralM (l, h) gen = case l `compare` h of
LT -> do
let limit = h - l
bounded <- case toIntegralSized limit :: Maybe Word64 of
Just limitAsWord64 ->
fromIntegral <$> unsignedBitmaskWithRejectionM uniformWord64 limitAsWord64 gen
Nothing -> boundedExclusiveIntegralM (limit + 1) gen
return $ l + bounded
GT -> uniformIntegralM (h, l) gen
EQ -> pure l
{-# INLINEABLE uniformIntegralM #-}
{-# SPECIALIZE uniformIntegralM :: StatefulGen g m => (Integer, Integer) -> g -> m Integer #-}
{-# SPECIALIZE uniformIntegralM :: StatefulGen g m => (Natural, Natural) -> g -> m Natural #-}
boundedExclusiveIntegralM :: forall a g m . (Bits a, Integral a, StatefulGen g m) => a -> g -> m a
boundedExclusiveIntegralM s gen = go
where
n = integralWordSize s
k = wordSizeInBits * n
twoToK = (1 :: a) `shiftL` k
modTwoToKMask = twoToK - 1
t = (twoToK - s) `rem` s
go :: (Bits a, Integral a, StatefulGen g m) => m a
go = do
x <- uniformIntegralWords n gen
let m = x * s
let l = m .&. modTwoToKMask
if l < t
then go
else return $ m `shiftR` k
{-# INLINE boundedExclusiveIntegralM #-}
boundedByPowerOf2ExclusiveIntegralM ::
forall a g m. (Bits a, Integral a, StatefulGen g m) => Int -> g -> m a
boundedByPowerOf2ExclusiveIntegralM s gen = do
let n = (s + wordSizeInBits - 1) `quot` wordSizeInBits
x <- uniformIntegralWords n gen
return $ x .&. (bit s - 1)
{-# INLINE boundedByPowerOf2ExclusiveIntegralM #-}
integralWordSize :: (Bits a, Num a) => a -> Int
integralWordSize = go 0
where
go !acc i
| i == 0 = acc
| otherwise = go (acc + 1) (i `shiftR` wordSizeInBits)
{-# INLINE integralWordSize #-}
uniformIntegralWords :: forall a g m. (Bits a, Integral a, StatefulGen g m) => Int -> g -> m a
uniformIntegralWords n gen = go 0 n
where
go !acc i
| i == 0 = return acc
| otherwise = do
(w :: Word) <- uniformM gen
go ((acc `shiftL` wordSizeInBits) .|. fromIntegral w) (i - 1)
{-# INLINE uniformIntegralWords #-}
unbiasedWordMult32RM :: forall a g m. (Integral a, StatefulGen g m) => (a, a) -> g -> m a
unbiasedWordMult32RM (b, t) g
| b <= t = (+b) . fromIntegral <$> unbiasedWordMult32 (fromIntegral (t - b)) g
| otherwise = (+t) . fromIntegral <$> unbiasedWordMult32 (fromIntegral (b - t)) g
{-# INLINE unbiasedWordMult32RM #-}
unbiasedWordMult32 :: forall g m. StatefulGen g m => Word32 -> g -> m Word32
unbiasedWordMult32 s g
| s == maxBound = uniformWord32 g
| otherwise = unbiasedWordMult32Exclusive (s+1) g
{-# INLINE unbiasedWordMult32 #-}
unbiasedWordMult32Exclusive :: forall g m . StatefulGen g m => Word32 -> g -> m Word32
unbiasedWordMult32Exclusive r g = go
where
t :: Word32
t = (-r) `mod` r
go :: StatefulGen g m => m Word32
go = do
x <- uniformWord32 g
let m :: Word64
m = fromIntegral x * fromIntegral r
l :: Word32
l = fromIntegral m
if l >= t then return (fromIntegral $ m `shiftR` 32) else go
{-# INLINE unbiasedWordMult32Exclusive #-}
unsignedBitmaskWithRejectionRM ::
forall a g m . (FiniteBits a, Num a, Ord a, Uniform a, StatefulGen g m)
=> (a, a)
-> g
-> m a
unsignedBitmaskWithRejectionRM (bottom, top) gen
| bottom == top = pure top
| otherwise = (b +) <$> unsignedBitmaskWithRejectionM uniformM r gen
where
(b, r) = if bottom > top then (top, bottom - top) else (bottom, top - bottom)
{-# INLINE unsignedBitmaskWithRejectionRM #-}
signedBitmaskWithRejectionRM ::
forall a b g m. (Num a, Num b, Ord b, Ord a, FiniteBits a, StatefulGen g m, Uniform a)
=> (b -> a)
-> (a -> b)
-> (b, b)
-> g
-> m b
signedBitmaskWithRejectionRM toUnsigned fromUnsigned (bottom, top) gen
| bottom == top = pure top
| otherwise =
(b +) . fromUnsigned <$> unsignedBitmaskWithRejectionM uniformM r gen
where
(b, r) =
if bottom > top
then (top, toUnsigned bottom - toUnsigned top)
else (bottom, toUnsigned top - toUnsigned bottom)
{-# INLINE signedBitmaskWithRejectionRM #-}
unsignedBitmaskWithRejectionM ::
forall a g m. (Ord a, FiniteBits a, Num a, StatefulGen g m) => (g -> m a) -> a -> g -> m a
unsignedBitmaskWithRejectionM genUniformM range gen = go
where
mask :: a
mask = complement zeroBits `shiftR` countLeadingZeros (range .|. 1)
go = do
x <- genUniformM gen
let x' = x .&. mask
if x' > range
then go
else pure x'
{-# INLINE unsignedBitmaskWithRejectionM #-}
instance (Uniform a, Uniform b) => Uniform (a, b) where
uniformM g = (,) <$> uniformM g <*> uniformM g
{-# INLINE uniformM #-}
instance (Uniform a, Uniform b, Uniform c) => Uniform (a, b, c) where
uniformM g = (,,) <$> uniformM g <*> uniformM g <*> uniformM g
{-# INLINE uniformM #-}
instance (Uniform a, Uniform b, Uniform c, Uniform d) => Uniform (a, b, c, d) where
uniformM g = (,,,) <$> uniformM g <*> uniformM g <*> uniformM g <*> uniformM g
{-# INLINE uniformM #-}
instance (Uniform a, Uniform b, Uniform c, Uniform d, Uniform e) => Uniform (a, b, c, d, e) where
uniformM g = (,,,,) <$> uniformM g <*> uniformM g <*> uniformM g <*> uniformM g <*> uniformM g
{-# INLINE uniformM #-}
instance (Uniform a, Uniform b, Uniform c, Uniform d, Uniform e, Uniform f) =>
Uniform (a, b, c, d, e, f) where
uniformM g = (,,,,,)
<$> uniformM g
<*> uniformM g
<*> uniformM g
<*> uniformM g
<*> uniformM g
<*> uniformM g
{-# INLINE uniformM #-}
instance (Uniform a, Uniform b, Uniform c, Uniform d, Uniform e, Uniform f, Uniform g) =>
Uniform (a, b, c, d, e, f, g) where
uniformM g = (,,,,,,)
<$> uniformM g
<*> uniformM g
<*> uniformM g
<*> uniformM g
<*> uniformM g
<*> uniformM g
<*> uniformM g
{-# INLINE uniformM #-}