module UVMHS.Lib.Rand where

import UVMHS.Core

import System.Random as R


--------
-- RG --
--------

class MonadRand m where
  rng ∷ State RG a → m a

newtype RG = RG { RG -> StdGen
unRG ∷ R.StdGen }

instance MonadRand IO where
  rng :: forall a. State RG a -> IO a
rng State RG a
f = (StdGen -> (a, StdGen)) -> IO a
forall (m :: * -> *) a. MonadIO m => (StdGen -> (a, StdGen)) -> m a
R.getStdRandom ((StdGen -> (a, StdGen)) -> IO a)
-> (StdGen -> (a, StdGen)) -> IO a
forall a b. (a -> b) -> a -> b
$ \ StdGen
ℊ →
    let RG StdGen
ℊ' :* a
x = RG -> State RG a -> RG ∧ a
forall s a. s -> State s a -> s ∧ a
runState (StdGen -> RG
RG StdGen
ℊ) State RG a
f
    in (a
x,StdGen
ℊ')

rngSeed ∷ ℕ64 → IO ()
rngSeed :: ℕ64 -> IO ()
rngSeed = StdGen -> IO ()
forall (m :: * -> *). MonadIO m => StdGen -> m ()
R.setStdGen (StdGen -> IO ()) -> (Int -> StdGen) -> Int -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
∘ Int -> StdGen
R.mkStdGen (Int -> IO ()) -> (ℤ64 -> Int) -> ℤ64 -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
∘ ℤ64 -> Int
forall a b. CHS a b => a -> b
tohs (ℤ64 -> IO ()) -> (ℕ64 -> ℤ64) -> ℕ64 -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
∘ ℕ64 -> ℤ64
frBitsℤ64

wrapPrimRandu ∷ (R.StdGen → (a,R.StdGen)) → State RG a
wrapPrimRandu :: forall a. (StdGen -> (a, StdGen)) -> State RG a
wrapPrimRandu StdGen -> (a, StdGen)
f = do
  RG StdGen
ℊ ← StateT RG ID RG
forall s (m :: * -> *). MonadState s m => m s
get
  let (a
x,StdGen
ℊ') = StdGen -> (a, StdGen)
f StdGen
ℊ
  RG -> StateT RG ID ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (RG -> StateT RG ID ()) -> RG -> StateT RG ID ()
forall a b. (a -> b) -> a -> b
$ StdGen -> RG
RG StdGen
ℊ'
  a -> State RG a
forall a. a -> StateT RG ID a
forall (m :: * -> *) a. Return m => a -> m a
return a
x

wrapPrimRandr ∷ ((a,a) → R.StdGen → (a,R.StdGen)) → a → a → State RG a
wrapPrimRandr :: forall a. ((a, a) -> StdGen -> (a, StdGen)) -> a -> a -> State RG a
wrapPrimRandr (a, a) -> StdGen -> (a, StdGen)
f a
xl a
xh = do
  RG StdGen
ℊ ← StateT RG ID RG
forall s (m :: * -> *). MonadState s m => m s
get
  let (a
x,StdGen
ℊ') = (a, a) -> StdGen -> (a, StdGen)
f (a
xl,a
xh) StdGen
ℊ
  RG -> StateT RG ID ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (RG -> StateT RG ID ()) -> RG -> StateT RG ID ()
forall a b. (a -> b) -> a -> b
$ StdGen -> RG
RG StdGen
ℊ'
  a -> State RG a
forall a. a -> StateT RG ID a
forall (m :: * -> *) a. Return m => a -> m a
return a
x

------------------------
-- BASE VALUE CLASSES --
------------------------

class RandUniform a where
  prandu ∷ State RG a

class RandRange a where
  -- both bounds inclusive
  prandr ∷ a → a → State RG a

prandrRadius ∷ (RandRange a,Zero a,Minus a) ⇒ a → State RG a
prandrRadius :: forall a. (RandRange a, Zero a, Minus a) => a -> State RG a
prandrRadius a
x = a -> a -> State RG a
forall a. RandRange a => a -> a -> State RG a
prandr (a -> a
forall a. (Zero a, Minus a) => a -> a
neg a
x) a
x

--------------------------
-- BASE VALUE INSTANCES --
--------------------------

instance RandUniform 𝔹   where prandu :: State RG 𝔹
prandu = (StdGen -> (𝔹, StdGen)) -> State RG 𝔹
forall a. (StdGen -> (a, StdGen)) -> State RG a
wrapPrimRandu StdGen -> (𝔹, StdGen)
forall g a. (RandomGen g, Uniform a) => g -> (a, g)
R.uniform

instance RandUniform ℕ64 where prandu :: State RG ℕ64
prandu = (StdGen -> (ℕ64, StdGen)) -> State RG ℕ64
forall a. (StdGen -> (a, StdGen)) -> State RG a
wrapPrimRandu StdGen -> (ℕ64, StdGen)
forall g a. (RandomGen g, Uniform a) => g -> (a, g)
R.uniform
instance RandUniform ℕ32 where prandu :: State RG ℕ32
prandu = (StdGen -> (ℕ32, StdGen)) -> State RG ℕ32
forall a. (StdGen -> (a, StdGen)) -> State RG a
wrapPrimRandu StdGen -> (ℕ32, StdGen)
forall g a. (RandomGen g, Uniform a) => g -> (a, g)
R.uniform
instance RandUniform ℕ16 where prandu :: State RG ℕ16
prandu = (StdGen -> (ℕ16, StdGen)) -> State RG ℕ16
forall a. (StdGen -> (a, StdGen)) -> State RG a
wrapPrimRandu StdGen -> (ℕ16, StdGen)
forall g a. (RandomGen g, Uniform a) => g -> (a, g)
R.uniform
instance RandUniform ℕ8  where prandu :: State RG ℕ8
prandu = (StdGen -> (ℕ8, StdGen)) -> State RG ℕ8
forall a. (StdGen -> (a, StdGen)) -> State RG a
wrapPrimRandu StdGen -> (ℕ8, StdGen)
forall g a. (RandomGen g, Uniform a) => g -> (a, g)
R.uniform

instance RandUniform ℤ64 where prandu :: State RG ℤ64
prandu = (StdGen -> (ℤ64, StdGen)) -> State RG ℤ64
forall a. (StdGen -> (a, StdGen)) -> State RG a
wrapPrimRandu StdGen -> (ℤ64, StdGen)
forall g a. (RandomGen g, Uniform a) => g -> (a, g)
R.uniform
instance RandUniform ℤ32 where prandu :: State RG ℤ32
prandu = (StdGen -> (ℤ32, StdGen)) -> State RG ℤ32
forall a. (StdGen -> (a, StdGen)) -> State RG a
wrapPrimRandu StdGen -> (ℤ32, StdGen)
forall g a. (RandomGen g, Uniform a) => g -> (a, g)
R.uniform
instance RandUniform ℤ16 where prandu :: State RG ℤ16
prandu = (StdGen -> (ℤ16, StdGen)) -> State RG ℤ16
forall a. (StdGen -> (a, StdGen)) -> State RG a
wrapPrimRandu StdGen -> (ℤ16, StdGen)
forall g a. (RandomGen g, Uniform a) => g -> (a, g)
R.uniform
instance RandUniform ℤ8  where prandu :: State RG ℤ8
prandu = (StdGen -> (ℤ8, StdGen)) -> State RG ℤ8
forall a. (StdGen -> (a, StdGen)) -> State RG a
wrapPrimRandu StdGen -> (ℤ8, StdGen)
forall g a. (RandomGen g, Uniform a) => g -> (a, g)
R.uniform

instance RandRange ℕ64   where prandr :: ℕ64 -> ℕ64 -> State RG ℕ64
prandr = ((ℕ64, ℕ64) -> StdGen -> (ℕ64, StdGen))
-> ℕ64 -> ℕ64 -> State RG ℕ64
forall a. ((a, a) -> StdGen -> (a, StdGen)) -> a -> a -> State RG a
wrapPrimRandr (ℕ64, ℕ64) -> StdGen -> (ℕ64, StdGen)
forall g a. (RandomGen g, UniformRange a) => (a, a) -> g -> (a, g)
R.uniformR
instance RandRange ℕ32   where prandr :: ℕ32 -> ℕ32 -> State RG ℕ32
prandr = ((ℕ32, ℕ32) -> StdGen -> (ℕ32, StdGen))
-> ℕ32 -> ℕ32 -> State RG ℕ32
forall a. ((a, a) -> StdGen -> (a, StdGen)) -> a -> a -> State RG a
wrapPrimRandr (ℕ32, ℕ32) -> StdGen -> (ℕ32, StdGen)
forall g a. (RandomGen g, UniformRange a) => (a, a) -> g -> (a, g)
R.uniformR
instance RandRange ℕ16   where prandr :: ℕ16 -> ℕ16 -> State RG ℕ16
prandr = ((ℕ16, ℕ16) -> StdGen -> (ℕ16, StdGen))
-> ℕ16 -> ℕ16 -> State RG ℕ16
forall a. ((a, a) -> StdGen -> (a, StdGen)) -> a -> a -> State RG a
wrapPrimRandr (ℕ16, ℕ16) -> StdGen -> (ℕ16, StdGen)
forall g a. (RandomGen g, UniformRange a) => (a, a) -> g -> (a, g)
R.uniformR
instance RandRange ℕ8    where prandr :: ℕ8 -> ℕ8 -> State RG ℕ8
prandr = ((ℕ8, ℕ8) -> StdGen -> (ℕ8, StdGen)) -> ℕ8 -> ℕ8 -> State RG ℕ8
forall a. ((a, a) -> StdGen -> (a, StdGen)) -> a -> a -> State RG a
wrapPrimRandr (ℕ8, ℕ8) -> StdGen -> (ℕ8, StdGen)
forall g a. (RandomGen g, UniformRange a) => (a, a) -> g -> (a, g)
R.uniformR

instance RandRange ℤ64   where prandr :: ℤ64 -> ℤ64 -> State RG ℤ64
prandr = ((ℤ64, ℤ64) -> StdGen -> (ℤ64, StdGen))
-> ℤ64 -> ℤ64 -> State RG ℤ64
forall a. ((a, a) -> StdGen -> (a, StdGen)) -> a -> a -> State RG a
wrapPrimRandr (ℤ64, ℤ64) -> StdGen -> (ℤ64, StdGen)
forall g a. (RandomGen g, UniformRange a) => (a, a) -> g -> (a, g)
R.uniformR
instance RandRange ℤ32   where prandr :: ℤ32 -> ℤ32 -> State RG ℤ32
prandr = ((ℤ32, ℤ32) -> StdGen -> (ℤ32, StdGen))
-> ℤ32 -> ℤ32 -> State RG ℤ32
forall a. ((a, a) -> StdGen -> (a, StdGen)) -> a -> a -> State RG a
wrapPrimRandr (ℤ32, ℤ32) -> StdGen -> (ℤ32, StdGen)
forall g a. (RandomGen g, UniformRange a) => (a, a) -> g -> (a, g)
R.uniformR
instance RandRange ℤ16   where prandr :: ℤ16 -> ℤ16 -> State RG ℤ16
prandr = ((ℤ16, ℤ16) -> StdGen -> (ℤ16, StdGen))
-> ℤ16 -> ℤ16 -> State RG ℤ16
forall a. ((a, a) -> StdGen -> (a, StdGen)) -> a -> a -> State RG a
wrapPrimRandr (ℤ16, ℤ16) -> StdGen -> (ℤ16, StdGen)
forall g a. (RandomGen g, UniformRange a) => (a, a) -> g -> (a, g)
R.uniformR
instance RandRange ℤ8    where prandr :: ℤ8 -> ℤ8 -> State RG ℤ8
prandr = ((ℤ8, ℤ8) -> StdGen -> (ℤ8, StdGen)) -> ℤ8 -> ℤ8 -> State RG ℤ8
forall a. ((a, a) -> StdGen -> (a, StdGen)) -> a -> a -> State RG a
wrapPrimRandr (ℤ8, ℤ8) -> StdGen -> (ℤ8, StdGen)
forall g a. (RandomGen g, UniformRange a) => (a, a) -> g -> (a, g)
R.uniformR

instance RandRange 𝔻     where prandr :: 𝔻 -> 𝔻 -> State RG 𝔻
prandr = ((𝔻, 𝔻) -> StdGen -> (𝔻, StdGen)) -> 𝔻 -> 𝔻 -> State RG 𝔻
forall a. ((a, a) -> StdGen -> (a, StdGen)) -> a -> a -> State RG a
wrapPrimRandr (𝔻, 𝔻) -> StdGen -> (𝔻, StdGen)
forall g a. (RandomGen g, UniformRange a) => (a, a) -> g -> (a, g)
R.uniformR

-----------------
-- COMBINATORS --
-----------------

randu ∷ ∀ a m. (MonadRand m,RandUniform a) ⇒ m a
randu :: forall a (m :: * -> *). (MonadRand m, RandUniform a) => m a
randu = State RG a -> m a
forall a. State RG a -> m a
forall (m :: * -> *) a. MonadRand m => State RG a -> m a
rng State RG a
forall a. RandUniform a => State RG a
prandu

-- both bounds inclusive
randr ∷ ∀ a m. (MonadRand m,RandRange a) ⇒ a → a → m a
randr :: forall a (m :: * -> *). (MonadRand m, RandRange a) => a -> a -> m a
randr a
lb a
hb = State RG a -> m a
forall a. State RG a -> m a
forall (m :: * -> *) a. MonadRand m => State RG a -> m a
rng (State RG a -> m a) -> State RG a -> m a
forall a b. (a -> b) -> a -> b
$ a -> a -> State RG a
forall a. RandRange a => a -> a -> State RG a
prandr a
lb a
hb

randrRadius ∷ ∀ a m. (MonadRand m,RandRange a,Zero a,Minus a) ⇒ a → m a
randrRadius :: forall a (m :: * -> *).
(MonadRand m, RandRange a, Zero a, Minus a) =>
a -> m a
randrRadius = State RG a -> m a
forall a. State RG a -> m a
forall (m :: * -> *) a. MonadRand m => State RG a -> m a
rng (State RG a -> m a) -> (a -> State RG a) -> a -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
∘ a -> State RG a
forall a. (RandRange a, Zero a, Minus a) => a -> State RG a
prandrRadius

wrchoose ∷ ∀ t m a. (Monad m,MonadRand m,ToIter (ℕ64 ∧ (() → m a)) t) ⇒ t → m a
wrchoose :: forall t (m :: * -> *) a.
(Monad m, MonadRand m, ToIter (ℕ64 ∧ (() -> m a)) t) =>
t -> m a
wrchoose t
wxs
  | t -> 𝔹
forall a t. ToIter a t => t -> 𝔹
isEmpty t
wxs = 𝕊 -> m a
forall a. STACK => 𝕊 -> a
error 𝕊
"wrchoose not defined for zero elements"
  | 𝔹
otherwise   = do
      let ws :: 𝐼 ℕ64
ws = ((ℕ64 ∧ (() -> m a)) -> ℕ64) -> 𝐼 (ℕ64 ∧ (() -> m a)) -> 𝐼 ℕ64
forall a b. (a -> b) -> 𝐼 a -> 𝐼 b
forall (t :: * -> *) a b. Functor t => (a -> b) -> t a -> t b
map (ℕ64 ∧ (() -> m a)) -> ℕ64
forall a b. (a ∧ b) -> a
fst (𝐼 (ℕ64 ∧ (() -> m a)) -> 𝐼 ℕ64) -> 𝐼 (ℕ64 ∧ (() -> m a)) -> 𝐼 ℕ64
forall a b. (a -> b) -> a -> b
$ t -> 𝐼 (ℕ64 ∧ (() -> m a))
forall a t. ToIter a t => t -> 𝐼 a
iter t
wxs
          w₀ :: ℕ64
w₀ = 𝐼 ℕ64 -> ℕ64
forall a t. (ToIter a t, Additive a) => t -> a
sum 𝐼 ℕ64
ws
      let ()
_ = if ℕ64
w₀ ℕ64 -> ℕ64 -> 𝔹
forall a. Eq a => a -> a -> 𝔹
≡ ℕ64
0 then 𝕊 -> ()
forall a. STACK => 𝕊 -> a
error (𝕊 -> ()) -> 𝕊 -> ()
forall a b. (a -> b) -> a -> b
$ 𝕊
"wrchoose not defined for zero total weight: " 𝕊 -> 𝕊 -> 𝕊
forall a. Append a => a -> a -> a
⧺ 𝐼 ℕ64 -> 𝕊
forall a. Show a => a -> 𝕊
show𝕊 𝐼 ℕ64
ws else ()
      ℕ64
n ← ℕ64 -> ℕ64 -> m ℕ64
forall a (m :: * -> *). (MonadRand m, RandRange a) => a -> a -> m a
randr ℕ64
1 ℕ64
w₀
      (ℕ64 -> m a) -> ContT a m ℕ64 -> m a
forall {k} a (m :: k -> *) (u :: k).
(a -> m u) -> ContT u m a -> m u
runContT (\ ℕ64
n' → 𝕊 -> m a
forall a. STACK => 𝕊 -> a
error (𝕊 -> m a) -> 𝕊 -> m a
forall a b. (a -> b) -> a -> b
$ 𝕊
"impossible" 𝕊 -> 𝕊 -> 𝕊
forall a. Append a => a -> a -> a
⧺ ℕ64 -> 𝕊
forall a. Show a => a -> 𝕊
show𝕊 ℕ64
n') (ContT a m ℕ64 -> m a) -> ContT a m ℕ64 -> m a
forall a b. (a -> b) -> a -> b
$ t
-> ℕ64
-> ((ℕ64 ∧ (() -> m a)) -> ℕ64 -> ContT a m ℕ64)
-> ContT a m ℕ64
forall (m :: * -> *) a t b.
(Monad m, ToIter a t) =>
t -> b -> (a -> b -> m b) -> m b
mfoldOnFrom t
wxs ℕ64
0 (((ℕ64 ∧ (() -> m a)) -> ℕ64 -> ContT a m ℕ64) -> ContT a m ℕ64)
-> ((ℕ64 ∧ (() -> m a)) -> ℕ64 -> ContT a m ℕ64) -> ContT a m ℕ64
forall a b. (a -> b) -> a -> b
$ \ (ℕ64
w :* () -> m a
xM) ℕ64
wᵢ →
        let wᵢ' :: ℕ64
wᵢ' = ℕ64
wᵢℕ64 -> ℕ64 -> ℕ64
forall a. Plus a => a -> a -> a
+ℕ64
w
        in
        if ℕ64
n ℕ64 -> ℕ64 -> 𝔹
forall a. Ord a => a -> a -> 𝔹
≤ ℕ64
wᵢ'
        then ((ℕ64 -> ContT a m a) -> ContT a m a) -> ContT a m ℕ64
forall a. ((a -> ContT a m a) -> ContT a m a) -> ContT a m a
forall r (m :: * -> *) a.
MonadCont r m =>
((a -> m r) -> m r) -> m a
callCC (((ℕ64 -> ContT a m a) -> ContT a m a) -> ContT a m ℕ64)
-> ((ℕ64 -> ContT a m a) -> ContT a m a) -> ContT a m ℕ64
forall a b. (a -> b) -> a -> b
$ \ ℕ64 -> ContT a m a
_𝓀 → m a -> ContT a m a
forall (m :: * -> *) a. Monad m => m a -> ContT a m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(Transformer t, Monad m) =>
m a -> t m a
lift (m a -> ContT a m a) -> m a -> ContT a m a
forall a b. (a -> b) -> a -> b
$ () -> m a
xM ()
        else ℕ64 -> ContT a m ℕ64
forall a. a -> ContT a m a
forall (m :: * -> *) a. Return m => a -> m a
return ℕ64
wᵢ'

rchoose ∷ (Monad m,MonadRand m,ToIter (() → m a) t) ⇒ t → m a
rchoose :: forall (m :: * -> *) a t.
(Monad m, MonadRand m, ToIter (() -> m a) t) =>
t -> m a
rchoose t
xMs
  | t -> 𝔹
forall a t. ToIter a t => t -> 𝔹
isEmpty t
xMs = 𝕊 -> m a
forall a. STACK => 𝕊 -> a
error 𝕊
"rchoose not defined for zero elements"
  | 𝔹
otherwise   = 𝐼 (ℕ64 ∧ (() -> m a)) -> m a
forall t (m :: * -> *) a.
(Monad m, MonadRand m, ToIter (ℕ64 ∧ (() -> m a)) t) =>
t -> m a
wrchoose (𝐼 (ℕ64 ∧ (() -> m a)) -> m a) -> 𝐼 (ℕ64 ∧ (() -> m a)) -> m a
forall a b. (a -> b) -> a -> b
$ ((() -> m a) -> ℕ64 ∧ (() -> m a))
-> 𝐼 (() -> m a) -> 𝐼 (ℕ64 ∧ (() -> m a))
forall a b. (a -> b) -> 𝐼 a -> 𝐼 b
forall (t :: * -> *) a b. Functor t => (a -> b) -> t a -> t b
map (ℕ64
forall a. One a => a
one ℕ64 -> (() -> m a) -> ℕ64 ∧ (() -> m a)
forall a b. a -> b -> a ∧ b
:*) (𝐼 (() -> m a) -> 𝐼 (ℕ64 ∧ (() -> m a)))
-> 𝐼 (() -> m a) -> 𝐼 (ℕ64 ∧ (() -> m a))
forall a b. (a -> b) -> a -> b
$ t -> 𝐼 (() -> m a)
forall a t. ToIter a t => t -> 𝐼 a
iter t
xMs

untilPass ∷ (Monad m) ⇒ (a → 𝔹) → m a → m a
untilPass :: forall (m :: * -> *) a. Monad m => (a -> 𝔹) -> m a -> m a
untilPass a -> 𝔹
f m a
xM = m a
loop
  where
    loop :: m a
loop = do
      a
x ← m a
xM
      if a -> 𝔹
f a
x
      then a -> m a
forall a. a -> m a
forall (m :: * -> *) a. Return m => a -> m a
return a
x
      else m a
loop