Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Uniform for Generic #70

Merged
merged 7 commits into from
Aug 20, 2020
Merged
Show file tree
Hide file tree
Changes from all commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
2 changes: 2 additions & 0 deletions random.cabal
Original file line number Diff line number Diff line change
Expand Up @@ -86,6 +86,8 @@ library
System.Random
System.Random.Internal
System.Random.Stateful
other-modules:
System.Random.GFinite

hs-source-dirs: src
default-language: Haskell2010
Expand Down
3 changes: 3 additions & 0 deletions src/System/Random.hs
Original file line number Diff line number Diff line change
Expand Up @@ -27,6 +27,8 @@ module System.Random
, Random(..)
, Uniform
, UniformRange
, Finite

-- ** Standard pseudo-random number generator
, StdGen
, mkStdGen
Expand Down Expand Up @@ -64,6 +66,7 @@ import Data.Word
import Foreign.C.Types
import GHC.Exts
import System.IO.Unsafe (unsafePerformIO)
import System.Random.GFinite (Finite)
import System.Random.Internal
import qualified System.Random.SplitMix as SM

Expand Down
280 changes: 280 additions & 0 deletions src/System/Random/GFinite.hs
Original file line number Diff line number Diff line change
@@ -0,0 +1,280 @@
-- |
-- Module : System.Random.GFinite
-- Copyright : (c) Andrew Lelechenko 2020
-- License : BSD-style (see the file LICENSE in the 'random' repository)
-- Maintainer : [email protected]
--

{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}

module System.Random.GFinite
( Cardinality(..)
, Finite(..)
, GFinite(..)
) where

import Data.Bits
import Data.Int
import Data.Void
import Data.Word
import GHC.Exts (Proxy#, proxy#)
import GHC.Generics

-- | Cardinality of a set.
data Cardinality
= Shift !Int -- ^ Shift n is equivalent to Card (bit n)
| Card !Integer
deriving (Eq, Ord, Show)

-- | This is needed only as a superclass of 'Integral'.
instance Enum Cardinality where
Shimuuar marked this conversation as resolved.
Show resolved Hide resolved
toEnum = fromIntegral
fromEnum = fromIntegral
succ = (+ 1)
pred = subtract 1
enumFrom x = map fromInteger (enumFrom (toInteger x))
enumFromThen x y = map fromInteger (enumFromThen (toInteger x) (toInteger y))
enumFromTo x y = map fromInteger (enumFromTo (toInteger x) (toInteger y))
enumFromThenTo x y z = map fromInteger (enumFromThenTo (toInteger x) (toInteger y) (toInteger z))

instance Num Cardinality where
fromInteger 1 = Shift 0 -- ()
fromInteger 2 = Shift 1 -- Bool
fromInteger n = Card n
{-# INLINE fromInteger #-}

x + y = fromInteger (toInteger x + toInteger y)
{-# INLINE (+) #-}

Shift x * Shift y = Shift (x + y)
Shift x * Card y = Card (y `shiftL` x)
Card x * Shift y = Card (x `shiftL` y)
Card x * Card y = Card (x * y)
{-# INLINE (*) #-}

abs = Card . abs . toInteger
signum = Card . signum . toInteger
negate = Card . negate . toInteger

-- | This is needed only as a superclass of 'Integral'.
instance Real Cardinality where
toRational = fromIntegral

instance Integral Cardinality where
toInteger = \case
Shift n -> bit n
Card n -> n
{-# INLINE toInteger #-}

quotRem x' = \case
Shift n -> (Card (x `shiftR` n), Card (x .&. (bit n - 1)))
Card n -> let (q, r) = x `quotRem` n in (Card q, Card r)
where
x = toInteger x'
{-# INLINE quotRem #-}

-- | A type class for data with a finite number of inhabitants.
-- This type class is used
-- in default implementations of 'System.Random.Stateful.Uniform'
-- and 'System.Random.Stateful.UniformRange'.
--
-- Users are not supposed to write instances of 'Finite' manually.
-- There is a default implementation in terms of 'Generic' instead.
--
-- >>> :set -XDeriveGeneric -XDeriveAnyClass
-- >>> import GHC.Generics (Generic)
-- >>> data MyBool = MyTrue | MyFalse deriving (Generic, Finite)
-- >>> data Action = Code MyBool | Eat (Maybe Bool) | Sleep deriving (Generic, Finite)
--
class Finite a where
cardinality :: Proxy# a -> Cardinality
toFinite :: Integer -> a
fromFinite :: a -> Integer

default cardinality :: (Generic a, GFinite (Rep a)) => Proxy# a -> Cardinality
cardinality _ = gcardinality (proxy# :: Proxy# (Rep a))

default toFinite :: (Generic a, GFinite (Rep a)) => Integer -> a
toFinite = to . toGFinite

default fromFinite :: (Generic a, GFinite (Rep a)) => a -> Integer
fromFinite = fromGFinite . from

class GFinite f where
gcardinality :: Proxy# f -> Cardinality
toGFinite :: Integer -> f a
fromGFinite :: f a -> Integer

instance GFinite V1 where
gcardinality _ = 0
{-# INLINE gcardinality #-}
toGFinite = const $ error "GFinite: V1 has no inhabitants"
{-# INLINE toGFinite #-}
fromGFinite = const $ error "GFinite: V1 has no inhabitants"
{-# INLINE fromGFinite #-}

instance GFinite U1 where
gcardinality _ = 1
{-# INLINE gcardinality #-}
toGFinite = const U1
{-# INLINE toGFinite #-}
fromGFinite = const 0
{-# INLINE fromGFinite #-}

instance Finite a => GFinite (K1 _x a) where
gcardinality _ = cardinality (proxy# :: Proxy# a)
{-# INLINE gcardinality #-}
toGFinite = K1 . toFinite
{-# INLINE toGFinite #-}
fromGFinite = fromFinite . unK1
{-# INLINE fromGFinite #-}

instance GFinite a => GFinite (M1 _x _y a) where
gcardinality _ = gcardinality (proxy# :: Proxy# a)
{-# INLINE gcardinality #-}
toGFinite = M1 . toGFinite
{-# INLINE toGFinite #-}
fromGFinite = fromGFinite . unM1
{-# INLINE fromGFinite #-}

instance (GFinite a, GFinite b) => GFinite (a :+: b) where
gcardinality _ =
gcardinality (proxy# :: Proxy# a) + gcardinality (proxy# :: Proxy# b)
{-# INLINE gcardinality #-}

toGFinite n
| n < cardA = L1 $ toGFinite n
| otherwise = R1 $ toGFinite (n - cardA)
where
cardA = toInteger (gcardinality (proxy# :: Proxy# a))
{-# INLINE toGFinite #-}

fromGFinite = \case
L1 x -> fromGFinite x
R1 x -> fromGFinite x + toInteger (gcardinality (proxy# :: Proxy# a))
{-# INLINE fromGFinite #-}

instance (GFinite a, GFinite b) => GFinite (a :*: b) where
gcardinality _ =
gcardinality (proxy# :: Proxy# a) * gcardinality (proxy# :: Proxy# b)
{-# INLINE gcardinality #-}

toGFinite n = toGFinite (toInteger q) :*: toGFinite (toInteger r)
where
cardB = gcardinality (proxy# :: Proxy# b)
(q, r) = Card n `quotRem` cardB
{-# INLINE toGFinite #-}

fromGFinite (q :*: r) =
toInteger (gcardinality (proxy# :: Proxy# b) * Card (fromGFinite q)) + fromGFinite r
{-# INLINE fromGFinite #-}

instance Finite Void
instance Finite ()
instance Finite Bool
instance Finite Ordering

instance Finite Char where
cardinality _ = Card $ toInteger (fromEnum (maxBound :: Char)) + 1
{-# INLINE cardinality #-}
toFinite = toEnum . fromInteger
{-# INLINE toFinite #-}
fromFinite = toInteger . fromEnum
{-# INLINE fromFinite #-}

cardinalityDef :: forall a. (Num a, FiniteBits a) => Proxy# a -> Cardinality
cardinalityDef _ = Shift (finiteBitSize (0 :: a))

toFiniteDef :: forall a. (Num a, FiniteBits a) => Integer -> a
toFiniteDef n
| isSigned (0 :: a) = fromInteger (n - bit (finiteBitSize (0 :: a) - 1))
| otherwise = fromInteger n

fromFiniteDef :: (Integral a, FiniteBits a) => a -> Integer
fromFiniteDef x
| isSigned x = toInteger x + bit (finiteBitSize x - 1)
| otherwise = toInteger x

instance Finite Word8 where
cardinality = cardinalityDef
{-# INLINE cardinality #-}
toFinite = toFiniteDef
{-# INLINE toFinite #-}
fromFinite = fromFiniteDef
{-# INLINE fromFinite #-}
instance Finite Word16 where
cardinality = cardinalityDef
{-# INLINE cardinality #-}
toFinite = toFiniteDef
{-# INLINE toFinite #-}
fromFinite = fromFiniteDef
{-# INLINE fromFinite #-}
instance Finite Word32 where
cardinality = cardinalityDef
{-# INLINE cardinality #-}
toFinite = toFiniteDef
{-# INLINE toFinite #-}
fromFinite = fromFiniteDef
{-# INLINE fromFinite #-}
instance Finite Word64 where
cardinality = cardinalityDef
{-# INLINE cardinality #-}
toFinite = toFiniteDef
{-# INLINE toFinite #-}
fromFinite = fromFiniteDef
{-# INLINE fromFinite #-}
instance Finite Word where
cardinality = cardinalityDef
{-# INLINE cardinality #-}
toFinite = toFiniteDef
{-# INLINE toFinite #-}
fromFinite = fromFiniteDef
{-# INLINE fromFinite #-}
instance Finite Int8 where
cardinality = cardinalityDef
{-# INLINE cardinality #-}
toFinite = toFiniteDef
{-# INLINE toFinite #-}
fromFinite = fromFiniteDef
{-# INLINE fromFinite #-}
instance Finite Int16 where
cardinality = cardinalityDef
{-# INLINE cardinality #-}
toFinite = toFiniteDef
{-# INLINE toFinite #-}
fromFinite = fromFiniteDef
{-# INLINE fromFinite #-}
instance Finite Int32 where
cardinality = cardinalityDef
{-# INLINE cardinality #-}
toFinite = toFiniteDef
{-# INLINE toFinite #-}
fromFinite = fromFiniteDef
{-# INLINE fromFinite #-}
instance Finite Int64 where
cardinality = cardinalityDef
{-# INLINE cardinality #-}
toFinite = toFiniteDef
{-# INLINE toFinite #-}
fromFinite = fromFiniteDef
{-# INLINE fromFinite #-}
instance Finite Int where
cardinality = cardinalityDef
{-# INLINE cardinality #-}
toFinite = toFiniteDef
{-# INLINE toFinite #-}
fromFinite = fromFiniteDef
{-# INLINE fromFinite #-}

instance Finite a => Finite (Maybe a)
instance (Finite a, Finite b) => Finite (Either a b)
instance (Finite a, Finite b) => Finite (a, b)
instance (Finite a, Finite b, Finite c) => Finite (a, b, c)
instance (Finite a, Finite b, Finite c, Finite d) => Finite (a, b, c, d)
instance (Finite a, Finite b, Finite c, Finite d, Finite e) => Finite (a, b, c, d, e)
instance (Finite a, Finite b, Finite c, Finite d, Finite e, Finite f) => Finite (a, b, c, d, e, f)
Loading