{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GHCForeignImportPrim #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE UnboxedTuples #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE UnliftedFFITypes #-}
#if __GLASGOW_HASKELL__ >= 800
{-# LANGUAGE TypeFamilyDependencies #-}
#else
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE KindSignatures #-}
#endif
{-# OPTIONS_HADDOCK hide, not-home #-}
module System.Random.Internal
(
RandomGen(..)
, StatefulGen(..)
, FrozenGen(..)
, StdGen(..)
, mkStdGen
, StateGen(..)
, StateGenM(..)
, splitGen
, runStateGen
, runStateGen_
, runStateGenT
, runStateGenT_
, runStateGenST
, Uniform(..)
, UniformRange(..)
, uniformByteStringM
, uniformDouble01M
, uniformDoublePositive01M
, uniformFloat01M
, uniformFloatPositive01M
, genShortByteStringIO
, genShortByteStringST
) where
import Control.Arrow
import Control.DeepSeq (NFData)
import Control.Monad.IO.Class
import Control.Monad.ST
import Control.Monad.ST.Unsafe
import Control.Monad.State.Strict
import Data.Bits
import Data.ByteString.Builder.Prim (word64LE)
import Data.ByteString.Builder.Prim.Internal (runF)
import Data.ByteString.Short.Internal (ShortByteString(SBS), fromShort)
import Data.Int
import Data.Word
import Foreign.C.Types
import Foreign.Ptr (plusPtr)
import Foreign.Storable (Storable(pokeByteOff))
import GHC.Exts
import GHC.IO (IO(..))
import GHC.Word
import Numeric.Natural (Natural)
import System.IO.Unsafe (unsafePerformIO)
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
{-# 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
genWord16 :: g -> (Word16, g)
genWord16 = first fromIntegral . genWord32
genWord32 :: g -> (Word32, g)
genWord32 = randomIvalIntegral (minBound, maxBound)
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'')
genWord32R :: Word32 -> g -> (Word32, g)
genWord32R m g = runStateGen g (unbiasedWordMult32 m)
genWord64R :: Word64 -> g -> (Word64, g)
genWord64R m g = runStateGen g (unsignedBitmaskWithRejectionM uniformWord64 m)
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
uniformWord64R :: Word64 -> g -> m Word64
uniformWord64R = unsignedBitmaskWithRejectionM uniformWord64
uniformWord8 :: g -> m Word8
uniformWord8 = fmap fromIntegral . uniformWord32
uniformWord16 :: g -> m Word16
uniformWord16 = fmap fromIntegral . uniformWord32
uniformWord32 :: g -> m Word32
uniformWord32 = fmap fromIntegral . uniformWord64
uniformWord64 :: g -> m Word64
uniformWord64 g = do
l32 <- uniformWord32 g
h32 <- uniformWord32 g
pure (shiftL (fromIntegral h32) 32 .|. fromIntegral l32)
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 s = MBA (MutableByteArray# s)
genShortByteStringIO ::
MonadIO m
=> Int
-> m Word64
-> m ShortByteString
genShortByteStringIO n0 gen64 = do
let !n@(I# n#) = max 0 n0
!n64 = n `quot` 8
!nrem64 = n `rem` 8
MBA mba# <-
liftIO $
IO $ \s# ->
case newPinnedByteArray# n# s# of
(# s'#, mba# #) -> (# s'#, MBA mba# #)
let go i ptr
| i < n64 = do
w64 <- gen64
liftIO $ runF word64LE w64 ptr
go (i + 1) (ptr `plusPtr` 8)
| otherwise = return ptr
ptr <- go 0 (Ptr (byteArrayContents# (unsafeCoerce# mba#)))
when (nrem64 > 0) $ do
w64 <- gen64
liftIO $ do
let goRem64 z i =
when (i < nrem64) $ do
pokeByteOff ptr i (fromIntegral z :: Word8)
goRem64 (z `shiftR` 8) (i + 1)
goRem64 w64 0
liftIO $
IO $ \s# ->
case unsafeFreezeByteArray# mba# s# of
(# s'#, ba# #) -> (# s'#, SBS ba# #)
{-# INLINE genShortByteStringIO #-}
genShortByteStringST :: Int -> ST s Word64 -> ST s ShortByteString
genShortByteStringST n action =
unsafeIOToST (genShortByteStringIO n (unsafeSTToIO action))
{-# INLINE uniformByteStringM #-}
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
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)
uniformWord64R r _ = state (genWord64R r)
uniformWord8 _ = state genWord8
uniformWord16 _ = state genWord16
uniformWord32 _ = state genWord32
uniformWord64 _ = state genWord64
uniformShortByteString n _ = state (genShortByteString n)
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
runStateGen :: RandomGen g => g -> (StateGenM g -> State g a) -> (a, g)
runStateGen g f = runState (f StateGenM) g
runStateGen_ :: RandomGen g => g -> (StateGenM g -> State g a) -> a
runStateGen_ g = fst . runStateGen g
runStateGenT :: RandomGen g => g -> (StateGenM g -> StateT g m a) -> m (a, g)
runStateGenT g f = runStateT (f StateGenM) g
runStateGenT_ :: (RandomGen g, Functor f) => g -> (StateGenM g -> StateT g f a) -> f a
runStateGenT_ g = fmap fst . runStateGenT g
runStateGenST :: RandomGen g => g -> (forall s . StateGenM g -> StateT g (ST s) a) -> (a, g)
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
genWord32 = SM.nextWord32
genWord64 = SM.nextWord64
split = SM.splitSMGen
instance RandomGen SM32.SMGen where
next = SM32.nextInt
genWord32 = SM32.nextWord32
genWord64 = SM32.nextWord64
split = SM32.splitSMGen
mkStdGen :: Int -> StdGen
mkStdGen = StdGen . SM.mkSMGen . fromIntegral
class Uniform a where
uniformM :: StatefulGen g m => g -> m a
class UniformRange a where
uniformRM :: StatefulGen g m => (a, a) -> g -> m a
instance UniformRange Integer where
uniformRM = uniformIntegralM
instance UniformRange Natural where
uniformRM = uniformIntegralM
instance Uniform Int8 where
uniformM = fmap (fromIntegral :: Word8 -> Int8) . uniformWord8
instance UniformRange Int8 where
uniformRM = signedBitmaskWithRejectionRM (fromIntegral :: Int8 -> Word8) fromIntegral
instance Uniform Int16 where
uniformM = fmap (fromIntegral :: Word16 -> Int16) . uniformWord16
instance UniformRange Int16 where
uniformRM = signedBitmaskWithRejectionRM (fromIntegral :: Int16 -> Word16) fromIntegral
{-# INLINE uniformRM #-}
instance Uniform Int32 where
uniformM = fmap (fromIntegral :: Word32 -> Int32) . uniformWord32
instance UniformRange Int32 where
uniformRM = signedBitmaskWithRejectionRM (fromIntegral :: Int32 -> Word32) fromIntegral
{-# INLINE uniformRM #-}
instance Uniform Int64 where
uniformM = fmap (fromIntegral :: Word64 -> Int64) . uniformWord64
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
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
instance UniformRange Word where
{-# INLINE uniformRM #-}
uniformRM = unsignedBitmaskWithRejectionRM
instance Uniform Word8 where
{-# INLINE uniformM #-}
uniformM = uniformWord8
instance UniformRange Word8 where
{-# INLINE uniformRM #-}
uniformRM = unbiasedWordMult32RM
instance Uniform Word16 where
{-# INLINE uniformM #-}
uniformM = uniformWord16
instance UniformRange Word16 where
{-# INLINE uniformRM #-}
uniformRM = unbiasedWordMult32RM
instance Uniform Word32 where
{-# INLINE uniformM #-}
uniformM = uniformWord32
instance UniformRange Word32 where
{-# INLINE uniformRM #-}
uniformRM = unbiasedWordMult32RM
instance Uniform Word64 where
{-# INLINE uniformM #-}
uniformM = uniformWord64
instance UniformRange Word64 where
{-# INLINE uniformRM #-}
uniformRM = unsignedBitmaskWithRejectionRM
#if __GLASGOW_HASKELL__ >= 802
instance Uniform CBool where
uniformM = fmap CBool . 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
instance UniformRange CChar where
uniformRM (CChar b, CChar t) = fmap CChar . uniformRM (b, t)
{-# INLINE uniformRM #-}
instance Uniform CSChar where
uniformM = fmap CSChar . 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
instance UniformRange CUChar where
uniformRM (CUChar b, CUChar t) = fmap CUChar . uniformRM (b, t)
{-# INLINE uniformRM #-}
instance Uniform CShort where
uniformM = fmap CShort . 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
instance UniformRange CUShort where
uniformRM (CUShort b, CUShort t) = fmap CUShort . uniformRM (b, t)
{-# INLINE uniformRM #-}
instance Uniform CInt where
uniformM = fmap CInt . 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
instance UniformRange CUInt where
uniformRM (CUInt b, CUInt t) = fmap CUInt . uniformRM (b, t)
{-# INLINE uniformRM #-}
instance Uniform CLong where
uniformM = fmap CLong . 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
instance UniformRange CULong where
uniformRM (CULong b, CULong t) = fmap CULong . uniformRM (b, t)
{-# INLINE uniformRM #-}
instance Uniform CPtrdiff where
uniformM = fmap CPtrdiff . 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
instance UniformRange CSize where
uniformRM (CSize b, CSize t) = fmap CSize . uniformRM (b, t)
{-# INLINE uniformRM #-}
instance Uniform CWchar where
uniformM = fmap CWchar . 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
instance UniformRange CSigAtomic where
uniformRM (CSigAtomic b, CSigAtomic t) = fmap CSigAtomic . uniformRM (b, t)
{-# INLINE uniformRM #-}
instance Uniform CLLong where
uniformM = fmap CLLong . 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
instance UniformRange CULLong where
uniformRM (CULLong b, CULLong t) = fmap CULLong . uniformRM (b, t)
{-# INLINE uniformRM #-}
instance Uniform CIntPtr where
uniformM = fmap CIntPtr . 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
instance UniformRange CUIntPtr where
uniformRM (CUIntPtr b, CUIntPtr t) = fmap CUIntPtr . uniformRM (b, t)
{-# INLINE uniformRM #-}
instance Uniform CIntMax where
uniformM = fmap CIntMax . 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
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
word32ToChar (W32# w#) = C# (chr# (word2Int# w#))
{-# INLINE word32ToChar #-}
charToWord32 :: Char -> Word32
charToWord32 (C# c#) = W32# (int2Word# (ord# c#))
{-# 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 Bool where
uniformM = fmap wordToBool . uniformWord8
where wordToBool w = (w .&. 1) /= 0
instance UniformRange Bool where
uniformRM (False, False) _g = return False
uniformRM (True, True) _g = return True
uniformRM _ g = uniformM g
instance UniformRange Double where
uniformRM (l, h) g
| l == h = return l
| otherwise = do
x <- uniformDouble01M g
return $ x * l + (1 -x) * h
uniformDouble01M :: StatefulGen g m => g -> m Double
uniformDouble01M g = do
w64 <- uniformWord64 g
return $ fromIntegral w64 / m
where
m = fromIntegral (maxBound :: Word64) :: Double
uniformDoublePositive01M :: StatefulGen g m => g -> m Double
uniformDoublePositive01M g = (+ d) <$> uniformDouble01M g
where
d = 2.710505431213761e-20
instance UniformRange Float where
uniformRM (l, h) g
| l == h = return l
| otherwise = do
x <- uniformFloat01M g
return $ x * l + (1 - x) * h
uniformFloat01M :: StatefulGen g m => g -> m Float
uniformFloat01M g = do
w32 <- uniformWord32 g
return $ fromIntegral w32 / m
where
m = fromIntegral (maxBound :: Word32) :: Float
uniformFloatPositive01M :: StatefulGen g m => g -> m Float
uniformFloatPositive01M g = (+ d) <$> uniformFloat01M g
where
d = 1.1641532182693481e-10
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 :: (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 #-}
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 #-}
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 :: (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 :: (StatefulGen g m, Integral a) => (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
{-# SPECIALIZE unbiasedWordMult32RM :: StatefulGen g m => (Word8, Word8) -> g -> m Word8 #-}
unbiasedWordMult32 :: 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
unsignedBitmaskWithRejectionRM ::
(StatefulGen g m, FiniteBits a, Num a, Ord a, Uniform a)
=> (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 ::
(Num a, Num b, Ord b, Ord a, FiniteBits a, StatefulGen g f, Uniform a)
=> (b -> a)
-> (a -> b)
-> (b, b)
-> g
-> f 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
instance (Uniform a, Uniform b, Uniform c) => Uniform (a, b, c) where
uniformM g = (,,) <$> uniformM g <*> uniformM g <*> uniformM g
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
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
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
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