{-# LANGUAGE TypeFamilies #-}
module Math.HiddenMarkovModel.Private where

import qualified Math.HiddenMarkovModel.Public.Distribution as Distr
import qualified Math.HiddenMarkovModel.CSV as HMMCSV
import Math.HiddenMarkovModel.Utility (diagonal)

import qualified Numeric.LAPACK.Matrix.Array as ArrMatrix
import qualified Numeric.LAPACK.Matrix.Square as Square
import qualified Numeric.LAPACK.Matrix as Matrix
import qualified Numeric.LAPACK.Vector as Vector
import qualified Numeric.LAPACK.Format as Format
import Numeric.LAPACK.Matrix ((-*#), (##*#), (#*##), (#*|))
import Numeric.LAPACK.Vector (Vector)

import qualified Numeric.Netlib.Class as Class

import Control.DeepSeq (NFData, rnf)
import Control.Applicative ((<$>))

import Foreign.Storable (Storable)

import qualified Data.Array.Comfort.Storable as StorableArray
import qualified Data.Array.Comfort.Shape as Shape

import qualified Data.NonEmpty.Class as NonEmptyC
import qualified Data.NonEmpty as NonEmpty
import qualified Data.Semigroup as Sg
import qualified Data.List as List
import Data.Semigroup ((<>))
import Data.Traversable (Traversable, mapAccumL)
import Data.Tuple.HT (mapFst, mapSnd, swap)


{- |
A Hidden Markov model consists of a number of (hidden) states
and a set of emissions.
There is a vector for the initial probability of each state
and a matrix containing the probability for switching
from one state to another one.
The 'distribution' field points to probability distributions
that associate every state with emissions of different probability.
Famous distribution instances are discrete and Gaussian distributions.
See "Math.HiddenMarkovModel.Distribution" for details.

The transition matrix is transposed
with respect to popular HMM descriptions.
But I think this is the natural orientation, because this way
you can write \"transition matrix times probability column vector\".
-}
data T typ sh prob =
   Cons {
      T typ sh prob -> Vector sh prob
initial :: Vector sh prob,
      T typ sh prob -> Square sh prob
transition :: Matrix.Square sh prob,
      T typ sh prob -> T typ sh prob
distribution :: Distr.T typ sh prob
   }
   deriving (Int -> T typ sh prob -> ShowS
[T typ sh prob] -> ShowS
T typ sh prob -> String
(Int -> T typ sh prob -> ShowS)
-> (T typ sh prob -> String)
-> ([T typ sh prob] -> ShowS)
-> Show (T typ sh prob)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall typ sh prob.
(C sh, Storable prob, Show sh, Show prob, Show typ) =>
Int -> T typ sh prob -> ShowS
forall typ sh prob.
(C sh, Storable prob, Show sh, Show prob, Show typ) =>
[T typ sh prob] -> ShowS
forall typ sh prob.
(C sh, Storable prob, Show sh, Show prob, Show typ) =>
T typ sh prob -> String
showList :: [T typ sh prob] -> ShowS
$cshowList :: forall typ sh prob.
(C sh, Storable prob, Show sh, Show prob, Show typ) =>
[T typ sh prob] -> ShowS
show :: T typ sh prob -> String
$cshow :: forall typ sh prob.
(C sh, Storable prob, Show sh, Show prob, Show typ) =>
T typ sh prob -> String
showsPrec :: Int -> T typ sh prob -> ShowS
$cshowsPrec :: forall typ sh prob.
(C sh, Storable prob, Show sh, Show prob, Show typ) =>
Int -> T typ sh prob -> ShowS
Show)

instance
   (Distr.NFData typ, NFData sh, Shape.C sh, NFData prob, Storable prob) =>
      NFData (T typ sh prob) where
   rnf :: T typ sh prob -> ()
rnf (Cons Vector sh prob
initial_ Square sh prob
transition_ T typ sh prob
distribution_) =
      (Vector sh prob, Square sh prob, T typ sh prob) -> ()
forall a. NFData a => a -> ()
rnf (Vector sh prob
initial_, Square sh prob
transition_, T typ sh prob
distribution_)

instance
   (Distr.Format typ, Format.FormatArray sh, Class.Real prob) =>
      Format.Format (T typ sh prob) where
   format :: Config -> T typ sh prob -> out
format Config
fmt (Cons Vector sh prob
initial_ Square sh prob
transition_ T typ sh prob
distribution_) =
      Config -> (Vector sh prob, Square sh prob, T typ sh prob) -> out
forall a out. (Format a, Output out) => Config -> a -> out
Format.format Config
fmt (Vector sh prob
initial_, Square sh prob
transition_, T typ sh prob
distribution_)

mapStatesShape ::
   (Distr.EmissionProb typ, Shape.C sh0, Shape.C sh1) =>
   (sh0 -> sh1) -> T typ sh0 prob -> T typ sh1 prob
mapStatesShape :: (sh0 -> sh1) -> T typ sh0 prob -> T typ sh1 prob
mapStatesShape sh0 -> sh1
f T typ sh0 prob
hmm =
   Cons :: forall typ sh prob.
Vector sh prob -> Square sh prob -> T typ sh prob -> T typ sh prob
Cons {
      initial :: Vector sh1 prob
initial = (sh0 -> sh1) -> Array sh0 prob -> Vector sh1 prob
forall sh0 sh1 a.
(C sh0, C sh1) =>
(sh0 -> sh1) -> Array sh0 a -> Array sh1 a
StorableArray.mapShape sh0 -> sh1
f (Array sh0 prob -> Vector sh1 prob)
-> Array sh0 prob -> Vector sh1 prob
forall a b. (a -> b) -> a -> b
$ T typ sh0 prob -> Array sh0 prob
forall typ sh prob. T typ sh prob -> Vector sh prob
initial T typ sh0 prob
hmm,
      transition :: Square sh1 prob
transition = (sh0 -> sh1) -> Square sh0 prob -> Square sh1 prob
forall sh0 sh1 a. (sh0 -> sh1) -> Square sh0 a -> Square sh1 a
Square.mapSize sh0 -> sh1
f (Square sh0 prob -> Square sh1 prob)
-> Square sh0 prob -> Square sh1 prob
forall a b. (a -> b) -> a -> b
$ T typ sh0 prob -> Square sh0 prob
forall typ sh prob. T typ sh prob -> Square sh prob
transition T typ sh0 prob
hmm,
      distribution :: T typ sh1 prob
distribution = (sh0 -> sh1) -> T typ sh0 prob -> T typ sh1 prob
forall typ sh0 sh1 prob.
(EmissionProb typ, C sh0, C sh1) =>
(sh0 -> sh1) -> T typ sh0 prob -> T typ sh1 prob
Distr.mapStatesShape sh0 -> sh1
f (T typ sh0 prob -> T typ sh1 prob)
-> T typ sh0 prob -> T typ sh1 prob
forall a b. (a -> b) -> a -> b
$ T typ sh0 prob -> T typ sh0 prob
forall typ sh prob. T typ sh prob -> T typ sh prob
distribution T typ sh0 prob
hmm
   }


emission ::
   (Distr.EmissionProb typ, Shape.C sh, Eq sh, Class.Real prob) =>
   T typ sh prob -> Distr.Emission typ prob -> Vector sh prob
emission :: T typ sh prob -> Emission typ prob -> Vector sh prob
emission  =  T typ sh prob -> Emission typ prob -> Vector sh prob
forall typ sh prob.
(EmissionProb typ, C sh, Real prob) =>
T typ sh prob -> Emission typ prob -> Vector sh prob
Distr.emissionProb (T typ sh prob -> Emission typ prob -> Vector sh prob)
-> (T typ sh prob -> T typ sh prob)
-> T typ sh prob
-> Emission typ prob
-> Vector sh prob
forall b c a. (b -> c) -> (a -> b) -> a -> c
. T typ sh prob -> T typ sh prob
forall typ sh prob. T typ sh prob -> T typ sh prob
distribution


forward ::
   (Distr.EmissionProb typ, Shape.C sh, Eq sh, Class.Real prob,
    Distr.Emission typ prob ~ emission, Traversable f) =>
   T typ sh prob -> NonEmpty.T f emission -> prob
forward :: T typ sh prob -> T f emission -> prob
forward T typ sh prob
hmm = Vector sh prob -> prob
forall sh a. (C sh, Floating a) => Vector sh a -> a
Vector.sum (Vector sh prob -> prob)
-> (T f emission -> Vector sh prob) -> T f emission -> prob
forall b c a. (b -> c) -> (a -> b) -> a -> c
. T f (Vector sh prob) -> Vector sh prob
forall (f :: * -> *) a. Foldable f => T f a -> a
NonEmpty.last (T f (Vector sh prob) -> Vector sh prob)
-> (T f emission -> T f (Vector sh prob))
-> T f emission
-> Vector sh prob
forall b c a. (b -> c) -> (a -> b) -> a -> c
. T typ sh prob -> T f emission -> T f (Vector sh prob)
forall typ sh prob emission (f :: * -> *).
(EmissionProb typ, C sh, Eq sh, Real prob,
 Emission typ prob ~ emission, Traversable f) =>
T typ sh prob -> T f emission -> T f (Vector sh prob)
alpha T typ sh prob
hmm

alpha ::
   (Distr.EmissionProb typ, Shape.C sh, Eq sh, Class.Real prob,
    Distr.Emission typ prob ~ emission, Traversable f) =>
   T typ sh prob -> NonEmpty.T f emission -> NonEmpty.T f (Vector sh prob)
alpha :: T typ sh prob -> T f emission -> T f (Vector sh prob)
alpha T typ sh prob
hmm (NonEmpty.Cons emission
x f emission
xs) =
   (Vector sh prob -> emission -> Vector sh prob)
-> Vector sh prob -> f emission -> T f (Vector sh prob)
forall (f :: * -> *) b a.
Traversable f =>
(b -> a -> b) -> b -> f a -> T f b
NonEmpty.scanl
      (\Vector sh prob
alphai emission
xi -> Vector sh prob -> Vector sh prob -> Vector sh prob
forall sh a.
(C sh, Eq sh, Floating a) =>
Vector sh a -> Vector sh a -> Vector sh a
Vector.mul (T typ sh prob -> Emission typ prob -> Vector sh prob
forall typ sh prob.
(EmissionProb typ, C sh, Eq sh, Real prob) =>
T typ sh prob -> Emission typ prob -> Vector sh prob
emission T typ sh prob
hmm emission
Emission typ prob
xi) (T typ sh prob -> Square sh prob
forall typ sh prob. T typ sh prob -> Square sh prob
transition T typ sh prob
hmm Square sh prob -> Vector sh prob -> Vector sh prob
forall typ lower upper xl xu meas vert horiz height width a.
(MultiplyVector typ, Strip lower, Strip upper,
 MultiplyVectorExtra typ xl, MultiplyVectorExtra typ xu,
 Measure meas, C vert, C horiz, C height, C width, Eq width,
 Floating a) =>
Matrix typ xl xu lower upper meas vert horiz height width a
-> Vector width a -> Vector height a
#*| Vector sh prob
alphai))
      (Vector sh prob -> Vector sh prob -> Vector sh prob
forall sh a.
(C sh, Eq sh, Floating a) =>
Vector sh a -> Vector sh a -> Vector sh a
Vector.mul (T typ sh prob -> Emission typ prob -> Vector sh prob
forall typ sh prob.
(EmissionProb typ, C sh, Eq sh, Real prob) =>
T typ sh prob -> Emission typ prob -> Vector sh prob
emission T typ sh prob
hmm emission
Emission typ prob
x) (T typ sh prob -> Vector sh prob
forall typ sh prob. T typ sh prob -> Vector sh prob
initial T typ sh prob
hmm))
      f emission
xs


backward ::
   (Distr.EmissionProb typ, Shape.C sh, Eq sh, Class.Real prob,
    Distr.Emission typ prob ~ emission, Traversable f) =>
   T typ sh prob -> NonEmpty.T f emission -> prob
backward :: T typ sh prob -> T f emission -> prob
backward T typ sh prob
hmm (NonEmpty.Cons emission
x f emission
xs) =
   Vector sh prob -> Vector sh prob -> prob
forall sh a.
(C sh, Eq sh, Floating a) =>
Vector sh a -> Vector sh a -> a
Vector.dot (T typ sh prob -> Vector sh prob
forall typ sh prob. T typ sh prob -> Vector sh prob
initial T typ sh prob
hmm) (Vector sh prob -> prob) -> Vector sh prob -> prob
forall a b. (a -> b) -> a -> b
$
   Vector sh prob -> Vector sh prob -> Vector sh prob
forall sh a.
(C sh, Eq sh, Floating a) =>
Vector sh a -> Vector sh a -> Vector sh a
Vector.mul (T typ sh prob -> Emission typ prob -> Vector sh prob
forall typ sh prob.
(EmissionProb typ, C sh, Eq sh, Real prob) =>
T typ sh prob -> Emission typ prob -> Vector sh prob
emission T typ sh prob
hmm emission
Emission typ prob
x) (Vector sh prob -> Vector sh prob)
-> Vector sh prob -> Vector sh prob
forall a b. (a -> b) -> a -> b
$
   T f (Vector sh prob) -> Vector sh prob
forall (f :: * -> *) a. T f a -> a
NonEmpty.head (T f (Vector sh prob) -> Vector sh prob)
-> T f (Vector sh prob) -> Vector sh prob
forall a b. (a -> b) -> a -> b
$ T typ sh prob -> f emission -> T f (Vector sh prob)
forall typ sh prob emission (f :: * -> *).
(EmissionProb typ, C sh, Eq sh, Real prob,
 Emission typ prob ~ emission, Traversable f) =>
T typ sh prob -> f emission -> T f (Vector sh prob)
beta T typ sh prob
hmm f emission
xs

beta ::
   (Distr.EmissionProb typ, Shape.C sh, Eq sh, Class.Real prob,
    Distr.Emission typ prob ~ emission, Traversable f) =>
   T typ sh prob -> f emission -> NonEmpty.T f (Vector sh prob)
beta :: T typ sh prob -> f emission -> T f (Vector sh prob)
beta T typ sh prob
hmm =
   (emission -> Vector sh prob -> Vector sh prob)
-> Vector sh prob -> f emission -> T f (Vector sh prob)
forall (f :: * -> *) a b.
Traversable f =>
(a -> b -> b) -> b -> f a -> T f b
NonEmpty.scanr
      (\emission
xi Vector sh prob
betai -> Vector sh prob -> Vector sh prob -> Vector sh prob
forall sh a.
(C sh, Eq sh, Floating a) =>
Vector sh a -> Vector sh a -> Vector sh a
Vector.mul (T typ sh prob -> Emission typ prob -> Vector sh prob
forall typ sh prob.
(EmissionProb typ, C sh, Eq sh, Real prob) =>
T typ sh prob -> Emission typ prob -> Vector sh prob
emission T typ sh prob
hmm emission
Emission typ prob
xi) Vector sh prob
betai Vector sh prob
-> Matrix
     (Array Unpacked Arbitrary)
     ()
     ()
     Filled
     Filled
     Shape
     Small
     Small
     sh
     sh
     prob
-> Vector sh prob
forall typ lower upper xl xu meas vert horiz height width a.
(MultiplyVector typ, Strip lower, Strip upper,
 MultiplyVectorExtra typ xl, MultiplyVectorExtra typ xu,
 Measure meas, C vert, C horiz, C height, C width, Eq height,
 Floating a) =>
Vector height a
-> Matrix typ xl xu lower upper meas vert horiz height width a
-> Vector width a
-*# T typ sh prob
-> Matrix
     (Array Unpacked Arbitrary)
     ()
     ()
     Filled
     Filled
     Shape
     Small
     Small
     sh
     sh
     prob
forall typ sh prob. T typ sh prob -> Square sh prob
transition T typ sh prob
hmm)
      (sh -> Vector sh prob
forall sh a. (C sh, Floating a) => sh -> Vector sh a
Vector.one (sh -> Vector sh prob) -> sh -> Vector sh prob
forall a b. (a -> b) -> a -> b
$ Vector sh prob -> sh
forall sh a. Array sh a -> sh
StorableArray.shape (Vector sh prob -> sh) -> Vector sh prob -> sh
forall a b. (a -> b) -> a -> b
$ T typ sh prob -> Vector sh prob
forall typ sh prob. T typ sh prob -> Vector sh prob
initial T typ sh prob
hmm)


alphaBeta ::
   (Distr.EmissionProb typ, Shape.C sh, Eq sh, Class.Real prob,
    Distr.Emission typ prob ~ emission, Traversable f) =>
   T typ sh prob ->
   NonEmpty.T f emission ->
   (prob, NonEmpty.T f (Vector sh prob), NonEmpty.T f (Vector sh prob))
alphaBeta :: T typ sh prob
-> T f emission
-> (prob, T f (Vector sh prob), T f (Vector sh prob))
alphaBeta T typ sh prob
hmm T f emission
xs =
   let alphas :: T f (Vector sh prob)
alphas = T typ sh prob -> T f emission -> T f (Vector sh prob)
forall typ sh prob emission (f :: * -> *).
(EmissionProb typ, C sh, Eq sh, Real prob,
 Emission typ prob ~ emission, Traversable f) =>
T typ sh prob -> T f emission -> T f (Vector sh prob)
alpha T typ sh prob
hmm T f emission
xs
       betas :: T f (Vector sh prob)
betas = T typ sh prob -> f emission -> T f (Vector sh prob)
forall typ sh prob emission (f :: * -> *).
(EmissionProb typ, C sh, Eq sh, Real prob,
 Emission typ prob ~ emission, Traversable f) =>
T typ sh prob -> f emission -> T f (Vector sh prob)
beta T typ sh prob
hmm (f emission -> T f (Vector sh prob))
-> f emission -> T f (Vector sh prob)
forall a b. (a -> b) -> a -> b
$ T f emission -> f emission
forall (f :: * -> *) a. T f a -> f a
NonEmpty.tail T f emission
xs
       recipLikelihood :: prob
recipLikelihood = prob -> prob
forall a. Fractional a => a -> a
recip (prob -> prob) -> prob -> prob
forall a b. (a -> b) -> a -> b
$ Vector sh prob -> prob
forall sh a. (C sh, Floating a) => Vector sh a -> a
Vector.sum (Vector sh prob -> prob) -> Vector sh prob -> prob
forall a b. (a -> b) -> a -> b
$ T f (Vector sh prob) -> Vector sh prob
forall (f :: * -> *) a. Foldable f => T f a -> a
NonEmpty.last T f (Vector sh prob)
alphas
   in  (prob
recipLikelihood, T f (Vector sh prob)
alphas, T f (Vector sh prob)
betas)



biscaleTransition ::
   (Distr.EmissionProb typ, Shape.C sh, Eq sh, Class.Real prob) =>
   T typ sh prob -> Distr.Emission typ prob ->
   Vector sh prob -> Vector sh prob -> Matrix.Square sh prob
biscaleTransition :: T typ sh prob
-> Emission typ prob
-> Vector sh prob
-> Vector sh prob
-> Square sh prob
biscaleTransition T typ sh prob
hmm Emission typ prob
x Vector sh prob
alpha0 Vector sh prob
beta1 =
   (Vector sh prob -> Diagonal sh prob
forall sh a. (C sh, Real a) => Vector sh a -> Diagonal sh a
diagonal (Vector sh prob -> Vector sh prob -> Vector sh prob
forall sh a.
(C sh, Eq sh, Floating a) =>
Vector sh a -> Vector sh a -> Vector sh a
Vector.mul (T typ sh prob -> Emission typ prob -> Vector sh prob
forall typ sh prob.
(EmissionProb typ, C sh, Eq sh, Real prob) =>
T typ sh prob -> Emission typ prob -> Vector sh prob
emission T typ sh prob
hmm Emission typ prob
x) Vector sh prob
beta1)
    #*##
    T typ sh prob -> Square sh prob
forall typ sh prob. T typ sh prob -> Square sh prob
transition T typ sh prob
hmm)
   ##*#
   Vector sh prob -> Diagonal sh prob
forall sh a. (C sh, Real a) => Vector sh a -> Diagonal sh a
diagonal Vector sh prob
alpha0

xiFromAlphaBeta ::
   (Distr.EmissionProb typ, Shape.C sh, Eq sh, Class.Real prob,
    Distr.Emission typ prob ~ emission) =>
   T typ sh prob -> prob ->
   NonEmpty.T [] emission ->
   NonEmpty.T [] (Vector sh prob) ->
   NonEmpty.T [] (Vector sh prob) ->
   [Matrix.Square sh prob]
xiFromAlphaBeta :: T typ sh prob
-> prob
-> T [] emission
-> T [] (Vector sh prob)
-> T [] (Vector sh prob)
-> [Square sh prob]
xiFromAlphaBeta T typ sh prob
hmm prob
recipLikelihood T [] emission
xs T [] (Vector sh prob)
alphas T [] (Vector sh prob)
betas =
   (emission -> Vector sh prob -> Vector sh prob -> Square sh prob)
-> [emission]
-> [Vector sh prob]
-> [Vector sh prob]
-> [Square sh prob]
forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3
      (\emission
x Vector sh prob
alpha0 Vector sh prob
beta1 ->
         prob -> Square sh prob -> Square sh prob
forall typ xl xu meas vert horiz height width a lower upper.
(Scale typ, ScaleExtra typ xl, ScaleExtra typ xu, Measure meas,
 C vert, C horiz, C height, C width, Floating a) =>
a
-> Matrix typ xl xu lower upper meas vert horiz height width a
-> Matrix typ xl xu lower upper meas vert horiz height width a
Matrix.scale prob
recipLikelihood (Square sh prob -> Square sh prob)
-> Square sh prob -> Square sh prob
forall a b. (a -> b) -> a -> b
$
         T typ sh prob
-> Emission typ prob
-> Vector sh prob
-> Vector sh prob
-> Square sh prob
forall typ sh prob.
(EmissionProb typ, C sh, Eq sh, Real prob) =>
T typ sh prob
-> Emission typ prob
-> Vector sh prob
-> Vector sh prob
-> Square sh prob
biscaleTransition T typ sh prob
hmm emission
Emission typ prob
x Vector sh prob
alpha0 Vector sh prob
beta1)
      (T [] emission -> [emission]
forall (f :: * -> *) a. T f a -> f a
NonEmpty.tail T [] emission
xs)
      (T [] (Vector sh prob) -> [Vector sh prob]
forall (f :: * -> *) a. Traversable f => T f a -> f a
NonEmpty.init T [] (Vector sh prob)
alphas)
      (T [] (Vector sh prob) -> [Vector sh prob]
forall (f :: * -> *) a. T f a -> f a
NonEmpty.tail T [] (Vector sh prob)
betas)

zetaFromXi ::
   (Shape.C sh, Eq sh, Class.Real prob) =>
   [Matrix.Square sh prob] -> [Vector sh prob]
zetaFromXi :: [Square sh prob] -> [Vector sh prob]
zetaFromXi = (Square sh prob -> Vector sh prob)
-> [Square sh prob] -> [Vector sh prob]
forall a b. (a -> b) -> [a] -> [b]
map Square sh prob -> Vector sh prob
forall meas vert horiz height width a.
(Measure meas, C vert, C horiz, C height, C width, Floating a) =>
Full meas vert horiz height width a -> Vector width a
Matrix.columnSums

zetaFromAlphaBeta ::
   (Shape.C sh, Eq sh, Class.Real prob) =>
   prob ->
   NonEmpty.T [] (Vector sh prob) ->
   NonEmpty.T [] (Vector sh prob) ->
   NonEmpty.T [] (Vector sh prob)
zetaFromAlphaBeta :: prob
-> T [] (Vector sh prob)
-> T [] (Vector sh prob)
-> T [] (Vector sh prob)
zetaFromAlphaBeta prob
recipLikelihood T [] (Vector sh prob)
alphas T [] (Vector sh prob)
betas =
   (Vector sh prob -> Vector sh prob)
-> T [] (Vector sh prob) -> T [] (Vector sh prob)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (prob -> Vector sh prob -> Vector sh prob
forall sh a. (C sh, Floating a) => a -> Vector sh a -> Vector sh a
Vector.scale prob
recipLikelihood) (T [] (Vector sh prob) -> T [] (Vector sh prob))
-> T [] (Vector sh prob) -> T [] (Vector sh prob)
forall a b. (a -> b) -> a -> b
$
   (Vector sh prob -> Vector sh prob -> Vector sh prob)
-> T [] (Vector sh prob)
-> T [] (Vector sh prob)
-> T [] (Vector sh prob)
forall (f :: * -> *) a b c.
Zip f =>
(a -> b -> c) -> f a -> f b -> f c
NonEmptyC.zipWith Vector sh prob -> Vector sh prob -> Vector sh prob
forall sh a.
(C sh, Eq sh, Floating a) =>
Vector sh a -> Vector sh a -> Vector sh a
Vector.mul T [] (Vector sh prob)
alphas T [] (Vector sh prob)
betas


{- |
In constrast to Math.HiddenMarkovModel.reveal
this does not normalize the vector.
This is slightly simpler but for long sequences
the product of probabilities might be smaller
than the smallest representable number.
-}
reveal ::
   (Distr.EmissionProb typ, Shape.InvIndexed sh, Eq sh, Shape.Index sh ~ state,
    Distr.Emission typ prob ~ emission, Class.Real prob, Traversable f) =>
   T typ sh prob -> NonEmpty.T f emission -> NonEmpty.T f state
reveal :: T typ sh prob -> T f emission -> T f state
reveal = (Vector (Deferred sh) prob -> Vector (Deferred sh) prob)
-> T typ sh prob -> T f emission -> T f state
forall typ sh state prob emission (f :: * -> *).
(EmissionProb typ, InvIndexed sh, Eq sh, Index sh ~ state,
 Emission typ prob ~ emission, Real prob, Traversable f) =>
(Vector (Deferred sh) prob -> Vector (Deferred sh) prob)
-> T typ sh prob -> T f emission -> T f state
revealGen Vector (Deferred sh) prob -> Vector (Deferred sh) prob
forall a. a -> a
id

revealGen ::
   (Distr.EmissionProb typ, Shape.InvIndexed sh, Eq sh, Shape.Index sh ~ state,
    Distr.Emission typ prob ~ emission, Class.Real prob, Traversable f) =>
   (Vector (Shape.Deferred sh) prob -> Vector (Shape.Deferred sh) prob) ->
   T typ sh prob -> NonEmpty.T f emission -> NonEmpty.T f state
revealGen :: (Vector (Deferred sh) prob -> Vector (Deferred sh) prob)
-> T typ sh prob -> T f emission -> T f state
revealGen Vector (Deferred sh) prob -> Vector (Deferred sh) prob
normalize T typ sh prob
hmm =
   (DeferredIndex sh -> state) -> T f (DeferredIndex sh) -> T f state
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (sh -> DeferredIndex sh -> state
forall sh ix.
(InvIndexed sh, Index sh ~ ix) =>
sh -> DeferredIndex sh -> ix
Shape.revealIndex (Array sh prob -> sh
forall sh a. Array sh a -> sh
StorableArray.shape (Array sh prob -> sh) -> Array sh prob -> sh
forall a b. (a -> b) -> a -> b
$ T typ sh prob -> Array sh prob
forall typ sh prob. T typ sh prob -> Vector sh prob
initial T typ sh prob
hmm)) (T f (DeferredIndex sh) -> T f state)
-> (T f emission -> T f (DeferredIndex sh))
-> T f emission
-> T f state
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
   (Vector (Deferred sh) prob -> Vector (Deferred sh) prob)
-> T typ (Deferred sh) prob
-> T f emission
-> T f (DeferredIndex sh)
forall typ sh state prob emission (f :: * -> *).
(EmissionProb typ, InvIndexed sh, Eq sh, Index sh ~ state,
 Storable state, Emission typ prob ~ emission, Real prob,
 Traversable f) =>
(Vector sh prob -> Vector sh prob)
-> T typ sh prob -> T f emission -> T f state
revealStorable Vector (Deferred sh) prob -> Vector (Deferred sh) prob
normalize ((sh -> Deferred sh) -> T typ sh prob -> T typ (Deferred sh) prob
forall typ sh0 sh1 prob.
(EmissionProb typ, C sh0, C sh1) =>
(sh0 -> sh1) -> T typ sh0 prob -> T typ sh1 prob
mapStatesShape sh -> Deferred sh
forall sh. sh -> Deferred sh
Shape.Deferred T typ sh prob
hmm)

revealStorable ::
   (Distr.EmissionProb typ, Shape.InvIndexed sh, Eq sh,
    Shape.Index sh ~ state, Storable state,
    Distr.Emission typ prob ~ emission, Class.Real prob, Traversable f) =>
   (Vector sh prob -> Vector sh prob) ->
   T typ sh prob -> NonEmpty.T f emission -> NonEmpty.T f state
revealStorable :: (Vector sh prob -> Vector sh prob)
-> T typ sh prob -> T f emission -> T f state
revealStorable Vector sh prob -> Vector sh prob
normalize T typ sh prob
hmm (NonEmpty.Cons emission
x f emission
xs) =
   (state -> f (Array sh state) -> T f state)
-> (state, f (Array sh state)) -> T f state
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((Array sh state -> state -> state)
-> state -> f (Array sh state) -> T f state
forall (f :: * -> *) a b.
Traversable f =>
(a -> b -> b) -> b -> f a -> T f b
NonEmpty.scanr Array sh state -> state -> state
forall sh a.
(Indexed sh, Storable a) =>
Array sh a -> Index sh -> a
(StorableArray.!)) ((state, f (Array sh state)) -> T f state)
-> (state, f (Array sh state)) -> T f state
forall a b. (a -> b) -> a -> b
$
   (Vector sh prob -> state)
-> (Vector sh prob, f (Array sh state))
-> (state, f (Array sh state))
forall a c b. (a -> c) -> (a, b) -> (c, b)
mapFst ((state, prob) -> state
forall a b. (a, b) -> a
fst ((state, prob) -> state)
-> (Vector sh prob -> (state, prob)) -> Vector sh prob -> state
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector sh prob -> (state, prob)
forall sh a.
(InvIndexed sh, Floating a) =>
Vector sh a -> (Index sh, a)
Vector.argAbsMaximum) ((Vector sh prob, f (Array sh state))
 -> (state, f (Array sh state)))
-> (Vector sh prob, f (Array sh state))
-> (state, f (Array sh state))
forall a b. (a -> b) -> a -> b
$
   (Vector sh prob -> emission -> (Vector sh prob, Array sh state))
-> Vector sh prob
-> f emission
-> (Vector sh prob, f (Array sh state))
forall (t :: * -> *) a b c.
Traversable t =>
(a -> b -> (a, c)) -> a -> t b -> (a, t c)
mapAccumL
      (\Vector sh prob
alphai emission
xi ->
         (Array sh state, Vector sh prob)
-> (Vector sh prob, Array sh state)
forall a b. (a, b) -> (b, a)
swap ((Array sh state, Vector sh prob)
 -> (Vector sh prob, Array sh state))
-> (Array sh state, Vector sh prob)
-> (Vector sh prob, Array sh state)
forall a b. (a -> b) -> a -> b
$ (Vector sh prob -> Vector sh prob)
-> (Array sh state, Vector sh prob)
-> (Array sh state, Vector sh prob)
forall b c a. (b -> c) -> (a, b) -> (a, c)
mapSnd (Vector sh prob -> Vector sh prob -> Vector sh prob
forall sh a.
(C sh, Eq sh, Floating a) =>
Vector sh a -> Vector sh a -> Vector sh a
Vector.mul (T typ sh prob -> Emission typ prob -> Vector sh prob
forall typ sh prob.
(EmissionProb typ, C sh, Eq sh, Real prob) =>
T typ sh prob -> Emission typ prob -> Vector sh prob
emission T typ sh prob
hmm emission
Emission typ prob
xi)) ((Array sh state, Vector sh prob)
 -> (Array sh state, Vector sh prob))
-> (Array sh state, Vector sh prob)
-> (Array sh state, Vector sh prob)
forall a b. (a -> b) -> a -> b
$
         Square sh prob
-> Vector sh prob -> (Array sh state, Vector sh prob)
forall sh ix a.
(InvIndexed sh, Eq sh, Index sh ~ ix, Storable ix, Real a) =>
Square sh a -> Vector sh a -> (Vector sh ix, Vector sh a)
matrixMaxMul (T typ sh prob -> Square sh prob
forall typ sh prob. T typ sh prob -> Square sh prob
transition T typ sh prob
hmm) (Vector sh prob -> (Array sh state, Vector sh prob))
-> Vector sh prob -> (Array sh state, Vector sh prob)
forall a b. (a -> b) -> a -> b
$ Vector sh prob -> Vector sh prob
normalize Vector sh prob
alphai)
      (Vector sh prob -> Vector sh prob -> Vector sh prob
forall sh a.
(C sh, Eq sh, Floating a) =>
Vector sh a -> Vector sh a -> Vector sh a
Vector.mul (T typ sh prob -> Emission typ prob -> Vector sh prob
forall typ sh prob.
(EmissionProb typ, C sh, Eq sh, Real prob) =>
T typ sh prob -> Emission typ prob -> Vector sh prob
emission T typ sh prob
hmm emission
Emission typ prob
x) (T typ sh prob -> Vector sh prob
forall typ sh prob. T typ sh prob -> Vector sh prob
initial T typ sh prob
hmm)) f emission
xs

matrixMaxMul ::
   (Shape.InvIndexed sh, Eq sh, Shape.Index sh ~ ix, Storable ix,
    Class.Real a) =>
   Matrix.Square sh a -> Vector sh a ->
   (Vector sh ix, Vector sh a)
matrixMaxMul :: Square sh a -> Vector sh a -> (Vector sh ix, Vector sh a)
matrixMaxMul Square sh a
m Vector sh a
v = Square sh a -> (Vector sh ix, Vector sh a)
forall meas vert horiz height width ix a.
(Measure meas, C vert, C horiz, C height, InvIndexed width,
 Index width ~ ix, Storable ix, Floating a) =>
Full meas vert horiz height width a
-> (Vector height ix, Vector height a)
Matrix.rowArgAbsMaximums (Square sh a -> (Vector sh ix, Vector sh a))
-> Square sh a -> (Vector sh ix, Vector sh a)
forall a b. (a -> b) -> a -> b
$ Vector sh a -> Square sh a -> Square sh a
forall meas vert horiz height width a.
(Measure meas, C vert, C horiz, C height, C width, Eq width,
 Floating a) =>
Vector width a
-> Full meas vert horiz height width a
-> Full meas vert horiz height width a
Matrix.scaleColumns Vector sh a
v Square sh a
m



{- |
A trained model is a temporary form of a Hidden Markov model
that we need during the training on multiple training sequences.
It allows to collect knowledge over many sequences with 'mergeTrained',
even with mixed supervised and unsupervised training.
You finish the training by converting the trained model
back to a plain modul using 'finishTraining'.

You can create a trained model in three ways:

* supervised training using an emission sequence with associated states,

* unsupervised training using an emission sequence and an existing Hidden Markov Model,

* derive it from state sequence patterns, cf. "Math.HiddenMarkovModel.Pattern".
-}
data Trained typ sh prob =
   Trained {
      Trained typ sh prob -> Vector sh prob
trainedInitial :: Vector sh prob,
      Trained typ sh prob -> Square sh prob
trainedTransition :: Matrix.Square sh prob,
      Trained typ sh prob -> Trained typ sh prob
trainedDistribution :: Distr.Trained typ sh prob
   }
   deriving (Int -> Trained typ sh prob -> ShowS
[Trained typ sh prob] -> ShowS
Trained typ sh prob -> String
(Int -> Trained typ sh prob -> ShowS)
-> (Trained typ sh prob -> String)
-> ([Trained typ sh prob] -> ShowS)
-> Show (Trained typ sh prob)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall typ sh prob.
(C sh, Storable prob, Show sh, Show prob, Show typ) =>
Int -> Trained typ sh prob -> ShowS
forall typ sh prob.
(C sh, Storable prob, Show sh, Show prob, Show typ) =>
[Trained typ sh prob] -> ShowS
forall typ sh prob.
(C sh, Storable prob, Show sh, Show prob, Show typ) =>
Trained typ sh prob -> String
showList :: [Trained typ sh prob] -> ShowS
$cshowList :: forall typ sh prob.
(C sh, Storable prob, Show sh, Show prob, Show typ) =>
[Trained typ sh prob] -> ShowS
show :: Trained typ sh prob -> String
$cshow :: forall typ sh prob.
(C sh, Storable prob, Show sh, Show prob, Show typ) =>
Trained typ sh prob -> String
showsPrec :: Int -> Trained typ sh prob -> ShowS
$cshowsPrec :: forall typ sh prob.
(C sh, Storable prob, Show sh, Show prob, Show typ) =>
Int -> Trained typ sh prob -> ShowS
Show)

instance
   (Distr.NFData typ, NFData sh, Shape.C sh, NFData prob, Storable prob) =>
      NFData (Trained typ sh prob) where
   rnf :: Trained typ sh prob -> ()
rnf Trained typ sh prob
hmm =
      (Vector sh prob, Square sh prob, Trained typ sh prob) -> ()
forall a. NFData a => a -> ()
rnf (Trained typ sh prob -> Vector sh prob
forall typ sh prob. Trained typ sh prob -> Vector sh prob
trainedInitial Trained typ sh prob
hmm, Trained typ sh prob -> Square sh prob
forall typ sh prob. Trained typ sh prob -> Square sh prob
trainedTransition Trained typ sh prob
hmm, Trained typ sh prob -> Trained typ sh prob
forall typ sh prob. Trained typ sh prob -> Trained typ sh prob
trainedDistribution Trained typ sh prob
hmm)


sumTransitions ::
   (Shape.C sh, Eq sh, Class.Real e) =>
   T typ sh e -> [Matrix.Square sh e] -> Matrix.Square sh e
sumTransitions :: T typ sh e -> [Square sh e] -> Square sh e
sumTransitions T typ sh e
hmm =
   (Square sh e -> Square sh e -> Square sh e)
-> Square sh e -> [Square sh e] -> Square sh e
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' Square sh e -> Square sh e -> Square sh e
forall typ meas vert horiz xl xu height width a lower upper.
(Additive typ, Measure meas, C vert, C horiz, AdditiveExtra typ xl,
 AdditiveExtra typ xu, C height, Eq height, C width, Eq width,
 Floating a) =>
Matrix typ xl xu lower upper meas vert horiz height width a
-> Matrix typ xl xu lower upper meas vert horiz height width a
-> Matrix typ xl xu lower upper meas vert horiz height width a
Matrix.add (Square sh e -> [Square sh e] -> Square sh e)
-> Square sh e -> [Square sh e] -> Square sh e
forall a b. (a -> b) -> a -> b
$
   Omni Unpacked Arbitrary Filled Filled Shape Small Small sh sh
-> Square sh e
forall property meas vert horiz height width a pack lower upper.
(Homogeneous property, Measure meas, C vert, C horiz, C height,
 C width, Floating a) =>
Omni pack property lower upper meas vert horiz height width
-> ArrayMatrix
     pack property lower upper meas vert horiz height width a
Matrix.zero (Omni Unpacked Arbitrary Filled Filled Shape Small Small sh sh
 -> Square sh e)
-> Omni Unpacked Arbitrary Filled Filled Shape Small Small sh sh
-> Square sh e
forall a b. (a -> b) -> a -> b
$ Square sh e
-> Omni Unpacked Arbitrary Filled Filled Shape Small Small sh sh
forall pack property lower upper meas vert horiz height width a.
ArrayMatrix
  pack property lower upper meas vert horiz height width a
-> Omni pack property lower upper meas vert horiz height width
ArrMatrix.shape (Square sh e
 -> Omni Unpacked Arbitrary Filled Filled Shape Small Small sh sh)
-> Square sh e
-> Omni Unpacked Arbitrary Filled Filled Shape Small Small sh sh
forall a b. (a -> b) -> a -> b
$ T typ sh e -> Square sh e
forall typ sh prob. T typ sh prob -> Square sh prob
transition T typ sh e
hmm

{- |
Baum-Welch algorithm
-}
trainUnsupervised ::
   (Distr.Estimate typ, Shape.C sh, Eq sh, Class.Real prob,
    Distr.Emission typ prob ~ emission) =>
   T typ sh prob -> NonEmpty.T [] emission -> Trained typ sh prob
trainUnsupervised :: T typ sh prob -> T [] emission -> Trained typ sh prob
trainUnsupervised T typ sh prob
hmm T [] emission
xs =
   let (prob
recipLikelihood, T [] (Vector sh prob)
alphas, T [] (Vector sh prob)
betas) = T typ sh prob
-> T [] emission
-> (prob, T [] (Vector sh prob), T [] (Vector sh prob))
forall typ sh prob emission (f :: * -> *).
(EmissionProb typ, C sh, Eq sh, Real prob,
 Emission typ prob ~ emission, Traversable f) =>
T typ sh prob
-> T f emission
-> (prob, T f (Vector sh prob), T f (Vector sh prob))
alphaBeta T typ sh prob
hmm T [] emission
xs
       zetas :: T [] (Vector sh prob)
zetas = prob
-> T [] (Vector sh prob)
-> T [] (Vector sh prob)
-> T [] (Vector sh prob)
forall sh prob.
(C sh, Eq sh, Real prob) =>
prob
-> T [] (Vector sh prob)
-> T [] (Vector sh prob)
-> T [] (Vector sh prob)
zetaFromAlphaBeta prob
recipLikelihood T [] (Vector sh prob)
alphas T [] (Vector sh prob)
betas
       zeta0 :: Vector sh prob
zeta0 = T [] (Vector sh prob) -> Vector sh prob
forall (f :: * -> *) a. T f a -> a
NonEmpty.head T [] (Vector sh prob)
zetas

   in  Trained :: forall typ sh prob.
Vector sh prob
-> Square sh prob -> Trained typ sh prob -> Trained typ sh prob
Trained {
          trainedInitial :: Vector sh prob
trainedInitial = Vector sh prob
zeta0,
          trainedTransition :: Square sh prob
trainedTransition =
             T typ sh prob -> [Square sh prob] -> Square sh prob
forall sh e typ.
(C sh, Eq sh, Real e) =>
T typ sh e -> [Square sh e] -> Square sh e
sumTransitions T typ sh prob
hmm ([Square sh prob] -> Square sh prob)
-> [Square sh prob] -> Square sh prob
forall a b. (a -> b) -> a -> b
$
             T typ sh prob
-> prob
-> T [] emission
-> T [] (Vector sh prob)
-> T [] (Vector sh prob)
-> [Square sh prob]
forall typ sh prob emission.
(EmissionProb typ, C sh, Eq sh, Real prob,
 Emission typ prob ~ emission) =>
T typ sh prob
-> prob
-> T [] emission
-> T [] (Vector sh prob)
-> T [] (Vector sh prob)
-> [Square sh prob]
xiFromAlphaBeta T typ sh prob
hmm prob
recipLikelihood T [] emission
xs T [] (Vector sh prob)
alphas T [] (Vector sh prob)
betas,
          trainedDistribution :: Trained typ sh prob
trainedDistribution =
             T [] (Emission typ prob, Vector sh prob) -> Trained typ sh prob
forall typ sh prob.
(Estimate typ, C sh, Eq sh, Real prob) =>
T [] (Emission typ prob, Vector sh prob) -> Trained typ sh prob
Distr.accumulateEmissionVectors (T [] (Emission typ prob, Vector sh prob) -> Trained typ sh prob)
-> T [] (Emission typ prob, Vector sh prob) -> Trained typ sh prob
forall a b. (a -> b) -> a -> b
$ T [] emission
-> T [] (Vector sh prob) -> T [] (emission, Vector sh prob)
forall (f :: * -> *) a b. Zip f => f a -> f b -> f (a, b)
NonEmptyC.zip T [] emission
xs T [] (Vector sh prob)
zetas
       }


mergeTrained ::
   (Distr.Estimate typ, Shape.C sh, Eq sh, Class.Real prob) =>
   Trained typ sh prob -> Trained typ sh prob -> Trained typ sh prob
mergeTrained :: Trained typ sh prob -> Trained typ sh prob -> Trained typ sh prob
mergeTrained Trained typ sh prob
hmm0 Trained typ sh prob
hmm1 =
   Trained :: forall typ sh prob.
Vector sh prob
-> Square sh prob -> Trained typ sh prob -> Trained typ sh prob
Trained {
      trainedInitial :: Vector sh prob
trainedInitial = Vector sh prob -> Vector sh prob -> Vector sh prob
forall sh a.
(C sh, Eq sh, Floating a) =>
Vector sh a -> Vector sh a -> Vector sh a
Vector.add (Trained typ sh prob -> Vector sh prob
forall typ sh prob. Trained typ sh prob -> Vector sh prob
trainedInitial Trained typ sh prob
hmm0) (Trained typ sh prob -> Vector sh prob
forall typ sh prob. Trained typ sh prob -> Vector sh prob
trainedInitial Trained typ sh prob
hmm1),
      trainedTransition :: Square sh prob
trainedTransition =
         Square sh prob -> Square sh prob -> Square sh prob
forall typ meas vert horiz xl xu height width a lower upper.
(Additive typ, Measure meas, C vert, C horiz, AdditiveExtra typ xl,
 AdditiveExtra typ xu, C height, Eq height, C width, Eq width,
 Floating a) =>
Matrix typ xl xu lower upper meas vert horiz height width a
-> Matrix typ xl xu lower upper meas vert horiz height width a
-> Matrix typ xl xu lower upper meas vert horiz height width a
Matrix.add (Trained typ sh prob -> Square sh prob
forall typ sh prob. Trained typ sh prob -> Square sh prob
trainedTransition Trained typ sh prob
hmm0) (Trained typ sh prob -> Square sh prob
forall typ sh prob. Trained typ sh prob -> Square sh prob
trainedTransition Trained typ sh prob
hmm1),
      trainedDistribution :: Trained typ sh prob
trainedDistribution =
         Trained typ sh prob -> Trained typ sh prob
forall typ sh prob. Trained typ sh prob -> Trained typ sh prob
trainedDistribution Trained typ sh prob
hmm0 Trained typ sh prob -> Trained typ sh prob -> Trained typ sh prob
forall a. Semigroup a => a -> a -> a
<> Trained typ sh prob -> Trained typ sh prob
forall typ sh prob. Trained typ sh prob -> Trained typ sh prob
trainedDistribution Trained typ sh prob
hmm1
   }

instance
   (Distr.Estimate typ, Shape.C sh, Eq sh, Class.Real prob) =>
      Sg.Semigroup (Trained typ sh prob) where
   <> :: Trained typ sh prob -> Trained typ sh prob -> Trained typ sh prob
(<>) = Trained typ sh prob -> Trained typ sh prob -> Trained typ sh prob
forall typ sh prob.
(Estimate typ, C sh, Eq sh, Real prob) =>
Trained typ sh prob -> Trained typ sh prob -> Trained typ sh prob
mergeTrained


toCells ::
   (Distr.ToCSV typ, Shape.Indexed sh, Class.Real prob, Show prob) =>
   T typ sh prob -> [[String]]
toCells :: T typ sh prob -> [[String]]
toCells T typ sh prob
hmm =
   (Vector sh prob -> [String]
forall sh a. (C sh, Show a, Real a) => Vector sh a -> [String]
HMMCSV.cellsFromVector (Vector sh prob -> [String]) -> Vector sh prob -> [String]
forall a b. (a -> b) -> a -> b
$ T typ sh prob -> Vector sh prob
forall typ sh prob. T typ sh prob -> Vector sh prob
initial T typ sh prob
hmm) [String] -> [[String]] -> [[String]]
forall a. a -> [a] -> [a]
:
   (Square sh prob -> [[String]]
forall sh a.
(Indexed sh, Show a, Real a) =>
Square sh a -> [[String]]
HMMCSV.cellsFromSquare (Square sh prob -> [[String]]) -> Square sh prob -> [[String]]
forall a b. (a -> b) -> a -> b
$ T typ sh prob -> Square sh prob
forall typ sh prob. T typ sh prob -> Square sh prob
transition T typ sh prob
hmm) [[String]] -> [[String]] -> [[String]]
forall a. [a] -> [a] -> [a]
++
   [] [String] -> [[String]] -> [[String]]
forall a. a -> [a] -> [a]
:
   (T typ sh prob -> [[String]]
forall typ sh prob.
(ToCSV typ, C sh, Real prob, Show prob) =>
T typ sh prob -> [[String]]
Distr.toCells (T typ sh prob -> [[String]]) -> T typ sh prob -> [[String]]
forall a b. (a -> b) -> a -> b
$ T typ sh prob -> T typ sh prob
forall typ sh prob. T typ sh prob -> T typ sh prob
distribution T typ sh prob
hmm)

parseCSV ::
   (Distr.FromCSV typ, Shape.C stateSh, Eq stateSh,
    Class.Real prob, Read prob) =>
   (Int -> stateSh) -> HMMCSV.CSVParser (T typ stateSh prob)
parseCSV :: (Int -> stateSh) -> CSVParser (T typ stateSh prob)
parseCSV Int -> stateSh
makeShape = do
   Array stateSh prob
v <-
      (ZeroBased Int -> stateSh)
-> Array (ZeroBased Int) prob -> Array stateSh prob
forall sh0 sh1 a.
(C sh0, C sh1) =>
(sh0 -> sh1) -> Array sh0 a -> Array sh1 a
StorableArray.mapShape (Int -> stateSh
makeShape (Int -> stateSh)
-> (ZeroBased Int -> Int) -> ZeroBased Int -> stateSh
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ZeroBased Int -> Int
forall n. ZeroBased n -> n
Shape.zeroBasedSize) (Array (ZeroBased Int) prob -> Array stateSh prob)
-> StateT
     CSVResult (Exceptional String) (Array (ZeroBased Int) prob)
-> StateT CSVResult (Exceptional String) (Array stateSh prob)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
      StateT CSVResult (Exceptional String) (Array (ZeroBased Int) prob)
forall a. (Read a, Real a) => CSVParser (Vector (ZeroBased Int) a)
HMMCSV.parseNonEmptyVectorCells
   let sh :: stateSh
sh = Array stateSh prob -> stateSh
forall sh a. Array sh a -> sh
StorableArray.shape Array stateSh prob
v
   Square stateSh prob
m <- stateSh -> CSVParser (Square stateSh prob)
forall sh a.
(C sh, Read a, Real a) =>
sh -> CSVParser (Square sh a)
HMMCSV.parseSquareMatrixCells stateSh
sh
   CSVParser ()
HMMCSV.skipEmptyRow
   T typ stateSh prob
distr <- stateSh -> CSVParser (T typ stateSh prob)
forall typ sh prob.
(FromCSV typ, C sh, Eq sh, Real prob, Read prob) =>
sh -> CSVParser (T typ sh prob)
Distr.parseCells stateSh
sh
   T typ stateSh prob -> CSVParser (T typ stateSh prob)
forall (m :: * -> *) a. Monad m => a -> m a
return (T typ stateSh prob -> CSVParser (T typ stateSh prob))
-> T typ stateSh prob -> CSVParser (T typ stateSh prob)
forall a b. (a -> b) -> a -> b
$ Cons :: forall typ sh prob.
Vector sh prob -> Square sh prob -> T typ sh prob -> T typ sh prob
Cons {
      initial :: Array stateSh prob
initial = Array stateSh prob
v,
      transition :: Square stateSh prob
transition = Square stateSh prob
m,
      distribution :: T typ stateSh prob
distribution = T typ stateSh prob
distr
   }