Haskell implementations of Hidden Markov Models & related algorithms from AIMA book
CHMM implementation for Swarm Robotics use case
+34
-25
+19
-1
src/cHMM.hs
+19
-1
src/cHMM.hs
···
1
1
{-# LANGUAGE DataKinds #-}
2
2
{-# LANGUAGE TypeOperators #-}
3
3
{-# LANGUAGE RankNTypes #-}
4
+
{-# LANGUAGE ScopedTypeVariables #-}
4
5
---------------------------------
5
6
-- |
6
7
-- Module : CHMM
···
15
16
16
17
import Papa
17
18
import GHC.TypeNats
18
-
import Data.Proxy
19
+
import Data.Proxy (Proxy(..))
19
20
import Linear.V
20
21
import Combinatorics
21
22
import qualified Data.Vector as Vec
22
23
24
+
import HMM
23
25
-----------------------
24
26
25
27
trajectory :: forall n t a . (KnownNat n, KnownNat t) => Proxy t -> V n a -> V (n ^ t) (V n a)
···
27
29
where
28
30
t' = fromIntegral $ natVal p
29
31
32
+
runCHMMInfer :: [Int] -> Int -> R
33
+
runCHMMInfer evs l = let v = Vec.fromList [0 .. dim (swarmRobotsHMM ^. tModel) - 1]
34
+
n = length evs
35
+
in
36
+
reifyDimNat n $ \t' ->
37
+
reifyVectorNat v $ \n' ->
38
+
let ts = trajectory t' n'
39
+
valid_ts = V $ Vec.filter (Vec.all (>=l) . toVector) $ toVector ts
40
+
in
41
+
sum $ cHMMInfer swarmRobotsHMM (V $ Vec.fromList evs) <$> valid_ts
42
+
43
+
44
+
45
+
46
+
47
+
+15
-24
src/hmm.hs
+15
-24
src/hmm.hs
···
15
15
16
16
module HMM where
17
17
18
-
import Prelude (undefined)
19
-
import System.IO (print)
20
18
import Text.Printf (printf)
21
19
22
20
import Papa
···
232
230
t += 1
233
231
mzero
234
232
235
-
-- ** [/WIP/] Cost based HMM(cHMM)
233
+
-- ** Cost based HMM(cHMM)
236
234
-- Inference algo from cost-HMM paper
237
-
238
235
cHMMInfer :: forall s u t b i. (KnownNat s, KnownNat u, KnownNat t, Eq b, Ord b, Integral i, Show i, Show b)
239
236
=> HMM s u R b -- ^ HMM model
240
-
-> V t i -- ^ state trajectory for time @1 .. t@; represented as @0@-based index of state
241
237
-> V t b -- ^ evidence/observation trajectory for time @1 .. t@
242
-
-> IO R
243
-
cHMMInfer hmm xs evs = do
244
-
let r = (\x y z -> (x * y) / z) <$> y0 <*> y1 <*> y2 $ zs
245
-
print zs
246
-
print $ y0 zs
247
-
print $ y1 zs
248
-
return r
238
+
-> V t i -- ^ state trajectory for time @1 .. t@; represented as @0@-based index of state
239
+
-> R
240
+
cHMMInfer hmm evs xs = (\x y z -> (x * y) / z) <$> y0 <*> y1 <*> y2 $ zs
249
241
where
250
242
y0 :: Vec.Vector (i, b) -> R
251
243
y0 = foldl' (\m (s,o') ->
···
258
250
m *
259
251
bool
260
252
(hmm ^?! tModel . ix (vs ^?! ix (idx - 1) . _1 . to fromIntegral) . ix (fromIntegral s))
261
-
(((Linear.transpose $ hmm ^. prior) !*! hmm ^. tModel) ^?! ix 0 . ix (fromIntegral s))
253
+
((Linear.transpose (hmm ^. prior) !*! hmm ^. tModel) ^?! ix 0 . ix (fromIntegral s))
262
254
(idx == 0))
263
255
1 vs
264
256
···
277
269
zs = Vec.zip (toVector xs) (toVector evs)
278
270
279
271
-- * Sample HMM Models
280
-
281
272
umbrellaHMM :: HMM 2 2 R Bool
282
273
umbrellaHMM = mkHMM1 (V2 (V2 0.7 0.3) (V2 0.3 0.7)) (V2 (V2 0.9 0.2) (V2 0.1 0.8))
283
-
274
+
284
275
swarmRobotsHMM :: HMM 4 4 R Int
285
276
swarmRobotsHMM = mkHMM_
286
277
(Just $ V $ Vec.replicate 4 (toV $ V1 0.25))
287
278
(V $ Vec.fromList
288
279
[
289
-
(V $ Vec.fromList [0.7393859 , 0.2233470 , 0.0330670 , 0.0042001]),
290
-
(V $ Vec.fromList [0.0928202 , 0.7172515 , 0.1719556 , 0.0179727]),
291
-
(V $ Vec.fromList [0.0139341 , 0.1755173 , 0.6936519 , 0.1168966]),
292
-
(V $ Vec.fromList [0.0047083 , 0.0403520 , 0.2561893 , 0.6987504])
280
+
V $ Vec.fromList [0.7393859 , 0.2233470 , 0.0330670 , 0.0042001],
281
+
V $ Vec.fromList [0.0928202 , 0.7172515 , 0.1719556 , 0.0179727],
282
+
V $ Vec.fromList [0.0139341 , 0.1755173 , 0.6936519 , 0.1168966],
283
+
V $ Vec.fromList [0.0047083 , 0.0403520 , 0.2561893 , 0.6987504]
293
284
])
294
285
(V $ Vec.fromList [1..4])
295
-
(Linear.transpose $ (V $ Vec.fromList
286
+
(Linear.transpose (V $ Vec.fromList
296
287
[
297
-
(V $ Vec.fromList [1.00000, 0.00000, 0.00000, 0.00000]),
298
-
(V $ Vec.fromList [0.10000, 0.90000, 0.00000, 0.00000]),
299
-
(V $ Vec.fromList [0.01000, 0.18000, 0.81000, 0.00000]),
300
-
(V $ Vec.fromList [0.00100, 0.02700, 0.24300, 0.72900])
288
+
V $ Vec.fromList [1.00000, 0.00000, 0.00000, 0.00000],
289
+
V $ Vec.fromList [0.10000, 0.90000, 0.00000, 0.00000],
290
+
V $ Vec.fromList [0.01000, 0.18000, 0.81000, 0.00000],
291
+
V $ Vec.fromList [0.00100, 0.02700, 0.24300, 0.72900]
301
292
]))
302
293
303
294
-- * Main