{-# LANGUAGE TypeFamilies #-}
module Math.HiddenMarkovModel.Example.TrafficLightPrivate 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.Vector as Vector
import Numeric.LAPACK.Vector (Vector)

import qualified Data.Array.Comfort.Shape as Shape

import Text.Read.HT (maybeRead)

import Control.DeepSeq (NFData(rnf))

import qualified Data.NonEmpty as NonEmpty
import qualified Data.List.HT as ListHT
import Data.NonEmpty ((!:))


{- $setup
>>> import qualified Data.NonEmpty as NonEmpty
>>> import Control.DeepSeq (deepseq)
>>>
>>> verifyRevelations :: HMM -> [Bool]
>>> verifyRevelations hmm_ =
>>>    map (verifyRevelation hmm_) (NonEmpty.flatten labeledSequences)
-}


data Color = Red | Yellow | Green
   deriving (Color -> Color -> Bool
(Color -> Color -> Bool) -> (Color -> Color -> Bool) -> Eq Color
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Color -> Color -> Bool
$c/= :: Color -> Color -> Bool
== :: Color -> Color -> Bool
$c== :: Color -> Color -> Bool
Eq, Eq Color
Eq Color
-> (Color -> Color -> Ordering)
-> (Color -> Color -> Bool)
-> (Color -> Color -> Bool)
-> (Color -> Color -> Bool)
-> (Color -> Color -> Bool)
-> (Color -> Color -> Color)
-> (Color -> Color -> Color)
-> Ord Color
Color -> Color -> Bool
Color -> Color -> Ordering
Color -> Color -> Color
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 :: Color -> Color -> Color
$cmin :: Color -> Color -> Color
max :: Color -> Color -> Color
$cmax :: Color -> Color -> Color
>= :: Color -> Color -> Bool
$c>= :: Color -> Color -> Bool
> :: Color -> Color -> Bool
$c> :: Color -> Color -> Bool
<= :: Color -> Color -> Bool
$c<= :: Color -> Color -> Bool
< :: Color -> Color -> Bool
$c< :: Color -> Color -> Bool
compare :: Color -> Color -> Ordering
$ccompare :: Color -> Color -> Ordering
$cp1Ord :: Eq Color
Ord, Int -> Color
Color -> Int
Color -> [Color]
Color -> Color
Color -> Color -> [Color]
Color -> Color -> Color -> [Color]
(Color -> Color)
-> (Color -> Color)
-> (Int -> Color)
-> (Color -> Int)
-> (Color -> [Color])
-> (Color -> Color -> [Color])
-> (Color -> Color -> [Color])
-> (Color -> Color -> Color -> [Color])
-> Enum Color
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 :: Color -> Color -> Color -> [Color]
$cenumFromThenTo :: Color -> Color -> Color -> [Color]
enumFromTo :: Color -> Color -> [Color]
$cenumFromTo :: Color -> Color -> [Color]
enumFromThen :: Color -> Color -> [Color]
$cenumFromThen :: Color -> Color -> [Color]
enumFrom :: Color -> [Color]
$cenumFrom :: Color -> [Color]
fromEnum :: Color -> Int
$cfromEnum :: Color -> Int
toEnum :: Int -> Color
$ctoEnum :: Int -> Color
pred :: Color -> Color
$cpred :: Color -> Color
succ :: Color -> Color
$csucc :: Color -> Color
Enum, Int -> Color -> ShowS
[Color] -> ShowS
Color -> String
(Int -> Color -> ShowS)
-> (Color -> String) -> ([Color] -> ShowS) -> Show Color
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Color] -> ShowS
$cshowList :: [Color] -> ShowS
show :: Color -> String
$cshow :: Color -> String
showsPrec :: Int -> Color -> ShowS
$cshowsPrec :: Int -> Color -> ShowS
Show, ReadPrec [Color]
ReadPrec Color
Int -> ReadS Color
ReadS [Color]
(Int -> ReadS Color)
-> ReadS [Color]
-> ReadPrec Color
-> ReadPrec [Color]
-> Read Color
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Color]
$creadListPrec :: ReadPrec [Color]
readPrec :: ReadPrec Color
$creadPrec :: ReadPrec Color
readList :: ReadS [Color]
$creadList :: ReadS [Color]
readsPrec :: Int -> ReadS Color
$creadsPrec :: Int -> ReadS Color
Read)

instance NFData Color where
   rnf :: Color -> ()
rnf Color
Red = ()
   rnf Color
_ = ()

{- |
Using 'show' and 'read' is not always a good choice
since they must format and parse Haskell expressions
which is not of much use to the outside world.
-}
instance Distr.CSVSymbol Color where
   cellFromSymbol :: Color -> String
cellFromSymbol = Color -> String
forall a. Show a => a -> String
show
   symbolFromCell :: String -> Maybe Color
symbolFromCell = String -> Maybe Color
forall a. Read a => String -> Maybe a
maybeRead


data State = StateRed | StateYellowRG | StateGreen | StateYellowGR
   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)

type StateSet = Shape.Enumeration State

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


type HMM = HMM.Discrete Color StateSet Double

{- |
>>> verifyRevelations hmm
[True,True]
-}
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
$ Double -> Double -> Double -> Double -> Vector StateSet Double
stateVector Double
2 Double
1 Double
2 Double
1,
      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.8 Double
0.0 Double
0.0 Double
0.2 Vector StateSet Double
-> [Vector StateSet Double] -> [Vector StateSet Double]
forall a. a -> [a] -> [a]
:
            Double -> Double -> Double -> Double -> Vector StateSet Double
stateVector Double
0.2 Double
0.8 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.2 Double
0.8 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.2 Double
0.8 Vector StateSet Double
-> [Vector StateSet Double] -> [Vector StateSet Double]
forall a. a -> [a] -> [a]
:
            [],
      distribution :: T (Discrete Color) StateSet Double
HMM.distribution =
         T [] (Color, Vector StateSet Double)
-> T (Discrete Color) StateSet Double
forall symbol sh prob.
(Ord symbol, C sh, Eq sh, Real prob) =>
T [] (symbol, Vector sh prob) -> T (Discrete symbol) sh prob
Distr.discreteFromList (T [] (Color, Vector StateSet Double)
 -> T (Discrete Color) StateSet Double)
-> T [] (Color, Vector StateSet Double)
-> T (Discrete Color) StateSet Double
forall a b. (a -> b) -> a -> b
$
            (Color
Red,    Double -> Double -> Double -> Double -> Vector StateSet Double
stateVector Double
1 Double
0 Double
0 Double
0) (Color, Vector StateSet Double)
-> [(Color, Vector StateSet Double)]
-> T [] (Color, Vector StateSet Double)
forall a (f :: * -> *). a -> f a -> T f a
!:
            (Color
Yellow, Double -> Double -> Double -> Double -> Vector StateSet Double
stateVector Double
0 Double
1 Double
0 Double
1) (Color, Vector StateSet Double)
-> [(Color, Vector StateSet Double)]
-> [(Color, Vector StateSet Double)]
forall a. a -> [a] -> [a]
:
            (Color
Green,  Double -> Double -> Double -> Double -> Vector StateSet Double
stateVector Double
0 Double
0 Double
1 Double
0) (Color, Vector StateSet Double)
-> [(Color, Vector StateSet Double)]
-> [(Color, Vector StateSet Double)]
forall a. a -> [a] -> [a]
:
            []
   }


{- |
>>> verifyRevelations hmmDisturbed
[True,True]
-}
hmmDisturbed :: HMM
hmmDisturbed :: HMM
hmmDisturbed =
   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
$ Double -> Double -> Double -> Double -> Vector StateSet Double
stateVector Double
1 Double
1 Double
1 Double
1,
      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.3 Double
0.2 Double
0.2 Double
0.3 Vector StateSet Double
-> [Vector StateSet Double] -> [Vector StateSet Double]
forall a. a -> [a] -> [a]
:
            Double -> Double -> Double -> Double -> Vector StateSet Double
stateVector Double
0.3 Double
0.3 Double
0.2 Double
0.2 Vector StateSet Double
-> [Vector StateSet Double] -> [Vector StateSet Double]
forall a. a -> [a] -> [a]
:
            Double -> Double -> Double -> Double -> Vector StateSet Double
stateVector Double
0.2 Double
0.3 Double
0.3 Double
0.2 Vector StateSet Double
-> [Vector StateSet Double] -> [Vector StateSet Double]
forall a. a -> [a] -> [a]
:
            Double -> Double -> Double -> Double -> Vector StateSet Double
stateVector Double
0.2 Double
0.2 Double
0.3 Double
0.3 Vector StateSet Double
-> [Vector StateSet Double] -> [Vector StateSet Double]
forall a. a -> [a] -> [a]
:
            [],
      distribution :: T (Discrete Color) StateSet Double
HMM.distribution =
         T [] (Color, Vector StateSet Double)
-> T (Discrete Color) StateSet Double
forall symbol sh prob.
(Ord symbol, C sh, Eq sh, Real prob) =>
T [] (symbol, Vector sh prob) -> T (Discrete symbol) sh prob
Distr.discreteFromList (T [] (Color, Vector StateSet Double)
 -> T (Discrete Color) StateSet Double)
-> T [] (Color, Vector StateSet Double)
-> T (Discrete Color) StateSet Double
forall a b. (a -> b) -> a -> b
$
            (Color
Red,    Double -> Double -> Double -> Double -> Vector StateSet Double
stateVector Double
0.6 Double
0.2 Double
0.2 Double
0.2) (Color, Vector StateSet Double)
-> [(Color, Vector StateSet Double)]
-> T [] (Color, Vector StateSet Double)
forall a (f :: * -> *). a -> f a -> T f a
!:
            (Color
Yellow, Double -> Double -> Double -> Double -> Vector StateSet Double
stateVector Double
0.2 Double
0.6 Double
0.2 Double
0.6) (Color, Vector StateSet Double)
-> [(Color, Vector StateSet Double)]
-> [(Color, Vector StateSet Double)]
forall a. a -> [a] -> [a]
:
            (Color
Green,  Double -> Double -> Double -> Double -> Vector StateSet Double
stateVector Double
0.2 Double
0.2 Double
0.6 Double
0.2) (Color, Vector StateSet Double)
-> [(Color, Vector StateSet Double)]
-> [(Color, Vector StateSet 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]


red, yellowRG, green, yellowGR :: (State, Color)
red :: (State, Color)
red      = (State
StateRed, Color
Red)
yellowRG :: (State, Color)
yellowRG = (State
StateYellowRG, Color
Yellow)
green :: (State, Color)
green    = (State
StateGreen, Color
Green)
yellowGR :: (State, Color)
yellowGR = (State
StateYellowGR, Color
Yellow)

labeledSequences :: NonEmpty.T [] (NonEmpty.T [] (State, Color))
labeledSequences :: T [] (T [] (State, Color))
labeledSequences =
   ((State, Color)
red (State, Color) -> [(State, Color)] -> T [] (State, Color)
forall a (f :: * -> *). a -> f a -> T f a
!: (State, Color)
red (State, Color) -> [(State, Color)] -> [(State, Color)]
forall a. a -> [a] -> [a]
: (State, Color)
red (State, Color) -> [(State, Color)] -> [(State, Color)]
forall a. a -> [a] -> [a]
: (State, Color)
red (State, Color) -> [(State, Color)] -> [(State, Color)]
forall a. a -> [a] -> [a]
:
    (State, Color)
yellowRG (State, Color) -> [(State, Color)] -> [(State, Color)]
forall a. a -> [a] -> [a]
: (State, Color)
yellowRG (State, Color) -> [(State, Color)] -> [(State, Color)]
forall a. a -> [a] -> [a]
:
    (State, Color)
green (State, Color) -> [(State, Color)] -> [(State, Color)]
forall a. a -> [a] -> [a]
: (State, Color)
green (State, Color) -> [(State, Color)] -> [(State, Color)]
forall a. a -> [a] -> [a]
: (State, Color)
green (State, Color) -> [(State, Color)] -> [(State, Color)]
forall a. a -> [a] -> [a]
: (State, Color)
green (State, Color) -> [(State, Color)] -> [(State, Color)]
forall a. a -> [a] -> [a]
: (State, Color)
green (State, Color) -> [(State, Color)] -> [(State, Color)]
forall a. a -> [a] -> [a]
:
    (State, Color)
yellowGR (State, Color) -> [(State, Color)] -> [(State, Color)]
forall a. a -> [a] -> [a]
:
    (State, Color)
red (State, Color) -> [(State, Color)] -> [(State, Color)]
forall a. a -> [a] -> [a]
: (State, Color)
red (State, Color) -> [(State, Color)] -> [(State, Color)]
forall a. a -> [a] -> [a]
: (State, Color)
red (State, Color) -> [(State, Color)] -> [(State, Color)]
forall a. a -> [a] -> [a]
:
    []) T [] (State, Color)
-> [T [] (State, Color)] -> T [] (T [] (State, Color))
forall a (f :: * -> *). a -> f a -> T f a
!:
   ((State, Color)
green (State, Color) -> [(State, Color)] -> T [] (State, Color)
forall a (f :: * -> *). a -> f a -> T f a
!: (State, Color)
green (State, Color) -> [(State, Color)] -> [(State, Color)]
forall a. a -> [a] -> [a]
: (State, Color)
green (State, Color) -> [(State, Color)] -> [(State, Color)]
forall a. a -> [a] -> [a]
:
    (State, Color)
yellowGR (State, Color) -> [(State, Color)] -> [(State, Color)]
forall a. a -> [a] -> [a]
:
    (State, Color)
red (State, Color) -> [(State, Color)] -> [(State, Color)]
forall a. a -> [a] -> [a]
: (State, Color)
red (State, Color) -> [(State, Color)] -> [(State, Color)]
forall a. a -> [a] -> [a]
: (State, Color)
red (State, Color) -> [(State, Color)] -> [(State, Color)]
forall a. a -> [a] -> [a]
: (State, Color)
red (State, Color) -> [(State, Color)] -> [(State, Color)]
forall a. a -> [a] -> [a]
:
    (State, Color)
yellowRG (State, Color) -> [(State, Color)] -> [(State, Color)]
forall a. a -> [a] -> [a]
:
    (State, Color)
green (State, Color) -> [(State, Color)] -> [(State, Color)]
forall a. a -> [a] -> [a]
: (State, Color)
green (State, Color) -> [(State, Color)] -> [(State, Color)]
forall a. a -> [a] -> [a]
: (State, Color)
green (State, Color) -> [(State, Color)] -> [(State, Color)]
forall a. a -> [a] -> [a]
: (State, Color)
green (State, Color) -> [(State, Color)] -> [(State, Color)]
forall a. a -> [a] -> [a]
: (State, Color)
green (State, Color) -> [(State, Color)] -> [(State, Color)]
forall a. a -> [a] -> [a]
:
    (State, Color)
yellowGR (State, Color) -> [(State, Color)] -> [(State, Color)]
forall a. a -> [a] -> [a]
: (State, Color)
yellowGR (State, Color) -> [(State, Color)] -> [(State, Color)]
forall a. a -> [a] -> [a]
:
    []) T [] (State, Color)
-> [T [] (State, Color)] -> [T [] (State, Color)]
forall a. a -> [a] -> [a]
:
   []

{- |
Construct a Hidden Markov model by watching a set
of manually created sequences of emissions and according states.

>>> verifyRevelations hmmTrainedSupervised
[True,True]
-}
hmmTrainedSupervised :: HMM
hmmTrainedSupervised :: HMM
hmmTrainedSupervised =
   (T [] (State, Color) -> Trained (Discrete Color) StateSet Double)
-> T [] (T [] (State, Color)) -> 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, Color) -> Trained (Discrete Color) 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, Color))
labeledSequences


stateSequences :: NonEmpty.T [] (NonEmpty.T [] Color)
stateSequences :: T [] (T [] Color)
stateSequences = (T [] (State, Color) -> T [] Color)
-> T [] (T [] (State, Color)) -> T [] (T [] Color)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((State, Color) -> Color) -> T [] (State, Color) -> T [] Color
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (State, Color) -> Color
forall a b. (a, b) -> b
snd) T [] (T [] (State, Color))
labeledSequences

{- |
Construct a Hidden Markov model starting from a known model
and a set of sequences that contain only the emissions, but no states.

>>> verifyRevelations hmmTrainedUnsupervised
[True,True]
-}
hmmTrainedUnsupervised :: HMM
hmmTrainedUnsupervised :: HMM
hmmTrainedUnsupervised =
   (T [] Color -> Trained (Discrete Color) StateSet Double)
-> T [] (T [] Color) -> 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 (HMM -> T [] Color -> Trained (Discrete Color) 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 [] (T [] Color)
stateSequences

{- |
Repeat unsupervised training until convergence.

prop> deepseq hmmIterativelyTrained True
-}
hmmIterativelyTrained :: HMM
hmmIterativelyTrained :: HMM
hmmIterativelyTrained =
   (Bool, HMM) -> HMM
forall a b. (a, b) -> b
snd ((Bool, HMM) -> HMM) -> (Bool, HMM) -> HMM
forall a b. (a -> b) -> a -> b
$ [(Bool, HMM)] -> (Bool, HMM)
forall a. [a] -> a
head ([(Bool, HMM)] -> (Bool, HMM)) -> [(Bool, HMM)] -> (Bool, HMM)
forall a b. (a -> b) -> a -> b
$ ((Bool, HMM) -> Bool) -> [(Bool, HMM)] -> [(Bool, HMM)]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Bool, HMM) -> Bool
forall a b. (a, b) -> a
fst ([(Bool, HMM)] -> [(Bool, HMM)]) -> [(Bool, HMM)] -> [(Bool, HMM)]
forall a b. (a -> b) -> a -> b
$
   (HMM -> HMM -> (Bool, HMM)) -> [HMM] -> [(Bool, HMM)]
forall a b. (a -> a -> b) -> [a] -> [b]
ListHT.mapAdjacent (\HMM
hmm0 HMM
hmm1 -> (HMM -> HMM -> Double
forall sh prob typ.
(C sh, Eq sh, Real prob) =>
T typ sh prob -> T typ sh prob -> prob
HMM.deviation HMM
hmm0 HMM
hmm1 Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
1e-5, HMM
hmm1)) ([HMM] -> [(Bool, HMM)]) -> [HMM] -> [(Bool, HMM)]
forall a b. (a -> b) -> a -> b
$
   (HMM -> HMM) -> HMM -> [HMM]
forall a. (a -> a) -> a -> [a]
iterate
      (((T [] Color -> Trained (Discrete Color) StateSet Double)
 -> T [] (T [] Color) -> HMM)
-> T [] (T [] Color)
-> (T [] Color -> Trained (Discrete Color) StateSet Double)
-> HMM
forall a b c. (a -> b -> c) -> b -> a -> c
flip (T [] Color -> Trained (Discrete Color) StateSet Double)
-> T [] (T [] Color) -> 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 T [] (T [] Color)
stateSequences ((T [] Color -> Trained (Discrete Color) StateSet Double) -> HMM)
-> (HMM -> T [] Color -> Trained (Discrete Color) StateSet Double)
-> HMM
-> HMM
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HMM -> T [] Color -> Trained (Discrete Color) 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
hmmDisturbed


verifyRevelation :: HMM -> NonEmpty.T [] (State, Color) -> Bool
verifyRevelation :: HMM -> T [] (State, Color) -> Bool
verifyRevelation HMM
model T [] (State, Color)
xs =
   ((State, Color) -> State) -> T [] (State, Color) -> T [] State
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (State, Color) -> State
forall a b. (a, b) -> a
fst T [] (State, Color)
xs T [] State -> T [] State -> Bool
forall a. Eq a => a -> a -> Bool
== HMM -> T [] Color -> 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
model (((State, Color) -> Color) -> T [] (State, Color) -> T [] Color
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (State, Color) -> Color
forall a b. (a, b) -> b
snd T [] (State, Color)
xs)