module Math.HiddenMarkovModel.Example.CirclePrivate where

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

import qualified Numeric.LAPACK.Matrix.HermitianPositiveDefinite as HermitianPD
import qualified Numeric.LAPACK.Vector as Vector
import Numeric.LAPACK.Vector (Vector)

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

import qualified System.Random as Rnd

import qualified Control.Monad.Trans.State as MS
import Control.Monad (liftM2, replicateM)

import qualified Data.NonEmpty.Class as NonEmptyC
import qualified Data.NonEmpty as NonEmpty
import Data.Function.HT (nest)
import Data.NonEmpty ((!:))
import Data.Maybe (fromMaybe)


{- $setup
>>> import qualified Math.HiddenMarkovModel as HMM
>>> import qualified Data.NonEmpty as NonEmpty
>>> import Data.Eq.HT (equating)
>>>
>>> checkTraining :: (Int, HMM) -> Bool
>>> checkTraining (maxDiff,hmm_) =
>>>    maxDiff >=
>>>    (length $ filter id $ NonEmpty.flatten $
>>>     NonEmpty.zipWith (/=)
>>>       (HMM.reveal hmm_ circle) (fmap fst circleLabeled))
-}


data State = Q1 | Q2 | Q3 | Q4
   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


data Coordinate = X | Y
   deriving (Coordinate -> Coordinate -> Bool
(Coordinate -> Coordinate -> Bool)
-> (Coordinate -> Coordinate -> Bool) -> Eq Coordinate
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Coordinate -> Coordinate -> Bool
$c/= :: Coordinate -> Coordinate -> Bool
== :: Coordinate -> Coordinate -> Bool
$c== :: Coordinate -> Coordinate -> Bool
Eq, Eq Coordinate
Eq Coordinate
-> (Coordinate -> Coordinate -> Ordering)
-> (Coordinate -> Coordinate -> Bool)
-> (Coordinate -> Coordinate -> Bool)
-> (Coordinate -> Coordinate -> Bool)
-> (Coordinate -> Coordinate -> Bool)
-> (Coordinate -> Coordinate -> Coordinate)
-> (Coordinate -> Coordinate -> Coordinate)
-> Ord Coordinate
Coordinate -> Coordinate -> Bool
Coordinate -> Coordinate -> Ordering
Coordinate -> Coordinate -> Coordinate
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 :: Coordinate -> Coordinate -> Coordinate
$cmin :: Coordinate -> Coordinate -> Coordinate
max :: Coordinate -> Coordinate -> Coordinate
$cmax :: Coordinate -> Coordinate -> Coordinate
>= :: Coordinate -> Coordinate -> Bool
$c>= :: Coordinate -> Coordinate -> Bool
> :: Coordinate -> Coordinate -> Bool
$c> :: Coordinate -> Coordinate -> Bool
<= :: Coordinate -> Coordinate -> Bool
$c<= :: Coordinate -> Coordinate -> Bool
< :: Coordinate -> Coordinate -> Bool
$c< :: Coordinate -> Coordinate -> Bool
compare :: Coordinate -> Coordinate -> Ordering
$ccompare :: Coordinate -> Coordinate -> Ordering
$cp1Ord :: Eq Coordinate
Ord, Int -> Coordinate
Coordinate -> Int
Coordinate -> [Coordinate]
Coordinate -> Coordinate
Coordinate -> Coordinate -> [Coordinate]
Coordinate -> Coordinate -> Coordinate -> [Coordinate]
(Coordinate -> Coordinate)
-> (Coordinate -> Coordinate)
-> (Int -> Coordinate)
-> (Coordinate -> Int)
-> (Coordinate -> [Coordinate])
-> (Coordinate -> Coordinate -> [Coordinate])
-> (Coordinate -> Coordinate -> [Coordinate])
-> (Coordinate -> Coordinate -> Coordinate -> [Coordinate])
-> Enum Coordinate
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 :: Coordinate -> Coordinate -> Coordinate -> [Coordinate]
$cenumFromThenTo :: Coordinate -> Coordinate -> Coordinate -> [Coordinate]
enumFromTo :: Coordinate -> Coordinate -> [Coordinate]
$cenumFromTo :: Coordinate -> Coordinate -> [Coordinate]
enumFromThen :: Coordinate -> Coordinate -> [Coordinate]
$cenumFromThen :: Coordinate -> Coordinate -> [Coordinate]
enumFrom :: Coordinate -> [Coordinate]
$cenumFrom :: Coordinate -> [Coordinate]
fromEnum :: Coordinate -> Int
$cfromEnum :: Coordinate -> Int
toEnum :: Int -> Coordinate
$ctoEnum :: Int -> Coordinate
pred :: Coordinate -> Coordinate
$cpred :: Coordinate -> Coordinate
succ :: Coordinate -> Coordinate
$csucc :: Coordinate -> Coordinate
Enum, Coordinate
Coordinate -> Coordinate -> Bounded Coordinate
forall a. a -> a -> Bounded a
maxBound :: Coordinate
$cmaxBound :: Coordinate
minBound :: Coordinate
$cminBound :: Coordinate
Bounded)

type CoordinateSet = Shape.Enumeration Coordinate

coordinateSet :: CoordinateSet
coordinateSet :: CoordinateSet
coordinateSet = CoordinateSet
forall n. Enumeration n
Shape.Enumeration

type HMM = HMM.Gaussian CoordinateSet StateSet Double

{- |
prop> checkTraining (0, hmm)
-}
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 CoordinateSet) StateSet Double
HMM.distribution =
         let hermitianPD :: [Double]
-> Quadratic
     Packed HermitianPositiveDefinite Filled Filled CoordinateSet Double
hermitianPD =
               AnyHermitianP Packed True True True Filled CoordinateSet Double
-> Quadratic
     Packed HermitianPositiveDefinite Filled Filled CoordinateSet Double
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 (AnyHermitianP Packed True True True Filled CoordinateSet Double
 -> Quadratic
      Packed
      HermitianPositiveDefinite
      Filled
      Filled
      CoordinateSet
      Double)
-> ([Double]
    -> AnyHermitianP Packed True True True Filled CoordinateSet Double)
-> [Double]
-> Quadratic
     Packed HermitianPositiveDefinite Filled Filled CoordinateSet Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
               CoordinateSet
-> [Double]
-> AnyHermitianP Packed True True True Filled CoordinateSet Double
forall sh a. (C sh, Floating a) => sh -> [a] -> Hermitian sh a
hermitianFromList CoordinateSet
coordinateSet
             cov0 :: Quadratic
  Packed HermitianPositiveDefinite Filled Filled CoordinateSet Double
cov0 = [Double]
-> Quadratic
     Packed HermitianPositiveDefinite Filled Filled CoordinateSet Double
hermitianPD [Double
0.10, -Double
0.09, Double
0.10]
             cov1 :: Quadratic
  Packed HermitianPositiveDefinite Filled Filled CoordinateSet Double
cov1 = [Double]
-> Quadratic
     Packed HermitianPositiveDefinite Filled Filled CoordinateSet Double
hermitianPD [Double
0.10,  Double
0.09, Double
0.10]
         in  Array
  StateSet
  (Vector CoordinateSet Double,
   Quadratic
     Packed
     HermitianPositiveDefinite
     Filled
     Filled
     CoordinateSet
     Double)
-> T (Gaussian CoordinateSet) 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 CoordinateSet Double,
    Quadratic
      Packed
      HermitianPositiveDefinite
      Filled
      Filled
      CoordinateSet
      Double)
 -> T (Gaussian CoordinateSet) StateSet Double)
-> Array
     StateSet
     (Vector CoordinateSet Double,
      Quadratic
        Packed
        HermitianPositiveDefinite
        Filled
        Filled
        CoordinateSet
        Double)
-> T (Gaussian CoordinateSet) StateSet Double
forall a b. (a -> b) -> a -> b
$ StateSet
-> [(Vector CoordinateSet Double,
     Quadratic
       Packed
       HermitianPositiveDefinite
       Filled
       Filled
       CoordinateSet
       Double)]
-> Array
     StateSet
     (Vector CoordinateSet Double,
      Quadratic
        Packed
        HermitianPositiveDefinite
        Filled
        Filled
        CoordinateSet
        Double)
forall sh a. C sh => sh -> [a] -> Array sh a
Array.fromList StateSet
stateSet ([(Vector CoordinateSet Double,
   Quadratic
     Packed
     HermitianPositiveDefinite
     Filled
     Filled
     CoordinateSet
     Double)]
 -> Array
      StateSet
      (Vector CoordinateSet Double,
       Quadratic
         Packed
         HermitianPositiveDefinite
         Filled
         Filled
         CoordinateSet
         Double))
-> [(Vector CoordinateSet Double,
     Quadratic
       Packed
       HermitianPositiveDefinite
       Filled
       Filled
       CoordinateSet
       Double)]
-> Array
     StateSet
     (Vector CoordinateSet Double,
      Quadratic
        Packed
        HermitianPositiveDefinite
        Filled
        Filled
        CoordinateSet
        Double)
forall a b. (a -> b) -> a -> b
$
                (CoordinateSet -> [Double] -> Vector CoordinateSet Double
forall sh a. (C sh, Storable a) => sh -> [a] -> Vector sh a
Vector.fromList CoordinateSet
coordinateSet [ Double
0.5,  Double
0.5], Quadratic
  Packed HermitianPositiveDefinite Filled Filled CoordinateSet Double
cov0) (Vector CoordinateSet Double,
 Quadratic
   Packed
   HermitianPositiveDefinite
   Filled
   Filled
   CoordinateSet
   Double)
-> [(Vector CoordinateSet Double,
     Quadratic
       Packed
       HermitianPositiveDefinite
       Filled
       Filled
       CoordinateSet
       Double)]
-> [(Vector CoordinateSet Double,
     Quadratic
       Packed
       HermitianPositiveDefinite
       Filled
       Filled
       CoordinateSet
       Double)]
forall a. a -> [a] -> [a]
:
                (CoordinateSet -> [Double] -> Vector CoordinateSet Double
forall sh a. (C sh, Storable a) => sh -> [a] -> Vector sh a
Vector.fromList CoordinateSet
coordinateSet [-Double
0.5,  Double
0.5], Quadratic
  Packed HermitianPositiveDefinite Filled Filled CoordinateSet Double
cov1) (Vector CoordinateSet Double,
 Quadratic
   Packed
   HermitianPositiveDefinite
   Filled
   Filled
   CoordinateSet
   Double)
-> [(Vector CoordinateSet Double,
     Quadratic
       Packed
       HermitianPositiveDefinite
       Filled
       Filled
       CoordinateSet
       Double)]
-> [(Vector CoordinateSet Double,
     Quadratic
       Packed
       HermitianPositiveDefinite
       Filled
       Filled
       CoordinateSet
       Double)]
forall a. a -> [a] -> [a]
:
                (CoordinateSet -> [Double] -> Vector CoordinateSet Double
forall sh a. (C sh, Storable a) => sh -> [a] -> Vector sh a
Vector.fromList CoordinateSet
coordinateSet [-Double
0.5, -Double
0.5], Quadratic
  Packed HermitianPositiveDefinite Filled Filled CoordinateSet Double
cov0) (Vector CoordinateSet Double,
 Quadratic
   Packed
   HermitianPositiveDefinite
   Filled
   Filled
   CoordinateSet
   Double)
-> [(Vector CoordinateSet Double,
     Quadratic
       Packed
       HermitianPositiveDefinite
       Filled
       Filled
       CoordinateSet
       Double)]
-> [(Vector CoordinateSet Double,
     Quadratic
       Packed
       HermitianPositiveDefinite
       Filled
       Filled
       CoordinateSet
       Double)]
forall a. a -> [a] -> [a]
:
                (CoordinateSet -> [Double] -> Vector CoordinateSet Double
forall sh a. (C sh, Storable a) => sh -> [a] -> Vector sh a
Vector.fromList CoordinateSet
coordinateSet [ Double
0.5, -Double
0.5], Quadratic
  Packed HermitianPositiveDefinite Filled Filled CoordinateSet Double
cov1) (Vector CoordinateSet Double,
 Quadratic
   Packed
   HermitianPositiveDefinite
   Filled
   Filled
   CoordinateSet
   Double)
-> [(Vector CoordinateSet Double,
     Quadratic
       Packed
       HermitianPositiveDefinite
       Filled
       Filled
       CoordinateSet
       Double)]
-> [(Vector CoordinateSet Double,
     Quadratic
       Packed
       HermitianPositiveDefinite
       Filled
       Filled
       CoordinateSet
       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]

circleLabeled :: NonEmpty.T [] (State, Vector CoordinateSet Double)
circleLabeled :: T [] (State, Vector CoordinateSet Double)
circleLabeled =
   ([(State, Vector CoordinateSet Double)]
 -> [(State, Vector CoordinateSet Double)])
-> T [] (State, Vector CoordinateSet Double)
-> T [] (State, Vector CoordinateSet Double)
forall (f :: * -> *) a (g :: * -> *).
(f a -> g a) -> T f a -> T g a
NonEmpty.mapTail (Int
-> [(State, Vector CoordinateSet Double)]
-> [(State, Vector CoordinateSet Double)]
forall a. Int -> [a] -> [a]
take Int
200) (T [] (State, Vector CoordinateSet Double)
 -> T [] (State, Vector CoordinateSet Double))
-> T [] (State, Vector CoordinateSet Double)
-> T [] (State, Vector CoordinateSet Double)
forall a b. (a -> b) -> a -> b
$
   (Double -> (State, Vector CoordinateSet Double))
-> T [] Double -> T [] (State, Vector CoordinateSet 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
pi)) Int
4,
          CoordinateSet -> [Double] -> Vector CoordinateSet Double
forall sh a. (C sh, Storable a) => sh -> [a] -> Vector sh a
Vector.fromList CoordinateSet
coordinateSet [Double -> Double
forall a. Floating a => a -> a
cos Double
x, Double -> Double
forall a. Floating a => a -> a
sin Double
x])) (T [] Double -> T [] (State, Vector CoordinateSet Double))
-> T [] Double -> T [] (State, Vector CoordinateSet 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

circle :: NonEmpty.T [] (Vector CoordinateSet Double)
circle :: T [] (Vector CoordinateSet Double)
circle = ((State, Vector CoordinateSet Double)
 -> Vector CoordinateSet Double)
-> T [] (State, Vector CoordinateSet Double)
-> T [] (Vector CoordinateSet Double)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (State, Vector CoordinateSet Double) -> Vector CoordinateSet Double
forall a b. (a, b) -> b
snd T [] (State, Vector CoordinateSet Double)
circleLabeled

{- |
>>> take 20 $ NonEmpty.flatten revealed
[Q1,Q1,Q1,Q1,Q2,Q2,Q2,Q3,Q3,Q3,Q4,Q4,Q4,Q1,Q1,Q1,Q2,Q2,Q2,Q3]

prop> equating (take 1000 . NonEmpty.flatten) revealed $ fmap fst circleLabeled
-}
revealed :: NonEmpty.T [] State
revealed :: T [] State
revealed = HMM -> T [] (Vector CoordinateSet 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
hmm T [] (Vector CoordinateSet Double)
circle

{- |
Sample multivariate normal distribution and reconstruct it from the samples.
You should obtain the same parameters.
-}
reconstructDistribution :: HMM.Gaussian CoordinateSet () Double
reconstructDistribution :: Gaussian CoordinateSet () Double
reconstructDistribution =
   let gen :: State StdGen (Emission (Gaussian CoordinateSet) Double)
gen = T (Gaussian CoordinateSet) StateSet Double
-> Index StateSet
-> State StdGen (Emission (Gaussian CoordinateSet) Double)
forall typ sh prob g.
(Generate typ, Indexed sh, Real prob, Random prob, RandomGen g) =>
T typ sh prob -> Index sh -> State g (Emission typ prob)
Distr.generate (HMM -> T (Gaussian CoordinateSet) StateSet Double
forall typ sh prob. T typ sh prob -> T typ sh prob
HMM.distribution HMM
hmm) Index StateSet
State
Q1
   in  Trained (Gaussian CoordinateSet) () Double
-> Gaussian CoordinateSet () Double
forall typ sh prob.
(Estimate typ, C sh, Eq sh, Real prob) =>
Trained typ sh prob -> T typ sh prob
HMM.finishTraining (Trained (Gaussian CoordinateSet) () Double
 -> Gaussian CoordinateSet () Double)
-> Trained (Gaussian CoordinateSet) () Double
-> Gaussian CoordinateSet () Double
forall a b. (a -> b) -> a -> b
$ ()
-> T [] ((), Vector CoordinateSet Double)
-> Trained (Gaussian CoordinateSet) () 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 () (T [] ((), Vector CoordinateSet Double)
 -> Trained (Gaussian CoordinateSet) () Double)
-> T [] ((), Vector CoordinateSet Double)
-> Trained (Gaussian CoordinateSet) () Double
forall a b. (a -> b) -> a -> b
$ (Vector CoordinateSet Double -> ((), Vector CoordinateSet Double))
-> T [] (Vector CoordinateSet Double)
-> T [] ((), Vector CoordinateSet Double)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((,) ()) (T [] (Vector CoordinateSet Double)
 -> T [] ((), Vector CoordinateSet Double))
-> T [] (Vector CoordinateSet Double)
-> T [] ((), Vector CoordinateSet Double)
forall a b. (a -> b) -> a -> b
$
       (State StdGen (T [] (Vector CoordinateSet Double))
 -> StdGen -> T [] (Vector CoordinateSet Double))
-> StdGen
-> State StdGen (T [] (Vector CoordinateSet Double))
-> T [] (Vector CoordinateSet Double)
forall a b c. (a -> b -> c) -> b -> a -> c
flip State StdGen (T [] (Vector CoordinateSet Double))
-> StdGen -> T [] (Vector CoordinateSet Double)
forall s a. State s a -> s -> a
MS.evalState (Int -> StdGen
Rnd.mkStdGen Int
23) (State StdGen (T [] (Vector CoordinateSet Double))
 -> T [] (Vector CoordinateSet Double))
-> State StdGen (T [] (Vector CoordinateSet Double))
-> T [] (Vector CoordinateSet Double)
forall a b. (a -> b) -> a -> b
$
       (Vector CoordinateSet Double
 -> [Vector CoordinateSet Double]
 -> T [] (Vector CoordinateSet Double))
-> StateT StdGen Identity (Vector CoordinateSet Double)
-> StateT StdGen Identity [Vector CoordinateSet Double]
-> State StdGen (T [] (Vector CoordinateSet Double))
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 Vector CoordinateSet Double
-> [Vector CoordinateSet Double]
-> T [] (Vector CoordinateSet Double)
forall a (f :: * -> *). a -> f a -> T f a
(!:) StateT StdGen Identity (Vector CoordinateSet Double)
gen (StateT StdGen Identity [Vector CoordinateSet Double]
 -> State StdGen (T [] (Vector CoordinateSet Double)))
-> StateT StdGen Identity [Vector CoordinateSet Double]
-> State StdGen (T [] (Vector CoordinateSet Double))
forall a b. (a -> b) -> a -> b
$ Int
-> StateT StdGen Identity (Vector CoordinateSet Double)
-> StateT StdGen Identity [Vector CoordinateSet Double]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
1000 StateT StdGen Identity (Vector CoordinateSet Double)
gen

{- |
Generate labeled emission sequences
and use them for supervised training.

prop> checkTraining (0, reconstructModel)
-}
reconstructModel :: HMM
reconstructModel :: HMM
reconstructModel =
   (T [] (State, Vector CoordinateSet Double)
 -> Trained (Gaussian CoordinateSet) StateSet Double)
-> T [] (T [] (State, Vector CoordinateSet Double)) -> HMM
forall typ sh prob (f :: * -> *) trainingData.
(Estimate typ, C sh, Eq sh, Real prob, Foldable f) =>
(trainingData -> Trained typ sh prob)
-> T f trainingData -> T typ sh prob
HMM.trainMany (StateSet
-> T [] (State, Vector CoordinateSet Double)
-> Trained (Gaussian CoordinateSet) 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 [] (T [] (State, Vector CoordinateSet Double)) -> HMM)
-> T [] (T [] (State, Vector CoordinateSet Double)) -> HMM
forall a b. (a -> b) -> a -> b
$
   (Int -> T [] (State, Vector CoordinateSet Double))
-> T [] Int -> T [] (T [] (State, Vector CoordinateSet Double))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
      (\Int
seed ->
         T [] (State, Vector CoordinateSet Double)
-> Maybe (T [] (State, Vector CoordinateSet Double))
-> T [] (State, Vector CoordinateSet Double)
forall a. a -> Maybe a -> a
fromMaybe (String -> T [] (State, Vector CoordinateSet Double)
forall a. HasCallStack => String -> a
error String
"empty generated sequence") (Maybe (T [] (State, Vector CoordinateSet Double))
 -> T [] (State, Vector CoordinateSet Double))
-> Maybe (T [] (State, Vector CoordinateSet Double))
-> T [] (State, Vector CoordinateSet Double)
forall a b. (a -> b) -> a -> b
$ [(State, Vector CoordinateSet Double)]
-> Maybe (T [] (State, Vector CoordinateSet Double))
forall (f :: * -> *) a. ViewL f => f a -> Maybe (T f a)
NonEmpty.fetch ([(State, Vector CoordinateSet Double)]
 -> Maybe (T [] (State, Vector CoordinateSet Double)))
-> [(State, Vector CoordinateSet Double)]
-> Maybe (T [] (State, Vector CoordinateSet Double))
forall a b. (a -> b) -> a -> b
$
         Int
-> [(State, Vector CoordinateSet Double)]
-> [(State, Vector CoordinateSet Double)]
forall a. Int -> [a] -> [a]
take Int
1000 ([(State, Vector CoordinateSet Double)]
 -> [(State, Vector CoordinateSet Double)])
-> [(State, Vector CoordinateSet Double)]
-> [(State, Vector CoordinateSet Double)]
forall a b. (a -> b) -> a -> b
$ HMM -> StdGen -> [(State, Vector CoordinateSet Double)]
forall typ sh state g prob emission.
(Generate typ, Indexed sh, Index sh ~ state, RandomGen g,
 Random prob, Real prob, Emission typ prob ~ emission) =>
T typ sh prob -> g -> [(state, emission)]
HMM.generateLabeled HMM
hmm (StdGen -> [(State, Vector CoordinateSet Double)])
-> StdGen -> [(State, Vector CoordinateSet Double)]
forall a b. (a -> b) -> a -> b
$ Int -> StdGen
Rnd.mkStdGen Int
seed)
      (Int
23 Int -> [Int] -> T [] Int
forall a (f :: * -> *). a -> f a -> T f a
!: Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
take Int
42 [Int
24..])


{- |
prop> checkTraining (0, hmmTrainedSupervised)
-}
hmmTrainedSupervised :: HMM
hmmTrainedSupervised :: HMM
hmmTrainedSupervised =
   Trained (Gaussian CoordinateSet) 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 CoordinateSet) StateSet Double -> HMM)
-> Trained (Gaussian CoordinateSet) StateSet Double -> HMM
forall a b. (a -> b) -> a -> b
$ StateSet
-> T [] (State, Vector CoordinateSet Double)
-> Trained (Gaussian CoordinateSet) 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 CoordinateSet Double)
circleLabeled

{- |
prop> checkTraining (0, hmmTrainedUnsupervised)
-}
hmmTrainedUnsupervised :: HMM
hmmTrainedUnsupervised :: HMM
hmmTrainedUnsupervised =
   Trained (Gaussian CoordinateSet) 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 CoordinateSet) StateSet Double -> HMM)
-> Trained (Gaussian CoordinateSet) StateSet Double -> HMM
forall a b. (a -> b) -> a -> b
$ HMM
-> T [] (Vector CoordinateSet Double)
-> Trained (Gaussian CoordinateSet) 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 CoordinateSet Double)
circle

{- |
prop> checkTraining (40, hmmIterativelyTrained)
-}
hmmIterativelyTrained :: HMM
hmmIterativelyTrained :: HMM
hmmIterativelyTrained =
   Int -> (HMM -> HMM) -> HMM -> HMM
forall a. Int -> (a -> a) -> a -> a
nest Int
100
      (Trained (Gaussian CoordinateSet) 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 CoordinateSet) StateSet Double -> HMM)
-> (HMM -> Trained (Gaussian CoordinateSet) StateSet Double)
-> HMM
-> HMM
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HMM
 -> T [] (Vector CoordinateSet Double)
 -> Trained (Gaussian CoordinateSet) StateSet Double)
-> T [] (Vector CoordinateSet Double)
-> HMM
-> Trained (Gaussian CoordinateSet) StateSet Double
forall a b c. (a -> b -> c) -> b -> a -> c
flip HMM
-> T [] (Vector CoordinateSet Double)
-> Trained (Gaussian CoordinateSet) 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 T [] (Vector CoordinateSet Double)
circle)
      HMM
hmm