{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
module Test.StateMachine.Markov
( Markov
, makeMarkov
, toAdjacencyMap
, (-<)
, (>-)
, (/-)
, markovGenerator
, coverMarkov
, tabulateMarkov
, transitionMatrix
, stimulusMatrix
, historyObservations
, markovToDot
, markovToPs
, StatsDb(..)
, PropertyName
, nullStatsDb
, fileStatsDb
, persistStats
, computeReliability
, printReliability
, quickCheckReliability
, testChainToDot
)
where
import Control.Arrow
((&&&))
import Data.Bifunctor
(bimap)
import Data.Either
(partitionEithers)
import Data.List
(genericLength)
import qualified Data.Set as Set
import Data.Map
(Map)
import qualified Data.Map as Map
import Data.Matrix
(Matrix, elementwise, fromLists, matrix, ncols,
nrows, submatrix, toLists, zero, getElem)
import Data.Maybe
(fromMaybe)
import Generic.Data
(FiniteEnum, GBounded, GEnum, gfiniteEnumFromTo,
gmaxBound, gminBound, gtoFiniteEnum, gfromFiniteEnum)
import GHC.Generics
(Generic, Rep)
import Prelude hiding
(readFile)
import System.Directory
(removeFile)
import System.FilePath.Posix
(replaceExtension)
import System.IO
(IOMode(ReadWriteMode), hGetContents, openFile)
import System.Process
(callProcess)
import Test.QuickCheck
(Gen, Property, Testable, coverTable, frequency,
property, quickCheck, tabulate)
import Test.QuickCheck.Monadic
(PropertyM, run)
import Test.QuickCheck.Property
(Callback(PostTest),
CallbackKind(NotCounterexample), callback)
import Text.Read
(readMaybe)
import MarkovChain
import Test.StateMachine.Logic
(boolean)
import Test.StateMachine.Types
(Command, Commands, Counter, History, Operation(..),
StateMachine(..), getCommand, makeOperations,
newCounter, unCommands, unHistory)
import Test.StateMachine.Types.GenSym
(runGenSym)
import Test.StateMachine.Types.References
(Concrete, Symbolic)
newtype Markov state cmd_ prob = Markov
{ forall state cmd_ prob.
Markov state cmd_ prob -> Map state [Transition state cmd_ prob]
unMarkov :: Map state [Transition state cmd_ prob] }
data Transition state cmd_ prob = Transition
{ forall state cmd_ prob. Transition state cmd_ prob -> cmd_
command :: cmd_
, forall state cmd_ prob. Transition state cmd_ prob -> prob
probability :: prob
, forall state cmd_ prob. Transition state cmd_ prob -> state
to :: state
}
makeMarkov :: Ord state
=> [Map state [Transition state cmd_ prob]] -> Markov state cmd_ prob
makeMarkov :: forall state cmd_ prob.
Ord state =>
[Map state [Transition state cmd_ prob]] -> Markov state cmd_ prob
makeMarkov = forall state cmd_ prob.
Map state [Transition state cmd_ prob] -> Markov state cmd_ prob
Markov forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions
toAdjacencyMap
:: Ord state
=> Markov state cmd_ prob
-> Map state (Map state (cmd_, prob))
toAdjacencyMap :: forall state cmd_ prob.
Ord state =>
Markov state cmd_ prob -> Map state (Map state (cmd_, prob))
toAdjacencyMap (Markov Map state [Transition state cmd_ prob]
m) =
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall {k} {a} {b}.
Ord k =>
Transition k a b -> Map k (a, b) -> Map k (a, b)
f forall a. Monoid a => a
mempty) Map state [Transition state cmd_ prob]
m
where
f :: Transition k a b -> Map k (a, b) -> Map k (a, b)
f Transition{k
a
b
to :: k
probability :: b
command :: a
to :: forall state cmd_ prob. Transition state cmd_ prob -> state
probability :: forall state cmd_ prob. Transition state cmd_ prob -> prob
command :: forall state cmd_ prob. Transition state cmd_ prob -> cmd_
..} = forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert k
to (a
command, b
probability)
infixl 5 -<
(-<) :: Fractional prob
=> state -> [Either (cmd_, state) ((cmd_, prob), state)]
-> Map state [Transition state cmd_ prob]
state
from -< :: forall prob state cmd_.
Fractional prob =>
state
-> [Either (cmd_, state) ((cmd_, prob), state)]
-> Map state [Transition state cmd_ prob]
-< [Either (cmd_, state) ((cmd_, prob), state)]
es = forall k a. k -> a -> Map k a
Map.singleton state
from (forall a b. (a -> b) -> [a] -> [b]
map forall {cmd_} {state}.
Either (cmd_, state) ((cmd_, prob), state)
-> Transition state cmd_ prob
go [Either (cmd_, state) ((cmd_, prob), state)]
es)
where
go :: Either (cmd_, state) ((cmd_, prob), state)
-> Transition state cmd_ prob
go (Left (cmd_
command, state
to)) = forall state cmd_ prob.
cmd_ -> prob -> state -> Transition state cmd_ prob
Transition cmd_
command prob
uniform state
to
go (Right ((cmd_
command, prob
probability), state
to)) = Transition {prob
state
cmd_
to :: state
probability :: prob
command :: cmd_
to :: state
probability :: prob
command :: cmd_
..}
([(cmd_, state)]
ls, [((cmd_, prob), state)]
rs) = forall a b. [Either a b] -> ([a], [b])
partitionEithers [Either (cmd_, state) ((cmd_, prob), state)]
es
uniform :: prob
uniform = (prob
100 forall a. Num a => a -> a -> a
- forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [((cmd_, prob), state)]
rs))) forall a. Fractional a => a -> a -> a
/ forall i a. Num i => [a] -> i
genericLength [(cmd_, state)]
ls
infixl 5 >-
(>-) :: (cmd_, prob) -> state -> Either (cmd_, state) ((cmd_, prob), state)
(cmd_
cmd, prob
prob) >- :: forall cmd_ prob state.
(cmd_, prob) -> state -> Either (cmd_, state) ((cmd_, prob), state)
>- state
state = forall a b. b -> Either a b
Right ((cmd_
cmd, prob
prob), state
state)
infixl 5 /-
(/-) :: cmd_ -> state -> Either (cmd_, state) ((cmd_, prob), state)
cmd_
cmd /- :: forall cmd_ state prob.
cmd_ -> state -> Either (cmd_, state) ((cmd_, prob), state)
/- state
state = forall a b. a -> Either a b
Left (cmd_
cmd, state
state)
markovGenerator :: forall state cmd_ cmd model. (Show state, Show cmd_)
=> (Ord state, Ord cmd_)
=> Markov state cmd_ Double
-> Map cmd_ (model Symbolic -> Gen (cmd Symbolic))
-> (model Symbolic -> state)
-> (state -> Bool)
-> (model Symbolic -> Maybe (Gen (cmd Symbolic)))
markovGenerator :: forall state cmd_ (cmd :: (* -> *) -> *) (model :: (* -> *) -> *).
(Show state, Show cmd_, Ord state, Ord cmd_) =>
Markov state cmd_ Double
-> Map cmd_ (model Symbolic -> Gen (cmd Symbolic))
-> (model Symbolic -> state)
-> (state -> Bool)
-> model Symbolic
-> Maybe (Gen (cmd Symbolic))
markovGenerator Markov state cmd_ Double
markov Map cmd_ (model Symbolic -> Gen (cmd Symbolic))
gens model Symbolic -> state
partition state -> Bool
isSink model Symbolic
model
| state -> Bool
isSink (model Symbolic -> state
partition model Symbolic
model) = forall a. Maybe a
Nothing
| Bool
otherwise = forall a. a -> Maybe a
Just (forall a. [(Int, Gen a)] -> Gen a
frequency (state -> [(Int, Gen (cmd Symbolic))]
go (model Symbolic -> state
partition model Symbolic
model)))
where
go :: state -> [(Int, Gen (cmd Symbolic))]
go :: state -> [(Int, Gen (cmd Symbolic))]
go state
state
= forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (RealFrac a, Integral b) => a -> b
round forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall state cmd_ prob. Transition state cmd_ prob -> prob
probability
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& (\cmd_
cmd_ -> forall a. a -> Maybe a -> a
fromMaybe (forall {a} {a}. Show a => a -> a
errMissing cmd_
cmd_) (forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup cmd_
cmd_ Map cmd_ (model Symbolic -> Gen (cmd Symbolic))
gens) model Symbolic
model) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall state cmd_ prob. Transition state cmd_ prob -> cmd_
command)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a -> a
fromMaybe forall {a}. a
errDeadlock
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup state
state
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall state cmd_ prob.
Markov state cmd_ prob -> Map state [Transition state cmd_ prob]
unMarkov
forall a b. (a -> b) -> a -> b
$ Markov state cmd_ Double
markov
where
errDeadlock :: a
errDeadlock = forall a. HasCallStack => [Char] -> a
error
([Char]
"markovGenerator: deadlock, no commands can be generated in given state: "
forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show state
state)
errMissing :: a -> a
errMissing a
cmd_ = forall a. HasCallStack => [Char] -> a
error
([Char]
"markovGenerator: don't know how to generate the command: "
forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show a
cmd_)
coverMarkov :: (Show state, Show cmd_, Testable prop)
=> Markov state cmd_ Double -> prop -> Property
coverMarkov :: forall state cmd_ prop.
(Show state, Show cmd_, Testable prop) =>
Markov state cmd_ Double -> prop -> Property
coverMarkov Markov state cmd_ Double
markov prop
prop = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall {prop} {a} {state} {cmd_}.
(Testable prop, Show a, Show state, Show cmd_) =>
(a, [Transition state cmd_ Double]) -> prop -> Property
go (forall prop. Testable prop => prop -> Property
property prop
prop) (forall k a. Map k a -> [(k, a)]
Map.toList (forall state cmd_ prob.
Markov state cmd_ prob -> Map state [Transition state cmd_ prob]
unMarkov Markov state cmd_ Double
markov))
where
go :: (a, [Transition state cmd_ Double]) -> prop -> Property
go (a
from, [Transition state cmd_ Double]
ts) prop
ih =
forall prop.
Testable prop =>
[Char] -> [([Char], Double)] -> prop -> Property
coverTable (forall a. Show a => a -> [Char]
show a
from)
(forall a b. (a -> b) -> [a] -> [b]
map (\Transition{state
cmd_
Double
to :: state
probability :: Double
command :: cmd_
to :: forall state cmd_ prob. Transition state cmd_ prob -> state
probability :: forall state cmd_ prob. Transition state cmd_ prob -> prob
command :: forall state cmd_ prob. Transition state cmd_ prob -> cmd_
..} -> (forall state cmd_.
(Show state, Show cmd_) =>
cmd_ -> state -> [Char]
toTransitionString cmd_
command state
to, Double
probability)) [Transition state cmd_ Double]
ts) prop
ih
toTransitionString :: (Show state, Show cmd_) => cmd_ -> state -> String
toTransitionString :: forall state cmd_.
(Show state, Show cmd_) =>
cmd_ -> state -> [Char]
toTransitionString cmd_
cmd state
to = [Char]
"-< " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show cmd_
cmd forall a. [a] -> [a] -> [a]
++ [Char]
" >- " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show state
to
tabulateMarkov :: forall model state cmd cmd_ m resp prop. Testable prop
=> (Show state, Show cmd_)
=> StateMachine model cmd m resp
-> (model Symbolic -> state)
-> (cmd Symbolic -> cmd_)
-> Commands cmd resp
-> prop
-> Property
tabulateMarkov :: forall (model :: (* -> *) -> *) state (cmd :: (* -> *) -> *) cmd_
(m :: * -> *) (resp :: (* -> *) -> *) prop.
(Testable prop, Show state, Show cmd_) =>
StateMachine model cmd m resp
-> (model Symbolic -> state)
-> (cmd Symbolic -> cmd_)
-> Commands cmd resp
-> prop
-> Property
tabulateMarkov StateMachine model cmd m resp
sm model Symbolic -> state
partition cmd Symbolic -> cmd_
constructor Commands cmd resp
cmds0 =
forall prob.
[(state, Transition state cmd_ prob)] -> prop -> Property
tabulateTransitions (StateMachine model cmd m resp
-> Commands cmd resp -> [(state, Transition state cmd_ ())]
commandsToTransitions StateMachine model cmd m resp
sm Commands cmd resp
cmds0)
where
tabulateTransitions :: [(state, Transition state cmd_ prob)]
-> prop
-> Property
tabulateTransitions :: forall prob.
[(state, Transition state cmd_ prob)] -> prop -> Property
tabulateTransitions [(state, Transition state cmd_ prob)]
ts prop
prop = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall {prop} {a} {state} {cmd_} {prob}.
(Testable prop, Show a, Show state, Show cmd_) =>
(a, Transition state cmd_ prob) -> prop -> Property
go (forall prop. Testable prop => prop -> Property
property prop
prop) [(state, Transition state cmd_ prob)]
ts
where
go :: (a, Transition state cmd_ prob) -> prop -> Property
go (a
from, Transition {prob
state
cmd_
to :: state
probability :: prob
command :: cmd_
to :: forall state cmd_ prob. Transition state cmd_ prob -> state
probability :: forall state cmd_ prob. Transition state cmd_ prob -> prob
command :: forall state cmd_ prob. Transition state cmd_ prob -> cmd_
..}) prop
ih =
forall prop.
Testable prop =>
[Char] -> [[Char]] -> prop -> Property
tabulate (forall a. Show a => a -> [Char]
show a
from) [ forall state cmd_.
(Show state, Show cmd_) =>
cmd_ -> state -> [Char]
toTransitionString cmd_
command state
to ] prop
ih
commandsToTransitions :: StateMachine model cmd m resp
-> Commands cmd resp
-> [(state, Transition state cmd_ ())]
commandsToTransitions :: StateMachine model cmd m resp
-> Commands cmd resp -> [(state, Transition state cmd_ ())]
commandsToTransitions StateMachine { forall (r :: * -> *). model r
initModel :: forall (model :: (* -> *) -> *) (cmd :: (* -> *) -> *)
(m :: * -> *) (resp :: (* -> *) -> *).
StateMachine model cmd m resp -> forall (r :: * -> *). model r
initModel :: forall (r :: * -> *). model r
initModel, forall (r :: * -> *).
(Show1 r, Ord1 r) =>
model r -> cmd r -> resp r -> model r
transition :: forall (model :: (* -> *) -> *) (cmd :: (* -> *) -> *)
(m :: * -> *) (resp :: (* -> *) -> *).
StateMachine model cmd m resp
-> forall (r :: * -> *).
(Show1 r, Ord1 r) =>
model r -> cmd r -> resp r -> model r
transition :: forall (r :: * -> *).
(Show1 r, Ord1 r) =>
model r -> cmd r -> resp r -> model r
transition, model Symbolic -> cmd Symbolic -> GenSym (resp Symbolic)
mock :: forall (model :: (* -> *) -> *) (cmd :: (* -> *) -> *)
(m :: * -> *) (resp :: (* -> *) -> *).
StateMachine model cmd m resp
-> model Symbolic -> cmd Symbolic -> GenSym (resp Symbolic)
mock :: model Symbolic -> cmd Symbolic -> GenSym (resp Symbolic)
mock } =
model Symbolic
-> Counter
-> [(state, Transition state cmd_ ())]
-> [Command cmd resp]
-> [(state, Transition state cmd_ ())]
go forall (r :: * -> *). model r
initModel Counter
newCounter [] forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (cmd :: (* -> *) -> *) (resp :: (* -> *) -> *).
Commands cmd resp -> [Command cmd resp]
unCommands
where
go :: model Symbolic -> Counter -> [(state, Transition state cmd_ ())]
-> [Command cmd resp] -> [(state, Transition state cmd_ ())]
go :: model Symbolic
-> Counter
-> [(state, Transition state cmd_ ())]
-> [Command cmd resp]
-> [(state, Transition state cmd_ ())]
go model Symbolic
_model Counter
_counter [(state, Transition state cmd_ ())]
acc [] = [(state, Transition state cmd_ ())]
acc
go model Symbolic
model Counter
counter [(state, Transition state cmd_ ())]
acc (Command cmd resp
cmd : [Command cmd resp]
cmds) = model Symbolic
-> Counter
-> [(state, Transition state cmd_ ())]
-> [Command cmd resp]
-> [(state, Transition state cmd_ ())]
go model Symbolic
model' Counter
counter' ((state
from, Transition state cmd_ ()
t) forall a. a -> [a] -> [a]
: [(state, Transition state cmd_ ())]
acc) [Command cmd resp]
cmds
where
from :: state
from = model Symbolic -> state
partition model Symbolic
model
cmd' :: cmd Symbolic
cmd' = forall (cmd :: (* -> *) -> *) (resp :: (* -> *) -> *).
Command cmd resp -> cmd Symbolic
getCommand Command cmd resp
cmd
model' :: model Symbolic
model' = forall (r :: * -> *).
(Show1 r, Ord1 r) =>
model r -> cmd r -> resp r -> model r
transition model Symbolic
model cmd Symbolic
cmd' resp Symbolic
resp
(resp Symbolic
resp, Counter
counter') = forall a. GenSym a -> Counter -> (a, Counter)
runGenSym (model Symbolic -> cmd Symbolic -> GenSym (resp Symbolic)
mock model Symbolic
model cmd Symbolic
cmd') Counter
counter
t :: Transition state cmd_ ()
t = Transition
{ command :: cmd_
command = cmd Symbolic -> cmd_
constructor cmd Symbolic
cmd'
, probability :: ()
probability = ()
, to :: state
to = model Symbolic -> state
partition model Symbolic
model'
}
enumMatrix :: forall e a. (Generic e, GEnum FiniteEnum (Rep e), GBounded (Rep e))
=> ((e, e) -> a)
-> Matrix a
enumMatrix :: forall e a.
(Generic e, GEnum FiniteEnum (Rep e), GBounded (Rep e)) =>
((e, e) -> a) -> Matrix a
enumMatrix (e, e) -> a
f = forall a. Int -> Int -> ((Int, Int) -> a) -> Matrix a
matrix Int
dimension Int
dimension ((e, e) -> a
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap Int -> e
g Int -> e
g)
where
g :: Int -> e
g :: Int -> e
g = forall a. (Generic a, GEnum FiniteEnum (Rep a)) => Int -> a
gtoFiniteEnum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Enum a => a -> a
pred
dimension :: Int
dimension :: Int
dimension = forall (t :: * -> *) a. Foldable t => t a -> Int
length [e]
es
es :: [e]
es :: [e]
es = forall a. (Generic a, GEnum FiniteEnum (Rep a)) => a -> a -> [a]
gfiniteEnumFromTo forall a. (Generic a, GBounded (Rep a)) => a
gminBound forall a. (Generic a, GBounded (Rep a)) => a
gmaxBound
transitionMatrix :: forall state cmd_. Ord state
=> (Generic state, GEnum FiniteEnum (Rep state), GBounded (Rep state))
=> Markov state cmd_ Double
-> Matrix Double
transitionMatrix :: forall state cmd_.
(Ord state, Generic state, GEnum FiniteEnum (Rep state),
GBounded (Rep state)) =>
Markov state cmd_ Double -> Matrix Double
transitionMatrix Markov state cmd_ Double
markov = forall e a.
(Generic e, GEnum FiniteEnum (Rep e), GBounded (Rep e)) =>
((e, e) -> a) -> Matrix a
enumMatrix (state, state) -> Double
go
where
go :: (state, state) -> Double
go :: (state, state) -> Double
go (state
state, state
state') = forall a. a -> Maybe a -> a
fromMaybe Double
0
(forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup state
state' forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup state
state Map state (Map state Double)
availableStates)
availableStates :: Map state (Map state Double)
availableStates :: Map state (Map state Double)
availableStates
= forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall state cmd_ prob. Transition state cmd_ prob -> state
to forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& (forall a. Fractional a => a -> a -> a
/ Double
100) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall state cmd_ prob. Transition state cmd_ prob -> prob
probability))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall state cmd_ prob.
Markov state cmd_ prob -> Map state [Transition state cmd_ prob]
unMarkov
forall a b. (a -> b) -> a -> b
$ Markov state cmd_ Double
markov
enumMatrix'
:: forall state cmd a
. (Generic state, GEnum FiniteEnum (Rep state), GBounded (Rep state))
=> (Generic cmd, GEnum FiniteEnum (Rep cmd), GBounded (Rep cmd))
=> ((state, cmd) -> a)
-> Matrix a
enumMatrix' :: forall state cmd a.
(Generic state, GEnum FiniteEnum (Rep state), GBounded (Rep state),
Generic cmd, GEnum FiniteEnum (Rep cmd), GBounded (Rep cmd)) =>
((state, cmd) -> a) -> Matrix a
enumMatrix' (state, cmd) -> a
f = forall a. Int -> Int -> ((Int, Int) -> a) -> Matrix a
matrix Int
m Int
n ((state, cmd) -> a
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap Int -> state
g Int -> cmd
h)
where
g :: Int -> state
g :: Int -> state
g = forall a. (Generic a, GEnum FiniteEnum (Rep a)) => Int -> a
gtoFiniteEnum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Enum a => a -> a
pred
h :: Int -> cmd
h :: Int -> cmd
h = forall a. (Generic a, GEnum FiniteEnum (Rep a)) => Int -> a
gtoFiniteEnum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Enum a => a -> a
pred
m :: Int
m :: Int
m = forall (t :: * -> *) a. Foldable t => t a -> Int
length [state]
states
n :: Int
n :: Int
n = forall (t :: * -> *) a. Foldable t => t a -> Int
length [cmd]
cmds
states :: [state]
states :: [state]
states = forall a. (Generic a, GEnum FiniteEnum (Rep a)) => a -> a -> [a]
gfiniteEnumFromTo forall a. (Generic a, GBounded (Rep a)) => a
gminBound forall a. (Generic a, GBounded (Rep a)) => a
gmaxBound
cmds :: [cmd]
cmds :: [cmd]
cmds = forall a. (Generic a, GEnum FiniteEnum (Rep a)) => a -> a -> [a]
gfiniteEnumFromTo forall a. (Generic a, GBounded (Rep a)) => a
gminBound forall a. (Generic a, GBounded (Rep a)) => a
gmaxBound
stimulusMatrix
:: forall state cmd. (Ord state, Ord cmd)
=> (Generic state, GEnum FiniteEnum (Rep state), GBounded (Rep state))
=> (Generic cmd, GEnum FiniteEnum (Rep cmd), GBounded (Rep cmd))
=> Markov state cmd Double
-> Matrix Double
stimulusMatrix :: forall state cmd.
(Ord state, Ord cmd, Generic state, GEnum FiniteEnum (Rep state),
GBounded (Rep state), Generic cmd, GEnum FiniteEnum (Rep cmd),
GBounded (Rep cmd)) =>
Markov state cmd Double -> Matrix Double
stimulusMatrix Markov state cmd Double
markov = forall state cmd a.
(Generic state, GEnum FiniteEnum (Rep state), GBounded (Rep state),
Generic cmd, GEnum FiniteEnum (Rep cmd), GBounded (Rep cmd)) =>
((state, cmd) -> a) -> Matrix a
enumMatrix' (state, cmd) -> Double
go
where
go :: (state, cmd) -> Double
go :: (state, cmd) -> Double
go (state
state, cmd
cmd) = forall a. a -> Maybe a -> a
fromMaybe Double
0
(forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup cmd
cmd forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup state
state Map state (Map cmd Double)
availableCmds)
availableCmds :: Map state (Map cmd Double)
availableCmds :: Map state (Map cmd Double)
availableCmds
= forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall state cmd_ prob. Transition state cmd_ prob -> cmd_
command forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& (forall a. Fractional a => a -> a -> a
/ Double
100) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall state cmd_ prob. Transition state cmd_ prob -> prob
probability))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall state cmd_ prob.
Markov state cmd_ prob -> Map state [Transition state cmd_ prob]
unMarkov
forall a b. (a -> b) -> a -> b
$ Markov state cmd Double
markov
historyObservations :: forall model cmd m resp state cmd_ prob. Ord state
=> Ord cmd_
=> (Generic state, GEnum FiniteEnum (Rep state), GBounded (Rep state))
=> StateMachine model cmd m resp
-> Markov state cmd_ prob
-> (model Concrete -> state)
-> (cmd Concrete -> cmd_)
-> History cmd resp
-> ( Matrix Double
, Matrix Double
)
historyObservations :: forall (model :: (* -> *) -> *) (cmd :: (* -> *) -> *)
(m :: * -> *) (resp :: (* -> *) -> *) state cmd_ prob.
(Ord state, Ord cmd_, Generic state, GEnum FiniteEnum (Rep state),
GBounded (Rep state)) =>
StateMachine model cmd m resp
-> Markov state cmd_ prob
-> (model Concrete -> state)
-> (cmd Concrete -> cmd_)
-> History cmd resp
-> (Matrix Double, Matrix Double)
historyObservations StateMachine { forall (r :: * -> *). model r
initModel :: forall (r :: * -> *). model r
initModel :: forall (model :: (* -> *) -> *) (cmd :: (* -> *) -> *)
(m :: * -> *) (resp :: (* -> *) -> *).
StateMachine model cmd m resp -> forall (r :: * -> *). model r
initModel, forall (r :: * -> *).
(Show1 r, Ord1 r) =>
model r -> cmd r -> resp r -> model r
transition :: forall (r :: * -> *).
(Show1 r, Ord1 r) =>
model r -> cmd r -> resp r -> model r
transition :: forall (model :: (* -> *) -> *) (cmd :: (* -> *) -> *)
(m :: * -> *) (resp :: (* -> *) -> *).
StateMachine model cmd m resp
-> forall (r :: * -> *).
(Show1 r, Ord1 r) =>
model r -> cmd r -> resp r -> model r
transition, model Concrete -> cmd Concrete -> resp Concrete -> Logic
postcondition :: forall (model :: (* -> *) -> *) (cmd :: (* -> *) -> *)
(m :: * -> *) (resp :: (* -> *) -> *).
StateMachine model cmd m resp
-> model Concrete -> cmd Concrete -> resp Concrete -> Logic
postcondition :: model Concrete -> cmd Concrete -> resp Concrete -> Logic
postcondition } Markov state cmd_ prob
markov model Concrete -> state
partition cmd Concrete -> cmd_
constructor
= forall {a}.
Num a =>
model Concrete
-> Map (state, state) a
-> Map (state, state) a
-> [Operation cmd resp]
-> (Matrix a, Matrix a)
go forall (r :: * -> *). model r
initModel forall k a. Map k a
Map.empty forall k a. Map k a
Map.empty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (cmd :: (* -> *) -> *) (resp :: (* -> *) -> *).
History' cmd resp -> [Operation cmd resp]
makeOperations forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (cmd :: (* -> *) -> *) (resp :: (* -> *) -> *).
History cmd resp -> History' cmd resp
unHistory
where
go :: model Concrete
-> Map (state, state) a
-> Map (state, state) a
-> [Operation cmd resp]
-> (Matrix a, Matrix a)
go model Concrete
_model Map (state, state) a
ss Map (state, state) a
fs [] =
( forall e a.
(Generic e, GEnum FiniteEnum (Rep e), GBounded (Rep e)) =>
((e, e) -> a) -> Matrix a
enumMatrix @state (forall a. a -> Maybe a -> a
fromMaybe a
0 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Map (state, state) a
ss)
, forall e a.
(Generic e, GEnum FiniteEnum (Rep e), GBounded (Rep e)) =>
((e, e) -> a) -> Matrix a
enumMatrix @state (forall a. a -> Maybe a -> a
fromMaybe a
0 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Map (state, state) a
fs)
)
go model Concrete
model Map (state, state) a
ss Map (state, state) a
fs (Operation cmd resp
op : [Operation cmd resp]
ops) = case Operation cmd resp
op of
Operation cmd Concrete
cmd resp Concrete
resp Pid
_pid ->
let
state :: state
state = model Concrete -> state
partition model Concrete
model
model' :: model Concrete
model' = forall (r :: * -> *).
(Show1 r, Ord1 r) =>
model r -> cmd r -> resp r -> model r
transition model Concrete
model cmd Concrete
cmd resp Concrete
resp
state' :: state
state' = model Concrete -> state
partition model Concrete
model'
incr :: Map (state, state) a -> Map (state, state) a
incr = forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith (\a
_new a
old -> a
old forall a. Num a => a -> a -> a
+ a
1) (state
state, state
state') a
1
in
if Logic -> Bool
boolean (model Concrete -> cmd Concrete -> resp Concrete -> Logic
postcondition model Concrete
model cmd Concrete
cmd resp Concrete
resp)
then model Concrete
-> Map (state, state) a
-> Map (state, state) a
-> [Operation cmd resp]
-> (Matrix a, Matrix a)
go model Concrete
model' (Map (state, state) a -> Map (state, state) a
incr Map (state, state) a
ss) Map (state, state) a
fs [Operation cmd resp]
ops
else model Concrete
-> Map (state, state) a
-> Map (state, state) a
-> [Operation cmd resp]
-> (Matrix a, Matrix a)
go model Concrete
model' Map (state, state) a
ss (Map (state, state) a -> Map (state, state) a
incr Map (state, state) a
fs) [Operation cmd resp]
ops
Crash cmd Concrete
cmd [Char]
_err Pid
_pid ->
let
state :: state
state = model Concrete -> state
partition model Concrete
model
state' :: state
state' = forall a. a -> Maybe a -> a
fromMaybe forall {a}. a
err
(forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (cmd Concrete -> cmd_
constructor cmd Concrete
cmd) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup state
state Map state (Map cmd_ state)
nextState)
incr :: Map (state, state) a -> Map (state, state) a
incr = forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith (\a
_new a
old -> a
old forall a. Num a => a -> a -> a
+ a
1) (state
state, state
state') a
1
in
model Concrete
-> Map (state, state) a
-> Map (state, state) a
-> [Operation cmd resp]
-> (Matrix a, Matrix a)
go model Concrete
model Map (state, state) a
ss (Map (state, state) a -> Map (state, state) a
incr Map (state, state) a
fs) [Operation cmd resp]
ops
where
err :: a
err = forall a. HasCallStack => [Char] -> a
error [Char]
"historyObservations: impossible."
nextState :: Map state (Map cmd_ state)
nextState :: Map state (Map cmd_ state)
nextState
= forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall state cmd_ prob. Transition state cmd_ prob -> cmd_
command forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& forall state cmd_ prob. Transition state cmd_ prob -> state
to))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall state cmd_ prob.
Markov state cmd_ prob -> Map state [Transition state cmd_ prob]
unMarkov
forall a b. (a -> b) -> a -> b
$ Markov state cmd_ prob
markov
markovToDot :: (Show state, Show cmd_, Show prob)
=> state -> state -> Markov state cmd_ prob -> String
markovToDot :: forall state cmd_ prob.
(Show state, Show cmd_, Show prob) =>
state -> state -> Markov state cmd_ prob -> [Char]
markovToDot state
source state
sink = forall {a} {a} {a} {a}.
(Show a, Show a, Show a, Show a) =>
[Char] -> [(a, [Transition a a a])] -> [Char]
go ([Char]
"digraph g {\n" forall a. [a] -> [a] -> [a]
++ [Char]
nodeColours) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [(k, a)]
Map.toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall state cmd_ prob.
Markov state cmd_ prob -> Map state [Transition state cmd_ prob]
unMarkov
where
nodeColours :: String
nodeColours :: [Char]
nodeColours = [Char] -> [Char]
string (forall a. Show a => a -> [Char]
show state
source) forall a. [a] -> [a] -> [a]
++ [Char]
" [color=\"green\"]\n" forall a. [a] -> [a] -> [a]
++
[Char] -> [Char]
string (forall a. Show a => a -> [Char]
show state
sink) forall a. [a] -> [a] -> [a]
++ [Char]
" [color=\"red\"]\n"
go :: [Char] -> [(a, [Transition a a a])] -> [Char]
go [Char]
acc [] = [Char]
acc forall a. [a] -> [a] -> [a]
++ [Char]
"}"
go [Char]
acc ((a
from, [Transition a a a]
via) : [(a, [Transition a a a])]
more) = [Char] -> [(a, [Transition a a a])] -> [Char]
go [Char]
acc' [(a, [Transition a a a])]
more
where
acc' :: String
acc' :: [Char]
acc' = [Char]
acc forall a. [a] -> [a] -> [a]
++
[[Char]] -> [Char]
unlines [ [Char] -> [Char]
string (forall a. Show a => a -> [Char]
show a
from) forall a. [a] -> [a] -> [a]
++
[Char]
" -> " forall a. [a] -> [a] -> [a]
++
[Char] -> [Char]
string (forall a. Show a => a -> [Char]
show a
to) forall a. [a] -> [a] -> [a]
++
[Char]
" [label=" forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
string (forall a. Show a => a -> [Char]
show a
cmd forall a. [a] -> [a] -> [a]
++ [Char]
"\\n(" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show a
prob forall a. [a] -> [a] -> [a]
++ [Char]
"%)") forall a. [a] -> [a] -> [a]
++ [Char]
"]"
| Transition a
cmd a
prob a
to <- [Transition a a a]
via
]
string :: String -> String
string :: [Char] -> [Char]
string [Char]
s = [Char]
"\"" forall a. [a] -> [a] -> [a]
++ [Char]
s forall a. [a] -> [a] -> [a]
++ [Char]
"\""
markovToPs :: (Show state, Show cmd_, Show prob)
=> state -> state -> Markov state cmd_ prob -> FilePath -> IO ()
markovToPs :: forall state cmd_ prob.
(Show state, Show cmd_, Show prob) =>
state -> state -> Markov state cmd_ prob -> [Char] -> IO ()
markovToPs state
source state
sink Markov state cmd_ prob
markov [Char]
out = do
let dotFile :: [Char]
dotFile = [Char] -> [Char] -> [Char]
replaceExtension [Char]
out [Char]
"dot"
[Char] -> [Char] -> IO ()
writeFile [Char]
dotFile (forall state cmd_ prob.
(Show state, Show cmd_, Show prob) =>
state -> state -> Markov state cmd_ prob -> [Char]
markovToDot state
source state
sink Markov state cmd_ prob
markov)
[Char] -> [[Char]] -> IO ()
callProcess [Char]
"dot" [[Char]
"-Tps", [Char]
dotFile, [Char]
"-o", [Char]
out]
data StatsDb m = StatsDb
{ forall (m :: * -> *).
StatsDb m -> (Matrix Double, Matrix Double) -> m ()
store :: (Matrix Double, Matrix Double) -> m ()
, forall (m :: * -> *).
StatsDb m -> m (Maybe (Matrix Double, Matrix Double))
load :: m (Maybe (Matrix Double, Matrix Double))
}
type PropertyName = String
nullStatsDb :: Monad m => StatsDb m
nullStatsDb :: forall (m :: * -> *). Monad m => StatsDb m
nullStatsDb = StatsDb
{ store :: (Matrix Double, Matrix Double) -> m ()
store = forall a b. a -> b -> a
const (forall (m :: * -> *) a. Monad m => a -> m a
return ())
, load :: m (Maybe (Matrix Double, Matrix Double))
load = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
}
fileStatsDb :: FilePath -> PropertyName -> StatsDb IO
fileStatsDb :: [Char] -> [Char] -> StatsDb IO
fileStatsDb [Char]
fp [Char]
name = StatsDb
{ store :: (Matrix Double, Matrix Double) -> IO ()
store = (Matrix Double, Matrix Double) -> IO ()
store
, load :: IO (Maybe (Matrix Double, Matrix Double))
load = IO (Maybe (Matrix Double, Matrix Double))
load
}
where
store :: (Matrix Double, Matrix Double) -> IO ()
store :: (Matrix Double, Matrix Double) -> IO ()
store (Matrix Double, Matrix Double)
observed = do
[Char] -> [Char] -> IO ()
appendFile ([Char]
fp forall a. [a] -> [a] -> [a]
++ [Char]
"-" forall a. [a] -> [a] -> [a]
++ [Char]
name) (forall a. Show a => a -> [Char]
show (forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap forall a. Matrix a -> [[a]]
toLists forall a. Matrix a -> [[a]]
toLists (Matrix Double, Matrix Double)
observed) forall a. [a] -> [a] -> [a]
++ [Char]
"\n")
load :: IO (Maybe (Matrix Double, Matrix Double))
load :: IO (Maybe (Matrix Double, Matrix Double))
load = do
Maybe (Matrix Double, Matrix Double)
mprior <- [Char] -> Maybe (Matrix Double, Matrix Double)
parse forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO [Char]
readFile' ([Char]
fp forall a. [a] -> [a] -> [a]
++ [Char]
"-" forall a. [a] -> [a] -> [a]
++ [Char]
name forall a. [a] -> [a] -> [a]
++ [Char]
"-cache")
Maybe [(Matrix Double, Matrix Double)]
mnew <- [Char] -> Maybe [(Matrix Double, Matrix Double)]
parseMany forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO [Char]
readFile' ([Char]
fp forall a. [a] -> [a] -> [a]
++ [Char]
"-" forall a. [a] -> [a] -> [a]
++ [Char]
name)
let sumElem :: [Matrix Double] -> Matrix Double
sumElem :: [Matrix Double] -> Matrix Double
sumElem = forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 (forall a b c. (a -> b -> c) -> Matrix a -> Matrix b -> Matrix c
elementwise forall a. Num a => a -> a -> a
(+))
let mprior' :: Maybe (Matrix Double, Matrix Double)
mprior' = case (Maybe (Matrix Double, Matrix Double)
mprior, Maybe [(Matrix Double, Matrix Double)]
mnew) of
(Just (Matrix Double
sprior, Matrix Double
fprior), Just [(Matrix Double, Matrix Double)]
new) ->
forall a. a -> Maybe a
Just (forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap [Matrix Double] -> Matrix Double
sumElem [Matrix Double] -> Matrix Double
sumElem (forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (Matrix Double
sprior forall a. a -> [a] -> [a]
:) (Matrix Double
fprior forall a. a -> [a] -> [a]
:) (forall a b. [(a, b)] -> ([a], [b])
unzip [(Matrix Double, Matrix Double)]
new)))
(Maybe (Matrix Double, Matrix Double)
Nothing, Just [(Matrix Double, Matrix Double)]
new) -> forall a. a -> Maybe a
Just (forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap [Matrix Double] -> Matrix Double
sumElem [Matrix Double] -> Matrix Double
sumElem (forall a b. [(a, b)] -> ([a], [b])
unzip [(Matrix Double, Matrix Double)]
new))
(Just (Matrix Double, Matrix Double)
prior, Maybe [(Matrix Double, Matrix Double)]
Nothing) -> forall a. a -> Maybe a
Just (Matrix Double, Matrix Double)
prior
(Maybe (Matrix Double, Matrix Double)
Nothing, Maybe [(Matrix Double, Matrix Double)]
Nothing) -> forall a. Maybe a
Nothing
case Maybe (Matrix Double, Matrix Double)
mprior' of
Just (Matrix Double, Matrix Double)
prior' -> [Char] -> [Char] -> IO ()
writeFile ([Char]
fp forall a. [a] -> [a] -> [a]
++ [Char]
"-" forall a. [a] -> [a] -> [a]
++ [Char]
name forall a. [a] -> [a] -> [a]
++ [Char]
"-cache") (forall a. Show a => a -> [Char]
show (forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap forall a. Matrix a -> [[a]]
toLists forall a. Matrix a -> [[a]]
toLists (Matrix Double, Matrix Double)
prior'))
Maybe (Matrix Double, Matrix Double)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
[Char] -> IO ()
removeFile ([Char]
fp forall a. [a] -> [a] -> [a]
++ [Char]
"-" forall a. [a] -> [a] -> [a]
++ [Char]
name)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Matrix Double, Matrix Double)
mprior'
where
parseMany :: String -> Maybe ([(Matrix Double, Matrix Double)])
parseMany :: [Char] -> Maybe [(Matrix Double, Matrix Double)]
parseMany = forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map [Char] -> Maybe (Matrix Double, Matrix Double)
parse
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [[Char]]
lines
parse :: String -> Maybe (Matrix Double, Matrix Double)
parse :: [Char] -> Maybe (Matrix Double, Matrix Double)
parse = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap forall a. [[a]] -> Matrix a
fromLists forall a. [[a]] -> Matrix a
fromLists) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Read a => [Char] -> Maybe a
readMaybe
readFile' :: FilePath -> IO String
readFile' :: [Char] -> IO [Char]
readFile' [Char]
file = Handle -> IO [Char]
hGetContents forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Char] -> IOMode -> IO Handle
openFile [Char]
file IOMode
ReadWriteMode
persistStats :: Monad m
=> StatsDb m -> (Matrix Double, Matrix Double) -> PropertyM m ()
persistStats :: forall (m :: * -> *).
Monad m =>
StatsDb m -> (Matrix Double, Matrix Double) -> PropertyM m ()
persistStats StatsDb { (Matrix Double, Matrix Double) -> m ()
store :: (Matrix Double, Matrix Double) -> m ()
store :: forall (m :: * -> *).
StatsDb m -> (Matrix Double, Matrix Double) -> m ()
store } = forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Matrix Double, Matrix Double) -> m ()
store
computeReliability :: Monad m
=> StatsDb m -> Matrix Double -> (Matrix Double, Matrix Double)
-> m (Double, Double)
computeReliability :: forall (m :: * -> *).
Monad m =>
StatsDb m
-> Matrix Double
-> (Matrix Double, Matrix Double)
-> m (Double, Double)
computeReliability StatsDb { m (Maybe (Matrix Double, Matrix Double))
load :: m (Maybe (Matrix Double, Matrix Double))
load :: forall (m :: * -> *).
StatsDb m -> m (Maybe (Matrix Double, Matrix Double))
load } Matrix Double
usage (Matrix Double, Matrix Double)
observed = do
Maybe (Matrix Double, Matrix Double)
mpriors <- m (Maybe (Matrix Double, Matrix Double))
load
forall (m :: * -> *) a. Monad m => a -> m a
return (Matrix Double
-> Maybe (Matrix Double, Matrix Double)
-> (Matrix Double, Matrix Double)
-> (Double, Double)
singleUseReliability (forall {a}. Matrix a -> Matrix a
reduce Matrix Double
usage) Maybe (Matrix Double, Matrix Double)
mpriors (forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap forall {a}. Matrix a -> Matrix a
reduce forall {a}. Matrix a -> Matrix a
reduce (Matrix Double, Matrix Double)
observed))
where
n :: Int
n = forall a. Matrix a -> Int
ncols Matrix Double
usage
m :: Int
m = forall a. Enum a => a -> a
pred Int
n
reduce :: Matrix a -> Matrix a
reduce = forall a. Int -> Int -> Int -> Int -> Matrix a -> Matrix a
submatrix Int
1 Int
m Int
1 Int
n
printReliability :: Testable prop
=> StatsDb IO -> Matrix Double -> (Matrix Double, Matrix Double)
-> prop -> Property
printReliability :: forall prop.
Testable prop =>
StatsDb IO
-> Matrix Double
-> (Matrix Double, Matrix Double)
-> prop
-> Property
printReliability StatsDb IO
sdb Matrix Double
usage (Matrix Double, Matrix Double)
observed = forall prop. Testable prop => Callback -> prop -> Property
callback forall a b. (a -> b) -> a -> b
$ CallbackKind -> (State -> Result -> IO ()) -> Callback
PostTest CallbackKind
NotCounterexample forall a b. (a -> b) -> a -> b
$ \State
_state Result
_result ->
forall a. Show a => a -> IO ()
print forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *).
Monad m =>
StatsDb m
-> Matrix Double
-> (Matrix Double, Matrix Double)
-> m (Double, Double)
computeReliability StatsDb IO
sdb Matrix Double
usage (Matrix Double, Matrix Double)
observed
quickCheckReliability :: Testable prop
=> StatsDb IO -> Matrix Double -> prop -> IO ()
quickCheckReliability :: forall prop.
Testable prop =>
StatsDb IO -> Matrix Double -> prop -> IO ()
quickCheckReliability StatsDb IO
sdb Matrix Double
usage prop
prop = do
forall prop. Testable prop => prop -> IO ()
quickCheck prop
prop
forall a. Show a => a -> IO ()
print forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *).
Monad m =>
StatsDb m
-> Matrix Double
-> (Matrix Double, Matrix Double)
-> m (Double, Double)
computeReliability StatsDb IO
sdb Matrix Double
usage (Matrix Double, Matrix Double)
observed
where
observed :: (Matrix Double, Matrix Double)
observed = ( forall a. Num a => Int -> Int -> Matrix a
zero (forall a. Matrix a -> Int
nrows Matrix Double
usage) (forall a. Matrix a -> Int
ncols Matrix Double
usage)
, forall a. Num a => Int -> Int -> Matrix a
zero (forall a. Matrix a -> Int
nrows Matrix Double
usage) (forall a. Matrix a -> Int
ncols Matrix Double
usage)
)
testChainToDot :: forall state cmd_ prob m. (Show state, Ord state, Monad m)
=> (Generic state, GEnum FiniteEnum (Rep state))
=> StatsDb m -> state -> state -> Markov state cmd_ prob -> m String
testChainToDot :: forall state cmd_ prob (m :: * -> *).
(Show state, Ord state, Monad m, Generic state,
GEnum FiniteEnum (Rep state)) =>
StatsDb m -> state -> state -> Markov state cmd_ prob -> m [Char]
testChainToDot StatsDb { m (Maybe (Matrix Double, Matrix Double))
load :: m (Maybe (Matrix Double, Matrix Double))
load :: forall (m :: * -> *).
StatsDb m -> m (Maybe (Matrix Double, Matrix Double))
load } state
source state
sink Markov state cmd_ prob
markov = do
Maybe (Matrix Double, Matrix Double)
mpriors <- m (Maybe (Matrix Double, Matrix Double))
load
case Maybe (Matrix Double, Matrix Double)
mpriors of
Maybe (Matrix Double, Matrix Double)
Nothing -> forall a. HasCallStack => [Char] -> a
error [Char]
"testChainToDot: no test chain exists"
Just (Matrix Double, Matrix Double)
priors -> forall (m :: * -> *) a. Monad m => a -> m a
return
([Char]
-> (Matrix Double, Matrix Double) -> [(state, state)] -> [Char]
go ([Char]
"digraph g {\n" forall a. [a] -> [a] -> [a]
++ [Char]
nodeColours) (Matrix Double, Matrix Double)
priors [(state, state)]
markovStatePairs)
where
nodeColours :: String
nodeColours :: [Char]
nodeColours = [Char] -> [Char]
string (forall a. Show a => a -> [Char]
show state
source) forall a. [a] -> [a] -> [a]
++ [Char]
" [color=\"green\"]\n" forall a. [a] -> [a] -> [a]
++
[Char] -> [Char]
string (forall a. Show a => a -> [Char]
show state
sink) forall a. [a] -> [a] -> [a]
++ [Char]
" [color=\"red\"]\n"
go :: String -> (Matrix Double, Matrix Double) -> [(state, state)] -> String
go :: [Char]
-> (Matrix Double, Matrix Double) -> [(state, state)] -> [Char]
go [Char]
acc (Matrix Double, Matrix Double)
_priors [] = [Char]
acc forall a. [a] -> [a] -> [a]
++ [Char]
"}"
go [Char]
acc (Matrix Double
successes, Matrix Double
failures) ((state
from, state
to) : [(state, state)]
more) = [Char]
-> (Matrix Double, Matrix Double) -> [(state, state)] -> [Char]
go [Char]
acc' (Matrix Double
successes, Matrix Double
failures) [(state, state)]
more
where
acc' :: String
acc' :: [Char]
acc' = [Char]
acc forall a. [a] -> [a] -> [a]
++
[Char] -> [Char]
string (forall a. Show a => a -> [Char]
show state
from) forall a. [a] -> [a] -> [a]
++
[Char]
" -> " forall a. [a] -> [a] -> [a]
++
[Char] -> [Char]
string (forall a. Show a => a -> [Char]
show state
to) forall a. [a] -> [a] -> [a]
++
[Char]
" [label=<(<font color='green'>" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (state -> state -> Matrix Double -> Int
lookupStates state
from state
to Matrix Double
successes) forall a. [a] -> [a] -> [a]
++ [Char]
"</font>"
forall a. [a] -> [a] -> [a]
++ [Char]
", <font color='red'>" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (state -> state -> Matrix Double -> Int
lookupStates state
from state
to Matrix Double
failures) forall a. [a] -> [a] -> [a]
++ [Char]
"</font>)>]\n"
markovStatePairs :: [(state, state)]
markovStatePairs :: [(state, state)]
markovStatePairs
= forall a. Set a -> [a]
Set.toList
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Set (state, state)
ih (state
from, [state]
tos) -> Set (state, state)
ih forall a. Ord a => Set a -> Set a -> Set a
`Set.union`
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Set (state, state)
ih' state
to -> forall a. Ord a => a -> Set a -> Set a
Set.insert (state
from, state
to) Set (state, state)
ih') forall a. Set a
Set.empty [state]
tos)
forall a. Set a
Set.empty
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. (a -> b) -> [a] -> [b]
map forall state cmd_ prob. Transition state cmd_ prob -> state
to))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [(k, a)]
Map.toList
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall state cmd_ prob.
Markov state cmd_ prob -> Map state [Transition state cmd_ prob]
unMarkov
forall a b. (a -> b) -> a -> b
$ Markov state cmd_ prob
markov
lookupStates :: state -> state -> Matrix Double -> Int
lookupStates :: state -> state -> Matrix Double -> Int
lookupStates state
from state
to = forall a b. (RealFrac a, Integral b) => a -> b
round forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> Int -> Matrix a -> a
getElem (forall a. (Generic a, GEnum FiniteEnum (Rep a)) => a -> Int
gfromFiniteEnum state
from forall a. Num a => a -> a -> a
+ Int
1) (forall a. (Generic a, GEnum FiniteEnum (Rep a)) => a -> Int
gfromFiniteEnum state
to forall a. Num a => a -> a -> a
+ Int
1)