{-# Language CPP, BangPatterns, MagicHash, ForeignFunctionInterface, UnliftedFFITypes #-}
module System.Random.TF.Gen
(TFGen, RandomGen(..), seedTFGen)
where
import qualified System.Random as R
import System.IO.Unsafe
import Data.Bits
import Data.Char (toUpper, isSpace)
import Data.Maybe (isJust, fromJust)
import Data.Int
import Data.Word
import Data.Primitive.ByteArray
import Numeric
#if !MIN_VERSION_base(4,4,0)
unsafeDupablePerformIO :: IO a -> a
unsafeDupablePerformIO = unsafePerformIO
#endif
foreign import ccall unsafe "skein.h Threefish_256_Process_Block"
threefish256EncryptBlock ::
ByteArray# -> ByteArray# -> MutableByteArray# s -> Int -> IO ()
createBlock256 :: Word64 -> Word64 -> Word64 -> Word64 -> IO ByteArray
createBlock256 :: Word64 -> Word64 -> Word64 -> Word64 -> IO ByteArray
createBlock256 !Word64
a !Word64
b !Word64
c !Word64
d = do
MutableByteArray RealWorld
ma <- forall (m :: * -> *).
PrimMonad m =>
Int -> m (MutableByteArray (PrimState m))
newByteArray Int
32
forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutableByteArray (PrimState m) -> Int -> a -> m ()
writeByteArray MutableByteArray RealWorld
ma Int
0 Word64
a
forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutableByteArray (PrimState m) -> Int -> a -> m ()
writeByteArray MutableByteArray RealWorld
ma Int
1 Word64
b
forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutableByteArray (PrimState m) -> Int -> a -> m ()
writeByteArray MutableByteArray RealWorld
ma Int
2 Word64
c
forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutableByteArray (PrimState m) -> Int -> a -> m ()
writeByteArray MutableByteArray RealWorld
ma Int
3 Word64
d
forall (m :: * -> *).
PrimMonad m =>
MutableByteArray (PrimState m) -> m ByteArray
unsafeFreezeByteArray MutableByteArray RealWorld
ma
readBlock256 :: ByteArray -> (Word64, Word64, Word64, Word64)
readBlock256 :: ByteArray -> (Word64, Word64, Word64, Word64)
readBlock256 ByteArray
ba =
( forall a. Prim a => ByteArray -> Int -> a
indexByteArray ByteArray
ba Int
0
, forall a. Prim a => ByteArray -> Int -> a
indexByteArray ByteArray
ba Int
1
, forall a. Prim a => ByteArray -> Int -> a
indexByteArray ByteArray
ba Int
2
, forall a. Prim a => ByteArray -> Int -> a
indexByteArray ByteArray
ba Int
3 )
data TFGen =
TFGen
{-# UNPACK #-} !ByteArray
{-# UNPACK #-} !Word64
{-# UNPACK #-} !Word64
{-# UNPACK #-} !Int16
{-# UNPACK #-} !Int16
ByteArray
newtype Hex = Hex ByteArray
instance Show Hex where
showsPrec :: Int -> Hex -> ShowS
showsPrec Int
_ (Hex ByteArray
ba) =
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toUpper forall b c a. (b -> c) -> (a -> b) -> a -> c
.
forall {a}. (Integral a, Show a) => a -> ShowS
showHex' Word64
x1 forall b c a. (b -> c) -> (a -> b) -> a -> c
.
forall {a}. (Integral a, Show a) => a -> ShowS
showHex' Word64
x2 forall b c a. (b -> c) -> (a -> b) -> a -> c
.
forall {a}. (Integral a, Show a) => a -> ShowS
showHex' Word64
x3 forall b c a. (b -> c) -> (a -> b) -> a -> c
.
forall {a}. (Integral a, Show a) => a -> ShowS
showHex' Word64
x4
where
(Word64
x1, Word64
x2, Word64
x3, Word64
x4) = ByteArray -> (Word64, Word64, Word64, Word64)
readBlock256 ByteArray
ba
showHex' :: a -> ShowS
showHex' a
x String
c = (ShowS
pad forall a b. (a -> b) -> a -> b
$ forall {a}. (Integral a, Show a) => a -> ShowS
showHex a
x String
"") forall a. [a] -> [a] -> [a]
++ String
c
pad :: ShowS
pad String
s = forall a. Int -> [a] -> [a]
take (Int
16 forall a. Num a => a -> a -> a
- Int
l) (forall a. a -> [a]
repeat Char
'0') forall a. [a] -> [a] -> [a]
++ String
s
where l :: Int
l = forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s
instance Read Hex where
readsPrec :: Int -> ReadS Hex
readsPrec Int
_ = forall a b. (a -> b) -> [a] -> [b]
map (\([Word64]
l, String
s) -> (ByteArray -> Hex
Hex forall a b. (a -> b) -> a -> b
$ forall {a}. (Num a, Prim a) => [a] -> ByteArray
makeBA [Word64]
l, String
s)) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
forall a. (a -> Bool) -> [a] -> [a]
filter (\([Word64]
l, String
_) -> forall (t :: * -> *) a. Foldable t => t a -> Int
length [Word64]
l forall a. Ord a => a -> a -> Bool
<= Int
4) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
forall a b. (a -> b) -> [a] -> [b]
map (\(Integer
x, String
s) -> (Integer -> [Word64]
toList Integer
x, String
s)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (Eq a, Num a) => ReadS a
readHex forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace
where makeBA :: [a] -> ByteArray
makeBA [a]
l = forall a. IO a -> a
unsafeDupablePerformIO forall a b. (a -> b) -> a -> b
$ do
MutableByteArray RealWorld
b <- forall (m :: * -> *).
PrimMonad m =>
Int -> m (MutableByteArray (PrimState m))
newByteArray Int
32
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [ forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutableByteArray (PrimState m) -> Int -> a -> m ()
writeByteArray MutableByteArray RealWorld
b Int
i a
x | (a
x, Int
i) <- forall a b. [a] -> [b] -> [(a, b)]
zip ([a]
l forall a. [a] -> [a] -> [a]
++ forall a. a -> [a]
repeat a
0) [Int
3,Int
2..Int
0] ]
forall (m :: * -> *).
PrimMonad m =>
MutableByteArray (PrimState m) -> m ByteArray
unsafeFreezeByteArray MutableByteArray RealWorld
b
toList :: Integer -> [Word64]
toList :: Integer -> [Word64]
toList Integer
0 = []
toList Integer
n = forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
m forall a. a -> [a] -> [a]
: Integer -> [Word64]
toList Integer
d
where (Integer
d, Integer
m) = Integer
n forall a. Integral a => a -> a -> (a, a)
`divMod` (Integer
2forall a b. (Num a, Integral b) => a -> b -> a
^Integer
64)
data TFGenR = TFGenR Hex Word64 Word64 Int16 Int16
deriving (Int -> TFGenR -> ShowS
[TFGenR] -> ShowS
TFGenR -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TFGenR] -> ShowS
$cshowList :: [TFGenR] -> ShowS
show :: TFGenR -> String
$cshow :: TFGenR -> String
showsPrec :: Int -> TFGenR -> ShowS
$cshowsPrec :: Int -> TFGenR -> ShowS
Show, ReadPrec [TFGenR]
ReadPrec TFGenR
Int -> ReadS TFGenR
ReadS [TFGenR]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [TFGenR]
$creadListPrec :: ReadPrec [TFGenR]
readPrec :: ReadPrec TFGenR
$creadPrec :: ReadPrec TFGenR
readList :: ReadS [TFGenR]
$creadList :: ReadS [TFGenR]
readsPrec :: Int -> ReadS TFGenR
$creadsPrec :: Int -> ReadS TFGenR
Read)
toTFGenR :: TFGen -> TFGenR
toTFGenR :: TFGen -> TFGenR
toTFGenR (TFGen ByteArray
k Word64
i Word64
b Int16
bi Int16
blki ByteArray
_) = Hex -> Word64 -> Word64 -> Int16 -> Int16 -> TFGenR
TFGenR (ByteArray -> Hex
Hex ByteArray
k) Word64
i Word64
b Int16
bi Int16
blki
fromTFGenR :: TFGenR -> Maybe TFGen
fromTFGenR :: TFGenR -> Maybe TFGen
fromTFGenR (TFGenR (Hex k :: ByteArray
k@(ByteArray ByteArray#
k')) Word64
i Word64
b Int16
bi Int16
blki)
| Int16
bi forall a. Ord a => a -> a -> Bool
>= Int16
0 Bool -> Bool -> Bool
&& Int16
bi forall a. Ord a => a -> a -> Bool
<= Int16
64 Bool -> Bool -> Bool
&& Int16
blki forall a. Ord a => a -> a -> Bool
>= Int16
0 Bool -> Bool -> Bool
&& Int16
blki forall a. Ord a => a -> a -> Bool
< Int16
8
= forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ ByteArray
-> Word64 -> Word64 -> Int16 -> Int16 -> ByteArray -> TFGen
TFGen ByteArray
k Word64
i Word64
b Int16
bi Int16
blki (ByteArray# -> Word64 -> Word64 -> Word64 -> Int -> ByteArray
mash ByteArray#
k' (Word64
iforall a. Num a => a -> a -> a
-forall a b. (Integral a, Num b) => a -> b
fromIntegral Int16
blki) Word64
b Word64
0 Int
1)
| Bool
otherwise = forall a. Maybe a
Nothing
instance Show TFGen where
showsPrec :: Int -> TFGen -> ShowS
showsPrec Int
n TFGen
g = forall a. Show a => Int -> a -> ShowS
showsPrec Int
n (TFGen -> TFGenR
toTFGenR TFGen
g)
instance Read TFGen where
readsPrec :: Int -> ReadS TFGen
readsPrec Int
n =
forall a b. (a -> b) -> [a] -> [b]
map (\(Maybe TFGen
g, String
s) -> (forall a. HasCallStack => Maybe a -> a
fromJust Maybe TFGen
g, String
s)) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
forall a. (a -> Bool) -> [a] -> [a]
filter (\(Maybe TFGen
g, String
_) -> forall a. Maybe a -> Bool
isJust Maybe TFGen
g) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
forall a b. (a -> b) -> [a] -> [b]
map (\(TFGenR
g, String
s) -> (TFGenR -> Maybe TFGen
fromTFGenR TFGenR
g, String
s)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Read a => Int -> ReadS a
readsPrec Int
n
mash :: ByteArray# -> Word64 -> Word64 -> Word64 -> Int -> ByteArray
mash :: ByteArray# -> Word64 -> Word64 -> Word64 -> Int -> ByteArray
mash ByteArray#
k' Word64
i Word64
b Word64
m Int
o32 =
forall a. IO a -> a
unsafeDupablePerformIO forall a b. (a -> b) -> a -> b
$ do
(ByteArray ByteArray#
c') <- Word64 -> Word64 -> Word64 -> Word64 -> IO ByteArray
createBlock256 Word64
b Word64
i Word64
m Word64
0
o :: MutableByteArray RealWorld
o@(MutableByteArray MutableByteArray# RealWorld
o') <- forall (m :: * -> *).
PrimMonad m =>
Int -> m (MutableByteArray (PrimState m))
newByteArray Int
32
forall s.
ByteArray# -> ByteArray# -> MutableByteArray# s -> Int -> IO ()
threefish256EncryptBlock ByteArray#
k' ByteArray#
c' MutableByteArray# RealWorld
o' Int
o32
forall (m :: * -> *).
PrimMonad m =>
MutableByteArray (PrimState m) -> m ByteArray
unsafeFreezeByteArray MutableByteArray RealWorld
o
mash' :: TFGen -> Word64 -> Int -> ByteArray
mash' :: TFGen -> Word64 -> Int -> ByteArray
mash' (TFGen (ByteArray ByteArray#
k') Word64
i Word64
b Int16
_ Int16
_ ByteArray
_) Word64
m Int
o32 =
ByteArray# -> Word64 -> Word64 -> Word64 -> Int -> ByteArray
mash ByteArray#
k' Word64
i Word64
b Word64
m Int
o32
mkTFGen :: ByteArray -> Word64 -> Word64 -> Int16 -> TFGen
mkTFGen :: ByteArray -> Word64 -> Word64 -> Int16 -> TFGen
mkTFGen k :: ByteArray
k@(ByteArray ByteArray#
k') Word64
i Word64
b Int16
bi =
ByteArray
-> Word64 -> Word64 -> Int16 -> Int16 -> ByteArray -> TFGen
TFGen ByteArray
k Word64
i Word64
b Int16
bi Int16
0 (ByteArray# -> Word64 -> Word64 -> Word64 -> Int -> ByteArray
mash ByteArray#
k' Word64
i Word64
b Word64
0 Int
1)
extract :: ByteArray -> Int -> Word32
ByteArray
b Int
i = forall a. Prim a => ByteArray -> Int -> a
indexByteArray ByteArray
b Int
i
{-# INLINE tfGenNext #-}
tfGenNext :: TFGen -> (Word32, TFGen)
tfGenNext :: TFGen -> (Word32, TFGen)
tfGenNext (TFGen k :: ByteArray
k@(ByteArray ByteArray#
k') Word64
i Word64
b Int16
bi Int16
blki ByteArray
blk) =
(Word32
val,
if Int16
blki forall a. Eq a => a -> a -> Bool
== Int16
7
then
if Word64
i forall a. Ord a => a -> a -> Bool
< forall a. Bounded a => a
maxBound forall a. Num a => a -> a -> a
- Word64
1
then ByteArray -> Word64 -> Word64 -> Int16 -> TFGen
mkTFGen ByteArray
k (Word64
iforall a. Num a => a -> a -> a
+Word64
1) Word64
b Int16
bi
else
if Int16
bi forall a. Ord a => a -> a -> Bool
< Int16
64
then ByteArray -> Word64 -> Word64 -> Int16 -> TFGen
mkTFGen ByteArray
k Word64
0 (forall a. Bits a => a -> Int -> a
setBit Word64
b forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int16
bi) (Int16
biforall a. Num a => a -> a -> a
+Int16
1)
else ByteArray -> Word64 -> Word64 -> Int16 -> TFGen
mkTFGen (ByteArray# -> Word64 -> Word64 -> Word64 -> Int -> ByteArray
mash ByteArray#
k' forall a. Bounded a => a
maxBound Word64
b Word64
0 Int
0) Word64
0 Word64
0 Int16
0
else ByteArray
-> Word64 -> Word64 -> Int16 -> Int16 -> ByteArray -> TFGen
TFGen ByteArray
k (Word64
iforall a. Num a => a -> a -> a
+Word64
1) Word64
b Int16
bi (Int16
blkiforall a. Num a => a -> a -> a
+Int16
1) ByteArray
blk)
where
val :: Word32
val :: Word32
val = ByteArray -> Int -> Word32
extract ByteArray
blk (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int16
blki)
tfGenNext' :: TFGen -> (Int, TFGen)
tfGenNext' :: TFGen -> (Int, TFGen)
tfGenNext' TFGen
g
| Word32
val' forall a. Ord a => a -> a -> Bool
<= Word32
2147483562 = (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
val', TFGen
g')
| Bool
otherwise = TFGen -> (Int, TFGen)
tfGenNext' TFGen
g'
where
(Word32
val, TFGen
g') = TFGen -> (Word32, TFGen)
tfGenNext TFGen
g
val' :: Word32
val' = Word32
0x7FFFFFFF forall a. Bits a => a -> a -> a
.&. Word32
val
tfGenSplit :: TFGen -> (TFGen, TFGen)
tfGenSplit :: TFGen -> (TFGen, TFGen)
tfGenSplit g :: TFGen
g@(TFGen ByteArray
k Word64
i Word64
b Int16
bi Int16
_ ByteArray
_)
| Int16
bi forall a. Eq a => a -> a -> Bool
== Int16
maxb = (ByteArray -> Word64 -> Word64 -> Int16 -> TFGen
mkTFGen ByteArray
k' Word64
0 Word64
0 Int16
1, ByteArray -> Word64 -> Word64 -> Int16 -> TFGen
mkTFGen ByteArray
k' Word64
0 Word64
1 Int16
1)
| Bool
otherwise = (ByteArray -> Word64 -> Word64 -> Int16 -> TFGen
mkTFGen ByteArray
k Word64
i Word64
b Int16
bi', ByteArray -> Word64 -> Word64 -> Int16 -> TFGen
mkTFGen ByteArray
k Word64
i Word64
b'' Int16
bi')
where
maxb :: Int16
maxb = Int16
64
bi' :: Int16
bi' = Int16
bi forall a. Num a => a -> a -> a
+ Int16
1
k' :: ByteArray
k' = TFGen -> Word64 -> Int -> ByteArray
mash' TFGen
g Word64
0 Int
0
b'' :: Word64
b'' = forall a. Bits a => a -> Int -> a
setBit Word64
b (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int16
bi)
instance R.RandomGen TFGen where
next :: TFGen -> (Int, TFGen)
next = TFGen -> (Int, TFGen)
tfGenNext'
genRange :: TFGen -> (Int, Int)
genRange TFGen
_ = (Int
0, Int
2147483562)
split :: TFGen -> (TFGen, TFGen)
split = TFGen -> (TFGen, TFGen)
tfGenSplit
seedTFGen :: (Word64, Word64, Word64, Word64) -> TFGen
seedTFGen :: (Word64, Word64, Word64, Word64) -> TFGen
seedTFGen (Word64
a1, Word64
a2, Word64
a3, Word64
a4) =
ByteArray -> Word64 -> Word64 -> Int16 -> TFGen
mkTFGen
(forall a. IO a -> a
unsafeDupablePerformIO forall a b. (a -> b) -> a -> b
$ Word64 -> Word64 -> Word64 -> Word64 -> IO ByteArray
createBlock256 Word64
a1 Word64
a2 Word64
a3 Word64
a4)
Word64
0 Word64
0 Int16
0
class RandomGen g where
next :: g -> (Word32, g)
split :: g -> (g, g)
splitn :: g
-> Int
-> Word32
-> g
level :: g -> g
tfGenSplitN :: TFGen -> Int -> Word32 -> TFGen
tfGenSplitN :: TFGen -> Int -> Word32 -> TFGen
tfGenSplitN (TFGen k :: ByteArray
k@(ByteArray ByteArray#
ku) Word64
i Word64
b Int16
bi Int16
_ ByteArray
_) Int
nbits
| Int
nbits forall a. Ord a => a -> a -> Bool
< Int
0 = forall a. HasCallStack => String -> a
error String
"tfGenSplitN called with nbits < 0"
| Int
nbits forall a. Ord a => a -> a -> Bool
> Int
32 = forall a. HasCallStack => String -> a
error String
"tfGenSplitN called with nbits > 32"
| Int
bi' forall a. Num a => a -> a -> a
+ Int
nbits forall a. Ord a => a -> a -> Bool
> Int
maxb = \Word32
n ->
let k' :: ByteArray
k' = ByteArray# -> Word64 -> Word64 -> Word64 -> Int -> ByteArray
mash ByteArray#
ku Word64
i (Word64
b forall a. Bits a => a -> a -> a
.|. forall a. Bits a => a -> Int -> a
shiftL (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall {a}. (Bits a, Num a) => a -> a
clip Word32
n) (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int16
bi)) Word64
0 Int
0 in
ByteArray -> Word64 -> Word64 -> Int16 -> TFGen
mkTFGen ByteArray
k' Word64
0 (forall a. Bits a => a -> Int -> a
shiftR (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall {a}. (Bits a, Num a) => a -> a
clip Word32
n) (Int
bi' forall a. Num a => a -> a -> a
+ Int
nbits forall a. Num a => a -> a -> a
- Int
maxb)) (Int16
bi forall a. Num a => a -> a -> a
- forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
maxb forall a. Num a => a -> a -> a
- Int
nbits))
| Bool
otherwise = \Word32
n ->
ByteArray -> Word64 -> Word64 -> Int16 -> TFGen
mkTFGen ByteArray
k Word64
i (Word64
b forall a. Bits a => a -> a -> a
.|. forall a. Bits a => a -> Int -> a
shiftL (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall {a}. (Bits a, Num a) => a -> a
clip Word32
n) Int
bi') (Int16
bi forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
nbits)
where
bi' :: Int
bi' = forall a b. (Integral a, Num b) => a -> b
fromIntegral Int16
bi
maxb :: Int
maxb = Int
64
clip :: a -> a
clip a
n = (a
0xFFFFFFFF forall a. Bits a => a -> Int -> a
`shiftR` (Int
32 forall a. Num a => a -> a -> a
- Int
nbits)) forall a. Bits a => a -> a -> a
.&. a
n
tfGenLevel :: TFGen -> TFGen
tfGenLevel :: TFGen -> TFGen
tfGenLevel g :: TFGen
g@(TFGen k :: ByteArray
k@(ByteArray ByteArray#
ku) Word64
i Word64
b Int16
bi Int16
_ ByteArray
_)
| Int16
bi forall a. Num a => a -> a -> a
+ Int16
40 forall a. Ord a => a -> a -> Bool
> Int16
maxb = ByteArray -> Word64 -> Word64 -> Int16 -> TFGen
mkTFGen ByteArray
k' Word64
0 Word64
0 Int16
0
| Bool
otherwise = TFGen
g
where
maxb :: Int16
maxb = Int16
64
k' :: ByteArray
k' = ByteArray# -> Word64 -> Word64 -> Word64 -> Int -> ByteArray
mash ByteArray#
ku Word64
i Word64
b Word64
0 Int
0
instance RandomGen TFGen where
{-# INLINE next #-}
next :: TFGen -> (Word32, TFGen)
next = TFGen -> (Word32, TFGen)
tfGenNext
split :: TFGen -> (TFGen, TFGen)
split = TFGen -> (TFGen, TFGen)
tfGenSplit
splitn :: TFGen -> Int -> Word32 -> TFGen
splitn = TFGen -> Int -> Word32 -> TFGen
tfGenSplitN
level :: TFGen -> TFGen
level = TFGen -> TFGen
tfGenLevel