{-# LANGUAGE TypeFamilies #-}
{- |
This module provides a simple way to train
the transition matrix and initial probability vector
using simple patterns of state sequences.

You may create a trained model using semigroup combinators like this:

> example :: HMM.DiscreteTrained Char (ShapeStatic.ZeroBased TypeNum.U2) Double
> example =
>    let a = atom FL.i0
>        b = atom FL.i1
>        distr =
>           Distr.DiscreteTrained $ Map.fromList $
>           ('a', ShapeStatic.vector $ 1!:2!:FL.end) :
>           ('b', ShapeStatic.vector $ 4!:3!:FL.end) :
>           ('c', ShapeStatic.vector $ 0!:1!:FL.end) :
>           []
>    in finish (ShapeStatic.ZeroBased Proxy) distr $
>       replicate 5 $ replicate 10 a <> replicate 20 b
-}
module Math.HiddenMarkovModel.Pattern (
   T,
   atom,
   append,
   replicate,
   finish,
   ) where

import qualified Math.HiddenMarkovModel.Distribution as Distr
import qualified Math.HiddenMarkovModel as HMM
import Math.HiddenMarkovModel.Private (Trained(..))
import Math.HiddenMarkovModel.Utility (squareConstant)

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.Netlib.Class as Class

import qualified Data.Array.Comfort.Storable as StorableArray
import qualified Data.Array.Comfort.Shape.Static as ShapeStatic
import qualified Data.Array.Comfort.Shape as Shape

import qualified Data.FixedLength as FL
import Data.FixedLength ((!:))

import qualified Type.Data.Num.Unary.Literal as TypeNum

import qualified Data.NonEmpty.Map as NonEmptyMap
import qualified Data.NonEmpty as NonEmpty
import Data.Semigroup (Semigroup, (<>), stimes)

import Prelude hiding (replicate)


newtype T sh prob =
   Cons (sh -> (Shape.Index sh, Matrix.Square sh prob, Shape.Index sh))

atom ::
   (Shape.Indexed sh, Shape.Index sh ~ state, Class.Real prob) =>
   state -> T sh prob
atom :: state -> T sh prob
atom state
s = (sh -> (Index sh, Square sh prob, Index sh)) -> T sh prob
forall sh prob.
(sh -> (Index sh, Square sh prob, Index sh)) -> T sh prob
Cons ((sh -> (Index sh, Square sh prob, Index sh)) -> T sh prob)
-> (sh -> (Index sh, Square sh prob, Index sh)) -> T sh prob
forall a b. (a -> b) -> a -> b
$ \sh
sh -> (state
Index sh
s, sh -> prob -> Square sh prob
forall sh a. (C sh, Real a) => sh -> a -> Square sh a
squareConstant sh
sh prob
0, state
Index sh
s)


instance
   (Shape.Indexed sh, Eq sh, Class.Real prob) =>
      Semigroup (T sh prob) where
   <> :: T sh prob -> T sh prob -> T sh prob
(<>) = T sh prob -> T sh prob -> T sh prob
forall sh prob.
(Indexed sh, Eq sh, Real prob) =>
T sh prob -> T sh prob -> T sh prob
append
   stimes :: b -> T sh prob -> T sh prob
stimes b
k = Int -> T sh prob -> T sh prob
forall sh prob.
(Indexed sh, Real prob) =>
Int -> T sh prob -> T sh prob
replicate (Int -> T sh prob -> T sh prob) -> Int -> T sh prob -> T sh prob
forall a b. (a -> b) -> a -> b
$ b -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral b
k


infixl 5 `append`

append ::
   (Shape.Indexed sh, Eq sh, Class.Real prob) =>
   T sh prob -> T sh prob -> T sh prob
append :: T sh prob -> T sh prob -> T sh prob
append (Cons sh -> (Index sh, Square sh prob, Index sh)
f) (Cons sh -> (Index sh, Square sh prob, Index sh)
g) =
   (sh -> (Index sh, Square sh prob, Index sh)) -> T sh prob
forall sh prob.
(sh -> (Index sh, Square sh prob, Index sh)) -> T sh prob
Cons ((sh -> (Index sh, Square sh prob, Index sh)) -> T sh prob)
-> (sh -> (Index sh, Square sh prob, Index sh)) -> T sh prob
forall a b. (a -> b) -> a -> b
$ \sh
n ->
      case (sh -> (Index sh, Square sh prob, Index sh)
f sh
n, sh -> (Index sh, Square sh prob, Index sh)
g sh
n) of
         ((Index sh
sai, Square sh prob
ma, Index sh
sao), (Index sh
sbi, Square sh prob
mb, Index sh
sbo)) ->
            (Index sh
sai, (Index sh, Index sh) -> prob -> Square sh prob -> Square sh prob
forall sh state a.
(Indexed sh, Index sh ~ state, Real a) =>
(state, state) -> a -> Square sh a -> Square sh a
increment (Index sh
sbi,Index sh
sao) prob
1 (Square sh prob -> Square sh prob)
-> Square sh prob -> Square sh prob
forall a b. (a -> b) -> a -> b
$ Square sh prob -> Square sh prob -> Square sh prob
forall meas vert horiz property height width a pack lower upper.
(Measure meas, C vert, C horiz, Additive property, C height,
 Eq height, C width, Eq width, Floating a) =>
ArrayMatrix
  pack property lower upper meas vert horiz height width a
-> ArrayMatrix
     pack property lower upper meas vert horiz height width a
-> ArrayMatrix
     pack property lower upper meas vert horiz height width a
Matrix.add Square sh prob
ma Square sh prob
mb, Index sh
sbo)

replicate ::
   (Shape.Indexed sh, Class.Real prob) => Int -> T sh prob -> T sh prob
replicate :: Int -> T sh prob -> T sh prob
replicate Int
ki (Cons sh -> (Index sh, Square sh prob, Index sh)
f) =
   (sh -> (Index sh, Square sh prob, Index sh)) -> T sh prob
forall sh prob.
(sh -> (Index sh, Square sh prob, Index sh)) -> T sh prob
Cons ((sh -> (Index sh, Square sh prob, Index sh)) -> T sh prob)
-> (sh -> (Index sh, Square sh prob, Index sh)) -> T sh prob
forall a b. (a -> b) -> a -> b
$ \sh
sh ->
      case sh -> (Index sh, Square sh prob, Index sh)
f sh
sh of
         (Index sh
si, Square sh prob
m, Index sh
so) ->
            let k :: prob
k = Int -> prob
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
ki
            in  (Index sh
si, (Index sh, Index sh) -> prob -> Square sh prob -> Square sh prob
forall sh state a.
(Indexed sh, Index sh ~ state, Real a) =>
(state, state) -> a -> Square sh a -> Square sh a
increment (Index sh
si,Index sh
so) (prob
kprob -> prob -> prob
forall a. Num a => a -> a -> a
-prob
1) (Square sh prob -> Square sh prob)
-> Square sh prob -> Square sh prob
forall a b. (a -> b) -> a -> b
$ prob -> Square sh prob -> Square sh prob
forall meas vert horiz property height width a pack lower upper.
(Measure meas, C vert, C horiz, Scale property, C height, C width,
 Floating a) =>
a
-> ArrayMatrix
     pack property lower upper meas vert horiz height width a
-> ArrayMatrix
     pack property lower upper meas vert horiz height width a
Matrix.scale prob
k Square sh prob
m, Index sh
so)

increment ::
   (Shape.Indexed sh, Shape.Index sh ~ state, Class.Real a) =>
   (state, state) -> a -> Matrix.Square sh a -> Matrix.Square sh a
increment :: (state, state) -> a -> Square sh a -> Square sh a
increment (state
i,state
j) a
x =
   (PlainArray
   Unpacked Arbitrary Filled Filled Shape Small Small sh sh a
 -> PlainArray
      Unpacked Arbitrary Filled Filled Shape Small Small sh sh a)
-> Square sh a -> Square sh a
forall packA propA lowerA upperA measA vertA horizA heightA widthA
       packB propB lowerB upperB measB vertB horizB heightB widthB a b.
(ToPlain
   packA propA lowerA upperA measA vertA horizA heightA widthA,
 FromPlain
   packB propB lowerB upperB measB vertB horizB heightB widthB) =>
(PlainArray
   packA propA lowerA upperA measA vertA horizA heightA widthA a
 -> PlainArray
      packB propB lowerB upperB measB vertB horizB heightB widthB b)
-> ArrayMatrix
     packA propA lowerA upperA measA vertA horizA heightA widthA a
-> ArrayMatrix
     packB propB lowerB upperB measB vertB horizB heightB widthB b
ArrMatrix.lift1 ((PlainArray
    Unpacked Arbitrary Filled Filled Shape Small Small sh sh a
  -> PlainArray
       Unpacked Arbitrary Filled Filled Shape Small Small sh sh a)
 -> Square sh a -> Square sh a)
-> (PlainArray
      Unpacked Arbitrary Filled Filled Shape Small Small sh sh a
    -> PlainArray
         Unpacked Arbitrary Filled Filled Shape Small Small sh sh a)
-> Square sh a
-> Square sh a
forall a b. (a -> b) -> a -> b
$ (Array (Full Shape Small Small sh sh) a
 -> [((state, state), a)] -> Array (Full Shape Small Small sh sh) a)
-> [((state, state), a)]
-> Array (Full Shape Small Small sh sh) a
-> Array (Full Shape Small Small sh sh) a
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((a -> a -> a)
-> Array (Full Shape Small Small sh sh) a
-> [(Index (Full Shape Small Small sh sh), a)]
-> Array (Full Shape Small Small sh sh) a
forall sh a b.
(Indexed sh, Storable a) =>
(a -> b -> a) -> Array sh a -> [(Index sh, b)] -> Array sh a
StorableArray.accumulate a -> a -> a
forall a. Num a => a -> a -> a
(+)) [((state
i,state
j), a
x)]


finish ::
   (Distr.Info typ, Shape.Indexed sh, Class.Real prob) =>
   Distr.Trained typ sh prob -> T sh prob -> Trained typ sh prob
finish :: Trained typ sh prob -> T sh prob -> Trained typ sh prob
finish Trained typ sh prob
tdistr (Cons sh -> (Index sh, Square sh prob, Index sh)
f) =
   let sh :: sh
sh = Trained typ sh prob -> sh
forall typ sh prob. (Info typ, C sh) => Trained typ sh prob -> sh
Distr.statesShapeTrained Trained typ sh prob
tdistr
       (Index sh
si, Square sh prob
m, Index sh
_so) = sh -> (Index sh, Square sh prob, Index sh)
f sh
sh
   in Trained :: forall typ sh prob.
Vector sh prob
-> Square sh prob -> Trained typ sh prob -> Trained typ sh prob
Trained {
         trainedInitial :: Vector sh prob
trainedInitial = sh -> Index sh -> Vector sh prob
forall sh a.
(Indexed sh, Floating a) =>
sh -> Index sh -> Vector sh a
Vector.unit sh
sh Index sh
si,
         trainedTransition :: Square sh prob
trainedTransition = Square sh prob
m,
         trainedDistribution :: Trained typ sh prob
trainedDistribution = Trained typ sh prob
tdistr
      }


_example :: HMM.DiscreteTrained Char (ShapeStatic.ZeroBased TypeNum.U2) Double
_example :: DiscreteTrained Char (ZeroBased U2) Double
_example =
   let a :: T (ZeroBased U2) Double
a = Index U2 -> T (ZeroBased U2) Double
forall sh state prob.
(Indexed sh, Index sh ~ state, Real prob) =>
state -> T sh prob
atom Index U2
forall n. Index (GE1 n)
FL.i0
       b :: T (ZeroBased U2) Double
b = Index U2 -> T (ZeroBased U2) Double
forall sh state prob.
(Indexed sh, Index sh ~ state, Real prob) =>
state -> T sh prob
atom Index U2
forall n. Index (GE2 n)
FL.i1
       distr :: Trained (Discrete Char) (ZeroBased U2) Double
distr =
          T Char (Vector (ZeroBased U2) Double)
-> Trained (Discrete Char) (ZeroBased U2) Double
forall symbol sh prob.
T symbol (Vector sh prob) -> Trained (Discrete symbol) sh prob
Distr.DiscreteTrained (T Char (Vector (ZeroBased U2) Double)
 -> Trained (Discrete Char) (ZeroBased U2) Double)
-> T Char (Vector (ZeroBased U2) Double)
-> Trained (Discrete Char) (ZeroBased U2) Double
forall a b. (a -> b) -> a -> b
$ T [] (Char, Vector (ZeroBased U2) Double)
-> T Char (Vector (ZeroBased U2) Double)
forall k a. Ord k => T [] (k, a) -> T k a
NonEmptyMap.fromList (T [] (Char, Vector (ZeroBased U2) Double)
 -> T Char (Vector (ZeroBased U2) Double))
-> T [] (Char, Vector (ZeroBased U2) Double)
-> T Char (Vector (ZeroBased U2) Double)
forall a b. (a -> b) -> a -> b
$
          (Char
'a', T U2 Double -> Vector (ZeroBased U2) Double
forall n a.
(Natural n, Storable a) =>
T n a -> Array (ZeroBased n) a
ShapeStatic.vector (T U2 Double -> Vector (ZeroBased U2) Double)
-> T U2 Double -> Vector (ZeroBased U2) Double
forall a b. (a -> b) -> a -> b
$ Double
1Double -> T (Succ Zero) Double -> T U2 Double
forall a n. a -> T n a -> T (Succ n) a
!:Double
2Double -> T Zero Double -> T (Succ Zero) Double
forall a n. a -> T n a -> T (Succ n) a
!:T Zero Double
forall a. T Zero a
FL.end) (Char, Vector (ZeroBased U2) Double)
-> [(Char, Vector (ZeroBased U2) Double)]
-> T [] (Char, Vector (ZeroBased U2) Double)
forall a (f :: * -> *). a -> f a -> T f a
NonEmpty.!:
          (Char
'b', T U2 Double -> Vector (ZeroBased U2) Double
forall n a.
(Natural n, Storable a) =>
T n a -> Array (ZeroBased n) a
ShapeStatic.vector (T U2 Double -> Vector (ZeroBased U2) Double)
-> T U2 Double -> Vector (ZeroBased U2) Double
forall a b. (a -> b) -> a -> b
$ Double
4Double -> T (Succ Zero) Double -> T U2 Double
forall a n. a -> T n a -> T (Succ n) a
!:Double
3Double -> T Zero Double -> T (Succ Zero) Double
forall a n. a -> T n a -> T (Succ n) a
!:T Zero Double
forall a. T Zero a
FL.end) (Char, Vector (ZeroBased U2) Double)
-> [(Char, Vector (ZeroBased U2) Double)]
-> [(Char, Vector (ZeroBased U2) Double)]
forall a. a -> [a] -> [a]
:
          (Char
'c', T U2 Double -> Vector (ZeroBased U2) Double
forall n a.
(Natural n, Storable a) =>
T n a -> Array (ZeroBased n) a
ShapeStatic.vector (T U2 Double -> Vector (ZeroBased U2) Double)
-> T U2 Double -> Vector (ZeroBased U2) Double
forall a b. (a -> b) -> a -> b
$ Double
0Double -> T (Succ Zero) Double -> T U2 Double
forall a n. a -> T n a -> T (Succ n) a
!:Double
1Double -> T Zero Double -> T (Succ Zero) Double
forall a n. a -> T n a -> T (Succ n) a
!:T Zero Double
forall a. T Zero a
FL.end) (Char, Vector (ZeroBased U2) Double)
-> [(Char, Vector (ZeroBased U2) Double)]
-> [(Char, Vector (ZeroBased U2) Double)]
forall a. a -> [a] -> [a]
:
          []
   in Trained (Discrete Char) (ZeroBased U2) Double
-> T (ZeroBased U2) Double
-> DiscreteTrained Char (ZeroBased U2) Double
forall typ sh prob.
(Info typ, Indexed sh, Real prob) =>
Trained typ sh prob -> T sh prob -> Trained typ sh prob
finish Trained (Discrete Char) (ZeroBased U2) Double
distr (T (ZeroBased U2) Double
 -> DiscreteTrained Char (ZeroBased U2) Double)
-> T (ZeroBased U2) Double
-> DiscreteTrained Char (ZeroBased U2) Double
forall a b. (a -> b) -> a -> b
$ Int -> T (ZeroBased U2) Double -> T (ZeroBased U2) Double
forall sh prob.
(Indexed sh, Real prob) =>
Int -> T sh prob -> T sh prob
replicate Int
5 (T (ZeroBased U2) Double -> T (ZeroBased U2) Double)
-> T (ZeroBased U2) Double -> T (ZeroBased U2) Double
forall a b. (a -> b) -> a -> b
$ Int -> T (ZeroBased U2) Double -> T (ZeroBased U2) Double
forall sh prob.
(Indexed sh, Real prob) =>
Int -> T sh prob -> T sh prob
replicate Int
10 T (ZeroBased U2) Double
a T (ZeroBased U2) Double
-> T (ZeroBased U2) Double -> T (ZeroBased U2) Double
forall a. Semigroup a => a -> a -> a
<> Int -> T (ZeroBased U2) Double -> T (ZeroBased U2) Double
forall sh prob.
(Indexed sh, Real prob) =>
Int -> T sh prob -> T sh prob
replicate Int
20 T (ZeroBased U2) Double
b