{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE EmptyDataDecls #-}
module Math.HiddenMarkovModel.Public.Distribution (
   T(..), Trained(..), Emission,
   Show(..), NFData(..), Format(..),
   Info(..), Generate(..), EmissionProb(..),
   Estimate(..), accumulateEmissionVectors,

   Discrete, discreteFromList,
   Gaussian, gaussian, gaussianTrained,

   ToCSV(..), FromCSV(..), HMMCSV.CSVParser, CSVSymbol(..),
   ) where

import qualified Math.HiddenMarkovModel.CSV as HMMCSV
import Math.HiddenMarkovModel.Utility (randomItemProp, vectorDim)

import qualified Numeric.LAPACK.Matrix.HermitianPositiveDefinite as HermitianPD
import qualified Numeric.LAPACK.Matrix.Hermitian as Hermitian
import qualified Numeric.LAPACK.Matrix.Triangular as Triangular
import qualified Numeric.LAPACK.Matrix.Layout as Layout
import qualified Numeric.LAPACK.Matrix.Array as ArrMatrix
import qualified Numeric.LAPACK.Matrix as Matrix
import qualified Numeric.LAPACK.Vector as Vector
import qualified Numeric.LAPACK.Format as Format
import qualified Numeric.LAPACK.Output as Output
import Numeric.LAPACK.Matrix ((-*#), (-/#), (#/\), (|*-), (#!))
import Numeric.LAPACK.Vector (Vector)
import Numeric.LAPACK.Format (FormatArray)
import Numeric.LAPACK.Output (Output)

import qualified Type.Data.Bool as TBool

import qualified Numeric.Netlib.Class as Class
import Foreign.Storable (Storable)

import qualified Data.Array.Comfort.Storable as StorableArray
import qualified Data.Array.Comfort.Shape as Shape
import qualified Data.Array.Comfort.Boxed as Array
import Data.Array.Comfort.Boxed (Array, (!))
import Data.Array.Comfort.Shape ((::+)((::+)))

import qualified System.Random as Rnd

import qualified Text.CSV.Lazy.String as CSV
import Text.Read.HT (maybeRead)
import Text.Printf (printf)

import qualified Control.Monad.Exception.Synchronous as ME
import qualified Control.Monad.Trans.Class as MT
import qualified Control.Monad.Trans.State as MS
import qualified Control.DeepSeq as DeepSeq
import Control.Monad (liftM2)
import Control.Applicative (liftA2)

import qualified Data.NonEmpty.Map as NonEmptyMap
import qualified Data.NonEmpty as NonEmpty
import qualified Data.Semigroup as Sg
import qualified Data.Map as Map
import qualified Data.List.HT as ListHT
import qualified Data.List as List
import Data.Functor.Identity (Identity(Identity), runIdentity)
import Data.Tuple.HT (snd3)
import Data.Set (Set)
import Data.Maybe (listToMaybe)

import qualified Prelude as P
import Prelude2010 hiding (Show, showsPrec)



data family T typ sh prob
data family Trained typ sh prob

type family Emission typ prob


class Show typ where
   showsPrec ::
      (Shape.C sh, P.Show sh, P.Show prob, Storable prob) =>
      Int -> T typ sh prob -> ShowS
   showsPrecTrained ::
      (Shape.C sh, P.Show sh, P.Show prob, Storable prob) =>
      Int -> Trained typ sh prob -> ShowS

instance
   (Show typ, Shape.C sh, P.Show sh, P.Show prob, Storable prob) =>
      P.Show (T typ sh prob) where
   showsPrec :: Int -> T typ sh prob -> ShowS
showsPrec = Int -> T typ sh prob -> ShowS
forall typ sh prob.
(Show typ, C sh, Show sh, Show prob, Storable prob) =>
Int -> T typ sh prob -> ShowS
showsPrec

instance
   (Show typ, Shape.C sh, P.Show sh, P.Show prob, Storable prob) =>
      P.Show (Trained typ sh prob) where
   showsPrec :: Int -> Trained typ sh prob -> ShowS
showsPrec = Int -> Trained typ sh prob -> ShowS
forall typ sh prob.
(Show typ, C sh, Show sh, Show prob, Storable prob) =>
Int -> Trained typ sh prob -> ShowS
showsPrecTrained


class NFData typ where
   rnf ::
      (DeepSeq.NFData sh, DeepSeq.NFData prob, Shape.C sh) =>
      T typ sh prob -> ()
   rnfTrained ::
      (DeepSeq.NFData sh, DeepSeq.NFData prob, Shape.C sh) =>
      Trained typ sh prob -> ()

instance
   (NFData typ, DeepSeq.NFData sh, DeepSeq.NFData prob, Shape.C sh) =>
      DeepSeq.NFData (T typ sh prob) where
   rnf :: T typ sh prob -> ()
rnf = T typ sh prob -> ()
forall typ sh prob.
(NFData typ, NFData sh, NFData prob, C sh) =>
T typ sh prob -> ()
rnf

instance
   (NFData typ, DeepSeq.NFData sh, DeepSeq.NFData prob, Shape.C sh) =>
      DeepSeq.NFData (Trained typ sh prob) where
   rnf :: Trained typ sh prob -> ()
rnf = Trained typ sh prob -> ()
forall typ sh prob.
(NFData typ, NFData sh, NFData prob, C sh) =>
Trained typ sh prob -> ()
rnfTrained


class Format typ where
   format ::
      (Shape.C sh, Output out, Class.Real prob) =>
      Format.Config -> T typ sh prob -> out

instance
   (Format typ, Shape.C sh, Class.Real prob) =>
      Format.Format (T typ sh prob) where
   format :: Config -> T typ sh prob -> out
format = Config -> T typ sh prob -> out
forall typ sh out prob.
(Format typ, C sh, Output out, Real prob) =>
Config -> T typ sh prob -> out
format



class Info typ where
   statesShape :: (Shape.C sh) => T typ sh prob -> sh
   statesShapeTrained :: (Shape.C sh) => Trained typ sh prob -> sh

class Generate typ where
   generate ::
      (Shape.Indexed sh, Class.Real prob, Rnd.Random prob, Rnd.RandomGen g) =>
      T typ sh prob -> Shape.Index sh -> MS.State g (Emission typ prob)

class EmissionProb typ where
   mapStatesShape ::
      (Shape.C sh0, Shape.C sh1) =>
      (sh0 -> sh1) -> T typ sh0 prob -> T typ sh1 prob
   {-
   This function could be implemented generically in terms of emissionStateProb
   but that would require an Info constraint.
   -}
   emissionProb ::
      (Shape.C sh, Class.Real prob) =>
      T typ sh prob -> Emission typ prob -> Vector sh prob
   emissionStateProb ::
      (Shape.Indexed sh, Class.Real prob) =>
      T typ sh prob -> Emission typ prob -> Shape.Index sh -> prob
   emissionStateProb T typ sh prob
distr Emission typ prob
e Index sh
s = 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
emissionProb T typ sh prob
distr Emission typ prob
e Vector sh prob -> Index sh -> prob
forall sh a.
(Indexed sh, Storable a) =>
Array sh a -> Index sh -> a
StorableArray.! Index sh
s

class (EmissionProb typ) => Estimate typ where
   accumulateEmissions ::
      (Shape.Indexed sh, Class.Real prob, Shape.Index sh ~ state) =>
      sh -> NonEmpty.T [] (state, Emission typ prob) -> Trained typ sh prob
   trainVector ::
      (Shape.C sh, Eq sh, Class.Real prob) =>
      Emission typ prob -> Vector sh prob -> Trained typ sh prob
   combine ::
      (Shape.C sh, Eq sh, Class.Real prob) =>
      Trained typ sh prob -> Trained typ sh prob -> Trained typ sh prob
   normalize ::
      (Shape.C sh, Eq sh, Class.Real prob) =>
      Trained typ sh prob -> T typ sh prob

accumulateEmissionVectors ::
   (Estimate typ, Shape.C sh, Eq sh, Class.Real prob) =>
   NonEmpty.T [] (Emission typ prob, Vector sh prob) -> Trained typ sh prob
accumulateEmissionVectors :: T [] (Emission typ prob, Vector sh prob) -> Trained typ sh prob
accumulateEmissionVectors = (Trained typ sh prob -> Trained typ sh prob -> Trained typ sh prob)
-> ((Emission typ prob, Vector sh prob) -> Trained typ sh prob)
-> T [] (Emission typ prob, Vector sh prob)
-> Trained typ sh prob
forall (f :: * -> *) b a.
Foldable f =>
(b -> b -> b) -> (a -> b) -> T f a -> b
NonEmpty.foldl1Map 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
combine ((Emission typ prob -> Vector sh prob -> Trained typ sh prob)
-> (Emission typ prob, Vector sh prob) -> Trained typ sh prob
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Emission typ prob -> Vector sh prob -> Trained typ sh prob
forall typ sh prob.
(Estimate typ, C sh, Eq sh, Real prob) =>
Emission typ prob -> Vector sh prob -> Trained typ sh prob
trainVector)

instance
   (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
combine


data Discrete symbol

newtype instance T (Discrete symbol) sh prob =
      Discrete (Matrix.General (Set symbol) sh prob)

newtype instance Trained (Discrete symbol) sh prob =
      DiscreteTrained (NonEmptyMap.T symbol (Vector sh prob))

type instance Emission (Discrete symbol) prob = symbol


instance (P.Show symbol, Ord symbol) => Show (Discrete symbol) where
   showsPrec :: Int -> T (Discrete symbol) sh prob -> ShowS
showsPrec Int
prec (Discrete m) = Int -> General (Set symbol) sh prob -> ShowS
forall a. Show a => Int -> a -> ShowS
P.showsPrec Int
prec General (Set symbol) sh prob
m
   showsPrecTrained :: Int -> Trained (Discrete symbol) sh prob -> ShowS
showsPrecTrained Int
prec (DiscreteTrained m) = Int -> T symbol (Vector sh prob) -> ShowS
forall a. Show a => Int -> a -> ShowS
P.showsPrec Int
prec T symbol (Vector sh prob)
m

instance (DeepSeq.NFData symbol) => NFData (Discrete symbol) where
   rnf :: T (Discrete symbol) sh prob -> ()
rnf (Discrete m) = General (Set symbol) sh prob -> ()
forall a. NFData a => a -> ()
DeepSeq.rnf General (Set symbol) sh prob
m
   rnfTrained :: Trained (Discrete symbol) sh prob -> ()
rnfTrained (DiscreteTrained m) = T symbol (Vector sh prob) -> ()
forall a. NFData a => a -> ()
DeepSeq.rnf T symbol (Vector sh prob)
m

instance (P.Show symbol, Ord symbol) => Format (Discrete symbol) where
   format :: Config -> T (Discrete symbol) sh prob -> out
format Config
fmt (Discrete m) =
      [[Identity out]] -> out
forall (f :: * -> *) out.
(Foldable f, Output out) =>
[[f out]] -> out
Output.formatAligned ([[Identity out]] -> out) -> [[Identity out]] -> out
forall a b. (a -> b) -> a -> b
$
      ((symbol, Vector sh prob) -> [Identity out])
-> [(symbol, Vector sh prob)] -> [[Identity out]]
forall a b. (a -> b) -> [a] -> [b]
map (\(symbol
sym,Vector sh prob
v) ->
            (String -> Identity out) -> [String] -> [Identity out]
forall a b. (a -> b) -> [a] -> [b]
map (out -> Identity out
forall a. a -> Identity a
Identity (out -> Identity out) -> (String -> out) -> String -> Identity out
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> out
forall out. Output out => String -> out
Output.text) ([String] -> [Identity out]) -> [String] -> [Identity out]
forall a b. (a -> b) -> a -> b
$
            (symbol -> String
forall a. Show a => a -> String
show symbol
sym String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
":") String -> [String] -> [String]
forall a. a -> [a] -> [a]
:
               (prob -> String) -> [prob] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> prob -> String
forall a. Real a => String -> a -> String
printFmt (String -> prob -> String) -> String -> prob -> String
forall a b. (a -> b) -> a -> b
$ Config -> String
Format.configFormat Config
fmt) (Vector sh prob -> [prob]
forall sh a. (C sh, Storable a) => Vector sh a -> [a]
Vector.toList Vector sh prob
v)) ([(symbol, Vector sh prob)] -> [[Identity out]])
-> [(symbol, Vector sh prob)] -> [[Identity out]]
forall a b. (a -> b) -> a -> b
$
      Array (Set symbol) (Vector sh prob)
-> [(Index (Set symbol), Vector sh prob)]
forall sh a. Indexed sh => Array sh a -> [(Index sh, a)]
Array.toAssociations (Array (Set symbol) (Vector sh prob)
 -> [(Index (Set symbol), Vector sh prob)])
-> Array (Set symbol) (Vector sh prob)
-> [(Index (Set symbol), Vector sh prob)]
forall a b. (a -> b) -> a -> b
$ Full Size Big Big (Set symbol) sh prob
-> Array (Set symbol) (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
-> Array height (Vector width a)
Matrix.toRowArray Full Size Big Big (Set symbol) sh prob
m

-- cf. Data.Bifunctor.Flip
newtype Flip f b a = Flip {Flip f b a -> f a b
getFlip :: f a b}

printFmt :: (Class.Real a) => String -> a -> String
printFmt :: String -> a -> String
printFmt String
fmt =
   Flip (->) String a -> a -> String
forall (f :: * -> * -> *) b a. Flip f b a -> f a b
getFlip (Flip (->) String a -> a -> String)
-> Flip (->) String a -> a -> String
forall a b. (a -> b) -> a -> b
$ Flip (->) String Float
-> Flip (->) String Double -> Flip (->) String a
forall a (f :: * -> *). Real a => f Float -> f Double -> f a
Class.switchReal ((Float -> String) -> Flip (->) String Float
forall (f :: * -> * -> *) b a. f a b -> Flip f b a
Flip ((Float -> String) -> Flip (->) String Float)
-> (Float -> String) -> Flip (->) String Float
forall a b. (a -> b) -> a -> b
$ String -> Float -> String
forall r. PrintfType r => String -> r
printf String
fmt) ((Double -> String) -> Flip (->) String Double
forall (f :: * -> * -> *) b a. f a b -> Flip f b a
Flip ((Double -> String) -> Flip (->) String Double)
-> (Double -> String) -> Flip (->) String Double
forall a b. (a -> b) -> a -> b
$ String -> Double -> String
forall r. PrintfType r => String -> r
printf String
fmt)

instance (Ord symbol) => Info (Discrete symbol) where
   statesShape :: T (Discrete symbol) sh prob -> sh
statesShape (Discrete m) = Matrix
  (Array Unpacked Arbitrary)
  ()
  ()
  Filled
  Filled
  Size
  Big
  Big
  (Set symbol)
  sh
  prob
-> sh
forall typ xl xu meas vert horiz lower upper height width a.
(Box typ, BoxExtra typ xl, BoxExtra typ xu, Measure meas, C vert,
 C horiz) =>
Matrix typ xl xu lower upper meas vert horiz height width a
-> width
Matrix.width Matrix
  (Array Unpacked Arbitrary)
  ()
  ()
  Filled
  Filled
  Size
  Big
  Big
  (Set symbol)
  sh
  prob
m
   statesShapeTrained :: Trained (Discrete symbol) sh prob -> sh
statesShapeTrained (DiscreteTrained m) = T symbol (Vector sh prob) -> sh
forall sh symbol prob. C sh => T symbol (Vector sh prob) -> sh
discreteStateShape T symbol (Vector sh prob)
m

instance (Ord symbol) => Generate (Discrete symbol) where
   generate :: T (Discrete symbol) sh prob
-> Index sh -> State g (Emission (Discrete symbol) prob)
generate (Discrete m) =
      [(symbol, prob)] -> State g symbol
forall g b a.
(RandomGen g, Random b, Num b, Ord b) =>
[(a, b)] -> State g a
randomItemProp ([(symbol, prob)] -> State g symbol)
-> (Index sh -> [(symbol, prob)]) -> Index sh -> State g symbol
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Array (Set symbol) prob -> [(symbol, prob)]
forall sh a.
(Indexed sh, Storable a) =>
Array sh a -> [(Index sh, a)]
StorableArray.toAssociations (Array (Set symbol) prob -> [(symbol, prob)])
-> (Index sh -> Array (Set symbol) prob)
-> Index sh
-> [(symbol, prob)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Full Size Big Big (Set symbol) sh prob
-> Index sh -> Array (Set symbol) prob
forall meas vert horiz height width ix a.
(Measure meas, C vert, C horiz, C height, Indexed width,
 Index width ~ ix, Floating a) =>
Full meas vert horiz height width a -> ix -> Vector height a
Matrix.takeColumn Full Size Big Big (Set symbol) sh prob
m

instance (Ord symbol) => EmissionProb (Discrete symbol) where
   mapStatesShape :: (sh0 -> sh1)
-> T (Discrete symbol) sh0 prob -> T (Discrete symbol) sh1 prob
mapStatesShape sh0 -> sh1
f (Discrete m) = General (Set symbol) sh1 prob -> T (Discrete symbol) sh1 prob
forall symbol sh prob.
General (Set symbol) sh prob -> T (Discrete symbol) sh prob
Discrete (General (Set symbol) sh1 prob -> T (Discrete symbol) sh1 prob)
-> General (Set symbol) sh1 prob -> T (Discrete symbol) sh1 prob
forall a b. (a -> b) -> a -> b
$ (sh0 -> sh1)
-> Matrix
     (Array Unpacked Arbitrary)
     ()
     ()
     Filled
     Filled
     Size
     Big
     Big
     (Set symbol)
     sh0
     prob
-> General (Set symbol) sh1 prob
forall typ vert horiz height widthA widthB extraLower extraUpper
       lower upper a.
(MapSize typ, C vert, C horiz, C height, C widthA, C widthB) =>
(widthA -> widthB)
-> Matrix
     typ
     extraLower
     extraUpper
     lower
     upper
     Size
     vert
     horiz
     height
     widthA
     a
-> Matrix
     typ
     extraLower
     extraUpper
     lower
     upper
     Size
     vert
     horiz
     height
     widthB
     a
Matrix.mapWidth sh0 -> sh1
f Matrix
  (Array Unpacked Arbitrary)
  ()
  ()
  Filled
  Filled
  Size
  Big
  Big
  (Set symbol)
  sh0
  prob
m
   emissionProb :: T (Discrete symbol) sh prob
-> Emission (Discrete symbol) prob -> Vector sh prob
emissionProb (Discrete m) = Full Size Big Big (Set symbol) sh prob -> symbol -> Vector sh prob
forall meas vert horiz height width ix a.
(Measure meas, C vert, C horiz, Indexed height, C width,
 Index height ~ ix, Floating a) =>
Full meas vert horiz height width a -> ix -> Vector width a
Matrix.takeRow Full Size Big Big (Set symbol) sh prob
m
   emissionStateProb :: T (Discrete symbol) sh prob
-> Emission (Discrete symbol) prob -> Index sh -> prob
emissionStateProb (Discrete m) Emission (Discrete symbol) prob
x Index sh
s = General (Set symbol) sh prob
m General (Set symbol) sh prob
-> (Index (Set symbol), Index sh) -> prob
forall typ meas vert horiz height width a xl xu lower upper.
(Indexed typ, Measure meas, C vert, C horiz, Indexed height,
 Indexed width, Floating a) =>
Matrix typ xl xu lower upper meas vert horiz height width a
-> (Index height, Index width) -> a
#! (Index (Set symbol)
Emission (Discrete symbol) prob
x,Index sh
s)

instance (Ord symbol) => Estimate (Discrete symbol) where
   accumulateEmissions :: sh
-> T [] (state, Emission (Discrete symbol) prob)
-> Trained (Discrete symbol) sh prob
accumulateEmissions sh
sh =
      T symbol (Vector sh prob) -> Trained (Discrete symbol) sh prob
forall symbol sh prob.
T symbol (Vector sh prob) -> Trained (Discrete symbol) sh prob
DiscreteTrained (T symbol (Vector sh prob) -> Trained (Discrete symbol) sh prob)
-> (T [] (state, symbol) -> T symbol (Vector sh prob))
-> T [] (state, symbol)
-> Trained (Discrete symbol) sh prob
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
      (Map (DeferredIndex sh) prob -> Vector sh prob)
-> T symbol (Map (DeferredIndex sh) prob)
-> T symbol (Vector sh prob)
forall k a b. Ord k => (a -> b) -> T k a -> T k b
NonEmptyMap.map
         (sh -> Array (Deferred sh) prob -> Vector sh prob
forall sh0 sh1 a.
(C sh0, C sh1) =>
sh1 -> Array sh0 a -> Array sh1 a
StorableArray.reshape sh
sh (Array (Deferred sh) prob -> Vector sh prob)
-> (Map (DeferredIndex sh) prob -> Array (Deferred sh) prob)
-> Map (DeferredIndex sh) prob
-> Vector sh prob
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
          prob
-> Deferred sh
-> [(Index (Deferred sh), prob)]
-> Array (Deferred sh) prob
forall sh a.
(Indexed sh, Storable a) =>
a -> sh -> [(Index sh, a)] -> Array sh a
StorableArray.fromAssociations prob
0 (sh -> Deferred sh
forall sh. sh -> Deferred sh
Shape.Deferred sh
sh) ([(DeferredIndex sh, prob)] -> Array (Deferred sh) prob)
-> (Map (DeferredIndex sh) prob -> [(DeferredIndex sh, prob)])
-> Map (DeferredIndex sh) prob
-> Array (Deferred sh) prob
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
          Map (DeferredIndex sh) prob -> [(DeferredIndex sh, prob)]
forall k a. Map k a -> [(k, a)]
Map.toList) (T symbol (Map (DeferredIndex sh) prob)
 -> T symbol (Vector sh prob))
-> (T [] (state, symbol) -> T symbol (Map (DeferredIndex sh) prob))
-> T [] (state, symbol)
-> T symbol (Vector sh prob)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
      (Map (DeferredIndex sh) prob
 -> Map (DeferredIndex sh) prob -> Map (DeferredIndex sh) prob)
-> T [] (symbol, Map (DeferredIndex sh) prob)
-> T symbol (Map (DeferredIndex sh) prob)
forall k a. Ord k => (a -> a -> a) -> T [] (k, a) -> T k a
NonEmptyMap.fromListWith ((prob -> prob -> prob)
-> Map (DeferredIndex sh) prob
-> Map (DeferredIndex sh) prob
-> Map (DeferredIndex sh) prob
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith prob -> prob -> prob
forall a. Num a => a -> a -> a
(+)) (T [] (symbol, Map (DeferredIndex sh) prob)
 -> T symbol (Map (DeferredIndex sh) prob))
-> (T [] (state, symbol)
    -> T [] (symbol, Map (DeferredIndex sh) prob))
-> T [] (state, symbol)
-> T symbol (Map (DeferredIndex sh) prob)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
      ((state, symbol) -> (symbol, Map (DeferredIndex sh) prob))
-> T [] (state, symbol)
-> T [] (symbol, Map (DeferredIndex sh) prob)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(state
state,symbol
sym) -> (symbol
sym, DeferredIndex sh -> prob -> Map (DeferredIndex sh) prob
forall k a. k -> a -> Map k a
Map.singleton (sh -> state -> DeferredIndex sh
forall sh ix.
(Indexed sh, Index sh ~ ix) =>
sh -> ix -> DeferredIndex sh
Shape.deferIndex sh
sh state
state) prob
1))
   trainVector :: Emission (Discrete symbol) prob
-> Vector sh prob -> Trained (Discrete symbol) sh prob
trainVector Emission (Discrete symbol) prob
sym = T symbol (Vector sh prob) -> Trained (Discrete symbol) sh prob
forall symbol sh prob.
T symbol (Vector sh prob) -> Trained (Discrete symbol) sh prob
DiscreteTrained (T symbol (Vector sh prob) -> Trained (Discrete symbol) sh prob)
-> (Vector sh prob -> T symbol (Vector sh prob))
-> Vector sh prob
-> Trained (Discrete symbol) sh prob
forall b c a. (b -> c) -> (a -> b) -> a -> c
. symbol -> Vector sh prob -> T symbol (Vector sh prob)
forall k a. k -> a -> T k a
NonEmptyMap.singleton symbol
Emission (Discrete symbol) prob
sym
   combine :: Trained (Discrete symbol) sh prob
-> Trained (Discrete symbol) sh prob
-> Trained (Discrete symbol) sh prob
combine (DiscreteTrained distr0) (DiscreteTrained distr1) =
      T symbol (Vector sh prob) -> Trained (Discrete symbol) sh prob
forall symbol sh prob.
T symbol (Vector sh prob) -> Trained (Discrete symbol) sh prob
DiscreteTrained (T symbol (Vector sh prob) -> Trained (Discrete symbol) sh prob)
-> T symbol (Vector sh prob) -> Trained (Discrete symbol) sh prob
forall a b. (a -> b) -> a -> b
$ (Vector sh prob -> Vector sh prob -> Vector sh prob)
-> T symbol (Vector sh prob)
-> T symbol (Vector sh prob)
-> T symbol (Vector sh prob)
forall k a. Ord k => (a -> a -> a) -> T k a -> T k a -> T k a
NonEmptyMap.unionWith 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 T symbol (Vector sh prob)
distr0 T symbol (Vector sh prob)
distr1
   normalize :: Trained (Discrete symbol) sh prob -> T (Discrete symbol) sh prob
normalize (DiscreteTrained distr) =
      General (Set symbol) sh prob -> T (Discrete symbol) sh prob
forall symbol sh prob.
General (Set symbol) sh prob -> T (Discrete symbol) sh prob
Discrete (General (Set symbol) sh prob -> T (Discrete symbol) sh prob)
-> General (Set symbol) sh prob -> T (Discrete symbol) sh prob
forall a b. (a -> b) -> a -> b
$ General (Set symbol) sh prob -> General (Set symbol) sh prob
forall height width a.
(C height, C width, Eq width, Real a) =>
General height width a -> General height width a
normalizeProbColumns (General (Set symbol) sh prob -> General (Set symbol) sh prob)
-> General (Set symbol) sh prob -> General (Set symbol) sh prob
forall a b. (a -> b) -> a -> b
$ T symbol (Vector sh prob) -> General (Set symbol) sh prob
forall symbol sh prob.
(Ord symbol, C sh, Eq sh, Real prob) =>
T symbol (Vector sh prob) -> General (Set symbol) sh prob
discreteFromMap T symbol (Vector sh prob)
distr

normalizeProbColumns ::
   (Shape.C height, Shape.C width, Eq width, Class.Real a) =>
   Matrix.General height width a -> Matrix.General height width a
normalizeProbColumns :: General height width a -> General height width a
normalizeProbColumns General height width a
m = General height width a
m General height width a -> Vector width a -> General height width a
forall meas vert horiz height width a.
(Measure meas, C vert, C horiz, C height, C width, Eq width,
 Floating a) =>
Full meas vert horiz height width a
-> Vector width a -> Full meas vert horiz height width a
#/\ General height width a -> Vector width a
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 General height width a
m

discreteStateShape ::
   (Shape.C sh) => NonEmptyMap.T symbol (Vector sh prob) -> sh
discreteStateShape :: T symbol (Vector sh prob) -> sh
discreteStateShape =
   Vector sh prob -> sh
forall sh a. Array sh a -> sh
StorableArray.shape (Vector sh prob -> sh)
-> (T symbol (Vector sh prob) -> Vector sh prob)
-> T symbol (Vector sh prob)
-> sh
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (symbol, Vector sh prob) -> Vector sh prob
forall a b. (a, b) -> b
snd ((symbol, Vector sh prob) -> Vector sh prob)
-> (T symbol (Vector sh prob) -> (symbol, Vector sh prob))
-> T symbol (Vector sh prob)
-> Vector sh prob
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((symbol, Vector sh prob), Map symbol (Vector sh prob))
-> (symbol, Vector sh prob)
forall a b. (a, b) -> a
fst (((symbol, Vector sh prob), Map symbol (Vector sh prob))
 -> (symbol, Vector sh prob))
-> (T symbol (Vector sh prob)
    -> ((symbol, Vector sh prob), Map symbol (Vector sh prob)))
-> T symbol (Vector sh prob)
-> (symbol, Vector sh prob)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. T symbol (Vector sh prob)
-> ((symbol, Vector sh prob), Map symbol (Vector sh prob))
forall k a. T k a -> ((k, a), Map k a)
NonEmptyMap.minViewWithKey

discreteFromMap ::
   (Ord symbol, Shape.C sh, Eq sh, Class.Real prob) =>
   NonEmptyMap.T symbol (Vector sh prob) -> Matrix.General (Set symbol) sh prob
discreteFromMap :: T symbol (Vector sh prob) -> General (Set symbol) sh prob
discreteFromMap T symbol (Vector sh prob)
m =
   sh
-> Array (Set symbol) (Vector sh prob)
-> General (Set symbol) sh prob
forall height width a.
(C height, C width, Eq width, Storable a) =>
width -> Array height (Vector width a) -> General height width a
Matrix.fromRowArray (T symbol (Vector sh prob) -> sh
forall sh symbol prob. C sh => T symbol (Vector sh prob) -> sh
discreteStateShape T symbol (Vector sh prob)
m) (Array (Set symbol) (Vector sh prob)
 -> General (Set symbol) sh prob)
-> Array (Set symbol) (Vector sh prob)
-> General (Set symbol) sh prob
forall a b. (a -> b) -> a -> b
$
   Map symbol (Vector sh prob) -> Array (Set symbol) (Vector sh prob)
forall k a. Ord k => Map k a -> Array (Set k) a
Array.fromMap (Map symbol (Vector sh prob)
 -> Array (Set symbol) (Vector sh prob))
-> Map symbol (Vector sh prob)
-> Array (Set symbol) (Vector sh prob)
forall a b. (a -> b) -> a -> b
$ T symbol (Vector sh prob) -> Map symbol (Vector sh prob)
forall k a. Ord k => T k a -> Map k a
NonEmptyMap.flatten T symbol (Vector sh prob)
m

discreteFromList ::
   (Ord symbol, Shape.C sh, Eq sh, Class.Real prob) =>
   NonEmpty.T [] (symbol, Vector sh prob) -> T (Discrete symbol) sh prob
discreteFromList :: T [] (symbol, Vector sh prob) -> T (Discrete symbol) sh prob
discreteFromList = General (Set symbol) sh prob -> T (Discrete symbol) sh prob
forall symbol sh prob.
General (Set symbol) sh prob -> T (Discrete symbol) sh prob
Discrete (General (Set symbol) sh prob -> T (Discrete symbol) sh prob)
-> (T [] (symbol, Vector sh prob) -> General (Set symbol) sh prob)
-> T [] (symbol, Vector sh prob)
-> T (Discrete symbol) sh prob
forall b c a. (b -> c) -> (a -> b) -> a -> c
. T symbol (Vector sh prob) -> General (Set symbol) sh prob
forall symbol sh prob.
(Ord symbol, C sh, Eq sh, Real prob) =>
T symbol (Vector sh prob) -> General (Set symbol) sh prob
discreteFromMap (T symbol (Vector sh prob) -> General (Set symbol) sh prob)
-> (T [] (symbol, Vector sh prob) -> T symbol (Vector sh prob))
-> T [] (symbol, Vector sh prob)
-> General (Set symbol) sh prob
forall b c a. (b -> c) -> (a -> b) -> a -> c
. T [] (symbol, Vector sh prob) -> T symbol (Vector sh prob)
forall k a. Ord k => T [] (k, a) -> T k a
NonEmptyMap.fromList



data Gaussian emiSh

newtype instance T (Gaussian emiSh) stateSh a =
   Gaussian (Array stateSh (a, Vector emiSh a, Triangular.Upper emiSh a))

newtype instance Trained (Gaussian emiSh) stateSh a =
   GaussianTrained
      (StorableArray.Array (stateSh, Layout.Hermitian (()::+emiSh)) a)

type instance Emission (Gaussian emiSh) a = Vector emiSh a


instance (Shape.C emiSh, P.Show emiSh) => Show (Gaussian emiSh) where
   showsPrec :: Int -> T (Gaussian emiSh) sh prob -> ShowS
showsPrec Int
prec (Gaussian m) = Int
-> Array sh (prob, Vector emiSh prob, Upper emiSh prob) -> ShowS
forall a. Show a => Int -> a -> ShowS
P.showsPrec Int
prec Array sh (prob, Vector emiSh prob, Upper emiSh prob)
m
   showsPrecTrained :: Int -> Trained (Gaussian emiSh) sh prob -> ShowS
showsPrecTrained Int
prec (GaussianTrained m) = Int -> Array (sh, Hermitian (() ::+ emiSh)) prob -> ShowS
forall a. Show a => Int -> a -> ShowS
P.showsPrec Int
prec Array (sh, Hermitian (() ::+ emiSh)) prob
m

instance (DeepSeq.NFData emiSh) => NFData (Gaussian emiSh) where
   rnf :: T (Gaussian emiSh) sh prob -> ()
rnf (Gaussian params) = Array sh (prob, Vector emiSh prob, Upper emiSh prob) -> ()
forall a. NFData a => a -> ()
DeepSeq.rnf Array sh (prob, Vector emiSh prob, Upper emiSh prob)
params
   rnfTrained :: Trained (Gaussian emiSh) sh prob -> ()
rnfTrained (GaussianTrained params) = Array (sh, Hermitian (() ::+ emiSh)) prob -> ()
forall a. NFData a => a -> ()
DeepSeq.rnf Array (sh, Hermitian (() ::+ emiSh)) prob
params


instance (FormatArray emiSh) => Format (Gaussian emiSh) where
   format :: Config -> T (Gaussian emiSh) sh prob -> out
format = FormatGaussian out emiSh sh prob
-> Config -> T (Gaussian emiSh) sh prob -> out
forall out emiSh stateSh a.
FormatGaussian out emiSh stateSh a
-> Config -> T (Gaussian emiSh) stateSh a -> out
runFormatGaussian (FormatGaussian out emiSh sh prob
 -> Config -> T (Gaussian emiSh) sh prob -> out)
-> FormatGaussian out emiSh sh prob
-> Config
-> T (Gaussian emiSh) sh prob
-> out
forall a b. (a -> b) -> a -> b
$ FormatGaussian out emiSh sh Float
-> FormatGaussian out emiSh sh Double
-> FormatGaussian out emiSh sh prob
forall a (f :: * -> *). Real a => f Float -> f Double -> f a
Class.switchReal FormatGaussian out emiSh sh Float
forall emiSh stateSh a out.
(FormatArray emiSh, C stateSh, Real a, Format a, Output out) =>
FormatGaussian out emiSh stateSh a
formatGaussian FormatGaussian out emiSh sh Double
forall emiSh stateSh a out.
(FormatArray emiSh, C stateSh, Real a, Format a, Output out) =>
FormatGaussian out emiSh stateSh a
formatGaussian

newtype FormatGaussian out emiSh stateSh a =
   FormatGaussian {
      FormatGaussian out emiSh stateSh a
-> Config -> T (Gaussian emiSh) stateSh a -> out
runFormatGaussian ::
         Format.Config -> T (Gaussian emiSh) stateSh a -> out
   }

formatGaussian ::
   (FormatArray emiSh, Shape.C stateSh,
    Class.Real a, Format.Format a, Output out) =>
   FormatGaussian out emiSh stateSh a
formatGaussian :: FormatGaussian out emiSh stateSh a
formatGaussian =
   (Config -> T (Gaussian emiSh) stateSh a -> out)
-> FormatGaussian out emiSh stateSh a
forall out emiSh stateSh a.
(Config -> T (Gaussian emiSh) stateSh a -> out)
-> FormatGaussian out emiSh stateSh a
FormatGaussian ((Config -> T (Gaussian emiSh) stateSh a -> out)
 -> FormatGaussian out emiSh stateSh a)
-> (Config -> T (Gaussian emiSh) stateSh a -> out)
-> FormatGaussian out emiSh stateSh a
forall a b. (a -> b) -> a -> b
$ \Config
fmt (Gaussian params) ->
      Config -> [(a, Vector emiSh a, Upper emiSh a)] -> out
forall a out. (Format a, Output out) => Config -> a -> out
Format.format Config
fmt ([(a, Vector emiSh a, Upper emiSh a)] -> out)
-> [(a, Vector emiSh a, Upper emiSh a)] -> out
forall a b. (a -> b) -> a -> b
$ Array stateSh (a, Vector emiSh a, Upper emiSh a)
-> [(a, Vector emiSh a, Upper emiSh a)]
forall sh a. C sh => Array sh a -> [a]
Array.toList Array stateSh (a, Vector emiSh a, Upper emiSh a)
params


instance Info (Gaussian emiSh) where
   statesShape :: T (Gaussian emiSh) sh prob -> sh
statesShape (Gaussian params) = Array sh (prob, Vector emiSh prob, Upper emiSh prob) -> sh
forall sh a. Array sh a -> sh
Array.shape Array sh (prob, Vector emiSh prob, Upper emiSh prob)
params
   statesShapeTrained :: Trained (Gaussian emiSh) sh prob -> sh
statesShapeTrained (GaussianTrained params) =
      (sh, Hermitian (() ::+ emiSh)) -> sh
forall a b. (a, b) -> a
fst ((sh, Hermitian (() ::+ emiSh)) -> sh)
-> (sh, Hermitian (() ::+ emiSh)) -> sh
forall a b. (a -> b) -> a -> b
$ Array (sh, Hermitian (() ::+ emiSh)) prob
-> (sh, Hermitian (() ::+ emiSh))
forall sh a. Array sh a -> sh
StorableArray.shape Array (sh, Hermitian (() ::+ emiSh)) prob
params

instance (Shape.C emiSh, Eq emiSh) => Generate (Gaussian emiSh) where
   generate :: T (Gaussian emiSh) sh prob
-> Index sh -> State g (Emission (Gaussian emiSh) prob)
generate (Gaussian allParams) Index sh
state = do
      let (prob
_c, Vector emiSh prob
center, Upper emiSh prob
covarianceChol) = Array sh (prob, Vector emiSh prob, Upper emiSh prob)
allParams Array sh (prob, Vector emiSh prob, Upper emiSh prob)
-> Index sh -> (prob, Vector emiSh prob, Upper emiSh prob)
forall sh a. Indexed sh => Array sh a -> Index sh -> a
! Index sh
state
      Word64
seed <- (g -> (Word64, g)) -> StateT g Identity Word64
forall (m :: * -> *) s a. Monad m => (s -> (a, s)) -> StateT s m a
MS.state g -> (Word64, g)
forall a g. (Random a, RandomGen g) => g -> (a, g)
Rnd.random
      Vector emiSh prob -> StateT g Identity (Vector emiSh prob)
forall (m :: * -> *) a. Monad m => a -> m a
return (Vector emiSh prob -> StateT g Identity (Vector emiSh prob))
-> Vector emiSh prob -> StateT g Identity (Vector emiSh prob)
forall a b. (a -> b) -> a -> b
$
         Vector emiSh prob -> Vector emiSh prob -> Vector emiSh prob
forall sh a.
(C sh, Eq sh, Floating a) =>
Vector sh a -> Vector sh a -> Vector sh a
Vector.add Vector emiSh prob
center (Vector emiSh prob -> Vector emiSh prob)
-> Vector emiSh prob -> Vector emiSh prob
forall a b. (a -> b) -> a -> b
$
         RandomDistribution -> emiSh -> Word64 -> Vector emiSh prob
forall sh a.
(C sh, Floating a) =>
RandomDistribution -> sh -> Word64 -> Vector sh a
Vector.random RandomDistribution
Vector.Normal (Vector emiSh prob -> emiSh
forall sh a. Array sh a -> sh
StorableArray.shape Vector emiSh prob
center) Word64
seed
            Vector emiSh prob -> Upper emiSh prob -> Vector emiSh 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
-*# Upper emiSh prob
covarianceChol

instance (Shape.C emiSh, Eq emiSh) => EmissionProb (Gaussian emiSh) where
   mapStatesShape :: (sh0 -> sh1)
-> T (Gaussian emiSh) sh0 prob -> T (Gaussian emiSh) sh1 prob
mapStatesShape sh0 -> sh1
f (Gaussian m) = Array sh1 (prob, Vector emiSh prob, Upper emiSh prob)
-> T (Gaussian emiSh) sh1 prob
forall emiSh stateSh a.
Array stateSh (a, Vector emiSh a, Upper emiSh a)
-> T (Gaussian emiSh) stateSh a
Gaussian (Array sh1 (prob, Vector emiSh prob, Upper emiSh prob)
 -> T (Gaussian emiSh) sh1 prob)
-> Array sh1 (prob, Vector emiSh prob, Upper emiSh prob)
-> T (Gaussian emiSh) sh1 prob
forall a b. (a -> b) -> a -> b
$ (sh0 -> sh1)
-> Array sh0 (prob, Vector emiSh prob, Upper emiSh prob)
-> Array sh1 (prob, Vector emiSh prob, Upper emiSh prob)
forall sh0 sh1 a.
(C sh0, C sh1) =>
(sh0 -> sh1) -> Array sh0 a -> Array sh1 a
Array.mapShape sh0 -> sh1
f Array sh0 (prob, Vector emiSh prob, Upper emiSh prob)
m
   emissionProb :: T (Gaussian emiSh) sh prob
-> Emission (Gaussian emiSh) prob -> Vector sh prob
emissionProb (Gaussian allParams) Emission (Gaussian emiSh) prob
x =
      Array sh prob -> Vector sh prob
forall sh a. (C sh, Storable a) => Array sh a -> Array sh a
StorableArray.fromBoxed (Array sh prob -> Vector sh prob)
-> Array sh prob -> Vector sh prob
forall a b. (a -> b) -> a -> b
$ ((prob, Vector emiSh prob, Upper emiSh prob) -> prob)
-> Array sh (prob, Vector emiSh prob, Upper emiSh prob)
-> Array sh prob
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Vector emiSh prob
-> (prob, Vector emiSh prob, Upper emiSh prob) -> prob
forall emiSh a.
(C emiSh, Eq emiSh, Real a) =>
Vector emiSh a -> (a, Vector emiSh a, Upper emiSh a) -> a
gaussianEmissionProb Vector emiSh prob
Emission (Gaussian emiSh) prob
x) Array sh (prob, Vector emiSh prob, Upper emiSh prob)
allParams
   emissionStateProb :: T (Gaussian emiSh) sh prob
-> Emission (Gaussian emiSh) prob -> Index sh -> prob
emissionStateProb (Gaussian allParams) Emission (Gaussian emiSh) prob
x Index sh
s =
      Vector emiSh prob
-> (prob, Vector emiSh prob, Upper emiSh prob) -> prob
forall emiSh a.
(C emiSh, Eq emiSh, Real a) =>
Vector emiSh a -> (a, Vector emiSh a, Upper emiSh a) -> a
gaussianEmissionProb Vector emiSh prob
Emission (Gaussian emiSh) prob
x ((prob, Vector emiSh prob, Upper emiSh prob) -> prob)
-> (prob, Vector emiSh prob, Upper emiSh prob) -> prob
forall a b. (a -> b) -> a -> b
$ Array sh (prob, Vector emiSh prob, Upper emiSh prob)
allParams Array sh (prob, Vector emiSh prob, Upper emiSh prob)
-> Index sh -> (prob, Vector emiSh prob, Upper emiSh prob)
forall sh a. Indexed sh => Array sh a -> Index sh -> a
! Index sh
s

gaussianEmissionProb ::
   (Shape.C emiSh, Eq emiSh, Class.Real a) =>
   Vector emiSh a -> (a, Vector emiSh a, Triangular.Upper emiSh a) -> a
gaussianEmissionProb :: Vector emiSh a -> (a, Vector emiSh a, Upper emiSh a) -> a
gaussianEmissionProb Vector emiSh a
x (a
c, Vector emiSh a
center, Upper emiSh a
covarianceChol) =
   a
c a -> a -> a
forall a. Num a => a -> a -> a
* Vector emiSh a -> a
forall sh a. (C sh, Real a) => Vector sh a -> a
expSquared (Vector emiSh a -> Vector emiSh a -> Vector emiSh a
forall sh a.
(C sh, Eq sh, Floating a) =>
Vector sh a -> Vector sh a -> Vector sh a
Vector.sub Vector emiSh a
x Vector emiSh a
center Vector emiSh a -> Upper emiSh a -> Vector emiSh a
forall typ xl xu lower upper meas height width a.
(Solve typ, ToQuadratic typ, SolveExtra typ xl, SolveExtra typ xu,
 BoxExtra typ xl, BoxExtra typ xu, Strip lower, Strip upper,
 Measure meas, C height, C width, Eq width, Floating a) =>
Vector width a
-> QuadraticMeas typ xl xu lower upper meas height width a
-> Vector height a
-/# Upper emiSh a
covarianceChol)

expSquared :: (Shape.C sh, Class.Real a) => Vector sh a -> a
expSquared :: Vector sh a -> a
expSquared =
   Norm (Array sh) a -> Vector sh a -> a
forall (f :: * -> *) a. Norm f a -> f a -> a
getNorm (Norm (Array sh) a -> Vector sh a -> a)
-> Norm (Array sh) a -> Vector sh a -> a
forall a b. (a -> b) -> a -> b
$ Norm (Array sh) Float
-> Norm (Array sh) Double -> Norm (Array sh) a
forall a (f :: * -> *). Real a => f Float -> f Double -> f a
Class.switchReal ((Array sh Float -> Float) -> Norm (Array sh) Float
forall (f :: * -> *) a. (f a -> a) -> Norm f a
Norm Array sh Float -> Float
forall sh a ar.
(C sh, Floating a, RealOf a ~ ar, Real ar) =>
Vector sh a -> ar
expSquaredAux) ((Array sh Double -> Double) -> Norm (Array sh) Double
forall (f :: * -> *) a. (f a -> a) -> Norm f a
Norm Array sh Double -> Double
forall sh a ar.
(C sh, Floating a, RealOf a ~ ar, Real ar) =>
Vector sh a -> ar
expSquaredAux)

newtype Norm f a = Norm {Norm f a -> f a -> a
getNorm :: f a -> a}

expSquaredAux ::
   (Shape.C sh, Class.Floating a, Vector.RealOf a ~ ar, Class.Real ar) =>
   Vector sh a -> ar
expSquaredAux :: Vector sh a -> ar
expSquaredAux Vector sh a
x = ar -> ar
forall a. Floating a => a -> a
exp ((-ar
1ar -> ar -> ar
forall a. Fractional a => a -> a -> a
/ar
2) ar -> ar -> ar
forall a. Num a => a -> a -> a
* Vector sh a -> RealOf a
forall sh a. (C sh, Floating a) => Vector sh a -> RealOf a
Vector.norm2Squared Vector sh a
x)


instance (Shape.C emiSh, Eq emiSh) => Estimate (Gaussian emiSh) where
   accumulateEmissions :: sh
-> T [] (state, Emission (Gaussian emiSh) prob)
-> Trained (Gaussian emiSh) sh prob
accumulateEmissions sh
sh T [] (state, Emission (Gaussian emiSh) prob)
xs =
      let emiSh :: emiSh
emiSh = Array emiSh prob -> emiSh
forall sh a. Array sh a -> sh
StorableArray.shape (Array emiSh prob -> emiSh) -> Array emiSh prob -> emiSh
forall a b. (a -> b) -> a -> b
$ (state, Array emiSh prob) -> Array emiSh prob
forall a b. (a, b) -> b
snd ((state, Array emiSh prob) -> Array emiSh prob)
-> (state, Array emiSh prob) -> Array emiSh prob
forall a b. (a -> b) -> a -> b
$ T [] (state, Array emiSh prob) -> (state, Array emiSh prob)
forall (f :: * -> *) a. T f a -> a
NonEmpty.head T [] (state, Array emiSh prob)
T [] (state, Emission (Gaussian emiSh) prob)
xs
          hermSh :: Hermitian (() ::+ emiSh)
hermSh = Order -> (() ::+ emiSh) -> Hermitian (() ::+ emiSh)
forall size. Order -> size -> Hermitian size
Layout.hermitian Order
Layout.RowMajor (()() -> emiSh -> () ::+ emiSh
forall sh0 sh1. sh0 -> sh1 -> sh0 ::+ sh1
::+emiSh
emiSh)
      in Array (sh, Hermitian (() ::+ emiSh)) prob
-> Trained (Gaussian emiSh) sh prob
forall emiSh stateSh a.
Array (stateSh, Hermitian (() ::+ emiSh)) a
-> Trained (Gaussian emiSh) stateSh a
GaussianTrained (Array (sh, Hermitian (() ::+ emiSh)) prob
 -> Trained (Gaussian emiSh) sh prob)
-> Array (sh, Hermitian (() ::+ emiSh)) prob
-> Trained (Gaussian emiSh) sh prob
forall a b. (a -> b) -> a -> b
$
         Full Size Big Big sh (Hermitian (() ::+ emiSh)) prob
-> Array (sh, Hermitian (() ::+ emiSh)) 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 -> Array (height, width) a
Matrix.toRowMajor (Full Size Big Big sh (Hermitian (() ::+ emiSh)) prob
 -> Array (sh, Hermitian (() ::+ emiSh)) prob)
-> (T [] (state, Array emiSh prob)
    -> Full Size Big Big sh (Hermitian (() ::+ emiSh)) prob)
-> T [] (state, Array emiSh prob)
-> Array (sh, Hermitian (() ::+ emiSh)) prob
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Hermitian (() ::+ emiSh)
-> Array sh (Vector (Hermitian (() ::+ emiSh)) prob)
-> Full Size Big Big sh (Hermitian (() ::+ emiSh)) prob
forall height width a.
(C height, C width, Eq width, Storable a) =>
width -> Array height (Vector width a) -> General height width a
Matrix.fromRowArray Hermitian (() ::+ emiSh)
hermSh (Array sh (Vector (Hermitian (() ::+ emiSh)) prob)
 -> Full Size Big Big sh (Hermitian (() ::+ emiSh)) prob)
-> (T [] (state, Array emiSh prob)
    -> Array sh (Vector (Hermitian (() ::+ emiSh)) prob))
-> T [] (state, Array emiSh prob)
-> Full Size Big Big sh (Hermitian (() ::+ emiSh)) prob
forall b c a. (b -> c) -> (a -> b) -> a -> c
. sh
-> Array (Deferred sh) (Vector (Hermitian (() ::+ emiSh)) prob)
-> Array sh (Vector (Hermitian (() ::+ emiSh)) prob)
forall sh0 sh1 a.
(C sh0, C sh1) =>
sh1 -> Array sh0 a -> Array sh1 a
Array.reshape sh
sh (Array (Deferred sh) (Vector (Hermitian (() ::+ emiSh)) prob)
 -> Array sh (Vector (Hermitian (() ::+ emiSh)) prob))
-> (T [] (state, Array emiSh prob)
    -> Array (Deferred sh) (Vector (Hermitian (() ::+ emiSh)) prob))
-> T [] (state, Array emiSh prob)
-> Array sh (Vector (Hermitian (() ::+ emiSh)) prob)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
         (Vector (Hermitian (() ::+ emiSh)) prob
 -> Vector (Hermitian (() ::+ emiSh)) prob
 -> Vector (Hermitian (() ::+ emiSh)) prob)
-> Array (Deferred sh) (Vector (Hermitian (() ::+ emiSh)) prob)
-> [(Index (Deferred sh), Vector (Hermitian (() ::+ emiSh)) prob)]
-> Array (Deferred sh) (Vector (Hermitian (() ::+ emiSh)) prob)
forall sh a b.
Indexed sh =>
(a -> b -> a) -> Array sh a -> [(Index sh, b)] -> Array sh a
Array.accumulate Vector (Hermitian (() ::+ emiSh)) prob
-> Vector (Hermitian (() ::+ emiSh)) prob
-> Vector (Hermitian (() ::+ emiSh)) prob
forall sh a.
(C sh, Eq sh, Floating a) =>
Vector sh a -> Vector sh a -> Vector sh a
Vector.add
            (Deferred sh
-> Vector (Hermitian (() ::+ emiSh)) prob
-> Array (Deferred sh) (Vector (Hermitian (() ::+ emiSh)) prob)
forall sh a. C sh => sh -> a -> Array sh a
Array.replicate (sh -> Deferred sh
forall sh. sh -> Deferred sh
Shape.Deferred sh
sh) (Hermitian (() ::+ emiSh) -> Vector (Hermitian (() ::+ emiSh)) prob
forall sh a. (C sh, Floating a) => sh -> Vector sh a
Vector.zero Hermitian (() ::+ emiSh)
hermSh)) ([(DeferredIndex sh, Vector (Hermitian (() ::+ emiSh)) prob)]
 -> Array (Deferred sh) (Vector (Hermitian (() ::+ emiSh)) prob))
-> (T [] (state, Array emiSh prob)
    -> [(DeferredIndex sh, Vector (Hermitian (() ::+ emiSh)) prob)])
-> T [] (state, Array emiSh prob)
-> Array (Deferred sh) (Vector (Hermitian (() ::+ emiSh)) prob)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
         ((state, Array emiSh prob)
 -> (DeferredIndex sh, Vector (Hermitian (() ::+ emiSh)) prob))
-> [(state, Array emiSh prob)]
-> [(DeferredIndex sh, Vector (Hermitian (() ::+ emiSh)) prob)]
forall a b. (a -> b) -> [a] -> [b]
map (\(state
state,Array emiSh prob
v) -> (sh -> state -> DeferredIndex sh
forall sh ix.
(Indexed sh, Index sh ~ ix) =>
sh -> ix -> DeferredIndex sh
Shape.deferIndex sh
sh state
state, Array emiSh prob -> Vector (Hermitian (() ::+ emiSh)) prob
forall emiSh a.
(C emiSh, Floating a) =>
Array emiSh a -> Array (Hermitian (() ::+ emiSh)) a
extendedHermitian Array emiSh prob
v)) ([(state, Array emiSh prob)]
 -> [(DeferredIndex sh, Vector (Hermitian (() ::+ emiSh)) prob)])
-> (T [] (state, Array emiSh prob) -> [(state, Array emiSh prob)])
-> T [] (state, Array emiSh prob)
-> [(DeferredIndex sh, Vector (Hermitian (() ::+ emiSh)) prob)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
         T [] (state, Array emiSh prob) -> [(state, Array emiSh prob)]
forall (f :: * -> *) a. Cons f => T f a -> f a
NonEmpty.flatten
            (T [] (state, Array emiSh prob)
 -> Array (sh, Hermitian (() ::+ emiSh)) prob)
-> T [] (state, Array emiSh prob)
-> Array (sh, Hermitian (() ::+ emiSh)) prob
forall a b. (a -> b) -> a -> b
$ T [] (state, Array emiSh prob)
T [] (state, Emission (Gaussian emiSh) prob)
xs
   trainVector :: Emission (Gaussian emiSh) prob
-> Vector sh prob -> Trained (Gaussian emiSh) sh prob
trainVector Emission (Gaussian emiSh) prob
xs Vector sh prob
probs =
      Array (sh, Hermitian (() ::+ emiSh)) prob
-> Trained (Gaussian emiSh) sh prob
forall emiSh stateSh a.
Array (stateSh, Hermitian (() ::+ emiSh)) a
-> Trained (Gaussian emiSh) stateSh a
GaussianTrained (Array (sh, Hermitian (() ::+ emiSh)) prob
 -> Trained (Gaussian emiSh) sh prob)
-> Array (sh, Hermitian (() ::+ emiSh)) prob
-> Trained (Gaussian emiSh) sh prob
forall a b. (a -> b) -> a -> b
$ Full Size Big Big sh (Hermitian (() ::+ emiSh)) prob
-> Array (sh, Hermitian (() ::+ emiSh)) 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 -> Array (height, width) a
Matrix.toRowMajor (Full Size Big Big sh (Hermitian (() ::+ emiSh)) prob
 -> Array (sh, Hermitian (() ::+ emiSh)) prob)
-> Full Size Big Big sh (Hermitian (() ::+ emiSh)) prob
-> Array (sh, Hermitian (() ::+ emiSh)) prob
forall a b. (a -> b) -> a -> b
$ Vector sh prob
probs Vector sh prob
-> Vector (Hermitian (() ::+ emiSh)) prob
-> Full Size Big Big sh (Hermitian (() ::+ emiSh)) prob
forall height width a.
(C height, Eq height, C width, Eq width, Floating a) =>
Vector height a -> Vector width a -> General height width a
|*- Array emiSh prob -> Vector (Hermitian (() ::+ emiSh)) prob
forall emiSh a.
(C emiSh, Floating a) =>
Array emiSh a -> Array (Hermitian (() ::+ emiSh)) a
extendedHermitian Array emiSh prob
Emission (Gaussian emiSh) prob
xs
   combine :: Trained (Gaussian emiSh) sh prob
-> Trained (Gaussian emiSh) sh prob
-> Trained (Gaussian emiSh) sh prob
combine (GaussianTrained m0) (GaussianTrained m1) =
      Array (sh, Hermitian (() ::+ emiSh)) prob
-> Trained (Gaussian emiSh) sh prob
forall emiSh stateSh a.
Array (stateSh, Hermitian (() ::+ emiSh)) a
-> Trained (Gaussian emiSh) stateSh a
GaussianTrained (Array (sh, Hermitian (() ::+ emiSh)) prob
 -> Trained (Gaussian emiSh) sh prob)
-> Array (sh, Hermitian (() ::+ emiSh)) prob
-> Trained (Gaussian emiSh) sh prob
forall a b. (a -> b) -> a -> b
$ Array (sh, Hermitian (() ::+ emiSh)) prob
-> Array (sh, Hermitian (() ::+ emiSh)) prob
-> Array (sh, Hermitian (() ::+ emiSh)) prob
forall sh a.
(C sh, Eq sh, Floating a) =>
Vector sh a -> Vector sh a -> Vector sh a
Vector.add Array (sh, Hermitian (() ::+ emiSh)) prob
m0 Array (sh, Hermitian (() ::+ emiSh)) prob
m1
   {-
     Sum_i (xi-m) * (xi-m)^T
   = Sum_i xi*xi^T + Sum_i m*m^T - Sum_i xi*m^T - Sum_i m*xi^T
   = Sum_i xi*xi^T - Sum_i m*m^T
   = Sum_i xi*xi^T - n * m*m^T
   -}
   normalize :: Trained (Gaussian emiSh) sh prob -> T (Gaussian emiSh) sh prob
normalize (GaussianTrained m) =
      let params :: (Matrix typ xl xu lower upper meas vert horiz height width a,
 General () sh a,
 Matrix
   (Array pack HermitianUnknownDefiniteness)
   ()
   ()
   Filled
   Filled
   Shape
   Small
   Small
   sh
   sh
   a)
-> (Vector sh a,
    Quadratic pack HermitianPositiveDefinite Filled Filled sh a)
params (Matrix typ xl xu lower upper meas vert horiz height width a
weight, General () sh a
centerSum, Matrix
  (Array pack HermitianUnknownDefiniteness)
  ()
  ()
  Filled
  Filled
  Shape
  Small
  Small
  sh
  sh
  a
covarianceSum) =
             let c :: a
c = a -> a
forall a. Fractional a => a -> a
recip (Matrix typ xl xu lower upper meas vert horiz height width a
weightMatrix typ xl xu lower upper meas vert horiz height width a
-> (Index height, Index width) -> a
forall typ meas vert horiz height width a xl xu lower upper.
(Indexed typ, Measure meas, C vert, C horiz, Indexed height,
 Indexed width, Floating a) =>
Matrix typ xl xu lower upper meas vert horiz height width a
-> (Index height, Index width) -> a
#!((),()))
                 center :: Vector sh a
center = a -> Vector sh a -> Vector sh a
forall sh a. (C sh, Floating a) => a -> Vector sh a -> Vector sh a
Vector.scale a
c (Vector sh a -> Vector sh a) -> Vector sh a -> Vector sh a
forall a b. (a -> b) -> a -> b
$ General () sh a -> Vector sh a
forall width a. General () width a -> Vector width a
Matrix.flattenRow General () sh a
centerSum
             in  (Vector sh a
center,
                  Matrix
  (Array pack HermitianUnknownDefiniteness)
  ()
  ()
  Filled
  Filled
  Shape
  Small
  Small
  sh
  sh
  a
-> Quadratic pack HermitianPositiveDefinite Filled Filled sh a
forall neg zero pos pack bands sh a.
(C neg, C zero, C pos) =>
AnyHermitianP pack neg zero pos bands sh a
-> Quadratic pack HermitianPositiveDefinite bands bands sh a
HermitianPD.assurePositiveDefiniteness (Matrix
   (Array pack HermitianUnknownDefiniteness)
   ()
   ()
   Filled
   Filled
   Shape
   Small
   Small
   sh
   sh
   a
 -> Quadratic pack HermitianPositiveDefinite Filled Filled sh a)
-> Matrix
     (Array pack HermitianUnknownDefiniteness)
     ()
     ()
     Filled
     Filled
     Shape
     Small
     Small
     sh
     sh
     a
-> Quadratic pack HermitianPositiveDefinite Filled Filled sh a
forall a b. (a -> b) -> a -> b
$
                  Matrix
  (Array pack HermitianUnknownDefiniteness)
  ()
  ()
  Filled
  Filled
  Shape
  Small
  Small
  sh
  sh
  a
-> Matrix
     (Array pack HermitianUnknownDefiniteness)
     ()
     ()
     Filled
     Filled
     Shape
     Small
     Small
     sh
     sh
     a
-> Matrix
     (Array pack HermitianUnknownDefiniteness)
     ()
     ()
     Filled
     Filled
     Shape
     Small
     Small
     sh
     sh
     a
forall typ meas vert horiz xl xu height width a lower upper.
(Subtractive typ, Measure meas, C vert, C horiz,
 SubtractiveExtra typ xl, SubtractiveExtra 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.sub
                     (a
-> Matrix
     (Array pack HermitianUnknownDefiniteness)
     ()
     ()
     Filled
     Filled
     Shape
     Small
     Small
     sh
     sh
     a
-> Matrix
     (Array pack HermitianUnknownDefiniteness)
     ()
     ()
     Filled
     Filled
     Shape
     Small
     Small
     sh
     sh
     a
forall typ xl xu meas vert horiz height width a lower upper.
(Homogeneous typ, HomogeneousExtra typ xl, HomogeneousExtra typ xu,
 Measure meas, C vert, C horiz, C height, C width, Real 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.scaleRealReal a
c Matrix
  (Array pack HermitianUnknownDefiniteness)
  ()
  ()
  Filled
  Filled
  Shape
  Small
  Small
  sh
  sh
  a
covarianceSum)
                     (AnyHermitianP pack False True True Filled sh a
-> Matrix
     (Array pack HermitianUnknownDefiniteness)
     ()
     ()
     Filled
     Filled
     Shape
     Small
     Small
     sh
     sh
     a
forall neg zero pos pack bands sh a.
(C neg, C zero, C pos) =>
AnyHermitianP pack neg zero pos bands sh a
-> Quadratic pack HermitianUnknownDefiniteness bands bands sh a
Hermitian.relaxIndefinite (AnyHermitianP pack False True True Filled sh a
 -> Matrix
      (Array pack HermitianUnknownDefiniteness)
      ()
      ()
      Filled
      Filled
      Shape
      Small
      Small
      sh
      sh
      a)
-> AnyHermitianP pack False True True Filled sh a
-> Matrix
     (Array pack HermitianUnknownDefiniteness)
     ()
     ()
     Filled
     Filled
     Shape
     Small
     Small
     sh
     sh
     a
forall a b. (a -> b) -> a -> b
$
                      Order
-> Vector sh a -> AnyHermitianP pack False True True Filled sh a
forall pack sh a.
(Packing pack, C sh, Floating a) =>
Order -> Vector sh a -> HermitianPosSemidefP pack sh a
Hermitian.outer Order
Layout.RowMajor Vector sh a
center))
      in Array sh (prob, Vector emiSh prob, Upper emiSh prob)
-> T (Gaussian emiSh) sh prob
forall emiSh stateSh a.
Array stateSh (a, Vector emiSh a, Upper emiSh a)
-> T (Gaussian emiSh) stateSh a
Gaussian (Array sh (prob, Vector emiSh prob, Upper emiSh prob)
 -> T (Gaussian emiSh) sh prob)
-> Array sh (prob, Vector emiSh prob, Upper emiSh prob)
-> T (Gaussian emiSh) sh prob
forall a b. (a -> b) -> a -> b
$
         (Array (Hermitian (() ::+ emiSh)) prob
 -> (prob, Vector emiSh prob, Upper emiSh prob))
-> Array sh (Array (Hermitian (() ::+ emiSh)) prob)
-> Array sh (prob, Vector emiSh prob, Upper emiSh prob)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Vector emiSh prob, HermitianPosDef emiSh prob)
-> (prob, Vector emiSh prob, Upper emiSh prob)
forall emiSh prob.
(C emiSh, Real prob) =>
(Vector emiSh prob, HermitianPosDef emiSh prob)
-> (prob, Vector emiSh prob, Upper emiSh prob)
gaussianParameters ((Vector emiSh prob, HermitianPosDef emiSh prob)
 -> (prob, Vector emiSh prob, Upper emiSh prob))
-> (Array (Hermitian (() ::+ emiSh)) prob
    -> (Vector emiSh prob, HermitianPosDef emiSh prob))
-> Array (Hermitian (() ::+ emiSh)) prob
-> (prob, Vector emiSh prob, Upper emiSh prob)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Matrix
   (Array Packed HermitianUnknownDefiniteness)
   ()
   ()
   Filled
   Filled
   Shape
   Small
   Small
   ()
   ()
   prob,
 General () emiSh prob,
 Matrix
   (Array Packed HermitianUnknownDefiniteness)
   ()
   ()
   Filled
   Filled
   Shape
   Small
   Small
   emiSh
   emiSh
   prob)
-> (Vector emiSh prob, HermitianPosDef emiSh prob)
forall a typ meas vert horiz height width pack sh xl xu lower
       upper.
(Indexed typ, Measure meas, C vert, C horiz, Indexed height,
 Indexed width, Real a, Packing pack, Eq sh, C sh,
 Index height ~ (), Index width ~ ()) =>
(Matrix typ xl xu lower upper meas vert horiz height width a,
 General () sh a,
 Matrix
   (Array pack HermitianUnknownDefiniteness)
   ()
   ()
   Filled
   Filled
   Shape
   Small
   Small
   sh
   sh
   a)
-> (Vector sh a,
    Quadratic pack HermitianPositiveDefinite Filled Filled sh a)
params ((Matrix
    (Array Packed HermitianUnknownDefiniteness)
    ()
    ()
    Filled
    Filled
    Shape
    Small
    Small
    ()
    ()
    prob,
  General () emiSh prob,
  Matrix
    (Array Packed HermitianUnknownDefiniteness)
    ()
    ()
    Filled
    Filled
    Shape
    Small
    Small
    emiSh
    emiSh
    prob)
 -> (Vector emiSh prob, HermitianPosDef emiSh prob))
-> (Array (Hermitian (() ::+ emiSh)) prob
    -> (Matrix
          (Array Packed HermitianUnknownDefiniteness)
          ()
          ()
          Filled
          Filled
          Shape
          Small
          Small
          ()
          ()
          prob,
        General () emiSh prob,
        Matrix
          (Array Packed HermitianUnknownDefiniteness)
          ()
          ()
          Filled
          Filled
          Shape
          Small
          Small
          emiSh
          emiSh
          prob))
-> Array (Hermitian (() ::+ emiSh)) prob
-> (Vector emiSh prob, HermitianPosDef emiSh prob)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
               FlexHermitianP Packed True True True (() ::+ emiSh) prob
-> (Matrix
      (Array Packed HermitianUnknownDefiniteness)
      ()
      ()
      Filled
      Filled
      Shape
      Small
      Small
      ()
      ()
      prob,
    General () emiSh prob,
    Matrix
      (Array Packed HermitianUnknownDefiniteness)
      ()
      ()
      Filled
      Filled
      Shape
      Small
      Small
      emiSh
      emiSh
      prob)
forall pack neg zero pos sh0 sh1 a.
(Packing pack, C neg, C zero, C pos, C sh0, C sh1, Floating a) =>
FlexHermitianP pack neg zero pos (sh0 ::+ sh1) a
-> (FlexHermitianP pack neg zero pos sh0 a, General sh0 sh1 a,
    FlexHermitianP pack neg zero pos sh1 a)
Hermitian.split (FlexHermitianP Packed True True True (() ::+ emiSh) prob
 -> (Matrix
       (Array Packed HermitianUnknownDefiniteness)
       ()
       ()
       Filled
       Filled
       Shape
       Small
       Small
       ()
       ()
       prob,
     General () emiSh prob,
     Matrix
       (Array Packed HermitianUnknownDefiniteness)
       ()
       ()
       Filled
       Filled
       Shape
       Small
       Small
       emiSh
       emiSh
       prob))
-> (Array (Hermitian (() ::+ emiSh)) prob
    -> FlexHermitianP Packed True True True (() ::+ emiSh) prob)
-> Array (Hermitian (() ::+ emiSh)) prob
-> (Matrix
      (Array Packed HermitianUnknownDefiniteness)
      ()
      ()
      Filled
      Filled
      Shape
      Small
      Small
      ()
      ()
      prob,
    General () emiSh prob,
    Matrix
      (Array Packed HermitianUnknownDefiniteness)
      ()
      ()
      Filled
      Filled
      Shape
      Small
      Small
      emiSh
      emiSh
      prob)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Array (Hermitian (() ::+ emiSh)) prob
-> FlexHermitianP Packed True True True (() ::+ emiSh) prob
forall pack prop lower upper meas vert horiz height width shape a.
(FromPlain pack prop lower upper meas vert horiz height width,
 Plain pack prop lower upper meas vert horiz height width ~ shape,
 Measure meas, C vert, C horiz, C height, C width, Floating a) =>
Array shape a
-> ArrayMatrix pack prop lower upper meas vert horiz height width a
ArrMatrix.fromVector) (Array sh (Array (Hermitian (() ::+ emiSh)) prob)
 -> Array sh (prob, Vector emiSh prob, Upper emiSh prob))
-> Array sh (Array (Hermitian (() ::+ emiSh)) prob)
-> Array sh (prob, Vector emiSh prob, Upper emiSh prob)
forall a b. (a -> b) -> a -> b
$
         Full Size Big Big sh (Hermitian (() ::+ emiSh)) prob
-> Array sh (Array (Hermitian (() ::+ emiSh)) 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
-> Array height (Vector width a)
Matrix.toRowArray (Full Size Big Big sh (Hermitian (() ::+ emiSh)) prob
 -> Array sh (Array (Hermitian (() ::+ emiSh)) prob))
-> Full Size Big Big sh (Hermitian (() ::+ emiSh)) prob
-> Array sh (Array (Hermitian (() ::+ emiSh)) prob)
forall a b. (a -> b) -> a -> b
$ Array (sh, Hermitian (() ::+ emiSh)) prob
-> Full Size Big Big sh (Hermitian (() ::+ emiSh)) prob
forall height width a.
(C height, C width, Floating a) =>
Array (height, width) a -> General height width a
Matrix.fromRowMajor Array (sh, Hermitian (() ::+ emiSh)) prob
m

extendedHermitian ::
   (Shape.C emiSh, Class.Floating a) =>
   StorableArray.Array emiSh a ->
   StorableArray.Array (Layout.Hermitian (()::+emiSh)) a
extendedHermitian :: Array emiSh a -> Array (Hermitian (() ::+ emiSh)) a
extendedHermitian =
   ArrayMatrix
  Packed
  HermitianPositiveSemidefinite
  Filled
  Filled
  Shape
  Small
  Small
  (() ::+ emiSh)
  (() ::+ emiSh)
  a
-> Array (Hermitian (() ::+ emiSh)) a
forall pack property lower upper meas vert horiz height width a.
ToPlain pack property lower upper meas vert horiz height width =>
ArrayMatrix
  pack property lower upper meas vert horiz height width a
-> PlainArray
     pack property lower upper meas vert horiz height width a
ArrMatrix.toVector (ArrayMatrix
   Packed
   HermitianPositiveSemidefinite
   Filled
   Filled
   Shape
   Small
   Small
   (() ::+ emiSh)
   (() ::+ emiSh)
   a
 -> Array (Hermitian (() ::+ emiSh)) a)
-> (Array emiSh a
    -> ArrayMatrix
         Packed
         HermitianPositiveSemidefinite
         Filled
         Filled
         Shape
         Small
         Small
         (() ::+ emiSh)
         (() ::+ emiSh)
         a)
-> Array emiSh a
-> Array (Hermitian (() ::+ emiSh)) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
   Order
-> Vector (() ::+ emiSh) a
-> ArrayMatrix
     Packed
     HermitianPositiveSemidefinite
     Filled
     Filled
     Shape
     Small
     Small
     (() ::+ emiSh)
     (() ::+ emiSh)
     a
forall pack sh a.
(Packing pack, C sh, Floating a) =>
Order -> Vector sh a -> HermitianPosSemidefP pack sh a
Hermitian.outer Order
Layout.RowMajor (Vector (() ::+ emiSh) a
 -> ArrayMatrix
      Packed
      HermitianPositiveSemidefinite
      Filled
      Filled
      Shape
      Small
      Small
      (() ::+ emiSh)
      (() ::+ emiSh)
      a)
-> (Array emiSh a -> Vector (() ::+ emiSh) a)
-> Array emiSh a
-> ArrayMatrix
     Packed
     HermitianPositiveSemidefinite
     Filled
     Filled
     Shape
     Small
     Small
     (() ::+ emiSh)
     (() ::+ emiSh)
     a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Array () a -> Array emiSh a -> Vector (() ::+ emiSh) a
forall shx shy a.
(C shx, C shy, Storable a) =>
Array shx a -> Array shy a -> Array (shx ::+ shy) a
Vector.append (() -> Array () a
forall sh a. (C sh, Floating a) => sh -> Vector sh a
Vector.one ())

{- |
input array must be non-empty
-}
gaussianTrained ::
   (TBool.C zero, Shape.C emiSh, Eq emiSh, Shape.C stateSh, Class.Real prob) =>
   Array stateSh
      (prob, Vector emiSh prob,
       Matrix.FlexHermitian TBool.False zero TBool.True emiSh prob) ->
   Trained (Gaussian emiSh) stateSh prob
gaussianTrained :: Array
  stateSh
  (prob, Vector emiSh prob, FlexHermitian False zero True emiSh prob)
-> Trained (Gaussian emiSh) stateSh prob
gaussianTrained =
   Array (stateSh, Hermitian (() ::+ emiSh)) prob
-> Trained (Gaussian emiSh) stateSh prob
forall emiSh stateSh a.
Array (stateSh, Hermitian (() ::+ emiSh)) a
-> Trained (Gaussian emiSh) stateSh a
GaussianTrained (Array (stateSh, Hermitian (() ::+ emiSh)) prob
 -> Trained (Gaussian emiSh) stateSh prob)
-> (Array
      stateSh
      (prob, Vector emiSh prob, FlexHermitian False zero True emiSh prob)
    -> Array (stateSh, Hermitian (() ::+ emiSh)) prob)
-> Array
     stateSh
     (prob, Vector emiSh prob, FlexHermitian False zero True emiSh prob)
-> Trained (Gaussian emiSh) stateSh prob
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Full Size Big Big stateSh (Hermitian (() ::+ emiSh)) prob
-> Array (stateSh, Hermitian (() ::+ emiSh)) 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 -> Array (height, width) a
Matrix.toRowMajor (Full Size Big Big stateSh (Hermitian (() ::+ emiSh)) prob
 -> Array (stateSh, Hermitian (() ::+ emiSh)) prob)
-> (Array
      stateSh
      (prob, Vector emiSh prob, FlexHermitian False zero True emiSh prob)
    -> Full Size Big Big stateSh (Hermitian (() ::+ emiSh)) prob)
-> Array
     stateSh
     (prob, Vector emiSh prob, FlexHermitian False zero True emiSh prob)
-> Array (stateSh, Hermitian (() ::+ emiSh)) prob
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
   String
-> Array stateSh (Array (Hermitian (() ::+ emiSh)) prob)
-> Full Size Big Big stateSh (Hermitian (() ::+ emiSh)) prob
forall width height a.
(C width, Eq width, C height, Real a) =>
String -> Array height (Array width a) -> General height width a
matrixFromRowArray String
"HMM.Distribution.gaussianTrained" (Array stateSh (Array (Hermitian (() ::+ emiSh)) prob)
 -> Full Size Big Big stateSh (Hermitian (() ::+ emiSh)) prob)
-> (Array
      stateSh
      (prob, Vector emiSh prob, FlexHermitian False zero True emiSh prob)
    -> Array stateSh (Array (Hermitian (() ::+ emiSh)) prob))
-> Array
     stateSh
     (prob, Vector emiSh prob, FlexHermitian False zero True emiSh prob)
-> Full Size Big Big stateSh (Hermitian (() ::+ emiSh)) prob
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
   ((prob, Vector emiSh prob,
  FlexHermitian False zero True emiSh prob)
 -> Array (Hermitian (() ::+ emiSh)) prob)
-> Array
     stateSh
     (prob, Vector emiSh prob, FlexHermitian False zero True emiSh prob)
-> Array stateSh (Array (Hermitian (() ::+ emiSh)) prob)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
      (\(prob
weight, Vector emiSh prob
center, FlexHermitian False zero True emiSh prob
covariance) ->
         ArrayMatrix
  Packed
  HermitianUnknownDefiniteness
  Filled
  Filled
  Shape
  Small
  Small
  (() ::+ emiSh)
  (() ::+ emiSh)
  prob
-> PlainArray
     Packed
     HermitianUnknownDefiniteness
     Filled
     Filled
     Shape
     Small
     Small
     (() ::+ emiSh)
     (() ::+ emiSh)
     prob
forall pack property lower upper meas vert horiz height width a.
ToPlain pack property lower upper meas vert horiz height width =>
ArrayMatrix
  pack property lower upper meas vert horiz height width a
-> PlainArray
     pack property lower upper meas vert horiz height width a
ArrMatrix.toVector (ArrayMatrix
   Packed
   HermitianUnknownDefiniteness
   Filled
   Filled
   Shape
   Small
   Small
   (() ::+ emiSh)
   (() ::+ emiSh)
   prob
 -> PlainArray
      Packed
      HermitianUnknownDefiniteness
      Filled
      Filled
      Shape
      Small
      Small
      (() ::+ emiSh)
      (() ::+ emiSh)
      prob)
-> ArrayMatrix
     Packed
     HermitianUnknownDefiniteness
     Filled
     Filled
     Shape
     Small
     Small
     (() ::+ emiSh)
     (() ::+ emiSh)
     prob
-> PlainArray
     Packed
     HermitianUnknownDefiniteness
     Filled
     Filled
     Shape
     Small
     Small
     (() ::+ emiSh)
     (() ::+ emiSh)
     prob
forall a b. (a -> b) -> a -> b
$
         HermitianP Packed () prob
-> General () emiSh prob
-> HermitianP Packed emiSh prob
-> ArrayMatrix
     Packed
     HermitianUnknownDefiniteness
     Filled
     Filled
     Shape
     Small
     Small
     (() ::+ emiSh)
     (() ::+ emiSh)
     prob
forall pack sh0 sh1 a.
(Packing pack, C sh0, Eq sh0, C sh1, Eq sh1, Floating a) =>
HermitianP pack sh0 a
-> General sh0 sh1 a
-> HermitianP pack sh1 a
-> HermitianP pack (sh0 ::+ sh1) a
Hermitian.stack
            (Order -> () -> [prob] -> HermitianP Packed () prob
forall sh a.
(C sh, Floating a) =>
Order -> sh -> [a] -> Hermitian sh a
Hermitian.fromList Order
Layout.RowMajor () [prob
weight])
            (Order -> Vector emiSh prob -> General () emiSh prob
forall width a. Order -> Vector width a -> General () width a
Matrix.singleRow Order
Layout.RowMajor Vector emiSh prob
center)
            (FlexHermitian False zero True emiSh prob
-> HermitianP Packed emiSh prob
forall neg zero pos pack bands sh a.
(C neg, C zero, C pos) =>
AnyHermitianP pack neg zero pos bands sh a
-> Quadratic pack HermitianUnknownDefiniteness bands bands sh a
Hermitian.relaxIndefinite FlexHermitian False zero True emiSh prob
covariance))

matrixFromRowArray ::
   (Shape.C width, Eq width, Shape.C height, Class.Real a) =>
   String ->
   Array height (StorableArray.Array width a) ->
   Matrix.General height width a
matrixFromRowArray :: String -> Array height (Array width a) -> General height width a
matrixFromRowArray String
name Array height (Array width a)
xs =
   case Array height (Array width a) -> [Array width a]
forall sh a. C sh => Array sh a -> [a]
Array.toList Array height (Array width a)
xs of
      [] -> String -> General height width a
forall a. HasCallStack => String -> a
error (String -> General height width a)
-> String -> General height width a
forall a b. (a -> b) -> a -> b
$ String
name String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": empty array"
      Array width a
x:[Array width a]
_ -> width -> Array height (Array width a) -> General height width a
forall height width a.
(C height, C width, Eq width, Storable a) =>
width -> Array height (Vector width a) -> General height width a
Matrix.fromRowArray (Array width a -> width
forall sh a. Array sh a -> sh
StorableArray.shape Array width a
x) Array height (Array width a)
xs

gaussian ::
   (Shape.C emiSh, Shape.C stateSh, Class.Real prob) =>
   Array stateSh (Vector emiSh prob, Matrix.HermitianPosDef emiSh prob) ->
   T (Gaussian emiSh) stateSh prob
gaussian :: Array stateSh (Vector emiSh prob, HermitianPosDef emiSh prob)
-> T (Gaussian emiSh) stateSh prob
gaussian = Array stateSh (prob, Vector emiSh prob, Upper emiSh prob)
-> T (Gaussian emiSh) stateSh prob
forall emiSh stateSh a.
Array stateSh (a, Vector emiSh a, Upper emiSh a)
-> T (Gaussian emiSh) stateSh a
Gaussian (Array stateSh (prob, Vector emiSh prob, Upper emiSh prob)
 -> T (Gaussian emiSh) stateSh prob)
-> (Array stateSh (Vector emiSh prob, HermitianPosDef emiSh prob)
    -> Array stateSh (prob, Vector emiSh prob, Upper emiSh prob))
-> Array stateSh (Vector emiSh prob, HermitianPosDef emiSh prob)
-> T (Gaussian emiSh) stateSh prob
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Vector emiSh prob, HermitianPosDef emiSh prob)
 -> (prob, Vector emiSh prob, Upper emiSh prob))
-> Array stateSh (Vector emiSh prob, HermitianPosDef emiSh prob)
-> Array stateSh (prob, Vector emiSh prob, Upper emiSh prob)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Vector emiSh prob, HermitianPosDef emiSh prob)
-> (prob, Vector emiSh prob, Upper emiSh prob)
forall emiSh prob.
(C emiSh, Real prob) =>
(Vector emiSh prob, HermitianPosDef emiSh prob)
-> (prob, Vector emiSh prob, Upper emiSh prob)
gaussianParameters

gaussianParameters ::
   (Shape.C emiSh, Class.Real prob) =>
   (Vector emiSh prob, Matrix.HermitianPosDef emiSh prob) ->
   (prob, Vector emiSh prob, Triangular.Upper emiSh prob)
gaussianParameters :: (Vector emiSh prob, HermitianPosDef emiSh prob)
-> (prob, Vector emiSh prob, Upper emiSh prob)
gaussianParameters (Vector emiSh prob
center, HermitianPosDef emiSh prob
covariance) =
   Vector emiSh prob
-> Upper emiSh prob -> (prob, Vector emiSh prob, Upper emiSh prob)
forall emiSh prob.
(C emiSh, Real prob) =>
Vector emiSh prob
-> Upper emiSh prob -> (prob, Vector emiSh prob, Upper emiSh prob)
gaussianFromCholesky Vector emiSh prob
center (Upper emiSh prob -> (prob, Vector emiSh prob, Upper emiSh prob))
-> Upper emiSh prob -> (prob, Vector emiSh prob, Upper emiSh prob)
forall a b. (a -> b) -> a -> b
$ HermitianPosDef emiSh prob -> Upper emiSh prob
forall pack sh a.
(Packing pack, C sh, Floating a) =>
HermitianPosDefP pack sh a -> UpperP pack sh a
HermitianPD.decompose HermitianPosDef emiSh prob
covariance

gaussianFromCholesky ::
   (Shape.C emiSh, Class.Real prob) =>
   Vector emiSh prob -> Triangular.Upper emiSh prob ->
   (prob, Vector emiSh prob, Triangular.Upper emiSh prob)
gaussianFromCholesky :: Vector emiSh prob
-> Upper emiSh prob -> (prob, Vector emiSh prob, Upper emiSh prob)
gaussianFromCholesky Vector emiSh prob
center Upper emiSh prob
covarianceChol =
   let covarianceSqrtDet :: prob
covarianceSqrtDet =
         Vector emiSh prob -> prob
forall sh a. (C sh, Floating a) => Vector sh a -> a
Vector.product (Vector emiSh prob -> prob) -> Vector emiSh prob -> prob
forall a b. (a -> b) -> a -> b
$ Upper emiSh prob -> Vector emiSh prob
forall lo up diag sh a pack.
(PowerStrip lo, PowerStrip up, TriDiag diag, C sh, Floating a) =>
TriangularP pack lo diag up sh a -> Vector sh a
Triangular.takeDiagonal Upper emiSh prob
covarianceChol
   in  (prob -> prob
forall a. Fractional a => a -> a
recip (prob
forall a. Real a => a
sqrt2pi prob -> Int -> prob
forall a b. (Num a, Integral b) => a -> b -> a
^ Vector emiSh prob -> Int
forall sh a. C sh => Vector sh a -> Int
vectorDim Vector emiSh prob
center prob -> prob -> prob
forall a. Num a => a -> a -> a
* prob
covarianceSqrtDet),
        Vector emiSh prob
center, Upper emiSh prob
covarianceChol)

sqrt2pi :: (Class.Real a) => a
sqrt2pi :: a
sqrt2pi = Identity a -> a
forall a. Identity a -> a
runIdentity (Identity a -> a) -> Identity a -> a
forall a b. (a -> b) -> a -> b
$ Identity Float -> Identity Double -> Identity a
forall a (f :: * -> *). Real a => f Float -> f Double -> f a
Class.switchReal Identity Float
forall a. Floating a => Identity a
sqrt2piAux Identity Double
forall a. Floating a => Identity a
sqrt2piAux

sqrt2piAux :: (Floating a) => Identity a
sqrt2piAux :: Identity a
sqrt2piAux = a -> Identity a
forall a. a -> Identity a
Identity (a -> Identity a) -> a -> Identity a
forall a b. (a -> b) -> a -> b
$ a -> a
forall a. Floating a => a -> a
sqrt (a
2a -> a -> a
forall a. Num a => a -> a -> a
*a
forall a. Floating a => a
pi)


class ToCSV typ where
   toCells ::
      (Shape.C sh, Class.Real prob, P.Show prob) =>
      T typ sh prob -> [[String]]

class FromCSV typ where
   parseCells ::
      (Shape.C sh, Eq sh, Class.Real prob, Read prob) =>
      sh -> HMMCSV.CSVParser (T typ sh prob)

class (Ord symbol) => CSVSymbol symbol where
   cellFromSymbol :: symbol -> String
   symbolFromCell :: String -> Maybe symbol

instance CSVSymbol Char where
   cellFromSymbol :: Char -> String
cellFromSymbol = (Char -> ShowS
forall a. a -> [a] -> [a]
:[])
   symbolFromCell :: String -> Maybe Char
symbolFromCell = String -> Maybe Char
forall a. [a] -> Maybe a
listToMaybe

instance CSVSymbol Int where
   cellFromSymbol :: Int -> String
cellFromSymbol = Int -> String
forall a. Show a => a -> String
show
   symbolFromCell :: String -> Maybe Int
symbolFromCell = String -> Maybe Int
forall a. Read a => String -> Maybe a
maybeRead


instance (CSVSymbol symbol) => ToCSV (Discrete symbol) where
   toCells :: T (Discrete symbol) sh prob -> [[String]]
toCells (Discrete m) =
      ((symbol, Vector sh prob) -> [String])
-> [(symbol, Vector sh prob)] -> [[String]]
forall a b. (a -> b) -> [a] -> [b]
map
         (\(symbol
symbol, Vector sh prob
probs) ->
            symbol -> String
forall symbol. CSVSymbol symbol => symbol -> String
cellFromSymbol symbol
symbol String -> [String] -> [String]
forall a. a -> [a] -> [a]
: Vector sh prob -> [String]
forall sh a. (C sh, Show a, Real a) => Vector sh a -> [String]
HMMCSV.cellsFromVector Vector sh prob
probs) ([(symbol, Vector sh prob)] -> [[String]])
-> [(symbol, Vector sh prob)] -> [[String]]
forall a b. (a -> b) -> a -> b
$
      Array (Set symbol) (Vector sh prob)
-> [(Index (Set symbol), Vector sh prob)]
forall sh a. Indexed sh => Array sh a -> [(Index sh, a)]
Array.toAssociations (Array (Set symbol) (Vector sh prob)
 -> [(Index (Set symbol), Vector sh prob)])
-> Array (Set symbol) (Vector sh prob)
-> [(Index (Set symbol), Vector sh prob)]
forall a b. (a -> b) -> a -> b
$ Full Size Big Big (Set symbol) sh prob
-> Array (Set symbol) (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
-> Array height (Vector width a)
Matrix.toRowArray Full Size Big Big (Set symbol) sh prob
m

instance (CSVSymbol symbol) => FromCSV (Discrete symbol) where
   parseCells :: sh -> CSVParser (T (Discrete symbol) sh prob)
parseCells sh
n =
      let p :: CSVRow -> CSVParser (symbol, Vector sh prob)
p = sh -> CSVRow -> CSVParser (symbol, Vector sh prob)
forall sh prob symbol.
(C sh, Real prob, Read prob, CSVSymbol symbol) =>
sh -> CSVRow -> CSVParser (symbol, Vector sh prob)
parseSymbolProb sh
n
      in (T [] (symbol, Vector sh prob) -> T (Discrete symbol) sh prob)
-> StateT
     CSVResult (Exceptional String) (T [] (symbol, Vector sh prob))
-> CSVParser (T (Discrete symbol) sh prob)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap T [] (symbol, Vector sh prob) -> T (Discrete symbol) sh prob
forall symbol sh prob.
(Ord symbol, C sh, Eq sh, Real prob) =>
T [] (symbol, Vector sh prob) -> T (Discrete symbol) sh prob
discreteFromList (StateT
   CSVResult (Exceptional String) (T [] (symbol, Vector sh prob))
 -> CSVParser (T (Discrete symbol) sh prob))
-> StateT
     CSVResult (Exceptional String) (T [] (symbol, Vector sh prob))
-> CSVParser (T (Discrete symbol) sh prob)
forall a b. (a -> b) -> a -> b
$
         ((symbol, Vector sh prob)
 -> [(symbol, Vector sh prob)] -> T [] (symbol, Vector sh prob))
-> CSVParser (symbol, Vector sh prob)
-> StateT CSVResult (Exceptional String) [(symbol, Vector sh prob)]
-> StateT
     CSVResult (Exceptional String) (T [] (symbol, Vector sh prob))
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (symbol, Vector sh prob)
-> [(symbol, Vector sh prob)] -> T [] (symbol, Vector sh prob)
forall (f :: * -> *) a. a -> f a -> T f a
NonEmpty.Cons (CSVParser CSVRow
HMMCSV.getRow CSVParser CSVRow
-> (CSVRow -> CSVParser (symbol, Vector sh prob))
-> CSVParser (symbol, Vector sh prob)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= CSVRow -> CSVParser (symbol, Vector sh prob)
p) ((CSVRow -> CSVParser (symbol, Vector sh prob))
-> StateT CSVResult (Exceptional String) [(symbol, Vector sh prob)]
forall a. (CSVRow -> CSVParser a) -> CSVParser [a]
HMMCSV.manyRowsUntilEnd CSVRow -> CSVParser (symbol, Vector sh prob)
p)

parseSymbolProb ::
   (Shape.C sh, Class.Real prob, Read prob, CSVSymbol symbol) =>
   sh -> CSV.CSVRow -> HMMCSV.CSVParser (symbol, Vector sh prob)
parseSymbolProb :: sh -> CSVRow -> CSVParser (symbol, Vector sh prob)
parseSymbolProb sh
sh CSVRow
row =
   case CSVRow
row of
      [] -> Exceptional String (symbol, Vector sh prob)
-> CSVParser (symbol, Vector sh prob)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
MT.lift (Exceptional String (symbol, Vector sh prob)
 -> CSVParser (symbol, Vector sh prob))
-> Exceptional String (symbol, Vector sh prob)
-> CSVParser (symbol, Vector sh prob)
forall a b. (a -> b) -> a -> b
$ String -> Exceptional String (symbol, Vector sh prob)
forall e a. e -> Exceptional e a
ME.throw String
"missing symbol"
      CSVField
c:CSVRow
cs ->
         (symbol -> Vector sh prob -> (symbol, Vector sh prob))
-> StateT CSVResult (Exceptional String) symbol
-> StateT CSVResult (Exceptional String) (Vector sh prob)
-> CSVParser (symbol, Vector sh prob)
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (,)
            (let str :: String
str = CSVField -> String
CSV.csvFieldContent CSVField
c
             in  Exceptional String symbol
-> StateT CSVResult (Exceptional String) symbol
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
MT.lift (Exceptional String symbol
 -> StateT CSVResult (Exceptional String) symbol)
-> Exceptional String symbol
-> StateT CSVResult (Exceptional String) symbol
forall a b. (a -> b) -> a -> b
$ String -> Maybe symbol -> Exceptional String symbol
forall e a. e -> Maybe a -> Exceptional e a
ME.fromMaybe (String -> ShowS
forall r. PrintfType r => String -> r
printf String
"unknown symbol %s" String
str) (Maybe symbol -> Exceptional String symbol)
-> Maybe symbol -> Exceptional String symbol
forall a b. (a -> b) -> a -> b
$
                 String -> Maybe symbol
forall symbol. CSVSymbol symbol => String -> Maybe symbol
symbolFromCell String
str)
            (do Vector ShapeInt prob
v <- CSVRow -> CSVParser (Vector ShapeInt prob)
forall a.
(Read a, Real a) =>
CSVRow -> CSVParser (Vector ShapeInt a)
HMMCSV.parseVectorFields CSVRow
cs
                let n :: Int
n = sh -> Int
forall sh. C sh => sh -> Int
Shape.size sh
sh
                let m :: Int
m = Vector ShapeInt prob -> Int
forall sh a. C sh => Vector sh a -> Int
vectorDim Vector ShapeInt prob
v
                Bool -> String -> CSVParser ()
HMMCSV.assert (Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
m)
                   (String -> Int -> Int -> String
forall r. PrintfType r => String -> r
printf String
"number of states (%d) and size of probability vector (%d) mismatch"
                      Int
n Int
m)
                Vector sh prob
-> StateT CSVResult (Exceptional String) (Vector sh prob)
forall (m :: * -> *) a. Monad m => a -> m a
return (Vector sh prob
 -> StateT CSVResult (Exceptional String) (Vector sh prob))
-> Vector sh prob
-> StateT CSVResult (Exceptional String) (Vector sh prob)
forall a b. (a -> b) -> a -> b
$ sh -> Vector ShapeInt prob -> Vector sh prob
forall sh0 sh1 a.
(C sh0, C sh1) =>
sh1 -> Array sh0 a -> Array sh1 a
StorableArray.reshape sh
sh Vector ShapeInt prob
v)


instance (Shape.Indexed emiSh) => ToCSV (Gaussian emiSh) where
   toCells :: T (Gaussian emiSh) sh prob -> [[String]]
toCells (Gaussian params) =
      [[String]] -> [[[String]]] -> [[String]]
forall a. [a] -> [[a]] -> [a]
List.intercalate [[]] ([[[String]]] -> [[String]]) -> [[[String]]] -> [[String]]
forall a b. (a -> b) -> a -> b
$
      ((prob, Vector emiSh prob,
  TriangularP Packed Empty Arbitrary Filled emiSh prob)
 -> [[String]])
-> [(prob, Vector emiSh prob,
     TriangularP Packed Empty Arbitrary Filled emiSh prob)]
-> [[[String]]]
forall a b. (a -> b) -> [a] -> [b]
map
         (\(prob
_, Vector emiSh prob
center, TriangularP Packed Empty Arbitrary Filled emiSh prob
covarianceChol) ->
            Vector emiSh prob -> [String]
forall sh a. (C sh, Show a, Real a) => Vector sh a -> [String]
HMMCSV.cellsFromVector Vector emiSh prob
center [String] -> [[String]] -> [[String]]
forall a. a -> [a] -> [a]
:
            Square emiSh prob -> [[String]]
forall sh a.
(Indexed sh, Show a, Real a) =>
Square sh a -> [[String]]
HMMCSV.cellsFromSquare (TriangularP Packed Empty Arbitrary Filled emiSh prob
-> Square emiSh prob
forall lo up diag sh a pack.
(PowerStrip lo, PowerStrip up, TriDiag diag, C sh, Floating a) =>
TriangularP pack lo diag up sh a -> Square sh a
Triangular.toSquare TriangularP Packed Empty Arbitrary Filled emiSh prob
covarianceChol)) ([(prob, Vector emiSh prob,
   TriangularP Packed Empty Arbitrary Filled emiSh prob)]
 -> [[[String]]])
-> [(prob, Vector emiSh prob,
     TriangularP Packed Empty Arbitrary Filled emiSh prob)]
-> [[[String]]]
forall a b. (a -> b) -> a -> b
$
      Array
  sh
  (prob, Vector emiSh prob,
   TriangularP Packed Empty Arbitrary Filled emiSh prob)
-> [(prob, Vector emiSh prob,
     TriangularP Packed Empty Arbitrary Filled emiSh prob)]
forall sh a. C sh => Array sh a -> [a]
Array.toList Array
  sh
  (prob, Vector emiSh prob,
   TriangularP Packed Empty Arbitrary Filled emiSh prob)
params

instance (emiSh ~ Matrix.ShapeInt) => FromCSV (Gaussian emiSh) where
   parseCells :: sh -> CSVParser (T (Gaussian emiSh) sh prob)
parseCells sh
sh = do
      let n :: Int
n = sh -> Int
forall sh. C sh => sh -> Int
Shape.size sh
sh
      [(prob, Vector emiSh prob, Upper emiSh prob)]
gs <- CSVParser (prob, Vector emiSh prob, Upper emiSh prob)
-> CSVParser [(prob, Vector emiSh prob, Upper emiSh prob)]
forall a. CSVParser a -> CSVParser [a]
HMMCSV.manySepUntilEnd CSVParser (prob, Vector emiSh prob, Upper emiSh prob)
forall emiSh prob.
(emiSh ~ ShapeInt, Real prob, Eq prob, Read prob) =>
CSVParser (prob, Vector emiSh prob, Upper emiSh prob)
parseSingleGaussian
      Bool -> String -> CSVParser ()
HMMCSV.assert ([(prob, Vector emiSh prob, Upper emiSh prob)] -> Int
forall a. [a] -> Int
length [(prob, Vector emiSh prob, Upper emiSh prob)]
gs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
n) (String -> CSVParser ()) -> String -> CSVParser ()
forall a b. (a -> b) -> a -> b
$
         String -> Int -> Int -> String
forall r. PrintfType r => String -> r
printf String
"number of states (%d) and number of Gaussians (%d) mismatch"
            Int
n ([(prob, Vector emiSh prob, Upper emiSh prob)] -> Int
forall a. [a] -> Int
length [(prob, Vector emiSh prob, Upper emiSh prob)]
gs)
      let sizes :: [Int]
sizes = ((prob, Vector emiSh prob, Upper emiSh prob) -> Int)
-> [(prob, Vector emiSh prob, Upper emiSh prob)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Vector emiSh prob -> Int
forall sh a. C sh => Vector sh a -> Int
vectorDim (Vector emiSh prob -> Int)
-> ((prob, Vector emiSh prob, Upper emiSh prob)
    -> Vector emiSh prob)
-> (prob, Vector emiSh prob, Upper emiSh prob)
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (prob, Vector emiSh prob, Upper emiSh prob) -> Vector emiSh prob
forall a b c. (a, b, c) -> b
snd3) [(prob, Vector emiSh prob, Upper emiSh prob)]
gs
      Bool -> String -> CSVParser ()
HMMCSV.assert ([Int] -> Bool
forall a. Eq a => [a] -> Bool
ListHT.allEqual [Int]
sizes) (String -> CSVParser ()) -> String -> CSVParser ()
forall a b. (a -> b) -> a -> b
$
         String -> ShowS
forall r. PrintfType r => String -> r
printf String
"dimensions of emissions mismatch: %s" ([Int] -> String
forall a. Show a => a -> String
show [Int]
sizes)
      T (Gaussian emiSh) sh prob
-> CSVParser (T (Gaussian emiSh) sh prob)
forall (m :: * -> *) a. Monad m => a -> m a
return (T (Gaussian emiSh) sh prob
 -> CSVParser (T (Gaussian emiSh) sh prob))
-> T (Gaussian emiSh) sh prob
-> CSVParser (T (Gaussian emiSh) sh prob)
forall a b. (a -> b) -> a -> b
$ Array sh (prob, Vector emiSh prob, Upper emiSh prob)
-> T (Gaussian emiSh) sh prob
forall emiSh stateSh a.
Array stateSh (a, Vector emiSh a, Upper emiSh a)
-> T (Gaussian emiSh) stateSh a
Gaussian (Array sh (prob, Vector emiSh prob, Upper emiSh prob)
 -> T (Gaussian emiSh) sh prob)
-> Array sh (prob, Vector emiSh prob, Upper emiSh prob)
-> T (Gaussian emiSh) sh prob
forall a b. (a -> b) -> a -> b
$ sh
-> [(prob, Vector emiSh prob, Upper emiSh prob)]
-> Array sh (prob, Vector emiSh prob, Upper emiSh prob)
forall sh a. C sh => sh -> [a] -> Array sh a
Array.fromList sh
sh [(prob, Vector emiSh prob, Upper emiSh prob)]
gs

parseSingleGaussian ::
   (emiSh ~ Matrix.ShapeInt, Class.Real prob, Eq prob, Read prob) =>
   HMMCSV.CSVParser (prob, Vector emiSh prob, Triangular.Upper emiSh prob)
parseSingleGaussian :: CSVParser (prob, Vector emiSh prob, Upper emiSh prob)
parseSingleGaussian = do
   Vector ShapeInt prob
center <- CSVParser (Vector ShapeInt prob)
forall a. (Read a, Real a) => CSVParser (Vector ShapeInt a)
HMMCSV.parseNonEmptyVectorCells
   Square ShapeInt prob
covarianceCholSquare <-
      ShapeInt -> CSVParser (Square ShapeInt prob)
forall sh a.
(C sh, Read a, Real a) =>
sh -> CSVParser (Square sh a)
HMMCSV.parseSquareMatrixCells (ShapeInt -> CSVParser (Square ShapeInt prob))
-> ShapeInt -> CSVParser (Square ShapeInt prob)
forall a b. (a -> b) -> a -> b
$ Vector ShapeInt prob -> ShapeInt
forall sh a. Array sh a -> sh
StorableArray.shape Vector ShapeInt prob
center
   let covarianceChol :: Upper ShapeInt prob
covarianceChol = Square ShapeInt prob -> Upper ShapeInt prob
forall property lower meas vert height width a.
(Property property, Strip lower, Measure meas, C vert, C height,
 C width, Floating a) =>
Unpacked property lower Filled meas vert Small height width a
-> Upper width a
Triangular.takeUpper Square ShapeInt prob
covarianceCholSquare
   Bool -> String -> CSVParser ()
HMMCSV.assert
      (Square ShapeInt prob -> Upper ShapeInt prob -> Bool
forall sh a.
(C sh, Real a, Eq a) =>
Square sh a -> Upper sh a -> Bool
isUpperTriang Square ShapeInt prob
covarianceCholSquare Upper ShapeInt prob
covarianceChol)
      String
"matrices must be upper triangular"
   (prob, Vector ShapeInt prob, Upper ShapeInt prob)
-> StateT
     CSVResult
     (Exceptional String)
     (prob, Vector ShapeInt prob, Upper ShapeInt prob)
forall (m :: * -> *) a. Monad m => a -> m a
return ((prob, Vector ShapeInt prob, Upper ShapeInt prob)
 -> StateT
      CSVResult
      (Exceptional String)
      (prob, Vector ShapeInt prob, Upper ShapeInt prob))
-> (prob, Vector ShapeInt prob, Upper ShapeInt prob)
-> StateT
     CSVResult
     (Exceptional String)
     (prob, Vector ShapeInt prob, Upper ShapeInt prob)
forall a b. (a -> b) -> a -> b
$ Vector ShapeInt prob
-> Upper ShapeInt prob
-> (prob, Vector ShapeInt prob, Upper ShapeInt prob)
forall emiSh prob.
(C emiSh, Real prob) =>
Vector emiSh prob
-> Upper emiSh prob -> (prob, Vector emiSh prob, Upper emiSh prob)
gaussianFromCholesky Vector ShapeInt prob
center Upper ShapeInt prob
covarianceChol


{-
Maybe this test is too strict.
It would also be ok, and certainly more intuitive
to use an orthogonal but not normalized matrix.
We could get such a matrix from the eigensystem.
-}
isUpperTriang ::
   (Shape.C sh, Class.Real a, Eq a) =>
   Matrix.Square sh a -> Triangular.Upper sh a -> Bool
isUpperTriang :: Square sh a -> Upper sh a -> Bool
isUpperTriang Square sh a
m Upper sh a
mt =
   Vector (Full Shape Small Small sh sh) a -> [a]
forall sh a. (C sh, Storable a) => Vector sh a -> [a]
Vector.toList (Square sh a
-> PlainArray
     Unpacked Arbitrary Filled Filled Shape Small Small sh sh a
forall pack property lower upper meas vert horiz height width a.
ToPlain pack property lower upper meas vert horiz height width =>
ArrayMatrix
  pack property lower upper meas vert horiz height width a
-> PlainArray
     pack property lower upper meas vert horiz height width a
ArrMatrix.toVector Square sh a
m)
   [a] -> [a] -> Bool
forall a. Eq a => a -> a -> Bool
==
   Vector (Full Shape Small Small sh sh) a -> [a]
forall sh a. (C sh, Storable a) => Vector sh a -> [a]
Vector.toList (Square sh a
-> PlainArray
     Unpacked Arbitrary Filled Filled Shape Small Small sh sh a
forall pack property lower upper meas vert horiz height width a.
ToPlain pack property lower upper meas vert horiz height width =>
ArrayMatrix
  pack property lower upper meas vert horiz height width a
-> PlainArray
     pack property lower upper meas vert horiz height width a
ArrMatrix.toVector (Upper sh a -> Square sh a
forall lo up diag sh a pack.
(PowerStrip lo, PowerStrip up, TriDiag diag, C sh, Floating a) =>
TriangularP pack lo diag up sh a -> Square sh a
Triangular.toSquare Upper sh a
mt))