{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE UndecidableInstances #-}
module System.Random.OneLiner (
GRandom(..)
, gRandomR
, gRandom
, gRandomRs
, gRandoms
, gRandomRIO
, gRandomIO
, GRandomSum(..)
, gRandomRSum
, gRandomSum
, gRandomRSums
, gRandomSums
, gRandomRIOSum
, gRandomIOSum
) where
import Control.Monad
import Data.Coerce
import Data.Data
import Data.Functor.Compose
import Data.List.NonEmpty (NonEmpty(..))
import Data.Maybe
import GHC.Exts (build)
import GHC.Generics
import Generics.OneLiner
import System.Random
import qualified Data.List.NonEmpty as NE
newtype GRandom a = GRandom { getGRandom :: a }
deriving (Eq, Ord, Show, Read, Data, Generic, Functor, Foldable, Traversable)
instance ( ADTRecord a
, Constraints a Random
)
=> Random (GRandom a) where
randomR :: forall g. RandomGen g => (GRandom a, GRandom a) -> g -> (GRandom a, g)
randomR = coerce (gRandomR @a @g)
{-# INLINE randomR #-}
random :: forall g. RandomGen g => g -> (GRandom a, g)
random = coerce (gRandom @a @g)
{-# INLINE random #-}
randomRs :: forall g. RandomGen g => (GRandom a, GRandom a) -> g -> [GRandom a]
randomRs = coerce (gRandomRs @a @g)
{-# INLINE randomRs #-}
randoms :: forall g. RandomGen g => g -> [GRandom a]
randoms = coerce (gRandoms @a @g)
{-# INLINE randoms #-}
randomRIO :: (GRandom a, GRandom a) -> IO (GRandom a)
randomRIO = coerce (gRandomRIO @a)
{-# INLINE randomRIO #-}
randomIO :: IO (GRandom a)
randomIO = coerce (gRandomIO @a)
{-# INLINE randomIO #-}
gRandomR
:: forall a g. (ADTRecord a, Constraints a Random, RandomGen g)
=> (a, a) -> g -> (a, g)
gRandomR (l, u) = runState $
dialgebra @Random
(State . randomR . dePair)
(Pair l u)
{-# INLINE gRandomR #-}
gRandom
:: forall a g. (ADTRecord a, Constraints a Random, RandomGen g)
=> g -> (a, g)
gRandom = runState $ createA' @Random (State random)
{-# INLINE gRandom #-}
gRandomRs
:: forall a g. (ADTRecord a, Constraints a Random, RandomGen g)
=> (a, a) -> g -> [a]
gRandomRs ival g = build (\cons _nil -> buildRandoms cons (gRandomR ival) g)
{-# INLINE gRandomRs #-}
gRandoms
:: forall a g. (ADTRecord a, Constraints a Random, RandomGen g)
=> g -> [a]
gRandoms g = build (\cons _nil -> buildRandoms cons gRandom g)
{-# INLINE gRandoms #-}
gRandomRIO
:: forall a. (ADTRecord a, Constraints a Random)
=> (a, a) -> IO a
gRandomRIO range = getStdRandom (gRandomR range)
{-# INLINE gRandomRIO #-}
gRandomIO
:: forall a. (ADTRecord a, Constraints a Random)
=> IO a
gRandomIO = getStdRandom gRandom
{-# INLINE gRandomIO #-}
newtype GRandomSum a = GRandomSum { getGRandomSum :: a }
deriving (Eq, Ord, Show, Read, Data, Generic, Functor, Foldable, Traversable)
instance ( ADT a
, Constraints a Random
)
=> Random (GRandomSum a) where
randomR :: forall g. RandomGen g => (GRandomSum a, GRandomSum a) -> g -> (GRandomSum a, g)
randomR = coerce (gRandomRSum @a @g)
{-# INLINE randomR #-}
random :: forall g. RandomGen g => g -> (GRandomSum a, g)
random = coerce (gRandomSum @a @g)
{-# INLINE random #-}
randomRs :: forall g. RandomGen g => (GRandomSum a, GRandomSum a) -> g -> [GRandomSum a]
randomRs = coerce (gRandomRSums @a @g)
{-# INLINE randomRs #-}
randoms :: forall g. RandomGen g => g -> [GRandomSum a]
randoms = coerce (gRandomSums @a @g)
{-# INLINE randoms #-}
randomRIO :: (GRandomSum a, GRandomSum a) -> IO (GRandomSum a)
randomRIO = coerce (gRandomRIOSum @a)
{-# INLINE randomRIO #-}
randomIO :: IO (GRandomSum a)
randomIO = coerce (gRandomIOSum @a)
{-# INLINE randomIO #-}
gRandomRSum
:: forall a g. (ADT a, Constraints a Random, RandomGen g)
=> (a, a) -> g -> (a, g)
gRandomRSum (l, u) = runState . fromMaybe (error badbad) . getCompose $
zipWithA @Random (\l' u' -> Compose (Just (State (randomR (l', u')))))
l u
where
badbad = "gRandomRSum: Constructors in range do not match."
{-# INLINE gRandomRSum #-}
gRandomSum
:: forall a g. (ADT a, Constraints a Random, RandomGen g)
=> g -> (a, g)
gRandomSum = case options of
Nothing -> (error "gRandomSum: Uninhabited type",)
Just opts -> runState (join (reservoir opts))
where
options = NE.nonEmpty . getCompose $ createA @Random @a $
Compose [State random]
{-# INLINE gRandomSum #-}
gRandomRSums
:: forall a g. (ADT a, Constraints a Random, RandomGen g)
=> (a, a) -> g -> [a]
gRandomRSums ival g = build (\cons _nil -> buildRandoms cons (gRandomRSum ival) g)
{-# INLINE gRandomRSums #-}
gRandomSums
:: forall a g. (ADT a, Constraints a Random, RandomGen g)
=> g -> [a]
gRandomSums g = build (\cons _nil -> buildRandoms cons gRandomSum g)
{-# INLINE gRandomSums #-}
gRandomRIOSum
:: forall a. (ADT a, Constraints a Random)
=> (a, a) -> IO a
gRandomRIOSum range = getStdRandom (gRandomRSum range)
{-# INLINE gRandomRIOSum #-}
gRandomIOSum
:: forall a. (ADT a, Constraints a Random)
=> IO a
gRandomIOSum = getStdRandom gRandomSum
{-# INLINE gRandomIOSum #-}
data Pair a = Pair !a !a
deriving Functor
dePair :: Pair a -> (a, a)
dePair (Pair x y) = (x, y)
{-# INLINE dePair #-}
newtype State s a = State { runState :: s -> (a, s) }
deriving Functor
instance Applicative (State s) where
pure x = State (x,)
{-# INLINE pure #-}
sf <*> sx = State $ \s0 ->
let (f, !s1) = runState sf s0
(x, !s2) = runState sx s1
in (f x, s2)
{-# INLINE (<*>) #-}
instance Monad (State s) where
return x = State (x,)
{-# INLINE return #-}
sx >>= f = State $ \s0 ->
let (x, !s1) = runState sx s0
in runState (f x) s1
{-# INLINE (>>=) #-}
buildRandoms :: RandomGen g
=> (a -> as -> as)
-> (g -> (a,g))
-> g
-> as
buildRandoms cons rand = go
where
go g = x `seq` (x `cons` go g') where (x,g') = rand g
{-# INLINE buildRandoms #-}
reservoir :: RandomGen g => NE.NonEmpty a -> State g a
reservoir (x :| xs) = go 2 x xs
where
go _ y [] = pure y
go !i y (z:zs) = do
j <- State $ randomR @Int (1, i)
if j <= 1
then go (i + 1) z zs
else go (i + 1) y zs
{-# INLINE reservoir #-}