{-# language OverloadedStrings #-}
{-# language DeriveFunctor, GeneralizedNewtypeDeriving #-}
module System.Random.MWC.Probability.Transition (
Transition
, mkTransition
, runTransition
, withSeverity
, Handler
, WithSeverity(..), Severity(..)
) where
import Control.Monad
import Control.Monad.Primitive
import qualified Control.Monad.State as S
import Control.Monad.Trans.Class (MonadTrans(..), lift)
import Control.Monad.Trans.State.Strict (StateT(..), evalStateT, execStateT, runStateT)
import Control.Monad.Log (MonadLog(..), Handler, WithSeverity(..), Severity(..), LoggingT(..), runLoggingT, withFDHandler, defaultBatchingOptions, logMessage)
import Data.Char
import System.Random.MWC.Probability
newtype Transition message s m a = Transition (
Gen (PrimState m) -> StateT s (LoggingT message m) a
) deriving (Functor)
mkTransition :: Monad m =>
(s -> Prob m t)
-> (s -> t -> (a, s))
-> (a -> s -> message)
-> Transition message s m a
mkTransition fm fs flog = Transition $ \gen -> do
s <- S.get
w <- lift . lift $ sample (fm s) gen
let (a, s') = fs s w
lift $ logMessage $ flog a s'
S.put s'
return a
runTransition :: Monad m =>
Handler m message
-> Transition message s m a
-> Int
-> s
-> Gen (PrimState m)
-> m [(a, s)]
runTransition logf (Transition fm) n s0 g =
runLoggingT (replicateM n (runStateT (fm g) s0)) logf
bracketsUpp :: Show a => a -> String
bracketsUpp p = unwords ["[", map toUpper (show p), "]"]
withSeverity :: (t -> String) -> WithSeverity t -> String
withSeverity k (WithSeverity u a ) = unwords [bracketsUpp u, k a]