random-fu-0.1.3: src/Data/Random/Internal/Primitives.hs
{-# LANGUAGE GADTs, RankNTypes, DeriveDataTypeable #-}
-- |This is an experimental interface to support an extensible set of primitives,
-- where a RandomSource will be able to support whatever subset of them they want
-- and have well-founded defaults generated automatically for any unsupported
-- primitives.
--
-- The purpose, in case it's not clear, is to decouple the implementations of
-- entropy sources from any particular set of primitives, so that implementors
-- of random variates can make use of a large number of primitives, supported
-- on all entropy sources, while the burden on entropy-source implementors
-- is only to provide one or two basic primitives of their choice.
--
-- One challenge I foresee with this interface is optimization - different
-- compilers or even different versions of GHC may treat this interface
-- radically differently, making it very hard to achieve reliable performance
-- on all platforms. It may even be that no compiler optimizes sufficiently
-- to make the flexibility this system provides worth the overhead. I hope
-- this is not the case, but if it turns out to be a major problem, this
-- system may disappear or be modified in significant ways.
module Data.Random.Internal.Primitives (Prim(..), getPrimWhere, decomposePrimWhere) where
import Data.Random.Internal.Words
import Data.Word
import Data.Bits
import Data.Typeable
import Control.Monad.Prompt
-- |A 'Prompt' GADT describing a request for a primitive random variate.
-- Random variable definitions will request their entropy via these prompts,
-- and entropy sources will satisfy some or all of them. The 'decomposePrimWhere'
-- function extends an entropy source's incomplete definition to a complete
-- definition, essentially defining a very flexible implementation-defaulting
-- system.
--
-- Some possible future additions:
-- PrimFloat :: Prim Float
-- PrimInt :: Prim Int
-- PrimPair :: Prim a -> Prim b -> Prim (a :*: b)
-- PrimNormal :: Prim Double
-- PrimChoice :: [(Double :*: a)] -> Prim a
--
-- Unfortunately, I cannot get Haddock to accept my comments about the
-- data constructors, but hopefully they should be reasonably self-explanatory.
data Prim a where
-- An unsigned byte, uniformly distributed from 0 to 0xff
PrimWord8 :: Prim Word8
-- An unsigned 16-bit word, uniformly distributed from 0 to 0xffff
PrimWord16 :: Prim Word16
-- An unsigned 32-bit word, uniformly distributed from 0 to 0xffffffff
PrimWord32 :: Prim Word32
-- An unsigned 64-bit word, uniformly distributed from 0 to 0xffffffffffffffff
PrimWord64 :: Prim Word64
-- A double-precision float U, uniformly distributed 0 <= U < 1
PrimDouble :: Prim Double
-- A uniformly distributed 'Integer' 0 <= U < 2^(8*n)
PrimNByteInteger :: !Int -> Prim Integer
deriving (Typeable)
instance Show (Prim a) where
showsPrec _p PrimWord8 = showString "PrimWord8"
showsPrec _p PrimWord16 = showString "PrimWord16"
showsPrec _p PrimWord32 = showString "PrimWord32"
showsPrec _p PrimWord64 = showString "PrimWord64"
showsPrec _p PrimDouble = showString "PrimDouble"
showsPrec p (PrimNByteInteger n) = showParen (p > 10) (showString "PrimNByteInteger " . showsPrec 11 n)
-- |This function wraps up the most common calling convention for 'decomposePrimWhere'.
-- Given a predicate identifying \"supported\" 'Prim's, and a (possibly partial)
-- function that maps those 'Prim's to implementations, derives a total function
-- mapping all 'Prim's to implementations.
{-# INLINE getPrimWhere #-}
{-# SPECIALIZE getPrimWhere :: Monad m => (forall t. Prim t -> Bool) -> (forall t. Prim t -> m t) -> Prim Word8 -> m Word8 #-}
{-# SPECIALIZE getPrimWhere :: Monad m => (forall t. Prim t -> Bool) -> (forall t. Prim t -> m t) -> Prim Word16 -> m Word16 #-}
{-# SPECIALIZE getPrimWhere :: Monad m => (forall t. Prim t -> Bool) -> (forall t. Prim t -> m t) -> Prim Word32 -> m Word32 #-}
{-# SPECIALIZE getPrimWhere :: Monad m => (forall t. Prim t -> Bool) -> (forall t. Prim t -> m t) -> Prim Word64 -> m Word64 #-}
{-# SPECIALIZE getPrimWhere :: Monad m => (forall t. Prim t -> Bool) -> (forall t. Prim t -> m t) -> Prim Double -> m Double #-}
{-# SPECIALIZE getPrimWhere :: Monad m => (forall t. Prim t -> Bool) -> (forall t. Prim t -> m t) -> Prim Integer -> m Integer #-}
getPrimWhere :: Monad m => (forall t. Prim t -> Bool) -> (forall t. Prim t -> m t) -> Prim a -> m a
getPrimWhere supported getPrim prim = runPromptM getPrim (decomposePrimWhere supported prim)
-- |This is essentially a suite of interrelated default implementations,
-- each definition making use of only \"supported\" primitives. It _really_
-- ought to be inlined to the point where the @supported@ predicate
-- is able to be inlined into it and eliminated.
--
-- When inlined sufficiently, it should in theory be optimized down to the
-- static set of "best" definitions for each required primitive in terms of
-- only supported primitives.
--
-- Hopefully it does not impose too much overhead when not inlined.
{-# INLINE decomposePrimWhere #-}
{-# SPECIALIZE decomposePrimWhere :: (forall t. Prim t -> Bool) -> Prim Word8 -> Prompt Prim Word8 #-}
{-# SPECIALIZE decomposePrimWhere :: (forall t. Prim t -> Bool) -> Prim Word16 -> Prompt Prim Word16 #-}
{-# SPECIALIZE decomposePrimWhere :: (forall t. Prim t -> Bool) -> Prim Word32 -> Prompt Prim Word32 #-}
{-# SPECIALIZE decomposePrimWhere :: (forall t. Prim t -> Bool) -> Prim Word64 -> Prompt Prim Word64 #-}
{-# SPECIALIZE decomposePrimWhere :: (forall t. Prim t -> Bool) -> Prim Double -> Prompt Prim Double #-}
{-# SPECIALIZE decomposePrimWhere :: (forall t. Prim t -> Bool) -> Prim Integer -> Prompt Prim Integer #-}
decomposePrimWhere :: (forall t. Prim t -> Bool) -> Prim a -> Prompt Prim a
decomposePrimWhere supported requested = decomp requested
where
{-# INLINE decomp #-}
{-# SPECIALIZE decomp :: Prim Word8 -> Prompt Prim Word8 #-}
{-# SPECIALIZE decomp :: Prim Word16 -> Prompt Prim Word16 #-}
{-# SPECIALIZE decomp :: Prim Word32 -> Prompt Prim Word32 #-}
{-# SPECIALIZE decomp :: Prim Word64 -> Prompt Prim Word64 #-}
{-# SPECIALIZE decomp :: Prim Double -> Prompt Prim Double #-}
{-# SPECIALIZE decomp :: Prim Integer -> Prompt Prim Integer #-}
-- First, all supported prims should just be evaluated directly.
decomp :: Prim a -> Prompt Prim a
decomp prim
| supported prim = prompt prim
-- beyond this point, all definitions must be in terms of
-- 'prompt's referring to other supported primitives or
-- 'decomp's referring to other primitives in a well-founded way
decomp PrimWord8
| supported PrimWord16 = do
w <- prompt PrimWord16
return (fromIntegral w)
| supported PrimWord32 = do
w <- prompt PrimWord32
return (fromIntegral w)
| supported PrimWord64 = do
w <- prompt PrimWord64
return (fromIntegral w)
| supported PrimDouble = do
d <- prompt PrimDouble
return (truncate (d * 256))
| supported (PrimNByteInteger 1) = do
i <- prompt (PrimNByteInteger 1)
return (fromInteger i)
decomp PrimWord16
| supported PrimWord8 = do
b0 <- prompt PrimWord8
b1 <- prompt PrimWord8
return (buildWord16 b0 b1)
| supported PrimWord32 = do
w <- prompt PrimWord32
return (fromIntegral w)
| supported PrimWord64 = do
w <- prompt PrimWord64
return (fromIntegral w)
| supported PrimDouble = do
d <- prompt PrimDouble
return (truncate (d * 65536))
| supported (PrimNByteInteger 2) = do
i <- prompt (PrimNByteInteger 2)
return (fromInteger i)
decomp PrimWord32
| supported PrimWord16 = do
w0 <- prompt PrimWord16
w1 <- prompt PrimWord16
return (buildWord32' w0 w1)
| supported PrimWord8 = do
b0 <- prompt PrimWord8
b1 <- prompt PrimWord8
b2 <- prompt PrimWord8
b3 <- prompt PrimWord8
return (buildWord32 b0 b1 b2 b3)
| supported PrimWord64 = do
w <- prompt PrimWord64
return (fromIntegral w)
| supported PrimDouble = do
d <- prompt PrimDouble
return (truncate (d * 4294967296))
| supported (PrimNByteInteger 4) = do
i <- prompt (PrimNByteInteger 4)
return (fromInteger i)
decomp PrimWord64
| supported PrimWord32 = do
w0 <- prompt PrimWord32
w1 <- prompt PrimWord32
return (buildWord64'' w0 w1)
| supported PrimWord16 = do
w0 <- prompt PrimWord16
w1 <- prompt PrimWord16
w2 <- prompt PrimWord16
w3 <- prompt PrimWord16
return (buildWord64' w0 w1 w2 w3)
| supported PrimWord8 = do
b0 <- prompt PrimWord8
b1 <- prompt PrimWord8
b2 <- prompt PrimWord8
b3 <- prompt PrimWord8
b4 <- prompt PrimWord8
b5 <- prompt PrimWord8
b6 <- prompt PrimWord8
b7 <- prompt PrimWord8
return (buildWord64 b0 b1 b2 b3 b4 b5 b6 b7)
| supported PrimDouble = do
-- Need 2 doubles, because a uniform [0,1) double only has
-- about 52 bits of reliable entropy
d0 <- prompt PrimDouble
d1 <- prompt PrimDouble
let w0 = truncate (d0 * 4294967296)
w1 = truncate (d1 * 4294967296)
return (w0 .|. (w1 `shiftL` 32))
| supported (PrimNByteInteger 8) = do
i <- prompt (PrimNByteInteger 8)
return (fromInteger i)
decomp PrimDouble = do
word <- decomp PrimWord64
return (wordToDouble word)
decomp (PrimNByteInteger 1) = do
x <- decomp PrimWord8
return $! toInteger x
decomp (PrimNByteInteger 2) = do
x <- decomp PrimWord16
return $! toInteger x
decomp (PrimNByteInteger 4) = do
x <- decomp PrimWord32
return $! toInteger x
decomp (PrimNByteInteger 8) = do
x <- decomp PrimWord64
return $! toInteger x
decomp (PrimNByteInteger (n+8)) = do
x <- decomp PrimWord64
y <- decomp (PrimNByteInteger n)
return $! (toInteger x `shiftL` (n `shiftL` 3)) .|. y
decomp (PrimNByteInteger (n+4)) = do
x <- decomp PrimWord32
y <- decomp (PrimNByteInteger n)
return $! (toInteger x `shiftL` (n `shiftL` 3)) .|. y
decomp (PrimNByteInteger (n+2)) = do
x <- decomp PrimWord16
y <- decomp (PrimNByteInteger n)
return $! (toInteger x `shiftL` (n `shiftL` 3)) .|. y
-- REDUNDANT CASE
-- decomp (PrimNByteInteger (n+1)) = do
-- x <- decomp PrimWord8
-- y <- decomp (PrimNByteInteger n)
-- return $! (toInteger x `shiftL` (n `shiftL` 3)) .|. y
decomp (PrimNByteInteger _) = return 0
decomp _ = error ("decomposePrimWhere: no supported primitive to satisfy " ++ show requested)