{-# LANGUAGE Rank2Types, DataKinds #-}
module System.Random.Dice.Internal
where
import System.Entropy
import Control.Monad.IO.Class
import Control.Monad
import Control.Exception
import qualified Data.ByteString as B
import Data.Word
import Data.Conduit
import qualified Data.Conduit.List as CL
integralToBits :: (Integral n,Integral m)
=> Int
-> n
-> [m]
integralToBits :: Int -> n -> [m]
integralToBits b :: Int
b x :: n
x = [m] -> [m]
forall a. [a] -> [a]
reverse ([m] -> [m]) -> [m] -> [m]
forall a b. (a -> b) -> a -> b
$ Int -> n -> [m]
forall t a. (Num a, Integral t) => Int -> t -> [a]
integralToBits' 0 n
x
where
integralToBits' :: Int -> t -> [a]
integralToBits' ns :: Int
ns 0 = Int -> a -> [a]
forall a. Int -> a -> [a]
replicate (Int
bInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
ns) 0
integralToBits' ns :: Int
ns y :: t
y =
let (a :: t
a,res :: t
res) = t -> t -> (t, t)
forall a. Integral a => a -> a -> (a, a)
quotRem t
y 2 in
t -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral t
res a -> [a] -> [a]
forall a. a -> [a] -> [a]
: Int -> t -> [a]
integralToBits' (Int
nsInt -> Int -> Int
forall a. Num a => a -> a -> a
+1) t
a
bitsToIntegral :: (Integral n) =>[n] -> n
bitsToIntegral :: [n] -> n
bitsToIntegral = n -> [n] -> n
forall n. Integral n => n -> [n] -> n
extendIntegralWithBits 0
extendIntegralWithBits :: (Integral n) => n -> [n] -> n
extendIntegralWithBits :: n -> [n] -> n
extendIntegralWithBits n :: n
n = (n -> n -> n) -> n -> [n] -> n
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\c :: n
c r :: n
r -> 2n -> n -> n
forall a. Num a => a -> a -> a
*n
r n -> n -> n
forall a. Num a => a -> a -> a
+ n
c) n
n ([n] -> n) -> ([n] -> [n]) -> [n] -> n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [n] -> [n]
forall a. [a] -> [a]
reverse
upperBound :: Word64
upperBound :: Word64
upperBound = 2Word64 -> Int -> Word64
forall a b. (Num a, Integral b) => a -> b -> a
^(55 :: Int)
getDiceRolls :: Int
-> Int
-> IO [Int]
getDiceRolls :: Int -> Int -> IO [Int]
getDiceRolls n :: Int
n len :: Int
len =
ConduitT () Word8 IO ()
Producer IO Word8
systemEntropy ConduitT () Word8 IO () -> Sink Word8 IO [Int] -> IO [Int]
forall (m :: * -> *) a b.
Monad m =>
Source m a -> Sink a m b -> m b
$$ Int -> Conduit Word8 IO Int
diceRolls Int
n Conduit Word8 IO Int
-> ConduitT Int Void IO [Int] -> Sink Word8 IO [Int]
forall (m :: * -> *) a b c r.
Monad m =>
Conduit a m b -> ConduitT b c m r -> ConduitT a c m r
=$= Int -> ConduitT Int Void IO [Int]
forall (m :: * -> *) a o. Monad m => Int -> ConduitT a o m [a]
CL.take Int
len
getRandomRs :: (Int,Int)
-> Int
-> IO [Int]
getRandomRs :: (Int, Int) -> Int -> IO [Int]
getRandomRs range :: (Int, Int)
range len :: Int
len =
ConduitT () Word8 IO ()
Producer IO Word8
systemEntropy ConduitT () Word8 IO () -> Sink Word8 IO [Int] -> IO [Int]
forall (m :: * -> *) a b.
Monad m =>
Source m a -> Sink a m b -> m b
$$ (Int, Int) -> Conduit Word8 IO Int
randomRs (Int, Int)
range Conduit Word8 IO Int
-> ConduitT Int Void IO [Int] -> Sink Word8 IO [Int]
forall (m :: * -> *) a b c r.
Monad m =>
Conduit a m b -> ConduitT b c m r -> ConduitT a c m r
=$= Int -> ConduitT Int Void IO [Int]
forall (m :: * -> *) a o. Monad m => Int -> ConduitT a o m [a]
CL.take Int
len
diceRolls :: Int -> Conduit Word8 IO Int
diceRolls :: Int -> Conduit Word8 IO Int
diceRolls n :: Int
n
| Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
> Word64
upperBound Bool -> Bool -> Bool
|| Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= 0
= AssertionFailed -> Conduit Word8 IO Int
forall a e. Exception e => e -> a
throw (AssertionFailed -> Conduit Word8 IO Int)
-> AssertionFailed -> Conduit Word8 IO Int
forall a b. (a -> b) -> a -> b
$ String -> AssertionFailed
AssertionFailed "diceRolls: n-sided dice are supported, for 1 <= n < 2^55."
| Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 1
= [Int] -> Conduit Word8 IO Int
forall (m :: * -> *) a i. Monad m => [a] -> ConduitT i a m ()
CL.sourceList [0,0..]
| Bool
otherwise
= Word64 -> Word64 -> Word64 -> Int -> Conduit Word8 IO (Int, Int)
dRoll (Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n) 1 0 0 Conduit Word8 IO (Int, Int)
-> ConduitT (Int, Int) Int IO () -> Conduit Word8 IO Int
forall (m :: * -> *) a b c r.
Monad m =>
Conduit a m b -> ConduitT b c m r -> ConduitT a c m r
=$= ((Int, Int) -> Int) -> ConduitT (Int, Int) Int IO ()
forall (m :: * -> *) a b. Monad m => (a -> b) -> ConduitT a b m ()
CL.map (Int, Int) -> Int
forall a b. (a, b) -> a
fst
randomRs :: (Int,Int)
-> Conduit Word8 IO Int
randomRs :: (Int, Int) -> Conduit Word8 IO Int
randomRs (low :: Int
low,up :: Int
up) = Int -> Conduit Word8 IO Int
diceRolls (Int
upInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
lowInt -> Int -> Int
forall a. Num a => a -> a -> a
+1) Conduit Word8 IO Int
-> ConduitT Int Int IO () -> Conduit Word8 IO Int
forall (m :: * -> *) a b c r.
Monad m =>
Conduit a m b -> ConduitT b c m r -> ConduitT a c m r
=$= (Int -> Int) -> ConduitT Int Int IO ()
forall (m :: * -> *) a b. Monad m => (a -> b) -> ConduitT a b m ()
CL.map (Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
low)
systemEntropy :: Producer IO Word8
systemEntropy :: ConduitT i Word8 IO ()
systemEntropy = do
[Word8]
bytes <- ByteString -> [Word8]
B.unpack (ByteString -> [Word8])
-> ConduitT i Word8 IO ByteString -> ConduitT i Word8 IO [Word8]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` IO ByteString -> ConduitT i Word8 IO ByteString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Int -> IO ByteString
getEntropy 8)
[Word8]
-> (Word8 -> ConduitT i Word8 IO ()) -> ConduitT i Word8 IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Word8]
bytes Word8 -> ConduitT i Word8 IO ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield
ConduitT i Word8 IO ()
Producer IO Word8
systemEntropy
dRoll :: Word64 -> Word64 -> Word64 -> Int -> Conduit Word8 IO (Int,Int)
dRoll :: Word64 -> Word64 -> Word64 -> Int -> Conduit Word8 IO (Int, Int)
dRoll n :: Word64
n m :: Word64
m r :: Word64
r cnt :: Int
cnt = do
let k :: Int
k = Double -> Int
forall a b. (RealFrac a, Integral b) => a -> b
ceiling (Double -> Int) -> Double -> Int
forall a b. (a -> b) -> a -> b
$ (Double -> Double -> Double
forall a. Floating a => a -> a -> a
logBase 2 (Word64 -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
upperBound) Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double -> Double -> Double
forall a. Floating a => a -> a -> a
logBase 2 (Word64 -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
m :: Double)) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ 8
let m' :: Word64
m' = 2Word64 -> Int -> Word64
forall a b. (Num a, Integral b) => a -> b -> a
^(8Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
k) Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Word64
m
[Word64]
bits <- ((Word8 -> [Word64]) -> [Word8] -> [Word64]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Int -> Word8 -> [Word64]
forall n m. (Integral n, Integral m) => Int -> n -> [m]
integralToBits 8) ([Word8] -> [Word64])
-> (ByteString -> [Word8]) -> ByteString -> [Word64]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [Word8]
B.unpack)
(ByteString -> [Word64])
-> ConduitT Word8 (Int, Int) IO ByteString
-> ConduitT Word8 (Int, Int) IO [Word64]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` (if Int
kInt -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>0 then IO ByteString -> ConduitT Word8 (Int, Int) IO ByteString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> ConduitT Word8 (Int, Int) IO ByteString)
-> IO ByteString -> ConduitT Word8 (Int, Int) IO ByteString
forall a b. (a -> b) -> a -> b
$ Int -> IO ByteString
getEntropy Int
k else ByteString -> ConduitT Word8 (Int, Int) IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> ConduitT Word8 (Int, Int) IO ByteString)
-> ByteString -> ConduitT Word8 (Int, Int) IO ByteString
forall a b. (a -> b) -> a -> b
$ [Word8] -> ByteString
B.pack [])
let w64 :: Word64
w64 = Word64 -> [Word64] -> Word64
forall n. Integral n => n -> [n] -> n
extendIntegralWithBits Word64
r [Word64]
bits
let q :: Word64
q = Word64
m' Word64 -> Word64 -> Word64
forall a. Integral a => a -> a -> a
`div` Word64
n
if Word64
w64 Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
< Word64
n Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Word64
q
then do
(Int, Int) -> Conduit Word8 IO (Int, Int)
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Int) -> Word64 -> Int
forall a b. (a -> b) -> a -> b
$ Word64
w64 Word64 -> Word64 -> Word64
forall a. Integral a => a -> a -> a
`mod` Word64
n,Int
k)
Word64 -> Word64 -> Word64 -> Int -> Conduit Word8 IO (Int, Int)
dRoll Word64
n Word64
q (Word64
w64 Word64 -> Word64 -> Word64
forall a. Integral a => a -> a -> a
`div` Word64
n) (Int
cnt Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
k)
else Word64 -> Word64 -> Word64 -> Int -> Conduit Word8 IO (Int, Int)
dRoll Word64
n (Word64
m' Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
nWord64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
*Word64
q) (Word64
w64 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
nWord64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
*Word64
q) (Int
cnt Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
k)