{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeOperators #-}
module Markov.Example
( FromLists (..)
, Simple (..)
, Urn (..)
, Extinction (..)
, Tidal (..)
, Room (..)
, FillBin
, initial
, expectedLoss
) where
import Markov
import Markov.Extra
import qualified Markov.Generic as MG
newtype FromLists = FromLists Char
deriving newtype (Eq, Ord, Show)
instance Combine FromLists where combine = const
instance Markov ((,) (Product Double)) FromLists where
transition = let mat = [ [0.4, 0.3, 0.3]
, [0.2, 0.1, 0.7]
, [0.9, 0.1, 0.0] ]
chars = map FromLists ['a','t','l']
in fromLists mat chars
newtype Simple = Simple Int
deriving newtype (Num, Enum, Eq, Ord, Show)
instance Combine Simple where combine = const
instance Markov0 Simple where
transition0 _ = [pred, succ]
instance Markov ((,) (Product Double)) Simple where
transition _ = [ 0.5 >*< pred
, 0.5 >*< succ ]
instance Markov ((,) (Product Int)) Simple where
transition _ = [ 1 >*< pred
, 1 >*< succ ]
instance Markov ((,) (Sum Int)) Simple where
transition _ = [ 1 >*< pred
, 0 >*< id
, 0 >*< succ ]
newtype Urn = Urn (Int,Int)
deriving newtype (Eq, Ord, Show)
instance Combine Urn where combine = const
instance Markov ((,) (Product Double)) Urn where
transition x = [ probLeft x >*< addLeft
, 1 - probLeft x >*< addRight ]
instance MG.Markov [] ((,) (Product Double)) Urn where
transition x = [ probLeft x >*< addLeft
, 1 - probLeft x >*< addRight ]
addLeft :: Urn -> Urn
addLeft (Urn (a,b)) = Urn (a+1,b)
addRight :: Urn -> Urn
addRight (Urn (a,b)) = Urn (a,b+1)
probLeft :: Fractional a => Urn -> a
probLeft (Urn (a,b)) = fromIntegral a / fromIntegral (a + b)
newtype Extinction = Extinction Int
deriving newtype (Eq, Num, Show)
instance Combine Extinction where combine = const
instance Markov ((,) (Sum Int, Product Rational)) Extinction where
transition = \case
0 -> [ 0 >*< (q+r) >*< id
, 0 >*< s >*< (+) 1 ]
_ -> [ 1 >*< q >*< const 0
, 0 >*< r >*< id
, 0 >*< s >*< (+) 1 ]
where q = 0.1; r = 0.3; s = 0.6
data Tidal = Tidal { time :: Double
, position :: Int }
deriving (Eq, Ord, Show)
instance Combine Tidal where combine = const
instance Markov ((,) (Product Double)) Tidal where
transition tw = [ probRight tw >*< stepPos (+1)
, 1 - probRight tw >*< stepPos (flip (-) 1) ]
stepPos :: (Int -> Int) -> Tidal -> Tidal
stepPos f tw = Tidal (time tw + 1) (f $ position tw)
probRight :: Tidal -> Product Double
probRight tw = Product $ timeBias * positionBias
where timeBias = (1 + sin (2 * pi * time tw / stepsPerCycle))/2
positionBias
| position tw >= 0 = 1 / steepness
| otherwise = 1
stepsPerCycle = 10
steepness = 1.3
newtype Room = Room Int
deriving Show
deriving newtype (Eq, Num, Ord)
instance Combine Room where combine = const
instance Markov ((,) (Product Rational, Merge String)) Room where
sequential = [giveToken, changeState]
where changeState = \case
1 -> [ 0.3 >*< mempty >*< const 1
, 0.6 >*< mempty >*< const 2
, 0.1 >*< mempty >*< const 3 ]
2 -> [ 1.0 >*< mempty >*< const 3 ]
3 -> [ 0.3 >*< mempty >*< const 1
, 0.6 >*< mempty >*< const 2
, 0.1 >*< mempty >*< const 3 ]
_ -> error "State out of bounds in transition"
giveToken = \case
1 -> [ 0.5 >*< Merge "a" >*< const 1
, 0.5 >*< Merge "b" >*< const 1 ]
2 -> [ 0.3 >*< Merge "a" >*< const 2
, 0.7 >*< Merge "b" >*< const 2 ]
3 -> [ 0.4 >*< Merge "a" >*< const 3
, 0.4 >*< Merge "b" >*< const 3
, 0.2 >*< Merge "c" >*< const 3 ]
_ -> error "State out of bounds in transition"
type Bin = (Open,Full)
type Index = Int
type Gap = Int
type Full = Int
type Open = Int
type Trans = FillBin -> FillBin
data FillBin = End Gap | Ext Gap Bin FillBin deriving (Eq, Ord)
instance Show FillBin where
show (Ext g b s) = show g ++ " " ++ show b ++ " " ++ show s
show (End g) = show g
instance Combine FillBin where combine = const
instance Markov ((,) (Product Double)) FillBin where
transition x = case probId x of
0 -> filter (\(Product y,_) -> y /= 0)
$ [probAdd i x >*< addItem i | i <- indices]
++ [probGrowL i x >*< addItem i . growLeft j i
| i <- indices, j <- [1..gapN (i-1) x]]
++ [probGrowR i x >*< addItem i . growRight j i
| i <- indices, j <- [1..gapN i x]]
1 -> [pure id]
_ -> error "Pattern not matched in transition"
where indices = [1..size x]
fBFromLists :: [Gap] -> [Bin] -> FillBin
fBFromLists gaps bins = case (gaps,bins) of
(g:_ , [] ) -> End g
([g] , _ ) -> End g
(g:gs , b:bs) -> Ext g b $ fBFromLists gs bs
([] , _ ) -> End 0
initial :: [Int] -> FillBin
initial gs = fBFromLists gs $ repeat (0,0)
size :: FillBin -> Int
size = \case
End _ -> 0
Ext _ _ s -> 1 + size s
getBins :: FillBin -> [Bin]
getBins = \case
End _ -> []
Ext _ b s -> b:getBins s
getOpen :: FillBin -> [Open]
getOpen x = map fst $ getBins x
openN :: Index -> FillBin -> Open
openN i x = getOpen x !!(i-1)
getFull :: FillBin -> [Full]
getFull x = map snd $ getBins x
fullN :: Index -> FillBin -> Full
fullN i x = getFull x !!(i-1)
getGap :: FillBin -> [Gap]
getGap = \case
End g -> [g]
Ext g _ s -> g:getGap s
gapN :: Index -> FillBin -> Gap
gapN i x = getGap x !! i
iApply :: Trans -> Index -> Trans
iApply f idx x = case (idx,x) of
(1, y) -> f y
(i, Ext g b s) -> Ext g b $ iApply f (i-1) s
_ -> error "Pattern not matched in iApply"
addItem :: Index -> Trans
addItem = iApply h
where h (Ext g (o,f) s) = Ext g (o-1,f+1) s
h _ = error "pattern not matched in h in addItem"
growLeft :: Int -> Index -> Trans
growLeft j = iApply h
where h (Ext g (o,f) s) = Ext (g-j) (o+j,f) s
h _ = error "pattern not matched in h in growLeft"
growRight :: Int -> Index -> Trans
growRight j = iApply h
where h (Ext g (o,f) s) = Ext g (o+j,f) (shrink s)
h _ = error "pattern not matched in h in growRight"
shrink = \case
End g -> End (g-j)
Ext g b t -> Ext (g-j) b t
slots :: FillBin -> Int
slots x = sum $ getGap x ++ getOpen x
probId :: Num a => FillBin -> a
probId x
| slots x == 0 = 1
| otherwise = 0
divInt :: Fractional a => Int -> Int -> a
divInt x y = fromIntegral x / fromIntegral y
probAdd :: Fractional a => Index -> FillBin -> a
probAdd i x = openN i x `divInt` slots x
probGrowL :: Fractional a => Index -> FillBin -> a
probGrowL i x
| test = 1 `divInt` slots x
| otherwise = 0
where test = i == 1 || fullN i x < fullN (i-1) x
probGrowR :: Fractional a => Index -> FillBin -> a
probGrowR i x
| test = 1 `divInt` slots x
| otherwise = 0
where test = i == size x || fullN i x <= fullN (i+1) x
individualLoss :: Fractional a => FillBin -> a
individualLoss x = sum . map f . getFull $ x
where f y = (fromIntegral y - ideal)^2
ideal = sum (getFull x) `divInt` size x
probLoss :: Fractional a => (Product a, FillBin) -> a
probLoss (Product x, y) = x * individualLoss y
expectedLoss :: (Fractional a, Markov ((,) (Product a)) FillBin)
=> [Product a :* FillBin] -> a
expectedLoss xs = sum . map probLoss $ chain xs !! idx
where idx = slots . snd . head $ xs