diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -28,17 +28,24 @@ We will make a new type for the state. ```haskell -data Extinction = Extinction Int +newtype Extinction = Extinction Int deriving Generic deriving newtype (Eq, Num, Show) deriving anyclass Grouping ``` +Combining identical states should not change the state, +so we make an instance of `Combine` as follows. + +```haskell +instance Combine Extinction where combine = const +``` + All that remains is to make an instance of `Markov`. ```haskell -instance Markov (Sum Int, Product Rational) Extinction where - transition x = case state x of +instance Markov ((,) (Sum Int, Product Rational)) Extinction where + transition = \case 0 -> [ 0 >*< (q+r) >*< id , 0 >*< s >*< (+1) ] _ -> [ 1 >*< q >*< const 0 diff --git a/markov-realization.cabal b/markov-realization.cabal --- a/markov-realization.cabal +++ b/markov-realization.cabal @@ -1,61 +1,55 @@ cabal-version: 1.12 - --- This file has been generated from package.yaml by hpack version 0.31.1. --- --- see: https://github.com/sol/hpack --- --- hash: b164fe328e9edef0858d48e61b56997280bd4bb2ea6ffe923afb24084a14efe6 - -name: markov-realization -version: 0.2.1 -description: Please see the README on GitHub at -homepage: https://github.com/alexloomis/markov -bug-reports: https://github.com/alexloomis/markov/issues -author: Alex Loomis -maintainer: atloomis@math.arizona.edu -copyright: 2019 Alex Loomis -license: BSD3 -license-file: LICENSE -build-type: Simple +name: markov-realization +version: 0.3.0 +license: BSD3 +license-file: LICENSE +copyright: 2019 Alex Loomis +maintainer: atloomis@math.arizona.edu +author: Alex Loomis +homepage: https://github.com/alexloomis/markov +bug-reports: https://github.com/alexloomis/markov/issues +synopsis: Realizations of Markov chains. +description: + Please see the README on GitHub at +category: Statistics +build-type: Simple extra-source-files: README.md ChangeLog.md -category: Statistics -synopsis: Realizations of Markov chains. source-repository head - type: git - location: git://github.com/alexloomis/markov.git + type: git + location: git://github.com/alexloomis/markov.git library - exposed-modules: - Markov - Markov.Example - Markov.Instance - other-modules: - Paths_markov_realization - hs-source-dirs: - src - build-depends: - base >=4.7 && <5 - , comonad - , configuration-tools - , contravariant - , discrimination - , generic-deriving - , MonadRandom - default-language: Haskell2010 + exposed-modules: + Markov + Markov.Example + Markov.Extra + Markov.Instance + hs-source-dirs: src + other-modules: + Paths_markov_realization + default-language: Haskell2010 + build-depends: + base >=4.7 && <5, + comonad >=5.0.5 && <5.1, + configuration-tools >=0.4.1 && <0.5, + contravariant >=1.5.1 && <1.6, + discrimination ==0.4.*, + generic-deriving >=1.12.4 && <1.13, + matrix >=0.3.6.1 && <0.4, + MonadRandom >=0.5.1.1 && <0.6 test-suite markov-test - type: exitcode-stdio-1.0 - main-is: Test.hs - other-modules: - Paths_markov_realization - hs-source-dirs: - test - ghc-options: -threaded -rtsopts -with-rtsopts=-N - build-depends: - base >=4.7 && <5 - , HTF - , markov-realization - default-language: Haskell2010 + type: exitcode-stdio-1.0 + main-is: Test.hs + hs-source-dirs: test + other-modules: + Paths_markov_realization + default-language: Haskell2010 + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + base >=4.7 && <5, + HTF >=0.13.2.5 && <0.14, + markov-realization -any diff --git a/src/Markov.hs b/src/Markov.hs --- a/src/Markov.hs +++ b/src/Markov.hs @@ -4,12 +4,11 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeOperators #-} {- | Module : Markov Description : Realization of Markov processes with known parameters. Maintainer : atloomis@math.arizona.edu -Stability : experimental +Stability : Experimental Three type classes for deterministically analyzing Markov chains with known parameters. @@ -32,23 +31,15 @@ , Merge (..) , Sum (..) , Product (..) - - -- *Misc - , (:*) - , (>*<) - , fromLists - , randomProduct - , randomPath ) where -- import Configuration.Utils.Operators ((<*<)) -import Control.Comonad +import Control.Comonad (Comonad, extract) import Data.Discrimination (Grouping, grouping) import Generics.Deriving (Generic) import Markov.Instance () -import qualified Control.Monad.Random as MR import qualified Data.Discrimination as DD import qualified Data.Functor.Contravariant as FC import qualified Data.List as DL @@ -67,6 +58,7 @@ step0 x = ($ x) <$> transition0 x {-# MINIMAL transition0 | step0 #-} +-- |Itterated steps, with equal states combined. chain0 :: Markov0 m => [m] -> [[m]] chain0 = DL.iterate' $ DL.nub . concatMap step0 @@ -93,11 +85,25 @@ -- step x = (<*> x) <$> transition (extract x) -- sequential = [fmap (fmap const) . step . pure] --- WARNING: DD.group does not currently respect equivalence classes. -- |Iterated steps, with equal states combined using 'summarize' operation. +-- WARNING: 'Data.Discrimination.group' does not currently +-- respect equivalence classes, only 'Grouping'. chain :: (Combine (t m), Grouping (t m), Markov t m) => [t m] -> [[t m]] chain = DL.iterate' $ fmap (summarize . NE.fromList) . DD.group . concatMap step +{- +-- |An implementation of Markov chains with non-list containers. +class (Applicative t, Comonad t, Monad c) => Markov' c t s where + transition' :: s -> c (t (s -> s)) + step' :: t s -> c (t s) + sequential' :: [s -> c (t (s -> s))] + transition' = fmap (fmap const) . step' . pure + step' x = foldr ((=<<) . step'') (pure x) sequential' + where step'' f y = (<*> y) <$> f (extract y) + sequential' = pure transition' + {-# MINIMAL transition' | step' | sequential' #-} +-} + --------------------------------------------------------------------------------------- -- Combine --------------------------------------------------------------------------------------- @@ -123,19 +129,6 @@ 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. --- Left associative, binds weaker than @+@ --- but stronger than @==@. -(>*<) :: a -> b -> a :* b -a >*< b = (a,b) -infixl 5 >*< - ---------------------------------------------------------------------------------------- -- Merge --------------------------------------------------------------------------------------- @@ -194,24 +187,3 @@ 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 = MR.fromList . fmap (\x -> (x, toRational $ fst x)) - --- |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 = fmap (`MR.evalRand` g) . iterate (>>= (randomProduct . step)) $ pure x - --- |Create a transition function from a transition matrix. --- --- prop> all (== length matrix) (map length matrix) --- prop> length matrix == length states -fromLists :: Eq b => [[a]] -> [b] -> b -> [(a, c -> b)] -fromLists matrix states b = case DL.elemIndex b states of - Nothing -> [] - Just n -> zip (matrix!!n) $ fmap const states diff --git a/src/Markov/Example.hs b/src/Markov/Example.hs --- a/src/Markov/Example.hs +++ b/src/Markov/Example.hs @@ -12,13 +12,13 @@ Module : Markov.Example Description : Examples of Markov chains implemented using "Markov". Maintainer : atloomis@math.arizona.edu -Stability : experimental +Stability : Experimental Several examples of Markov chains. It is probably more helpful to read the source code than the Haddock documentation. -} module Markov.Example - ( FromMatrix (..) + ( FromLists (..) , Simple (..) , Urn (..) , Extinction (..) @@ -30,8 +30,10 @@ ) where import Markov -import Generics.Deriving (Generic) +import Markov.Extra + import Data.Discrimination (Grouping) +import Generics.Deriving (Generic) --------------------------------------------------------------- -- From a matrix @@ -43,18 +45,18 @@ -- [ (0.5060975609756099,'a') -- , (0.201219512195122,'t') -- , (0.29268292682926833,'l') ] -newtype FromMatrix = FromMatrix Char +newtype FromLists = FromLists Char deriving Generic deriving newtype (Eq, Show) deriving anyclass Grouping -instance Combine FromMatrix where combine = const +instance Combine FromLists where combine = const -instance Markov ((,) (Product Double)) FromMatrix where +instance Markov ((,) (Product Double)) FromLists where transition = let mat = [ [0.4, 0.3, 0.3] , [0.2, 0.1, 0.7] , [0.9, 0.1, 0.0] ] - chars = map FromMatrix ['a','t','l'] + chars = map FromLists ['a','t','l'] in fromLists mat chars --------------------------------------------------------------- diff --git a/src/Markov/Extra.hs b/src/Markov/Extra.hs new file mode 100644 --- /dev/null +++ b/src/Markov/Extra.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeOperators #-} +{-| +Module : Markov.Extra +Maintainer : atloomis@math.arizona.edu +Stability : Experimental +-} +module Markov.Extra + ( fromLists + , randomPath + , (:*) + , (>*<) + ) where + +import Markov +import qualified Control.Monad.Random as MR +import qualified Data.List as DL + +--------------------------------------------------------------------------------------- +-- Misc +--------------------------------------------------------------------------------------- + +-- |Randomly choose from a list by probability. +randomProduct :: (Real a, MR.MonadRandom m) => [(a, b)] -> m (a, b) +randomProduct = MR.fromList . fmap (\x -> (x, toRational $ fst x)) + +-- |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 = fmap (`MR.evalRand` g) . iterate (>>= (randomProduct . step)) $ pure x + +-- |Create a transition function from a transition matrix. +-- Inputs should obey: +-- +-- > all (== length matrix) (map length matrix) +-- > length matrix == length states +fromLists :: Eq b => [[a]] -> [b] -> b -> [(a, c -> b)] +fromLists matrix states b = case DL.elemIndex b states of + Nothing -> [] + Just n -> zip (matrix!!n) $ fmap const states + +--------------------------------------------------------------------------------------- +-- 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. +-- Left associative, binds weaker than @+@ +-- but stronger than @==@. +(>*<) :: a -> b -> a :* b +a >*< b = (a,b) +infixl 5 >*< diff --git a/test/Test.hs b/test/Test.hs --- a/test/Test.hs +++ b/test/Test.hs @@ -10,12 +10,12 @@ main = htfMain htf_thisModulesTests -- Examples in the documentation. -test_fromMatrix = +test_fromLists = assertEqual - (chain [pure (FromMatrix 't') :: (Product Double, FromMatrix)] !! 100) - [ (0.5060975609756099, FromMatrix 'a') - , (0.201219512195122, FromMatrix 't') - , (0.29268292682926833, FromMatrix 'l') ] + (chain [pure (FromLists 't') :: (Product Double, FromLists)] !! 100) + [ (0.5060975609756099, FromLists 'a') + , (0.201219512195122, FromLists 't') + , (0.29268292682926833, FromLists 'l') ] test_m0Simple = assertEqual