module Math.HiddenMarkovModel.Example.TrafficLight
where
import qualified Math.HiddenMarkovModel as HMM
import qualified Math.HiddenMarkovModel.Distribution as Distr
import qualified Data.Packed.Matrix as Matrix
import qualified Data.Packed.Vector as Vector
import Text.Read.HT (maybeRead)
import Control.Monad (liftM2)
import qualified Data.Map as Map
import qualified Data.NonEmpty as NonEmpty
import qualified Data.List.HT as ListHT
import Data.NonEmpty ((!:))
data Color = Red | Yellow | Green
deriving (Eq, Ord, Enum, Show, Read)
instance Distr.CSVSymbol Color where
cellFromSymbol = show
symbolFromCell = maybeRead
hmm :: HMM.Discrete Double Color
hmm =
HMM.Cons {
HMM.initial = Vector.fromList [1/3, 1/6, 1/3, 1/6],
HMM.transition =
Matrix.fromLists $
[0.8, 0.0, 0.0, 0.2] :
[0.2, 0.8, 0.0, 0.0] :
[0.0, 0.2, 0.8, 0.0] :
[0.0, 0.0, 0.2, 0.8] :
[],
HMM.distribution =
Distr.Discrete $ Map.fromList $
(Red, Vector.fromList [1,0,0,0]) :
(Yellow, Vector.fromList [0,1,0,1]) :
(Green, Vector.fromList [0,0,1,0]) :
[]
}
hmmDisturbed :: HMM.Discrete Double Color
hmmDisturbed =
HMM.Cons {
HMM.initial = Vector.fromList [1/4, 1/4, 1/4, 1/4],
HMM.transition =
Matrix.fromLists $
[0.3, 0.2, 0.2, 0.3] :
[0.3, 0.3, 0.2, 0.2] :
[0.2, 0.3, 0.3, 0.2] :
[0.2, 0.2, 0.3, 0.3] :
[],
HMM.distribution =
Distr.Discrete $ Map.fromList $
(Red, Vector.fromList [0.6, 0.2, 0.2, 0.2]) :
(Yellow, Vector.fromList [0.2, 0.6, 0.2, 0.6]) :
(Green, Vector.fromList [0.2, 0.2, 0.6, 0.2]) :
[]
}
red, yellowRG, green, yellowGR :: (HMM.State, Color)
red = (HMM.state 0, Red)
yellowRG = (HMM.state 1, Yellow)
green = (HMM.state 2, Green)
yellowGR = (HMM.state 3, Yellow)
labeledSequences :: NonEmpty.T [] (NonEmpty.T [] (HMM.State, Color))
labeledSequences =
(red !: red : red : red :
yellowRG : yellowRG :
green : green : green : green : green :
yellowGR :
red : red : red :
[]) !:
(green !: green : green :
yellowGR :
red : red : red : red :
yellowRG :
green : green : green : green : green :
yellowGR : yellowGR :
[]) :
[]
hmmTrainedSupervised :: HMM.Discrete Double Color
hmmTrainedSupervised =
HMM.trainMany (HMM.trainSupervised 4) labeledSequences
stateSequences :: NonEmpty.T [] (NonEmpty.T [] Color)
stateSequences = fmap (fmap snd) labeledSequences
hmmTrainedUnsupervised :: HMM.Discrete Double Color
hmmTrainedUnsupervised =
HMM.trainMany (HMM.trainUnsupervised hmm) stateSequences
hmmIterativelyTrained :: HMM.Discrete Double Color
hmmIterativelyTrained =
snd $ head $ dropWhile fst $
ListHT.mapAdjacent (\hmm0 hmm1 -> (HMM.deviation hmm0 hmm1 > 1e-5, hmm1)) $
iterate
(flip HMM.trainMany stateSequences . HMM.trainUnsupervised)
hmmDisturbed
verifyRevelation ::
HMM.Discrete Double Color -> NonEmpty.T [] (HMM.State, Color) -> Bool
verifyRevelation model xs =
fmap fst xs == HMM.reveal model (fmap snd xs)
verifyRevelations :: [Bool]
verifyRevelations =
liftM2 verifyRevelation
[hmm, hmmDisturbed, hmmTrainedSupervised, hmmTrainedUnsupervised]
(NonEmpty.flatten labeledSequences)