random-class 0.1.2.0 → 0.2.0.0
raw patch · 3 files changed
+61/−26 lines, 3 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
- Random: instance (GHC.Enum.Bounded a, GHC.Enum.Enum a, GHC.Enum.Bounded b, GHC.Enum.Enum b) => Random.Uniform b a
- Random: instance Random.Uniform Data.Void.Void a
- Random: instance Random.Uniform a ()
- Random: instance Random.Uniform a a
+ Random: instance (GHC.Enum.Bounded a, GHC.Enum.Enum a) => Random.Uniform a
+ Random: instance Random.Uniform ()
+ Random: range :: (Gen g, Bounded (Native g), Enum (Native g), Enum a) => (a, a) -> State g a
+ Random: rangeM :: (Gen g, Bounded (Native g), Enum (Native g), Enum a, PrimMonad m) => (a, a) -> ReaderT (Mut (PrimState m) g) m a
+ Random: weighted :: (Gen g, Bounded (Native g), Enum (Native g), Uniform a) => NonEmpty (a, Ratio Natural) -> State g a
+ Random: weightedM :: (Gen g, Bounded (Native g), Enum (Native g), Uniform a, PrimMonad m) => NonEmpty (a, Ratio Natural) -> ReaderT (Mut (PrimState m) g) m a
- Random: class Uniform b a
+ Random: class Uniform a
- Random: liftUniform :: (Uniform b a, Monad m) => m b -> m a
+ Random: liftUniform :: (Uniform a, Bounded b, Enum b, Monad m) => m b -> m a
- Random: uniform :: (Gen g, Uniform (Native g) a) => State g a
+ Random: uniform :: (Gen g, Bounded (Native g), Enum (Native g), Uniform a) => State g a
- Random: uniformM :: (Gen g, Uniform (Native g) a, PrimMonad m) => ReaderT (Mut (PrimState m) g) m a
+ Random: uniformM :: (Gen g, Bounded (Native g), Enum (Native g), Uniform a, PrimMonad m) => ReaderT (Mut (PrimState m) g) m a
Files
- Random.hs +58/−20
- Util.hs +1/−4
- random-class.cabal +2/−2
Random.hs view
@@ -1,14 +1,23 @@ {-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE UndecidableInstances #-} -module Random where+module Random (Gen (..), Split (..), Uniform (..),+ uniform, range, weighted,+ uniformM, rangeM, weightedM) where +import Control.Applicative import Control.Monad.Primitive import Control.Monad.Trans.Reader import qualified Control.Monad.Trans.State as M+import Data.Bool+import Data.Foldable+import qualified Data.List as L+import Data.List.NonEmpty (NonEmpty)+import qualified Data.List.NonEmpty as NE import Data.Primitive.MutVar+import Data.Ratio import Data.Semigroup import Data.Tuple (swap)-import Data.Void import Numeric.Natural import Util@@ -35,29 +44,58 @@ class Split g where split :: g -> (g, g) -class Uniform b a where- liftUniform :: Monad m => m b -> m a--instance Uniform a a where liftUniform = id+class Uniform a where+ liftUniform :: (Bounded b, Enum b, Monad m) => m b -> m a -uniform :: (Gen g, Uniform (Native g) a) => M.State g a+uniform :: (Gen g, Bounded (Native g), Enum (Native g), Uniform a) => M.State g a uniform = liftUniform uniformNative -uniformM :: (Gen g, Uniform (Native g) a, PrimMonad m) => ReaderT (Mut (PrimState m) g) m a+uniformM :: (Gen g, Bounded (Native g), Enum (Native g), Uniform a, PrimMonad m)+ => ReaderT (Mut (PrimState m) g) m a uniformM = liftUniform uniformNativeM -instance {-# OVERLAPPABLE #-} (Bounded a, Enum a, Bounded b, Enum b) => Uniform b a where- liftUniform = untilJust- . fmap (toEnumMayWrap' . foldr (\ m n -> card @b * n + fromEnum' m) 0)- . replicateA @_ @[] r- where toEnumMayWrap' :: Natural -> Maybe a- toEnumMayWrap' n | n > r * card @b `div` card @a * card @a = Nothing- | otherwise = toEnumMay' (n `div` card @a)+instance {-# OVERLAPPABLE #-} (Bounded a, Enum a) => Uniform a where+ liftUniform = range' (minBound, maxBound) - r = (card @a + card @b - 1) `div` card @b+instance Uniform () where+ liftUniform _ = pure () -instance Uniform Void a where- liftUniform = fmap $ \ case+range :: (Gen g, Bounded (Native g), Enum (Native g), Enum a) => (a, a) -> M.State g a+range = flip range' uniformNative -instance Uniform a () where- liftUniform = (() <$)+rangeM :: (Gen g, Bounded (Native g), Enum (Native g), Enum a, PrimMonad m)+ => (a, a) -> ReaderT (Mut (PrimState m) g) m a+rangeM = flip range' uniformNativeM++range' :: ∀ a b m . (Enum a, Bounded b, Enum b, Monad m) => (a, a) -> m b -> m a+range' (a, b) = untilJust+ . fmap (toEnumMayWrap' . foldr (\ m n -> card @b * n + fromEnum' m) 0)+ . replicateA @_ @[] r+ where toEnumMayWrap' :: Natural -> Maybe a+ toEnumMayWrap' n | n > r * card @b `div` card_a * card_a = Nothing+ | otherwise = [a..b] !!? (n `div` card_a)++ r = (card_a + card @b - 1) `div` card @b++ card_a = L.genericLength [a..b]++{-# INLINE[1] range' #-}+{-# RULES "range'" range' = pure id #-}++weighted :: (Gen g, Bounded (Native g), Enum (Native g), Uniform a)+ => NonEmpty (a, Ratio Natural) -> M.State g a+weighted = weighted' range++weightedM :: (Gen g, Bounded (Native g), Enum (Native g), Uniform a, PrimMonad m)+ => NonEmpty (a, Ratio Natural) -> ReaderT (Mut (PrimState m) g) m a+weightedM = weighted' rangeM++weighted' :: Functor f+ => ((Natural, Natural) -> f Natural) -> NonEmpty (a, Ratio Natural) -> f a+weighted' range aps = flip go aps . (% b) <$> range (0, b - 1)+ where b = lcms $ denominator . snd <$> aps+ go x = NE.uncons & \ case ((a, _), Nothing) -> a+ ((a, p), Just aps) -> bool (go (x - p) aps) a (x < p)++lcms :: NonEmpty Natural -> Natural+lcms = liftA2 div product (foldr' gcd 0)
Util.hs view
@@ -1,7 +1,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE AllowAmbiguousTypes #-} -module Util (card, fromEnum', toEnumMay', module U) where+module Util (card, fromEnum', module U) where import qualified Data.List as L import Numeric.Natural@@ -12,6 +12,3 @@ fromEnum' :: (Bounded a, Enum a) => a -> Natural fromEnum' a = L.genericLength [minBound..a] - 1--toEnumMay' :: (Bounded a, Enum a) => Natural -> Maybe a-toEnumMay' = (!!?) [minBound..]
random-class.cabal view
@@ -1,5 +1,5 @@ name: random-class-version: 0.1.2.0+version: 0.2.0.0 synopsis: Class of random value generation -- description: license: BSD3@@ -26,10 +26,10 @@ , EmptyCase , TypeApplications , ScopedTypeVariables+ , InstanceSigs , PolyKinds , TypeFamilies , TypeFamilyDependencies- , MultiParamTypeClasses , FlexibleContexts , FlexibleInstances , PackageImports