module Math.HiddenMarkovModel.Example.SineWavePrivate where

import qualified Math.HiddenMarkovModel.Public as HMM
import qualified Math.HiddenMarkovModel.Public.Distribution as Distr
import Math.HiddenMarkovModel.Utility (normalizeProb, squareFromLists)

import qualified Numeric.LAPACK.Matrix.Hermitian as Hermitian
import qualified Numeric.LAPACK.Matrix.Layout as Layout
import qualified Numeric.LAPACK.Vector as Vector
import Numeric.LAPACK.Vector (Vector, singleton)

import qualified Data.Array.Comfort.Boxed as Array
import qualified Data.Array.Comfort.Shape as Shape

import qualified Data.NonEmpty.Class as NonEmptyC
import qualified Data.NonEmpty as NonEmpty
import Data.Function.HT (nest)
import Data.Tuple.HT (mapSnd)


{- $setup
>>> import qualified Data.NonEmpty as NonEmpty
-}


data State = Rising | High | Falling | Low
   deriving (State -> State -> Bool
(State -> State -> Bool) -> (State -> State -> Bool) -> Eq State
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: State -> State -> Bool
$c/= :: State -> State -> Bool
== :: State -> State -> Bool
$c== :: State -> State -> Bool
Eq, Eq State
Eq State
-> (State -> State -> Ordering)
-> (State -> State -> Bool)
-> (State -> State -> Bool)
-> (State -> State -> Bool)
-> (State -> State -> Bool)
-> (State -> State -> State)
-> (State -> State -> State)
-> Ord State
State -> State -> Bool
State -> State -> Ordering
State -> State -> State
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: State -> State -> State
$cmin :: State -> State -> State
max :: State -> State -> State
$cmax :: State -> State -> State
>= :: State -> State -> Bool
$c>= :: State -> State -> Bool
> :: State -> State -> Bool
$c> :: State -> State -> Bool
<= :: State -> State -> Bool
$c<= :: State -> State -> Bool
< :: State -> State -> Bool
$c< :: State -> State -> Bool
compare :: State -> State -> Ordering
$ccompare :: State -> State -> Ordering
$cp1Ord :: Eq State
Ord, Int -> State
State -> Int
State -> [State]
State -> State
State -> State -> [State]
State -> State -> State -> [State]
(State -> State)
-> (State -> State)
-> (Int -> State)
-> (State -> Int)
-> (State -> [State])
-> (State -> State -> [State])
-> (State -> State -> [State])
-> (State -> State -> State -> [State])
-> Enum State
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: State -> State -> State -> [State]
$cenumFromThenTo :: State -> State -> State -> [State]
enumFromTo :: State -> State -> [State]
$cenumFromTo :: State -> State -> [State]
enumFromThen :: State -> State -> [State]
$cenumFromThen :: State -> State -> [State]
enumFrom :: State -> [State]
$cenumFrom :: State -> [State]
fromEnum :: State -> Int
$cfromEnum :: State -> Int
toEnum :: Int -> State
$ctoEnum :: Int -> State
pred :: State -> State
$cpred :: State -> State
succ :: State -> State
$csucc :: State -> State
Enum, State
State -> State -> Bounded State
forall a. a -> a -> Bounded a
maxBound :: State
$cmaxBound :: State
minBound :: State
$cminBound :: State
Bounded, Int -> State -> ShowS
[State] -> ShowS
State -> String
(Int -> State -> ShowS)
-> (State -> String) -> ([State] -> ShowS) -> Show State
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [State] -> ShowS
$cshowList :: [State] -> ShowS
show :: State -> String
$cshow :: State -> String
showsPrec :: Int -> State -> ShowS
$cshowsPrec :: Int -> State -> ShowS
Show)

type StateSet = Shape.Enumeration State

stateSet :: StateSet
stateSet :: StateSet
stateSet = StateSet
forall n. Enumeration n
Shape.Enumeration


type HMM = HMM.Gaussian () StateSet Double

hmm :: HMM
hmm :: HMM
hmm =
   Cons :: forall typ sh prob.
Vector sh prob -> Square sh prob -> T typ sh prob -> T typ sh prob
HMM.Cons {
      initial :: Vector StateSet Double
HMM.initial = Vector StateSet Double -> Vector StateSet Double
forall sh a. (C sh, Real a) => Vector sh a -> Vector sh a
normalizeProb (Vector StateSet Double -> Vector StateSet Double)
-> Vector StateSet Double -> Vector StateSet Double
forall a b. (a -> b) -> a -> b
$ StateSet -> Vector StateSet Double
forall sh a. (C sh, Floating a) => sh -> Vector sh a
Vector.one StateSet
stateSet,
      transition :: Square StateSet Double
HMM.transition =
         StateSet -> [Vector StateSet Double] -> Square StateSet Double
forall sh a.
(C sh, Eq sh, Storable a) =>
sh -> [Vector sh a] -> Square sh a
squareFromLists StateSet
stateSet ([Vector StateSet Double] -> Square StateSet Double)
-> [Vector StateSet Double] -> Square StateSet Double
forall a b. (a -> b) -> a -> b
$
            Double -> Double -> Double -> Double -> Vector StateSet Double
stateVector Double
0.9 Double
0.0 Double
0.0 Double
0.1 Vector StateSet Double
-> [Vector StateSet Double] -> [Vector StateSet Double]
forall a. a -> [a] -> [a]
:
            Double -> Double -> Double -> Double -> Vector StateSet Double
stateVector Double
0.1 Double
0.9 Double
0.0 Double
0.0 Vector StateSet Double
-> [Vector StateSet Double] -> [Vector StateSet Double]
forall a. a -> [a] -> [a]
:
            Double -> Double -> Double -> Double -> Vector StateSet Double
stateVector Double
0.0 Double
0.1 Double
0.9 Double
0.0 Vector StateSet Double
-> [Vector StateSet Double] -> [Vector StateSet Double]
forall a. a -> [a] -> [a]
:
            Double -> Double -> Double -> Double -> Vector StateSet Double
stateVector Double
0.0 Double
0.0 Double
0.1 Double
0.9 Vector StateSet Double
-> [Vector StateSet Double] -> [Vector StateSet Double]
forall a. a -> [a] -> [a]
:
            [],
      distribution :: T (Gaussian ()) StateSet Double
HMM.distribution =
         Array StateSet (Vector () Double, HermitianPosDef () Double)
-> T (Gaussian ()) StateSet Double
forall emiSh stateSh prob.
(C emiSh, C stateSh, Real prob) =>
Array stateSh (Vector emiSh prob, HermitianPosDef emiSh prob)
-> T (Gaussian emiSh) stateSh prob
Distr.gaussian (Array StateSet (Vector () Double, HermitianPosDef () Double)
 -> T (Gaussian ()) StateSet Double)
-> Array StateSet (Vector () Double, HermitianPosDef () Double)
-> T (Gaussian ()) StateSet Double
forall a b. (a -> b) -> a -> b
$ StateSet
-> [(Vector () Double, HermitianPosDef () Double)]
-> Array StateSet (Vector () Double, HermitianPosDef () Double)
forall sh a. C sh => sh -> [a] -> Array sh a
Array.fromList StateSet
stateSet ([(Vector () Double, HermitianPosDef () Double)]
 -> Array StateSet (Vector () Double, HermitianPosDef () Double))
-> [(Vector () Double, HermitianPosDef () Double)]
-> Array StateSet (Vector () Double, HermitianPosDef () Double)
forall a b. (a -> b) -> a -> b
$
            (Double -> Vector () Double
forall a. Storable a => a -> Array () a
singleton   Double
0 , Order -> () -> HermitianPosDef () Double
forall sh a.
(C sh, Floating a) =>
Order -> sh -> HermitianPosDef sh a
Hermitian.identity Order
Layout.RowMajor ()) (Vector () Double, HermitianPosDef () Double)
-> [(Vector () Double, HermitianPosDef () Double)]
-> [(Vector () Double, HermitianPosDef () Double)]
forall a. a -> [a] -> [a]
:
            (Double -> Vector () Double
forall a. Storable a => a -> Array () a
singleton   Double
1 , Order -> () -> HermitianPosDef () Double
forall sh a.
(C sh, Floating a) =>
Order -> sh -> HermitianPosDef sh a
Hermitian.identity Order
Layout.RowMajor ()) (Vector () Double, HermitianPosDef () Double)
-> [(Vector () Double, HermitianPosDef () Double)]
-> [(Vector () Double, HermitianPosDef () Double)]
forall a. a -> [a] -> [a]
:
            (Double -> Vector () Double
forall a. Storable a => a -> Array () a
singleton   Double
0 , Order -> () -> HermitianPosDef () Double
forall sh a.
(C sh, Floating a) =>
Order -> sh -> HermitianPosDef sh a
Hermitian.identity Order
Layout.RowMajor ()) (Vector () Double, HermitianPosDef () Double)
-> [(Vector () Double, HermitianPosDef () Double)]
-> [(Vector () Double, HermitianPosDef () Double)]
forall a. a -> [a] -> [a]
:
            (Double -> Vector () Double
forall a. Storable a => a -> Array () a
singleton (-Double
1), Order -> () -> HermitianPosDef () Double
forall sh a.
(C sh, Floating a) =>
Order -> sh -> HermitianPosDef sh a
Hermitian.identity Order
Layout.RowMajor ()) (Vector () Double, HermitianPosDef () Double)
-> [(Vector () Double, HermitianPosDef () Double)]
-> [(Vector () Double, HermitianPosDef () Double)]
forall a. a -> [a] -> [a]
:
            []
   }

stateVector :: Double -> Double -> Double -> Double -> Vector StateSet Double
stateVector :: Double -> Double -> Double -> Double -> Vector StateSet Double
stateVector Double
x0 Double
x1 Double
x2 Double
x3 = StateSet -> [Double] -> Vector StateSet Double
forall sh a. (C sh, Storable a) => sh -> [a] -> Vector sh a
Vector.fromList StateSet
stateSet [Double
x0,Double
x1,Double
x2,Double
x3]

{- |
>>> take 20 $ map fst $ NonEmpty.flatten sineWaveLabeled
[Rising,Rising,High,High,High,Falling,Falling,Falling,Low,Low,Low,Rising,Rising,Rising,Rising,High,High,High,Falling,Falling]
-}
sineWaveLabeled :: NonEmpty.T [] (State, Double)
sineWaveLabeled :: T [] (State, Double)
sineWaveLabeled =
   ([(State, Double)] -> [(State, Double)])
-> T [] (State, Double) -> T [] (State, Double)
forall (f :: * -> *) a (g :: * -> *).
(f a -> g a) -> T f a -> T g a
NonEmpty.mapTail (Int -> [(State, Double)] -> [(State, Double)]
forall a. Int -> [a] -> [a]
take Int
200) (T [] (State, Double) -> T [] (State, Double))
-> T [] (State, Double) -> T [] (State, Double)
forall a b. (a -> b) -> a -> b
$
   (Double -> (State, Double)) -> T [] Double -> T [] (State, Double)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Double
x -> (Int -> State
forall a. Enum a => Int -> a
toEnum (Int -> State) -> Int -> State
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int
forall a. Integral a => a -> a -> a
mod (Double -> Int
forall a b. (RealFrac a, Integral b) => a -> b
floor (Double
xDouble -> Double -> Double
forall a. Num a => a -> a -> a
*Double
2Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
forall a. Floating a => a
piDouble -> Double -> Double
forall a. Num a => a -> a -> a
+Double
0.5)) Int
4, Double -> Double
forall a. Floating a => a -> a
sin Double
x)) (T [] Double -> T [] (State, Double))
-> T [] Double -> T [] (State, Double)
forall a b. (a -> b) -> a -> b
$
   (Double -> Double) -> Double -> T [] Double
forall (f :: * -> *) a. Iterate f => (a -> a) -> a -> f a
NonEmptyC.iterate (Double
0.5Double -> Double -> Double
forall a. Num a => a -> a -> a
+) Double
0

sineWave :: NonEmpty.T [] Double
sineWave :: T [] Double
sineWave = ((State, Double) -> Double) -> T [] (State, Double) -> T [] Double
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (State, Double) -> Double
forall a b. (a, b) -> b
snd T [] (State, Double)
sineWaveLabeled

{- |
>>> take 20 $ NonEmpty.flatten revealed
[Rising,Rising,High,High,High,Falling,Falling,Falling,Low,Low,Low,Low,Rising,Rising,Rising,High,High,High,Falling,Falling]
-}
revealed :: NonEmpty.T [] State
revealed :: T [] State
revealed = HMM -> T [] (Vector () Double) -> T [] 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) =>
T typ sh prob -> T f emission -> T f state
HMM.reveal HMM
hmmTrainedSupervised (T [] (Vector () Double) -> T [] State)
-> T [] (Vector () Double) -> T [] State
forall a b. (a -> b) -> a -> b
$ (Double -> Vector () Double)
-> T [] Double -> T [] (Vector () Double)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Double -> Vector () Double
forall a. Storable a => a -> Array () a
singleton T [] Double
sineWave

hmmTrainedSupervised :: HMM
hmmTrainedSupervised :: HMM
hmmTrainedSupervised =
   Trained (Gaussian ()) StateSet Double -> HMM
forall typ sh prob.
(Estimate typ, C sh, Eq sh, Real prob) =>
Trained typ sh prob -> T typ sh prob
HMM.finishTraining (Trained (Gaussian ()) StateSet Double -> HMM)
-> Trained (Gaussian ()) StateSet Double -> HMM
forall a b. (a -> b) -> a -> b
$ StateSet
-> T [] (State, Vector () Double)
-> Trained (Gaussian ()) StateSet Double
forall typ sh state prob emission.
(Estimate typ, Indexed sh, Index sh ~ state, Real prob,
 Emission typ prob ~ emission) =>
sh -> T [] (state, emission) -> Trained typ sh prob
HMM.trainSupervised StateSet
stateSet (T [] (State, Vector () Double)
 -> Trained (Gaussian ()) StateSet Double)
-> T [] (State, Vector () Double)
-> Trained (Gaussian ()) StateSet Double
forall a b. (a -> b) -> a -> b
$
   ((State, Double) -> (State, Vector () Double))
-> T [] (State, Double) -> T [] (State, Vector () Double)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Double -> Vector () Double)
-> (State, Double) -> (State, Vector () Double)
forall b c a. (b -> c) -> (a, b) -> (a, c)
mapSnd Double -> Vector () Double
forall a. Storable a => a -> Array () a
singleton) T [] (State, Double)
sineWaveLabeled

hmmTrainedUnsupervised :: HMM
hmmTrainedUnsupervised :: HMM
hmmTrainedUnsupervised =
   Trained (Gaussian ()) StateSet Double -> HMM
forall typ sh prob.
(Estimate typ, C sh, Eq sh, Real prob) =>
Trained typ sh prob -> T typ sh prob
HMM.finishTraining (Trained (Gaussian ()) StateSet Double -> HMM)
-> Trained (Gaussian ()) StateSet Double -> HMM
forall a b. (a -> b) -> a -> b
$ HMM
-> T [] (Vector () Double) -> Trained (Gaussian ()) StateSet Double
forall typ sh prob emission.
(Estimate typ, C sh, Eq sh, Real prob,
 Emission typ prob ~ emission) =>
T typ sh prob -> T [] emission -> Trained typ sh prob
HMM.trainUnsupervised HMM
hmm (T [] (Vector () Double) -> Trained (Gaussian ()) StateSet Double)
-> T [] (Vector () Double) -> Trained (Gaussian ()) StateSet Double
forall a b. (a -> b) -> a -> b
$ (Double -> Vector () Double)
-> T [] Double -> T [] (Vector () Double)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Double -> Vector () Double
forall a. Storable a => a -> Array () a
singleton T [] Double
sineWave

hmmIterativelyTrained :: HMM
hmmIterativelyTrained :: HMM
hmmIterativelyTrained =
   Int -> (HMM -> HMM) -> HMM -> HMM
forall a. Int -> (a -> a) -> a -> a
nest Int
100
      (\HMM
model ->
         Trained (Gaussian ()) StateSet Double -> HMM
forall typ sh prob.
(Estimate typ, C sh, Eq sh, Real prob) =>
Trained typ sh prob -> T typ sh prob
HMM.finishTraining (Trained (Gaussian ()) StateSet Double -> HMM)
-> Trained (Gaussian ()) StateSet Double -> HMM
forall a b. (a -> b) -> a -> b
$ HMM
-> T [] (Vector () Double) -> Trained (Gaussian ()) StateSet Double
forall typ sh prob emission.
(Estimate typ, C sh, Eq sh, Real prob,
 Emission typ prob ~ emission) =>
T typ sh prob -> T [] emission -> Trained typ sh prob
HMM.trainUnsupervised HMM
model (T [] (Vector () Double) -> Trained (Gaussian ()) StateSet Double)
-> T [] (Vector () Double) -> Trained (Gaussian ()) StateSet Double
forall a b. (a -> b) -> a -> b
$
         (Double -> Vector () Double)
-> T [] Double -> T [] (Vector () Double)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Double -> Vector () Double
forall a. Storable a => a -> Array () a
singleton T [] Double
sineWave)
      HMM
hmm