{-# LANGUAGE AllowAmbiguousTypes #-}
module Control.Monad.Freer.Random
(Random
,random
,randomR
,runRandom
,knownRandom
,runRandomWithSeed
,silentRandom
,FindInList
)
where
import Control.Monad.Freer
import Control.Monad.Freer.Internal
import qualified System.Random as R
import Data.Typeable ((:~:)(..))
import Data.Maybe
import Data.Set (Set)
import qualified Data.Set as S
data Elem a as where
Here :: Elem a (a ': as)
There :: Elem a as -> Elem a (b ': as)
class FindInList a as where
find :: Elem a as
instance {-# OVERLAPPING #-} FindInList a (a ': as) where
find = Here
instance FindInList a as => FindInList a (b ': as) where
find = There find
data Random typs a where
Random :: (R.Random a) => Elem a typs -> Random typs a
RandomR :: (R.Random a) => Elem a typs -> (a, a) -> Random typs a
random :: forall a typs r p. (R.Random a, FindInList a typs) => Eff (Random typs ': r) a
random = send $ Random (find @a @typs)
randomR :: forall a typs r p. (R.Random a, FindInList a typs) => (a, a) -> Eff (Random typs ': r) a
randomR range = send $ RandomR (find @a @typs) range
runRandom :: forall t r a . Member IO r => Eff (Random t ': r) a -> Eff r a
runRandom = interpret $ \r -> case r of
Random _ -> send R.randomIO
RandomR _ range -> send $ R.randomRIO range
silentRandom :: Eff (Random '[] ': r) v -> Eff r v
silentRandom = interpret $ \r -> case r of
knownRandom :: forall typ a r v . a -> Eff (Random (a ': typ) ': r) v -> Eff (Random typ ': r) v
knownRandom known = reinterpret $ \r -> case r of
Random Here -> return known
Random (There q) -> send $ Random q
RandomR Here _ -> return known
RandomR (There q) _ -> send $ Random q
runRandomWithSeed :: forall typ r v . Int -> Eff (Random typ ': r) v -> Eff r v
runRandomWithSeed seed = handleRelayS (R.mkStdGen seed) (\gen val -> return val) handler
where
handler :: R.StdGen -> Random typ a -> (R.StdGen -> a -> Eff r b) -> Eff r b
handler gen (Random _) next =
let r = R.random gen
in next (snd r) (fst r)
handler gen (RandomR _ range) next =
let r = R.randomR range gen
in next (snd r) (fst r)
pickRandom :: (FindInList Int typ) => [a] -> Eff (Random typ ': r) (Maybe a)
pickRandom vals = do
let max' = length vals
idx <- randomR (0, max' - 1)
return . listToMaybe $ drop idx vals
shuffle :: (FindInList Int typ) => Set a -> Eff (Random typ ': r) [a]
shuffle s
| S.null s = return []
| otherwise = do
idx <- randomR (0, S.size s - 1)
let val = S.elemAt idx s
rest <- shuffle $ S.deleteAt idx s
return $ val : rest