{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE NamedFieldPuns      #-}
{-# LANGUAGE RecordWildCards     #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications    #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Test.StateMachine.Markov
-- Copyright   :  (C) 2019, Stevan Andjelkovic
-- License     :  BSD-style (see the file LICENSE)
--
-- Maintainer  :  Stevan Andjelkovic <stevan.andjelkovic@strath.ac.uk>
-- Stability   :  provisional
-- Portability :  non-portable (GHC extensions)
--
-- This module contains helper functions for testing using Markov chains.
--
-----------------------------------------------------------------------------

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)

------------------------------------------------------------------------

-- | Markov chain.
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
  }

-- | Constructor for 'Markov' chains.
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

-- | Expose inner graph structure of markov chain
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 -<

-- | Infix operator for starting to creating a transition in the 'Markov' chain,
--   finish the transition with one of '(>-)' or '(/-)' depending on whether the
--   transition has a specific or a uniform probability.
(-<) :: 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
    -- ^ Note: If `length ls == 0` then `uniform` is not used, so division by
    -- zero doesn't happen.

infixl 5 >-

-- | Finish making a transition with a specified probability distribution.
(>-) :: (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 /-

-- | Finish making a transition with an uniform probability distribution.
(/-) :: 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)

------------------------------------------------------------------------

-- | Create a generator from a 'Markov' chain.
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_)

-- | Variant of QuickCheck's 'coverTable' which works on 'Markov' chains.
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

-- | Variant of QuickCheck's 'tabulate' which works for 'Markov' chains.
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 -- We need the predecessor because 'matrix' starts
                             -- indexing from 1.

    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 -- We need the predecessor because 'matrix' starts
                             -- indexing from 1.

    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)