{-# LANGUAGE MultiParamTypeClasses, GeneralizedNewtypeDeriving, DeriveGeneric,
DeriveAnyClass, DerivingStrategies, TypeOperators #-}
{-|
Module : Markov
Description : Realization of Markov processes with known parameters.
Maintainer : atloomis@math.arizona.edu
Stability : experimental
Three type classes for deterministically analyzing
Markov chains with known parameters.
'Markov0' is intended to list possible outcomes,
'Markov' should allow for more sophisticated analysis,
and 'MultiMarkov' is intended to make implementing
hidden Markov models easier.
See "Examples" for examples.
See README for a detailed description.
-}
module Markov (
-- *Markov0
Markov0 (..)
-- *Markov
, Markov (..)
-- *MultiMarkov
, randomProduct
, randomPath
, MultiMarkov (..)
-- *Combine
, Combine (..)
, Merge (..)
, Sum (..)
, Product (..)
-- *Misc
, (:*)
, (>*<)
, fromLists
-- *Testing
) where
import Markov.Instances ()
import Control.Applicative ((<**>))
import Generics.Deriving (Generic)
import Data.Discrimination (Grouping, grouping)
import qualified Data.Discrimination as DD
import qualified Data.List as DL
import qualified Data.List.NonEmpty as NE
import qualified Data.Functor.Contravariant as FC
import qualified Control.Monad.Random as MR
---------------------------------------------------------------
-- Markov0
---------------------------------------------------------------
-- |A basic implementation of Markov chains.
class (Eq m) => Markov0 m where
-- |The transition functions from a state.
transition0 :: m -> [m -> m]
step0 :: m -> [m]
-- |Iterated steps.
chain0 :: [m] -> [[m]]
step0 x = fmap ($ x) (transition0 x)
chain0 = DL.iterate' $ DL.nub . concatMap step0
---------------------------------------------------------------------------------------
-- Markov
---------------------------------------------------------------------------------------
-- |An implementation of Markov chains.
-- To speed up @chain@, try instead:
--
-- > chain = DL.iterate' $ map summarize' . NE.group . DL.sort . concatMap step
-- > where summarize' xs@((_,b)NE.:|_) = (summarize . fmap fst $ xs, b)
class (Combine t, Grouping t, Grouping m, Monoid t) => Markov t m where
transition :: m -> [(t, m -> m)]
step :: (t,m) -> [(t,m)]
chain :: [(t,m)] -> [[(t,m)]]
step x = fmap (x <**>) (transition $ snd x)
-- |Iterated steps, with equal states combined using 'summarize' operation.
chain = DL.iterate' $ map (summarize' . NE.fromList)
. DD.group . concatMap step
where summarize' xs@((_,b)NE.:|_) = (summarize . fmap fst $ xs, b)
-- WARNING: DD.group does not currently respect equivalence classes.
---------------------------------------------------------------------------------------
-- Multi-Transition Markov
---------------------------------------------------------------------------------------
-- |An implementation of Markov chains that allows multi-transition steps.
class (Combine m, Grouping m, Semigroup m) => MultiMarkov m where
multiTransition :: m -> [m -> [m]]
multiStep :: m -> [m]
multiChain :: [m] -> [[m]]
multiStep x = foldr phi [x] (multiTransition x)
where phi f = concatMap (delta f)
delta f y = map (y <>) (f y)
multiChain = DL.iterate' $ map (summarize . NE.fromList)
. DD.group . concatMap multiStep
---------------------------------------------------------------------------------------
-- Combine
---------------------------------------------------------------------------------------
-- |Within equivalence classes, @combine@ should be associative,
-- commutative, and should be idempotent up to equivalence.
-- I.e. if @x == y == z@,
--
-- prop> (x `combine` y) `combine` z = x `combine` (y `combine` z)
-- prop> x `combine` y = y `combine` x
-- prop> x `combine` x == x
class Combine a where
combine :: a -> a -> a
summarize :: NE.NonEmpty a -> a
summarize (a NE.:| b) = foldr combine a b
instance (Combine a, Combine b) => Combine (a,b) where
combine (w,x) (y,z) = (combine w y, combine x z)
instance (Combine a, Combine b, Combine c) => Combine (a,b,c) where
combine (a,w,x) (b,y,z) = (combine a b, combine w y, combine x z)
---------------------------------------------------------------------------------------
-- Easier way to write nested 2-tuples
---------------------------------------------------------------------------------------
-- |Easier way to write nested 2-tuples.
type a :* b = (a,b)
-- |Easier way to write nested 2-tuples,
-- since @a >*\< b >*\< c >*< d@
-- is much easier to read than
-- @(((a,b),c),d)@.
-- Left associative, binds weaker than @+@
-- but stronger than @==@.
(>*<) :: a -> b -> a :* b
a >*< b = (a,b)
infixl 5 >*<
---------------------------------------------------------------------------------------
-- Merge
---------------------------------------------------------------------------------------
-- Does not group to combine unless equal.
-- |Values from a 'Monoid' which have the respective
-- binary operation applied each step.
-- E.g., strings with concatenation.
newtype Merge a = Merge a
deriving (Eq, Generic)
deriving newtype (Semigroup, Monoid, Enum, Num, Fractional, Show)
deriving anyclass Grouping
instance Combine (Merge a) where
combine = const
---------------------------------------------------------------------------------------
-- Sum
---------------------------------------------------------------------------------------
-- |Values which are added each step.
-- E.g., number of times a red ball is picked from an urn.
newtype Sum a = Sum a
deriving Generic
deriving newtype (Eq, Enum, Num, Fractional, Show)
deriving anyclass Grouping
instance Combine (Sum a) where
combine = const
instance Num a => Semigroup (Sum a) where
x <> y = x + y
instance Num a => Monoid (Sum a) where
mempty = 0
---------------------------------------------------------------------------------------
-- Product
---------------------------------------------------------------------------------------
-- Does not effect equality of tuple,
-- @combine x y = x + y@.
-- |Values which are multiplied each step,
-- and combined additively for equal states.
-- E.g., probabilities.
newtype Product a = Product a
deriving Generic
deriving newtype (Num, Fractional, Enum, Show)
instance Grouping (Product a) where
grouping = FC.contramap (const ()) grouping
-- This causes Data.List.group to act more like Data.Discrimination.group
instance Eq (Product a) where
_ == _ = True
instance Num a => Combine (Product a) where
combine = (+)
instance Num a => Semigroup (Product a) where
x <> y = x * y
instance Num a => Monoid (Product a) where
mempty = 1
---------------------------------------------------------------------------------------
-- Misc
---------------------------------------------------------------------------------------
-- |Randomly choose from a list by probability.
randomProduct :: (Real a, MR.MonadRandom m) => [(a, b)] -> m (a, b)
randomProduct xs = MR.fromList . map (\x -> (x, toRational $ fst x)) $ xs
-- |Returns a single realization of a Markov chain.
randomPath :: (Markov a b, Real a, MR.RandomGen g) => (a,b) -> g -> [(a,b)]
randomPath x g = map (flip MR.evalRand g) . iterate (>>= (randomProduct . step)) $ pure x
-- |Create a transition function from a transition matrix.
-- If [[a]] is an n x n matrix, length [b] should be n.
fromLists :: Eq b => [[a]] -> [b] -> b -> [(a, b -> b)]
fromLists matrix states b = case DL.elemIndex b states of
Nothing -> []
Just n -> zip (matrix!!n) toState
where toState = map const states