module Foundation.Random
( MonadRandom(..)
, MonadRandomState(..)
, RandomGen(..)
, withRandomGenerator
, RNG
, RNGv1
) where
import Foundation.Class.Storable (peek)
import Foundation.Internal.Base
import Foundation.Primitive.Types.OffsetSize
import Foundation.Internal.Proxy
import Foundation.Primitive.Monad
import Foundation.System.Entropy
import Foundation.Array
import qualified Foundation.Array.Unboxed as A
import qualified Foundation.Array.Unboxed.Mutable as A
import GHC.ST
import qualified Prelude
import qualified Foreign.Marshal.Alloc (alloca)
class (Functor m, Applicative m, Monad m) => MonadRandom m where
getRandomBytes :: CountOf Word8 -> m (UArray Word8)
getRandomWord64 :: m Word64
getRandomF32 :: m Float
getRandomF64 :: m Double
instance MonadRandom IO where
getRandomBytes = getEntropy
getRandomWord64 = flip A.index 0 . A.unsafeRecast
<$> getRandomBytes (A.primSizeInBytes (Proxy :: Proxy Word64))
getRandomF32 = flip A.index 0 . A.unsafeRecast
<$> getRandomBytes (A.primSizeInBytes (Proxy :: Proxy Word64))
getRandomF64 = flip A.index 0 . A.unsafeRecast
<$> getRandomBytes (A.primSizeInBytes (Proxy :: Proxy Word64))
class RandomGen gen where
randomNew :: MonadRandom m => m gen
randomNewFrom :: UArray Word8 -> Maybe gen
randomGenerate :: CountOf Word8 -> gen -> (UArray Word8, gen)
randomGenerateWord64 :: gen -> (Word64, gen)
randomGenerateF32 :: gen -> (Float, gen)
randomGenerateF64 :: gen -> (Double, gen)
newtype MonadRandomState gen a = MonadRandomState { runRandomState :: gen -> (a, gen) }
instance Functor (MonadRandomState gen) where
fmap f m = MonadRandomState $ \g1 ->
let (a, g2) = runRandomState m g1 in (f a, g2)
instance Applicative (MonadRandomState gen) where
pure a = MonadRandomState $ \g -> (a, g)
(<*>) fm m = MonadRandomState $ \g1 ->
let (f, g2) = runRandomState fm g1
(a, g3) = runRandomState m g2
in (f a, g3)
instance Monad (MonadRandomState gen) where
return a = MonadRandomState $ \g -> (a, g)
(>>=) m1 m2 = MonadRandomState $ \g1 ->
let (a, g2) = runRandomState m1 g1
in runRandomState (m2 a) g2
instance RandomGen gen => MonadRandom (MonadRandomState gen) where
getRandomBytes n = MonadRandomState (randomGenerate n)
getRandomWord64 = MonadRandomState randomGenerateWord64
getRandomF32 = MonadRandomState randomGenerateF32
getRandomF64 = MonadRandomState randomGenerateF64
withRandomGenerator :: RandomGen gen
=> gen
-> MonadRandomState gen a
-> (a, gen)
withRandomGenerator gen m = runRandomState m gen
type RNG = RNGv1
newtype RNGv1 = RNGv1 (UArray Word8)
instance RandomGen RNGv1 where
randomNew = RNGv1 <$> getRandomBytes 32
randomNewFrom bs
| A.length bs == 32 = Just $ RNGv1 bs
| otherwise = Nothing
randomGenerate = rngv1Generate
randomGenerateWord64 = rngv1GenerateWord64
randomGenerateF32 = rngv1GenerateF32
randomGenerateF64 = rngv1GenerateF64
rngv1KeySize :: CountOf Word8
rngv1KeySize = 32
rngv1Generate :: CountOf Word8 -> RNGv1 -> (UArray Word8, RNGv1)
rngv1Generate n@(CountOf x) (RNGv1 key) = runST $ do
dst <- A.newPinned n
newKey <- A.newPinned rngv1KeySize
A.withMutablePtr dst $ \dstP ->
A.withMutablePtr newKey $ \newKeyP ->
A.withPtr key $ \keyP -> do
_ <- unsafePrimFromIO $ c_rngv1_generate newKeyP dstP keyP (Prelude.fromIntegral x)
return ()
(,) <$> A.unsafeFreeze dst
<*> (RNGv1 <$> A.unsafeFreeze newKey)
rngv1GenerateWord64 :: RNGv1 -> (Word64, RNGv1)
rngv1GenerateWord64 (RNGv1 key) = runST $ unsafePrimFromIO $
Foreign.Marshal.Alloc.alloca $ \dst -> do
newKey <- A.newPinned rngv1KeySize
A.withMutablePtr newKey $ \newKeyP ->
A.withPtr key $ \keyP ->
c_rngv1_generate_word64 newKeyP dst keyP *> return ()
(,) <$> peek dst <*> (RNGv1 <$> A.unsafeFreeze newKey)
rngv1GenerateF32 :: RNGv1 -> (Float, RNGv1)
rngv1GenerateF32 (RNGv1 key) = runST $ unsafePrimFromIO $
Foreign.Marshal.Alloc.alloca $ \dst -> do
newKey <- A.newPinned rngv1KeySize
A.withMutablePtr newKey $ \newKeyP ->
A.withPtr key $ \keyP ->
c_rngv1_generate_f32 newKeyP dst keyP *> return ()
(,) <$> peek dst <*> (RNGv1 <$> A.unsafeFreeze newKey)
rngv1GenerateF64 :: RNGv1 -> (Double, RNGv1)
rngv1GenerateF64 (RNGv1 key) = runST $ unsafePrimFromIO $
Foreign.Marshal.Alloc.alloca $ \dst -> do
newKey <- A.newPinned rngv1KeySize
A.withMutablePtr newKey $ \newKeyP ->
A.withPtr key $ \keyP ->
c_rngv1_generate_f64 newKeyP dst keyP *> return ()
(,) <$> peek dst <*> (RNGv1 <$> A.unsafeFreeze newKey)
foreign import ccall unsafe "foundation_rngV1_generate"
c_rngv1_generate :: Ptr Word8
-> Ptr Word8
-> Ptr Word8
-> Word32
-> IO Word32
foreign import ccall unsafe "foundation_rngV1_generate_word64"
c_rngv1_generate_word64 :: Ptr Word8
-> Ptr Word64
-> Ptr Word8
-> IO Word32
foreign import ccall unsafe "foundation_rngV1_generate_f32"
c_rngv1_generate_f32 :: Ptr Word8
-> Ptr Float
-> Ptr Word8
-> IO Word32
foreign import ccall unsafe "foundation_rngV1_generate_f64"
c_rngv1_generate_f64 :: Ptr Word8
-> Ptr Double
-> Ptr Word8
-> IO Word32