diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,49 @@ +# Changelog + +## 0.2.0.0 + +First Hackage release. + +- Added validated dense and sparse probability distributions. +- Added type-safe finite transition matrices and locally finite transition + kernels, with representation-independent finite-horizon evolution and + simulation. +- Added finite-time joint and conditional probabilities. +- Added exact-time, bounded, eventual, competing, and expected hitting and + return quantities. +- Added finite- and infinite-horizon visit-count analysis, including the + occupation matrix. +- Added communicating-class, recurrence, transience, periodicity, and cyclic + class analysis. +- Added canonical decomposition, fundamental matrices, and absorption + probabilities and expectations. +- Added extremal stationary distributions for every recurrent class, ordinary + limiting matrices, and cyclic subsequential limits. +- Added state-labelled and list-based construction and inspection. No + `hmatrix` type appears in the public API. +- Changed the internal dense storage of `DistributionVector` and + `TransitionMatrix` from statically sized values to ordinary `hmatrix` + vectors and matrices. The public types remain state-indexed and abstract, + and their smart constructors continue to validate dimensions against the + finite state cardinality. +- Added `Dtmc.Distribution.Map.mapStates` for transforming sparse + distributions, combining the weights of states that share a target. +- Added `Dtmc.Transition.Matrix.fromRows`, which builds a matrix from a grid + of weights and reports shape mismatches as typed errors. +- Made GTH stationary-distribution normalisation robust when finite weights + have a sum that overflows `Double`. +- Reduced dense transition-row lookup from quadratic to linear time and + space. +- Made `Dtmc.Distribution.Vector.fromList` positional: it now takes one weight + per state in canonical state order, so it is the exact inverse of `toList`, + and reports a length mismatch through the new `DistributionVectorError`. + Labelled construction, where duplicates combine and missing states default + to zero, remains `Dtmc.Distribution.Map.fromList`. +- Supports GHC 9.6 through 9.14. +- Narrowed `Dtmc.Analysis.Classification` to the queries themselves. The + `Classification` report and `classify` are no longer exported, and with them + the `Of` suffixes that existed only to keep record fields from colliding + with the standalone functions. `absorbingStates`, `chainPeriod` and + `ergodic` are now functions on a matrix, and `communicatingClasses` returns + `[CommClass state]`, carrying each class's period and closedness rather than + its members alone. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,26 @@ +Copyright (c) 2026 Arkadii Kholmetskii + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +3. Neither the name of the copyright holder nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,251 @@ +# dtmc + +Type-safe discrete-time Markov chains for Haskell. + +`dtmc` supports both finite chains and locally finite kernels over countable +state spaces. It validates probability data at construction, keeps finite +models tied to their state type, and provides finite-time, structural, and +long-run analysis alongside simulation. + +## Features + +- Dense transition matrices indexed by domain-specific finite state types. +- Sparse transition kernels for finite or potentially infinite state spaces. +- Validated dense and sparse probability distributions. +- Distribution evolution, transition probabilities, timed events, and + conditional probabilities. +- Hitting times, first-return times, and finite or total visit counts. +- Communicating classes, recurrence, periodicity, and absorbing states. +- Canonical decomposition, fundamental matrices, and absorption analysis. +- Stationary distributions, ordinary limits, and cyclic subsequential limits. +- Random sampling and trajectory simulation through either representation. +- No `hmatrix` types in the public API. + +## Installation + +Add the package to your Cabal file: + +```cabal +build-depends: dtmc ^>=0.2.0.0 +``` + +The package requires GHC 9.6 or newer and a BLAS/LAPACK implementation for +its internal use of `hmatrix`. On Ubuntu or Debian: + +```bash +sudo apt-get install libblas-dev liblapack-dev +``` + +On macOS, `hmatrix` can use Apple Accelerate. + +## Quick start + +This complete example defines a two-state weather chain and asks three +different probability questions: + +```haskell +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} + +module Main (main) where + +import Dtmc.Analysis.Event (DiscreteEvent (..)) +import Dtmc.Analysis.FiniteTime qualified as FiniteTime +import Dtmc.Analysis.HittingTime qualified as HittingTime +import Dtmc.Distribution.Vector (DistributionVector) +import Dtmc.Distribution.Vector qualified as Vector +import Dtmc.State (FiniteState) +import Dtmc.Transition.Matrix (TransitionMatrix) +import Dtmc.Transition.Matrix qualified as Matrix +import GHC.Generics (Generic) + +data Weather = Dry | Wet + deriving (Eq, Ord, Show, Generic, FiniteState) + +weather :: TransitionMatrix Weather +weather = + checked $ + Matrix.fromRows + [ [0.9, 0.1] + , [0.4, 0.6] + ] + +initial :: DistributionVector Weather +initial = checked (Vector.fromList [1, 0]) + +checked :: Show problem => Either problem value -> value +checked = either (error . show) id + +main :: IO () +main = do + -- P(X_2 = Wet | X_0 = Dry) + print (FiniteTime.nStepProbability 2 weather Dry Wet) + + -- P(H_Wet <= 2) under the initial distribution + print (HittingTime.probability (AtMost 2) weather (== Wet) initial) + + -- P(H_Wet < infinity) under the initial distribution + print (HittingTime.eventualProbability weather [Wet] initial) +``` + +Constructor order is the canonical state order. The rows and columns above +therefore represent `Dry` followed by `Wet`; `Vector.fromList` uses the same +order. Invalid dimensions, weights, or row sums are returned as typed errors. + +The two hitting queries take their target differently, and the difference is +not cosmetic. A bounded query walks forward a fixed number of steps, so it +works through any `Transition` — including a kernel over an infinite state +space — and takes a predicate. An eventual query solves a linear system over +the whole state space, so it requires a finite `TransitionMatrix`, takes an +explicit target list, and returns `Either LinearSystemError`. + +Analysis modules intentionally use concise, overlapping names such as +`probability` and `expectation`. Import them qualified, as in the example. +The top-level `Dtmc` module is an orientation and module map rather than a +facade of re-exports. + +## Choosing a representation + +| State space | Transitions | Initial distribution | Capabilities | +| --- | --- | --- | --- | +| Finite | `TransitionMatrix` | `DistributionVector` or `DistributionMap` | Complete finite-time, structural, and long-run analysis; simulation | +| Finite | `TransitionKernel` | `DistributionVector` or `DistributionMap` | Finite-horizon analysis; simulation | +| Potentially infinite | `TransitionKernel` | Finite-support `DistributionMap` | Finite-horizon analysis; simulation | + +A `TransitionKernel` does not enumerate its state space. It only requires each +one-step transition law to have finite support, so the same finite-horizon +algorithms work without global truncation. Analyses that need the complete +state space require a finite `TransitionMatrix`. + +### Finite states + +For a named enumeration, derive `Generic` and `FiniteState`: + +```haskell +data Queue = Empty | Busy | Full + deriving (Eq, Ord, Show, Generic, FiniteState) +``` + +Constructors must have no fields. Their declaration order determines the +canonical order used by vectors, matrices, and whole-state results. Use +`Finite n` when names are unnecessary. Instances are also provided for `()`, +`Bool`, and `Ordering`. + +### Locally finite kernels + +A kernel is a function from a state to a validated sparse distribution: + +```haskell +import Dtmc.Distribution (DistributionError) +import Dtmc.Distribution.Map qualified as Distribution +import Dtmc.Transition.Kernel (TransitionKernel) +import Dtmc.Transition.Kernel qualified as Kernel + +countUp :: TransitionKernel Integer +countUp = Kernel.fromLaws (Distribution.pointMass . (+ 1)) + +randomWalk :: Either DistributionError (TransitionKernel Integer) +randomWalk = do + stepLaw <- Distribution.fromList [(-1, 0.5), (1, 0.5)] + pure $ + Kernel.fromLaws $ \position -> + Distribution.mapStates (+ position) stepLaw +``` + +The random walk has an infinite reachable state space, while every individual +transition law remains finite. + +## Construction guide + +| Value | Constructor | Notes | +| --- | --- | --- | +| Sparse distribution | `Dtmc.Distribution.Map.fromList` | State-labelled; duplicate states combine | +| Point mass | `Dtmc.Distribution.Map.pointMass` | Concentrates probability on one state | +| Dense finite distribution | `Dtmc.Distribution.Vector.fromList` | One weight per state in canonical order | +| Transition kernel | `Dtmc.Transition.Kernel.fromLaws` | Accepts validated finite-support laws | +| Transition matrix | `Dtmc.Transition.Matrix.fromRows` | Plain row-major lists in canonical order | +| Matrix from a kernel | `Dtmc.Transition.Matrix.fromKernel` | Materializes a finite-state kernel | + +Transition matrices can be combined with `compose`, `identity`, and `power`. +Both matrix and vector values are abstract and nominally associated with their +state type, preventing accidental use with a different finite model. + +## Analysis guide + +| Task | Module | +| --- | --- | +| Evolve distributions | `Dtmc.Dynamics` | +| Transition and timed-observation probabilities | `Dtmc.Analysis.FiniteTime` | +| Hitting times and races between target sets | `Dtmc.Analysis.HittingTime` | +| First-return times | `Dtmc.Analysis.ReturnTime` | +| Bounded and total visit counts; occupation matrix | `Dtmc.Analysis.VisitCount` | +| Communication, recurrence, and periodicity | `Dtmc.Analysis.Classification` | +| Fundamental matrix and absorption quantities | `Dtmc.Analysis.Absorption` | +| Extremal stationary distributions | `Dtmc.Analysis.Stationary` | +| Ordinary and cyclic long-run limits | `Dtmc.Analysis.Limiting` | +| Sampling and trajectories | `Dtmc.Simulation` | + +Functions ending in `GivenInitialState` condition on a particular starting +state. Their shorter counterparts accept any compatible `Distribution`. + +### Discrete events + +Hitting, return, and visit-count queries use `DiscreteEvent`: + +| Constructor | Event for `Y` | +| --- | --- | +| `EqualTo n` | `Y = n` | +| `LessThan n` | `Y < n` | +| `AtMost n` | `Y <= n` | +| `GreaterThan n` | `Y > n` | +| `AtLeast n` | `Y >= n` | + +For a quantity that may be infinite, `GreaterThan` and `AtLeast` include its +mass at infinity. Eventual hitting, eventual return, and infinitely many +visits remain explicit operations because they require finite-state analysis. + +## Validation and numerical behavior + +Distribution constructors reject non-finite values and repair coordinate or +total-mass error only within `1e-9`. Tolerated coordinate error is clamped to +`[0, 1]`, then the repaired weights are normalized. Transition-matrix rows +follow the same policy. + +Structural analysis is combinatorial: a stored matrix entry is an edge exactly +when it is greater than zero, with no floating-point tolerance. Numerical +analyses use checked `Double` linear algebra and return +`Either LinearSystemError result` on failure. Computed results are not silently +clamped or renormalized, and mathematically infinite expectations are reported +as `InfiniteExpectation` rather than floating-point infinity. + +See each module's Haddock documentation for edge cases and complexity bounds. + +## Building from source + +```bash +git clone https://github.com/kholmetskii/dtmc.git +cd dtmc +cabal update +cabal build all --enable-tests +cabal test all --test-show-details=direct +``` + +Generate local API documentation with: + +```bash +cabal haddock all --haddock-hyperlink-source +``` + +The package is tested with GHC 9.6.7, 9.8.4, 9.10.3, 9.12.4, and 9.14.1. + +## Documentation and support + +- Browse the [Haddock API documentation](https://hackage.haskell.org/package/dtmc/docs/Dtmc.html). +- Report bugs or request features in the [issue tracker](https://github.com/kholmetskii/dtmc/issues). +- See the [changelog](https://hackage.haskell.org/package/dtmc/changelog) for + release notes. + +## License + +`dtmc` is distributed under the BSD 3-Clause License; see the `LICENSE` file +in the source distribution. diff --git a/dtmc.cabal b/dtmc.cabal new file mode 100644 --- /dev/null +++ b/dtmc.cabal @@ -0,0 +1,151 @@ +cabal-version: 3.0 +name: dtmc +version: 0.2.0.0 +synopsis: Type-safe discrete-time Markov chains +description: + Type-safe finite discrete-time Markov chains with matrix and kernel + representations, plus locally finite countable-state kernels for exact + finite-horizon analysis and simulation. + The package provides validated probability laws, finite-time joint and + conditional probabilities, hitting and return quantities, visit counts, + communicating-class analysis, canonical decomposition, absorption, + stationary distributions, and ordinary and cyclic limiting behaviour. +category: Math, Probability +homepage: https://github.com/kholmetskii/dtmc +bug-reports: https://github.com/kholmetskii/dtmc/issues +license: BSD-3-Clause +license-file: LICENSE +author: Arkadii Kholmetskii +maintainer: Arkadii Kholmetskii <373321aa@gmail.com> +copyright: 2026 Arkadii Kholmetskii +build-type: Simple +tested-with: + GHC ==9.6.7 + , GHC ==9.8.4 + , GHC ==9.10.3 + , GHC ==9.12.4 + , GHC ==9.14.1 +extra-doc-files: + README.md + CHANGELOG.md + +common lang + default-language: GHC2021 + + default-extensions: + DataKinds + , RoleAnnotations + , TypeFamilies + + ghc-options: + -Wall + -Wcompat + -Wincomplete-uni-patterns + -Wredundant-constraints + +library + import: lang + hs-source-dirs: src + + exposed-modules: + Dtmc + Dtmc.Simplex + Dtmc.State + Dtmc.Distribution + Dtmc.Distribution.Vector + Dtmc.Distribution.Map + Dtmc.Transition + Dtmc.Transition.Matrix + Dtmc.Transition.Kernel + Dtmc.Simulation + Dtmc.Dynamics + Dtmc.Analysis.Event + Dtmc.Analysis.FiniteTime + Dtmc.Analysis.Expectation + Dtmc.Analysis.Limiting + Dtmc.Analysis.LinearSystem + Dtmc.Analysis.HittingTime + Dtmc.Analysis.ReturnTime + Dtmc.Analysis.VisitCount + Dtmc.Analysis.Absorption + Dtmc.Analysis.Classification + Dtmc.Analysis.Stationary + + other-modules: + Dtmc.Distribution.Vector.Internal + Dtmc.Distribution.Map.Internal + Dtmc.Transition.Matrix.Internal + Dtmc.Simplex.Internal + Dtmc.Analysis.FiniteTime.Internal + Dtmc.Analysis.Classification.Internal + Dtmc.Analysis.LinearSystem.Internal + Dtmc.Analysis.Initial.Internal + Dtmc.Transition.Matrix.Internal.Graph + Dtmc.Dynamics.Internal + Dtmc.State.Internal + + build-depends: + base >=4.18 && <5 + , array >=0.5.8 && <0.6 + , containers >=0.6.7 && <0.8 + , finite-typelits >=0.2.0.1 && <0.3 + , hmatrix >=0.20.2 && <0.21 + , mwc-random >=0.15.0.1 && <0.16 + , primitive >=0.9 && <0.10 + +test-suite spec + import: lang + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + + other-modules: + Dtmc.Distribution.VectorSpec + Dtmc.Distribution.MapSpec + Dtmc.Distribution.InterfaceSpec + Dtmc.StateSpec + Dtmc.Transition.MatrixSpec + Dtmc.SimulationSpec + Dtmc.DynamicsSpec + Dtmc.Analysis.EventSpec + Dtmc.Analysis.FiniteTimeCanonicalSpec + Dtmc.Analysis.HittingTimeCanonicalSpec + Dtmc.Analysis.CanonicalDifferentialSpec + Dtmc.Analysis.NamespaceCompileSpec + Dtmc.Analysis.ProbabilityOracle + Dtmc.Analysis.FiniteTimeSpec + Dtmc.Analysis.AbsorptionSpec + Dtmc.Analysis.ClassificationSpec + Dtmc.Analysis.ReturnTimeCanonicalSpec + Dtmc.Analysis.VisitCountCanonicalSpec + Dtmc.Analysis.HittingTimeSpec + Dtmc.Analysis.ReturnTimeSpec + Dtmc.Analysis.VisitCountSpec + Dtmc.Analysis.LimitingSpec + Dtmc.Analysis.StationarySpec + Dtmc.Analysis.TimeSpecSupport + Dtmc.Transition.KernelSpec + Dtmc.Transition.InterfaceSpec + Dtmc.IntegrationSpec + Dtmc.TestSupport + + build-depends: + base + , containers + , dtmc + , finite-typelits + , hspec >=2.11.17 && <2.12 + , mwc-random + , QuickCheck >=2.18 && <2.19 + + build-tool-depends: + hspec-discover:hspec-discover >=2.11.17 && <2.12 + +source-repository head + type: git + location: https://github.com/kholmetskii/dtmc.git + +source-repository this + type: git + location: https://github.com/kholmetskii/dtmc.git + tag: v0.2.0.0 diff --git a/src/Dtmc.hs b/src/Dtmc.hs new file mode 100644 --- /dev/null +++ b/src/Dtmc.hs @@ -0,0 +1,45 @@ +{- | +Module : Dtmc +Description : Orientation and module map for discrete-time Markov chains. + +This package models time-homogeneous discrete-time Markov chains (DTMCs). +It supports two complementary representations: + +* finite chains over a 'Dtmc.State.FiniteState' use + 'Dtmc.Transition.Matrix.TransitionMatrix' and may use dense + 'Dtmc.Distribution.Vector.DistributionVector' values; +* locally finite chains over unrestricted state types use + 'Dtmc.Transition.Kernel.TransitionKernel' and sparse + 'Dtmc.Distribution.Map.DistributionMap' values. + +Start with these modules: + +* "Dtmc.State" for finite named state types; +* "Dtmc.Distribution.Map" and "Dtmc.Distribution.Vector" for validated + probability laws; +* "Dtmc.Transition.Kernel" and "Dtmc.Transition.Matrix" for transition + models; +* "Dtmc.Dynamics" and "Dtmc.Simulation" for evolution and sampling. + +Analysis is organised by mathematical subject: + +* "Dtmc.Analysis.FiniteTime" for transition, joint, and conditional + probabilities; +* "Dtmc.Analysis.HittingTime", "Dtmc.Analysis.ReturnTime", and + "Dtmc.Analysis.VisitCount" for path-time and occupation quantities; +* "Dtmc.Analysis.Classification" for communication, recurrence, and + periodicity; +* "Dtmc.Analysis.Absorption", "Dtmc.Analysis.Stationary", and + "Dtmc.Analysis.Limiting" for finite-chain long-run behaviour. + +The package deliberately has no broad facade of re-exports because several +analysis modules use the same concise names, such as @probability@ and +@expectation@, for their subject-specific operations. Import analysis modules +qualified. + +No @hmatrix@ type appears anywhere in the public API: values are built from +and inspected as plain lists of weights. The package still uses @hmatrix@ +internally and therefore requires a BLAS/LAPACK implementation when it is +built. +-} +module Dtmc () where diff --git a/src/Dtmc/Analysis/Absorption.hs b/src/Dtmc/Analysis/Absorption.hs new file mode 100644 --- /dev/null +++ b/src/Dtmc/Analysis/Absorption.hs @@ -0,0 +1,286 @@ +{- | +Module : Dtmc.Analysis.Absorption +Description : Canonical decomposition, fundamental matrix, and absorption. + +Absorption analysis for a finite chain. Ordering the states so that the +transient set @T@ comes first and the recurrent set @R@ last puts the +transition matrix in block form + +@ +P = [ Q R' ] + [ 0 S ] +@ + +and the fundamental matrix of the transient block is +@G = sum_(n >= 0) Q^n = (I - Q)^-1@, whose entry @G(i,j)@ is the expected +number of visits to @j@ starting from @i@ for transient @i@ and @j@. + +Every finite chain has this decomposition, including the degenerate cases +@T = empty@ (no transient states) and a single recurrent class. No witness +type is required: unlike stationarity, the analysis is defined for every +finite transition matrix. + +Absorption probabilities are @B = G R'@, where @B(i,k)@ is the probability +that the /first/ recurrent state the chain visits is @k@. This is not the +same as the probability of ever visiting @k@: a recurrent class with more +than one state can be entered at one member and later reach another, which +'Dtmc.Analysis.HittingTime.eventualProbability' counts and @B@ does not. The +two agree only after summing over a whole recurrent class. + +Unless stated otherwise, complexity bounds exclude 'FiniteState' method +costs. For those bounds, @n@ is the state count, @E@ the support-edge count, +@t@ the transient-state count, and @s@ an initial distribution's stored +support size. +-} +module Dtmc.Analysis.Absorption ( + -- * Result types + LinearSystemError (..), + Expectation (..), + + -- * Canonical decomposition + canonicalOrder, + fundamentalMatrix, + + -- * Absorption probabilities + probability, + probabilityGivenInitialState, + + -- * Expected time to absorption + expectation, + expectationGivenInitialState, +) where + +import Data.Array.Unboxed qualified as Unboxed +import Dtmc.Analysis.Classification ( + recurrentState, + recurrentStates, + transientStates, + ) +import Dtmc.Analysis.Expectation ( + Expectation (..), + ) +import Dtmc.Analysis.HittingTime qualified as Hitting +import Dtmc.Analysis.Initial.Internal ( + expectationUnderEither, + probabilityUnderEither, + ) +import Dtmc.Analysis.LinearSystem ( + LinearSystemError (..), + ) +import Dtmc.Analysis.LinearSystem.Internal ( + fundamental, + subMatrix, + ) +import Dtmc.Distribution ( + Distribution (..), + ) +import Dtmc.State ( + FiniteState, + ) +import Dtmc.State.Internal ( + stateCardinalityInt, + stateIndexInt, + ) +import Dtmc.Transition.Matrix.Internal ( + TransitionMatrix, + unTransitionMatrix, + ) +import Numeric.LinearAlgebra qualified as LA + +toIndex :: (FiniteState state) => state -> Int +toIndex = stateIndexInt + +{- | Return the transient and recurrent states, each in the canonical order +of the 'FiniteState' instance. This ordering puts the matrix in block form +and indexes the rows and columns of 'fundamentalMatrix'. + +Membership is decided from the support graph, so the split is exact and +involves no floating-point comparison. + +Complexity: with shared graph facts cached, @O(n)@ time and @O(n)@ temporary +and result space. On an unforced matrix, the first full evaluation takes +@O(n^2 + (n + E) log(n + 1))@ time, @O(n^2 + n + E)@ temporary space, and +retains @O(n + E)@ graph-cache space. +-} +canonicalOrder :: + (FiniteState state) => + TransitionMatrix state -> + ([state], [state]) +canonicalOrder p = + (transientStates p, recurrentStates p) + +{- | Compute the fundamental matrix @G = (I - Q)^-1@ of the transient block, +together with the transient states that index its rows and columns. + +Entry @(i,j)@ is @E(V_j | X_0 = i)@, the expected number of visits to +transient @j@ from transient @i@. Every entry is finite, so the result uses +'Double' rather than 'Expectation'. +'Dtmc.Analysis.VisitCount.totalExpectation' gives the same entries one at a +time and extends to recurrent targets, where the value is infinite. + +A chain with no transient states returns @([], [])@ without a solve. +Otherwise the numerical behaviour and errors of the shared @(I - Q)@ solver +apply; @rho(Q) < 1@ holds in exact arithmetic because every transient state +reaches a recurrent one. + +Complexity: including first-time graph classification, +@O(n^2 + (n + E) log(n + 1) + t^3)@ time, +@O(n^2 + n + E + t^2)@ temporary space, @O(n + E)@ retained graph-cache +space, and @O(t^2)@ result space. +-} +fundamentalMatrix :: + (FiniteState state) => + TransitionMatrix state -> + Either LinearSystemError ([state], [[Double]]) +fundamentalMatrix p + | null transient = Right ([], []) + | otherwise = do + g <- fundamental (subMatrix transientIdx transientIdx matrix) + pure (transient, LA.toLists g) + where + transient = transientStates p + transientIdx = map toIndex transient + matrix = unTransitionMatrix p + +{- | Compute absorption probabilities into one recurrent state in canonical +state order. Coordinate @i@ is the probability that the supplied target is +the first recurrent state visited when starting from @i@. + +Boundary values are exact and taken without a solve: + +* a target that is not recurrent gives an all-zero vector; +* a recurrent starting state has already arrived, so its coordinate is @1@ + when it is the target and @0@ otherwise. + +Transient coordinates are the corresponding column of @B = G R'@ and inherit +the numerical behaviour and errors of 'fundamentalMatrix'. + +Complexity: including first-time graph classification, +@O(n^2 + (n + E) log(n + 1) + t^3)@ worst-case time, +@O(n^2 + n + E + t^2)@ temporary space, @O(n + E)@ retained graph-cache +space, and @O(n)@ result space. A non-recurrent target avoids the numerical +solve. +-} +probabilityByState :: + forall state. + (FiniteState state) => + TransitionMatrix state -> + state -> + Either LinearSystemError (LA.Vector Double) +probabilityByState p target + | not (recurrentState p target) = + Right (LA.fromList (replicate dim 0)) + | null transientIdx = + Right (LA.fromList [arrived i | i <- [0 .. dim - 1]]) + | otherwise = do + g <- fundamental (subMatrix transientIdx transientIdx matrix) + let exits = LA.flatten (subMatrix transientIdx [targetIdx] matrix) + solved = LA.toList (g LA.#> exits) + interior :: Unboxed.UArray Int Double + interior = + Unboxed.accumArray + (\_ x -> x) + 0 + (0, dim - 1) + (zip transientIdx solved) + valueAt i + | transientMask Unboxed.! i = interior Unboxed.! i + | otherwise = arrived i + pure (LA.fromList [valueAt i | i <- [0 .. dim - 1]]) + where + dim = stateCardinalityInt @state + matrix = unTransitionMatrix p + targetIdx = toIndex target + transientIdx = map toIndex (transientStates p) + transientMask :: Unboxed.UArray Int Bool + transientMask = + Unboxed.accumArray + (\_ x -> x) + False + (0, dim - 1) + [(i, True) | i <- transientIdx] + arrived i = if i == targetIdx then 1 else 0 + +{- | Compute, under an arbitrary initial distribution, the probability that +the supplied target is the first recurrent state visited. The result is the +initial-law mixture of the state-conditioned absorption probabilities. A +non-recurrent target gives exactly zero without a numerical solve. + +Complexity: excluding 'distributionWeights', @O(n^3 + s)@ worst-case time, +@O(n^2 + s)@ temporary space, and @O(1)@ result space. The matrix may retain +@O(n + E)@ graph-cache space. +-} +probability :: + ( FiniteState state + , Distribution distribution + , DistributionState distribution ~ state + ) => + TransitionMatrix state -> + state -> + distribution -> + Either LinearSystemError Double +probability p target initial = + probabilityUnderEither initial (probabilityGivenInitialState p target) + +{- | Compute the probability that the supplied target is the first recurrent +state visited, conditioned on @X_0 = i@. A recurrent initial state is already +absorbed at time zero. + +Partial application shares one lazy all-state table. A non-recurrent target +produces exact zeros without a numerical solve. + +Complexity: the first forced query takes @O(n^3)@ worst-case time and +@O(n^2)@ temporary space and may retain an @O(n)@ all-state result and +@O(n + E)@ graph cache. Subsequent shared lookups take @O(1)@ time and +space; the scalar result occupies @O(1)@ space. +-} +probabilityGivenInitialState :: + (FiniteState state) => + TransitionMatrix state -> + state -> + state -> + Either LinearSystemError Double +probabilityGivenInitialState p target = + \i -> (`LA.atIndex` toIndex i) <$> values + where + values = probabilityByState p target + +{- | Compute the expected number of transitions until the chain first enters +the recurrent states under an arbitrary initial distribution. The value is +mathematically finite for every valid finite chain; numerical failures come +from the checked transient-state solve. + +Complexity: excluding 'distributionWeights', @O(n^3 + s)@ worst-case time, +@O(n^2 + s)@ temporary space, and @O(1)@ result space. The matrix may retain +@O(n + E)@ graph-cache space. +-} +expectation :: + ( FiniteState state + , Distribution distribution + , DistributionState distribution ~ state + ) => + TransitionMatrix state -> + distribution -> + Either LinearSystemError Expectation +expectation p initial = + expectationUnderEither initial (expectationGivenInitialState p) + +{- | Compute the expected number of transitions until the chain first enters +the recurrent states, conditioned on @X_0 = i@. A recurrent initial state has +expectation zero; every transient state has a mathematically finite value. + +Partial application shares the lazy all-state result of the checked +transient-state solve. + +Complexity: the first forced query takes @O(n^3)@ worst-case time and +@O(n^2)@ temporary space and may retain an @O(n)@ all-state result and +@O(n + E)@ graph cache. Subsequent shared lookups take @O(1)@ time and +space; the scalar result occupies @O(1)@ space. +-} +expectationGivenInitialState :: + (FiniteState state) => + TransitionMatrix state -> + state -> + Either LinearSystemError Expectation +expectationGivenInitialState p = + Hitting.expectationGivenInitialState p (recurrentStates p) diff --git a/src/Dtmc/Analysis/Classification.hs b/src/Dtmc/Analysis/Classification.hs new file mode 100644 --- /dev/null +++ b/src/Dtmc/Analysis/Classification.hs @@ -0,0 +1,384 @@ +{-# LANGUAGE ExplicitNamespaces #-} + +{- | +Module : Dtmc.Analysis.Classification +Description : Communication, irreducibility, periodicity, and recurrence. + +Qualitative DTMC properties derived from the support graph of @P@: there is an +edge @i -> j@ exactly when the stored @P(i,j) > 0@. The comparison has no +tolerance, so a tiny positive value is a transition while zero or a negative +value is not. Results depend on which entries are positive, not their +magnitudes. Recurrence statements assume a finite, valid transition matrix. +Queries accept named state constructors through 'FiniteState'; state lists are +returned in the canonical order of that instance. + +For the complexity bounds, @n@ is the number of states and @E@ is the number +of strictly positive entries. The stated per-operation bounds exclude +'FiniteState' method costs and construction of the shared support graph. Its +first use adds @O(n^2)@ time and temporary space and retains @O(n + E)@ cache +space. Strong components, closedness, periods, and phases are also computed +lazily and shared by later queries on the same matrix. + +A @0 x 0@ matrix has no communicating classes and is neither irreducible nor +aperiodic here. +-} +module Dtmc.Analysis.Classification ( + -- * Reachability + supportEdge, + accessible, + reachesAny, + communicates, + + -- * Communicating classes + type CommClass (..), + communicatingClasses, + irreducible, + + -- * Periodicity + period, + chainPeriod, + aperiodic, + cyclicClasses, + + -- * Recurrence and transience + recurrentState, + transientState, + recurrentStates, + transientStates, + absorbingStates, + + -- * Ergodicity + ergodic, +) where + +import Data.Array qualified as Array +import Data.Maybe ( + fromMaybe, + ) +import Dtmc.Analysis.Classification.Internal ( + type Classification (..), + type CommClass (..), + ) +import Dtmc.State ( + FiniteState, + ) +import Dtmc.State.Internal ( + stateFromInt, + stateIndexInt, + ) +import Dtmc.Transition.Matrix.Internal (TransitionMatrix, tmSupport) +import Dtmc.Transition.Matrix.Internal.Graph qualified as G +import Numeric.Natural (Natural) + +toState :: (FiniteState state) => Int -> state +toState index = + fromMaybe + (error "Dtmc.Analysis.Classification: graph vertex out of bounds") + (stateFromInt index) + +toIndex :: (FiniteState state) => state -> Int +toIndex = stateIndexInt + +{- | Test whether @P(i,j) > 0@, so that the support graph contains the direct +edge @i -> j@. No tolerance is applied. + +Complexity: excluding shared support-graph construction, @O(d_i)@ time and +@O(1)@ temporary and result space for out-degree @d_i@ of state @i@. +-} +supportEdge :: + (FiniteState state) => + TransitionMatrix state -> + state -> + state -> + Bool +supportEdge p i j = G.hasEdge (tmSupport p) (toIndex i) (toIndex j) + +{- | Test whether @j@ is reachable from @i@ in zero or more transitions. +Every state is therefore reachable from itself, even without a self-loop. + +Complexity: excluding shared support-graph construction, @O(n + E)@ time, +@O(n)@ temporary space, and @O(1)@ result space. +-} +accessible :: + (FiniteState state) => + TransitionMatrix state -> + state -> + state -> + Bool +accessible p i j = G.reachable (tmSupport p) (toIndex i) (toIndex j) + +{- | Test whether any supplied target is reachable from @i@ in zero or more +transitions. An empty target list gives 'False'; including @i@ gives 'True'. + +The graph is traversed once rather than once per target. + +Complexity: excluding shared support-graph construction, @O(n + E + t)@ +worst-case time, @O(n + t)@ temporary space, and @O(1)@ result space for @t@ +supplied targets. +-} +reachesAny :: + (FiniteState state) => + TransitionMatrix state -> + state -> + [state] -> + Bool +reachesAny p i targets = + G.reachesAny (tmSupport p) (toIndex i) (map toIndex targets) + +{- | Test whether @i@ and @j@ communicate, meaning that each is reachable +from the other. This is an equivalence relation on the state space. + +Complexity: excluding shared support-graph construction, the first query +takes @O(n + E + n log(n + 1))@ time and @O(n + E)@ temporary space and +retains @O(n)@ component-cache space; subsequent queries take @O(1)@ time. +Temporary and result space per cached query are @O(1)@. +-} +communicates :: + (FiniteState state) => + TransitionMatrix state -> + state -> + state -> + Bool +communicates p i j = + G.sameComponent (tmSupport p) (toIndex i) (toIndex j) + +{- | Return the communicating classes, equivalently the strongly connected +components of the support graph, each with its period and whether it is +closed. States within each class are ascending, and classes are ordered by +their least member. For the members alone, use +@map 'classMembers' . communicatingClasses@. + +Whole-chain queries in this module share one pass over the support graph. + +Complexity: excluding shared support-graph construction, the first full +evaluation takes @O(n + E + n log(n + 1))@ time and @O(n + E)@ temporary +space and retains @O(n)@ component cache; subsequent evaluations take +@O(n)@ time and temporary space. Result space is @O(n)@. +-} +communicatingClasses :: + (FiniteState state) => + TransitionMatrix state -> + [CommClass state] +communicatingClasses = classesOf . classify + +{- | Test whether every state communicates with every other state. The empty +chain is not irreducible. + +Complexity: excluding shared support-graph construction, the first query +takes @O(n + E + n log(n + 1))@ time and @O(n + E)@ temporary space and +retains @O(n)@ component-cache space; subsequent queries take @O(1)@ time. +Temporary and result space per cached query are @O(1)@. +-} +irreducible :: TransitionMatrix state -> Bool +irreducible = graphIrreducible . tmSupport + +graphIrreducible :: G.Graph -> Bool +graphIrreducible graph = + case G.components graph of + [component] -> not (null component) + _ -> False + +{- | Return the period of @i@: +@gcd { k >= 1 | (P^k)(i,i) > 0 }@. Returns 'Nothing' when @i@ has no +positive-length return path, necessarily a singleton class without a +self-transition. + +Complexity: excluding shared support-graph construction, the first query +takes @O((n + E) log(n + 1))@ time and @O(n + E)@ temporary space and retains +@O(n)@ period-cache space; subsequent queries take @O(1)@ time. Temporary +and result space per cached query are @O(1)@. +-} +period :: + (FiniteState state) => + TransitionMatrix state -> + state -> + Maybe Natural +period p i = G.periodOf (tmSupport p) (toIndex i) + +{- | Test whether every communicating class has period @1@. The empty chain +and a chain containing a class with undefined period are not aperiodic under +this definition. + +Complexity: excluding shared support-graph construction, the first query +takes @O((n + E) log(n + 1))@ time and @O(n + E)@ temporary space and retains +@O(n)@ component and period cache; later queries take @O(c)@ time for @c@ +communicating classes. Temporary and result space per cached query are +@O(1)@. +-} +aperiodic :: TransitionMatrix state -> Bool +aperiodic = graphAperiodic . tmSupport + +graphAperiodic :: G.Graph -> Bool +graphAperiodic graph = + not (null components) + && all ((== Just 1) . G.componentPeriod graph) components + where + components = G.components graph + +{- | Partition an irreducible chain of period @d@ into cyclic classes +@C_0, ..., C_(d-1)@. Every transition from @C_r@ enters +@C_((r+1) mod d)@; @C_0@ contains the least state. Returns 'Nothing' for a +reducible chain or an undefined period. + +Complexity: excluding shared support-graph construction, the first full +evaluation takes @O((n + E) log(n + 1))@ time and @O(n + E)@ temporary space +and retains @O(n)@ component, period, and phase cache; later evaluations take +@O(n)@ time and temporary space. Result space is @O(n)@. +-} +cyclicClasses :: (FiniteState state) => TransitionMatrix state -> Maybe [[state]] +cyclicClasses p + | not (irreducible p) = Nothing + | otherwise = + case G.periodOf g 0 of + Nothing -> Nothing + Just d -> + let dInt = fromIntegral d + -- One pass buckets every vertex by its phase (@O(V + d)@), + -- rather than scanning all vertices once per phase. + buckets = + Array.accumArray + (flip (:)) + [] + (0, dInt - 1) + [(G.phaseOf g v, toState v) | v <- [0 .. G.graphDim g - 1]] + in Just [reverse (buckets Array.! r) | r <- [0 .. dInt - 1]] + where + g = tmSupport p + +{- | Test whether the chain returns to @i@ with probability one when started +there. For a finite DTMC this holds exactly when @i@ belongs to a closed +communicating class. + +Complexity: excluding shared support-graph construction, the first query +takes @O((n + E) log(n + 1))@ time and @O(n + E)@ temporary space and retains +@O(n)@ component-closedness cache; subsequent queries take @O(1)@ time. +Temporary and result space per cached query are @O(1)@. +-} +recurrentState :: + (FiniteState state) => + TransitionMatrix state -> + state -> + Bool +recurrentState p i = G.inClosedComponent (tmSupport p) (toIndex i) + +{- | Test whether @i@ is transient, meaning that its return probability is +less than one. This is the negation of 'recurrentState' for a finite DTMC. + +Complexity: excluding shared support-graph construction, the first query +takes @O((n + E) log(n + 1))@ time and @O(n + E)@ temporary space and retains +@O(n)@ component-closedness cache; subsequent queries take @O(1)@ time. +Temporary and result space per cached query are @O(1)@. +-} +transientState :: + (FiniteState state) => + TransitionMatrix state -> + state -> + Bool +transientState p i = not (recurrentState p i) + +{- | Return the members of closed communicating classes, ordered by class and +state index. Every non-empty finite DTMC has at least one; the empty chain +returns the empty list. + +Whole-chain queries in this module share one pass over the support graph. + +Complexity: excluding shared support-graph construction, the first full +evaluation takes @O((n + E) log(n + 1))@ time and @O(n + E)@ temporary space +and retains @O(n)@ component and closedness cache; later evaluations take +@O(n)@ time and temporary space. Result space is @O(n)@. +-} +recurrentStates :: (FiniteState state) => TransitionMatrix state -> [state] +recurrentStates = recurrentStatesOf . classify + +{- | Return the members of non-closed communicating classes, ordered by class +and state index. The result is empty exactly when every class is closed. + +Whole-chain queries in this module share one pass over the support graph. + +Complexity: excluding shared support-graph construction, the first full +evaluation takes @O((n + E) log(n + 1))@ time and @O(n + E)@ temporary space +and retains @O(n)@ component and closedness cache; later evaluations take +@O(n)@ time and temporary space. Result space is @O(n)@. +-} +transientStates :: (FiniteState state) => TransitionMatrix state -> [state] +transientStates = transientStatesOf . classify + +{- | Return the states that form a communicating class on their own and cannot +be left. For exact stochastic rows these are the absorbing states, those with +@P(i,i) = 1@; numerically derived or otherwise unchecked rows are classified +only by strict-positive support. + +Whole-chain queries in this module share one pass over the support graph. + +Complexity: excluding shared support-graph construction, the first full +evaluation takes @O((n + E) log(n + 1))@ time and @O(n + E)@ temporary space +and retains @O(n)@ component and closedness cache; later evaluations take +@O(n)@ time and temporary space. Result space is @O(n)@. +-} +absorbingStates :: (FiniteState state) => TransitionMatrix state -> [state] +absorbingStates = absorbingStatesOf . classify + +{- | Return the period shared by every state of an irreducible chain. Returns +'Nothing' for a reducible chain, where period is a per-class notion and +'period' should be used instead, and for a single class whose period is +undefined. + +Whole-chain queries in this module share one pass over the support graph. + +Complexity: excluding shared support-graph construction, the first query takes +@O((n + E) log(n + 1))@ time and @O(n + E)@ temporary space and retains @O(n)@ +component and period cache; later queries take @O(1)@ time. Temporary and +result space per cached query are @O(1)@. +-} +chainPeriod :: (FiniteState state) => TransitionMatrix state -> Maybe Natural +chainPeriod = chainPeriodOf . classify + +{- | Test whether the chain is irreducible and aperiodic. For a finite DTMC +this is the hypothesis under which @P^k@ converges to a matrix whose every row +is the unique stationary distribution, so 'Dtmc.Analysis.Limiting.converges' +holds and 'Dtmc.Analysis.Stationary.stationaryDistributions' returns exactly +one distribution. + +Complexity: as 'irreducible' and 'aperiodic' together. +-} +ergodic :: TransitionMatrix state -> Bool +ergodic p = irreducible p && aperiodic p + +{- | Build the complete class, period, recurrence, absorbing-state, +irreducibility, and aperiodicity report from one shared support graph. The +standalone whole-chain queries are focused projections of this report; scalar +reachability, period, and recurrence queries remain direct graph lookups. + +Complexity: full evaluation on an unforced matrix takes +@O(n^2 + (n + E) log(n + 1))@ time, @O(n^2 + n + E)@ temporary space, +@O(n + E)@ retained graph-cache space, and @O(n)@ result space. With all +graph facts cached, it takes @O(n)@ time and @O(n)@ temporary and result +space. +-} +classify :: (FiniteState state) => TransitionMatrix state -> Classification state +classify p = + Classification + { classesOf = cs + , isIrreducible = irreducible' + , isAperiodic = aperiodic' + , isErgodic = irreducible' && aperiodic' + , chainPeriodOf = chainPeriodOf' + , recurrentStatesOf = concatMap classMembers (filter classClosed cs) + , transientStatesOf = concatMap classMembers (filter (not . classClosed) cs) + , absorbingStatesOf = [i | cc <- cs, classClosed cc, [i] <- [classMembers cc]] + } + where + g = tmSupport p + cs = + [ CommClass + { classMembers = map toState c + , classPeriod = G.periodOf g v + , classClosed = G.inClosedComponent g v + } + | c@(v : _) <- G.components g + ] + irreducible' = graphIrreducible g + aperiodic' = graphAperiodic g + chainPeriodOf' = case cs of + [c] -> classPeriod c + _ -> Nothing diff --git a/src/Dtmc/Analysis/Classification/Internal.hs b/src/Dtmc/Analysis/Classification/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Dtmc/Analysis/Classification/Internal.hs @@ -0,0 +1,120 @@ +{-# LANGUAGE ExplicitNamespaces #-} + +{- | +Module : Dtmc.Analysis.Classification.Internal +Description : Internal carriers and graph operations for chain classification. + +Raw carrier types and solver-oriented graph operations behind +"Dtmc.Analysis.Classification": the per-class summary t'CommClass' and the +whole-chain structural report t'Classification'. This module exposes the +report constructor for trusted internal use; constructing it here may produce +summary fields inconsistent with its communicating classes. +-} +module Dtmc.Analysis.Classification.Internal ( + type CommClass (..), + type Classification (..), + backwardReachable, +) where + +import Data.Maybe ( + fromMaybe, + ) +import Dtmc.State ( + FiniteState, + ) +import Dtmc.State.Internal ( + stateFromInt, + stateIndexInt, + ) +import Dtmc.Transition.Matrix.Internal ( + TransitionMatrix, + tmSupport, + ) +import Dtmc.Transition.Matrix.Internal.Graph qualified as G +import Numeric.Natural ( + Natural, + ) + +{- | Structural facts about one communicating class. For a finite valid DTMC, +a closed class consists of recurrent states. +-} +data CommClass state = CommClass + { classMembers :: [state] + -- ^ Member states in ascending order. + , classPeriod :: Maybe Natural + -- ^ Shared state period, or 'Nothing' when the class has no cycle. + , classClosed :: Bool + -- ^ Whether no positive-probability transition leaves the class. + } + +deriving instance (Eq state) => Eq (CommClass state) + +deriving instance (Show state) => Show (CommClass state) + +{- | A consistent structural report built by +'Dtmc.Analysis.Classification.classify'. The constructor is exposed here for +trusted internal use; "Dtmc.Analysis.Classification" keeps it hidden so its +summary fields stay aligned with its communicating classes. +-} +data Classification state = Classification + { classesOf :: [CommClass state] + -- ^ The communicating classes, ordered by least member. + , isIrreducible :: Bool + -- ^ Whether the states form a single (non-empty) communicating class. + , isAperiodic :: Bool + -- ^ Whether every class has period @1@ (and there is at least one class). + , isErgodic :: Bool + {- ^ Whether the chain is irreducible and aperiodic. For a finite DTMC this + implies convergence to its unique stationary distribution. + -} + , chainPeriodOf :: Maybe Natural + {- ^ The period of an irreducible chain (@Just d@), or @Nothing@ for a + reducible chain, where period is a per-class notion, or when the single + class has no cycles. + -} + , recurrentStatesOf :: [state] + -- ^ States in closed classes, which are recurrent in a finite chain. + , transientStatesOf :: [state] + -- ^ States in non-closed classes, which are transient. + , absorbingStatesOf :: [state] + {- ^ Singleton closed classes. For exact stochastic rows these are + absorbing states with @P(i,i) = 1@; numerically derived or otherwise + unchecked rows are classified only by strict-positive support. + -} + } + +type role Classification nominal + +deriving instance (Eq state) => Eq (Classification state) + +deriving instance (Show state) => Show (Classification state) + +toState :: (FiniteState state) => Int -> state +toState index = + fromMaybe + (error "Dtmc.Analysis.Classification.Internal: graph vertex out of bounds") + (stateFromInt index) + +toIndex :: (FiniteState state) => state -> Int +toIndex = stateIndexInt + +{- | Return states from which an allowed seed is reachable along a support +path containing only states accepted by @allowed@. Disallowed seeds are +ignored; the result is duplicate-free and ordered by state index. + +For the complexity bounds, @n@ is the state count, @E@ the support-edge count, +@s@ the number of supplied seeds, and @r@ the number of returned states. + +Complexity: excluding @n@ evaluations of @allowed@, 'FiniteState' method +costs, and shared support-graph construction, @O(n + E + s)@ time, +@O(n + E + s)@ temporary space, and @O(r)@ result space. The first reverse +traversal also retains @O(n + E)@ predecessor-cache space. +-} +backwardReachable :: + (FiniteState state) => + TransitionMatrix state -> + (state -> Bool) -> + [state] -> + [state] +backwardReachable p allowed seeds = + map toState (G.backwardReachable (tmSupport p) (allowed . toState) (map toIndex seeds)) diff --git a/src/Dtmc/Analysis/Event.hs b/src/Dtmc/Analysis/Event.hs new file mode 100644 --- /dev/null +++ b/src/Dtmc/Analysis/Event.hs @@ -0,0 +1,64 @@ +{- | +Module : Dtmc.Analysis.Event +Description : Closed comparisons for discrete analysis quantities. + +A small, closed vocabulary for comparing a discrete random quantity with a +finite threshold. Analysis modules use this selector for exact masses, lower +tails, and upper tails without accepting arbitrary predicates or constructing +a general event algebra. +-} +module Dtmc.Analysis.Event ( + DiscreteEvent (..), + matches, + includesInfiniteOutcome, +) where + +import Numeric.Natural ( + Natural, + ) + +{- | A comparison between a non-negative integer-valued quantity and a finite +threshold. + +If the quantity can equal infinity, that atom belongs to 'GreaterThan' and +'AtLeast' and to none of the other events. Eventual hitting, eventual return, +and infinitely many visits remain separate queries because this type contains +only finite thresholds. +-} +data DiscreteEvent + = EqualTo Natural -- ^ The quantity equals the threshold. + | LessThan Natural -- ^ The quantity is strictly below the threshold. + | AtMost Natural -- ^ The quantity does not exceed the threshold. + | GreaterThan Natural -- ^ The quantity is strictly above the threshold. + | AtLeast Natural -- ^ The quantity is at least the threshold. + deriving (Eq, Ord, Show) + +{- | Test whether a finite value satisfies a 'DiscreteEvent'. This is the +literal closed comparison semantics and performs no probability calculation. +For the separate infinite outcome, use 'includesInfiniteOutcome'. + +Complexity: @O(1)@ time and @O(1)@ space. +-} +matches :: DiscreteEvent -> Natural -> Bool +matches event value = + case event of + EqualTo threshold -> value == threshold + LessThan threshold -> value < threshold + AtMost threshold -> value <= threshold + GreaterThan threshold -> value > threshold + AtLeast threshold -> value >= threshold + +{- | Test whether the event contains the infinity atom of an extended-natural +quantity. Every finite threshold is below infinity, so precisely the two +upper-tail comparisons contain it. + +Complexity: @O(1)@ time and @O(1)@ space. +-} +includesInfiniteOutcome :: DiscreteEvent -> Bool +includesInfiniteOutcome event = + case event of + EqualTo _ -> False + LessThan _ -> False + AtMost _ -> False + GreaterThan _ -> True + AtLeast _ -> True diff --git a/src/Dtmc/Analysis/Expectation.hs b/src/Dtmc/Analysis/Expectation.hs new file mode 100644 --- /dev/null +++ b/src/Dtmc/Analysis/Expectation.hs @@ -0,0 +1,25 @@ +{- | +Module : Dtmc.Analysis.Expectation +Description : Finite and infinite expectations of non-negative quantities. + +A shared result type for expectations that may be mathematically infinite. +It is used by hitting-time, return-time, and total visit-count analysis. +-} +module Dtmc.Analysis.Expectation ( + Expectation (..), +) where + +{- | An expectation of a non-negative random quantity. + +'FiniteExpectation' performs no validation: callers can construct negative, +non-finite, or @NaN@ values. Library functions use 'InfiniteExpectation' for a +structural mathematical infinity, not floating-point overflow. Derived +ordering places every 'FiniteExpectation' before 'InfiniteExpectation'; finite +comparisons inherit the behaviour of 'Double', including @NaN@. +-} +data Expectation + = -- | A finite expectation represented as a 'Double', without validation. + FiniteExpectation Double + | -- | A mathematically infinite expectation. + InfiniteExpectation + deriving (Eq, Ord, Show) diff --git a/src/Dtmc/Analysis/FiniteTime.hs b/src/Dtmc/Analysis/FiniteTime.hs new file mode 100644 --- /dev/null +++ b/src/Dtmc/Analysis/FiniteTime.hs @@ -0,0 +1,169 @@ +{- | +Module : Dtmc.Analysis.FiniteTime +Description : Transition, event, and conditional probabilities. + +Finite-time probability queries shared by dense finite matrices and locally +finite kernels. Kernels implement 'Transition'; initial laws may be either a +dense finite @DistributionVector@ or a @DistributionMap@ through the +'Distribution' abstraction. All calculations use finite reachable support +and perform no truncation, clamping, or renormalisation. +-} +module Dtmc.Analysis.FiniteTime ( + stepProbability, + nStepProbability, + probability, + probabilityGiven, + Observation (..), + ConditionalProbabilityError (..), +) where + +import Dtmc.Analysis.FiniteTime.Internal ( + NormalisedObservations (..), + normalise, + ) +import Dtmc.Distribution ( + Distribution (..), + ) +import Dtmc.Distribution.Map ( + pointMass, + ) +import Dtmc.Dynamics ( + evolveN, + ) +import Dtmc.Transition ( + Transition (..), + ) +import Numeric.Natural ( + Natural, + ) + +{- | A timed state observation. @At t i@ is the event @X_t = i@. A list of +observations denotes their conjunction; list order has no meaning. +-} +data Observation state + = At Natural state -- ^ Require the supplied state at the specified time. + deriving (Eq, Show) + +-- | Why a conditional probability query has no defined value. +data ConditionalProbabilityError + = -- | The condition has probability exactly zero. + ZeroProbabilityCondition + deriving (Eq, Show) + +{- | Return the one-step transition probability +@P(X_1 = j | X_0 = i)@ through any locally finite 'Transition'. + +Complexity: excluding 'transitionLaw', @O(log(s + 1))@ time and @O(1)@ +temporary and result space for returned law support size @s@. +-} +stepProbability :: + (Transition kernel, Ord (TransitionState kernel)) => + kernel -> + TransitionState kernel -> + TransitionState kernel -> + Double +stepProbability kernel source = + probabilityAt (transitionLaw kernel source) + +{- | Return the @k@-step transition probability @P(X_k = j | X_0 = i)@. At +@k = 0@ this is the Kronecker delta. + +For the complexity bounds, @w@, @e@, and @u@ are per-step upper bounds on +stored source states, traversed transition edges, and accumulated destination +states, and @r@ bounds the final stored support. + +Complexity: excluding 'transitionLaw', +@O(k (w + e log(u + 1) + u) + log(r + 1) + 1)@ time, @O(w + u)@ temporary +space, and @O(1)@ result space. +-} +nStepProbability :: + (Transition kernel, Ord (TransitionState kernel)) => + Natural -> + kernel -> + TransitionState kernel -> + TransitionState kernel -> + Double +nStepProbability steps kernel source = + probabilityAt (evolveN steps (pointMass source) kernel) + +{- | Compute the probability of a conjunction of timed observations. +Observation order has no meaning, duplicates collapse, and an empty +conjunction is exactly one. Contradictory observations at one time give +exactly zero without inspecting the initial distribution or kernel. + +A state probability is represented by a singleton observation. A consecutive +path is represented by observations at times zero, one, and so on. + +For the complexity bounds, @m@ is the supplied observation count, @q@ the +normalised count, @k@ the greatest observed time, and @s_0@ the initial stored +support size. Across all propagation steps and observation gaps, @w@, @e@, +and @u@ bound stored source states, traversed transition edges, and +accumulated destination states, while @r@ bounds support at each lookup. Let +@C = w + e log(u + 1) + u@. + +Complexity: excluding the initial 'distributionWeights' call and all +'transitionLaw' evaluations, +@O(m log(m + 1) + s_0 + k C + q log(r + 1) + 1)@ time, +@O(m + w + u)@ temporary space, and @O(1)@ result space. +-} +probability :: + ( Distribution distribution + , Transition kernel + , DistributionState distribution ~ TransitionState kernel + , Ord (TransitionState kernel) + ) => + distribution -> + kernel -> + [Observation (TransitionState kernel)] -> + Double +probability initial kernel observations = + case normalise [(time, state) | At time state <- observations] of + Impossible -> 0 + Consistent [] -> 1 + Consistent ((firstTime, firstState) : rest) -> + probabilityAt (evolveN firstTime initial kernel) firstState + * gaps (firstTime, firstState) rest + where + gaps _ [] = 1 + gaps (previousTime, previousState) ((time, state) : more) = + nStepProbability + (time - previousTime) + kernel + previousState + state + * gaps (time, state) more + +{- | Compute conditional probability @P(E | C)@ for two conjunctions of timed +observations. An exactly zero-probability condition returns +'ZeroProbabilityCondition' without evaluating the numerator; otherwise the +result is the ordinary 'Double' quotient of the joint and condition +probabilities. + +For the complexity bounds, use the parameters from 'probability' across both +probability evaluations: @m@ is the total number of pairs processed, @q@ the +total normalised count, and @k@ the total number of propagation steps. +Let @C = w + e log(u + 1) + u@. + +Complexity: excluding up to two initial 'distributionWeights' calls and all +'transitionLaw' evaluations, +@O(m log(m + 1) + s_0 + k C + q log(r + 1) + 1)@ time, +@O(m + w + u)@ temporary space, and @O(1)@ result space. +-} +probabilityGiven :: + ( Distribution distribution + , Transition kernel + , DistributionState distribution ~ TransitionState kernel + , Ord (TransitionState kernel) + ) => + distribution -> + kernel -> + [Observation (TransitionState kernel)] -> + [Observation (TransitionState kernel)] -> + Either ConditionalProbabilityError Double +probabilityGiven initial kernel event condition = + if denominator == 0 + then Left ZeroProbabilityCondition + else Right (numerator / denominator) + where + denominator = probability initial kernel condition + numerator = probability initial kernel (event <> condition) diff --git a/src/Dtmc/Analysis/FiniteTime/Internal.hs b/src/Dtmc/Analysis/FiniteTime/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Dtmc/Analysis/FiniteTime/Internal.hs @@ -0,0 +1,54 @@ +{- | +Module : Dtmc.Analysis.FiniteTime.Internal +Description : Normalised timed observations (unsafe underbelly). + +The private normal form behind the event and conditional probability queries +in "Dtmc.Analysis.FiniteTime". 'normalise' is the intended way to build a +t'NormalisedObservations': it establishes the invariant that a 'Consistent' +list holds exactly one @(time, state)@ entry per distinct time, in ascending +time order. Building 'Consistent' directly can break that invariant and give +the scoring in "Dtmc.Analysis.FiniteTime" a wrong answer. +-} +module Dtmc.Analysis.FiniteTime.Internal ( + NormalisedObservations (..), + normalise, +) where + +import Data.List ( + sortBy, + ) +import Data.Ord ( + comparing, + ) +import Numeric.Natural ( + Natural, + ) + +{- | A conjunction of timed state observations after sorting, de-duplication, +and consistency checking. +-} +data NormalisedObservations state + = -- | Two observations demand different states at one time. + Impossible + | -- | Distinct times in ascending order, each with one required state. + Consistent [(Natural, state)] + +{- | Normalise @(time, state)@ pairs by ascending time, collapse exact +duplicates, and detect contradictions. Pairs requiring different states at +the same time yield 'Impossible'; otherwise the result is 'Consistent' with +one entry per distinct time in ascending order, so consecutive entries always +have strictly increasing times. + +Complexity: @O(m log(m + 1))@ time, @O(m)@ temporary space, and @O(m)@ +worst-case result space for @m@ supplied pairs. +-} +normalise :: (Eq state) => [(Natural, state)] -> NormalisedObservations state +normalise pairs = + foldr insert (Consistent []) (sortBy (comparing fst) pairs) + where + insert _ Impossible = Impossible + insert step (Consistent []) = Consistent [step] + insert (t, i) (Consistent ((t', i') : rest)) + | t == t' && i == i' = Consistent ((t', i') : rest) + | t == t' = Impossible + | otherwise = Consistent ((t, i) : (t', i') : rest) diff --git a/src/Dtmc/Analysis/HittingTime.hs b/src/Dtmc/Analysis/HittingTime.hs new file mode 100644 --- /dev/null +++ b/src/Dtmc/Analysis/HittingTime.hs @@ -0,0 +1,616 @@ +{- | +Module : Dtmc.Analysis.HittingTime +Description : Exact, bounded, eventual, competing, and expected hitting times. + +Hitting-time quantities for DTMCs. Scalar exact-time and bounded queries work +through any locally finite 'Transition', including kernels on infinite state +spaces. Eventual, competing, and expected queries use a finite +'TransitionMatrix'. For a target set @A@, +@H_A = inf { t >= 0 | X_t in A }@. + +Exact-time and strictly bounded queries use finite recurrences. Eventual, +competing, and expected queries use support reachability and checked 'Double' +linear solves. Results are not clamped or renormalised. + +Unless stated otherwise, complexity bounds exclude 'FiniteState' method +costs. Bounds over abstract distributions, transitions, or target predicates +also identify the excluded typeclass-method and predicate costs. + +For finite-matrix bounds, @n@ is the state count and @E@ the support-edge +count. +-} +module Dtmc.Analysis.HittingTime ( + -- * Result types + LinearSystemError (..), + Expectation (..), + + -- * Hitting-time distribution + probability, + probabilityGivenInitialState, + + -- * Eventual hitting + eventualProbability, + eventualProbabilityGivenInitialState, + + -- * Competing targets + raceProbability, + raceProbabilityGivenInitialState, + + -- * Expected hitting time + expectation, + expectationGivenInitialState, +) where + +import Data.Array qualified as Array +import Data.Array.Unboxed qualified as Unboxed +import Data.Map.Strict ( + Map, + ) +import Data.Map.Strict qualified as Map +import Data.Maybe ( + fromMaybe, + ) +import Dtmc.Analysis.Classification.Internal ( + backwardReachable, + ) +import Dtmc.Analysis.Event ( + DiscreteEvent (..), + ) +import Dtmc.Analysis.Expectation ( + Expectation (..), + ) +import Dtmc.Analysis.Initial.Internal ( + expectationUnderEither, + probabilityUnder, + probabilityUnderEither, + ) +import Dtmc.Analysis.LinearSystem ( + LinearSystemError (..), + ) +import Dtmc.Analysis.LinearSystem.Internal ( + rowSums, + solveIminusQVector, + subMatrix, + ) +import Dtmc.Distribution ( + Distribution (..), + ) +import Dtmc.Dynamics.Internal ( + pushSparseWeights, + ) +import Dtmc.State ( + FiniteState, + ) +import Dtmc.State.Internal ( + stateCardinalityInt, + stateFromInt, + stateIndexInt, + ) +import Dtmc.Transition ( + Transition (..), + ) +import Dtmc.Transition.Matrix.Internal ( + TransitionMatrix, + unTransitionMatrix, + ) +import Numeric.LinearAlgebra qualified as LA +import Numeric.Natural ( + Natural, + ) + +toIndex :: (FiniteState state) => state -> Int +toIndex = stateIndexInt + +toState :: (FiniteState state) => Int -> state +toState index = + fromMaybe + (error "Dtmc.Analysis.HittingTime: graph vertex out of bounds") + (stateFromInt index) + +-- Use a mask so duplicates collapse and per-state membership stays O(1). +indexMask :: Int -> [Int] -> Unboxed.UArray Int Bool +indexMask dim indices = + Unboxed.accumArray (||) False (0, dim - 1) [(i, True) | i <- indices] + +advanceUntilTarget :: + (Transition kernel, Ord (TransitionState kernel)) => + kernel -> + (TransitionState kernel -> Bool) -> + Map (TransitionState kernel) Double -> + (Map (TransitionState kernel) Double, Double) +advanceUntilTarget kernel isTarget survivors = + (remaining, hitMass) + where + advanced = pushSparseWeights survivors kernel + (hits, remaining) = Map.partitionWithKey (\state _ -> isTarget state) advanced + hitMass = sum (Map.elems hits) + +{- | Compute the exact scalar hitting-time probability +@P(H_A = t | X_0 = i)@ through any 'Transition'. The target set is represented +by a membership predicate, which also works when the state space is infinite. +Hitting includes time zero, and newly hit mass is removed after every step. + +Complexity: excluding 'transitionLaw' and predicate evaluation, +@O(k (w + e log(u + 1) + u) + 1)@ time, @O(w + u)@ temporary space, and +@O(1)@ result space, where @k = t@ and @w@, @e@, and @u@ bound per-step +survivor states, traversed transition edges, and accumulated destinations. +-} +exactProbabilityAt :: + ( Transition kernel + , Ord (TransitionState kernel) + ) => + Natural -> + kernel -> + (TransitionState kernel -> Bool) -> + TransitionState kernel -> + Double +exactProbabilityAt time kernel isTarget initialState + | time == 0 = if isTarget initialState then 1 else 0 + | isTarget initialState = 0 + | otherwise = go time (Map.singleton initialState 1) + where + go 0 _ = 0 + go _ survivors | Map.null survivors = 0 + go remaining survivors = + let (next, hitMass) = advanceUntilTarget kernel isTarget survivors + in if remaining == 1 + then hitMass + else go (remaining - 1) next + +{- | Compute the strict bounded scalar hitting probability +@P(H_A < c | X_0 = i)@ through any 'Transition'. At @c = 0@ the result is +zero; at a positive bound an initial target gives one. + +Complexity: excluding 'transitionLaw' and predicate evaluation, +@O(k (w + e log(u + 1) + u) + 1)@ time, @O(w + u)@ temporary space, and +@O(1)@ result space, where @k = c@ and @w@, @e@, and @u@ bound per-step +survivor states, traversed transition edges, and accumulated destinations. +-} +lowerTailProbability :: + ( Transition kernel + , Ord (TransitionState kernel) + ) => + Natural -> + kernel -> + (TransitionState kernel -> Bool) -> + TransitionState kernel -> + Double +lowerTailProbability bound kernel isTarget initialState + | bound == 0 = 0 + | isTarget initialState = 1 + | otherwise = go (bound - 1) (Map.singleton initialState 1) 0 + where + go 0 _ total = total + go _ survivors total | Map.null survivors = total + go remaining survivors total = + let (next, hitMass) = advanceUntilTarget kernel isTarget survivors + cumulative = total + hitMass + in cumulative `seq` go (remaining - 1) next cumulative + +{- | Compute hitting probabilities +@h_i = P(H_A < infinity | X_0 = i)@ in state order. Target order and +duplicates are ignored; an empty target set gives an all-zero vector. + +The result is the minimal non-negative solution of @h_i = 1@ on @A@ and +@h_i = sum_j P(i,j) h_j@ elsewhere. Target entries are exactly @1@, and +states from which @A@ is unreachable are exactly @0@. Remaining entries solve +@(I - P[D,D])x = P[D,A]1@ and inherit floating-point error. + +Returns 'Left' if the interior solve fails the numerical contract. + +Complexity: @O(n^3 + a)@ worst-case time, @O(n^2 + a)@ temporary space, +@O(n + E)@ retained graph-cache space, and @O(n)@ result space for @n@ +states, @E@ support edges, and @a@ supplied targets. +-} +eventualProbabilitiesByState :: + (FiniteState state) => + TransitionMatrix state -> + [state] -> + Either LinearSystemError (LA.Vector Double) +eventualProbabilitiesByState p targets = + -- The ordinary hitting problem is the competing problem with no competing + -- boundary (@H_B = infinity@), so it reuses the same single solve. + raceProbabilitiesByState p targets [] + +{- | Compute the probability of ever hitting the target set from one state. +This has the same edge cases, numerical behaviour, and errors as +@eventualProbabilitiesByState@. + +Partially applying the matrix and target set shares one lazy all-state solve: +the first forced query computes the table, and later lookups read it directly. + +Complexity: the first forced query takes @O(n^3 + a)@ worst-case time and +@O(n^2 + a)@ temporary space for @n@ states and @a@ supplied targets. It may +retain an @O(n)@ all-state result and @O(n + E)@ graph cache; subsequent +shared lookups take @O(1)@ time and space. The scalar result occupies +@O(1)@ space. +-} +eventualProbabilityGivenInitialState :: + forall state. + (FiniteState state) => + TransitionMatrix state -> + [state] -> + state -> + Either LinearSystemError Double +eventualProbabilityGivenInitialState p targets = + \i -> (`LA.atIndex` toIndex i) <$> probabilities + where + probabilities = eventualProbabilitiesByState p targets + +{- | Compute competing hitting probabilities +@h_i = P(H_A < H_B | X_0 = i)@ in state order, for a successful boundary @A@ +(first argument) and a competing boundary @B@ (second argument). Hitting times +include time zero, @H_A = inf { t >= 0 | X_t in A }@ and likewise for @B@, and +the comparison is /strict/: @A@ must be reached strictly before @B@. + +Target order and duplicate states are ignored in both lists. + +Overlap and ties. The two boundaries need not be disjoint. Reaching a state in +both @A@ and @B@ ties the two hitting times (@H_A = H_B@), and a tie fails the +strict inequality, so the competing boundary claims every shared state. Writing +the effective successful set as @A' = A \\ B@: + +* states in @A'@ have value exactly @1@; +* states in @B@ -- including states shared with @A@ -- have value exactly @0@; +* if @A@ and @B@ are identical, every result is @0@. + +Empty boundaries. Because @H_(empty) = infinity@: + +* an empty successful set gives an all-zero vector; +* an empty competing set agrees with 'eventualProbabilitiesByState' on the same + successful set; +* two empty sets give an all-zero vector. + +Reachability is structural. Using the strict-positive support graph, one reverse +traversal from @A'@ that is forbidden to pass through @B@ marks the states that +can reach @A'@ before @B@. This never consults floating-point probabilities, so +a state that cannot reach @A'@ at all, or can reach it only by first entering +@B@, is assigned exactly @0@ without a solve. For the remaining interior states +@D@ the values are the minimal non-negative solution of +@h_i = sum_j P(i,j) h_j@, i.e. @(I - P[D,D]) x = P[D,A'] 1@; these entries come +from the shared 'Double' linear solver, inherit its rounding, and are not +clamped to @[0, 1]@, renormalised, or given any tolerance. + +Returns 'Left' if the interior solve fails the numerical contract. For a valid +transition matrix the system is nonsingular in exact arithmetic, but may still +be too ill-conditioned for a reliable 'Double' result. The all-state result +performs at most one linear solve. + +Complexity: @O(n^3 + a + b)@ worst-case time and @O(n^2 + a + b)@ +temporary space for @n@ states and boundary-list lengths @a@ and @b@. The +matrix retains @O(n + E)@ graph-cache space, and the result occupies @O(n)@ +space. +-} +raceProbabilitiesByState :: + forall state. + (FiniteState state) => + TransitionMatrix state -> + [state] -> + [state] -> + Either LinearSystemError (LA.Vector Double) +raceProbabilitiesByState p successful competing = do + solved <- + if null interiorIdx + then Right [] + else + LA.toList + <$> solveIminusQVector + (subMatrix interiorIdx interiorIdx matrix) + (rowSums (subMatrix interiorIdx effectiveIdx matrix)) + let interiorValues :: Unboxed.UArray Int Double + interiorValues = + Unboxed.accumArray + (\_ x -> x) + 0 + (0, dim - 1) + (zip interiorIdx solved) + valueAt i + | inEffective i = 1 + | canReach i = interiorValues Unboxed.! i + | otherwise = 0 + pure (LA.fromList [valueAt i | i <- [0 .. dim - 1]]) + where + dim = stateCardinalityInt @state + -- Masks keep boundary and solution lookup constant-time during assembly. + competingMask = indexMask dim (map toIndex competing) + inCompeting i = competingMask Unboxed.! i + successfulMask = indexMask dim (map toIndex successful) + -- Effective successful set A' = A \ B. A state on both boundaries is a + -- tie, and a tie loses, so the competing boundary claims it. + inEffective i = successfulMask Unboxed.! i && not (inCompeting i) + effectiveIdx = [i | i <- [0 .. dim - 1], inEffective i] + -- One reverse traversal to A', forbidden to cross B, marks every state + -- that can reach A' before B; this is structural, not numerical. + reachMask = + indexMask + dim + ( map + toIndex + ( backwardReachable + p + (not . inCompeting . toIndex) + (map toState effectiveIdx) + ) + ) + canReach i = reachMask Unboxed.! i + interiorIdx = [i | i <- [0 .. dim - 1], not (inEffective i), canReach i] + matrix = unTransitionMatrix p + +{- | Compute the probability of hitting the successful boundary strictly +before the competing boundary from one state, @P(H_A < H_B | X_0 = i)@. This +has the same overlap, empty-set, structural, numerical, and error behaviour as +@raceProbabilitiesByState@. + +Partially applying the matrix and both boundaries shares one lazy all-state +solve. + +Complexity: the first forced query takes @O(n^3 + a + b)@ worst-case time and +@O(n^2 + a + b)@ temporary space for @n@ states and boundary-list lengths +@a@ and @b@. It may retain an @O(n)@ all-state result and @O(n + E)@ graph +cache; subsequent shared lookups take @O(1)@ time and space. The scalar result +occupies @O(1)@ space. +-} +raceProbabilityGivenInitialState :: + forall state. + (FiniteState state) => + TransitionMatrix state -> + [state] -> + [state] -> + state -> + Either LinearSystemError Double +raceProbabilityGivenInitialState p successful competing = + \i -> (`LA.atIndex` toIndex i) <$> probabilities + where + probabilities = raceProbabilitiesByState p successful competing + +{- | Compute expected hitting times @E(H_A | X_0 = i)@ in state order. +Targets have exact expectation zero. A non-target state has +'InfiniteExpectation' exactly when the target is not hit with probability +one; this is decided from support reachability, not a floating-point +comparison. An empty target set therefore gives 'InfiniteExpectation' for +every state. + +Finite entries are the solution of +@eta_i = 1 + sum_(j not in A) P(i,j) eta_j@. They inherit solver rounding and +are not clamped. Returns 'Left' if the finite-state system fails the numerical +contract. + +Complexity: @O(n^3 + a)@ worst-case time, @O(n^2 + a)@ temporary space, +@O(n + E)@ retained graph-cache space, and @O(n)@ result space for @n@ +states, @E@ support edges, and @a@ supplied targets. +-} +expectationsByState :: + forall state. + (FiniteState state) => + TransitionMatrix state -> + [state] -> + Either LinearSystemError [Expectation] +expectationsByState p targets = do + solved <- + if null certainIdx + then Right [] + else + LA.toList + <$> solveIminusQVector + (subMatrix certainIdx certainIdx matrix) + (LA.konst 1 (length certainIdx)) + let certainValues :: Unboxed.UArray Int Double + certainValues = + Unboxed.accumArray + (\_ x -> x) + 0 + (0, dim - 1) + (zip certainIdx solved) + valueAt i + | inTarget i = FiniteExpectation 0 + | doomedMask Unboxed.! i = InfiniteExpectation + | otherwise = FiniteExpectation (certainValues Unboxed.! i) + pure [valueAt i | i <- [0 .. dim - 1]] + where + dim = stateCardinalityInt @state + targetMask = indexMask dim (map toIndex targets) + inTarget i = targetMask Unboxed.! i + -- One reverse traversal replaces a reachability query for every state. + reachMask = + indexMask dim (map toIndex (backwardReachable p (const True) targets)) + unreachable = + [i | i <- [0 .. dim - 1], not (inTarget i), not (reachMask Unboxed.! i)] + -- Reaching an unreachable state without crossing the target makes the + -- hitting probability less than one. + doomed = + backwardReachable + p + (not . inTarget . toIndex) + (map toState unreachable) + doomedMask = indexMask dim (map toIndex doomed) + certainIdx = + [i | i <- [0 .. dim - 1], not (inTarget i), not (doomedMask Unboxed.! i)] + matrix = unTransitionMatrix p + +{- | Compute the expected time to hit the target set from one state. This has +the same edge cases, numerical behaviour, and errors as @expectationsByState@. + +Partial application shares one lazy all-state table: the first forced query +computes the table, and later lookups read it directly. + +Complexity: the first forced query takes @O(n^3 + a)@ worst-case time and +@O(n^2 + a)@ temporary space for @n@ states and @a@ supplied targets. It may +retain an @O(n)@ all-state result and @O(n + E)@ graph cache; subsequent +shared lookups take @O(1)@ time and space. The scalar result occupies +@O(1)@ space. +-} +expectationGivenInitialState :: + forall state. + (FiniteState state) => + TransitionMatrix state -> + [state] -> + state -> + Either LinearSystemError Expectation +expectationGivenInitialState p targets = + \i -> (Array.! toIndex i) <$> table + where + -- Back the shared table with a boxed array so each state query is O(1) + -- List indexing was linear; the array keeps shared queries constant-time. + table = + Array.listArray (0, dim - 1) <$> expectationsByState p targets + dim = stateCardinalityInt @state + +-- Direct survivor mass @P(H_A > t)@ through a locally finite transition. +-- Newly hit paths are removed at every step, so paths that never hit remain +-- in the map and the result naturally includes the infinity atom. +upperTailProbability :: + ( Transition kernel + , Ord (TransitionState kernel) + ) => + Natural -> + kernel -> + (TransitionState kernel -> Bool) -> + TransitionState kernel -> + Double +upperTailProbability time kernel isTarget initialState + | isTarget initialState = 0 + | otherwise = go time (Map.singleton initialState 1) + where + go 0 survivors = sum (Map.elems survivors) + go _ survivors | Map.null survivors = 0 + go remaining survivors = + let (next, _) = advanceUntilTarget kernel isTarget survivors + in next `seq` go (remaining - 1) next + +{- | Compute, under an arbitrary initial distribution, the probability of a +finite-threshold event in the hitting time +@H_A = inf { t >= 0 | X_t in A }@. The initial distribution supplies the +probability measure @P_mu@. + +'EqualTo' and the two lower tails reuse the direct exact/bounded recurrences. +'GreaterThan' and 'AtLeast' use surviving mass directly rather than subtracting +a cumulative probability from one. Consequently upper tails include the atom +at infinity and avoid cancellation when the surviving probability is small. +'AtLeast' @0@ is exactly one. + +This function works through any locally finite 'Transition'. Results use +ordinary 'Double' arithmetic without clamping or renormalisation. + +For the complexity bounds, @s@ is the initial stored support size, @k@ the +event threshold, and @w@, @e@, and @u@ are per-step upper bounds on survivor +states, traversed transition edges, and accumulated destinations. + +Complexity: excluding 'distributionWeights', 'transitionLaw', and predicate +evaluation, @O(s (k (w + e log(u + 1) + u) + 1))@ time, +@O(s + w + u)@ temporary space, and @O(1)@ result space. +-} +probability :: + ( Distribution distribution + , Transition kernel + , DistributionState distribution ~ TransitionState kernel + , Ord (TransitionState kernel) + ) => + DiscreteEvent -> + kernel -> + (TransitionState kernel -> Bool) -> + distribution -> + Double +probability event kernel isTarget initial = + probabilityUnder initial (probabilityGivenInitialState event kernel isTarget) + +{- | Compute the probability of a finite-threshold hitting-time event +conditioned on @X_0 = i@. Hitting includes time zero and follows the event +boundary behaviour documented by 'probability'. + +For the complexity bounds, @k@ is the event threshold and @w@, @e@, and @u@ +are per-step upper bounds on survivor states, traversed transition edges, and +accumulated destinations. + +Complexity: excluding 'transitionLaw' and predicate evaluation, +@O(k (w + e log(u + 1) + u) + 1)@ time, @O(w + u)@ temporary space, and +@O(1)@ result space. +-} +probabilityGivenInitialState :: + ( Transition kernel + , Ord (TransitionState kernel) + ) => + DiscreteEvent -> + kernel -> + (TransitionState kernel -> Bool) -> + TransitionState kernel -> + Double +probabilityGivenInitialState event kernel isTarget initialState = + case event of + EqualTo time -> + exactProbabilityAt time kernel isTarget initialState + LessThan bound -> + lowerTailProbability bound kernel isTarget initialState + AtMost time -> + lowerTailProbability (time + 1) kernel isTarget initialState + GreaterThan time -> + upperTailProbability time kernel isTarget initialState + AtLeast 0 -> 1 + AtLeast time -> + upperTailProbability (time - 1) kernel isTarget initialState + +{- | Compute, under an arbitrary initial distribution, the probability of ever +hitting the target set. Target order and duplicates do not affect the result; +an empty target set gives zero. Numerical failures come from the checked +all-state linear solve. + +Complexity: excluding 'distributionWeights', @O(n^3 + a + s)@ worst-case +time, @O(n^2 + a + s)@ temporary space, and @O(1)@ result space for @n@ +states, @a@ supplied targets, and initial stored support size @s@. The matrix +may retain @O(n + E)@ graph-cache space. +-} +eventualProbability :: + ( FiniteState state + , Distribution distribution + , DistributionState distribution ~ state + ) => + TransitionMatrix state -> + [state] -> + distribution -> + Either LinearSystemError Double +eventualProbability matrix targets initial = + probabilityUnderEither initial (eventualProbabilityGivenInitialState matrix targets) + +{- | Compute, under an arbitrary initial distribution, the probability of +hitting the successful boundary strictly before the competing boundary. +Overlap ties lose, and empty-boundary behaviour matches +'raceProbabilityGivenInitialState'. + +Complexity: excluding 'distributionWeights', @O(n^3 + a + b + s)@ +worst-case time, @O(n^2 + a + b + s)@ temporary space, and @O(1)@ result +space for @n@ states, boundary-list lengths @a@ and @b@, and initial stored +support size @s@. The matrix may retain @O(n + E)@ graph-cache space. +-} +raceProbability :: + ( FiniteState state + , Distribution distribution + , DistributionState distribution ~ state + ) => + TransitionMatrix state -> + [state] -> + [state] -> + distribution -> + Either LinearSystemError Double +raceProbability matrix successful competing initial = + probabilityUnderEither initial (raceProbabilityGivenInitialState matrix successful competing) + +{- | Compute the expected hitting time under an arbitrary initial +distribution. It is 'InfiniteExpectation' exactly when a state of positive +initial probability does not hit the target almost surely. Numerical failures +come from the checked all-state linear solve. + +Complexity: excluding 'distributionWeights', @O(n^3 + a + s)@ worst-case +time, @O(n^2 + a + s)@ temporary space, and @O(1)@ result space for @n@ +states, @a@ supplied targets, and initial stored support size @s@. The matrix +may retain @O(n + E)@ graph-cache space. +-} +expectation :: + ( FiniteState state + , Distribution distribution + , DistributionState distribution ~ state + ) => + TransitionMatrix state -> + [state] -> + distribution -> + Either LinearSystemError Expectation +expectation matrix targets initial = + expectationUnderEither initial (expectationGivenInitialState matrix targets) diff --git a/src/Dtmc/Analysis/Initial/Internal.hs b/src/Dtmc/Analysis/Initial/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Dtmc/Analysis/Initial/Internal.hs @@ -0,0 +1,94 @@ +{-# LANGUAGE TypeFamilies #-} + +{- | +Module : Dtmc.Analysis.Initial.Internal +Description : Mixing state-conditioned analysis results under an initial law. + +Private helpers for turning quantities conditioned on @X_0 = i@ into the +corresponding quantity under an arbitrary finite-support initial distribution. +Weights and query results are combined with ordinary 'Double' arithmetic; +these helpers do not validate, clamp, or renormalise them. +-} +module Dtmc.Analysis.Initial.Internal ( + probabilityUnder, + probabilityUnderEither, + expectationUnderEither, +) where + +import Control.Monad ( + foldM, + ) +import Dtmc.Analysis.Expectation ( + Expectation (..), + ) +import Dtmc.Distribution ( + Distribution (..), + ) + +{- | Compute the initial-law mixture of state-conditioned probabilities. +Every stored state is queried, and an empty weight list sums to zero. + +Complexity: excluding 'distributionWeights' and query evaluations, @O(s)@ +time, @O(s)@ temporary space, and @O(1)@ result space for @s@ stored weights. +-} +probabilityUnder :: + (Distribution distribution) => + distribution -> + (DistributionState distribution -> Double) -> + Double +probabilityUnder initial query = + sum + [ weight * query state + | (state, weight) <- distributionWeights initial + ] + +{- | Compute the initial-law mixture of fallible state-conditioned +probabilities. Queries are evaluated in stored order, and the first 'Left' +is returned without evaluating later queries. On success, values are combined +with ordinary 'Double' arithmetic. + +Complexity: excluding 'distributionWeights' and query evaluations, @O(s)@ +worst-case time, @O(s)@ temporary space, and @O(1)@ result space for @s@ +stored weights. +-} +probabilityUnderEither :: + (Distribution distribution) => + distribution -> + (DistributionState distribution -> Either error Double) -> + Either error Double +probabilityUnderEither initial query = + sum + <$> traverse + (\(state, weight) -> (weight *) <$> query state) + (distributionWeights initial) + +{- | Compute the initial-law mixture of fallible non-negative expectations. +A positive-weight 'InfiniteExpectation' makes the result infinite; a +zero-weight infinity is ignored. After the result becomes infinite, remaining +weights are traversed without evaluating their queries. Before that point, +the first query error is returned. + +Finite values use ordinary 'Double' arithmetic without validation. + +Complexity: excluding 'distributionWeights' and query evaluations, @O(s)@ +worst-case time, @O(s)@ temporary space, and @O(1)@ result space for @s@ +stored weights. +-} +expectationUnderEither :: + (Distribution distribution) => + distribution -> + (DistributionState distribution -> Either error Expectation) -> + Either error Expectation +expectationUnderEither initial query = + foldM add (FiniteExpectation 0) (distributionWeights initial) + where + add InfiniteExpectation _ = Right InfiniteExpectation + add (FiniteExpectation total) (state, weight) = do + value <- query state + pure $ + case value of + InfiniteExpectation + | weight > 0 -> InfiniteExpectation + | otherwise -> FiniteExpectation total + FiniteExpectation x -> + FiniteExpectation (total + weight * x) diff --git a/src/Dtmc/Analysis/Limiting.hs b/src/Dtmc/Analysis/Limiting.hs new file mode 100644 --- /dev/null +++ b/src/Dtmc/Analysis/Limiting.hs @@ -0,0 +1,382 @@ +{- | +Module : Dtmc.Analysis.Limiting +Description : Limits of the n-step transition matrix. + +Long-run behaviour of @P^n@ for a finite chain. For a target @j@ in a +recurrent class @C@ that is aperiodic, + +@lim_(n -> infinity) (P^n)(i,j) = h(i,C) pi^C(j)@, + +where @h(i,C)@ is the probability of ever entering @C@ from @i@ and @pi^C@ is +the stationary distribution carried by @C@. A transient target has limit +zero. The limit therefore exists exactly when every recurrent class is +aperiodic; a periodic class makes the entries oscillate forever. + +For any finite chain, let @d@ be the least common multiple of its recurrent +class periods. The whole matrix has @d@ subsequential limits, one for each +residue of @n@ modulo @d@, and 'cyclicLimits' returns them. An empty chain uses +@d = 1@. + +'limitingMatrix' assembles eventual hitting probabilities and per-class +stationary distributions without powering the matrix. 'cyclicLimits' applies +that decomposition to @P^d@ and rotates its recurrent phase classes. No +truncation or convergence threshold is involved. Class periods are decided +combinatorially; entries inherit the numerical behaviour of the underlying +solves and matrix products. + +Unless stated otherwise, complexity bounds exclude 'FiniteState' method +costs. For those bounds, @n@ is the state count, @E@ the support-edge count, +@c@ the number of recurrent classes, and @d@ the least common multiple of +their periods. +-} +module Dtmc.Analysis.Limiting ( + LinearSystemError (..), + converges, + limitingMatrix, + cyclicLimits, +) where + +import Data.Array.Unboxed qualified as Unboxed +import Data.List qualified as List +import Dtmc.Analysis.Classification ( + classClosed, + classMembers, + classPeriod, + communicatingClasses, + transientStates, + ) +import Dtmc.Analysis.LinearSystem ( + LinearSystemError (..), + ) +import Dtmc.Analysis.LinearSystem.Internal ( + rowSums, + solveIminusQ, + subMatrix, + ) +import Dtmc.Analysis.Stationary ( + stationaryDistributions, + ) +import Dtmc.Distribution.Vector.Internal ( + DistributionVector, + unDistributionVector, + ) +import Dtmc.State ( + FiniteState, + ) +import Dtmc.State.Internal ( + stateCardinalityInt, + stateIndexInt, + ) +import Dtmc.Transition.Matrix ( + TransitionMatrix, + power, + ) +import Dtmc.Transition.Matrix.Internal ( + unTransitionMatrix, + ) +import Numeric.LinearAlgebra qualified as LA +import Numeric.Natural ( + Natural, + ) + +{- | Test whether @P^n@ converges entrywise, equivalently whether every +recurrent class is aperiodic. Transient classes are irrelevant because their +columns tend to zero whatever their period. + +The test is combinatorial, taken from the support graph, so it involves no +arithmetic and no tolerance. The empty chain converges vacuously. + +Complexity: on an unforced matrix, the first query takes +@O(n^2 + (n + E) log(n + 1))@ time and @O(n^2 + n + E)@ temporary space and +retains @O(n + E)@ graph and classification caches. With those facts cached, +it takes @O(c)@ time, @O(c)@ temporary space, and @O(1)@ result space. +-} +converges :: (FiniteState state) => TransitionMatrix state -> Bool +converges p = + all + ((== Just 1) . classPeriod) + [c | c <- communicatingClasses p, classClosed c] + +{- | Compute the entrywise limit of @P^n@, with rows and columns in the +canonical order of the 'FiniteState' instance. Return 'Nothing' exactly when +some recurrent class is periodic and the limit does not exist. + +Entry @(i,j)@ is @h(i,C) pi^C(j)@ for @j@ in the recurrent class @C@, and an +exact zero for transient @j@ -- the class distributions vanish there, so the +zero costs no arithmetic. All recurrent-class hitting probabilities are the +columns of one linear system; each recurrent class still contributes one +stationary solve. + +Rows sum to one mathematically because a finite chain enters some recurrent +class almost surely. Numerical failures come from the checked hitting and +stationary solves. A periodic chain returns 'Nothing' without those solves. + +Complexity: @O(n^3)@ worst-case time, @O(n^2)@ temporary space, +@O(n + E)@ retained graph-cache space, and @O(n^2)@ result space. +-} +limitingMatrix :: + forall state. + (FiniteState state) => + TransitionMatrix state -> + Either LinearSystemError (Maybe [[Double]]) +limitingMatrix p + | not (converges p) = Right Nothing + | otherwise = Just <$> convergentLimit p + +{- | Compute the limiting matrix of a chain already known to have only +aperiodic recurrent classes. Keeping this separate lets 'cyclicLimits' apply +the same class-and-hitting decomposition to @P^d@ without a redundant +convergence branch. + +The caller is responsible for the aperiodicity precondition. Numerical +failures come from the checked hitting and stationary solves. + +Complexity: @O(n^3)@ worst-case time, @O(n^2)@ temporary space, +@O(n + E)@ retained graph-cache space, and @O(n^2)@ result space. +-} +convergentLimit :: + forall state. + (FiniteState state) => + TransitionMatrix state -> + Either LinearSystemError [[Double]] +convergentLimit p = do + (classes, entering) <- limitDecomposition p + if null classes + then pure (replicate dim (replicate dim 0)) + else + pure + ( LA.toLists + ( entering + LA.<> LA.fromRows + [ unDistributionVector distribution + | (_, distribution) <- classes + ] + ) + ) + where + dim = stateCardinalityInt @state + +{- | Compute the recurrent-class stationary distributions and the matrix +@H@ whose entry @(i,C)@ is the probability of eventually entering class @C@ +from @i@. + +Writing @T@ for the transient states, all transient rows are obtained from the +single multiple-right-hand-side system + +@(I - P[T,T]) H[T,*] = B@, + +where @B(i,C) = sum_(j in C) P(i,j)@. Recurrent rows are exact zero/one +boundary values supplied from classification. + +An empty chain returns no classes and an empty entering matrix. Numerical +failures come from the transient hitting solve or a class stationary solve. + +Complexity: @O(n^3)@ worst-case time, @O(n^2)@ temporary space, +@O(n + E)@ retained graph-cache space, and @O(c n)@ result space. +-} +limitDecomposition :: + forall state. + (FiniteState state) => + TransitionMatrix state -> + Either + LinearSystemError + ([([state], DistributionVector state)], LA.Matrix Double) +limitDecomposition p = do + classes <- stationaryDistributions p + transientSolution <- + if null transient + then Right (LA.konst 0 (0, classCount)) + else + solveIminusQ + (subMatrix transientIndices transientIndices matrix) + ( LA.fromColumns + [ rowSums (subMatrix transientIndices (map toIndex members) matrix) + | (members, _) <- classes + ] + ) + let entering = + LA.fromLists + [ [ entryAt stateIndex classIndex + | classIndex <- [0 .. classCount - 1] + ] + | stateIndex <- [0 .. dim - 1] + ] + entryAt stateIndex classIndex + | transientPosition Unboxed.! stateIndex >= 0 = + transientSolution + `LA.atIndex` (transientPosition Unboxed.! stateIndex, classIndex) + | otherwise = + if recurrentClass Unboxed.! stateIndex == classIndex then 1 else 0 + pure (classes, entering) + where + dim = stateCardinalityInt @state + matrix = unTransitionMatrix p + transient = transientStates p + transientIndices = map toIndex transient + closedClasses = + [ classMembers recurrentClass' + | recurrentClass' <- communicatingClasses p + , classClosed recurrentClass' + ] + classCount = length closedClasses + + transientPosition :: Unboxed.UArray Int Int + transientPosition = + Unboxed.accumArray + (\_ position -> position) + (-1) + (0, dim - 1) + (zip transientIndices [0 ..]) + + recurrentClass :: Unboxed.UArray Int Int + recurrentClass = + Unboxed.accumArray + (\_ classIndex -> classIndex) + (-1) + (0, dim - 1) + [ (toIndex member, classIndex) + | (classIndex, members) <- zip [0 ..] closedClasses + , member <- members + ] + + toIndex = stateIndexInt + +{- | Compute the @d@ subsequential limits of any finite chain, where @d@ is +the least common multiple of its recurrent class periods. Element @r@ is +@lim_(n -> infinity) P^(n d + r)@. When every recurrent class is aperiodic, +@d = 1@ and the single result is the ordinary limiting matrix. The empty chain +also returns one empty matrix. + +The powered chain @Q = P^d@ has only aperiodic recurrent classes. Its closed +classes are the cyclic phases of the original recurrent classes. One batched +solve finds the probability of entering every phase at times divisible by +@d@. A transition under @P@ permutes those phase classes, so later residues +are assembled by rotating class indices rather than multiplying dense +matrices. This accounts automatically for multiple recurrent classes, +transient-state hitting probabilities, and entry phases. + +Numerical failures come from the checked hitting and stationary solves. An +inconsistent phase-class successor relation produces 'SingularSystem'. + +Complexity: @O(n^3 log(d + 1) + d n^2)@ time, @O(n^2)@ temporary space, +@O(n + E)@ retained graph-cache space, and @O(d n^2)@ result space. +-} +cyclicLimits :: + forall state. + (FiniteState state) => + TransitionMatrix state -> + Either LinearSystemError [[[Double]]] +cyclicLimits p + | dim == 0 = Right [[]] + | otherwise = do + (phaseClasses, entering) <- limitDecomposition powered + let classCount = length phaseClasses + classBounds = (0, classCount - 1) + phaseClassByState = classByState phaseClasses + successors <- traverse (successorOf phaseClassByState . fst) phaseClasses + if List.sort successors /= [0 .. classCount - 1] + then Left SingularSystem + else + pure + ( successiveLimits + commonPeriod + classBounds + classCount + (Unboxed.listArray classBounds [0 .. classCount - 1]) + ( Unboxed.array + classBounds + [(successor, source) | (source, successor) <- zip [0 ..] successors] + ) + entering + phaseClassByState + (stationaryMass phaseClasses) + ) + where + dim = stateCardinalityInt @state + original = unTransitionMatrix p + powered = power commonPeriod p + commonPeriod = + foldr + lcm + 1 + [ classPeriodValue + | recurrentClass <- communicatingClasses p + , classClosed recurrentClass + , Just classPeriodValue <- [classPeriod recurrentClass] + ] + + classByState phaseClasses = + Unboxed.accumArray + (\_ classIndex -> classIndex) + (-1) + (0, dim - 1) + [ (stateIndexInt member, classIndex) + | (classIndex, (members, _)) <- zip [0 ..] phaseClasses + , member <- members + ] + + stationaryMass phaseClasses = + Unboxed.accumArray + (\_ probability -> probability) + 0 + (0, dim - 1) + [ (memberIndex, vector `LA.atIndex` memberIndex) + | (members, distribution) <- phaseClasses + , let vector = unDistributionVector distribution + , member <- members + , let memberIndex = stateIndexInt member + ] + + successorOf phaseClassByState members = + case destinations of + successor : rest + | successor >= 0 && all (== successor) rest -> Right successor + _ -> Left SingularSystem + where + destinations = + [ phaseClassByState Unboxed.! destination + | member <- members + , let source = stateIndexInt member + , destination <- [0 .. dim - 1] + , original `LA.atIndex` (source, destination) > 0 + ] + + successiveLimits :: + Natural -> + (Int, Int) -> + Int -> + Unboxed.UArray Int Int -> + Unboxed.UArray Int Int -> + LA.Matrix Double -> + Unboxed.UArray Int Int -> + Unboxed.UArray Int Double -> + [[[Double]]] + successiveLimits 0 _ _ _ _ _ _ _ = [] + successiveLimits remaining classBounds classCount origins predecessors entering classOf mass = + [ [ limitEntry initial target + | target <- [0 .. dim - 1] + ] + | initial <- [0 .. dim - 1] + ] + : successiveLimits + (remaining - 1) + classBounds + classCount + ( Unboxed.listArray + classBounds + [ predecessors Unboxed.! (origins Unboxed.! classIndex) + | classIndex <- [0 .. classCount - 1] + ] + ) + predecessors + entering + classOf + mass + where + limitEntry initial target + | targetClass < 0 = 0 + | otherwise = + entering `LA.atIndex` (initial, origins Unboxed.! targetClass) + * (mass Unboxed.! target) + where + targetClass = classOf Unboxed.! target diff --git a/src/Dtmc/Analysis/LinearSystem.hs b/src/Dtmc/Analysis/LinearSystem.hs new file mode 100644 --- /dev/null +++ b/src/Dtmc/Analysis/LinearSystem.hs @@ -0,0 +1,38 @@ +{- | +Module : Dtmc.Analysis.LinearSystem +Description : Numerical errors shared by finite-state linear-system analyses. + +The explicit failure type shared by eventual hitting, return-time expectation, +and stationary-distribution calculations. The solvers themselves remain an +implementation detail; this module owns only their public error contract. +-} +module Dtmc.Analysis.LinearSystem ( + LinearSystemError (..), +) where + +{- | Why a numerical linear-system result could not be accepted safely. + +The reciprocal condition estimate and relative residual are dimensionless. +Smaller reciprocal condition estimates indicate greater sensitivity; smaller +relative residuals indicate a better computed solution. +-} +data LinearSystemError + = -- | A required solve or decomposition has no usable unique result. + SingularSystem + | -- | The coefficient matrix is too sensitive for the numerical contract. + IllConditionedSystem + { reciprocalConditionEstimate :: Double + -- ^ The backend's estimated reciprocal condition number. + } + | -- | A coefficient or right-hand-side entry was @NaN@ or infinite. + NonFiniteSystem + | -- | The solver produced a @NaN@ or infinite result. + NonFiniteSolution + | -- | The computed solution did not satisfy the equations closely enough. + ResidualTooLarge + { relativeResidual :: Double + -- ^ The scaled residual of the computed solution. + , residualLimit :: Double + -- ^ The largest scaled residual accepted by the solver. + } + deriving (Eq, Show) diff --git a/src/Dtmc/Analysis/LinearSystem/Internal.hs b/src/Dtmc/Analysis/LinearSystem/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Dtmc/Analysis/LinearSystem/Internal.hs @@ -0,0 +1,170 @@ +{- | +Module : Dtmc.Analysis.LinearSystem.Internal +Description : @(I - Q)@ linear solves and sub-block extraction. + +Dynamic linear algebra for DTMC hitting and return calculations: extract +blocks indexed by runtime state sets and solve systems of the form +@(I - Q) x = b@. Public modules convert bounded state indices to 'Int' and +keep dynamically sized matrices inside the implementation. + +All arithmetic uses 'Double'. Every solve validates finiteness, rejects a +reciprocal condition estimate below @1e-12@, and verifies a scaled residual +against @1e-9@. +-} +module Dtmc.Analysis.LinearSystem.Internal ( + subMatrix, + rowSums, + solveLinearSystem, + solveIminusQ, + solveIminusQVector, + fundamental, +) where + +import Dtmc.Analysis.LinearSystem ( + LinearSystemError (..), + ) +import Numeric.LinearAlgebra qualified as LA + +conditionLimit :: Double +conditionLimit = 1e-12 + +residualLimitValue :: Double +residualLimitValue = 1e-9 + +allFinite :: LA.Matrix Double -> Bool +allFinite = all isFinite . LA.toList . LA.flatten + +isFinite :: Double -> Bool +isFinite value = not (isNaN value || isInfinite value) + +infinityNorm :: LA.Matrix Double -> Double +infinityNorm = maximum . (0 :) . map (sum . map abs) . LA.toLists + +relativeSystemResidual :: + LA.Matrix Double -> + LA.Matrix Double -> + LA.Matrix Double -> + Double +relativeSystemResidual coefficient solution rightHandSide = + infinityNorm (coefficient LA.<> solution - rightHandSide) + / max + 1 + ( infinityNorm coefficient * infinityNorm solution + + infinityNorm rightHandSide + ) + +{- | Solve @A X = B@ by LU decomposition. @A@ must be a non-empty square +matrix, @B@ must have the same number of rows, and all entries must be finite; +incompatible dimensions raise a backend error. + +Returns a 'LinearSystemError' when the input or result is non-finite, the +backend reports singularity, the reciprocal condition estimate is below +@1e-12@, or the scaled infinity-norm residual exceeds @1e-9@. + +Complexity: @O(n^3 + n^2 r)@ time, @O(n^2 + n r)@ temporary space, and +@O(n r)@ result space for an @n x n@ coefficient matrix and @r@ right-hand +sides. +-} +solveLinearSystem :: + LA.Matrix Double -> + LA.Matrix Double -> + Either LinearSystemError (LA.Matrix Double) +solveLinearSystem coefficient rightHandSide + | not (allFinite coefficient && allFinite rightHandSide) = + Left NonFiniteSystem + | otherwise = + case LA.linearSolve coefficient rightHandSide of + Nothing -> Left SingularSystem + Just solution + | not (allFinite solution) -> Left NonFiniteSolution + | not (isFinite reciprocalCondition) -> Left NonFiniteSystem + | reciprocalCondition < conditionLimit -> + Left (IllConditionedSystem reciprocalCondition) + | residual > residualLimitValue -> + Left + ( ResidualTooLarge + { relativeResidual = residual + , residualLimit = residualLimitValue + } + ) + | otherwise -> Right solution + where + residual = + relativeSystemResidual coefficient solution rightHandSide + where + reciprocalCondition = LA.rcond coefficient + +{- | Extract the block of @m@ selected by the row and column indices. Their +order and multiplicity are preserved; an empty list produces a zero-sized +dimension. + +Row indices must be in @{0 .. rows(m)-1}@ and column indices in +@{0 .. cols(m)-1}@; otherwise the backend raises an error. + +Complexity: @O(R + C + R C)@ time, @O(R + C)@ temporary space, and +@O(R C)@ result space for @R@ selected rows and @C@ selected columns. +-} +subMatrix :: [Int] -> [Int] -> LA.Matrix Double -> LA.Matrix Double +subMatrix rowIdx colIdx m = + m LA.?? (LA.Pos (LA.idxs rowIdx), LA.Pos (LA.idxs colIdx)) + +{- | Compute the vector of row sums of @m@, equivalently @m@ applied to a +vector of ones. For a block @P[D, A]@ of a transition matrix, this is the +one-step probability of transitioning from each state in @D@ directly into +@A@. Results use ordinary floating-point summation and are not clamped to +@[0, 1]@. + +Complexity: @O(R C + R + C)@ time, @O(C)@ temporary space, and @O(R)@ +result space for an @R x C@ matrix. +-} +rowSums :: LA.Matrix Double -> LA.Vector Double +rowSums m = m LA.#> LA.konst 1 (LA.cols m) + +{- | Solve @(I - Q) X = B@ by LU decomposition. @Q@ must be @n x n@, @B@ +must be @n x r@, and all entries must be finite; incompatible dimensions +raise a backend error. + +Returns a 'LinearSystemError' when the input or result is non-finite, the +backend reports singularity, the reciprocal condition estimate is below +@1e-12@, or the scaled infinity-norm residual exceeds @1e-9@. Current DTMC +callers choose @Q@ with spectral radius below one, which guarantees +invertibility in exact arithmetic but not a reliable 'Double' result. + +Complexity: @O(n^3 + n^2 r)@ time, @O(n^2 + n r)@ temporary space, and +@O(n r)@ result space for @r@ right-hand sides. +-} +solveIminusQ :: + LA.Matrix Double -> + LA.Matrix Double -> + Either LinearSystemError (LA.Matrix Double) +solveIminusQ q rightHandSide + | not (allFinite q) = Left NonFiniteSystem + | otherwise = solveLinearSystem coefficient rightHandSide + where + coefficient = LA.ident (LA.rows q) - q + +{- | Solve @(I - Q) x = b@ for a vector of length @n@. This has the same +shape requirements, numerical behaviour, and errors as 'solveIminusQ'. + +Complexity: @O(n^3)@ time, @O(n^2)@ temporary space, and @O(n)@ result +space. +-} +solveIminusQVector :: + LA.Matrix Double -> + LA.Vector Double -> + Either LinearSystemError (LA.Vector Double) +solveIminusQVector q b = + LA.flatten <$> solveIminusQ q (LA.asColumn b) + +{- | Compute @(I - Q)^-1@ by solving @(I - Q) G = I@. When @Q@ is a +transient-to-transient transition block with spectral radius below one, this +is the fundamental matrix @sum_{k=0}^infinity Q^k@. + +This requires a non-empty square matrix with finite entries and inherits the +validation and error behaviour of 'solveIminusQ'. + +Complexity: @O(n^3)@ time and @O(n^2)@ temporary and result space. +-} +fundamental :: LA.Matrix Double -> Either LinearSystemError (LA.Matrix Double) +fundamental q = + solveIminusQ q (LA.ident (LA.rows q)) diff --git a/src/Dtmc/Analysis/ReturnTime.hs b/src/Dtmc/Analysis/ReturnTime.hs new file mode 100644 --- /dev/null +++ b/src/Dtmc/Analysis/ReturnTime.hs @@ -0,0 +1,434 @@ +{- | +Module : Dtmc.Analysis.ReturnTime +Description : Exact, bounded, eventual, and expected first-return times. + +First-return quantities for DTMCs. For state @i@, +@T_i^+ = inf { t >= 1 | X_t = i }@, so time zero is never a return. Scalar +exact-time and bounded queries work through any locally finite 'Transition'. +Eventual and expected queries use a finite 'TransitionMatrix'. + +Exact-time and strictly bounded queries use finite recurrences. Eventual +queries use support classification and checked 'Double' linear solves. +Expected return times use class stationary distributions and Kac's formula. +Results are not clamped or renormalised. + +Unless stated otherwise, complexity bounds exclude 'FiniteState' method +costs. Bounds over abstract distributions or transitions also identify the +excluded typeclass-method costs. + +For finite-matrix bounds, @n@ is the state count and @E@ the support-edge +count. +-} +module Dtmc.Analysis.ReturnTime ( + -- * Result types + LinearSystemError (..), + Expectation (..), + + -- * First-return-time distribution + probability, + probabilityGivenInitialState, + + -- * Eventual return + eventualProbability, + eventualProbabilityGivenInitialState, + + -- * Expected return time + expectation, + expectationGivenInitialState, +) where + +import Data.Array qualified as Array +import Data.Array.Unboxed qualified as Unboxed +import Data.Map.Strict ( + Map, + ) +import Data.Map.Strict qualified as Map +import Dtmc.Analysis.Classification ( + recurrentState, + transientStates, + ) +import Dtmc.Analysis.Event ( + DiscreteEvent (..), + ) +import Dtmc.Analysis.Expectation ( + Expectation (..), + ) +import Dtmc.Analysis.Initial.Internal ( + expectationUnderEither, + probabilityUnder, + probabilityUnderEither, + ) +import Dtmc.Analysis.LinearSystem ( + LinearSystemError (..), + ) +import Dtmc.Analysis.LinearSystem.Internal ( + fundamental, + subMatrix, + ) +import Dtmc.Analysis.Stationary ( + stationaryDistributions, + ) +import Dtmc.Distribution ( + Distribution (..), + ) +import Dtmc.Distribution.Vector.Internal ( + unDistributionVector, + ) +import Dtmc.Dynamics.Internal ( + pushSparseWeights, + ) +import Dtmc.State ( + FiniteState, + finiteStates, + ) +import Dtmc.State.Internal ( + stateCardinalityInt, + stateIndexInt, + ) +import Dtmc.Transition ( + Transition (..), + ) +import Dtmc.Transition.Matrix.Internal ( + TransitionMatrix, + unTransitionMatrix, + ) +import Numeric.LinearAlgebra qualified as LA +import Numeric.Natural ( + Natural, + ) + +toIndex :: (FiniteState state) => state -> Int +toIndex = stateIndexInt + +advanceUntilTarget :: + (Transition kernel, Ord (TransitionState kernel)) => + kernel -> + (TransitionState kernel -> Bool) -> + Map (TransitionState kernel) Double -> + (Map (TransitionState kernel) Double, Double) +advanceUntilTarget kernel isTarget survivors = + (remaining, hitMass) + where + advanced = pushSparseWeights survivors kernel + (hits, remaining) = Map.partitionWithKey (\state _ -> isTarget state) advanced + hitMass = sum (Map.elems hits) + +{- | Compute the exact first-return probability +@P(T_i^+ = t | X_0 = i)@ through any 'Transition'. Time zero is exactly zero; +a self-loop returns at time one. + +Complexity: excluding 'transitionLaw', +@O(k (w + e log(u + 1) + u) + 1)@ time, @O(w + u)@ temporary space, and +@O(1)@ result space, where @k = t@ and @w@, @e@, and @u@ bound per-step +survivor states, traversed transition edges, and accumulated destinations. +-} +exactProbabilityAt :: + (Transition kernel, Ord (TransitionState kernel)) => + Natural -> + kernel -> + TransitionState kernel -> + Double +exactProbabilityAt 0 _ _ = 0 +exactProbabilityAt time kernel initialState = + go time (Map.singleton initialState 1) + where + isInitial state = state == initialState + + go 0 _ = 0 + go _ survivors | Map.null survivors = 0 + go remaining survivors = + let (next, returnMass) = advanceUntilTarget kernel isInitial survivors + in if remaining == 1 + then returnMass + else go (remaining - 1) next + +{- | Compute the strict bounded first-return probability +@P(T_i^+ < c | X_0 = i)@ through any 'Transition'. Bounds @0@ and @1@ are +exactly zero. + +Complexity: excluding 'transitionLaw', +@O(k (w + e log(u + 1) + u) + 1)@ time, @O(w + u)@ temporary space, and +@O(1)@ result space, where @k = c@ and @w@, @e@, and @u@ bound per-step +survivor states, traversed transition edges, and accumulated destinations. +-} +lowerTailProbability :: + (Transition kernel, Ord (TransitionState kernel)) => + Natural -> + kernel -> + TransitionState kernel -> + Double +lowerTailProbability bound kernel initialState = + go bound (Map.singleton initialState 1) 0 + where + isInitial state = state == initialState + + go remaining _ total | remaining <= 1 = total + go _ survivors total | Map.null survivors = total + go remaining survivors total = + let (next, returnMass) = advanceUntilTarget kernel isInitial survivors + cumulative = total + returnMass + in cumulative `seq` go (remaining - 1) next cumulative + +{- | Compute first-return probabilities +@f_i = P(T_i^+ < infinity | X_0 = i)@ in state order. Recurrent states are +exactly @1@ from support classification. + +For all transient states, one fundamental-matrix solve computes +@N = (I - Q)^-1@ and @f_i = 1 - 1/N(i,i)@. Transient results inherit solver +rounding and are not clamped to @[0,1]@. Returns 'Left' if the transient system +fails the numerical contract. + +Complexity: @O(n^3)@ worst-case time, @O(n^2)@ temporary space, +@O(n + E)@ retained graph-cache space, and @O(n)@ result space for @n@ +states and @E@ support edges. +-} +eventualProbabilitiesByState :: + forall state. + (FiniteState state) => + TransitionMatrix state -> + Either LinearSystemError (LA.Vector Double) +eventualProbabilitiesByState p = do + transientReturns <- + if null transient + then Right [] + else do + nMatrix <- fundamental (subMatrix transientIdx transientIdx matrix) + pure + [ 1 - 1 / (nMatrix `LA.atIndex` (k, k)) + | k <- [0 .. length transient - 1] + ] + let transientValues :: Unboxed.UArray Int Double + transientValues = + Unboxed.accumArray + (\_ x -> x) + 0 + (0, dim - 1) + (zip transientIdx transientReturns) + valueAt i + | recurrentState p i = 1 + | otherwise = transientValues Unboxed.! toIndex i + pure (LA.fromList [valueAt i | i <- finiteStates]) + where + dim = stateCardinalityInt @state + transient = transientStates p + transientIdx = map toIndex transient + matrix = unTransitionMatrix p + +{- | Compute the probability of returning to one state after at least one +transition. A recurrent-state query returns exactly @1@ without forcing the +fundamental-matrix solve. Partial application shares the all-state transient +solve. + +Transient queries inherit the numerical behaviour and errors of +@eventualProbabilitiesByState@. + +Complexity: the first transient query takes @O(n^3)@ worst-case time and +@O(n^2)@ temporary space and may retain an @O(n)@ all-state result; later +lookups take @O(1)@ time and space. A recurrent query avoids the solve. The +matrix may retain @O(n + E)@ graph-cache space, and the scalar result occupies +@O(1)@ space. +-} +eventualProbabilityGivenInitialState :: + forall state. + (FiniteState state) => + TransitionMatrix state -> + state -> + Either LinearSystemError Double +eventualProbabilityGivenInitialState p = + \i -> + if recurrentState p i + then Right 1 + else (`LA.atIndex` toIndex i) <$> probabilities + where + probabilities = eventualProbabilitiesByState p + +{- | Compute the expected first-return time for one state. A transient state +returns 'InfiniteExpectation' without a numerical solve. For a recurrent +state @i@, Kac's formula gives @E_i T_i^+ = 1 / pi_i@, where @pi@ is the +stationary distribution of its closed communicating class. + +Partial application shares the stationary distributions and resulting +all-state table. A transient query does not force that table. Numerical +failures are those of 'stationaryDistributions' or a non-positive or +non-finite recurrent stationary probability. + +Complexity: the first recurrent query takes @O(n^3)@ worst-case time and +@O(n^2)@ temporary space and may retain an @O(n)@ all-state result; later +lookups take @O(1)@ time and space. A transient query avoids the stationary +solves. The matrix may retain @O(n + E)@ graph-cache space, and the scalar +result occupies @O(1)@ space. +-} +expectationGivenInitialState :: + forall state. + (FiniteState state) => + TransitionMatrix state -> + state -> + Either LinearSystemError Expectation +expectationGivenInitialState p = + \i -> + if recurrentState p i + then (Array.! toIndex i) <$> recurrentExpectations + else Right InfiniteExpectation + where + recurrentExpectations = recurrentReturnExpectations p + +{- | Compute expected return times for all recurrent states from one set of +class-stationary solves. The array also contains infinity at transient +coordinates, although callers decide transience structurally before lookup. + +Complexity: @O(n^3)@ worst-case time, @O(n^2)@ temporary space, +@O(n + E)@ retained graph-cache space, and @O(n)@ result space. +-} +recurrentReturnExpectations :: + forall state. + (FiniteState state) => + TransitionMatrix state -> + Either LinearSystemError (Array.Array Int Expectation) +recurrentReturnExpectations p = do + classes <- stationaryDistributions p + recurrentEntries <- concat <$> traverse entriesForClass classes + pure + ( Array.accumArray + (\_ value -> value) + InfiniteExpectation + (0, stateCardinalityInt @state - 1) + recurrentEntries + ) + where + entriesForClass (members, distribution) = + traverse (entry vector) members + where + vector = unDistributionVector distribution + + entry vector member + | stationaryProbability <= 0 || not (finite reciprocal) = Left NonFiniteSolution + | otherwise = Right (index, FiniteExpectation reciprocal) + where + index = toIndex member + stationaryProbability = vector `LA.atIndex` index + reciprocal = 1 / stationaryProbability + + finite value = not (isNaN value || isInfinite value) + +-- Direct survivor mass @P(T_i > t)@ through a locally finite transition. +-- Unlike hitting time, the initial state is not removed at time zero: a first +-- return can occur only after at least one transition. +upperTailProbability :: + (Transition kernel, Ord (TransitionState kernel)) => + Natural -> + kernel -> + TransitionState kernel -> + Double +upperTailProbability time kernel initialState = + go time (Map.singleton initialState 1) + where + isInitial state = state == initialState + go 0 survivors = sum (Map.elems survivors) + go _ survivors | Map.null survivors = 0 + go remaining survivors = + let (next, _) = advanceUntilTarget kernel isInitial survivors + in next `seq` go (remaining - 1) next + +{- | Compute the probability of a finite-threshold event in the first-return +time @T_i^+ = inf { t >= 1 | X_t = i }@. + +'EqualTo' and the lower tails reuse the direct exact/bounded recurrences. +'GreaterThan' and 'AtLeast' use surviving mass directly, include the atom at +infinity, and avoid complement cancellation. Because time zero is excluded, +'EqualTo' @0@, 'LessThan' @1@, and 'AtMost' @0@ are exactly zero, while +'GreaterThan' @0@, 'AtLeast' @0@, and 'AtLeast' @1@ are exactly one. + +The initial state is sampled from the supplied distribution; each path then +measures return to its own sampled state. The query works through any locally +finite 'Transition'. Results use ordinary 'Double' arithmetic without +clamping or renormalisation. + +For the complexity bounds, @s@ is the initial stored support size, @k@ the +event threshold, and @w@, @e@, and @u@ are per-step upper bounds on survivor +states, traversed transition edges, and accumulated destinations. + +Complexity: excluding 'distributionWeights' and 'transitionLaw', +@O(s (k (w + e log(u + 1) + u) + 1))@ time, @O(s + w + u)@ temporary +space, and @O(1)@ result space. +-} +probability :: + ( Distribution distribution + , Transition kernel + , DistributionState distribution ~ TransitionState kernel + , Ord (TransitionState kernel) + ) => + DiscreteEvent -> + kernel -> + distribution -> + Double +probability event kernel initial = + probabilityUnder initial (probabilityGivenInitialState event kernel) + +{- | Compute the probability of a finite-threshold first-return event +conditioned on @X_0 = i@. The return target is that same initial state, and +time zero is not a return. + +For the complexity bounds, @k@ is the event threshold and @w@, @e@, and @u@ +are per-step upper bounds on survivor states, traversed transition edges, and +accumulated destinations. + +Complexity: excluding 'transitionLaw', +@O(k (w + e log(u + 1) + u) + 1)@ time, @O(w + u)@ temporary space, and +@O(1)@ result space. +-} +probabilityGivenInitialState :: + (Transition kernel, Ord (TransitionState kernel)) => + DiscreteEvent -> + kernel -> + TransitionState kernel -> + Double +probabilityGivenInitialState event kernel initialState = + case event of + EqualTo time -> exactProbabilityAt time kernel initialState + LessThan bound -> lowerTailProbability bound kernel initialState + AtMost time -> lowerTailProbability (time + 1) kernel initialState + GreaterThan time -> upperTailProbability time kernel initialState + AtLeast 0 -> 1 + AtLeast time -> upperTailProbability (time - 1) kernel initialState + +{- | Compute, under an arbitrary initial distribution, the probability of +eventually returning to the sampled initial state after at least one +transition. Recurrent states contribute exactly one; transient-state values +come from one shared checked fundamental-matrix solve. + +Complexity: excluding 'distributionWeights', @O(n^3 + s)@ worst-case time, +@O(n^2 + s)@ temporary space, and @O(1)@ result space for @n@ states and +initial stored support size @s@. The matrix may retain @O(n + E)@ graph-cache +space. +-} +eventualProbability :: + ( FiniteState state + , Distribution distribution + , DistributionState distribution ~ state + ) => + TransitionMatrix state -> + distribution -> + Either LinearSystemError Double +eventualProbability matrix initial = + probabilityUnderEither initial (eventualProbabilityGivenInitialState matrix) + +{- | Compute the expected first-return time under an arbitrary initial +distribution. The result is infinite when a transient state has positive +initial probability. Otherwise recurrent-state expectations use shared class +stationary distributions and Kac's formula. + +Complexity: excluding 'distributionWeights', @O(n^3 + s)@ worst-case time, +@O(n^2 + s)@ temporary space, and @O(1)@ result space for @n@ states and +initial stored support size @s@. The matrix may retain @O(n + E)@ graph-cache +space. +-} +expectation :: + ( FiniteState state + , Distribution distribution + , DistributionState distribution ~ state + ) => + TransitionMatrix state -> + distribution -> + Either LinearSystemError Expectation +expectation matrix initial = + expectationUnderEither initial (expectationGivenInitialState matrix) diff --git a/src/Dtmc/Analysis/Stationary.hs b/src/Dtmc/Analysis/Stationary.hs new file mode 100644 --- /dev/null +++ b/src/Dtmc/Analysis/Stationary.hs @@ -0,0 +1,259 @@ +{- | +Module : Dtmc.Analysis.Stationary +Description : Stationary distributions of finite chains. + +Every finite irreducible DTMC has exactly one stationary distribution, +including periodic chains. A reducible chain has one extremal stationary +distribution per recurrent class and no canonical choice among them. +'stationaryDistributions' returns these class-supported distributions. Every +stationary distribution of the chain is a convex combination of them, and a +chain with two or more recurrent classes therefore has infinitely many. + +Each recurrent class is solved by Grassmann-Taksar-Heyman state reduction. +GTH never forms @transpose(P) - I@ and performs no subtraction at all: every +step adds, multiplies, or divides non-negative quantities, avoiding the +cancellation that damages a balance solve on a nearly uncoupled chain. It has +the same @O(m^3)@ asymptotic cost as an LU factorisation. + +Every supplied block is irreducible because a closed communicating class +restricted to itself is irreducible. This is exactly the condition under which +no elimination step can divide by zero. An 'IllConditionedSystem' is therefore +unreachable here, unlike in the hitting- and return-time solves that share the +error type. Results are not clamped or renormalised; a non-finite input or +solution, and a residual @|pi P - pi|@ above @1e-9@, are still reported +explicitly. Complexity bounds exclude 'FiniteState' method costs. For the +top-level bound, @n@ is the state count and @E@ the support-edge count. +-} +module Dtmc.Analysis.Stationary ( + LinearSystemError (..), + stationaryDistributions, +) where + +import Control.Monad.ST ( + ST, + runST, + ) +import Data.Array.MArray ( + newListArray, + readArray, + writeArray, + ) +import Data.Array.ST ( + STUArray, + ) +import Data.Array.Unboxed qualified as Unboxed +import Dtmc.Analysis.Classification ( + classClosed, + classMembers, + communicatingClasses, + ) +import Dtmc.Analysis.LinearSystem ( + LinearSystemError (..), + ) +import Dtmc.Analysis.LinearSystem.Internal ( + subMatrix, + ) +import Dtmc.Distribution.Vector.Internal ( + DistributionVector (DistributionVector), + ) +import Dtmc.State ( + FiniteState, + ) +import Dtmc.State.Internal ( + stateCardinalityInt, + stateIndexInt, + ) +import Dtmc.Transition.Matrix ( + TransitionMatrix, + ) +import Dtmc.Transition.Matrix.Internal ( + unTransitionMatrix, + ) +import Numeric.LinearAlgebra qualified as LA + +toIndex :: (FiniteState state) => state -> Int +toIndex = stateIndexInt + +{- | Compute the stationary vector of a non-empty irreducible stochastic +block, in the block's own ordering, by Grassmann-Taksar-Heyman state +reduction. + +The reduction removes states one at a time. Censoring the chain on +@{1, ..., k-1}@ -- watching it only when it is outside @k@ -- leaves a Markov +chain with the same stationary distribution up to normalisation, and its +transition probabilities are + +@P'(i,j) = P(i,j) + P(i,k) P(k,j) / S, S = sum_(j < k) P(k,j)@, + +read as: reach @j@ directly, or by entering @k@ and leaving it at @j@. This is +the same elimination order as Gaussian elimination, arranged so that no +subtraction appears. In particular @S@ is accumulated from the off-diagonal +entries rather than as @1 - P(k,k)@, which is what saves a state that holds +probability close to one: the difference would lose most of its significant +digits while the sum loses none. + +The back substitution reads @x(k) = sum_(i < k) x(i) P(i,k)@ off the stored +factors, @x(k)@ being the expected number of visits to @k@ per visit to the +first state in the chain censored on @{1, ..., k}@ -- non-negative, so it does +not cancel either. Normalising gives @pi@. + +An irreducible block makes @S > 0@ at every step because the censored chain is +again irreducible and its last state must be able to leave. A reducible block +that reaches @S = 0@ is reported as 'SingularSystem'. Non-finite inputs, +weights, or solutions and an excessive stationarity residual produce the +corresponding 'LinearSystemError'. + +Complexity: @O(m^3)@ time, @O(m^2)@ temporary space, and @O(m)@ result +space for an @m x m@ block. +-} +stationaryOfBlock :: + LA.Matrix Double -> + Either LinearSystemError (LA.Vector Double) +stationaryOfBlock block + | dimension == 0 = Left SingularSystem + | not (all isFinite (LA.toList (LA.flatten block))) = Left NonFiniteSystem + | otherwise = + case reduceGth dimension (LA.toList (LA.flatten block)) of + Nothing -> Left SingularSystem + Just weights -> normalise weights + where + dimension = LA.rows block + normalise weights + | not (all isFinite weights) = Left NonFiniteSolution + | scale <= 0 = Left SingularSystem + | not (isFinite total) = Left NonFiniteSolution + | total <= 0 = Left SingularSystem + | not (all isFinite stationaryWeights) = Left NonFiniteSolution + | not (isFinite residual) = Left NonFiniteSolution + | residual > limit = + Left + ( ResidualTooLarge + { relativeResidual = residual + , residualLimit = limit + } + ) + | otherwise = Right stationary + where + limit = 1e-9 + scale = maximum weights + scaledWeights = map (/ scale) weights + total = sum scaledWeights + stationaryWeights = map (/ total) scaledWeights + stationary = LA.fromList stationaryWeights + residual = + foldr (max . abs) 0 (LA.toList (LA.tr block LA.#> stationary - stationary)) + +isFinite :: Double -> Bool +isFinite value = not (isNaN value || isInfinite value) + +-- Allocating through a signature that quantifies the state thread keeps the +-- array type unambiguous without local annotations inside 'runST'. +newFlatArray :: (Int, Int) -> [Double] -> ST s (STUArray s Int Double) +newFlatArray = newListArray + +{- | Compute the unnormalised GTH weights of an @n x n@ block supplied in +row-major order. Return 'Nothing' when an elimination step finds no positive +way out of the state being removed. + +The caller must supply exactly @n^2@ entries. This helper performs no +finiteness, stochasticity, or irreducibility validation. + +Complexity: @O(n^3)@ time, @O(n^2)@ temporary space, and @O(n)@ result +space. +-} +reduceGth :: Int -> [Double] -> Maybe [Double] +reduceGth n entries = runST $ do + a <- newFlatArray (0, n * n - 1) entries + let index i j = i * n + j + + exitMass k = + sum <$> mapM (readArray a . index k) [0 .. k - 1] + + absorbRow k s i = do + entering <- readArray a (index i k) + let scaled = entering / s + writeArray a (index i k) scaled + mapM_ + ( \j -> do + leaving <- readArray a (index k j) + current <- readArray a (index i j) + writeArray a (index i j) (current + scaled * leaving) + ) + [0 .. k - 1] + + eliminate k + | k < 1 = pure True + | otherwise = do + s <- exitMass k + if s <= 0 + then pure False + else do + mapM_ (absorbRow k s) [0 .. k - 1] + eliminate (k - 1) + + -- visits holds x(0) .. x(k-1) in order. + substitute k visits + | k >= n = pure visits + | otherwise = do + terms <- + mapM + (\(i, x) -> (x *) <$> readArray a (index i k)) + (zip [0 ..] visits) + substitute (k + 1) (visits ++ [sum terms]) + + feasible <- eliminate (n - 1) + if feasible + then Just <$> substitute 1 [1] + else pure Nothing + +{- | Compute the extremal stationary distributions, one per recurrent class +and paired with the class on which each lives. Classes come in the order of +'Dtmc.Analysis.Classification.communicatingClasses', that is by least member. +An empty chain returns an empty list. + +Each distribution is returned over the whole state space, carrying exact zeros +outside its class. This is correct rather than merely convenient: a recurrent +class is closed, so a distribution supported on it satisfies @pi P = pi@ for +the full matrix, and no stationary distribution of a finite chain puts mass on +a transient state. + +Every stationary distribution of the chain is a convex combination of these. +The result has exactly one element precisely when the stationary distribution +is unique, including reducible chains with transient states and one recurrent +class. It has two or more elements exactly when the chain has infinitely many +stationary distributions. + +Each class is solved separately. The first numerical failure aborts the +traversal, although the error does not identify its class. + +Complexity: @O(n^2 + sum_C |C|^3)@ time, at most @O(n^3)@, and @O(n^2)@ +temporary space. Result space is @O(c n)@ for @c@ recurrent classes. The +matrix may retain @O(n + E)@ graph-cache space. +-} +stationaryDistributions :: + forall state. + (FiniteState state) => + TransitionMatrix state -> + Either LinearSystemError [([state], DistributionVector state)] +stationaryDistributions p = + traverse distributionOn closedClasses + where + dim = stateCardinalityInt @state + matrix = unTransitionMatrix p + closedClasses = + [classMembers c | c <- communicatingClasses p, classClosed c] + distributionOn members = do + solution <- stationaryOfBlock (subMatrix indices indices matrix) + let placed :: Unboxed.UArray Int Double + placed = + Unboxed.accumArray + (\_ x -> x) + 0 + (0, dim - 1) + (zip indices (LA.toList solution)) + pure + ( members + , DistributionVector (LA.fromList [placed Unboxed.! i | i <- [0 .. dim - 1]]) + ) + where + indices = map toIndex members diff --git a/src/Dtmc/Analysis/VisitCount.hs b/src/Dtmc/Analysis/VisitCount.hs new file mode 100644 --- /dev/null +++ b/src/Dtmc/Analysis/VisitCount.hs @@ -0,0 +1,729 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +{- | +Module : Dtmc.Analysis.VisitCount +Description : Finite- and infinite-horizon visit-count analysis. + +Exact analysis of visit counts. The bounded functions count visits to a state +predicate before a strict time bound and work through any locally finite +'Transition'. The total-count functions analyse visits to one state over the +entire path of a finite 'TransitionMatrix'. Both notions include the initial +state at time zero. + +For a target state @i@, the total visit count is +@V_i = sum_(t = 0)^infinity 1_{X_t = i}@. Its law is determined by the +probability of ever hitting @i@ and the probability of returning to @i@. The +implementation uses exact graph classification for zero and infinite cases, +and checked 'Double' linear solves for the remaining probabilities. It does +not simulate, truncate an infinite series, clamp, or renormalise results. + +Unless a declaration states otherwise, complexity bounds exclude +'FiniteState' method costs. Bounds for operations over abstract distributions +or transitions also identify excluded typeclass-method and predicate costs. +-} +module Dtmc.Analysis.VisitCount ( + -- * Result types + LinearSystemError (..), + Expectation (..), + + -- * Total visits over an infinite horizon + totalProbability, + totalProbabilityGivenInitialState, + infiniteProbability, + infiniteProbabilityGivenInitialState, + totalExpectation, + totalExpectationGivenInitialState, + + -- * Visits within a bounded horizon + boundedLaw, + boundedProbability, + boundedProbabilityGivenInitialState, + boundedExpectation, + boundedExpectationGivenInitialState, + + -- * Occupation matrix + occupationMatrix, +) where + +import Data.Array qualified as Array +import Data.Array.Unboxed qualified as Unboxed +import Data.Map.Strict qualified as Map +import Dtmc.Analysis.Absorption ( + fundamentalMatrix, + ) +import Dtmc.Analysis.Classification ( + classClosed, + classMembers, + communicatingClasses, + recurrentState, + ) +import Dtmc.Analysis.Classification.Internal ( + backwardReachable, + ) +import Dtmc.Analysis.Event ( + DiscreteEvent (..), + matches, + ) +import Dtmc.Analysis.Expectation ( + Expectation (..), + ) +import Dtmc.Analysis.HittingTime qualified as Hit +import Dtmc.Analysis.Initial.Internal ( + expectationUnderEither, + probabilityUnderEither, + ) +import Dtmc.Analysis.LinearSystem ( + LinearSystemError (..), + ) +import Dtmc.Analysis.ReturnTime qualified as Return +import Dtmc.Distribution ( + Distribution (..), + ) +import Dtmc.Distribution.Map ( + pointMass, + ) +import Dtmc.Distribution.Map.Internal ( + DistributionMap (DistributionMap), + unDistributionMap, + ) +import Dtmc.Dynamics.Internal ( + pushSparseWeights, + ) +import Dtmc.State ( + FiniteState, + finiteStates, + ) +import Dtmc.State.Internal ( + stateCardinalityInt, + stateIndexInt, + ) +import Dtmc.Transition ( + Transition (..), + ) +import Dtmc.Transition.Matrix ( + TransitionMatrix, + ) +import Numeric.LinearAlgebra qualified as LA +import Numeric.Natural ( + Natural, + ) + +toIndex :: (FiniteState state) => state -> Int +toIndex = stateIndexInt + +{- | Build a Boolean mask of the states from which at least one seed is +reachable. The reverse support graph is traversed once for the whole seed set. + +Complexity: excluding shared support-graph construction, @O(n + E + s)@ time, +@O(n + E + s)@ temporary space, and @O(n)@ result space for @n@ states, @E@ +support edges, and @s@ supplied seeds. +-} +backwardReachabilityMask :: + forall state. + (FiniteState state) => + TransitionMatrix state -> + [state] -> + Unboxed.UArray Int Bool +backwardReachabilityMask matrix seeds = + Unboxed.accumArray + (||) + False + (0, stateCardinalityInt @state - 1) + [ (toIndex state, True) + | state <- backwardReachable matrix (const True) seeds + ] + +{- | Compute probabilities of exactly @n@ total visits in canonical state order. +The count is the first argument and the target is the third; coordinate @j@ is +@P(V_i = n | X_0 = j)@. + +Writing @h_ji = P_j(H_i < infinity)@ and +@f_i = P_i(T_i^+ < infinity)@, a transient target has + +* @P_j(V_i = 0) = 1 - h_ji@; +* @P_j(V_i = n) = h_ji f_i^(n - 1) (1 - f_i)@ for @n >= 1@; + +For a recurrent target, every positive finite count has probability zero. +Recurrence is decided from the support graph, not by comparing a computed +return probability with one. + +Structural zero cases avoid a linear solve. Other cases inherit the numerical +behaviour and errors of the state-conditioned eventual hitting and return +queries. + +Complexity: @O(m^3 + log(n + 1))@ worst-case time, @O(m^2)@ temporary +space, and @O(m)@ result space for @m@ states. +-} +exactProbabilitiesByState :: + forall state. + (FiniteState state) => + Natural -> + TransitionMatrix state -> + state -> + Either LinearSystemError (LA.Vector Double) +exactProbabilitiesByState count matrix target + | count == 0 = mapProbabilities (1 -) <$> hitting + | recurrentState matrix target = Right zeroProbabilities + | otherwise = do + hits <- hitting + returning <- Return.eventualProbabilityGivenInitialState matrix target + let finiteMass = returning ^ (count - 1) * (1 - returning) + pure (mapProbabilities (* finiteMass) hits) + where + hitting :: Either LinearSystemError (LA.Vector Double) + hitting = + LA.fromList + <$> traverse + (Hit.eventualProbabilityGivenInitialState matrix [target]) + finiteStates + zeroProbabilities = LA.fromList [0 | _ <- finiteStates @state] + mapProbabilities = LA.cmap + +{- | Compute probabilities of infinitely many visits in canonical initial-state +order. +For target @i@, coordinate @j@ is @P(V_i = infinity | X_0 = j)@. A recurrent +target returns its hitting probabilities; a transient target returns an exact +zero vector without a linear solve. + +Recurrence is decided from the support graph. The recurrent case inherits the +numerical behaviour and errors of +'Dtmc.Analysis.HittingTime.eventualProbabilityGivenInitialState'. + +Complexity: @O(n^3)@ worst-case time, @O(n^2)@ temporary space, and @O(n)@ +result space. +-} +infiniteProbabilitiesByState :: + forall state. + (FiniteState state) => + TransitionMatrix state -> + state -> + Either LinearSystemError (LA.Vector Double) +infiniteProbabilitiesByState matrix target + | recurrentState matrix target = + LA.fromList + <$> traverse + (Hit.eventualProbabilityGivenInitialState matrix [target]) + finiteStates + | otherwise = Right (LA.fromList [0 | _ <- finiteStates @state]) + +{- | Compute the probability of infinitely many visits from one initial state. +Argument order is matrix, target, then initial state. Partially applying the +matrix and target shares the all-state computation. + +Complexity: the first forced query takes @O(n^3)@ worst-case time, +@O(n^2)@ temporary space, and may retain an @O(n)@ all-state cache; +subsequent shared lookups take @O(1)@ time. The scalar result occupies +@O(1)@ space. +-} +infiniteProbabilityGivenInitialState :: + (FiniteState state) => + TransitionMatrix state -> + state -> + state -> + Either LinearSystemError Double +infiniteProbabilityGivenInitialState matrix target = + \initial -> (`LA.atIndex` toIndex initial) <$> probabilities + where + probabilities = infiniteProbabilitiesByState matrix target + +{- | Compute expected total visits to the target in canonical initial-state +order. + +For a transient target @i@, coordinate @j@ is +@h_ji / (1 - f_i)@. For a recurrent target it is zero when @i@ is +unreachable from @j@ and 'InfiniteExpectation' otherwise. The recurrent case +is decided entirely from the support graph and requires no linear solve. + +Transient results inherit the numerical behaviour and errors of +the state-conditioned eventual hitting and return queries. + +Complexity: @O(n^3)@ worst-case time, @O(n^2)@ temporary space, and @O(n)@ +result space. +-} +totalExpectationsByState :: + forall state. + (FiniteState state) => + TransitionMatrix state -> + state -> + Either LinearSystemError [Expectation] +totalExpectationsByState matrix target + | recurrentState matrix target = + Right + [ if reachingTarget Unboxed.! toIndex initial + then InfiniteExpectation + else FiniteExpectation 0 + | initial <- finiteStates @state + ] + | otherwise = do + hits <- + traverse + (Hit.eventualProbabilityGivenInitialState matrix [target]) + finiteStates + returning <- Return.eventualProbabilityGivenInitialState matrix target + pure + [ FiniteExpectation (hit / (1 - returning)) + | hit <- hits + ] + where + reachingTarget = backwardReachabilityMask matrix [target] + +{- | Compute expected total visits to the target from one initial state. +Argument order is matrix, target, then initial state. Partially applying the +matrix and target shares the all-state computation. + +Complexity: the first forced query takes @O(n^3)@ worst-case time, +@O(n^2)@ temporary space, and may retain an @O(n)@ all-state cache; +subsequent shared list lookups take @O(n)@ worst-case time and @O(1)@ +temporary space. The scalar result occupies @O(1)@ space. +-} +totalExpectationGivenInitialState :: + (FiniteState state) => + TransitionMatrix state -> + state -> + state -> + Either LinearSystemError Expectation +totalExpectationGivenInitialState matrix target = + \initial -> (!! toIndex initial) <$> expectations + where + expectations = totalExpectationsByState matrix target + +iterateNatural :: Natural -> (value -> value) -> value -> value +iterateNatural steps advance = go steps + where + go 0 value = value + go remaining value = + let next = advance value + in next `seq` go (remaining - 1) next + +{- | Construct the distribution of +@N_A(c) = sum_(t = 0)^(c - 1) 1_A(X_t)@, the number of visits to the supplied +state predicate strictly before time @c@. + +The time bound is the first argument, consistently with the other +finite-horizon APIs. Bound zero returns a point mass at count zero. At a +positive bound, the initial state at time zero is included. Consequently the +result is supported on counts from zero through the bound. + +The result is computed from the exact finite reachable support of the joint +process @(X_t, N_A(t + 1))@. Ordinary 'Double' arithmetic is preserved without +clamping or renormalisation. + +For the complexity bounds, @k@ is the time bound, @s@ the initial stored +support size, @j@ an upper bound on live or accumulated joint +@(state, count)@ pairs, @e@ an upper bound on transition edges traversed per +step, and @r@ an upper bound on count keys accumulated before final zero +removal. The returned support contains at most @r@ counts. + +Complexity: excluding the initial 'distributionWeights' call, +'transitionLaw', and predicate evaluation, +@O(s log(s + 1) + k (j + e log(j + 1)) + j log(r + 1) + r)@ time, +@O(j + r)@ temporary space, and @O(r)@ result space. At @k = 0@ the function +takes @O(1)@ time and space and does not inspect its other arguments. +-} +boundedLaw :: + ( Distribution distribution + , Transition transition + , DistributionState distribution ~ TransitionState transition + , Ord (TransitionState transition) + ) => + Natural -> + distribution -> + transition -> + (TransitionState transition -> Bool) -> + DistributionMap Natural +boundedLaw bound initial transition isVisited + | bound == 0 = DistributionMap (Map.singleton 0 1) + | otherwise = DistributionMap (countMarginal finalJoint) + where + initialJoint = + Map.fromList + [ ((state, if isVisited state then 1 else 0), weight) + | (state, weight) <- distributionWeights initial + , weight /= 0 + ] + finalJoint = + iterateNatural (bound - 1) advanceJoint initialJoint + + advanceJoint joint = + Map.filter (/= 0) (Map.foldlWithKey' advanceState Map.empty joint) + + advanceState accumulated (state, count) stateWeight = + Map.foldlWithKey' + (advanceDestination count stateWeight) + accumulated + (unDistributionMap (transitionLaw transition state)) + + advanceDestination count stateWeight accumulated nextState transitionWeight = + Map.insertWith + (+) + (nextState, count + if isVisited nextState then 1 else 0) + (stateWeight * transitionWeight) + accumulated + + countMarginal = + Map.filter (/= 0) + . Map.foldlWithKey' + (\counts (_, count) weight -> Map.insertWith (+) count weight counts) + Map.empty + +{- | Compute the expected number of visits before the strict time bound. Using +@E(N_A(c)) = sum_(t = 0)^(c - 1) P(X_t in A)@, this evolves only the state +marginal rather than constructing the joint count distribution. The result +lies mathematically between zero and the bound, subject to ordinary +floating-point error. + +For the complexity bounds, @k@ is the time bound, @s@ the initial stored +support size, and @w@, @e@, and @u@ are per-step upper bounds on stored source +states, traversed transition edges, and accumulated destination states. + +Complexity: excluding the initial 'distributionWeights' call, +'transitionLaw', and predicate evaluation, +@O(s log(s + 1) + k (w + e log(u + 1) + u))@ time, @O(w + u)@ temporary +space, and @O(1)@ result space. At @k = 0@ the function takes @O(1)@ time and +space and does not inspect its other arguments. +-} +boundedExpectation :: + ( Distribution distribution + , Transition transition + , DistributionState distribution ~ TransitionState transition + , Ord (TransitionState transition) + ) => + Natural -> + distribution -> + transition -> + (TransitionState transition -> Bool) -> + Double +boundedExpectation bound initial transition isVisited = + go bound (Map.fromList (distributionWeights initial)) 0 + where + go 0 _ expectation = expectation + go remaining weights expectation = + let visitProbability = + Map.foldlWithKey' + ( \total state weight -> + if isVisited state then total + weight else total + ) + 0 + weights + cumulative = expectation + visitProbability + in if remaining == 1 + then cumulative + else + let next = pushSparseWeights weights transition + in cumulative `seq` next `seq` go (remaining - 1) next cumulative + +{- | Compute, under an arbitrary initial distribution, the probability of a +finite-threshold event in the total number of visits +@V_i = sum_(t = 0)^infinity 1_{X_t = i}@. + +The initial state at time zero is included. Upper-tail events include the atom +at infinity. For @h_ji = P_j(H_i < infinity)@ and transient-target return +probability @f_i@, the implementation evaluates +@P_j(V_i > n) = h_ji f_i^n@ directly. Recurrent targets use support +classification, so their positive mass is placed structurally at infinity. + +The implementation mixes the internally shared state-conditioned results +under the supplied initial distribution. + +For the complexity bounds, @n@ is the state count, @s@ the initial stored +support size, and @k@ the event's numeric threshold. + +Complexity: excluding 'distributionWeights', @O(n^3 + s + log(k + 1))@ +worst-case time, @O(n^2 + s)@ temporary space, and @O(1)@ result space. +-} +totalProbability :: + ( FiniteState state + , Distribution distribution + , DistributionState distribution ~ state + ) => + DiscreteEvent -> + TransitionMatrix state -> + state -> + distribution -> + Either LinearSystemError Double +totalProbability event matrix target initial = + probabilityUnderEither initial (totalProbabilityGivenInitialState event matrix target) + +{- | Compute the probability of a total-visit event conditioned on @X_0 = j@. +Partially applying the event, matrix, and target shares the all-state +computation. + +Complexity: the first forced query takes @O(n^3 + log(k + 1))@ worst-case +time, @O(n^2)@ temporary space, and may retain an @O(n)@ all-state cache for +event threshold @k@; subsequent shared lookups take @O(1)@ time. The scalar +result occupies @O(1)@ space. +-} +totalProbabilityGivenInitialState :: + (FiniteState state) => + DiscreteEvent -> + TransitionMatrix state -> + state -> + state -> + Either LinearSystemError Double +totalProbabilityGivenInitialState event matrix target = + \initial -> (`LA.atIndex` toIndex initial) <$> probabilities + where + probabilities = totalProbabilityByState event matrix target + +{- | Compute total-visit event probabilities in canonical initial-state order. +Coordinate @j@ is @P_j(V_i in E)@ for the supplied target @i@ and +'DiscreteEvent' @E@. Upper tails are evaluated directly and include infinitely +many visits; lower tails contain finite counts only. + +Graph classification and any required checked linear solves are shared across +all initial states. Structural zero and one boundaries avoid a solve. + +Complexity: @O(n^3 + log(k + 1))@ worst-case time, @O(n^2)@ temporary +space, and @O(n)@ result space for @n@ states and event threshold @k@. +-} +totalProbabilityByState :: + forall state. + (FiniteState state) => + DiscreteEvent -> + TransitionMatrix state -> + state -> + Either LinearSystemError (LA.Vector Double) +totalProbabilityByState event matrix target = + case event of + EqualTo count -> exactProbabilitiesByState count matrix target + LessThan 0 -> Right zeros + LessThan bound -> atMost (bound - 1) + AtMost count -> atMost count + GreaterThan count -> after count + AtLeast 0 -> Right ones + AtLeast count -> after (count - 1) + where + recurrent = recurrentState matrix target + hits :: Either LinearSystemError (LA.Vector Double) + hits = + LA.fromList + <$> traverse + (Hit.eventualProbabilityGivenInitialState matrix [target]) + finiteStates + zeros = LA.fromList [0 | _ <- finiteStates @state] + ones = LA.fromList [1 | _ <- finiteStates @state] + mapValues = LA.cmap + + atMost count + | recurrent = mapValues (1 -) <$> hits + | otherwise = do + hitValues <- hits + returning <- Return.eventualProbabilityGivenInitialState matrix target + pure + ( mapValues + (\hit -> 1 - hit * returning ^ count) + hitValues + ) + + after count + | recurrent = hits + | count == 0 = hits + | otherwise = do + hitValues <- hits + returning <- Return.eventualProbabilityGivenInitialState matrix target + pure (mapValues (* (returning ^ count)) hitValues) + +{- | Compute, under an arbitrary initial distribution, the probability of +infinitely many visits to the target. A transient target gives exactly zero; +a recurrent target mixes its state-conditioned hitting probabilities. Any +numerical failure comes from the checked hitting-probability solve. + +Complexity: excluding 'distributionWeights', @O(n^3 + s)@ worst-case time, +@O(n^2 + s)@ temporary space, and @O(1)@ result space for @n@ states and +initial stored support size @s@. +-} +infiniteProbability :: + ( FiniteState state + , Distribution distribution + , DistributionState distribution ~ state + ) => + TransitionMatrix state -> + state -> + distribution -> + Either LinearSystemError Double +infiniteProbability matrix target initial = + probabilityUnderEither initial (infiniteProbabilityGivenInitialState matrix target) + +{- | Compute expected total visits under an arbitrary initial distribution. + +A recurrent target gives 'InfiniteExpectation' exactly when it is reachable +from a state with positive initial weight. A transient target has a finite +result unless a required checked hitting or return solve fails. + +Complexity: excluding 'distributionWeights', @O(n^3 + s n)@ worst-case time, +@O(n^2 + s)@ temporary space, and @O(1)@ result space for @n@ states and +initial stored support size @s@. +-} +totalExpectation :: + ( FiniteState state + , Distribution distribution + , DistributionState distribution ~ state + ) => + TransitionMatrix state -> + state -> + distribution -> + Either LinearSystemError Expectation +totalExpectation matrix target initial = + expectationUnderEither initial (totalExpectationGivenInitialState matrix target) + +{- | Compute the probability of a 'DiscreteEvent' in the number of visits +strictly before a finite time bound. The bounded law has no atom at infinity, +and values outside its support contribute exactly zero. + +Use @k@, @s@, @j@, @e@, and @r@ as defined for 'boundedLaw'. + +Complexity: excluding the initial 'distributionWeights' call, +'transitionLaw', and predicate evaluation, +@O(s log(s + 1) + k (j + e log(j + 1)) + j log(r + 1) + r)@ time, +@O(j + r)@ temporary space, and @O(1)@ result space. At @k = 0@ the function +takes @O(1)@ time and space. +-} +boundedProbability :: + ( Distribution distribution + , Transition transition + , DistributionState distribution ~ TransitionState transition + , Ord (TransitionState transition) + ) => + Natural -> + DiscreteEvent -> + distribution -> + transition -> + (TransitionState transition -> Bool) -> + Double +boundedProbability bound event initial transition isVisited = + sum + [ weight + | (count, weight) <- distributionWeights law + , matches event count + ] + where + law = boundedLaw bound initial transition isVisited + +{- | Compute the probability of a bounded visit-count event conditioned on +@X_0 = i@. + +Use @k@, @j@, @e@, and @r@ as defined for 'boundedLaw'; the initial support +has size one. + +Complexity: excluding 'transitionLaw' and predicate evaluation, +@O(k (j + e log(j + 1)) + j log(r + 1) + r)@ time, @O(j + r)@ temporary +space, and @O(1)@ result space. At @k = 0@ the function takes @O(1)@ time and +space. +-} +boundedProbabilityGivenInitialState :: + ( Transition transition + , Ord (TransitionState transition) + ) => + Natural -> + DiscreteEvent -> + TransitionState transition -> + transition -> + (TransitionState transition -> Bool) -> + Double +boundedProbabilityGivenInitialState bound event initial = + boundedProbability bound event (pointMass initial) + +{- | Compute expected visits before a strict finite time bound conditioned on +@X_0 = i@. + +Use @k@, @w@, @e@, and @u@ as defined for 'boundedExpectation'; the initial +support has size one. + +Complexity: excluding 'transitionLaw' and predicate evaluation, +@O(k (w + e log(u + 1) + u))@ time, @O(w + u)@ temporary space, and @O(1)@ +result space. At @k = 0@ the function takes @O(1)@ time and space. +-} +boundedExpectationGivenInitialState :: + ( Transition transition + , Ord (TransitionState transition) + ) => + Natural -> + TransitionState transition -> + transition -> + (TransitionState transition -> Bool) -> + Double +boundedExpectationGivenInitialState bound initial = + boundedExpectation bound (pointMass initial) + +{- | Compute the occupation matrix of the chain, also known as its Green +function. Entry @(i, j)@ is +@sum_(n >= 0) (P^n)(i,j) = E(V_j | X_0 = i)@, the expected total number of +visits to @j@ started from @i@. Rows and columns follow the canonical order of +the 'FiniteState' instance. + +Unlike 'Dtmc.Analysis.Absorption.fundamentalMatrix', which is the finite +@T x T@ block, this is defined on the whole state space and therefore needs +'Expectation': a recurrent target reachable from @i@ is visited infinitely +often almost surely. The four cases are + +* @j@ transient and @i@ transient: the corresponding entry of + @(I - Q)^-1@; +* @j@ transient and @i@ recurrent: exactly zero, because a recurrent class is + closed and cannot reach a transient state; +* @j@ recurrent and reachable from @i@: 'InfiniteExpectation'; +* @j@ recurrent and unreachable from @i@: exactly zero. + +Only the transient block needs arithmetic; the infinite and zero entries come +from the support graph, so they are exact. +'Dtmc.Analysis.VisitCount.totalExpectation' computes single entries by a +different route and agrees with this one. + +Returns 'Left' when construction of the transient fundamental matrix fails +the checked linear-system contract. + +If there are @c@ recurrent classes, reverse reachability is computed once per +class and shared by every target in it. + +Complexity: for @n@ states, @t@ transient states, @E@ support edges, and @c@ +closed classes, full evaluation takes +@O(n^2 + (n + E) log(n + 1) + t^3 + c (n + E) + n^2 log(t + 1))@ time, +@O(n^2)@ temporary space, @O(n + E)@ retained graph-cache space, and +@O(n^2)@ result space. The time bound is @O(n^3)@ in the worst case. +-} +occupationMatrix :: + forall state. + (FiniteState state) => + TransitionMatrix state -> + Either LinearSystemError [[Expectation]] +occupationMatrix p = do + (transient, block) <- fundamentalMatrix p + let table = + Map.fromList + [ ((i, j), value) + | (i, row) <- zip transient block + , (j, value) <- zip transient row + ] + closedClasses = + [ classMembers recurrentClass + | recurrentClass <- communicatingClasses p + , classClosed recurrentClass + ] + classCount = length closedClasses + classByState :: Unboxed.UArray Int Int + classByState = + Unboxed.accumArray + (\_ classIndex -> classIndex) + (-1) + (0, stateCardinalityInt @state - 1) + [ (toIndex member, classIndex) + | (classIndex, members) <- zip [0 ..] closedClasses + , member <- members + ] + reachesClass :: Array.Array Int (Unboxed.UArray Int Bool) + reachesClass = + Array.listArray + (0, classCount - 1) + [ backwardReachabilityMask p members + | members <- closedClasses + ] + valueAt i j + | targetClass >= 0 = + if (reachesClass Array.! targetClass) Unboxed.! toIndex i + then InfiniteExpectation + else FiniteExpectation 0 + | otherwise = + FiniteExpectation (Map.findWithDefault 0 (i, j) table) + where + targetClass = classByState Unboxed.! toIndex j + pure [[valueAt i j | j <- finiteStates] | i <- finiteStates] diff --git a/src/Dtmc/Distribution.hs b/src/Dtmc/Distribution.hs new file mode 100644 --- /dev/null +++ b/src/Dtmc/Distribution.hs @@ -0,0 +1,75 @@ +{- | +Module : Dtmc.Distribution +Description : Shared abstraction for finite-support probability distributions. + +The 'Distribution' class captures the read-only probability operations shared +by concrete distribution representations. Implementations live in +"Dtmc.Distribution.Vector" and "Dtmc.Distribution.Map". +-} +module Dtmc.Distribution ( + Distribution (..), + DistributionError (..), +) where + +import Dtmc.Simplex ( + SimplexError, + ) + +{- | A simplex failure while constructing a distribution representation. +For a map-backed law, coordinate indices refer to ascending state order after +duplicate states have been combined and exact-zero weights omitted. The +wrapper keeps distribution failures distinct from transition-matrix row +failures. +-} +newtype DistributionError + = -- | Wrap the underlying simplex failure. + DistributionError SimplexError + deriving (Eq, Show) + +{- | A discrete probability distribution with finite stored support. + +The class exposes observations common to every representation. Conversions +belong to the target representation module, so this abstraction does not +depend on a particular carrier. A lawful instance has finite, non-negative +weights summing to one and reports each state at most once. Public operations +still validate where an unchecked or numerically derived value could otherwise +cause a backend failure. +-} +class Distribution distribution where + -- | State type carried by the distribution representation. + type DistributionState distribution + + {- | Read the stored probability of one state, returning exactly zero when + the representation does not store that state. The value is returned + without clamping or revalidation. + + Complexity: implementation-dependent. + -} + probabilityAt :: + (Ord (DistributionState distribution)) => + distribution -> + DistributionState distribution -> + Double + + {- | Return canonical ascending state weights. Exact-zero weights are + omitted. Custom instances and numerically derived values are returned + without revalidation. + + Complexity: implementation-dependent. + -} + distributionWeights :: + distribution -> + [(DistributionState distribution, Double)] + + {- | Return states with strictly positive stored weight, in ascending + order. Non-positive coordinates from custom instances or unchecked + numerical operations are not mathematical support. + + Complexity: implementation-dependent. + -} + support :: distribution -> [DistributionState distribution] + support distribution = + [ state + | (state, weight) <- distributionWeights distribution + , weight > 0 + ] diff --git a/src/Dtmc/Distribution/Map.hs b/src/Dtmc/Distribution/Map.hs new file mode 100644 --- /dev/null +++ b/src/Dtmc/Distribution/Map.hs @@ -0,0 +1,112 @@ +{- | +Module : Dtmc.Distribution.Map +Description : Map-backed finite-support probability distributions. + +t'DistributionMap' stores the nonzero coordinates of a probability law in a +'Data.Map.Strict.Map'. The represented state type is otherwise unrestricted. +-} +module Dtmc.Distribution.Map ( + DistributionMap, + fromList, + fromDistribution, + pointMass, + mapStates, + toMap, +) where + +import Data.Bifunctor ( + first, + ) +import Data.Map.Strict qualified as Map +import Dtmc.Distribution ( + Distribution (..), + DistributionError (DistributionError), + ) +import Dtmc.Distribution.Map.Internal ( + DistributionMap (DistributionMap), + unDistributionMap, + ) +import Dtmc.Simplex.Internal ( + canonicaliseSimplexEntries, + ) + +{- | Construct a canonical finite-support probability law. Duplicate states +are combined, entries whose combined weight is exactly zero are removed, and +input order is ignored. Tolerated coordinate error is clamped to @[0, 1]@; +the repaired weights are normalised, and weights repaired to zero are omitted. + +Complexity: @O(m log m)@ time for @m@ supplied entries, with @O(s)@ temporary +and result space for @s@ distinct states. +-} +fromList :: + (Ord state) => + [(state, Double)] -> + Either DistributionError (DistributionMap state) +fromList entries = + DistributionMap + . Map.fromDistinctAscList + . filter ((/= 0) . snd) + . zip (Map.keys combined) + <$> first + DistributionError + (canonicaliseSimplexEntries (Map.elems combined)) + where + combined = Map.filter (/= 0) (Map.fromListWith (+) entries) + +{- | Construct the point mass concentrated on one state. + +Complexity: @O(1)@ time and @O(1)@ result space. +-} +pointMass :: state -> DistributionMap state +pointMass state = DistributionMap (Map.singleton state 1) + +{- | Push a distribution through a deterministic state mapping. Weights whose +states map to the same target are added, and an exact-zero combined weight is +removed. + +No validation, clamping, or renormalisation is performed. A valid input +therefore remains a probability distribution up to ordinary floating-point +summation error. + +Complexity: @O(s log(s + 1))@ time, @O(s)@ temporary space, and @O(r)@ +result space for @s@ stored source states and @r@ distinct target states. +-} +mapStates :: + (Ord target) => + (source -> target) -> + DistributionMap source -> + DistributionMap target +mapStates transform = + DistributionMap + . Map.filter (/= 0) + . Map.mapKeysWith (+) transform + . unDistributionMap + +{- | Convert any distribution representation to a map without revalidation or +renormalisation. Weights reported for the same state are added and an +exact-zero combined weight is removed, so an instance that reports states out +of order, or reports one twice, still yields a structurally sound map. Whether +the reported weights form a probability law remains the obligation of the +'Distribution' instance. + +Complexity: the cost of 'distributionWeights', plus @O(s log s)@ time and +@O(s)@ temporary and result space for @s@ returned weights. +-} +fromDistribution :: + (Distribution distribution, Ord (DistributionState distribution)) => + distribution -> + DistributionMap (DistributionState distribution) +fromDistribution = + DistributionMap + . Map.filter (/= 0) + . Map.fromListWith (+) + . distributionWeights + +{- | Project the stored coordinates as a strict map. Exact-zero coordinates +are already omitted, so the result carries the mathematical support with its +weights. + +Complexity: @O(1)@ time and space; the stored map is shared, not copied. +-} +toMap :: DistributionMap state -> Map.Map state Double +toMap = unDistributionMap diff --git a/src/Dtmc/Distribution/Map/Internal.hs b/src/Dtmc/Distribution/Map/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Dtmc/Distribution/Map/Internal.hs @@ -0,0 +1,67 @@ +{- | +Module : Dtmc.Distribution.Map.Internal +Description : Unsafe carrier for map-backed distributions. + +The public smart constructor validates and canonicalises the simplex +invariant. Internal callers may construct values only when their operation +preserves that invariant up to floating-point error. +-} +module Dtmc.Distribution.Map.Internal ( + DistributionMap (DistributionMap), + unDistributionMap, + denseWeights, +) where + +import Data.Map.Strict ( + Map, + ) +import Data.Map.Strict qualified as Map +import Dtmc.Distribution ( + Distribution (..), + ) + +{- | A finite-support probability distribution backed by a strict map. The +internal constructor performs no validation. +-} +newtype DistributionMap state + = -- | Wrap an unchecked state-to-weight map. + DistributionMap (Map state Double) + +type role DistributionMap nominal + +deriving instance (Eq state) => Eq (DistributionMap state) +deriving instance (Show state) => Show (DistributionMap state) + +{- | Return the canonical state-to-weight map without copying or validation. + +Complexity: @O(1)@ time and @O(1)@ space. +-} +unDistributionMap :: DistributionMap state -> Map state Double +unDistributionMap (DistributionMap weights) = weights + +{- | Return the weights of a map-backed distribution over a supplied ascending +state list, inserting exact zeros for absent states. Stored states absent from +the supplied list are ignored; lawful 'Dtmc.State.FiniteState' enumerations +contain every value of their state type. + +Complexity: @O(n + s)@ time for @n@ requested states and stored support size +@s@, with @O(s)@ temporary space and @O(n)@ result space. +-} +denseWeights :: (Ord state) => [state] -> DistributionMap state -> [Double] +denseWeights states = align states . Map.toAscList . unDistributionMap + where + align [] _ = [] + align remaining [] = replicate (length remaining) 0 + align allStates@(state : rest) allWeights@((storedState, weight) : weights) = + case compare storedState state of + LT -> align allStates weights + EQ -> weight : align rest weights + GT -> 0 : align rest allWeights + +instance Distribution (DistributionMap state) where + type DistributionState (DistributionMap state) = state + + probabilityAt distribution state = + Map.findWithDefault 0 state (unDistributionMap distribution) + + distributionWeights = Map.toAscList . unDistributionMap diff --git a/src/Dtmc/Distribution/Vector.hs b/src/Dtmc/Distribution/Vector.hs new file mode 100644 --- /dev/null +++ b/src/Dtmc/Distribution/Vector.hs @@ -0,0 +1,90 @@ +{- | +Module : Dtmc.Distribution.Vector +Description : Dense probability vectors over finite state types. + +t'DistributionVector' stores a probability law over a 'FiniteState' type in an +hmatrix vector. Coordinates follow its canonical state order, so +'fromList' and 'toList' are a positional pair: both speak the same list of +weights, one coordinate per state. 'fromList' checks and canonicalises the +simplex invariant with the @1e-9@ tolerance documented by +'Dtmc.Simplex.SimplexError'. + +To build a vector from /labelled/ weights, where duplicates should combine +and missing states should default to zero, use +'Dtmc.Distribution.Map.fromList' and read the coordinates off the result: + +> Vector.fromList [probabilityAt m s | s <- finiteStates] +-} +module Dtmc.Distribution.Vector ( + DistributionVector, + DistributionVectorError (..), + fromList, + toList, +) where + +import Data.Bifunctor ( + bimap, + ) +import Dtmc.Distribution.Vector.Internal ( + DistributionVector (DistributionVector), + unDistributionVector, + ) +import Dtmc.Simplex ( + SimplexError, + ) +import Dtmc.Simplex.Internal ( + canonicaliseSimplexEntries, + ) +import Dtmc.State ( + FiniteState, + ) +import Dtmc.State.Internal ( + stateCardinalityInt, + ) +import Numeric.LinearAlgebra qualified as LA + +{- | Why a list of weights was rejected as a state distribution. +-} +data DistributionVectorError + = -- | The state cardinality and the supplied number of weights. + WrongLength Int Int + | -- | The weights failed simplex validation. The coordinate index the + -- 'SimplexError' carries is zero-based in canonical state order. + InWeights SimplexError + deriving (Eq, Show) + +{- | Construct a dense state distribution from one weight per state, in +canonical state order. The list must have exactly as many entries as the +state type has inhabitants; tolerated coordinate error is clamped to @[0, 1]@ +and the repaired weights are normalised before storage. This is the exact +inverse of 'toList' up to that repair. + +For a state type of cardinality zero the only accepted input is @[]@, which +is rejected as @Left (InWeights (SumOffBy 0))@: the empty simplex has no +points. + +Complexity: @O(n)@ time and @O(n)@ temporary and result space for state +cardinality @n@. +-} +fromList :: + forall state. + (FiniteState state) => + [Double] -> + Either DistributionVectorError (DistributionVector state) +fromList weights + | supplied /= dimension = Left (WrongLength dimension supplied) + | otherwise = + bimap InWeights (DistributionVector . LA.fromList) canonicalised + where + dimension = stateCardinalityInt @state + supplied = length weights + canonicalised = canonicaliseSimplexEntries weights + +{- | Return every stored coordinate in canonical state order, including exact +zeros. This is a representation-neutral copy of the dense vector. + +Complexity: @O(n)@ time and @O(n)@ temporary and result space for state +cardinality @n@. +-} +toList :: DistributionVector state -> [Double] +toList = LA.toList . unDistributionVector diff --git a/src/Dtmc/Distribution/Vector/Internal.hs b/src/Dtmc/Distribution/Vector/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Dtmc/Distribution/Vector/Internal.hs @@ -0,0 +1,61 @@ +{- | +Module : Dtmc.Distribution.Vector.Internal +Description : Unsafe carrier for dense distribution vectors. + +The public smart constructor validates and canonicalises the simplex +invariant. Internal callers may use the constructor only when their operation +preserves that invariant up to floating-point error. +-} +module Dtmc.Distribution.Vector.Internal ( + DistributionVector (DistributionVector), + unDistributionVector, +) where + +import Dtmc.Distribution ( + Distribution (..), + ) +import Dtmc.State ( + FiniteState, + finiteStates, + ) +import Dtmc.State.Internal ( + stateIndexInt, + ) +import Numeric.LinearAlgebra qualified as LA + +{- | A state distribution vector whose coordinates follow the canonical order +of its finite state type. The internal constructor performs no validation. +-} +newtype DistributionVector state + = -- | Wrap an unchecked probability vector. + DistributionVector (LA.Vector Double) + +-- Nominal role prevents coercion between distinct state types, including +-- state types with the same cardinality. +type role DistributionVector nominal + +deriving instance Show (DistributionVector state) + +{- | Return the stored probability vector unchanged. This performs no copy, +validation, clamping, or renormalisation. + +Complexity: @O(1)@ time and @O(1)@ space. +-} +unDistributionVector :: + DistributionVector state -> + LA.Vector Double +unDistributionVector (DistributionVector vector) = vector + +instance (FiniteState state) => Distribution (DistributionVector state) where + type DistributionState (DistributionVector state) = state + + probabilityAt distribution state = + unDistributionVector distribution `LA.atIndex` stateIndexInt state + + distributionWeights distribution = + [ (state, weight) + | (state, weight) <- zip finiteStates weights + , weight /= 0 + ] + where + weights = LA.toList (unDistributionVector distribution) diff --git a/src/Dtmc/Dynamics.hs b/src/Dtmc/Dynamics.hs new file mode 100644 --- /dev/null +++ b/src/Dtmc/Dynamics.hs @@ -0,0 +1,143 @@ +{- | +Module : Dtmc.Dynamics +Description : Deterministic forward evolution of distributions. + +Deterministic push-forward of a state distribution through a DTMC. Dense +finite laws use transition matrices; sparse finite-support laws use any +locally finite 'Transition'. In both cases, +@mu'(j) = sum_i mu(i) P(i,j)@. +-} +module Dtmc.Dynamics ( + evolve, + evolveN, + evolveVector, + evolveVectorN, +) where + +import Dtmc.Distribution ( + Distribution (..), + ) +import Dtmc.Distribution.Map ( + fromDistribution, + ) +import Dtmc.Distribution.Map.Internal ( + DistributionMap (DistributionMap), + unDistributionMap, + ) +import Dtmc.Distribution.Vector.Internal ( + DistributionVector (DistributionVector), + ) +import Dtmc.Dynamics.Internal ( + pushSparseWeights, + ) +import Dtmc.State ( + FiniteState, + ) +import Dtmc.Transition ( + Transition (..), + ) +import Dtmc.Transition.Matrix ( + power, + ) +import Dtmc.Transition.Matrix.Internal ( + TransitionMatrix, + unTransitionMatrix, + ) +import Numeric.LinearAlgebra qualified as LA +import Numeric.Natural (Natural) + +{- | Compute the next-state distribution @mu' = transpose(P) mu@. + +Exact probability inputs produce a probability distribution. The result is +wrapped without validation, clamping, or renormalisation, so error from custom +or numerically derived inputs and floating-point rounding is preserved and may +make a subsequent validation fail. + +Complexity: @O(n^2)@ time, @O(n^2)@ temporary space in the worst case, and +@O(n)@ result space for state cardinality @n@. +-} +evolveVector :: + DistributionVector state -> + TransitionMatrix state -> + DistributionVector state +evolveVector (DistributionVector v) p = + DistributionVector (LA.tr (unTransitionMatrix p) LA.#> v) + +{- | Compute the distribution after @k@ transitions as +@evolveVector mu (power k p)@. Exponent zero is the original distribution +mathematically. + +This powers the matrix rather than iterating 'evolveVector', so the two +calculations may differ by floating-point rounding. The result is not +revalidated. + +Complexity: @O(n^2 + n^3 log(k + 1))@ time, @O(n^2)@ temporary space, and +@O(n)@ result space. +-} +evolveVectorN :: + (FiniteState state) => + Natural -> + DistributionVector state -> + TransitionMatrix state -> + DistributionVector state +evolveVectorN k mu p = + evolveVector mu (power k p) + +{- | Push any finite-support 'Distribution' through one locally finite kernel +step. The result uses t'DistributionMap' because a general kernel does not +provide a finite global state enumeration. It is not revalidated, clamped, or +renormalised. + +For the complexity bounds, @s@ is the number of source states, @e@ the number +of traversed support edges, @u@ the number of distinct destinations +encountered, and @r@ the number retained after exact-zero removal. + +Complexity: excluding 'distributionWeights' and 'transitionLaw' evaluation, +@O(s + e log(u + 1) + u)@ time, @O(s + u)@ temporary space, and @O(r)@ result +space. +-} +evolve :: + ( Distribution distribution + , Transition kernel + , DistributionState distribution ~ TransitionState kernel + , Ord (TransitionState kernel) + ) => + distribution -> + kernel -> + DistributionMap (TransitionState kernel) +evolve distribution kernel = + DistributionMap + ( pushSparseWeights + (unDistributionMap (fromDistribution distribution)) + kernel + ) + +{- | Apply 'evolve' exactly @k@ times. At @k = 0@ the initial law is converted +to an equivalent t'DistributionMap' without revalidation. No state-space +enumeration or truncation is performed. + +For a positive step count, let @s@, @e@, and @u@ be upper bounds per step on +the source states, traversed support edges, and distinct destinations +encountered; let @r@ be the final support size. + +Complexity: excluding the initial 'distributionWeights' call and all +'transitionLaw' evaluations, @O(k (s + e log(u + 1) + u))@ time, +@O(s + u)@ temporary space, and @O(r)@ result space. At @k = 0@, the cost is +that of 'Dtmc.Distribution.Map.fromDistribution'. +-} +evolveN :: + ( Distribution distribution + , Transition kernel + , DistributionState distribution ~ TransitionState kernel + , Ord (TransitionState kernel) + ) => + Natural -> + distribution -> + kernel -> + DistributionMap (TransitionState kernel) +evolveN steps initial kernel = go steps (fromDistribution initial) + where + go 0 distribution = distribution + go remaining distribution = + let next = evolve distribution kernel + in next `seq` go (remaining - 1) next diff --git a/src/Dtmc/Dynamics/Internal.hs b/src/Dtmc/Dynamics/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Dtmc/Dynamics/Internal.hs @@ -0,0 +1,54 @@ +{- | +Module : Dtmc.Dynamics.Internal +Description : Unchecked sparse forward-dynamics primitive. + +Sparse weight propagation shared by public evolution and path-analysis +algorithms. Inputs may be sub-probability maps; no simplex invariant is +required or restored here. +-} +module Dtmc.Dynamics.Internal ( + pushSparseWeights, +) where + +import Data.Map.Strict ( + Map, + ) +import Data.Map.Strict qualified as Map +import Dtmc.Distribution.Map.Internal ( + unDistributionMap, + ) +import Dtmc.Transition ( + Transition (..), + ) + +{- | Push a finite, possibly sub-probability weight map through one locally +finite kernel step. Exact zero results are removed. No validation, clamping, +or renormalisation is performed. + +For the complexity bounds, @s@ is the number of source states, @e@ the number +of traversed support edges, @u@ the number of distinct destinations +encountered, and @r@ the number retained after exact-zero removal. + +Complexity: excluding 'transitionLaw' evaluation, +@O(s + e log(u + 1) + u)@ time, @O(u)@ temporary space, and @O(r)@ result +space. +-} +pushSparseWeights :: + (Transition kernel, Ord (TransitionState kernel)) => + Map (TransitionState kernel) Double -> + kernel -> + Map (TransitionState kernel) Double +pushSparseWeights weights kernel = + Map.filter (/= 0) (Map.foldlWithKey' pushState Map.empty weights) + where + pushState accumulated state stateWeight = + Map.foldlWithKey' + ( \next nextState transitionWeight -> + Map.insertWith + (+) + nextState + (stateWeight * transitionWeight) + next + ) + accumulated + (unDistributionMap (transitionLaw kernel state)) diff --git a/src/Dtmc/Simplex.hs b/src/Dtmc/Simplex.hs new file mode 100644 --- /dev/null +++ b/src/Dtmc/Simplex.hs @@ -0,0 +1,31 @@ +{- | +Module : Dtmc.Simplex +Description : Probability-simplex construction errors. + +Errors shared by the distribution and transition-matrix smart constructors. +Construction uses an absolute tolerance of @1e-9@ for coordinates and the +total. +-} +module Dtmc.Simplex ( + SimplexError (..), +) where + +{- | Why a vector failed to be a probability distribution. Bound errors carry +a zero-based index and the offending value; 'NonFiniteEntry' identifies a +@NaN@ or infinite coordinate; 'SumOffBy' carries the computed total. + +The first coordinate error takes precedence over the total. Coordinate bounds +accept @[-1e-9, 1 + 1e-9]@; the total succeeds when +@abs (total - 1) <= 1e-9@. Smart constructors clamp accepted coordinates to +@[0, 1]@ and normalise before storage. An empty vector yields @SumOffBy 0@. +-} +data SimplexError + = -- | Coordinate is @NaN@ or infinite. + NonFiniteEntry Int + | -- | Coordinate less than @-1e-9@. + NegativeEntry Int Double + | -- | Coordinate greater than @1 + 1e-9@. + EntryAboveOne Int Double + | -- | No coordinate error, but the total is outside tolerance. + SumOffBy Double + deriving (Eq, Show) diff --git a/src/Dtmc/Simplex/Internal.hs b/src/Dtmc/Simplex/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Dtmc/Simplex/Internal.hs @@ -0,0 +1,77 @@ +{- | +Module : Dtmc.Simplex.Internal +Description : Construction and repair of probability-simplex values. + +Shared simplex construction for distribution and transition-matrix smart +constructors. Accepted values are made canonical by clamping tolerated bound +error and normalising the repaired total. +-} +module Dtmc.Simplex.Internal ( + simplexTolerance, + canonicaliseSimplex, + canonicaliseSimplexEntries, +) where + +import Data.List qualified as List +import Dtmc.Simplex ( + SimplexError (..), + ) +import Numeric.LinearAlgebra qualified as LA + +-- | The absolute tolerance shared by simplex construction and sampling repair. +simplexTolerance :: Double +simplexTolerance = 1e-9 + +{- | Construct a canonical simplex vector when every coordinate is in +@[-simplexTolerance, 1 + simplexTolerance]@ and its total is in +@[1 - simplexTolerance, 1 + simplexTolerance]@. Tolerated negative coordinates +are clamped to zero, tolerated coordinates above one are clamped to one, and +the repaired coordinates are divided by their computed total. + +Reports the first non-finite or bound error before checking the total. An +empty vector yields @Left (SumOffBy 0)@. + +Complexity: @O(n)@ time and @O(n)@ temporary and result space. +-} +canonicaliseSimplex :: LA.Vector Double -> Either SimplexError (LA.Vector Double) +canonicaliseSimplex vector = + LA.fromList <$> canonicaliseSimplexEntries (LA.toList vector) + +{- | Construct a canonical finite list with the same tolerance, repair, and +error ordering as 'canonicaliseSimplex'. Entry indices refer to the supplied +list order. + +An empty list yields @Left (SumOffBy 0)@. + +Complexity: @O(n)@ time and @O(n)@ temporary and result space. +-} +canonicaliseSimplexEntries :: [Double] -> Either SimplexError [Double] +canonicaliseSimplexEntries entries = + case firstInvalidEntry 0 entries of + Just err -> Left err + Nothing + | abs (total - 1.0) <= simplexTolerance -> + Right (map (/ repairedTotal) repaired) + | otherwise -> Left (SumOffBy total) + where + total = List.foldl' (+) 0 entries + repaired = map repair entries + repairedTotal = List.foldl' (+) 0 repaired + + repair entry + | entry < 0 = 0 + | entry > 1 = 1 + | otherwise = entry + +-- Scan separately so a coordinate error reports its index before the total. +firstInvalidEntry :: Int -> [Double] -> Maybe SimplexError +firstInvalidEntry _ [] = Nothing +firstInvalidEntry index (entry : rest) + | isNaN entry || isInfinite entry = + Just (NonFiniteEntry index) + | entry < negate simplexTolerance = + Just (NegativeEntry index entry) + | entry > 1.0 + simplexTolerance = + Just (EntryAboveOne index entry) + | otherwise = + firstInvalidEntry (index + 1) rest diff --git a/src/Dtmc/Simulation.hs b/src/Dtmc/Simulation.hs new file mode 100644 --- /dev/null +++ b/src/Dtmc/Simulation.hs @@ -0,0 +1,157 @@ +{- | +Module : Dtmc.Simulation +Description : Sampling states and running the chain forward. + +Random sampling from dense or sparse state distributions, plus shared +simulation through any locally finite 'Transition'. Failures are returned as +'SimulationError' values. A validation failure leaves the supplied MWC +generator unchanged; successfully validated sampling passes it to the +categorical backend in any 'PrimMonad'. +-} +module Dtmc.Simulation ( + SimulationError (..), + sample, + step, + simulate, +) where + +import Control.Monad.Primitive ( + PrimMonad, + PrimState, + ) +import Data.List qualified as List +import Dtmc.Distribution ( + Distribution (..), + ) +import Dtmc.Simplex.Internal ( + simplexTolerance, + ) +import Dtmc.Transition ( + Transition (..), + ) +import Numeric.LinearAlgebra qualified as LA +import Numeric.Natural ( + Natural, + ) +import System.Random.MWC qualified as MWC +import System.Random.MWC.Distributions qualified as MWCD + +{- | Why sampling could not produce a state. Weight indices refer to the order +returned by 'distributionWeights'. Input errors are detected before the random +generator is used. +-} +data SimulationError + = -- | The distribution stores no states. + EmptySupport + | -- | Zero-based index of a weight that is @NaN@ or infinite. + NonFiniteWeight Int + | -- | Zero-based index and value of a weight below @-1e-9@. + NegativeWeight Int Double + | -- | Finite individual weights overflowed while being summed. + NonFiniteTotal + | -- | The repaired weights have a zero or negative total. + NonPositiveTotal Double + | -- | Impossible backend index and the stored support size. + SampleIndexOutOfBounds Int Int + deriving (Eq, Show) + +{- | Draw a state from any finite-support 'Distribution'. Before sampling, +stored weights in @[-1e-9, 0)@ are replaced by zero; the categorical sampler +scales by the resulting total, so no explicit renormalisation is stored. + +Returns 'Left' for empty support, non-finite weights or totals, weights below +@-1e-9@, or a non-positive repaired total. Validation happens before the +generator is advanced. + +Complexity: excluding 'distributionWeights', @O(s + 1)@ time and @O(s)@ +temporary space for stored support size @s@; result space is @O(1)@. +-} +sample :: + (Distribution distribution, PrimMonad m) => + distribution -> + MWC.Gen (PrimState m) -> + m (Either SimulationError (DistributionState distribution)) +sample distribution generator = + case prepareEntries (distributionWeights distribution) of + Left problem -> pure (Left problem) + Right (states, weights) -> do + index <- MWCD.categorical weights generator + pure + ( case atMay states index of + Nothing -> Left (SampleIndexOutOfBounds index (length states)) + Just state -> Right state + ) + +prepareEntries :: [(state, Double)] -> Either SimulationError ([state], LA.Vector Double) +prepareEntries [] = Left EmptySupport +prepareEntries entries = do + repaired <- traverse repairWeight (zip [0 ..] (map snd entries)) + let total = List.foldl' (+) 0 repaired + validateTotal total + pure (map fst entries, LA.fromList repaired) + +validateTotal :: Double -> Either SimulationError () +validateTotal total + | isNaN total || isInfinite total = Left NonFiniteTotal + | total <= 0 = Left (NonPositiveTotal total) + | otherwise = Right () + +repairWeight :: (Int, Double) -> Either SimulationError Double +repairWeight (index, weight) + | isNaN weight || isInfinite weight = Left (NonFiniteWeight index) + | weight < negate simplexTolerance = Left (NegativeWeight index weight) + | weight < 0 = Right 0 + | otherwise = Right weight + +atMay :: [value] -> Int -> Maybe value +atMay _ index | index < 0 = Nothing +atMay values index = + case drop index values of + [] -> Nothing + value : _ -> Just value + +{- | Sample one transition from a state through any 'Transition'. Passing each +result back with the same generator advances one trajectory. The returned +finite-support law inherits the checked repair behaviour of 'sample'. + +Complexity: excluding 'transitionLaw' and 'distributionWeights', @O(s + 1)@ +time and @O(s)@ temporary space for stored support size @s@; result space is +@O(1)@. +-} +step :: + (PrimMonad m, Transition kernel) => + kernel -> + TransitionState kernel -> + MWC.Gen (PrimState m) -> + m (Either SimulationError (TransitionState kernel)) +step kernel state = + sample (transitionLaw kernel state) + +{- | Simulate exactly @k@ transitions through any 'Transition'. On success, +return the trajectory including its initial state, with length @k + 1@. Stop +at the first invalid transition law and return its 'SimulationError'. At +@k = 0@, return the initial state without inspecting the kernel or advancing +the generator. + +Let @s@ bound the stored support size of every transition law encountered. + +Complexity: excluding 'transitionLaw' and 'distributionWeights', +@O(k (s + 1) + 1)@ time, @O(k + s + 1)@ temporary space, and @O(k + 1)@ +result space. +-} +simulate :: + (PrimMonad m, Transition kernel) => + Natural -> + kernel -> + TransitionState kernel -> + MWC.Gen (PrimState m) -> + m (Either SimulationError [TransitionState kernel]) +simulate transitions kernel initial generator = + go transitions initial [initial] + where + go 0 _ reversed = pure (Right (reverse reversed)) + go remaining current reversed = do + result <- step kernel current generator + case result of + Left problem -> pure (Left problem) + Right next -> go (remaining - 1) next (next : reversed) diff --git a/src/Dtmc/State.hs b/src/Dtmc/State.hs new file mode 100644 --- /dev/null +++ b/src/Dtmc/State.hs @@ -0,0 +1,241 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE EmptyCase #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} + +{- | +Module : Dtmc.State +Description : Canonical indexing for finite named state types. + +'FiniteState' identifies a globally finite state type with a canonical total +indexing by @'Finite' ('Cardinality' state)@. The generic implementation +supports enumeration types whose constructors have no fields. Enable +@DeriveAnyClass@ and @DeriveGeneric@, then derive both 'Generic' and +'FiniteState': + +@ +data Weather = Dry | Wet | Storm + deriving (Eq, Ord, Show, Generic, FiniteState) +@ + +After deriving 'Generic', declaring an empty @instance FiniteState Weather@ +is a more explicit way to select the same generic defaults. + +Constructor declaration order determines vector and matrix order. A stock +derived 'Ord' instance has the same order and is the intended companion; +handwritten 'FiniteState' and 'Ord' instances are trusted to preserve the +documented ordering and bijection laws. +-} +module Dtmc.State ( + type Cardinality, + type GenericCardinality, + FiniteState, + finiteStates, + stateIndex, + stateAt, +) where + +import Data.Finite ( + Finite, + finite, + finites, + getFinite, + ) +import Data.Kind ( + Type, + ) +import Data.Proxy ( + Proxy (Proxy), + ) +import GHC.Generics ( + C, + D, + Generic (Rep, from, to), + M1 (M1), + U1 (U1), + V1, + type (:+:) (L1, R1), + ) +import GHC.TypeLits ( + ErrorMessage (Text), + TypeError, + ) +import GHC.TypeNats ( + KnownNat, + Nat, + natVal, + type (+), + ) + +{- | The number of inhabitants of a finite state type. For 'Finite', this is +its existing type-level bound; for every other type, it is derived from its +'Generic' representation. Users cannot override this closed family +independently of that representation. + +A generic constructor carrying any fields reduces to a custom 'TypeError'. +-} +type family Cardinality (state :: Type) :: Nat where + Cardinality (Finite n) = n + Cardinality state = GenericCardinality (Rep state) + +{- | A finite state type with a canonical bijection to +@'Finite' ('Cardinality' state)@. + +Instances must satisfy: + +* @stateAt (stateIndex state) == state@; +* @stateIndex (stateAt index) == index@; +* @finiteStates == map stateAt finites@; +* @finiteStates@ is strictly ascending according to 'Ord'. + +The generic defaults satisfy these laws for fieldless enumeration types with +a stock derived 'Ord' instance. Handwritten method implementations are trusted +to satisfy them, but their 'Cardinality' still comes from the supported +'Generic' representation. Empty state types are supported: their state list is +empty and 'stateAt' has an uninhabited 'Finite 0' domain. +-} +class (Ord state, KnownNat (Cardinality state)) => FiniteState state where + {- | Return every state exactly once, in canonical index order. + + Complexity: implementation-dependent. + -} + finiteStates :: [state] + + {- | Convert a state to its total, statically bounded index. + + Complexity: implementation-dependent. + -} + stateIndex :: state -> Finite (Cardinality state) + + {- | Recover the state at a statically bounded index. + + Complexity: implementation-dependent. + -} + stateAt :: Finite (Cardinality state) -> state + + default finiteStates :: + ( Generic state + , GenericFiniteState (Rep state) + ) => + [state] + finiteStates = map to genericStates + + default stateIndex :: + ( Generic state + , GenericFiniteState (Rep state) + ) => + state -> + Finite (Cardinality state) + stateIndex = finite . genericIndex . from + + default stateAt :: + ( Generic state + , GenericFiniteState (Rep state) + ) => + Finite (Cardinality state) -> + state + stateAt = to . genericAt . fromIntegral . getFinite + +instance (KnownNat n) => FiniteState (Finite n) where + finiteStates = finites + stateIndex = id + stateAt = id + +instance FiniteState () + +instance FiniteState Bool + +instance FiniteState Ordering + +{- | The type-level cardinality of a 'Generic' representation. This advanced +helper underlies 'Cardinality'; ordinary users should use 'FiniteState' +instead. +-} +type family GenericCardinality (representation :: Type -> Type) :: Nat where + GenericCardinality (M1 D metadata representation) = + GenericCardinality representation + GenericCardinality (left :+: right) = + GenericCardinality left + GenericCardinality right + GenericCardinality (M1 C metadata U1) = 1 + GenericCardinality (M1 C metadata fields) = + TypeError + ( 'Text + "FiniteState: constructors with fields are unsupported" + ) + GenericCardinality V1 = 0 + +-- Generic machinery implementing the canonical state/index bijection for +-- fieldless enumeration representations. +class GenericFiniteState representation where + genericStates :: [representation value] + genericIndex :: representation value -> Integer + genericAt :: Integer -> representation value + +instance + (GenericFiniteState representation) => + GenericFiniteState (M1 D metadata representation) + where + genericStates = map M1 genericStates + genericIndex (M1 value) = genericIndex value + genericAt = M1 . genericAt + +instance + ( GenericFiniteState left + , GenericFiniteState right + , KnownNat (GenericCardinality left) + ) => + GenericFiniteState (left :+: right) + where + genericStates = + map L1 (genericStates @left) + ++ map R1 (genericStates @right) + + genericIndex (L1 value) = genericIndex value + genericIndex (R1 value) = genericCardinality @left + genericIndex value + + genericAt index + | index < genericCardinality @left = L1 (genericAt index) + | otherwise = + R1 (genericAt (index - genericCardinality @left)) + +genericCardinality :: + forall representation. + (KnownNat (GenericCardinality representation)) => + Integer +genericCardinality = + fromIntegral (natVal (Proxy @(GenericCardinality representation))) + +instance {-# OVERLAPPING #-} GenericFiniteState (M1 C metadata U1) where + genericStates = [M1 U1] + genericIndex (M1 U1) = 0 + genericAt _ = M1 U1 + +instance + {-# OVERLAPPABLE #-} + ( TypeError + ( 'Text + "FiniteState: constructors with fields are unsupported" + ) + ) => + GenericFiniteState (M1 C metadata fields) + where + genericStates = unsupportedConstructorFields + genericIndex _ = unsupportedConstructorFields + genericAt _ = unsupportedConstructorFields + +-- Required only to complete an instance made unusable by its 'TypeError'. +unsupportedConstructorFields :: value +unsupportedConstructorFields = + error "Dtmc.State: constructors with fields are unsupported" + +instance GenericFiniteState V1 where + genericStates = [] + genericIndex value = case value of {} + genericAt _ = + error "Dtmc.State.stateAt: unreachable Finite 0 index" diff --git a/src/Dtmc/State/Internal.hs b/src/Dtmc/State/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Dtmc/State/Internal.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +{- | +Module : Dtmc.State.Internal +Description : Checked conversions for finite-state indices. + +Shared conversions between named finite states and the integer indices used by +dynamic graph and linear-algebra code. Keeping the reverse conversion here +prevents an arbitrary 'Int' from being passed directly to 'Data.Finite.finite', +which wraps out-of-range values modulo the state-space cardinality. +-} +module Dtmc.State.Internal ( + stateCardinalityInt, + stateIndexInt, + stateFromInt, +) where + +import Data.Finite ( + finite, + getFinite, + ) +import Data.Proxy ( + Proxy (Proxy), + ) +import Dtmc.State ( + Cardinality, + FiniteState, + stateAt, + stateIndex, + ) +import GHC.TypeNats ( + natVal, + ) + +{- | Return the number of states as a runtime 'Int'. + +Complexity: @O(1)@ time and @O(1)@ space. +-} +stateCardinalityInt :: forall state. (FiniteState state) => Int +stateCardinalityInt = + fromIntegral (natVal (Proxy @(Cardinality state))) + +{- | Return the canonical zero-based integer index of a state. + +Complexity: the cost of 'stateIndex' plus @O(1)@ time and @O(1)@ space. +-} +stateIndexInt :: (FiniteState state) => state -> Int +stateIndexInt = fromIntegral . getFinite . stateIndex + +{- | Recover the state at a runtime integer index. Returns 'Nothing' rather +than wrapping a negative or out-of-range integer modulo the state count. + +Complexity: the cost of 'stateAt' plus @O(1)@ time and @O(1)@ space. +-} +stateFromInt :: forall state. (FiniteState state) => Int -> Maybe state +stateFromInt index + | index < 0 || index >= stateCardinalityInt @state = Nothing + | otherwise = Just (stateAt (finite (fromIntegral index))) diff --git a/src/Dtmc/Transition.hs b/src/Dtmc/Transition.hs new file mode 100644 --- /dev/null +++ b/src/Dtmc/Transition.hs @@ -0,0 +1,35 @@ +{- | +Module : Dtmc.Transition +Description : Shared abstraction for locally finite transition rules. + +'Transition' captures the operation shared by finite transition matrices and +locally finite kernels: obtaining the validated finite-support law of the next +state from a supplied current state. Concrete representations live in +"Dtmc.Transition.Matrix" and "Dtmc.Transition.Kernel". +-} +module Dtmc.Transition ( + Transition (..), +) where + +import Dtmc.Distribution.Map (DistributionMap) + +{- | A time-homogeneous transition rule whose law from any supplied state has +finite support. The complete state space may be finite or infinite. + +This capability is sufficient for exact finite-horizon map-backed algorithms. +It does not imply that states can be enumerated, so it cannot by itself support +generic classification, stationary, eventual-hitting, or expectation +algorithms. +-} +class Transition transition where + -- | State type governed by this transition representation. + type TransitionState transition + + {- | Return the validated finite-support law of the next state. + + Complexity: implementation-dependent. + -} + transitionLaw :: + transition -> + TransitionState transition -> + DistributionMap (TransitionState transition) diff --git a/src/Dtmc/Transition/Kernel.hs b/src/Dtmc/Transition/Kernel.hs new file mode 100644 --- /dev/null +++ b/src/Dtmc/Transition/Kernel.hs @@ -0,0 +1,42 @@ +{- | +Module : Dtmc.Transition.Kernel +Description : Locally finite transition kernels over unrestricted state types. + +A t'TransitionKernel' represents a transition rule directly as a function from +each state to its validated map-backed next-state distribution. No global +state-space enumeration is required or attempted. +-} +module Dtmc.Transition.Kernel ( + TransitionKernel, + fromLaws, +) where + +import Dtmc.Distribution.Map ( + DistributionMap, + ) +import Dtmc.Transition ( + Transition (..), + ) + +-- | A locally finite transition kernel over a potentially infinite state type. +newtype TransitionKernel state + = TransitionKernel (state -> DistributionMap state) + +type role TransitionKernel nominal + +instance Transition (TransitionKernel state) where + type TransitionState (TransitionKernel state) = state + + transitionLaw (TransitionKernel kernel) = kernel + +{- | Construct a kernel from the function that supplies its transition laws. +Each law must already be a validated t'DistributionMap'; no global state-space +traversal is required or attempted. +'Dtmc.Transition.transitionLaw' reads those laws back. + +Complexity: @O(1)@ time and @O(1)@ space. +-} +fromLaws :: + (state -> DistributionMap state) -> + TransitionKernel state +fromLaws = TransitionKernel diff --git a/src/Dtmc/Transition/Matrix.hs b/src/Dtmc/Transition/Matrix.hs new file mode 100644 --- /dev/null +++ b/src/Dtmc/Transition/Matrix.hs @@ -0,0 +1,206 @@ +{- | +Module : Dtmc.Transition.Matrix +Description : Row-stochastic matrices over finite state types. + +One-step transition probabilities for a DTMC over a 'FiniteState' type. +'fromRows' builds one from a grid of weights and 'fromKernel' from an +already-validated finite-state kernel; 'compose', 'identity', and 'power' +provide multi-step transitions. 'toRows' reads the stored probabilities back +as plain lists. +-} +module Dtmc.Transition.Matrix ( + -- * Representation + TransitionMatrix, + TransitionMatrixError (..), + + -- * Construction and inspection + fromKernel, + fromRows, + toRows, + rowAt, + + -- * Composition + compose, + identity, + power, +) where + +import Data.Bifunctor ( + first, + ) +import Data.Semigroup ( + mtimesDefault, + ) +import Dtmc.Distribution.Map.Internal ( + denseWeights, + ) +import Dtmc.Distribution.Vector.Internal ( + DistributionVector, + ) +import Dtmc.Simplex ( + SimplexError, + ) +import Dtmc.Simplex.Internal ( + canonicaliseSimplexEntries, + ) +import Dtmc.State ( + FiniteState, + finiteStates, + ) +import Dtmc.State.Internal ( + stateCardinalityInt, + ) +import Dtmc.Transition ( + Transition (transitionLaw), + ) +import Dtmc.Transition.Kernel ( + TransitionKernel, + ) +import Dtmc.Transition.Matrix.Internal ( + TransitionMatrix, + matrixRowAt, + unTransitionMatrix, + unsafeTransitionMatrix, + ) +import Numeric.LinearAlgebra qualified as LA +import Numeric.Natural ( + Natural, + ) + +{- | Why a supplied grid of weights is not a transition matrix. Row and column +indices are zero-based and follow the canonical state order of the +'FiniteState' instance. +-} +data TransitionMatrixError + = -- | A row failed simplex validation: its index and the underlying + -- failure, whose coordinate index is the zero-based column. + InRow Int SimplexError + | -- | The state cardinality and the supplied number of rows. + WrongRowCount Int Int + | -- | A row of the wrong width: its index, the state cardinality, and the + -- supplied width. + WrongRowWidth Int Int Int + deriving (Eq, Show) + +{- | Construct a row-stochastic matrix from a grid of weights in canonical +state order, stopping at the first problem. Within each accepted row, +tolerated coordinate error is clamped to @[0, 1]@ and the repaired row is +normalised. The support graph remains lazy, and the empty @0 x 0@ matrix is +accepted. + +This inverts 'toRows' up to that repair and needs no @hmatrix@ value: the +shape is checked here and reported as 'WrongRowCount' or 'WrongRowWidth' +rather than raised by the array backend. + +Complexity: @O(n^2)@ time and @O(n^2)@ temporary and result space. +-} +fromRows :: + forall state. + (FiniteState state) => + [[Double]] -> + Either TransitionMatrixError (TransitionMatrix state) +fromRows rows + | suppliedRows /= dimension = Left (WrongRowCount dimension suppliedRows) + | otherwise = + unsafeTransitionMatrix . (dimension LA.>< dimension) . concat + <$> traverse canonicaliseRow (zip [0 ..] rows) + where + dimension = stateCardinalityInt @state + suppliedRows = length rows + + canonicaliseRow (index, row) + | width /= dimension = Left (WrongRowWidth index dimension width) + | otherwise = first (InRow index) (canonicaliseSimplexEntries row) + where + width = length row + +{- | Materialise a finite-state kernel as a dense transition matrix. Kernel +rows are already validated 'Dtmc.Distribution.Map.DistributionMap' values, so +this conversion is total and performs no additional clamping or +renormalisation. Missing coordinates become exact zeros. The support graph +remains lazy, and the empty @0 x 0@ matrix is accepted. + +Complexity: excluding evaluation of 'finiteStates' and the kernel laws, +@O(n^2)@ time and @O(n^2)@ temporary and result space. +-} +fromKernel :: + forall state. + (FiniteState state) => + TransitionKernel state -> + TransitionMatrix state +fromKernel kernel = + unsafeTransitionMatrix $ + (dimension LA.>< dimension) + [ weight + | source <- finiteStates + , let distribution = transitionLaw kernel source + , weight <- denseWeights finiteStates distribution + ] + where + dimension = stateCardinalityInt @state + +{- | Return all stored entries as rows in canonical state order. Exact zeros +are retained. This is a representation-neutral copy of the dense matrix and +does not force its support graph. + +Complexity: @O(n^2)@ time and @O(n^2)@ temporary and result space. +-} +toRows :: TransitionMatrix state -> [[Double]] +toRows = LA.toLists . unTransitionMatrix + +{- | Compose two transitions: @compose p q@ means take a @p@ step, +then a @q@ step, and stores the matrix product @P Q@. + +The product is not revalidated. Row-stochastic matrices are closed under +multiplication mathematically, but floating-point rounding can accumulate. + +Complexity: @O(n^3)@ worst-case time and @O(n^2)@ temporary and result space. +The support graph is built lazily. +-} +compose :: + TransitionMatrix state -> + TransitionMatrix state -> + TransitionMatrix state +compose = (<>) + +{- | Return the @n x n@ identity: the zero-step transition that leaves every +state unchanged. For @n = 0@ this is the empty matrix. + +Complexity: @O(1)@ construction time and @O(1)@ construction space. Forcing +the dense entries or support graph takes @O(n^2)@ time and @O(n^2)@ temporary +space; the support graph itself occupies @O(n)@ space. +-} +identity :: (FiniteState state) => TransitionMatrix state +identity = mempty + +{- | Compute the @k@-step transition matrix @p^k@. Exponent zero returns +'identity'; positive exponents use repeated squaring through +'Data.Semigroup.mtimesDefault'. + +Chapman-Kolmogorov gives @p^(m+n) = p^m p^n@ mathematically; computed matrices +may differ by floating-point rounding and are not revalidated. + +Complexity: @O(n^2 + n^3 log(k + 1))@ time and @O(n^2)@ temporary and result +space. +-} +power :: + (FiniteState state) => + Natural -> + TransitionMatrix state -> + TransitionMatrix state +power = mtimesDefault + +{- | Return the stored row for a state: its next-state distribution. +'FiniteState' indexing makes the lookup total. The row is wrapped without +revalidation, so any floating-point drift from matrix arithmetic is +preserved. + +Complexity: excluding 'Dtmc.State.stateIndex', @O(n)@ time and @O(n)@ result +space for state cardinality @n@. +-} +rowAt :: + (FiniteState state) => + TransitionMatrix state -> + state -> + DistributionVector state +rowAt = matrixRowAt diff --git a/src/Dtmc/Transition/Matrix/Internal.hs b/src/Dtmc/Transition/Matrix/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Dtmc/Transition/Matrix/Internal.hs @@ -0,0 +1,168 @@ +{- | +Module : Dtmc.Transition.Matrix.Internal +Description : Raw carrier for transition matrices (unsafe underbelly). + +Raw carrier behind t'Dtmc.Transition.Matrix.TransitionMatrix': an hmatrix +matrix paired with its lazy support graph. The public smart constructor +validates its square shape and canonicalises rows; this internal module +exposes unchecked construction. + +The constructor is positional so the public matrix projection cannot act as a +record-update setter and desynchronise the matrix from its cached graph. +-} +module Dtmc.Transition.Matrix.Internal ( + TransitionMatrix (TransitionMatrix), + unTransitionMatrix, + tmSupport, + unsafeTransitionMatrix, + matrixRowAt, +) where + +import Dtmc.Distribution.Map ( + fromDistribution, + ) +import Dtmc.Distribution.Vector.Internal ( + DistributionVector (DistributionVector), + ) +import Dtmc.State ( + FiniteState, + ) +import Dtmc.State.Internal ( + stateCardinalityInt, + stateIndexInt, + ) +import Dtmc.Transition ( + Transition (..), + ) +import Dtmc.Transition.Matrix.Internal.Graph ( + Graph, + fromAdjacency, + ) +import Numeric.LinearAlgebra qualified as LA + +{- | A stored square matrix whose rows and columns follow the canonical order +of its finite state type. Entry @(i,j)@ is the transition probability from +state @i@ to state @j@. 'Dtmc.Transition.Matrix.fromKernel' materialises +already-validated rows, while 'Dtmc.Transition.Matrix.fromRows' applies +tolerant row validation and canonicalisation. The internal constructor and +arithmetic instances do not revalidate. + +Each value also carries its support graph as a /lazy/ second argument, so any +graph-based analyses on the same value share one build. Construct internal +values with @unsafeTransitionMatrix@ rather than pairing a matrix and graph +directly. +-} +data TransitionMatrix state + = -- | Unchecked matrix/cache pair; the graph must match the matrix. + TransitionMatrix (LA.Matrix Double) Graph + +-- Nominal role prevents coercion between distinct state types, including +-- state types with the same cardinality. +type role TransitionMatrix nominal + +{- | Return the stored matrix unchanged without forcing the support graph. + +Complexity: @O(1)@ time and @O(1)@ space. +-} +unTransitionMatrix :: + TransitionMatrix state -> + LA.Matrix Double +unTransitionMatrix (TransitionMatrix matrix _) = matrix + +{- | Return the lazy support graph, with edge @i -> j@ exactly when the stored +entry is strictly positive. No tolerance is applied: a tiny positive rounding +value creates an edge, while zero or a negative value does not. + +The result is shared by later analyses of the same value. + +Complexity: @O(1)@ projection time and @O(1)@ projection space. The first +analysis that forces the graph takes @O(n^2)@ time and @O(n^2)@ temporary +space; the resulting graph occupies @O(n + E)@ space for @E@ support edges. +-} +tmSupport :: TransitionMatrix state -> Graph +tmSupport (TransitionMatrix _ support) = support + +-- Manual 'Show': 'Graph' has no 'Show', and the derived cache should not +-- appear in the rendering. +instance Show (TransitionMatrix state) where + showsPrec d p = + showParen (d > 10) $ + showString "TransitionMatrix " + . showsPrec 11 (unTransitionMatrix p) + +{- | Pair a raw matrix with its lazy support graph. This performs no +row-stochastic, finiteness, or simplex validation; internal callers must +establish the required invariant. + +Complexity: @O(1)@ construction time and @O(1)@ construction space. Forcing +the support graph takes @O(n^2)@ time and @O(n^2)@ temporary space; the graph +occupies @O(n + E)@ space for @E@ support edges. +-} +unsafeTransitionMatrix :: + LA.Matrix Double -> + TransitionMatrix state +unsafeTransitionMatrix matrix = + TransitionMatrix matrix (supportGraphOf matrix) + +{- | Wrap one stored matrix row as a distribution vector without revalidation. +The finite-state index makes the lookup total. + +Complexity: excluding 'Dtmc.State.stateIndex', @O(n)@ time and @O(n)@ result +space for state cardinality @n@. +-} +matrixRowAt :: + (FiniteState state) => + TransitionMatrix state -> + state -> + DistributionVector state +matrixRowAt matrix state = DistributionVector row + where + stored = unTransitionMatrix matrix + row = + LA.flatten + ( LA.subMatrix + (stateIndexInt state, 0) + (1, LA.cols stored) + stored + ) + +instance (FiniteState state) => Transition (TransitionMatrix state) where + type TransitionState (TransitionMatrix state) = state + + transitionLaw matrix = + fromDistribution . matrixRowAt matrix + +-- Use strict positivity without tolerance so graph queries reflect the stored +-- matrix exactly; keep construction here so the cache cannot become stale. +supportGraphOf :: + LA.Matrix Double -> + Graph +supportGraphOf matrix = + fromAdjacency + dim + [ ((i, j), entry > 0) + | (i, row) <- zip [0 ..] rows + , (j, entry) <- zip [0 ..] row + ] + where + rows = LA.toLists matrix + dim = length rows + +{- | Matrix multiplication as transition composition: @p '<>' q@ takes a @p@ +step followed by a @q@ step. Exact products preserve row-stochasticity and +associativity; 'Double' results are neither revalidated nor exactly +associative. +-} +instance Semigroup (TransitionMatrix state) where + (<>) :: + TransitionMatrix state -> + TransitionMatrix state -> + TransitionMatrix state + p <> q = unsafeTransitionMatrix (unTransitionMatrix p LA.<> unTransitionMatrix q) + +{- | The identity matrix represents zero transitions and is the unit of the +transition-composition monoid. +-} +instance (FiniteState state) => Monoid (TransitionMatrix state) where + mempty :: TransitionMatrix state + mempty = unsafeTransitionMatrix (LA.ident (stateCardinalityInt @state)) diff --git a/src/Dtmc/Transition/Matrix/Internal/Graph.hs b/src/Dtmc/Transition/Matrix/Internal/Graph.hs new file mode 100644 --- /dev/null +++ b/src/Dtmc/Transition/Matrix/Internal/Graph.hs @@ -0,0 +1,496 @@ +{- | +Module : Dtmc.Transition.Matrix.Internal.Graph +Description : Support-graph reachability, components, periods, and phases. + +A small DTMC-specific layer over "Data.Graph". It knows nothing about +probabilities: vertices are the integers @{0 .. n-1}@ and edges are the +positive entries of the transition matrix's support. + +The graph is stored as adjacency lists in both directions. Keeping the +transpose makes forward and reverse traversals proportional to the graph +actually visited instead of requiring matrix row or column scans. + +Unless stated otherwise, every vertex argument must be in @{0 .. V-1}@. +Passing an out-of-range vertex may raise an array-bounds error. + +Query complexities assume that the required forward or reverse adjacency +array has already been forced. The first query after 'fromAdjacency' also pays +the documented cost of building that array. +-} +module Dtmc.Transition.Matrix.Internal.Graph ( + Graph, + graphDim, + fromAdjacency, + hasEdge, + reachable, + reachesAny, + backwardReachable, + components, + componentOf, + sameComponent, + isClosed, + inClosedComponent, + componentPeriod, + periodOf, + phaseOf, +) where + +import Data.Array qualified as Array +import Data.Array.Unboxed qualified as Unboxed +import Data.Graph qualified as DG +import Data.IntMap.Strict qualified as IntMap +import Data.IntSet qualified as IntSet +import Data.List qualified as List +import Data.Sequence qualified as Sequence +import Data.Tree (Tree, flatten) +import Numeric.Natural (Natural) + +{- | An immutable directed graph. + +'graphSuccessors' contains outgoing neighbours. 'graphPredecessors' is the +transposed graph and therefore contains incoming neighbours. Both describe +the same logical edge set. + +Strongly connected components, the component lookup table, the +closed-component table, and the per-vertex period and phase tables are lazy +derived fields. The component structure comes from 'DG.scc'; the period and +phase tables come from one BFS per component. Each field is computed on first +use. +-} +data Graph = Graph + { graphDim :: Int + {- ^ Number of vertices @V@. + + Complexity: @O(1)@ time and @O(1)@ space. + -} + , graphSuccessors :: DG.Graph + -- ^ Original graph: the row for @u@ contains every @v@ with @u -> v@. + , graphPredecessors :: DG.Graph + -- ^ Transpose: the row for @v@ contains every @u@ with @u -> v@. + , graphSccs :: [[Int]] + -- ^ Normalised strongly connected components. + , graphComponentOf :: Array.Array Int [Int] + -- ^ Constant-time vertex-to-component lookup after SCC construction. + , graphComponentId :: Unboxed.UArray Int Int + {- ^ Constant-time vertex-to-component-index lookup: two vertices share a + strongly connected component (communicate) iff they map to the same + index. Backs 'sameComponent'. The table is also used while deriving + component closedness; retaining it here adds @O(V)@ unboxed storage and + makes same-component queries @O(1)@. + -} + , graphClosedComponentTable :: Unboxed.UArray Int Bool + {- ^ Per-vertex closedness of its component: @True@ iff the vertex's + strongly connected component is a sink of the condensation (no edge + leaves it). Settled in one pass over all edges. + -} + , graphPeriodOf :: Array.Array Int (Maybe Natural) + {- ^ Per-vertex period of its strongly connected component (@Nothing@ when + the component has no cycles). Filled by one BFS per component. + -} + , graphPhaseOf :: Unboxed.UArray Int Int + {- ^ Per-vertex phase within its component: the BFS level from the + component's least vertex, modulo the period. Every edge /within a + component/ advances the phase by one (modulo that period); edges leaving + a component relate phases across different components and obey no such + rule. Shares its BFS with 'graphPeriodOf'. + -} + } + +{- | Build a graph from a complete Boolean adjacency association list. Only +entries whose value is 'True' become edges. + +The dimension must be non-negative, and the list is expected to contain +exactly one entry for each pair in @{0 .. V-1}^2@. Completeness and uniqueness +are not validated: missing pairs act as 'False', and repeated 'True' entries +create duplicate edges. A negative dimension raises an error; an out-of-range +endpoint may fail when a lazy field is forced. + +Complexity: @O(1)@ initial time and @O(1)@ initial space. For @A@ supplied +entries, forcing the forward adjacency array takes @O(V + A)@ time and +@O(V + E)@ result space; first forcing the transpose takes a further +@O(V + E)@ time and @O(V + E)@ result space. For a complete input, @A = V^2@. +-} +fromAdjacency :: Int -> [((Int, Int), Bool)] -> Graph +fromAdjacency dim entries + | dim < 0 = error "Dtmc.Transition.Matrix.Internal.Graph.fromAdjacency: negative dimension" + | otherwise = + Graph + { graphDim = dim + , graphSuccessors = successors + , graphPredecessors = DG.transposeG successors + , graphSccs = sccs + , graphComponentOf = componentTable + , graphComponentId = componentIds + , graphClosedComponentTable = closedComponentTable + , graphPeriodOf = periodTable + , graphPhaseOf = phaseTable + } + where + successors = + DG.buildG + (vertexBounds dim) + [pair | (pair, present) <- entries, present] + + sccs = normaliseComponents (DG.scc successors) + + componentTable = + Array.array + (vertexBounds dim) + [ (vertex, component) + | component <- sccs + , vertex <- component + ] + + -- A component is closed iff no edge leaves it. Record component ids so one + -- pass over cross-component edges can mark every open component. + componentIds :: Unboxed.UArray Int Int + componentIds = + Unboxed.array + (vertexBounds dim) + [ (vertex, componentIndex) + | (componentIndex, component) <- zip [0 ..] sccs + , vertex <- component + ] + + openComponentIds :: IntSet.IntSet + openComponentIds = + IntSet.fromList + [ componentIds Unboxed.! from + | from <- [0 .. dim - 1] + , to <- successors Array.! from + , componentIds Unboxed.! from /= componentIds Unboxed.! to + ] + + closedComponentTable :: Unboxed.UArray Int Bool + closedComponentTable = + Unboxed.listArray + (vertexBounds dim) + [ not (IntSet.member (componentIds Unboxed.! vertex) openComponentIds) + | vertex <- [0 .. dim - 1] + ] + + -- One BFS per component yields both its period and each vertex's phase. + -- The list is a shared thunk, so the period and phase tables never repeat + -- the traversal. + componentPhases :: [(Maybe Natural, [(Int, Int)])] + componentPhases = [componentPhasing successors component | component <- sccs] + + periodTable :: Array.Array Int (Maybe Natural) + periodTable = + Array.array + (vertexBounds dim) + [ (vertex, period) + | (period, phases) <- componentPhases + , (vertex, _) <- phases + ] + + phaseTable :: Unboxed.UArray Int Int + phaseTable = + Unboxed.array + (vertexBounds dim) + [ (vertex, phase) + | (_, phases) <- componentPhases + , (vertex, phase) <- phases + ] + +vertexBounds :: Int -> (Int, Int) +vertexBounds dim = (0, dim - 1) + +vertices :: Graph -> [Int] +vertices graph = [0 .. graphDim graph - 1] + +{- | Test whether a direct edge leads from @from@ to @to@. + +Algorithms should normally enumerate an adjacency row instead of repeatedly +calling 'hasEdge'. + +Complexity: @O(outDegree(from))@ time and @O(1)@ space because a 'Data.Graph' +row is a list. +-} +hasEdge :: Graph -> Int -> Int -> Bool +hasEdge graph from to = to `elem` (graphSuccessors graph Array.! from) + +{- | Test whether @to@ is reachable from @from@ in zero or more steps. + +This delegates to 'DG.path' and performs a graph search rather than +retaining a quadratic transitive closure. + +Complexity: @O(V + E)@ worst-case time and @O(V)@ traversal space per query. +-} +reachable :: Graph -> Int -> Int -> Bool +reachable graph = DG.path (graphSuccessors graph) + +{- | Test whether @from@ can reach any supplied target in zero or more steps. + +Targets are materialised as a Boolean membership array. The lazy reachable +stream is then consumed until it encounters a target, so the traversal can +terminate early. + +Complexity: @O(V + T + E_r)@ worst-case time, where @T@ is the number of +supplied targets and @E_r@ is the portion of the graph examined before +termination; @O(V)@ space. +-} +reachesAny :: Graph -> Int -> [Int] -> Bool +reachesAny _ _ [] = False +reachesAny graph from targets = + any (targetMask Unboxed.!) reachableVertices + where + targetMask :: Unboxed.UArray Int Bool + targetMask = + Unboxed.accumArray + (||) + False + (vertexBounds (graphDim graph)) + [(target, True) | target <- targets] + + reachableVertices = DG.reachable (graphSuccessors graph) from + +{- | Return the vertices that can reach a seed inside the subgraph induced by +@allowed@. + +The allowed predicate is evaluated once per vertex. The transpose is +filtered to the induced subgraph, after which 'DG.dfs' performs one +multi-source traversal. A Boolean result mask restores ascending output +order without an @O(R log R)@ comparison sort. + +Complexity: @O(V + E)@ time, excluding the cost of the @V@ predicate calls, +and @O(V + E)@ space for the filtered adjacency lists and traversal state. +-} +backwardReachable :: Graph -> (Int -> Bool) -> [Int] -> [Int] +backwardReachable graph allowed seeds = + [vertex | vertex <- allVertices, reachedMask Unboxed.! vertex] + where + allVertices = vertices graph + dim = graphDim graph + + allowedMask :: Unboxed.UArray Int Bool + allowedMask = + Unboxed.listArray + (vertexBounds dim) + (map allowed allVertices) + + isAllowed vertex = allowedMask Unboxed.! vertex + + allowedSeeds = List.filter isAllowed seeds + + restrictedPredecessors :: DG.Graph + restrictedPredecessors = + Array.listArray + (vertexBounds dim) + [ if isAllowed vertex + then + List.filter + isAllowed + (graphPredecessors graph Array.! vertex) + else [] + | vertex <- allVertices + ] + + reached = + concatMap flatten (DG.dfs restrictedPredecessors allowedSeeds) + + reachedMask :: Unboxed.UArray Int Bool + reachedMask = + Unboxed.accumArray + (||) + False + (vertexBounds dim) + [(vertex, True) | vertex <- reached] + +{- | Return the strongly connected components. Vertices within each component +are in ascending order, and components are ordered by their least vertex. + +Complexity: first full evaluation takes @O(V + E + V log V)@ time and @O(V)@ +temporary and result space. Later projections take @O(1)@ time and @O(1)@ +space before traversal of the cached result. +-} +components :: Graph -> [[Int]] +components = graphSccs + +normaliseComponents :: [Tree Int] -> [[Int]] +normaliseComponents = + List.sortOn componentKey . map (List.sort . flatten) + where + componentKey [] = -1 + componentKey (first : _) = first + +{- | Return the strongly connected component containing a vertex. + +Complexity: the first query takes @O(V + E + V log V)@ time and @O(V)@ cache +space; subsequent queries take @O(1)@ time and @O(1)@ space. +-} +componentOf :: Graph -> Int -> [Int] +componentOf graph vertex + | vertex < 0 || vertex >= graphDim graph = + error "Dtmc.Transition.Matrix.Internal.Graph.componentOf: vertex out of bounds" + | otherwise = graphComponentOf graph Array.! vertex + +{- | Test whether two vertices lie in the same strongly connected component; +that is, whether they communicate. This compares their cached component +indices instead of performing two reachability searches. + +Complexity: the first query takes @O(V + E + V log V)@ time and @O(V)@ cache +space; subsequent queries take @O(1)@ time and @O(1)@ space. +-} +sameComponent :: Graph -> Int -> Int -> Bool +sameComponent graph a b + | outOfRange a || outOfRange b = + error "Dtmc.Transition.Matrix.Internal.Graph.sameComponent: vertex out of bounds" + | otherwise = + graphComponentId graph Unboxed.! a == graphComponentId graph Unboxed.! b + where + outOfRange v = v < 0 || v >= graphDim graph + +{- | Test whether a vertex set is closed: no direct edge leaves it. + +Duplicates are ignored, and the empty set is closed. + +Complexity: @O(V + S + E_C)@ time, where @S@ is the supplied list length and +@E_C@ is the total out-degree of its vertices; @O(V)@ space for membership. +-} +isClosed :: Graph -> [Int] -> Bool +isClosed graph suppliedVertices = + all staysInside uniqueVertices + where + dim = graphDim graph + allVertices = vertices graph + + member :: Unboxed.UArray Int Bool + member = + Unboxed.accumArray + (||) + False + (vertexBounds dim) + [(vertex, True) | vertex <- suppliedVertices] + + uniqueVertices = + [vertex | vertex <- allVertices, member Unboxed.! vertex] + + staysInside from = + all + (member Unboxed.!) + (graphSuccessors graph Array.! from) + +{- | Test whether a vertex lies in a closed strongly connected component: a +sink of the condensation with no outgoing edge. In finite-chain terms, this +is exactly recurrence, but that interpretation belongs to the Markov-chain +layer rather than this graph module. + +This is the specialised, precomputed form of +@'isClosed' g ('componentOf' g v)@: the open/closed status of every component +is settled once by a pass over all edges and cached, so each later query is a +constant-time array read. + +Complexity: the first query takes @O((V + E) log V)@ time and @O(V)@ cache +space; subsequent queries take @O(1)@ time and @O(1)@ space. +-} +inClosedComponent :: Graph -> Int -> Bool +inClosedComponent graph vertex + | vertex < 0 || vertex >= graphDim graph = + error "Dtmc.Transition.Matrix.Internal.Graph.inClosedComponent: vertex out of bounds" + | otherwise = graphClosedComponentTable graph Unboxed.! vertex + +{- | Return the period of a strongly connected component: the gcd of the +lengths of all its closed walks. 'Nothing' denotes an empty component or a +singleton with no self-loop. + +The input is expected to be a genuine strongly connected component; the value +returned is the period of the component containing its first vertex, read from +the precomputed 'graphPeriodOf' table. + +Complexity: an empty input takes @O(1)@ time and @O(1)@ space. The first +non-empty query takes @O((V + E) log V)@ time and @O(V)@ cache space; +subsequent queries take @O(1)@ time and @O(1)@ space. +-} +componentPeriod :: Graph -> [Int] -> Maybe Natural +componentPeriod _ [] = Nothing +componentPeriod graph (root : _) = periodOf graph root + +{- | Return the period of the strongly connected component containing the +vertex. Returns 'Nothing' when that component has no cycles. The value is read +from the precomputed table. + +Complexity: the first query takes @O((V + E) log V)@ time and @O(V)@ cache +space; subsequent queries take @O(1)@ time and @O(1)@ space. +-} +periodOf :: Graph -> Int -> Maybe Natural +periodOf graph vertex + | vertex < 0 || vertex >= graphDim graph = + error "Dtmc.Transition.Matrix.Internal.Graph.periodOf: vertex out of bounds" + | otherwise = graphPeriodOf graph Array.! vertex + +{- | Return the phase of a vertex within its strongly connected component: its +BFS level from the component's least vertex, modulo the component's period +@d@. Every edge @u -> v@ /internal to a component/ satisfies +@phaseOf v == (phaseOf u + 1) `mod` d@. Therefore, grouping a component's +vertices by phase yields its cyclic classes. An edge leaving a component +relates two independent phasings and carries no such relation. A component of +period @d@ has phases in @{0 .. d-1}@; a vertex whose component has no cycles +has phase @0@. + +Complexity: the first query takes @O((V + E) log V)@ time and @O(V)@ cache +space; subsequent queries take @O(1)@ time and @O(1)@ space. +-} +phaseOf :: Graph -> Int -> Int +phaseOf graph vertex + | vertex < 0 || vertex >= graphDim graph = + error "Dtmc.Transition.Matrix.Internal.Graph.phaseOf: vertex out of bounds" + | otherwise = graphPhaseOf graph Unboxed.! vertex + +-- The sole caller supplies strongly connected components, but retain a +-- defensive fallback for an incomplete BFS: avoid missing-level lookups and +-- assign no period and phase 0. Otherwise one BFS supplies both cached tables. +componentPhasing :: DG.Graph -> [Int] -> (Maybe Natural, [(Int, Int)]) +componentPhasing _ [] = (Nothing, []) +componentPhasing successors component@(root : _) + | not reachedAll = (Nothing, [(vertex, 0) | vertex <- component]) + | period == 0 = (Nothing, [(vertex, 0) | vertex <- component]) + | otherwise = + ( Just (fromIntegral period) + , [(vertex, (levels IntMap.! vertex) `mod` period) | vertex <- component] + ) + where + member = IntSet.fromList component + levels = bfsLevels successors member root + reachedAll = IntMap.size levels == IntSet.size member + + period = + List.foldl' accumulateVertex 0 (IntSet.toList member) + + accumulateVertex currentGcd from = + List.foldl' + (accumulateEdge (levels IntMap.! from)) + currentGcd + (successors Array.! from) + + accumulateEdge fromLevel currentGcd to + | not (IntSet.member to member) = currentGcd + | otherwise = + gcd currentGcd (abs (fromLevel + 1 - levels IntMap.! to)) + +-- Breadth-first levels within one component. Vertices are inserted into the +-- level map when enqueued, so each is enqueued exactly once. +bfsLevels :: DG.Graph -> IntSet.IntSet -> Int -> IntMap.IntMap Int +bfsLevels successors member root = + search (Sequence.singleton root) (IntMap.singleton root 0) + where + search queue levels = + case Sequence.viewl queue of + Sequence.EmptyL -> levels + from Sequence.:< rest -> + search queue' levels' + where + fromLevel = levels IntMap.! from + (queue', levels') = + List.foldl' + (discover fromLevel) + (rest, levels) + (successors Array.! from) + + discover fromLevel state@(queue, levels) candidate + | not (IntSet.member candidate member) = state + | IntMap.member candidate levels = state + | otherwise = + ( queue Sequence.|> candidate + , IntMap.insert candidate (fromLevel + 1) levels + ) diff --git a/test/Dtmc/Analysis/AbsorptionSpec.hs b/test/Dtmc/Analysis/AbsorptionSpec.hs new file mode 100644 --- /dev/null +++ b/test/Dtmc/Analysis/AbsorptionSpec.hs @@ -0,0 +1,167 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TypeApplications #-} + +module Dtmc.Analysis.AbsorptionSpec ( + spec, +) where + +import Data.Finite ( + Finite, + ) +import Dtmc.Analysis.Absorption qualified as Absorption +import Dtmc.Analysis.Classification ( + recurrentStates, + transientStates, + ) +import Dtmc.Analysis.Expectation qualified as E +import Dtmc.Analysis.HittingTime qualified as Hitting +import Dtmc.State ( + FiniteState, + ) +import Dtmc.TestSupport +import Dtmc.Transition.Matrix ( + TransitionMatrix, + TransitionMatrixError, + fromRows, + ) +import GHC.Generics ( + Generic, + ) +import Test.Hspec +import Test.Hspec.QuickCheck ( + prop, + ) +import Test.QuickCheck + +-- The chain of the "transient class {A,B}, recurrent class {C,D}" example in +-- section 3.7 of the notes, which states G, eta and the hit-before +-- probabilities in closed form. +data Four = A | B | C | D + deriving (Eq, Ord, Show, Generic, FiniteState) + +chain :: TransitionMatrix Four +chain = + either (error . show) id $ + fromRows + ( chunksOf + 4 + [ 0 + , 1 / 3 + , 2 / 3 + , 0 + , 1 / 2 + , 0 + , 1 / 8 + , 3 / 8 + , 0 + , 0 + , 1 / 2 + , 1 / 2 + , 0 + , 0 + , 3 / 4 + , 1 / 4 + ] + ) + +-- Two states in one recurrent class: no transient states at all. +twoCycle :: TransitionMatrix Bool +twoCycle = + either (error . show) id $ + fromRows (chunksOf 2 [0, 1, 1, 0]) + +closeTo :: Double -> Double -> Bool +closeTo expected actual = approxEq testTolerance expected actual + +finiteCloseTo :: Double -> E.Expectation -> Bool +finiteCloseTo expected (E.FiniteExpectation x) = closeTo expected x +finiteCloseTo _ E.InfiniteExpectation = False + +rightCloseTo :: Double -> Either err Double -> Bool +rightCloseTo expected (Right actual) = closeTo expected actual +rightCloseTo _ (Left _) = False + +spec :: Spec +spec = do + describe "canonicalOrder" $ + it "splits the example chain into {A,B} and {C,D}" $ + Absorption.canonicalOrder chain `shouldBe` ([A, B], [C, D]) + + describe "fundamentalMatrix" $ do + it "indexes rows and columns by the transient states" $ + fmap fst (Absorption.fundamentalMatrix chain) `shouldBe` Right [A, B] + + it "matches the closed form of the notes" $ + case Absorption.fundamentalMatrix chain of + Left err -> expectationFailure ("solve failed: " <> show err) + Right (_, rows) -> + concat rows + `shouldSatisfy` ( and + . zipWith closeTo [6 / 5, 2 / 5, 3 / 5, 6 / 5] + ) + + it "returns an empty block when no state is transient" $ + Absorption.fundamentalMatrix twoCycle `shouldBe` Right ([], []) + + describe "probability" $ do + it "reproduces the hit-before probabilities of the notes" $ do + Absorption.probabilityGivenInitialState chain C A `shouldSatisfy` rightCloseTo (17 / 20) + Absorption.probabilityGivenInitialState chain D A `shouldSatisfy` rightCloseTo (3 / 20) + Absorption.probabilityGivenInitialState chain C B `shouldSatisfy` rightCloseTo (11 / 20) + Absorption.probabilityGivenInitialState chain D B `shouldSatisfy` rightCloseTo (9 / 20) + + it "is exact at a recurrent starting state" $ do + Absorption.probabilityGivenInitialState chain C C `shouldBe` Right 1 + Absorption.probabilityGivenInitialState chain D C `shouldBe` Right 0 + + it "is exactly zero for a transient target" $ + Absorption.probabilityGivenInitialState chain A B `shouldBe` Right 0 + + it "differs from ever hitting the same state" $ do + -- The chain reaches C almost surely, but it enters {C,D} at D + -- with probability 3/20, so B(A,C) is strictly smaller. + Hitting.eventualProbabilityGivenInitialState chain [C] A `shouldSatisfy` rightCloseTo 1 + Absorption.probabilityGivenInitialState chain C A `shouldSatisfy` rightCloseTo (17 / 20) + + it "agrees with eventual hitting after summing over the class" $ + case (Absorption.probabilityGivenInitialState chain C A, Absorption.probabilityGivenInitialState chain D A) of + (Right toC, Right toD) -> + Hitting.eventualProbabilityGivenInitialState chain [C, D] A + `shouldSatisfy` rightCloseTo (toC + toD) + other -> expectationFailure ("solve failed: " <> show other) + + describe "expectationByState" $ do + it "matches the closed form of the notes" $ + case absorptionExpectationByState chain of + Left err -> expectationFailure ("solve failed: " <> show err) + Right values -> + values + `shouldSatisfy` ( and + . zipWith finiteCloseTo [8 / 5, 9 / 5, 0, 0] + ) + + it "equals the expected hitting time of the recurrent set" $ + absorptionExpectationByState chain + `shouldBe` hitExpectationByState chain [C, D] + + describe "absorption probabilities" $ + prop "sum to one from every transient state" $ + forAll (genTransitionRows 3) $ \m -> + case fromRows m :: + Either TransitionMatrixError (TransitionMatrix (Finite 3)) of + Left err -> + counterexample ("generated matrix rejected: " <> show err) False + Right p -> + conjoin + [ case traverse (\k -> Absorption.probabilityGivenInitialState p k i) (recurrentStates p) of + -- A refused solve is a documented outcome, not a + -- violated law. + Left _ -> property True + Right ps -> + counterexample + ("from " <> show i <> ": " <> show ps) + (approxEq 1e-9 1 (sum ps)) + | i <- transientStates p + ] diff --git a/test/Dtmc/Analysis/CanonicalDifferentialSpec.hs b/test/Dtmc/Analysis/CanonicalDifferentialSpec.hs new file mode 100644 --- /dev/null +++ b/test/Dtmc/Analysis/CanonicalDifferentialSpec.hs @@ -0,0 +1,377 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeApplications #-} + +module Dtmc.Analysis.CanonicalDifferentialSpec ( + spec, +) where + +import Data.Finite ( + Finite, + finites, + ) +import Data.Maybe ( + fromMaybe, + ) +import Dtmc.Analysis.Event ( + DiscreteEvent (..), + ) +import Dtmc.Analysis.Expectation ( + Expectation (..), + ) +import Dtmc.Analysis.FiniteTime qualified as FT +import Dtmc.Analysis.HittingTime qualified as Hit +import Dtmc.Analysis.ProbabilityOracle qualified as Oracle +import Dtmc.Analysis.ReturnTime qualified as Return +import Dtmc.Analysis.VisitCount qualified as Visit +import Dtmc.Distribution ( + probabilityAt, + ) +import Dtmc.Distribution.Vector ( + DistributionVector, + ) +import Dtmc.Distribution.Vector qualified as Vector +import Dtmc.TestSupport +import Dtmc.Transition.Matrix ( + TransitionMatrix, + TransitionMatrixError, + fromRows, + ) +import Test.Hspec ( + Spec, + describe, + it, + ) +import Test.Hspec.QuickCheck ( + prop, + ) +import Test.QuickCheck ( + counterexample, + forAll, + property, + ) + +initialWeights :: [(Finite 3, Double)] +initialWeights = zip finites [0.2, 0.3, 0.5] + +initialDistribution :: DistributionVector (Finite 3) +initialDistribution = + checked (Vector.fromList [0.2, 0.3, 0.5]) + +terminalChain :: TransitionMatrix (Finite 3) +terminalChain = + checked + ( fromRows + ( chunksOf + 3 + [ 0 + , 0.5 + , 0.5 + , 0 + , 0 + , 1 + , 0 + , 0 + , 1 + ] + ) + ) + +checked :: (Show error) => Either error value -> value +checked = either (error . show) id + +known :: Maybe Double -> Double +known = fromMaybe (error "oracle horizon does not determine this event") + +close :: Double -> Double -> Bool +close = approxEq testTolerance + +rightClose :: Double -> Either error Double -> Bool +rightClose expected = either (const False) (close expected) + +expectationClose :: Maybe Double -> Expectation -> Bool +expectationClose Nothing InfiniteExpectation = True +expectationClose (Just expected) (FiniteExpectation actual) = close expected actual +expectationClose _ _ = False + +finiteAndBoundedChecks :: TransitionMatrix (Finite 3) -> Bool +finiteAndBoundedChecks matrix = + and + [ transitionChecks + , trajectoryChecks + , observationChecks + , hittingChecks + , returnChecks + , visitChecks + ] + where + target state = state == (2 :: Finite 3) + transitionChecks = + and + [ close + (FT.stepProbability matrix source destination) + (Oracle.transitionWeight matrix source destination) + | source <- finites + , destination <- finites + ] + && and + [ close + (FT.nStepProbability time matrix source destination) + (Oracle.stateProbability time [(source, 1)] matrix destination) + | time <- [0 .. 4] + , source <- finites + , destination <- finites + ] + && and + [ close + (FT.probability initialDistribution matrix [FT.At time destination]) + (Oracle.stateProbability time initialWeights matrix destination) + | time <- [0 .. 4] + , destination <- finites + ] + trajectoryChecks = + close + ( FT.probability + initialDistribution + matrix + [FT.At 0 0, FT.At 1 1, FT.At 2 2] + ) + (Oracle.trajectoryProbability initialWeights matrix [0, 1, 2]) + observations = [(1, 1), (3, 2)] + oracleJoint = + Oracle.observationProbability 3 initialWeights matrix observations + observationChecks = + close + (FT.probability initialDistribution matrix [FT.At 1 1, FT.At 3 2]) + oracleJoint + && conditionalChecks + conditionalChecks = + let denominator = + Oracle.observationProbability 1 initialWeights matrix [(1, 1)] + numerator = oracleJoint + actual = + FT.probabilityGiven + initialDistribution + matrix + [FT.At 3 2] + [FT.At 1 1] + in if denominator == 0 + then actual == Left FT.ZeroProbabilityCondition + else either (const False) (close (numerator / denominator)) actual + hittingChecks = + and + [ let law = Oracle.hittingLaw 4 matrix target source + exact = known (Oracle.lawProbability (EqualTo time) law) + dense = (hitProbabilityByState (EqualTo time) matrix [2]) + in close (Hit.probabilityGivenInitialState (EqualTo time) matrix target source) exact + && close (dense !! fromIntegral source) exact + | source <- finites + , time <- [0 .. 4] + ] + && and + [ let law = Oracle.hittingLaw 4 matrix target source + bounded = known (Oracle.lawProbability (LessThan bound) law) + dense = (hitProbabilityByState (LessThan bound) matrix [2]) + in close + (Hit.probabilityGivenInitialState (LessThan bound) matrix target source) + bounded + && close (dense !! fromIntegral source) bounded + | source <- finites + , bound <- [0 .. 5] + ] + returnChecks = + and + [ let law = Oracle.returnLaw 4 matrix source + exact = known (Oracle.lawProbability (EqualTo time) law) + dense = (returnProbabilityByState (EqualTo time) matrix) + in close (Return.probabilityGivenInitialState (EqualTo time) matrix source) exact + && close (dense !! fromIntegral source) exact + | source <- finites + , time <- [0 .. 4] + ] + && and + [ let law = Oracle.returnLaw 4 matrix source + bounded = known (Oracle.lawProbability (LessThan bound) law) + dense = (returnProbabilityByState (LessThan bound) matrix) + in close + (Return.probabilityGivenInitialState (LessThan bound) matrix source) + bounded + && close (dense !! fromIntegral source) bounded + | source <- finites + , bound <- [0 .. 5] + ] + visitChecks = + and + [ let law = + Oracle.visitLawBefore + bound + initialWeights + matrix + target + distribution = + Visit.boundedLaw + bound + initialDistribution + matrix + target + expected = known (Oracle.lawFiniteExpectation law) + in and + [ close + (probabilityAt distribution count) + (known (Oracle.lawProbability (EqualTo count) law)) + && close + ( Visit.boundedProbability + bound + (EqualTo count) + initialDistribution + matrix + target + ) + (known (Oracle.lawProbability (EqualTo count) law)) + | count <- [0 .. bound] + ] + && close + ( Visit.boundedExpectation + bound + initialDistribution + matrix + target + ) + expected + | bound <- [0 .. 4] + ] + +terminalChecks :: Bool +terminalChecks = + and + [ hittingEventualChecks + , hittingRaceChecks + , hittingExpectationChecks + , returnEventualChecks + , returnExpectationChecks + , totalVisitChecks + ] + where + states = finites :: [Finite 3] + target state = state == (1 :: Finite 3) + competing state = state == (2 :: Finite 3) + hitLaws = [Oracle.hittingLaw 1 terminalChain target state | state <- states] + returnLaws = [Oracle.returnLaw 1 terminalChain state | state <- states] + eventual law = 1 - Oracle.lawUnresolvedMass law + hitValues = map eventual hitLaws + returnValues = map eventual returnLaws + hittingEventualChecks = + case hitEventualProbabilityByState terminalChain [1] of + Left _ -> False + Right dense -> + and (zipWith close (dense) hitValues) + && and + [ rightClose expected (Hit.eventualProbabilityGivenInitialState terminalChain [1] state) + | (state, expected) <- zip states hitValues + ] + raceValues = + [ Oracle.raceProbabilityWithin + 1 + terminalChain + target + competing + state + | state <- states + ] + hittingRaceChecks = + case hitRaceProbabilityByState terminalChain [1] [2] of + Left _ -> False + Right dense -> + and (zipWith close (dense) raceValues) + && and + [ rightClose + expected + (Hit.raceProbabilityGivenInitialState terminalChain [1] [2] state) + | (state, expected) <- zip states raceValues + ] + hitExpectations = map Oracle.lawFiniteExpectation hitLaws + hittingExpectationChecks = + case hitExpectationByState terminalChain [1] of + Left _ -> False + Right actual -> + and (zipWith expectationClose hitExpectations actual) + && and + [ either + (const False) + (expectationClose expected) + (Hit.expectationGivenInitialState terminalChain [1] state) + | (state, expected) <- zip states hitExpectations + ] + returnEventualChecks = + case returnEventualProbabilityByState terminalChain of + Left _ -> False + Right dense -> + and (zipWith close (dense) returnValues) + && and + [ rightClose expected (Return.eventualProbabilityGivenInitialState terminalChain state) + | (state, expected) <- zip states returnValues + ] + returnExpectations = map Oracle.lawFiniteExpectation returnLaws + returnExpectationChecks = + case returnExpectationByState terminalChain of + Left _ -> False + Right actual -> + and (zipWith expectationClose returnExpectations actual) + && and + [ either + (const False) + (expectationClose expected) + (Return.expectationGivenInitialState terminalChain state) + | (state, expected) <- zip states returnExpectations + ] + visitLaws = + [ Oracle.visitLawBefore 2 [(state, 1)] terminalChain target + | state <- states + ] + visitExpectations = map Oracle.lawFiniteExpectation visitLaws + totalVisitChecks = + and + [ case visitTotalProbabilityByState (EqualTo count) terminalChain 1 of + Left _ -> False + Right dense -> + and + [ let expected = known (Oracle.lawProbability (EqualTo count) law) + in close (dense !! fromIntegral state) expected + && rightClose + expected + (Visit.totalProbabilityGivenInitialState (EqualTo count) terminalChain 1 state) + | (state, law) <- zip states visitLaws + ] + | count <- [0 .. 2] + ] + && case visitInfiniteProbabilityByState terminalChain 1 of + Left _ -> False + Right dense -> + dense == [0, 0, 0] + && all + (rightClose 0 . Visit.infiniteProbabilityGivenInitialState terminalChain 1) + states + && case visitTotalExpectationByState terminalChain 1 of + Left _ -> False + Right actual -> + and (zipWith expectationClose visitExpectations actual) + && and + [ either + (const False) + (expectationClose expected) + (Visit.totalExpectationGivenInitialState terminalChain 1 state) + | (state, expected) <- zip states visitExpectations + ] + +spec :: Spec +spec = do + describe "canonical finite-horizon differential baseline" $ do + prop "all finite and bounded queries match path enumeration (random @3)" $ + forAll (genTransitionRows 3) $ \rawMatrix -> + case fromRows rawMatrix :: + Either TransitionMatrixError (TransitionMatrix (Finite 3)) of + Left problem -> counterexample (show problem) False + Right matrix -> property (finiteAndBoundedChecks matrix) + + describe "canonical infinite-horizon differential baseline" $ do + it "all eventual, race, expectation, and total-visit queries match a completed path law" $ + terminalChecks diff --git a/test/Dtmc/Analysis/ClassificationSpec.hs b/test/Dtmc/Analysis/ClassificationSpec.hs new file mode 100644 --- /dev/null +++ b/test/Dtmc/Analysis/ClassificationSpec.hs @@ -0,0 +1,603 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module Dtmc.Analysis.ClassificationSpec ( + spec, +) where + +import Data.Finite ( + Finite, + finites, + getFinite, + ) +import Data.List ( + sort, + ) +import Dtmc.Analysis.Classification ( + CommClass (..), + absorbingStates, + accessible, + aperiodic, + chainPeriod, + communicates, + communicatingClasses, + cyclicClasses, + ergodic, + irreducible, + period, + reachesAny, + recurrentState, + recurrentStates, + supportEdge, + transientState, + transientStates, + ) +import Dtmc.State ( + FiniteState, + ) +import Dtmc.TestSupport ( + chunksOf, + genTransitionRows, + ) +import Dtmc.Transition.Matrix ( + TransitionMatrix, + TransitionMatrixError, + fromRows, + toRows, + ) +import GHC.Generics ( + Generic, + ) +import GHC.TypeNats ( + KnownNat, + ) +import Numeric.Natural (Natural) +import Test.Hspec ( + Spec, + describe, + it, + shouldBe, + ) +import Test.Hspec.QuickCheck ( + prop, + ) +import Test.QuickCheck ( + Property, + conjoin, + counterexample, + forAll, + property, + (===), + ) + +data NamedClassState = ClassA | ClassB | ClassC + deriving (Eq, Ord, Show, Generic) + +instance FiniteState NamedClassState + +checked :: (Show e) => Either e a -> a +checked = either (error . show) id + +threeCycle :: TransitionMatrix (Finite 3) +threeCycle = + checked $ + fromRows + ( chunksOf + 3 + [ 0 + , 1 + , 0 + , 0 + , 0 + , 1 + , 1 + , 0 + , 0 + ] + ) + +namedThreeCycle :: TransitionMatrix NamedClassState +namedThreeCycle = + checked $ + fromRows @NamedClassState + (chunksOf 3 [0, 1, 0, 0, 0, 1, 1, 0, 0]) + +selfLoopTwo :: TransitionMatrix (Finite 2) +selfLoopTwo = + checked $ + fromRows + ( chunksOf + 2 + [ 0.5 + , 0.5 + , 1.0 + , 0.0 + ] + ) + +bipartiteTwo :: TransitionMatrix (Finite 2) +bipartiteTwo = + checked $ + fromRows + ( chunksOf + 2 + [ 0 + , 1 + , 1 + , 0 + ] + ) + +sevenState :: TransitionMatrix (Finite 7) +sevenState = + checked $ + fromRows + ( chunksOf + 7 + [ 0 + , 1 + , 0 + , 0 + , 0 + , 0 + , 0 + , 1 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0.4 + , 0 + , 0.6 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0.3 + , 0 + , 0.7 + , 0 + , 0 + , 0 + , 0 + , 0.3 + , 0.4 + , 0 + , 0.3 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0.2 + , 0 + , 0.8 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 1 + ] + ) + +identityThree :: TransitionMatrix (Finite 3) +identityThree = + checked $ + fromRows + ( chunksOf + 3 + [ 1 + , 0 + , 0 + , 0 + , 1 + , 0 + , 0 + , 0 + , 1 + ] + ) + +-- Exercise 3.2.2: irreducible, period 2, cyclic classes {A,B} and {C,D}. +fourStateCyclic :: TransitionMatrix (Finite 4) +fourStateCyclic = + checked $ + fromRows + ( chunksOf + 4 + [ 0 + , 0 + , 1 + , 0 + , 0 + , 0 + , 0 + , 1 + , 0.5 + , 0.5 + , 0 + , 0 + , 1 + , 0 + , 0 + , 0 + ] + ) + +matrixSupport :: TransitionMatrix (Finite n) -> [[Bool]] +matrixSupport = map (map (> 0)) . toRows + +boolMul :: [[Bool]] -> [[Bool]] -> [[Bool]] +boolMul a b = + [ [or [ai && (b !! k !! j) | (k, ai) <- zip [0 ..] row] | j <- idxs] + | row <- a + ] + where + idxs = [0 .. length a - 1] + +boolIdentity :: Int -> [[Bool]] +boolIdentity dim = [[i == j | j <- [0 .. dim - 1]] | i <- [0 .. dim - 1]] + +referencePeriod :: [[Bool]] -> Int -> Maybe Natural +referencePeriod s i = + case returns of + [] -> Nothing + _ -> Just (fromIntegral (foldr1 gcd returns)) + where + dim = length s + bound = 4 * dim * dim + 1 + powers = take bound (drop 1 (iterate (boolMul s) (boolIdentity dim))) + returns = [k | (k, m) <- zip [1 :: Int ..] powers, (m !! i) !! i] + +classesAsInts :: (KnownNat n) => TransitionMatrix (Finite n) -> [[Integer]] +classesAsInts = map (map getFinite . classMembers) . communicatingClasses + +cyclicClassesAsInts :: (KnownNat n) => TransitionMatrix (Finite n) -> Maybe [[Integer]] +cyclicClassesAsInts = fmap (map (map getFinite)) . cyclicClasses + +sortUnique :: (Ord a) => [a] -> [a] +sortUnique = foldr insert [] + where + insert x [] = [x] + insert x (y : ys) + | x < y = x : y : ys + | x == y = y : ys + | otherwise = y : insert x ys + +periodMatchesReference :: (KnownNat n) => TransitionMatrix (Finite n) -> [Finite n] -> Property +periodMatchesReference p states = + conjoin + [ period p i === referencePeriod s (fromIntegral (getFinite i)) + | i <- states + ] + where + s = matrixSupport p + +spec :: Spec +spec = do + describe "communication is an equivalence relation" $ do + prop "is reflexive, symmetric, and transitive on random support graphs" $ + forAll (genTransitionRows 4) $ \matrix -> + case fromRows matrix :: + Either TransitionMatrixError (TransitionMatrix (Finite 4)) of + Right p -> + let states = finites :: [Finite 4] + in conjoin + [ conjoin + [ counterexample "reflexivity" (communicates p i i) + | i <- states + ] + , conjoin + [ counterexample "symmetry" $ + communicates p i j === communicates p j i + | i <- states + , j <- states + ] + , conjoin + [ counterexample "transitivity" $ + not (communicates p i j && communicates p j k) + || communicates p i k + | i <- states + , j <- states + , k <- states + ] + ] + Left err -> + counterexample ("generated matrix was rejected: " <> show err) False + + prop "accessibility is reflexive" $ + forAll (genTransitionRows 4) $ \matrix -> + case fromRows matrix :: + Either TransitionMatrixError (TransitionMatrix (Finite 4)) of + Right p -> + conjoin + [ property (accessible p i i) + | i <- finites :: [Finite 4] + ] + Left err -> + counterexample ("generated matrix was rejected: " <> show err) False + + describe "reachesAny" $ do + it "finds a reachable target" $ + reachesAny threeCycle 0 [2] `shouldBe` True + + it "returns false for an empty target set" $ + reachesAny threeCycle 0 [] `shouldBe` False + + it "uses zero-step reachability" $ + reachesAny identityThree 1 [1] `shouldBe` True + + describe "period" $ do + it "is 3 for every state of the three-cycle" $ + map (period threeCycle) (finites :: [Finite 3]) + `shouldBe` [Just 3, Just 3, Just 3] + + it "is 1 for the self-loop chain (aperiodic)" $ do + map (period selfLoopTwo) (finites :: [Finite 2]) + `shouldBe` [Just 1, Just 1] + aperiodic selfLoopTwo `shouldBe` True + + it "is 2 for the bipartite swap (periodic)" $ do + map (period bipartiteTwo) (finites :: [Finite 2]) + `shouldBe` [Just 2, Just 2] + aperiodic bipartiteTwo `shouldBe` False + + it "matches the hand-computed periods of the seven-state chain" $ + map (period sevenState) (finites :: [Finite 7]) + `shouldBe` [Just 2, Just 2, Just 1, Just 1, Just 1, Just 1, Just 1] + + prop "agrees with the gcd of return-time lengths (random @4)" $ + forAll (genTransitionRows 4) $ \matrix -> + case fromRows matrix :: + Either TransitionMatrixError (TransitionMatrix (Finite 4)) of + Right p -> periodMatchesReference p (finites :: [Finite 4]) + Left err -> + counterexample ("generated matrix was rejected: " <> show err) False + + prop "agrees with the gcd of return-time lengths (random @3)" $ + forAll (genTransitionRows 3) $ \matrix -> + case fromRows matrix :: + Either TransitionMatrixError (TransitionMatrix (Finite 3)) of + Right p -> periodMatchesReference p (finites :: [Finite 3]) + Left err -> + counterexample ("generated matrix was rejected: " <> show err) False + + describe "communicatingClasses" $ do + it "splits the seven-state chain into {A,B}, {C,D,E,F}, {G}" $ + classesAsInts sevenState `shouldBe` [[0, 1], [2, 3, 4, 5], [6]] + + it "returns a single class for the irreducible three-cycle" $ + classesAsInts threeCycle `shouldBe` [[0, 1, 2]] + + prop "the classes partition the state space (random @4)" $ + forAll (genTransitionRows 4) $ \matrix -> + case fromRows matrix :: + Either TransitionMatrixError (TransitionMatrix (Finite 4)) of + Right p -> + property (sortUnique (concat (classesAsInts p)) == [0 .. 3]) + Left err -> + counterexample ("generated matrix was rejected: " <> show err) False + + prop "communication agrees with the class partition (random @4)" $ + forAll (genTransitionRows 4) $ \matrix -> + case fromRows matrix :: + Either TransitionMatrixError (TransitionMatrix (Finite 4)) of + Right p -> + let states = finites :: [Finite 4] + classIx = map classMembers (communicatingClasses p) + sameClass i j = or [i `elem` c && j `elem` c | c <- classIx] + in conjoin + [ counterexample (show (i, j)) $ + communicates p i j === sameClass i j + | i <- states + , j <- states + ] + Left err -> + counterexample ("generated matrix was rejected: " <> show err) False + + describe "cyclicClasses" $ do + it "splits the period-2 four-state chain into {A,B} and {C,D}" $ + cyclicClassesAsInts fourStateCyclic `shouldBe` Just [[0, 1], [2, 3]] + + it "splits the three-cycle into three singletons" $ + cyclicClassesAsInts threeCycle `shouldBe` Just [[0], [1], [2]] + + it "is Nothing for the reducible seven-state chain" $ + cyclicClassesAsInts sevenState `shouldBe` Nothing + + prop "classes partition the states and advance one step (random @4)" $ + forAll (genTransitionRows 4) $ \matrix -> + case fromRows matrix :: + Either TransitionMatrixError (TransitionMatrix (Finite 4)) of + Right p -> + case cyclicClasses p of + Nothing -> property True + Just cs -> + let d = length cs + states = finites :: [Finite 4] + in conjoin + [ counterexample "partition" (sort (concat cs) === states) + , conjoin + [ counterexample (show (i, j)) $ + property (j `elem` (cs !! ((r + 1) `mod` d))) + | (r, c) <- zip [0 ..] cs + , i <- c + , j <- states + , supportEdge p i j + ] + ] + Left err -> + counterexample ("generated matrix was rejected: " <> show err) False + + describe "irreducible" $ do + it "holds for the three-cycle and swap, fails for the seven-state chain" $ do + irreducible threeCycle `shouldBe` True + irreducible bipartiteTwo `shouldBe` True + irreducible sevenState `shouldBe` False + + describe "communicatingClasses details" $ do + it "records members, periods, and closedness for the seven-state chain" $ do + let cs = communicatingClasses sevenState + map (map getFinite . classMembers) cs + `shouldBe` [[0, 1], [2, 3, 4, 5], [6]] + map classPeriod cs `shouldBe` [Just 2, Just 1, Just 1] + map classClosed cs `shouldBe` [True, False, True] + + describe "absorbingStates" $ do + it "finds the absorbing states" $ do + map getFinite (absorbingStates sevenState) `shouldBe` [6] + map getFinite (absorbingStates identityThree) `shouldBe` [0, 1, 2] + map getFinite (absorbingStates threeCycle) `shouldBe` [] + + prop "absorbing states have only a self-loop (random @4)" $ + forAll (genTransitionRows 4) $ \matrix -> + case fromRows matrix :: + Either TransitionMatrixError (TransitionMatrix (Finite 4)) of + Right p -> + conjoin + [ counterexample (show i) $ + [j | j <- finites :: [Finite 4], supportEdge p i j] === [i] + | i <- absorbingStates p + ] + Left err -> + counterexample ("generated matrix was rejected: " <> show err) False + + describe "whole-chain queries agree with the class summaries" $ do + -- These are not restatements of one definition: the left-hand sides + -- reach the support graph through G.components and G.componentPeriod, + -- the right-hand sides through G.periodOf and per-class closedness. + prop "on random @4 chains" $ + forAll (genTransitionRows 4) $ \matrix -> + case fromRows matrix :: + Either TransitionMatrixError (TransitionMatrix (Finite 4)) of + Right p -> + let cs = communicatingClasses p + closed = filter classClosed cs + open = filter (not . classClosed) cs + in conjoin + [ counterexample "irreducible" $ + irreducible p === (length cs == 1) + , counterexample "aperiodic" $ + aperiodic p + === (not (null cs) && all ((== Just 1) . classPeriod) cs) + , counterexample "ergodic" $ + ergodic p === (irreducible p && aperiodic p) + , counterexample "recurrentStates" $ + recurrentStates p + === concatMap classMembers closed + , counterexample "transientStates" $ + transientStates p + === concatMap classMembers open + , counterexample "chainPeriod" $ + chainPeriod p + === case cs of + [singleClass] -> classPeriod singleClass + _ -> Nothing + ] + Left err -> + counterexample ("generated matrix was rejected: " <> show err) False + + prop "chainPeriod is the shared period of an irreducible chain (random @4)" $ + forAll (genTransitionRows 4) $ \matrix -> + case fromRows matrix :: + Either TransitionMatrixError (TransitionMatrix (Finite 4)) of + Right p + | irreducible p -> + conjoin + [ counterexample (show i) (chainPeriod p === period p i) + | i <- finites :: [Finite 4] + ] + | otherwise -> property True + Left err -> + counterexample ("generated matrix was rejected: " <> show err) False + + describe "recurrence and transience" $ do + it "matches the closed classes of the seven-state chain" $ do + map getFinite (recurrentStates sevenState) `shouldBe` [0, 1, 6] + map getFinite (transientStates sevenState) `shouldBe` [2, 3, 4, 5] + + it "marks every state of the irreducible three-cycle recurrent" $ do + map getFinite (recurrentStates threeCycle) `shouldBe` [0, 1, 2] + transientStates threeCycle `shouldBe` [] + + it "marks every state of the identity chain recurrent" $ do + map getFinite (recurrentStates identityThree) `shouldBe` [0, 1, 2] + transientStates identityThree `shouldBe` [] + + prop "recurrent and transient states partition the state space (random @4)" $ + forAll (genTransitionRows 4) $ \matrix -> + case fromRows matrix :: + Either TransitionMatrixError (TransitionMatrix (Finite 4)) of + Right p -> + sort + ( map getFinite (recurrentStates p) + <> map getFinite (transientStates p) + ) + === [0 .. 3] + Left err -> + counterexample ("generated matrix was rejected: " <> show err) False + + prop "every finite chain has a recurrent state (random @4)" $ + forAll (genTransitionRows 4) $ \matrix -> + case fromRows matrix :: + Either TransitionMatrixError (TransitionMatrix (Finite 4)) of + Right p -> + property (not (null (recurrentStates p))) + Left err -> + counterexample ("generated matrix was rejected: " <> show err) False + + prop "transient iff some reachable state cannot reach back (random @4)" $ + forAll (genTransitionRows 4) $ \matrix -> + case fromRows matrix :: + Either TransitionMatrixError (TransitionMatrix (Finite 4)) of + Right p -> + let states = finites :: [Finite 4] + in conjoin + [ transientState p i + === or + [ accessible p i j && not (accessible p j i) + | j <- states + ] + | i <- states + ] + Left err -> + counterexample ("generated matrix was rejected: " <> show err) False + + prop "predicates agree with the state lists (random @4)" $ + forAll (genTransitionRows 4) $ \matrix -> + case fromRows matrix :: + Either TransitionMatrixError (TransitionMatrix (Finite 4)) of + Right p -> + let states = finites :: [Finite 4] + in conjoin + [ recurrentState p i === (i `elem` recurrentStates p) + | i <- states + ] + Left err -> + counterexample ("generated matrix was rejected: " <> show err) False + + describe "named finite states" $ do + it "reports communication and periods with named constructors" $ do + map classMembers (communicatingClasses namedThreeCycle) + `shouldBe` [[ClassA, ClassB, ClassC]] + map (period namedThreeCycle) [ClassA, ClassB, ClassC] + `shouldBe` replicate 3 (Just 3) + + it "returns named recurrent states in canonical order" $ + recurrentStates namedThreeCycle + `shouldBe` [ClassA, ClassB, ClassC] + + it "answers whole-chain queries with named constructors" $ do + map classMembers (communicatingClasses namedThreeCycle) + `shouldBe` [[ClassA, ClassB, ClassC]] + recurrentStates namedThreeCycle `shouldBe` [ClassA, ClassB, ClassC] + absorbingStates namedThreeCycle `shouldBe` [] + chainPeriod namedThreeCycle `shouldBe` Just 3 + ergodic namedThreeCycle `shouldBe` False diff --git a/test/Dtmc/Analysis/EventSpec.hs b/test/Dtmc/Analysis/EventSpec.hs new file mode 100644 --- /dev/null +++ b/test/Dtmc/Analysis/EventSpec.hs @@ -0,0 +1,97 @@ +module Dtmc.Analysis.EventSpec ( + spec, +) where + +import Dtmc.Analysis.Event ( + DiscreteEvent (..), + includesInfiniteOutcome, + matches, + ) +import Numeric.Natural ( + Natural, + ) +import Test.Hspec ( + Spec, + describe, + it, + shouldBe, + ) +import Test.Hspec.QuickCheck ( + prop, + ) +import Test.QuickCheck ( + NonNegative (..), + property, + ) + +asNatural :: NonNegative Integer -> Natural +asNatural (NonNegative value) = fromInteger value + +spec :: Spec +spec = do + describe "matches" $ do + it "implements every comparison at and around its threshold" $ do + let values = [2, 3, 4] + map (matches (EqualTo 3)) values + `shouldBe` [False, True, False] + map (matches (LessThan 3)) values + `shouldBe` [True, False, False] + map (matches (AtMost 3)) values + `shouldBe` [True, True, False] + map (matches (GreaterThan 3)) values + `shouldBe` [False, False, True] + map (matches (AtLeast 3)) values + `shouldBe` [False, True, True] + + it "has the structural zero-threshold boundaries" $ do + matches (LessThan 0) 0 `shouldBe` False + matches (AtMost 0) 0 `shouldBe` True + matches (GreaterThan 0) 0 `shouldBe` False + matches (AtLeast 0) 0 `shouldBe` True + + prop "AtMost n is LessThan (n + 1)" $ \rawThreshold rawValue -> + let threshold = asNatural rawThreshold + value = asNatural rawValue + in matches (AtMost threshold) value + == matches (LessThan (threshold + 1)) value + + prop "AtLeast (n + 1) is GreaterThan n" $ \rawThreshold rawValue -> + let threshold = asNatural rawThreshold + value = asNatural rawValue + in matches (AtLeast (threshold + 1)) value + == matches (GreaterThan threshold) value + + prop "upper and lower complements partition every finite value" $ + \rawThreshold rawValue -> + let threshold = asNatural rawThreshold + value = asNatural rawValue + in property $ + and + [ matches (GreaterThan threshold) value + /= matches (AtMost threshold) value + , matches (AtLeast threshold) value + /= matches (LessThan threshold) value + ] + + describe "includesInfiniteOutcome" $ do + it "includes infinity exactly in upper-tail events" $ do + map + includesInfiniteOutcome + [ EqualTo 3 + , LessThan 3 + , AtMost 3 + , GreaterThan 3 + , AtLeast 3 + ] + `shouldBe` [False, False, False, True, True] + + prop "is independent of the finite threshold" $ \rawThreshold -> + let threshold = asNatural rawThreshold + in property $ + and + [ not (includesInfiniteOutcome (EqualTo threshold)) + , not (includesInfiniteOutcome (LessThan threshold)) + , not (includesInfiniteOutcome (AtMost threshold)) + , includesInfiniteOutcome (GreaterThan threshold) + , includesInfiniteOutcome (AtLeast threshold) + ] diff --git a/test/Dtmc/Analysis/FiniteTimeCanonicalSpec.hs b/test/Dtmc/Analysis/FiniteTimeCanonicalSpec.hs new file mode 100644 --- /dev/null +++ b/test/Dtmc/Analysis/FiniteTimeCanonicalSpec.hs @@ -0,0 +1,190 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeApplications #-} + +module Dtmc.Analysis.FiniteTimeCanonicalSpec ( + spec, +) where + +import Data.Finite ( + Finite, + finites, + ) +import Dtmc.Analysis.FiniteTime qualified as FT +import Dtmc.Analysis.ProbabilityOracle qualified as Oracle +import Dtmc.Distribution.Map ( + fromList, + pointMass, + ) +import Dtmc.Distribution.Vector ( + DistributionVector, + ) +import Dtmc.Distribution.Vector qualified as Vector +import Dtmc.TestSupport ( + approxEq, + chunksOf, + genTransitionRows, + testTolerance, + ) +import Dtmc.Transition.Kernel ( + TransitionKernel, + fromLaws, + ) +import Dtmc.Transition.Matrix ( + TransitionMatrix, + TransitionMatrixError, + fromRows, + ) +import Test.Hspec ( + Spec, + describe, + it, + shouldBe, + ) +import Test.Hspec.QuickCheck ( + prop, + ) +import Test.QuickCheck ( + counterexample, + forAll, + property, + ) + +initialWeights :: [(Finite 3, Double)] +initialWeights = zip finites [0.2, 0.3, 0.5] + +initialDistribution :: DistributionVector (Finite 3) +initialDistribution = + checked (Vector.fromList [0.2, 0.3, 0.5]) + +checked :: (Show error) => Either error value -> value +checked = either (error . show) id + +simpleRandomWalk :: TransitionKernel Integer +simpleRandomWalk = + fromLaws $ \state -> + checked + ( fromList + [(state - 1, 0.5), (state + 1, 0.5)] + ) + +close :: Double -> Double -> Bool +close = approxEq testTolerance + +canonicalMatchesOracle :: TransitionMatrix (Finite 3) -> Bool +canonicalMatchesOracle matrix = + and + [ and + [ close + (FT.stepProbability matrix source destination) + (Oracle.transitionWeight matrix source destination) + | source <- finites + , destination <- finites + ] + , and + [ close + (FT.nStepProbability time matrix source destination) + (Oracle.stateProbability time [(source, 1)] matrix destination) + | time <- [0 .. 4] + , source <- finites + , destination <- finites + ] + , and + [ close + (FT.probability initialDistribution matrix [FT.At time destination]) + (Oracle.stateProbability time initialWeights matrix destination) + | time <- [0 .. 4] + , destination <- finites + ] + , close + ( FT.probability + initialDistribution + matrix + [FT.At 0 0, FT.At 1 1, FT.At 2 2] + ) + (Oracle.trajectoryProbability initialWeights matrix [0, 1, 2]) + , close + ( FT.probability + initialDistribution + matrix + [FT.At 1 1, FT.At 3 2] + ) + ( Oracle.observationProbability + 3 + initialWeights + matrix + [(1, 1), (3, 2)] + ) + , conditionalMatchesOracle + ] + where + denominator = + Oracle.observationProbability 1 initialWeights matrix [(1, 1)] + numerator = + Oracle.observationProbability + 3 + initialWeights + matrix + [(1, 1), (3, 2)] + conditionalMatchesOracle = + case FT.probabilityGiven + initialDistribution + matrix + [FT.At 3 2] + [FT.At 1 1] of + Left FT.ZeroProbabilityCondition -> denominator == 0 + Right actual -> denominator /= 0 && close actual (numerator / denominator) + +spec :: Spec +spec = do + describe "canonical finite-time namespace" $ do + it "uses the four grammar-compliant names together" $ do + let matrix :: TransitionMatrix (Finite 2) + matrix = + checked + ( fromRows + (chunksOf 2 [0.5, 0.5, 0, 1]) + ) + initial :: DistributionVector (Finite 2) + initial = + checked + (Vector.fromList [1, 0]) + FT.stepProbability matrix 0 1 `shouldBe` 0.5 + FT.nStepProbability 2 matrix 0 1 `shouldBe` 0.75 + FT.probability initial matrix [FT.At 1 1] `shouldBe` 0.5 + FT.probability initial matrix [FT.At 0 0, FT.At 1 1] + `shouldBe` 0.5 + FT.probabilityGiven + initial + matrix + [FT.At 1 1] + [FT.At 0 0] + `shouldBe` Right 0.5 + + it "preserves locally finite countable-state support" $ do + FT.stepProbability simpleRandomWalk 0 1 `shouldBe` 0.5 + FT.nStepProbability 2 simpleRandomWalk 0 0 `shouldBe` 0.5 + FT.probability (pointMass 0) simpleRandomWalk [FT.At 2 0] + `shouldBe` 0.5 + FT.probability + (pointMass 0) + simpleRandomWalk + [FT.At 0 0, FT.At 1 1, FT.At 2 0] + `shouldBe` 0.25 + FT.probability + (pointMass 0) + simpleRandomWalk + [FT.At 0 0, FT.At 2 0] + `shouldBe` 0.5 + FT.probabilityGiven + (pointMass 0) + simpleRandomWalk + [FT.At 2 0] + [FT.At 1 1] + `shouldBe` Right 0.5 + + prop "matches independent path enumeration (random @3)" $ + forAll (genTransitionRows 3) $ \rawMatrix -> + case fromRows rawMatrix :: + Either TransitionMatrixError (TransitionMatrix (Finite 3)) of + Left problem -> counterexample (show problem) False + Right matrix -> property (canonicalMatchesOracle matrix) diff --git a/test/Dtmc/Analysis/FiniteTimeSpec.hs b/test/Dtmc/Analysis/FiniteTimeSpec.hs new file mode 100644 --- /dev/null +++ b/test/Dtmc/Analysis/FiniteTimeSpec.hs @@ -0,0 +1,671 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TypeApplications #-} + +module Dtmc.Analysis.FiniteTimeSpec ( + spec, +) where + +import Data.Finite ( + Finite, + finites, + getFinite, + ) +import Dtmc.Analysis.FiniteTime ( + ConditionalProbabilityError (..), + Observation (..), + nStepProbability, + probability, + probabilityGiven, + stepProbability, + ) +import Dtmc.Distribution ( + probabilityAt, + ) +import Dtmc.Distribution.Map qualified as DistributionMap +import Dtmc.Distribution.Vector ( + DistributionVector, + ) +import Dtmc.Distribution.Vector qualified as Vector +import Dtmc.Dynamics ( + evolveVector, + evolveVectorN, + ) +import Dtmc.State qualified +import Dtmc.TestSupport ( + approxEq, + chunksOf, + genSimplexPoint, + genTransitionRows, + testTolerance, + ) +import Dtmc.Transition.Kernel qualified as Kernel +import Dtmc.Transition.Matrix ( + TransitionMatrix, + TransitionMatrixError, + fromRows, + power, + rowAt, + toRows, + ) +import GHC.Generics ( + Generic, + ) +import Numeric.Natural ( + Natural, + ) +import Test.Hspec ( + Spec, + describe, + it, + shouldBe, + shouldSatisfy, + ) +import Test.Hspec.QuickCheck ( + prop, + ) +import Test.QuickCheck ( + choose, + conjoin, + counterexample, + forAll, + property, + (===), + ) + +-- A three-state chain with several impossible one-step transitions. +chain :: TransitionMatrix (Finite 3) +chain = + either (error . show) id $ + fromRows + ( chunksOf + 3 + [ 0.5 + , 0.5 + , 0.0 + , 0.0 + , 0.2 + , 0.8 + , 1.0 + , 0.0 + , 0.0 + ] + ) + +initial :: DistributionVector (Finite 3) +initial = + either (error . show) id $ + Vector.fromList [0.6, 0.3, 0.1] + +checked :: (Show error) => Either error value -> value +checked = either (error . show) id + +asTransitionKernel :: + (Dtmc.State.FiniteState state) => + TransitionMatrix state -> + Kernel.TransitionKernel state +asTransitionKernel matrix = + Kernel.fromLaws $ \source -> + checked $ + DistributionMap.fromList + [ (destination, stepProbability matrix source destination) + | destination <- Dtmc.State.finiteStates + ] + +kernelChain :: Kernel.TransitionKernel (Finite 3) +kernelChain = asTransitionKernel chain + +mapInitial :: DistributionMap.DistributionMap (Finite 3) +mapInitial = + checked $ + DistributionMap.fromList + [ (state, probabilityAt initial state) + | state <- Dtmc.State.finiteStates + ] + +simpleRandomWalk :: Kernel.TransitionKernel Integer +simpleRandomWalk = + Kernel.fromLaws $ \state -> + checked + (DistributionMap.fromList [(state - 1, 0.5), (state + 1, 0.5)]) + +closeTo :: Double -> Double -> Bool +closeTo = approxEq testTolerance + +{- | Hold for a @Right@ whose 'Double' is within 'testTolerance' of the +expected value; fail for any @Left@ or out-of-tolerance value. +-} +rightCloseTo :: Double -> Either ConditionalProbabilityError Double -> Bool +rightCloseTo expected (Right actual) = approxEq testTolerance actual expected +rightCloseTo _ (Left _) = False + +rightResultsClose :: Either error Double -> Either error Double -> Bool +rightResultsClose (Right left) (Right right) = closeTo left right +rightResultsClose (Left _) (Left _) = True +rightResultsClose _ _ = False + +data NamedPhase = PhaseA | PhaseB | PhaseC + deriving (Eq, Ord, Show, Generic) + +instance Dtmc.State.FiniteState NamedPhase + +namedCycle :: TransitionMatrix NamedPhase +namedCycle = + either (error . show) id $ + fromRows @NamedPhase + (chunksOf 3 [0, 1, 0, 0, 0, 1, 1, 0, 0]) + +twoState :: TransitionMatrix (Finite 2) +twoState = + either (error . show) id $ + fromRows + (chunksOf 2 [0.9, 0.1, 0.4, 0.6]) + +twoStateSquared :: TransitionMatrix (Finite 2) +twoStateSquared = + either (error . show) id $ + fromRows + (chunksOf 2 [0.85, 0.15, 0.6, 0.4]) + +closedFormTransition :: TransitionMatrix (Finite 3) +closedFormTransition = + either (error . show) id $ + fromRows + ( chunksOf + 3 + [ 0.1 + , 0.5 + , 0.4 + , 0.1 + , 0.8 + , 0.1 + , 0.0 + , 0.5 + , 0.5 + ] + ) + +closedFormProbability :: Int -> Double +closedFormProbability n = + 5 / 63 + 5 / 18 * (0.1 ^ n) - 5 / 14 * (0.3 ^ n) + +{- | Five-state transition matrix over states @[A, B, C, D, E]@ used by the +probability examples. +-} +observationMatrix :: TransitionMatrix (Finite 5) +observationMatrix = + either (error . show) id $ + fromRows + ( chunksOf + 5 + [ 0 + , 0 + , 0 + , 1 + , 0 + , 1 / 3 + , 0 + , 0 + , 0 + , 2 / 3 + , 0 + , 0 + , 0 + , 0 + , 1 + , 0 + , 0 + , 1 / 3 + , 2 / 3 + , 0 + , 1 / 4 + , 1 / 4 + , 0 + , 0 + , 1 / 2 + ] + ) + +-- | Initial law @lambda = [1/4, 1/2, 0, 1/4, 0]@ for the probability examples. +observationInitial :: DistributionVector (Finite 5) +observationInitial = + either (error . show) id $ + Vector.fromList [1 / 4, 1 / 2, 0, 1 / 4, 0] + +spec :: Spec +spec = do + describe "Observation" $ do + it "is polymorphic in the state type" $ + (At 2 "rain" :: Observation String) `shouldBe` At 2 "rain" + + describe "stepProbability" $ do + prop "agrees with rowAt then probabilityAt" $ + forAll (genTransitionRows 3) $ \matrix -> + case fromRows @(Finite 3) matrix of + Right p -> + conjoin + [ stepProbability p i j + === probabilityAt (rowAt p i) j + | i <- finites + , j <- finites + ] + Left err -> + counterexample + ("generated matrix was rejected: " <> show err) + False + + it "uses named state constructors" $ + stepProbability namedCycle PhaseB PhaseC + `shouldBe` 1 + + describe "nStepProbability" $ do + it "is the Kronecker delta at exponent zero" $ + let ijs = + [(i, j) | i <- finites, j <- finites] :: + [(Finite 2, Finite 2)] + in map (uncurry (nStepProbability 0 twoState)) ijs + `shouldBe` map (\(i, j) -> if i == j then 1 else 0) ijs + + prop "agrees with stepProbability at exponent one" $ + forAll (genTransitionRows 3) $ \matrix -> + case fromRows @(Finite 3) matrix of + Right p -> + conjoin + [ property $ + approxEq + testTolerance + (nStepProbability 1 p i j) + (stepProbability p i j) + | i <- finites + , j <- finites + ] + Left err -> + counterexample + ("generated matrix was rejected: " <> show err) + False + + it "matches a hand-computed square at exponent two" $ + sequence_ + [ nStepProbability 2 twoState i j + `shouldSatisfy` closeTo (probabilityAt (rowAt twoStateSquared i) j) + | i <- finites :: [Finite 2] + , j <- finites :: [Finite 2] + ] + + prop "agrees with the corresponding power entry" $ + forAll (genTransitionRows 3) $ \matrix -> + case fromRows @(Finite 3) matrix of + Right p -> + let fourStep = toRows (power 4 p) + in conjoin + [ property $ + approxEq + testTolerance + (nStepProbability 4 p i j) + ( fourStep + !! fromIntegral (getFinite i) + !! fromIntegral (getFinite j) + ) + | i <- finites + , j <- finites + ] + Left err -> + counterexample + ("generated matrix was rejected: " <> show err) + False + + it "preserves named state types" $ + nStepProbability 2 namedCycle PhaseA PhaseC + `shouldBe` 1 + + describe "nStepProbability hand-computed regressions" $ do + it "gives P^3(E, D) = 3/8 for the five-state chain" $ + nStepProbability 3 observationMatrix 4 3 + `shouldSatisfy` closeTo (3 / 8) + + it "matches the three-state P^n(2, 0) closed form" $ + mapM_ + ( \n -> + nStepProbability n closedFormTransition 2 0 + `shouldSatisfy` closeTo + (closedFormProbability (fromIntegral n)) + ) + ([0, 1, 2, 3, 5, 10, 20] :: [Natural]) + + describe "probability for state observations" $ do + it "returns the initial probability at time zero" $ + conjoin + [ probability initial chain [At 0 state] + === probabilityAt initial state + | state <- finites + ] + + prop "agrees with probabilityAt of evolveVectorN" + $ forAll + ( (,,) + <$> choose (0, 6 :: Int) + <*> genSimplexPoint 3 + <*> genTransitionRows 3 + ) + $ \(k, entries, matrix) -> + case ( Vector.fromList @(Finite 3) entries + , fromRows @(Finite 3) matrix + ) of + (Right mu, Right p) -> + conjoin + [ property $ + approxEq + testTolerance + (probability mu p [At (fromIntegral k) state]) + (probabilityAt (evolveVectorN (fromIntegral k) mu p) state) + | state <- finites + ] + result -> + counterexample + ("generated input was rejected: " <> show result) + False + + prop "agrees with repeated evolveVector for small exponents" + $ forAll + ( (,,) + <$> choose (0, 6 :: Int) + <*> genSimplexPoint 3 + <*> genTransitionRows 3 + ) + $ \(k, entries, matrix) -> + case ( Vector.fromList @(Finite 3) entries + , fromRows @(Finite 3) matrix + ) of + (Right mu, Right p) -> + let iterated = iterate (`evolveVector` p) mu !! k + in conjoin + [ property $ + approxEq + testTolerance + (probability mu p [At (fromIntegral k) state]) + (probabilityAt iterated state) + | state <- finites + ] + result -> + counterexample + ("generated input was rejected: " <> show result) + False + + describe "Transition realization independence" $ do + it "computes transition probabilities on an infinite state type" $ do + nStepProbability 2 simpleRandomWalk 0 0 + `shouldSatisfy` closeTo 0.5 + nStepProbability 3 simpleRandomWalk 0 0 + `shouldBe` 0 + + prop "gives matrices and equivalent kernels the same transition powers" $ + forAll (genTransitionRows 3) $ \rawMatrix -> + case fromRows rawMatrix :: + Either TransitionMatrixError (TransitionMatrix (Finite 3)) of + Left problem -> counterexample (show problem) False + Right matrix -> + let kernel = asTransitionKernel matrix + in conjoin + [ property $ + closeTo + (nStepProbability time matrix source destination) + (nStepProbability time kernel source destination) + | source <- finites :: [Finite 3] + , destination <- finites :: [Finite 3] + , time <- [0 .. 4] + ] + + it "matches finite trajectory and observation queries" $ do + probability mapInitial kernelChain [At 0 0, At 1 1, At 2 2] + `shouldSatisfy` closeTo + (probability initial chain [At 0 0, At 1 1, At 2 2]) + probability + mapInitial + kernelChain + [At 3 2, At 0 0, At 1 1] + `shouldSatisfy` closeTo + (probability initial chain [At 3 2, At 0 0, At 1 1]) + + it "matches finite conditional probability queries" $ + rightResultsClose + (probabilityGiven mapInitial kernelChain [At 2 2] [At 0 0]) + (probabilityGiven initial chain [At 2 2] [At 0 0]) + `shouldBe` True + + describe "probability for consecutive observations" $ do + it "returns the initial probability for a one-state path" $ + approxEq + testTolerance + (probability initial chain [At 0 0]) + (probabilityAt initial 0) + `shouldBe` True + + it "is lambda_i * P(i, j) for a two-state path" $ + approxEq + testTolerance + (probability initial chain [At 0 0, At 1 1]) + (0.6 * 0.5) + `shouldBe` True + + it "is the product of initial and transition probabilities" $ + approxEq + testTolerance + (probability initial chain [At 0 0, At 1 1, At 2 2]) + (0.6 * 0.5 * 0.8) + `shouldBe` True + + it "is zero for a path with an impossible transition" $ do + approxEq + testTolerance + (probability initial chain [At 0 0, At 1 2]) + 0 + `shouldBe` True + approxEq + testTolerance + (probability initial chain [At 0 0, At 1 1, At 2 0]) + 0 + `shouldBe` True + + prop "a one-state path equals the initial probability" $ + forAll ((,) <$> genSimplexPoint 3 <*> genTransitionRows 3) $ + \(entries, matrix) -> + case ( Vector.fromList @(Finite 3) entries + , fromRows @(Finite 3) matrix + ) of + (Right mu, Right p) -> + conjoin + [ probability mu p [At 0 i] + === probabilityAt mu i + | i <- [0, 1, 2] + ] + result -> + counterexample + ("generated input was rejected: " <> show result) + False + + prop "a two-state path equals lambda_i * P(i, j)" $ + forAll ((,) <$> genSimplexPoint 3 <*> genTransitionRows 3) $ + \(entries, matrix) -> + case ( Vector.fromList @(Finite 3) entries + , fromRows @(Finite 3) matrix + ) of + (Right mu, Right p) -> + conjoin + [ property $ + approxEq + testTolerance + (probability mu p [At 0 i, At 1 j]) + ( probabilityAt mu i + * stepProbability p i j + ) + | i <- [0, 1, 2] + , j <- [0, 1, 2] + ] + result -> + counterexample + ("generated input was rejected: " <> show result) + False + + describe "probability" $ do + it "returns exactly one for no observations" $ + probability initial chain [] `shouldBe` 1 + + it "computes a single state observation" $ + approxEq + testTolerance + (probability initial chain [At 1 1]) + (probabilityAt (evolveVectorN 1 initial chain) 1) + `shouldBe` True + + it "is unchanged by observation order" $ + approxEq + testTolerance + (probability initial chain [At 0 0, At 1 1]) + (probability initial chain [At 1 1, At 0 0]) + `shouldBe` True + + it "is unchanged by duplicate observations" $ + approxEq + testTolerance + (probability initial chain [At 0 0, At 0 0, At 1 1]) + (probability initial chain [At 0 0, At 1 1]) + `shouldBe` True + + it "is exactly zero for conflicting states at one time" $ + probability initial chain [At 0 0, At 0 1] `shouldBe` 0 + + it "agrees with the explicit transition product over times 0, 1, 2" $ + approxEq + testTolerance + (probability initial chain [At 0 0, At 1 1, At 2 2]) + (0.6 * 0.5 * 0.8) + `shouldBe` True + + it "is exactly zero through an impossible transition" $ + probability initial chain [At 0 0, At 1 2] `shouldBe` 0 + + it "matches a hand-computed multi-gap example" $ + approxEq + testTolerance + ( probability + observationInitial + observationMatrix + [At 2 2, At 3 4, At 6 3] + ) + (5 / 96) + `shouldBe` True + + prop "a single observation equals direct evolution" $ + forAll ((,) <$> genSimplexPoint 3 <*> genTransitionRows 3) $ + \(entries, matrix) -> + case ( Vector.fromList @(Finite 3) entries + , fromRows @(Finite 3) matrix + ) of + (Right mu, Right p) -> + conjoin + [ property $ + approxEq + testTolerance + (probability mu p [At t i]) + (probabilityAt (evolveVectorN t mu p) i) + | t <- [0, 1, 2] + , i <- [0, 1, 2] + ] + result -> + counterexample + ("generated input was rejected: " <> show result) + False + + prop "is invariant under observation order" $ + forAll ((,) <$> genSimplexPoint 3 <*> genTransitionRows 3) $ + \(entries, matrix) -> + case ( Vector.fromList @(Finite 3) entries + , fromRows @(Finite 3) matrix + ) of + (Right mu, Right p) -> + property $ + approxEq + testTolerance + (probability mu p [At 1 1, At 3 2]) + (probability mu p [At 3 2, At 1 1]) + result -> + counterexample + ("generated input was rejected: " <> show result) + False + + describe "probabilityGiven" $ do + it "returns the event probability for an empty condition" $ + probabilityGiven initial chain [At 1 1] [] + `shouldSatisfy` rightCloseTo + (probability initial chain [At 1 1]) + + it "returns one for an empty event and a positive condition" $ + probabilityGiven initial chain [] [At 0 0] + `shouldSatisfy` rightCloseTo 1 + + it "returns one when conditioning an observation on itself" $ + probabilityGiven initial chain [At 1 1] [At 1 1] + `shouldSatisfy` rightCloseTo 1 + + it "ignores observations shared by event and condition" $ + probabilityGiven initial chain [At 1 1] [At 1 1, At 2 2] + `shouldSatisfy` rightCloseTo 1 + + it "returns zero for a conflict against a possible condition" $ + probabilityGiven initial chain [At 1 0] [At 1 1] + `shouldSatisfy` rightCloseTo 0 + + it "reports a zero-probability condition" $ + probabilityGiven initial chain [At 0 0] [At 0 0, At 1 2] + `shouldBe` Left ZeroProbabilityCondition + + it "reports a contradictory condition" $ + probabilityGiven initial chain [At 0 0] [At 1 1, At 1 2] + `shouldBe` Left ZeroProbabilityCondition + + it "is unaffected by event and condition ordering" $ do + probabilityGiven initial chain [At 2 2, At 1 1] [At 0 0] + `shouldSatisfy` rightCloseTo 0.4 + probabilityGiven initial chain [At 1 1, At 2 2] [At 0 0] + `shouldSatisfy` rightCloseTo 0.4 + + describe "probabilityGiven hand-computed regressions" $ do + it "gives P(X10=D, X11=D | X3=A, X7=E) = 1/4" $ + probabilityGiven + observationInitial + observationMatrix + [At 10 3, At 11 3] + [At 3 0, At 7 4] + `shouldSatisfy` rightCloseTo (1 / 4) + + it "accepts an out-of-order event and gives 15/92" $ + probabilityGiven + observationInitial + observationMatrix + [At 6 3, At 2 2] + [At 3 4] + `shouldSatisfy` rightCloseTo (15 / 92) + + it "gives P(X2=C) = 5/36" $ + approxEq + testTolerance + (probability observationInitial observationMatrix [At 2 2]) + (5 / 36) + `shouldBe` True + + it "gives P(X3=E) = 23/72" $ + approxEq + testTolerance + (probability observationInitial observationMatrix [At 3 4]) + (23 / 72) + `shouldBe` True + + it "gives P(X2=C, X3=E, X6=D) = 5/96" $ + approxEq + testTolerance + ( probability + observationInitial + observationMatrix + [At 2 2, At 3 4, At 6 3] + ) + (5 / 96) + `shouldBe` True diff --git a/test/Dtmc/Analysis/HittingTimeCanonicalSpec.hs b/test/Dtmc/Analysis/HittingTimeCanonicalSpec.hs new file mode 100644 --- /dev/null +++ b/test/Dtmc/Analysis/HittingTimeCanonicalSpec.hs @@ -0,0 +1,215 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeApplications #-} + +module Dtmc.Analysis.HittingTimeCanonicalSpec ( + spec, +) where + +import Data.Finite ( + Finite, + finites, + ) +import Data.Maybe ( + fromMaybe, + ) +import Dtmc.Analysis.Event ( + DiscreteEvent (..), + ) +import Dtmc.Analysis.Expectation ( + Expectation (..), + ) +import Dtmc.Analysis.HittingTime qualified as Hit +import Dtmc.Analysis.ProbabilityOracle qualified as Oracle +import Dtmc.Distribution.Map ( + fromList, + ) +import Dtmc.TestSupport +import Dtmc.Transition.Kernel ( + TransitionKernel, + fromLaws, + ) +import Dtmc.Transition.Matrix ( + TransitionMatrix, + TransitionMatrixError, + fromRows, + ) +import Test.Hspec ( + Spec, + describe, + it, + shouldBe, + ) +import Test.Hspec.QuickCheck ( + prop, + ) +import Test.QuickCheck ( + counterexample, + forAll, + property, + ) + +terminalChain :: TransitionMatrix (Finite 3) +terminalChain = + checked + ( fromRows + ( chunksOf + 3 + [ 0 + , 0.5 + , 0.5 + , 0 + , 0 + , 1 + , 0 + , 0 + , 1 + ] + ) + ) + +simpleRandomWalk :: TransitionKernel Integer +simpleRandomWalk = + fromLaws $ \state -> + checked + (fromList [(state - 1, 0.5), (state + 1, 0.5)]) + +tinySurvival :: Double +tinySurvival = 1e-12 + +tinySurvivalKernel :: TransitionKernel Int +tinySurvivalKernel = + fromLaws $ \state -> + case state of + 0 -> + checked + ( fromList + [(1, 1 - tinySurvival), (2, tinySurvival)] + ) + _ -> deterministicLaw state + where + deterministicLaw state = + checked (fromList [(state, 1)]) + +checked :: (Show error) => Either error value -> value +checked = either (error . show) id + +close :: Double -> Double -> Bool +close = approxEq testTolerance + +known :: Maybe Double -> Double +known = fromMaybe (error "oracle horizon does not determine this event") + +eventsThrough :: Integer -> [DiscreteEvent] +eventsThrough rawHorizon = + [EqualTo time | time <- [0 .. horizon]] + <> [LessThan time | time <- [0 .. horizon + 1]] + <> [AtMost time | time <- [0 .. horizon]] + <> [GreaterThan time | time <- [0 .. horizon]] + <> [AtLeast time | time <- [0 .. horizon + 1]] + where + horizon = fromInteger rawHorizon + +generatedChecks :: TransitionMatrix (Finite 3) -> Bool +generatedChecks matrix = + and + [ let law = Oracle.hittingLaw 4 matrix isTarget initial + oracle = known (Oracle.lawProbability event law) + scalar = Hit.probabilityGivenInitialState event matrix isTarget initial + dense = (hitProbabilityByState event matrix [2]) + in close scalar oracle + && close (dense !! fromIntegral initial) oracle + | initial <- finites + , event <- eventsThrough 4 + ] + where + isTarget state = state == (2 :: Finite 3) + +spec :: Spec +spec = do + describe "canonical hitting probability" $ do + it "implements every relation and carries the infinity atom in upper tails" $ do + let target state = state == (1 :: Finite 3) + Hit.probabilityGivenInitialState (EqualTo 0) terminalChain target 0 `shouldBe` 0 + Hit.probabilityGivenInitialState (EqualTo 1) terminalChain target 0 `shouldBe` 0.5 + Hit.probabilityGivenInitialState (LessThan 1) terminalChain target 0 `shouldBe` 0 + Hit.probabilityGivenInitialState (AtMost 1) terminalChain target 0 `shouldBe` 0.5 + Hit.probabilityGivenInitialState (GreaterThan 0) terminalChain target 0 `shouldBe` 1 + Hit.probabilityGivenInitialState (GreaterThan 1) terminalChain target 0 `shouldBe` 0.5 + Hit.probabilityGivenInitialState (AtLeast 0) terminalChain target 0 `shouldBe` 1 + Hit.probabilityGivenInitialState (AtLeast 1) terminalChain target 0 `shouldBe` 1 + Hit.probabilityGivenInitialState (AtLeast 2) terminalChain target 0 `shouldBe` 0.5 + (hitProbabilityByState (GreaterThan 1) terminalChain [1]) + `shouldBe` [0.5, 0, 1] + (hitProbabilityByState (AtMost 1) terminalChain [1]) + `shouldBe` [0.5, 1, 0] + + it "keeps empty-target and time-zero boundaries structural" $ do + (hitProbabilityByState (EqualTo 3) terminalChain []) + `shouldBe` [0, 0, 0] + (hitProbabilityByState (AtMost 3) terminalChain []) + `shouldBe` [0, 0, 0] + (hitProbabilityByState (GreaterThan 3) terminalChain []) + `shouldBe` [1, 1, 1] + (hitProbabilityByState (AtLeast 0) terminalChain [1]) + `shouldBe` [1, 1, 1] + Hit.probabilityGivenInitialState (EqualTo 0) terminalChain (== 1) 1 `shouldBe` 1 + Hit.probabilityGivenInitialState (GreaterThan 0) terminalChain (== 1) 1 `shouldBe` 0 + + it "preserves locally finite kernels and tiny survivor mass directly" $ do + Hit.probabilityGivenInitialState (EqualTo 2) simpleRandomWalk (== 2) 0 + `shouldBe` 0.25 + Hit.probabilityGivenInitialState (AtMost 2) simpleRandomWalk (== 2) 0 + `shouldBe` 0.25 + Hit.probabilityGivenInitialState (GreaterThan 2) simpleRandomWalk (== 2) 0 + `shouldBe` 0.75 + Hit.probabilityGivenInitialState (AtLeast 3) simpleRandomWalk (== 2) 0 + `shouldBe` 0.75 + Hit.probabilityGivenInitialState (GreaterThan 1) tinySurvivalKernel (== 1) 0 + `shouldBe` tinySurvival + + prop "matches the path oracle for every relation (random @3)" $ + forAll (genTransitionRows 3) $ \rawMatrix -> + case fromRows rawMatrix :: + Either TransitionMatrixError (TransitionMatrix (Finite 3)) of + Left problem -> counterexample (show problem) False + Right matrix -> property (generatedChecks matrix) + + describe "canonical eventual, race, and expectation names" $ do + it "match the completed defective hitting law" $ do + let states = finites :: [Finite 3] + case hitEventualProbabilityByState terminalChain [1] of + Left problem -> error (show problem) + Right values -> values `shouldBe` [0.5, 1, 0] + mapM_ + ( \(state, expected) -> + Hit.eventualProbabilityGivenInitialState terminalChain [1] state + `shouldBe` Right expected + ) + (zip states [0.5, 1, 0]) + case hitRaceProbabilityByState terminalChain [1] [2] of + Left problem -> error (show problem) + Right values -> values `shouldBe` [0.5, 1, 0] + mapM_ + ( \(state, expected) -> + Hit.raceProbabilityGivenInitialState terminalChain [1] [2] state + `shouldBe` Right expected + ) + (zip states [0.5, 1, 0]) + hitExpectationByState terminalChain [1] + `shouldBe` Right + [ InfiniteExpectation + , FiniteExpectation 0 + , InfiniteExpectation + ] + mapM_ + ( \(state, expected) -> + Hit.expectationGivenInitialState terminalChain [1] state + `shouldBe` Right expected + ) + ( zip + states + [ InfiniteExpectation + , FiniteExpectation 0 + , InfiniteExpectation + ] + ) diff --git a/test/Dtmc/Analysis/HittingTimeSpec.hs b/test/Dtmc/Analysis/HittingTimeSpec.hs new file mode 100644 --- /dev/null +++ b/test/Dtmc/Analysis/HittingTimeSpec.hs @@ -0,0 +1,13 @@ +module Dtmc.Analysis.HittingTimeSpec ( + spec, +) where + +import Dtmc.Analysis.TimeSpecSupport ( + hittingTimeSpec, + ) +import Test.Hspec ( + Spec, + ) + +spec :: Spec +spec = hittingTimeSpec diff --git a/test/Dtmc/Analysis/LimitingSpec.hs b/test/Dtmc/Analysis/LimitingSpec.hs new file mode 100644 --- /dev/null +++ b/test/Dtmc/Analysis/LimitingSpec.hs @@ -0,0 +1,288 @@ +{-# LANGUAGE DataKinds #-} + +module Dtmc.Analysis.LimitingSpec ( + spec, +) where + +import Data.Finite ( + Finite, + ) +import Dtmc.Analysis.Limiting ( + converges, + cyclicLimits, + limitingMatrix, + ) +import Dtmc.State ( + FiniteState, + ) +import Dtmc.TestSupport ( + approxEq, + chunksOf, + testTolerance, + ) +import Dtmc.Transition.Matrix ( + TransitionMatrix, + fromRows, + identity, + power, + toRows, + ) +import Numeric.Natural ( + Natural, + ) +import Test.Hspec ( + Spec, + describe, + expectationFailure, + it, + shouldBe, + shouldSatisfy, + ) + +checked :: (Show error) => Either error value -> value +checked = either (error . show) id + +-- Section 4.2: closed classes {0} and {1,2}, both aperiodic. +twoClosedClasses :: TransitionMatrix (Finite 3) +twoClosedClasses = + checked + ( fromRows + (chunksOf 3 [1, 0, 0, 0, 0.4, 0.6, 0, 0.5, 0.5]) + ) + +-- State 0 is transient; {1,2} is the only recurrent class. +withTransient :: TransitionMatrix (Finite 3) +withTransient = + checked + ( fromRows + (chunksOf 3 [0, 0.5, 0.5, 0, 0.4, 0.6, 0, 0.5, 0.5]) + ) + +-- States 0 and 1 are transient and can enter either absorbing class. This +-- exercises the multiple right-hand sides of the batched class-entry solve. +withTwoDestinations :: TransitionMatrix (Finite 4) +withTwoDestinations = + checked + ( fromRows + ( chunksOf + 4 + [ 0 + , 1 / 2 + , 1 / 4 + , 1 / 4 + , 0 + , 1 / 5 + , 3 / 10 + , 1 / 2 + , 0 + , 0 + , 1 + , 0 + , 0 + , 0 + , 0 + , 1 + ] + ) + ) + +-- Irreducible, aperiodic, stationary distribution (0.8, 0.2). +twoState :: TransitionMatrix (Finite 2) +twoState = + checked + ( fromRows + (chunksOf 2 [0.9, 0.1, 0.4, 0.6]) + ) + +-- Irreducible with period 3, so P^n never settles. +threeCycle :: TransitionMatrix (Finite 3) +threeCycle = + checked + ( fromRows + (chunksOf 3 [0, 1, 0, 0, 0, 1, 1, 0, 0]) + ) + +-- Reducible with disjoint recurrent cycles of periods 2 and 3. +mixedPeriods :: TransitionMatrix (Finite 5) +mixedPeriods = + checked + ( fromRows + ( chunksOf + 5 + [ 0 + , 1 + , 0 + , 0 + , 0 + , 1 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 1 + , 0 + , 0 + , 0 + , 0 + , 0 + , 1 + , 0 + , 0 + , 1 + , 0 + , 0 + ] + ) + ) + +-- State 0 is transient and enters the recurrent period-2 class {1,2}. +withTransientCycle :: TransitionMatrix (Finite 3) +withTransientCycle = + checked + ( fromRows + (chunksOf 3 [0, 1, 0, 0, 0, 1, 0, 1, 0]) + ) + +-- An irreducible period-2 chain whose two cyclic phases have different +-- cardinalities and whose non-singleton phase is non-uniform. +unequalPhases :: TransitionMatrix (Finite 3) +unequalPhases = + checked + ( fromRows + (chunksOf 3 [0, 1 / 4, 3 / 4, 1, 0, 0, 1, 0, 0]) + ) + +powerRows :: (FiniteState state) => Natural -> TransitionMatrix state -> [[Double]] +powerRows steps p = + toRows (power steps p) + +matrixCloseTo :: [[Double]] -> [[Double]] -> Bool +matrixCloseTo expected actual = + length expected == length actual + && and (zipWith rowCloseTo expected actual) + where + rowCloseTo e a = + length e == length a && and (zipWith (approxEq testTolerance) e a) + +spec :: Spec +spec = do + describe "converges" $ do + it "accepts an aperiodic irreducible chain" $ + converges twoState `shouldBe` True + + it "accepts several aperiodic recurrent classes" $ + converges twoClosedClasses `shouldBe` True + + it "rejects a periodic class" $ + converges threeCycle `shouldBe` False + + describe "limitingMatrix" $ do + it "matches the closed form of the notes" $ + case limitingMatrix twoClosedClasses of + Right (Just rows) -> + rows + `shouldSatisfy` matrixCloseTo + [ [1, 0, 0] + , [0, 5 / 11, 6 / 11] + , [0, 5 / 11, 6 / 11] + ] + other -> expectationFailure ("unexpected result: " ++ show other) + + it "repeats the stationary distribution in every row of an ergodic chain" $ + case limitingMatrix twoState of + Right (Just rows) -> + rows `shouldSatisfy` matrixCloseTo [[0.8, 0.2], [0.8, 0.2]] + other -> expectationFailure ("unexpected result: " ++ show other) + + it "is exactly zero on a transient column" $ + case limitingMatrix withTransient of + Right (Just rows) -> do + map (take 1) rows `shouldBe` [[0], [0], [0]] + rows + `shouldSatisfy` matrixCloseTo + [ [0, 5 / 11, 6 / 11] + , [0, 5 / 11, 6 / 11] + , [0, 5 / 11, 6 / 11] + ] + other -> expectationFailure ("unexpected result: " ++ show other) + + it "batches entry probabilities for several recurrent classes" $ + case limitingMatrix withTwoDestinations of + Right (Just rows) -> + rows + `shouldSatisfy` matrixCloseTo + [ [0, 0, 7 / 16, 9 / 16] + , [0, 0, 3 / 8, 5 / 8] + , [0, 0, 1, 0] + , [0, 0, 0, 1] + ] + other -> expectationFailure ("unexpected result: " ++ show other) + + it "reports that a periodic chain has no limit" $ + limitingMatrix threeCycle `shouldBe` Right Nothing + + it "agrees with a high matrix power" $ do + -- An independent route: repeated squaring rather than the + -- hitting/stationary decomposition. + case limitingMatrix twoState of + Right (Just rows) -> + rows `shouldSatisfy` matrixCloseTo (powerRows 256 twoState) + other -> expectationFailure ("unexpected result: " ++ show other) + case limitingMatrix twoClosedClasses of + Right (Just rows) -> + rows `shouldSatisfy` matrixCloseTo (powerRows 256 twoClosedClasses) + other -> expectationFailure ("unexpected result: " ++ show other) + + describe "cyclicLimits" $ do + it "returns one limit per period and reproduces the powers" $ + case cyclicLimits threeCycle of + Right [atZero, atOne, atTwo] -> do + atZero `shouldSatisfy` matrixCloseTo (powerRows 3 threeCycle) + atOne `shouldSatisfy` matrixCloseTo (powerRows 4 threeCycle) + atTwo `shouldSatisfy` matrixCloseTo (powerRows 5 threeCycle) + other -> expectationFailure ("expected three limits: " ++ show other) + + it "collapses to the ordinary limit when aperiodic" $ + case (cyclicLimits twoState, limitingMatrix twoState) of + (Right [only], Right (Just rows)) -> + only `shouldSatisfy` matrixCloseTo rows + other -> expectationFailure ("unexpected result: " ++ show other) + + it "collapses to the ordinary limit for a reducible aperiodic chain" $ + case (cyclicLimits twoClosedClasses, limitingMatrix twoClosedClasses) of + (Right [only], Right (Just rows)) -> + only `shouldSatisfy` matrixCloseTo rows + other -> expectationFailure ("unexpected result: " ++ show other) + + it "uses the least common multiple of recurrent class periods" $ + case cyclicLimits mixedPeriods of + Right limits -> do + length limits `shouldBe` 6 + and + ( zipWith + matrixCloseTo + [powerRows r mixedPeriods | r <- [0 .. 5]] + limits + ) + `shouldBe` True + other -> expectationFailure ("unexpected result: " ++ show other) + + it "accounts for the entry phase of transient states" $ + case cyclicLimits withTransientCycle of + Right [atZero, atOne] -> do + atZero `shouldSatisfy` matrixCloseTo (powerRows 100 withTransientCycle) + atOne `shouldSatisfy` matrixCloseTo (powerRows 101 withTransientCycle) + other -> expectationFailure ("expected two limits: " ++ show other) + + it "rotates non-uniform phase distributions" $ + case cyclicLimits unequalPhases of + Right [atZero, atOne] -> do + atZero `shouldSatisfy` matrixCloseTo (powerRows 100 unequalPhases) + atOne `shouldSatisfy` matrixCloseTo (powerRows 101 unequalPhases) + other -> expectationFailure ("expected two limits: " ++ show other) + + it "returns one empty limit for the empty chain" $ + cyclicLimits (identity @(Finite 0)) `shouldBe` Right [[]] diff --git a/test/Dtmc/Analysis/NamespaceCompileSpec.hs b/test/Dtmc/Analysis/NamespaceCompileSpec.hs new file mode 100644 --- /dev/null +++ b/test/Dtmc/Analysis/NamespaceCompileSpec.hs @@ -0,0 +1,135 @@ +{-# LANGUAGE DataKinds #-} + +module Dtmc.Analysis.NamespaceCompileSpec ( + spec, +) where + +import Data.Finite ( + Finite, + ) +import Dtmc.Analysis.Absorption qualified as Absorption +import Dtmc.Analysis.Event ( + DiscreteEvent (..), + matches, + ) +import Dtmc.Analysis.Expectation ( + Expectation (..), + ) +import Dtmc.Analysis.FiniteTime qualified as FT +import Dtmc.Analysis.HittingTime qualified as Hit +import Dtmc.Analysis.ReturnTime qualified as Return +import Dtmc.Analysis.VisitCount qualified as Visit +import Dtmc.Distribution.Vector ( + DistributionVector, + ) +import Dtmc.Distribution.Vector qualified as Vector +import Dtmc.TestSupport ( + chunksOf, + ) +import Dtmc.Transition.Matrix ( + TransitionMatrix, + fromRows, + ) +import Test.Hspec ( + Spec, + describe, + it, + shouldBe, + ) + +matrix :: TransitionMatrix (Finite 2) +matrix = + checked + ( fromRows + (chunksOf 2 [0.5, 0.5, 0, 1]) + ) + +initial :: DistributionVector (Finite 2) +initial = + checked + (Vector.fromList [1, 0]) + +mixedInitial :: DistributionVector (Finite 2) +mixedInitial = + checked + (Vector.fromList [0.25, 0.75]) + +checked :: (Show error) => Either error value -> value +checked = either (error . show) id + +spec :: Spec +spec = do + describe "qualified analysis namespaces" $ do + it "coexist under the documented aliases" $ do + FT.stepProbability matrix 0 1 `shouldBe` 0.5 + FT.nStepProbability 2 matrix 0 1 `shouldBe` 0.75 + FT.probability initial matrix [FT.At 1 1] `shouldBe` 0.5 + FT.probability initial matrix [FT.At 0 0, FT.At 1 1] + `shouldBe` 0.5 + FT.probabilityGiven + initial + matrix + [FT.At 1 1] + [FT.At 0 0] + `shouldBe` Right 0.5 + Hit.probability (EqualTo 1) matrix (== 1) initial `shouldBe` 0.5 + length + [ Hit.probabilityGivenInitialState (AtMost 1) matrix (== 1) 0 `seq` () + , Hit.probability (AtMost 1) matrix (== 1) initial `seq` () + , Hit.eventualProbabilityGivenInitialState matrix [1] 0 `seq` () + , Hit.eventualProbability matrix [1] initial `seq` () + , Hit.raceProbabilityGivenInitialState matrix [1] [] 0 `seq` () + , Hit.raceProbability matrix [1] [] initial `seq` () + , Hit.expectationGivenInitialState matrix [1] 0 `seq` () + , Hit.expectation matrix [1] initial `seq` () + ] + `shouldBe` 8 + Return.probability (EqualTo 1) matrix initial `shouldBe` 0.5 + length + [ Return.probabilityGivenInitialState (AtMost 1) matrix 0 `seq` () + , Return.probability (AtMost 1) matrix initial `seq` () + , Return.eventualProbabilityGivenInitialState matrix 0 `seq` () + , Return.eventualProbability matrix initial `seq` () + , Return.expectationGivenInitialState matrix 0 `seq` () + , Return.expectation matrix initial `seq` () + ] + `shouldBe` 6 + Visit.boundedProbability 2 (EqualTo 1) initial matrix (== 1) + `shouldBe` 0.5 + length + [ Visit.totalProbabilityGivenInitialState (EqualTo 1) matrix 1 0 `seq` () + , Visit.totalProbability (AtMost 1) matrix 1 initial `seq` () + , Visit.infiniteProbabilityGivenInitialState matrix 1 0 `seq` () + , Visit.infiniteProbability matrix 1 initial `seq` () + , Visit.totalExpectationGivenInitialState matrix 1 0 `seq` () + , Visit.totalExpectation matrix 1 initial `seq` () + , Visit.boundedLaw 2 initial matrix (== 1) `seq` () + , Visit.boundedProbability 2 (AtMost 1) initial matrix (== 1) `seq` () + , Visit.boundedProbabilityGivenInitialState 2 (AtMost 1) 0 matrix (== 1) `seq` () + , Visit.boundedExpectation 2 initial matrix (== 1) `seq` () + , Visit.boundedExpectationGivenInitialState 2 0 matrix (== 1) `seq` () + ] + `shouldBe` 11 + matches (AtMost 1) 1 `shouldBe` True + + it "distinguishes distribution and initial-state forms" $ do + Hit.probability (EqualTo 1) matrix (== 1) mixedInitial + `shouldBe` 0.125 + Hit.probabilityGivenInitialState (EqualTo 1) matrix (== 1) 0 + `shouldBe` 0.5 + Hit.expectation matrix [1] mixedInitial + `shouldBe` Right (FiniteExpectation 0.5) + Return.probability (EqualTo 1) matrix mixedInitial + `shouldBe` 0.875 + Return.eventualProbability matrix mixedInitial + `shouldBe` Right 0.875 + Return.expectation matrix mixedInitial + `shouldBe` Right InfiniteExpectation + Visit.totalProbability (EqualTo 0) matrix 0 mixedInitial + `shouldBe` Right 0.75 + Visit.totalExpectation matrix 0 mixedInitial + `shouldBe` Right (FiniteExpectation 0.5) + Absorption.probability matrix 1 mixedInitial + `shouldBe` Right 1 + Absorption.expectation matrix mixedInitial + `shouldBe` Right (FiniteExpectation 0.5) diff --git a/test/Dtmc/Analysis/ProbabilityOracle.hs b/test/Dtmc/Analysis/ProbabilityOracle.hs new file mode 100644 --- /dev/null +++ b/test/Dtmc/Analysis/ProbabilityOracle.hs @@ -0,0 +1,261 @@ +module Dtmc.Analysis.ProbabilityOracle ( + TruncatedLaw, + transitionWeight, + trajectoryProbability, + stateProbability, + observationProbability, + hittingLaw, + returnLaw, + visitLawBefore, + raceProbabilityWithin, + lawProbability, + lawUnresolvedMass, + lawFiniteExpectation, +) where + +import Data.Finite ( + getFinite, + ) +import Data.List ( + findIndex, + ) +import Data.Map.Strict ( + Map, + ) +import Data.Map.Strict qualified as Map +import Dtmc.Analysis.Event ( + DiscreteEvent (..), + includesInfiniteOutcome, + matches, + ) +import Dtmc.State ( + FiniteState, + finiteStates, + stateIndex, + ) +import Dtmc.Transition.Matrix ( + TransitionMatrix, + toRows, + ) +import Numeric.Natural ( + Natural, + ) + +data WeightedPath state = WeightedPath [state] Double + +{- | A finite prefix of a discrete law. 'lawUnresolvedMass' is the probability +whose event time is strictly beyond the stored horizon, including any atom at +infinity. This test-only type deliberately does not appear in the library API. +-} +data TruncatedLaw = TruncatedLaw + { lawHorizon :: Natural + , lawFiniteMasses :: Map Natural Double + , lawUnresolvedMass :: Double + } + +toIndex :: (FiniteState state) => state -> Int +toIndex = fromIntegral . getFinite . stateIndex + +transitionWeight :: + (FiniteState state) => + TransitionMatrix state -> + state -> + state -> + Double +transitionWeight matrix source destination = + toRows matrix !! toIndex source !! toIndex destination + +iterateNatural :: Natural -> (value -> value) -> value -> value +iterateNatural steps advance = go steps + where + go 0 value = value + go remaining value = go (remaining - 1) (advance value) + +weightedTrajectories :: + (FiniteState state) => + Natural -> + [(state, Double)] -> + TransitionMatrix state -> + [WeightedPath state] +weightedTrajectories steps initial matrix = + iterateNatural steps advance initialPaths + where + initialPaths = + [ WeightedPath [state] weight + | (state, weight) <- initial + , weight /= 0 + ] + advance paths = paths >>= extend + extend (WeightedPath path weight) = + [ WeightedPath (path <> [destination]) (weight * probability) + | destination <- finiteStates + , let probability = transitionWeight matrix (last path) destination + , probability /= 0 + ] + +trajectoryProbability :: + (FiniteState state) => + [(state, Double)] -> + TransitionMatrix state -> + [state] -> + Double +trajectoryProbability _ _ [] = 0 +trajectoryProbability initial matrix (first : rest) = + initialMass first * go first rest + where + initialMass state = + sum [weight | (candidate, weight) <- initial, candidate == state] + go _ [] = 1 + go previous (next : more) = + transitionWeight matrix previous next * go next more + +stateProbability :: + (FiniteState state) => + Natural -> + [(state, Double)] -> + TransitionMatrix state -> + state -> + Double +stateProbability time initial matrix destination = + sum + [ weight + | WeightedPath path weight <- weightedTrajectories time initial matrix + , last path == destination + ] + +observationProbability :: + (FiniteState state) => + Natural -> + [(state, Double)] -> + TransitionMatrix state -> + [(Natural, state)] -> + Double +observationProbability horizon initial matrix observations = + sum + [ weight + | WeightedPath path weight <- weightedTrajectories horizon initial matrix + , all (matchesAt path) observations + ] + where + matchesAt path (time, expected) = + path !! fromIntegral time == expected + +lawFromFirstOccurrence :: + Natural -> + [WeightedPath state] -> + ([state] -> Maybe Natural) -> + TruncatedLaw +lawFromFirstOccurrence horizon paths occurrence = + TruncatedLaw horizon masses unresolved + where + (masses, unresolved) = foldr addPath (Map.empty, 0) paths + addPath (WeightedPath path weight) (known, unknown) = + case occurrence path of + Nothing -> (known, unknown + weight) + Just time -> (Map.insertWith (+) time weight known, unknown) + +hittingLaw :: + (FiniteState state) => + Natural -> + TransitionMatrix state -> + (state -> Bool) -> + state -> + TruncatedLaw +hittingLaw horizon matrix isTarget initial = + lawFromFirstOccurrence horizon paths firstHit + where + paths = weightedTrajectories horizon [(initial, 1)] matrix + firstHit path = fromIntegral <$> findIndex isTarget path + +returnLaw :: + (FiniteState state) => + Natural -> + TransitionMatrix state -> + state -> + TruncatedLaw +returnLaw horizon matrix initial = + lawFromFirstOccurrence horizon paths firstReturn + where + paths = weightedTrajectories horizon [(initial, 1)] matrix + firstReturn path = + fromIntegral . (+ 1) <$> findIndex (== initial) (drop 1 path) + +visitLawBefore :: + (FiniteState state) => + Natural -> + [(state, Double)] -> + TransitionMatrix state -> + (state -> Bool) -> + TruncatedLaw +visitLawBefore bound initial matrix isVisited = + TruncatedLaw bound masses 0 + where + steps + | bound == 0 = 0 + | otherwise = bound - 1 + paths = weightedTrajectories steps initial matrix + count path = + fromIntegral (length (filter isVisited (take (fromIntegral bound) path))) + masses = + Map.fromListWith + (+) + [(count path, weight) | WeightedPath path weight <- paths] + +raceProbabilityWithin :: + (FiniteState state) => + Natural -> + TransitionMatrix state -> + (state -> Bool) -> + (state -> Bool) -> + state -> + Double +raceProbabilityWithin horizon matrix isSuccessful isCompeting initial = + sum + [ weight + | WeightedPath path weight <- + weightedTrajectories horizon [(initial, 1)] matrix + , wins path + ] + where + wins path = + case (findIndex isSuccessful path, findIndex isCompeting path) of + (Just successfulTime, Just competingTime) -> + successfulTime < competingTime + (Just _, Nothing) -> True + _ -> False + +lawProbability :: DiscreteEvent -> TruncatedLaw -> Maybe Double +lawProbability event law + | eventKnown event (lawHorizon law) = + Just (finiteMass + unresolvedContribution) + | otherwise = Nothing + where + finiteMass = + sum + [ mass + | (value, mass) <- Map.toList (lawFiniteMasses law) + , matches event value + ] + unresolvedContribution + | includesInfiniteOutcome event = lawUnresolvedMass law + | otherwise = 0 + +eventKnown :: DiscreteEvent -> Natural -> Bool +eventKnown event horizon = + case event of + EqualTo threshold -> threshold <= horizon + LessThan threshold -> threshold <= horizon + 1 + AtMost threshold -> threshold <= horizon + GreaterThan threshold -> threshold <= horizon + AtLeast threshold -> threshold <= horizon + 1 + +lawFiniteExpectation :: TruncatedLaw -> Maybe Double +lawFiniteExpectation law + | lawUnresolvedMass law == 0 = + Just + ( sum + [ fromIntegral value * mass + | (value, mass) <- Map.toList (lawFiniteMasses law) + ] + ) + | otherwise = Nothing diff --git a/test/Dtmc/Analysis/ReturnTimeCanonicalSpec.hs b/test/Dtmc/Analysis/ReturnTimeCanonicalSpec.hs new file mode 100644 --- /dev/null +++ b/test/Dtmc/Analysis/ReturnTimeCanonicalSpec.hs @@ -0,0 +1,194 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeApplications #-} + +module Dtmc.Analysis.ReturnTimeCanonicalSpec ( + spec, +) where + +import Data.Finite ( + Finite, + finites, + ) +import Data.Maybe ( + fromMaybe, + ) +import Dtmc.Analysis.Event ( + DiscreteEvent (..), + ) +import Dtmc.Analysis.Expectation ( + Expectation (..), + ) +import Dtmc.Analysis.ProbabilityOracle qualified as Oracle +import Dtmc.Analysis.ReturnTime qualified as Return +import Dtmc.Distribution.Map ( + fromList, + ) +import Dtmc.TestSupport +import Dtmc.Transition.Kernel ( + TransitionKernel, + fromLaws, + ) +import Dtmc.Transition.Matrix ( + TransitionMatrix, + TransitionMatrixError, + fromRows, + ) +import Test.Hspec ( + Spec, + describe, + it, + shouldBe, + ) +import Test.Hspec.QuickCheck ( + prop, + ) +import Test.QuickCheck ( + counterexample, + forAll, + property, + ) + +terminalChain :: TransitionMatrix (Finite 3) +terminalChain = + checked + ( fromRows + ( chunksOf + 3 + [ 0 + , 0.5 + , 0.5 + , 0 + , 0 + , 1 + , 0 + , 0 + , 1 + ] + ) + ) + +simpleRandomWalk :: TransitionKernel Integer +simpleRandomWalk = + fromLaws $ \state -> + checked + (fromList [(state - 1, 0.5), (state + 1, 0.5)]) + +tinySurvival :: Double +tinySurvival = 1e-12 + +tinyReturnKernel :: TransitionKernel Int +tinyReturnKernel = + fromLaws $ \state -> + case state of + 0 -> + checked + ( fromList + [(0, 1 - tinySurvival), (1, tinySurvival)] + ) + _ -> checked (fromList [(state, 1)]) + +checked :: (Show error) => Either error value -> value +checked = either (error . show) id + +close :: Double -> Double -> Bool +close = approxEq testTolerance + +known :: Maybe Double -> Double +known = fromMaybe (error "oracle horizon does not determine this event") + +eventsThrough :: Integer -> [DiscreteEvent] +eventsThrough rawHorizon = + [EqualTo time | time <- [0 .. horizon]] + <> [LessThan time | time <- [0 .. horizon + 1]] + <> [AtMost time | time <- [0 .. horizon]] + <> [GreaterThan time | time <- [0 .. horizon]] + <> [AtLeast time | time <- [0 .. horizon + 1]] + where + horizon = fromInteger rawHorizon + +generatedChecks :: TransitionMatrix (Finite 3) -> Bool +generatedChecks matrix = + and + [ let law = Oracle.returnLaw 4 matrix initial + oracle = known (Oracle.lawProbability event law) + scalar = Return.probabilityGivenInitialState event matrix initial + dense = (returnProbabilityByState event matrix) + in close scalar oracle + && close (dense !! fromIntegral initial) oracle + | initial <- finites + , event <- eventsThrough 4 + ] + +spec :: Spec +spec = do + describe "canonical return probability" $ do + it "enforces the time-zero exclusion exactly" $ do + (returnProbabilityByState (EqualTo 0) terminalChain) + `shouldBe` [0, 0, 0] + (returnProbabilityByState (LessThan 1) terminalChain) + `shouldBe` [0, 0, 0] + (returnProbabilityByState (AtMost 0) terminalChain) + `shouldBe` [0, 0, 0] + (returnProbabilityByState (GreaterThan 0) terminalChain) + `shouldBe` [1, 1, 1] + (returnProbabilityByState (AtLeast 0) terminalChain) + `shouldBe` [1, 1, 1] + (returnProbabilityByState (AtLeast 1) terminalChain) + `shouldBe` [1, 1, 1] + + it "implements every relation and carries non-return mass in upper tails" $ do + Return.probabilityGivenInitialState (EqualTo 1) terminalChain 2 `shouldBe` 1 + Return.probabilityGivenInitialState (AtMost 1) terminalChain 2 `shouldBe` 1 + Return.probabilityGivenInitialState (GreaterThan 1) terminalChain 2 `shouldBe` 0 + (returnProbabilityByState (AtMost 1) terminalChain) + `shouldBe` [0, 0, 1] + (returnProbabilityByState (GreaterThan 1) terminalChain) + `shouldBe` [1, 1, 0] + (returnProbabilityByState (AtLeast 2) terminalChain) + `shouldBe` [1, 1, 0] + + it "preserves locally finite kernels and tiny survivor mass directly" $ do + Return.probabilityGivenInitialState (EqualTo 2) simpleRandomWalk 0 `shouldBe` 0.5 + Return.probabilityGivenInitialState (AtMost 2) simpleRandomWalk 0 `shouldBe` 0.5 + Return.probabilityGivenInitialState (GreaterThan 2) simpleRandomWalk 0 `shouldBe` 0.5 + Return.probabilityGivenInitialState (AtLeast 3) simpleRandomWalk 0 `shouldBe` 0.5 + Return.probabilityGivenInitialState (GreaterThan 1) tinyReturnKernel 0 + `shouldBe` tinySurvival + + prop "matches the path oracle for every relation (random @3)" $ + forAll (genTransitionRows 3) $ \rawMatrix -> + case fromRows rawMatrix :: + Either TransitionMatrixError (TransitionMatrix (Finite 3)) of + Left problem -> counterexample (show problem) False + Right matrix -> property (generatedChecks matrix) + + describe "canonical eventual and expectation names" $ do + it "match the completed defective return laws" $ do + let states = finites :: [Finite 3] + case returnEventualProbabilityByState terminalChain of + Left problem -> error (show problem) + Right values -> values `shouldBe` [0, 0, 1] + mapM_ + ( \(state, expected) -> + Return.eventualProbabilityGivenInitialState terminalChain state + `shouldBe` Right expected + ) + (zip states [0, 0, 1]) + returnExpectationByState terminalChain + `shouldBe` Right + [ InfiniteExpectation + , InfiniteExpectation + , FiniteExpectation 1 + ] + mapM_ + ( \(state, expected) -> + Return.expectationGivenInitialState terminalChain state + `shouldBe` Right expected + ) + ( zip + states + [ InfiniteExpectation + , InfiniteExpectation + , FiniteExpectation 1 + ] + ) diff --git a/test/Dtmc/Analysis/ReturnTimeSpec.hs b/test/Dtmc/Analysis/ReturnTimeSpec.hs new file mode 100644 --- /dev/null +++ b/test/Dtmc/Analysis/ReturnTimeSpec.hs @@ -0,0 +1,13 @@ +module Dtmc.Analysis.ReturnTimeSpec ( + spec, +) where + +import Dtmc.Analysis.TimeSpecSupport ( + returnTimeSpec, + ) +import Test.Hspec ( + Spec, + ) + +spec :: Spec +spec = returnTimeSpec diff --git a/test/Dtmc/Analysis/StationarySpec.hs b/test/Dtmc/Analysis/StationarySpec.hs new file mode 100644 --- /dev/null +++ b/test/Dtmc/Analysis/StationarySpec.hs @@ -0,0 +1,328 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TypeApplications #-} + +module Dtmc.Analysis.StationarySpec ( + spec, +) where + +import Data.Finite ( + Finite, + ) +import Dtmc.Analysis.Expectation ( + Expectation (..), + ) +import Dtmc.Analysis.ReturnTime qualified as Return +import Dtmc.Analysis.Stationary ( + stationaryDistributions, + ) +import Dtmc.Distribution ( + probabilityAt, + ) +import Dtmc.Distribution.Vector qualified as Vector +import Dtmc.Dynamics ( + evolveVector, + ) +import Dtmc.State ( + FiniteState, + ) +import Dtmc.TestSupport ( + approxDistributionEq, + approxEq, + chunksOf, + genTransitionRows, + testTolerance, + ) +import Dtmc.Transition.Matrix ( + TransitionMatrix, + fromRows, + ) +import GHC.Generics ( + Generic, + ) +import Test.Hspec ( + Spec, + describe, + expectationFailure, + it, + shouldBe, + shouldSatisfy, + ) +import Test.Hspec.QuickCheck ( + prop, + ) +import Test.QuickCheck ( + Gen, + Property, + choose, + conjoin, + counterexample, + forAll, + property, + vectorOf, + ) + +data Weather = Dry | Wet + deriving (Eq, Ord, Show, Generic) + +instance FiniteState Weather + +checked :: (Show error) => Either error value -> value +checked = either (error . show) id + +onlyStationary :: + (FiniteState state) => + TransitionMatrix state -> + Vector.DistributionVector state +onlyStationary matrix = + case checked (stationaryDistributions matrix) of + [(_, distribution)] -> distribution + _ -> error "test matrix does not have a unique stationary distribution" + +twoState :: TransitionMatrix (Finite 2) +twoState = + checked + ( fromRows + (chunksOf 2 [0.9, 0.1, 0.4, 0.6]) + ) + +singleton :: TransitionMatrix (Finite 1) +singleton = + checked + ( fromRows + (chunksOf 1 [1]) + ) + +threeCycle :: TransitionMatrix (Finite 3) +threeCycle = + checked + ( fromRows + (chunksOf 3 [0, 1, 0, 0, 0, 1, 1, 0, 0]) + ) + +namedTwoState :: TransitionMatrix Weather +namedTwoState = + checked + ( fromRows + (chunksOf 2 [0.9, 0.1, 0.4, 0.6]) + ) + +genPositiveTransitionMatrix :: Gen [[Double]] +genPositiveTransitionMatrix = vectorOf 3 positiveSimplex + where + positiveSimplex = do + weights <- vectorOf 3 (choose (1, 1000 :: Double)) + let total = sum weights + pure (map (/ total) weights) + +stationaryLawsHold :: [[Double]] -> Property +stationaryLawsHold raw = + case fromRows @(Finite 3) raw of + Left err -> counterexample (show err) (property False) + Right matrix -> + case stationaryDistributions matrix of + Left err -> counterexample (show err) (property False) + Right [(_, distribution)] -> + conjoin + [ counterexample "pi P /= pi" $ + property + ( approxDistributionEq + testTolerance + (evolveVector distribution matrix) + distribution + ) + , counterexample "sum pi /= 1" $ + property + (approxEq testTolerance (sum (Vector.toList distribution)) 1) + ] + Right _ -> counterexample "positive matrix was not uniquely stationary" (property False) + +spec :: Spec +spec = do + describe "stationaryDistributions" $ do + it "returns the point mass for a singleton chain" $ + Vector.toList (onlyStationary singleton) + `shouldBe` [1] + + it "matches the closed form for a two-state chain" $ + and + ( zipWith + (approxEq testTolerance) + (Vector.toList (onlyStationary twoState)) + [0.8, 0.2] + ) + `shouldBe` True + + it "is uniform for a periodic three-cycle" $ + and + [ approxEq testTolerance actual (1 / 3) + | actual <- Vector.toList (onlyStationary threeCycle) + ] + `shouldBe` True + + it "preserves named-state coordinates" $ do + let distribution = + onlyStationary namedTwoState + approxEq testTolerance (probabilityAt distribution Dry) 0.8 + `shouldBe` True + approxEq testTolerance (probabilityAt distribution Wet) 0.2 + `shouldBe` True + + prop "satisfies the balance and normalization equations" $ + forAll genPositiveTransitionMatrix stationaryLawsHold + + it "solves a symmetric nearly uncoupled chain exactly" $ do + -- The balance system is hopelessly ill conditioned here, but GTH + -- never forms it: the exit mass is accumulated rather than taken + -- as 1 - P(k,k), so the answer comes out bit-exact. + let epsilon = 1e-14 + matrix = + checked + ( fromRows @(Finite 2) + ( chunksOf + 2 + [ 1 - epsilon + , epsilon + , epsilon + , 1 - epsilon + ] + ) + ) + Vector.toList (onlyStationary matrix) + `shouldBe` [0.5, 0.5] + + it "solves an asymmetric nearly uncoupled chain" $ do + -- For [[1-a, a], [b, 1-b]] the stationary law is + -- (b, a) / (a + b), here (3/4, 1/4) at a scale where forming + -- transpose(P) - I would destroy every significant digit. + let leaving = 1e-14 + returning = 3e-14 + matrix = + checked + ( fromRows @(Finite 2) + ( chunksOf + 2 + [ 1 - leaving + , leaving + , returning + , 1 - returning + ] + ) + ) + Vector.toList (onlyStationary matrix) + `shouldSatisfy` allCloseTo [0.75, 0.25] + + it "normalises extreme finite GTH weights without overflow" $ do + let epsilon = 5e-309 + matrix = + checked + ( fromRows @(Finite 3) + ( chunksOf + 3 + [ 0 + , 0.5 + , 0.5 + , epsilon + , 0 + , 1 + , epsilon + , 1 + , 0 + ] + ) + ) + weights = Vector.toList (onlyStationary matrix) + weights `shouldSatisfy` all isFinite + sum weights `shouldSatisfy` approxEq testTolerance 1 + weights `shouldSatisfy` allCloseTo [0, 0.5, 0.5] + case weights of + first : _ -> first `shouldSatisfy` (> 0) + [] -> expectationFailure "expected three stationary weights" + + describe "multiple recurrent classes" $ do + it "returns one distribution per recurrent class, by least member" $ + fmap (map fst) (stationaryDistributions twoClosedClasses) + `shouldBe` Right [[0], [1, 2]] + + it "matches the closed form of the notes" $ + case stationaryDistributions twoClosedClasses of + Right [(_, onFirst), (_, onSecond)] -> do + Vector.toList onFirst `shouldSatisfy` allCloseTo [1, 0, 0] + Vector.toList onSecond `shouldSatisfy` allCloseTo [0, 5 / 11, 6 / 11] + other -> expectationFailure ("unexpected result: " ++ show other) + + it "puts exact zero on a transient state" $ + case stationaryDistributions withTransient of + Right [(members, only)] -> do + members `shouldBe` [1, 2] + take 1 (Vector.toList only) `shouldBe` [0] + Vector.toList only `shouldSatisfy` allCloseTo [0, 5 / 11, 6 / 11] + other -> expectationFailure ("unexpected result: " ++ show other) + + it "returns one distribution for an irreducible chain" $ + case stationaryDistributions twoState of + Right [(_, only)] -> + Vector.toList only `shouldSatisfy` allCloseTo [0.8, 0.2] + other -> expectationFailure ("unexpected result: " ++ show other) + + it "inverts the mean return time" $ + -- pi_i m_i = 1 for state 1 of the recurrent class {1, 2} + case stationaryDistributions twoClosedClasses of + Right [_, (_, onSecond)] -> + Return.expectationGivenInitialState twoClosedClasses 1 + `shouldSatisfy` inverts (Vector.toList onSecond !! 1) + other -> expectationFailure ("unexpected result: " ++ show other) + + prop "every returned distribution is stationary and normalised" $ + forAll (genTransitionRows 3) $ \raw -> + case fromRows @(Finite 3) raw of + Left err -> counterexample (show err) (property False) + Right matrix -> + case stationaryDistributions matrix of + -- A refused solve is a documented outcome. + Left _ -> property True + Right results -> + conjoin + [ conjoin + [ counterexample "pi P /= pi" $ + property + ( approxDistributionEq + testTolerance + (evolveVector d matrix) + d + ) + , counterexample "sum pi /= 1" $ + property + (approxEq testTolerance (sum (Vector.toList d)) 1) + ] + | (_, d) <- results + ] + +-- Section 4.1: two closed classes, hence infinitely many stationary +-- distributions for the chain as a whole. +twoClosedClasses :: TransitionMatrix (Finite 3) +twoClosedClasses = + checked + ( fromRows + (chunksOf 3 [1, 0, 0, 0, 0.4, 0.6, 0, 0.5, 0.5]) + ) + +-- State 0 is transient; {1, 2} is the only recurrent class. +withTransient :: TransitionMatrix (Finite 3) +withTransient = + checked + ( fromRows + (chunksOf 3 [0, 0.5, 0.5, 0, 0.4, 0.6, 0, 0.5, 0.5]) + ) + +allCloseTo :: [Double] -> [Double] -> Bool +allCloseTo expected actual = + length expected == length actual + && and (zipWith (approxEq testTolerance) expected actual) + +isFinite :: Double -> Bool +isFinite value = not (isNaN value || isInfinite value) + +inverts :: Double -> Either error Expectation -> Bool +inverts probability (Right (FiniteExpectation mean)) = + approxEq testTolerance (probability * mean) 1 +inverts _ _ = False diff --git a/test/Dtmc/Analysis/TimeSpecSupport.hs b/test/Dtmc/Analysis/TimeSpecSupport.hs new file mode 100644 --- /dev/null +++ b/test/Dtmc/Analysis/TimeSpecSupport.hs @@ -0,0 +1,953 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module Dtmc.Analysis.TimeSpecSupport ( + hittingTimeSpec, + returnTimeSpec, +) where + +import Data.Finite ( + Finite, + finites, + ) +import Dtmc.Analysis.Classification ( + accessible, + recurrentState, + ) +import Dtmc.Analysis.Event ( + DiscreteEvent (..), + ) +import Dtmc.Analysis.FiniteTime qualified as FT +import Dtmc.Analysis.HittingTime ( + Expectation (..), + LinearSystemError (..), + ) +import Dtmc.Analysis.HittingTime qualified as Hit +import Dtmc.Analysis.ReturnTime qualified as Return +import Dtmc.Distribution.Map qualified as DistributionMap +import Dtmc.State ( + FiniteState, + finiteStates, + ) +import Dtmc.TestSupport +import Dtmc.Transition.Kernel qualified as Kernel +import Dtmc.Transition.Matrix ( + TransitionMatrix, + TransitionMatrixError, + fromRows, + identity, + toRows, + ) +import GHC.Generics ( + Generic, + ) +import GHC.TypeNats ( + KnownNat, + ) +import Test.Hspec ( + Spec, + describe, + expectationFailure, + it, + shouldBe, + shouldSatisfy, + ) +import Test.Hspec.QuickCheck ( + prop, + ) +import Test.QuickCheck ( + Property, + conjoin, + counterexample, + forAll, + property, + (===), + ) + +data NamedRuinState = Ruined | One | Two | Three | Won + deriving (Eq, Ord, Show, Generic) + +instance FiniteState NamedRuinState + +checked :: (Show e) => Either e a -> a +checked = either (error . show) id + +asTransitionKernel :: + (FiniteState state) => + TransitionMatrix state -> + Kernel.TransitionKernel state +asTransitionKernel matrix = + Kernel.fromLaws $ \source -> + either (error . show) id $ + DistributionMap.fromList + [ (destination, FT.stepProbability matrix source destination) + | destination <- finiteStates + ] + +simpleRandomWalk :: Kernel.TransitionKernel Integer +simpleRandomWalk = + Kernel.fromLaws $ \state -> + either (error . show) id $ + DistributionMap.fromList [(state - 1, 0.5), (state + 1, 0.5)] + +-- Gambler's ruin on {0..4}: win 1 with probability p, lose 1 with +-- probability 1-p; 0 (ruin) and 4 (goal) are absorbing. +gambler :: Double -> TransitionMatrix (Finite 5) +gambler p = + checked $ + fromRows + ( chunksOf + 5 + [ 1 + , 0 + , 0 + , 0 + , 0 + , 1 - p + , 0 + , p + , 0 + , 0 + , 0 + , 1 - p + , 0 + , p + , 0 + , 0 + , 0 + , 1 - p + , 0 + , p + , 0 + , 0 + , 0 + , 0 + , 1 + ] + ) + +namedGambler :: TransitionMatrix NamedRuinState +namedGambler = + checked $ + fromRows @NamedRuinState + ( chunksOf + 5 + [ 1 + , 0 + , 0 + , 0 + , 0 + , 0.5 + , 0 + , 0.5 + , 0 + , 0 + , 0 + , 0.5 + , 0 + , 0.5 + , 0 + , 0 + , 0 + , 0.5 + , 0 + , 0.5 + , 0 + , 0 + , 0 + , 0 + , 1 + ] + ) + +-- Oscillator: states 0 and 1 swap with probability 1/2 or exit to +-- their own absorbing state (0 -> 2, 1 -> 3). +oscillator :: TransitionMatrix (Finite 4) +oscillator = + checked $ + fromRows + ( chunksOf + 4 + [ 0 + , 0.5 + , 0.5 + , 0 + , 0.5 + , 0 + , 0 + , 0.5 + , 0 + , 0 + , 1 + , 0 + , 0 + , 0 + , 0 + , 1 + ] + ) + +twoCycle :: TransitionMatrix (Finite 2) +twoCycle = + checked $ + fromRows + ( chunksOf + 2 + [ 0 + , 1 + , 1 + , 0 + ] + ) + +nonUniformRecurrent :: TransitionMatrix (Finite 2) +nonUniformRecurrent = + checked $ + fromRows + ( chunksOf + 2 + [ 0.9 + , 0.1 + , 0.4 + , 0.6 + ] + ) + +-- 0 -> 1 -> 2 (absorbing): reaching 2 requires passing through 1 first. +pathChain :: TransitionMatrix (Finite 3) +pathChain = + checked $ + fromRows + ( chunksOf + 3 + [ 0 + , 1 + , 0 + , 0 + , 0 + , 1 + , 0 + , 0 + , 1 + ] + ) + +-- Two transient equations with very different scales. The system is +-- nonsingular in exact arithmetic but too ill-conditioned for the public +-- Double-precision numerical contract. +illConditionedChain :: TransitionMatrix (Finite 3) +illConditionedChain = + checked $ + fromRows + ( chunksOf + 3 + [ 1 - epsilon + , 0 + , epsilon + , 0 + , 0 + , 1 + , 0 + , 0 + , 1 + ] + ) + where + epsilon = 1e-14 + +-- Ruin probability from i with N = 4: (r^i - r^N) / (1 - r^N), r = (1-p)/p. +-- Only for p /= 1/2 (the symmetric case is 1 - i/N). +ruinProbability :: Double -> Int -> Double +ruinProbability p i = (r ^^ i - r ^^ n) / (1 - r ^^ n) + where + r = (1 - p) / p + n = 4 :: Int + +-- Expected duration until absorption at 0 or 4, for p /= 1/2: +-- i/(q-p) - (N/(q-p)) (1 - r^i) / (1 - r^N), q = 1-p, r = q/p. +ruinDuration :: Double -> Int -> Double +ruinDuration p i = + fromIntegral i / (q - p) + - (fromIntegral n / (q - p)) * (1 - r ^^ i) / (1 - r ^^ n) + where + q = 1 - p + r = q / p + n = 4 :: Int + +closeTo :: Double -> Double -> Bool +closeTo expected x = abs (x - expected) <= testTolerance + +expectationCloseTo :: Double -> Expectation -> Bool +expectationCloseTo expected (FiniteExpectation v) = closeTo expected v +expectationCloseTo _ InfiniteExpectation = False + +checkedChain :: + forall n. + (KnownNat n) => + [[Double]] -> + (TransitionMatrix (Finite n) -> Property) -> + Property +checkedChain matrix check = + case fromRows matrix of + Right p -> check p + Left err -> + counterexample ("generated matrix was rejected: " <> show err) False + +hittingTimeSpec :: Spec +hittingTimeSpec = do + describe "numerical analysis errors" $ + it "rejects an ill-conditioned eventual-hitting system explicitly" $ + hitEventualProbabilityByState illConditionedChain [2] + `shouldSatisfy` isIllConditioned + + describe "eventual hitting probability" $ do + it "matches the gambler's ruin closed form (p = 0.4)" $ do + case hitEventualProbabilityByState (gambler 0.4) [0] of + Left err -> expectationFailure (show err) + Right result -> do + let h = result + length h `shouldBe` 5 + sequence_ + [ x `shouldSatisfy` closeTo (ruinProbability 0.4 i) + | (i, x) <- zip [0 ..] h + ] + + it "matches the symmetric closed form 1 - i/4 (p = 0.5)" $ do + case hitEventualProbabilityByState (gambler 0.5) [0] of + Left err -> expectationFailure (show err) + Right result -> + sequence_ + [ x `shouldSatisfy` closeTo (1 - fromIntegral i / 4) + | (i, x) <- zip [0 :: Int ..] (result) + ] + + it "solves the oscillator race to a single absorbing state" $ do + case hitEventualProbabilityByState oscillator [2] of + Left err -> expectationFailure (show err) + Right result -> + sequence_ + [ x `shouldSatisfy` closeTo v + | (x, v) <- zip (result) [2 / 3, 1 / 3, 1, 0] + ] + + it "is all zero for an empty target" $ + hitEventualProbabilityByState oscillator [] + `shouldBe` Right [0, 0, 0, 0] + + it "supports a single-state lookup without changing the result" $ + Hit.eventualProbabilityGivenInitialState oscillator [2] 0 + `shouldSatisfy` either (const False) (closeTo (2 / 3)) + + prop "is exactly one on the target and zero off its basin (random @4)" $ + forAll (genTransitionRows 4) $ \matrix -> + checkedChain matrix $ \p -> + case hitEventualProbabilityByState p [0] of + Left err -> counterexample (show err) False + Right result -> + conjoin + [ counterexample (show (i, x)) $ + if + | i == 0 -> x === 1 + | accessible p i 0 -> + property + (x >= -testTolerance && x <= 1 + testTolerance) + | otherwise -> x === 0 + | (i, x) <- + zip (finites :: [Finite 4]) (result) + ] + + prop "satisfies the first-step equations off the target (random @4)" $ + forAll (genTransitionRows 4) $ \matrix -> + checkedChain @4 matrix $ \p -> + case hitEventualProbabilityByState p [0] of + Left err -> counterexample (show err) False + Right h -> + let pushed = + [ sum (zipWith (*) row h) + | row <- toRows p + ] + in conjoin + [ property (closeTo hi pi_) + | (i, hi, pi_) <- + zip3 (finites :: [Finite 4]) (h) pushed + , i /= 0 + ] + + describe "bounded hitting times" $ do + it "returns an empty result for the empty chain" $ + ((hitProbabilityByState . LessThan) 3 (identity @(Finite 0)) []) + `shouldBe` [] + + it "places all time-zero mass on the target" $ + ((hitProbabilityByState . EqualTo) 0 oscillator [2]) + `shouldBe` [0, 0, 1, 0] + + it "gives zero exact-time mass for an empty target" $ + ((hitProbabilityByState . EqualTo) 5 oscillator []) + `shouldBe` [0, 0, 0, 0] + + it "matches a one-step gambler's-ruin hit" $ + ((hitProbabilityByState . EqualTo) 1 (gambler 0.5) [0]) + `shouldBe` [0, 0.5, 0, 0, 0] + + it "uses a strict time bound" $ do + ((hitProbabilityByState . LessThan) 0 oscillator [2]) + `shouldBe` [0, 0, 0, 0] + ((hitProbabilityByState . LessThan) 1 oscillator [2]) + `shouldBe` [0, 0, 1, 0] + (Hit.probabilityGivenInitialState . LessThan) 2 (gambler 0.5) (== 0) 1 + `shouldSatisfy` closeTo 0.5 + + it "ignores duplicate and reordered targets" $ + ((hitProbabilityByState . LessThan) 4 oscillator [2, 3, 2]) + `shouldBe` ((hitProbabilityByState . LessThan) 4 oscillator [3, 2]) + + it "single-state queries look up the all-state results" $ do + let exact = ((hitProbabilityByState . EqualTo) 3 oscillator [2]) + bounded = ((hitProbabilityByState . LessThan) 4 oscillator [2]) + sequence_ + [ (Hit.probabilityGivenInitialState . EqualTo) 3 oscillator (== 2) i + `shouldSatisfy` closeTo exactAt + | (i, exactAt) <- zip (finites :: [Finite 4]) exact + ] + sequence_ + [ (Hit.probabilityGivenInitialState . LessThan) 4 oscillator (== 2) i + `shouldSatisfy` closeTo boundedAt + | (i, boundedAt) <- zip (finites :: [Finite 4]) bounded + ] + + prop "bounded increments equal exact-time mass (random @4)" $ + forAll (genTransitionRows 4) $ \matrix -> + checkedChain matrix $ \p -> + conjoin + [ counterexample (show (t, i, before, after, mass)) $ + property (closeTo mass (after - before)) + | t <- [0 .. 4] + , i <- finites :: [Finite 4] + , let before = (Hit.probabilityGivenInitialState . LessThan) t p (== 0) i + , let after = (Hit.probabilityGivenInitialState . LessThan) (t + 1) p (== 0) i + , let mass = (Hit.probabilityGivenInitialState . EqualTo) t p (== 0) i + ] + + prop "bounded probabilities increase toward the eventual value (random @4)" $ + forAll (genTransitionRows 4) $ \matrix -> + checkedChain matrix $ \p -> + conjoin + [ counterexample (show (bound, i, current, next, eventual)) $ + case eventual of + Left err -> counterexample (show err) False + Right value -> + property + ( current >= -testTolerance + && current <= next + testTolerance + && next <= value + testTolerance + ) + | bound <- [0 .. 4] + , i <- finites :: [Finite 4] + , let current = (Hit.probabilityGivenInitialState . LessThan) bound p (== 0) i + , let next = (Hit.probabilityGivenInitialState . LessThan) (bound + 1) p (== 0) i + , let eventual = Hit.eventualProbabilityGivenInitialState p [0] i + ] + + describe "hitting race probability" $ do + it "is exactly one on an effective successful state" $ + Hit.raceProbabilityGivenInitialState (gambler 0.5) [4] [0] 4 `shouldBe` Right 1 + + it "is exactly zero on a competing state" $ + Hit.raceProbabilityGivenInitialState (gambler 0.5) [4] [0] 0 `shouldBe` Right 0 + + it "is exactly zero on an overlapping (tied) state" $ + -- State 2 is in both boundaries, so the tie loses: value zero. + Hit.raceProbabilityGivenInitialState oscillator [2] [2, 3] 2 + `shouldBe` Right 0 + + it "gives all zeros for identical successful and competing sets" $ + ( hitRaceProbabilityByState + oscillator + [2, 3] + [2, 3] + ) + `shouldBe` Right (replicate 4 0) + + it "gives all zeros for an empty successful set" $ + hitRaceProbabilityByState oscillator [] [2, 3] + `shouldBe` Right (replicate 4 0) + + it "agrees with eventual hitting for an empty competing set" $ do + case ( hitRaceProbabilityByState + oscillator + [2, 3] + [] + , hitEventualProbabilityByState oscillator [2, 3] + ) of + (Left err, _) -> expectationFailure (show err) + (_, Left err) -> expectationFailure (show err) + (Right before, Right plain) -> + sequence_ + [ x `shouldSatisfy` closeTo y + | (x, y) <- zip (before) (plain) + ] + + it "is exactly zero when the successful set is unreachable" $ + -- Absorbing state 3 cannot reach absorbing state 2. + Hit.raceProbabilityGivenInitialState oscillator [2] [] 3 + `shouldBe` Right 0 + + it "is exactly zero when success needs a competitor first" $ + -- 0 -> 1 -> 2 with 1 competing: 2 is reachable only through 1. + Hit.raceProbabilityGivenInitialState pathChain [2] [1] 0 `shouldBe` Right 0 + + it "ignores duplicate targets" $ do + case ( hitRaceProbabilityByState + oscillator + [2, 2] + [3, 3] + , hitRaceProbabilityByState + oscillator + [2] + [3] + ) of + (Left err, _) -> expectationFailure (show err) + (_, Left err) -> expectationFailure (show err) + (Right withDuplicates, Right once) -> + sequence_ + [ x `shouldSatisfy` closeTo y + | (x, y) <- zip (withDuplicates) (once) + ] + + it "ignores target order" $ do + case ( hitRaceProbabilityByState + oscillator + [2, 0] + [3, 1] + , hitRaceProbabilityByState + oscillator + [0, 2] + [1, 3] + ) of + (Left err, _) -> expectationFailure (show err) + (_, Left err) -> expectationFailure (show err) + (Right reordered, Right ordered) -> + sequence_ + [ x `shouldSatisfy` closeTo y + | (x, y) <- zip (reordered) (ordered) + ] + + it "single-state lookups match the all-state vector" $ + case hitRaceProbabilityByState + oscillator + [2] + [3] of + Left err -> expectationFailure (show err) + Right result -> + sequence_ + [ Hit.raceProbabilityGivenInitialState + oscillator + [2] + [3] + i + `shouldSatisfy` either (const False) (closeTo x) + | (i, x) <- + zip (finites :: [Finite 4]) (result) + ] + + it "solves the oscillator race against a competing absorber" $ do + case hitRaceProbabilityByState oscillator [2] [3] of + Left err -> expectationFailure (show err) + Right result -> + sequence_ + [ x `shouldSatisfy` closeTo v + | (x, v) <- zip (result) [2 / 3, 1 / 3, 1, 0] + ] + + it "matches a hand-computed symmetric race (gambler p = 0.5)" $ do + case hitRaceProbabilityByState (gambler 0.5) [4] [0] of + Left err -> expectationFailure (show err) + Right result -> + sequence_ + [ x `shouldSatisfy` closeTo (fromIntegral i / 4) + | (i, x) <- zip [0 :: Int ..] (result) + ] + + it "disjoint races sum to one when the union is hit almost surely" $ + sequence_ + [ case ( hitRaceProbabilityByState g [4] [0] + , hitRaceProbabilityByState g [0] [4] + ) of + (Left err, _) -> expectationFailure (show err) + (_, Left err) -> expectationFailure (show err) + (Right wins, Right losses) -> + sequence_ + [ (x + y) `shouldSatisfy` closeTo 1 + | (x, y) <- zip (wins) (losses) + ] + | pp <- [0.3, 0.5, 0.7] + , let g = gambler pp + ] + + describe "expected hitting time" $ do + it "returns one entry per state" $ do + -- The transient come from the linear solve, so they are + -- compared within tolerance; the target are assigned + -- exactly and checked exactly. + case hitExpectationByState oscillator [2, 3] of + Left err -> expectationFailure (show err) + Right eta -> do + sequence_ + [ e `shouldSatisfy` expectationCloseTo 2 + | e <- take 2 eta + ] + drop 2 eta `shouldBe` [FiniteExpectation 0, FiniteExpectation 0] + + it "matches the gambler duration closed form (p = 0.4)" $ do + let eta = Hit.expectationGivenInitialState (gambler 0.4) [0, 4] + sequence_ + [ eta i + `shouldSatisfy` either + (const False) + (expectationCloseTo (ruinDuration 0.4 (fromIntegral i))) + | i <- finites :: [Finite 5] + ] + + it "matches the symmetric duration i (4 - i) (p = 0.5)" $ do + let eta = Hit.expectationGivenInitialState (gambler 0.5) [0, 4] + sequence_ + [ eta i + `shouldSatisfy` either + (const False) + (expectationCloseTo (fromIntegral i * (4 - fromIntegral i))) + | i <- finites :: [Finite 5] + ] + + it "expects two steps to absorption from either oscillator state" $ do + let eta = Hit.expectationGivenInitialState oscillator [2, 3] + eta 0 `shouldSatisfy` either (const False) (expectationCloseTo 2) + eta 1 `shouldSatisfy` either (const False) (expectationCloseTo 2) + eta 2 `shouldBe` Right (FiniteExpectation 0) + eta 3 `shouldBe` Right (FiniteExpectation 0) + + it "is infinite when a competing absorbing state is reachable" $ do + let eta = Hit.expectationGivenInitialState oscillator [2] + eta 0 `shouldBe` Right InfiniteExpectation + eta 1 `shouldBe` Right InfiniteExpectation + eta 2 `shouldBe` Right (FiniteExpectation 0) + eta 3 `shouldBe` Right InfiniteExpectation + + prop "finite satisfy the first-step equations (random @4)" $ + forAll (genTransitionRows 4) $ \matrix -> + checkedChain @4 matrix $ \p -> + case hitExpectationByState p [0] of + Left err -> counterexample (show err) False + Right times -> + let eta i = times !! fromIntegral i + rows = toRows p + firstStep i row = + case eta i of + InfiniteExpectation -> property True + FiniteExpectation e -> + case successorExpectations row of + Nothing -> + counterexample + "finite state with doomed successor" + False + Just total -> + property (closeTo e (1 + total)) + successorExpectations row = + sum + <$> sequence + [ case eta j of + FiniteExpectation e -> Just (pij * e) + InfiniteExpectation -> Nothing + | (j, pij) <- + zip (finites :: [Finite 4]) row + , pij > 0 + , j /= 0 + ] + in conjoin + [ firstStep i row + | (i, row) <- + zip (finites :: [Finite 4]) rows + , i /= 0 + ] + +returnTimeSpec :: Spec +returnTimeSpec = do + describe "bounded first-return times" $ do + it "returns an empty result for the empty chain" $ + ((returnProbabilityByState . LessThan) 3 (identity @(Finite 0))) + `shouldBe` [] + + it "has no return mass at time zero" $ + ((returnProbabilityByState . EqualTo) 0 oscillator) + `shouldBe` [0, 0, 0, 0] + + it "uses the transition diagonal at time one" $ + ((returnProbabilityByState . EqualTo) 1 nonUniformRecurrent) + `shouldBe` [0.9, 0.6] + + it "counts only the first return" $ do + ((returnProbabilityByState . EqualTo) 1 oscillator) + `shouldBe` [0, 0, 1, 1] + ((returnProbabilityByState . EqualTo) 2 oscillator) + `shouldBe` [0.25, 0.25, 0, 0] + ((returnProbabilityByState . EqualTo) 2 twoCycle) + `shouldBe` [1, 1] + + it "uses a strict time bound" $ do + ((returnProbabilityByState . LessThan) 0 oscillator) + `shouldBe` [0, 0, 0, 0] + ((returnProbabilityByState . LessThan) 1 oscillator) + `shouldBe` [0, 0, 0, 0] + ((returnProbabilityByState . LessThan) 2 oscillator) + `shouldBe` [0, 0, 1, 1] + ((returnProbabilityByState . LessThan) 3 twoCycle) + `shouldBe` [1, 1] + + it "single-state queries look up the all-state results" $ do + let exact = ((returnProbabilityByState . EqualTo) 3 oscillator) + bounded = ((returnProbabilityByState . LessThan) 4 oscillator) + sequence_ + [ (Return.probabilityGivenInitialState . EqualTo) 3 oscillator i + `shouldSatisfy` closeTo exactAt + | (i, exactAt) <- zip (finites :: [Finite 4]) exact + ] + sequence_ + [ (Return.probabilityGivenInitialState . LessThan) 4 oscillator i + `shouldSatisfy` closeTo boundedAt + | (i, boundedAt) <- zip (finites :: [Finite 4]) bounded + ] + + prop "bounded increments equal exact-time mass (random @4)" $ + forAll (genTransitionRows 4) $ \matrix -> + checkedChain matrix $ \p -> + conjoin + [ counterexample (show (t, i, before, after, mass)) $ + property (closeTo mass (after - before)) + | t <- [0 .. 4] + , i <- finites :: [Finite 4] + , let before = (Return.probabilityGivenInitialState . LessThan) t p i + , let after = (Return.probabilityGivenInitialState . LessThan) (t + 1) p i + , let mass = (Return.probabilityGivenInitialState . EqualTo) t p i + ] + + prop "bounded probabilities increase toward the eventual value (random @4)" $ + forAll (genTransitionRows 4) $ \matrix -> + checkedChain matrix $ \p -> + conjoin + [ counterexample (show (bound, i, current, next, eventual)) $ + case eventual of + Left err -> counterexample (show err) False + Right value -> + property + ( current >= -testTolerance + && current <= next + testTolerance + && next <= value + testTolerance + ) + | bound <- [0 .. 4] + , i <- finites :: [Finite 4] + , let current = (Return.probabilityGivenInitialState . LessThan) bound p i + , let next = (Return.probabilityGivenInitialState . LessThan) (bound + 1) p i + , let eventual = Return.eventualProbabilityGivenInitialState p i + ] + + describe "eventual return probability" $ do + it "returns all state values in one solve" $ do + -- The transient come from the fundamental-matrix solve, + -- so they are compared within tolerance; the recurrent entries + -- are assigned exactly one by the classification and checked + -- exactly. + case returnEventualProbabilityByState oscillator of + Left err -> expectationFailure (show err) + Right result -> do + let f = result + sequence_ + [ x `shouldSatisfy` closeTo 0.25 + | x <- take 2 f + ] + drop 2 f `shouldBe` [1, 1] + + prop "agrees with the first-step decomposition (random @4)" $ + -- Two independent theorems for the same quantity: the + -- implementation computes f_i = 1 - 1/N_ii from the renewal + -- identity, while conditioning on the first step gives + -- f_i = sum_j P_ij h_j{i}. + forAll (genTransitionRows 4) $ \matrix -> + checkedChain matrix $ \p -> + case returnEventualProbabilityByState p of + Left err -> counterexample (show err) False + Right returns -> + let rows = toRows p + in conjoin + [ case hitEventualProbabilityByState p [i] of + Left err -> counterexample (show err) False + Right hits -> + let firstStep = + sum + ( zipWith + (*) + row + (hits) + ) + in counterexample + (show (i, f, firstStep)) + (property (closeTo firstStep f)) + | (i, row, f) <- + zip3 + (finites :: [Finite 4]) + rows + (returns) + ] + + it "is one for an absorbing state" $ + Return.eventualProbabilityGivenInitialState (gambler 0.5) 0 + `shouldSatisfy` either (const False) (closeTo 1) + + it "is one quarter for an oscillator state" $ + -- From 0: half the time exit to 2 (never return); otherwise reach + -- 1, whence the return probability to 0 is 1/2. So f = 1/4. + Return.eventualProbabilityGivenInitialState oscillator 0 + `shouldSatisfy` either (const False) (closeTo 0.25) + + it "is one for both states of the two-cycle" $ do + Return.eventualProbabilityGivenInitialState twoCycle 0 + `shouldSatisfy` either (const False) (closeTo 1) + Return.eventualProbabilityGivenInitialState twoCycle 1 + `shouldSatisfy` either (const False) (closeTo 1) + + prop "is close to one on recurrent states and within [0, 1] (random @4)" $ + forAll (genTransitionRows 4) $ \matrix -> + checkedChain matrix $ \p -> + conjoin + [ counterexample (show (i, f)) $ + case f of + Left err -> counterexample (show err) False + Right value -> + property + ( value >= -testTolerance + && value <= 1 + testTolerance + && ( not (recurrentState p i) + || closeTo 1 value + ) + ) + | i <- finites :: [Finite 4] + , let f = Return.eventualProbabilityGivenInitialState p i + ] + + describe "expected return time" $ do + it "returns all state values in one table" $ + returnExpectationByState oscillator + `shouldBe` Right [InfiniteExpectation, InfiniteExpectation, FiniteExpectation 1, FiniteExpectation 1] + + it "is one for an absorbing state" $ + Return.expectationGivenInitialState oscillator 2 `shouldBe` Right (FiniteExpectation 1) + + it "is two for either state of the two-cycle" $ do + Return.expectationGivenInitialState twoCycle 0 + `shouldSatisfy` either (const False) (expectationCloseTo 2) + Return.expectationGivenInitialState twoCycle 1 + `shouldSatisfy` either (const False) (expectationCloseTo 2) + + it "handles a non-uniform recurrent class" $ do + Return.expectationGivenInitialState nonUniformRecurrent 0 + `shouldSatisfy` either (const False) (expectationCloseTo 1.25) + Return.expectationGivenInitialState nonUniformRecurrent 1 + `shouldSatisfy` either (const False) (expectationCloseTo 5) + + it "is infinite for the oscillator's transient states" $ do + Return.expectationGivenInitialState oscillator 0 `shouldBe` Right InfiniteExpectation + Return.expectationGivenInitialState oscillator 1 `shouldBe` Right InfiniteExpectation + + prop "is finite exactly on recurrent states (random @4)" $ + forAll (genTransitionRows 4) $ \matrix -> + checkedChain matrix $ \p -> + conjoin + [ counterexample (show i) $ + case Return.expectationGivenInitialState p i of + Left err -> counterexample (show err) False + Right result -> + isFinite result === recurrentState p i + | i <- finites :: [Finite 4] + ] + + describe "Transition realization independence" $ do + it "uses strict hitting bounds on an infinite random walk" $ do + (Hit.probabilityGivenInitialState . EqualTo) 2 simpleRandomWalk (== 2) 0 + `shouldSatisfy` closeTo 0.25 + (Hit.probabilityGivenInitialState . LessThan) 2 simpleRandomWalk (== 2) 0 + `shouldBe` 0 + (Hit.probabilityGivenInitialState . LessThan) 3 simpleRandomWalk (== 2) 0 + `shouldSatisfy` closeTo 0.25 + + it "distinguishes return time from time-zero hitting" $ do + (Hit.probabilityGivenInitialState . EqualTo) 0 simpleRandomWalk (== 0) 0 + `shouldBe` 1 + (Return.probabilityGivenInitialState . EqualTo) 0 simpleRandomWalk 0 + `shouldBe` 0 + (Return.probabilityGivenInitialState . EqualTo) 2 simpleRandomWalk 0 + `shouldSatisfy` closeTo 0.5 + (Return.probabilityGivenInitialState . LessThan) 2 simpleRandomWalk 0 + `shouldBe` 0 + (Return.probabilityGivenInitialState . LessThan) 3 simpleRandomWalk 0 + `shouldSatisfy` closeTo 0.5 + + prop "matches matrix and equivalent-kernel bounded queries" $ + forAll (genTransitionRows 3) $ \rawMatrix -> + case fromRows rawMatrix :: + Either TransitionMatrixError (TransitionMatrix (Finite 3)) of + Left problem -> counterexample (show problem) False + Right matrix -> + let kernel = asTransitionKernel matrix + target state = state == (2 :: Finite 3) + in conjoin + [ counterexample (show (state, time)) $ + property $ + and + [ closeTo + ((Hit.probabilityGivenInitialState . EqualTo) time matrix target state) + ((Hit.probabilityGivenInitialState . EqualTo) time kernel target state) + , closeTo + ((Hit.probabilityGivenInitialState . LessThan) time matrix target state) + ((Hit.probabilityGivenInitialState . LessThan) time kernel target state) + , closeTo + ((Return.probabilityGivenInitialState . EqualTo) time matrix state) + ((Return.probabilityGivenInitialState . EqualTo) time kernel state) + , closeTo + ((Return.probabilityGivenInitialState . LessThan) time matrix state) + ((Return.probabilityGivenInitialState . LessThan) time kernel state) + ] + | state <- finites :: [Finite 3] + , time <- [0 .. 4] + ] + + describe "named finite states" $ do + it "solves eventual and competing hitting queries by constructor" $ do + case hitEventualProbabilityByState namedGambler [Ruined, Won] of + Left err -> expectationFailure (show err) + Right result -> + sequence_ + [ probability `shouldSatisfy` closeTo 1 + | probability <- result + ] + Hit.raceProbabilityGivenInitialState namedGambler [Won] [Ruined] Two + `shouldSatisfy` either (const False) (closeTo 0.5) + + it "solves bounded hitting queries in named state order" $ + ((hitProbabilityByState . LessThan) 3 namedGambler [Won]) + `shouldBe` [0, 0, 0.25, 0.5, 1] + + it "solves named expected hitting and return times" $ do + Hit.expectationGivenInitialState namedGambler [Ruined, Won] Two + `shouldSatisfy` either (const False) (expectationCloseTo 4) + Return.expectationGivenInitialState namedGambler Ruined + `shouldBe` Right (FiniteExpectation 1) + +isFinite :: Expectation -> Bool +isFinite (FiniteExpectation _) = True +isFinite InfiniteExpectation = False + +isIllConditioned :: Either LinearSystemError value -> Bool +isIllConditioned (Left (IllConditionedSystem estimate)) = + estimate < 1e-12 +isIllConditioned _ = False diff --git a/test/Dtmc/Analysis/VisitCountCanonicalSpec.hs b/test/Dtmc/Analysis/VisitCountCanonicalSpec.hs new file mode 100644 --- /dev/null +++ b/test/Dtmc/Analysis/VisitCountCanonicalSpec.hs @@ -0,0 +1,256 @@ +{-# LANGUAGE TypeApplications #-} + +module Dtmc.Analysis.VisitCountCanonicalSpec ( + spec, +) where + +import Data.Finite ( + Finite, + finites, + ) +import Data.Maybe ( + fromMaybe, + ) +import Dtmc.Analysis.Event ( + DiscreteEvent (..), + ) +import Dtmc.Analysis.Expectation ( + Expectation (..), + ) +import Dtmc.Analysis.ProbabilityOracle qualified as Oracle +import Dtmc.Analysis.VisitCount qualified as Visit +import Dtmc.Distribution ( + distributionWeights, + ) +import Dtmc.Distribution.Map qualified as DistributionMap +import Dtmc.TestSupport +import Dtmc.Transition.Kernel ( + TransitionKernel, + fromLaws, + ) +import Dtmc.Transition.Matrix ( + TransitionMatrix, + TransitionMatrixError, + fromRows, + ) +import Numeric.Natural ( + Natural, + ) +import Test.Hspec ( + Spec, + describe, + it, + shouldBe, + shouldSatisfy, + ) +import Test.Hspec.QuickCheck ( + prop, + ) +import Test.QuickCheck ( + counterexample, + forAll, + property, + ) + +checked :: (Show error) => Either error value -> value +checked = either (error . show) id + +transientVisitChain :: TransitionMatrix (Finite 3) +transientVisitChain = + checked + ( fromRows + ( chunksOf + 3 + [ 1 / 4 + , 0 + , 3 / 4 + , 1 / 2 + , 0 + , 1 / 2 + , 0 + , 0 + , 1 + ] + ) + ) + +recurrentVisitChain :: TransitionMatrix (Finite 4) +recurrentVisitChain = + checked + ( fromRows + ( chunksOf + 4 + [ 0 + , 1 / 2 + , 1 / 2 + , 0 + , 1 / 2 + , 0 + , 0 + , 1 / 2 + , 0 + , 0 + , 1 + , 0 + , 0 + , 0 + , 0 + , 1 + ] + ) + ) + +tinyReturn :: Double +tinyReturn = 1e-12 + +tinyVisitChain :: TransitionMatrix (Finite 2) +tinyVisitChain = + checked + ( fromRows + ( chunksOf + 2 + [ tinyReturn + , 1 - tinyReturn + , 0 + , 1 + ] + ) + ) + +simpleRandomWalk :: TransitionKernel Integer +simpleRandomWalk = + fromLaws $ \state -> + checked + ( DistributionMap.fromList + [(state - 1, 0.5), (state + 1, 0.5)] + ) + +close :: Double -> Double -> Bool +close = approxEq testTolerance + +known :: Maybe Double -> Double +known = fromMaybe (error "oracle horizon does not determine this event") + +eventsThrough :: Natural -> [DiscreteEvent] +eventsThrough horizon = + [EqualTo count | count <- [0 .. horizon]] + <> [LessThan count | count <- [0 .. horizon + 1]] + <> [AtMost count | count <- [0 .. horizon]] + <> [GreaterThan count | count <- [0 .. horizon]] + <> [AtLeast count | count <- [0 .. horizon + 1]] + +generatedTotalChecks :: TransitionMatrix (Finite 3) -> Bool +generatedTotalChecks matrix = + and + [ let scalar = checked (Visit.totalProbabilityGivenInitialState event matrix 0 initial) + dense = (checked (visitTotalProbabilityByState event matrix 0)) + in close (dense !! fromIntegral initial) scalar + && scalar >= negate testTolerance + && scalar <= 1 + testTolerance + | initial <- finites + , event <- eventsThrough 4 + ] + +generatedBoundedChecks :: TransitionMatrix (Finite 3) -> Bool +generatedBoundedChecks matrix = + and + [ let initial = DistributionMap.pointMass (0 :: Finite 3) + oracleLaw = Oracle.visitLawBefore bound [(0, 1)] matrix (== 0) + expected = known (Oracle.lawProbability event oracleLaw) + actual = Visit.boundedProbability bound event initial matrix (== 0) + in close actual expected + | bound <- [0 .. 4] + , event <- eventsThrough bound + ] + +spec :: Spec +spec = do + describe "canonical total visit count" $ do + it "implements every relation for a transient geometric law" $ do + let probability event = + checked (Visit.totalProbabilityGivenInitialState event transientVisitChain 0 1) + probability (EqualTo 0) `shouldSatisfy` close (1 / 2) + probability (EqualTo 1) `shouldSatisfy` close (3 / 8) + probability (LessThan 2) `shouldSatisfy` close (7 / 8) + probability (AtMost 1) `shouldSatisfy` close (7 / 8) + probability (GreaterThan 1) `shouldSatisfy` close (1 / 8) + probability (AtLeast 2) `shouldSatisfy` close (1 / 8) + probability (AtLeast 0) `shouldBe` 1 + + it "places recurrent positive-count mass structurally at infinity" $ do + let probabilities event = + checked (visitTotalProbabilityByState event recurrentVisitChain 2) + expectedHit = [2 / 3, 1 / 3, 1, 0] + expectedMiss = [1 / 3, 2 / 3, 0, 1] + sequence_ + [ actual `shouldSatisfy` close expected + | (actual, expected) <- zip (probabilities (GreaterThan 3)) expectedHit + ] + sequence_ + [ actual `shouldSatisfy` close expected + | (actual, expected) <- zip (probabilities (AtMost 3)) expectedMiss + ] + probabilities (EqualTo 2) `shouldBe` [0, 0, 0, 0] + probabilities (AtLeast 0) `shouldBe` [1, 1, 1, 1] + + it "evaluates a tiny upper tail without complement subtraction" $ do + let actual = + checked + ( Visit.totalProbabilityGivenInitialState + (GreaterThan 1) + tinyVisitChain + 0 + 0 + ) + actual `shouldSatisfy` (> 0) + actual `shouldSatisfy` (\value -> abs (value - tinyReturn) < 1e-15) + + prop "keeps scalar and all-state event queries consistent (random @3)" $ + forAll (genTransitionRows 3) $ \rawMatrix -> + case fromRows rawMatrix :: + Either TransitionMatrixError (TransitionMatrix (Finite 3)) of + Left problem -> counterexample (show problem) False + Right matrix -> property (generatedTotalChecks matrix) + + describe "canonical bounded visit count" $ do + it "supports every event relation on a locally finite kernel" $ do + let initial = DistributionMap.pointMass (0 :: Integer) + probability event = + Visit.boundedProbability 3 event initial simpleRandomWalk (== 0) + distributionWeights (Visit.boundedLaw 3 initial simpleRandomWalk (== 0)) + `shouldBe` [(1, 0.5), (2, 0.5)] + probability (EqualTo 1) `shouldBe` 0.5 + probability (LessThan 2) `shouldBe` 0.5 + probability (AtMost 1) `shouldBe` 0.5 + probability (GreaterThan 1) `shouldBe` 0.5 + probability (AtLeast 2) `shouldBe` 0.5 + Visit.boundedExpectation 3 initial simpleRandomWalk (== 0) + `shouldBe` 1.5 + + prop "matches independent path enumeration for every relation (random @3)" $ + forAll (genTransitionRows 3) $ \rawMatrix -> + case fromRows rawMatrix :: + Either TransitionMatrixError (TransitionMatrix (Finite 3)) of + Left problem -> counterexample (show problem) False + Right matrix -> property (generatedBoundedChecks matrix) + + describe "canonical infinite and expectation names" $ do + it "match the completed total-visit law" $ do + let infiniteValues = + checked + (visitInfiniteProbabilityByState recurrentVisitChain 2) + sequence_ + [ actual `shouldSatisfy` close expected + | (actual, expected) <- zip infiniteValues [2 / 3, 1 / 3, 1, 0] + ] + checked (Visit.infiniteProbabilityGivenInitialState recurrentVisitChain 2 0) + `shouldSatisfy` close (2 / 3) + visitTotalExpectationByState recurrentVisitChain 2 + `shouldBe` Right + [ InfiniteExpectation + , InfiniteExpectation + , InfiniteExpectation + , FiniteExpectation 0 + ] + Visit.totalExpectationGivenInitialState recurrentVisitChain 2 3 + `shouldBe` Right (FiniteExpectation 0) diff --git a/test/Dtmc/Analysis/VisitCountSpec.hs b/test/Dtmc/Analysis/VisitCountSpec.hs new file mode 100644 --- /dev/null +++ b/test/Dtmc/Analysis/VisitCountSpec.hs @@ -0,0 +1,485 @@ +{-# LANGUAGE TypeApplications #-} + +module Dtmc.Analysis.VisitCountSpec ( + spec, +) where + +import Data.Finite ( + Finite, + finites, + ) +import Dtmc.Analysis.Classification ( + accessible, + recurrentState, + ) +import Dtmc.Analysis.Event ( + DiscreteEvent (..), + ) +import Dtmc.Analysis.FiniteTime qualified as FT +import Dtmc.Analysis.ReturnTime qualified as Return +import Dtmc.Analysis.VisitCount ( + Expectation (..), + ) +import Dtmc.Analysis.VisitCount qualified as Visit +import Dtmc.Distribution ( + distributionWeights, + ) +import Dtmc.Distribution.Map qualified as DistributionMap +import Dtmc.TestSupport +import Dtmc.Transition.Kernel qualified as Kernel +import Dtmc.Transition.Matrix ( + TransitionMatrix, + TransitionMatrixError, + fromRows, + ) +import Test.Hspec ( + Spec, + describe, + it, + shouldBe, + shouldSatisfy, + ) +import Test.Hspec.QuickCheck ( + prop, + ) +import Test.QuickCheck ( + choose, + conjoin, + counterexample, + forAll, + property, + (===), + ) + +checked :: (Show error) => Either error value -> value +checked = either (error . show) id + +twoCycle :: TransitionMatrix (Finite 2) +twoCycle = + checked $ + fromRows + ( chunksOf + 2 + [ 0 + , 1 + , 1 + , 0 + ] + ) + +-- Target 0 returns with probability 1/4. State 1 first reaches it with +-- probability 1/2, while absorbing state 2 cannot reach it. +transientVisitChain :: TransitionMatrix (Finite 3) +transientVisitChain = + checked $ + fromRows + ( chunksOf + 3 + [ 1 / 4 + , 0 + , 3 / 4 + , 1 / 2 + , 0 + , 1 / 2 + , 0 + , 0 + , 1 + ] + ) + +-- States 0 and 1 may enter absorbing target 2; absorbing state 3 cannot. +recurrentVisitChain :: TransitionMatrix (Finite 4) +recurrentVisitChain = + checked $ + fromRows + ( chunksOf + 4 + [ 0 + , 1 / 2 + , 1 / 2 + , 0 + , 1 / 2 + , 0 + , 0 + , 1 / 2 + , 0 + , 0 + , 1 + , 0 + , 0 + , 0 + , 0 + , 1 + ] + ) + +mixedInitial :: DistributionMap.DistributionMap (Finite 2) +mixedInitial = + checked (DistributionMap.fromList [(0, 0.25), (1, 0.75)]) + +asKernel :: + TransitionMatrix (Finite 2) -> + Kernel.TransitionKernel (Finite 2) +asKernel matrix = + Kernel.fromLaws $ \source -> + checked $ + DistributionMap.fromList + [ (destination, FT.stepProbability matrix source destination) + | destination <- finites + ] + +simpleRandomWalk :: Kernel.TransitionKernel Integer +simpleRandomWalk = + Kernel.fromLaws $ \state -> + checked $ + DistributionMap.fromList + [(state - 1, 0.5), (state + 1, 0.5)] + +closeTo :: Double -> Double -> Bool +closeTo expected actual = abs (actual - expected) <= testTolerance + +expectationCloseTo :: Double -> Expectation -> Bool +expectationCloseTo expected (FiniteExpectation actual) = closeTo expected actual +expectationCloseTo _ InfiniteExpectation = False + +spec :: Spec +spec = do + describe "totalProbabilityByState" $ do + it "matches the geometric law for a transient target" $ do + let probabilities count = + (checked ((visitTotalProbabilityByState . EqualTo) count transientVisitChain 0)) + sequence_ + [ actual `shouldSatisfy` closeTo expected + | (actual, expected) <- + zip (probabilities 0) [0, 1 / 2, 1] + ] + sequence_ + [ actual `shouldSatisfy` closeTo expected + | (actual, expected) <- + zip (probabilities 1) [3 / 4, 3 / 8, 0] + ] + sequence_ + [ actual `shouldSatisfy` closeTo expected + | (actual, expected) <- + zip (probabilities 3) [3 / 64, 3 / 128, 0] + ] + (checked (visitInfiniteProbabilityByState transientVisitChain 0)) + `shouldBe` [0, 0, 0] + + it "puts all positive recurrent-target mass at infinity" $ do + checked ((visitTotalProbabilityByState . EqualTo) 1 recurrentVisitChain 2) + `shouldBe` [0, 0, 0, 0] + sequence_ + [ actual `shouldSatisfy` closeTo expected + | (actual, expected) <- + zip + ((checked (visitInfiniteProbabilityByState recurrentVisitChain 2))) + [2 / 3, 1 / 3, 1, 0] + ] + sequence_ + [ actual `shouldSatisfy` closeTo expected + | (actual, expected) <- + zip + ((checked ((visitTotalProbabilityByState . EqualTo) 0 recurrentVisitChain 2))) + [1 / 3, 2 / 3, 0, 1] + ] + + it "counts the target at time zero" $ do + checked ((Visit.totalProbabilityGivenInitialState . EqualTo) 0 transientVisitChain 0 0) + `shouldBe` 0 + checked ((Visit.totalProbabilityGivenInitialState . EqualTo) 1 transientVisitChain 0 0) + `shouldSatisfy` closeTo (3 / 4) + + prop "scalar queries look up the all-state result (random @3)" $ + forAll (genTransitionRows 3) $ \rawMatrix -> + case fromRows rawMatrix :: + Either TransitionMatrixError (TransitionMatrix (Finite 3)) of + Left err -> counterexample (show err) False + Right matrix -> + conjoin + [ conjoin + [ case (visitTotalProbabilityByState . EqualTo) count matrix 0 of + Left err -> counterexample (show err) False + Right probabilities -> + conjoin + [ (Visit.totalProbabilityGivenInitialState . EqualTo) count matrix 0 initial + === Right probability + | (initial, probability) <- + zip (finites :: [Finite 3]) (probabilities) + ] + | count <- [0, 1, 3] + ] + , case visitInfiniteProbabilityByState matrix 0 of + Left err -> counterexample (show err) False + Right probabilities -> + conjoin + [ Visit.infiniteProbabilityGivenInitialState matrix 0 initial + === Right probability + | (initial, probability) <- + zip (finites :: [Finite 3]) (probabilities) + ] + ] + + describe "totalExpectationByState" $ do + it "matches h / (1 - f) for a transient target" $ do + let expectations = checked (visitTotalExpectationByState transientVisitChain 0) + sequence_ + [ expectation `shouldSatisfy` expectationCloseTo expected + | (expectation, expected) <- zip expectations [4 / 3, 2 / 3, 0] + ] + checked (Visit.totalExpectationGivenInitialState transientVisitChain 0 1) + `shouldSatisfy` expectationCloseTo (2 / 3) + + it "is infinite exactly where a recurrent target is reachable" $ do + checked (visitTotalExpectationByState recurrentVisitChain 2) + `shouldBe` [InfiniteExpectation, InfiniteExpectation, InfiniteExpectation, FiniteExpectation 0] + checked (Visit.totalExpectationGivenInitialState recurrentVisitChain 2 3) + `shouldBe` FiniteExpectation 0 + checked (visitTotalExpectationByState recurrentVisitChain 3) + `shouldBe` [InfiniteExpectation, InfiniteExpectation, FiniteExpectation 0, InfiniteExpectation] + + prop "agrees with hitting, return, recurrence, and reachability (random @3)" $ + forAll (genTransitionRows 3) $ \rawMatrix -> + case fromRows rawMatrix :: + Either TransitionMatrixError (TransitionMatrix (Finite 3)) of + Left err -> counterexample (show err) False + Right matrix -> + case do + hits <- hitEventualProbabilityByState matrix [0] + returning <- Return.eventualProbabilityGivenInitialState matrix 0 + zeroVisits <- (visitTotalProbabilityByState . EqualTo) 0 matrix 0 + oneVisit <- (visitTotalProbabilityByState . EqualTo) 1 matrix 0 + twoVisits <- (visitTotalProbabilityByState . EqualTo) 2 matrix 0 + infiniteVisits <- visitInfiniteProbabilityByState matrix 0 + expectations <- visitTotalExpectationByState matrix 0 + pure + ( hits + , returning + , zeroVisits + , oneVisit + , twoVisits + , infiniteVisits + , expectations + ) of + Left err -> counterexample (show err) False + Right + ( hits + , returning + , zeroVisits + , oneVisit + , twoVisits + , infiniteVisits + , expectations + ) -> + let hitValues = hits + zeroValues = zeroVisits + oneValues = oneVisit + twoValues = twoVisits + infiniteValues = infiniteVisits + states = finites :: [Finite 3] + structuralExpectations = + [ if accessible matrix initial 0 + then InfiniteExpectation + else FiniteExpectation 0 + | initial <- states + ] + in conjoin + [ conjoin + [ property (closeTo (1 - hit) zero) + | (hit, zero) <- zip hitValues zeroValues + ] + , if recurrentState matrix 0 + then + conjoin + [ oneValues === [0, 0, 0] + , twoValues === [0, 0, 0] + , infiniteValues === hitValues + , expectations === structuralExpectations + ] + else + conjoin + [ infiniteValues === [0, 0, 0] + , conjoin + [ property (closeTo (hit * (1 - returning)) one) + | (hit, one) <- zip hitValues oneValues + ] + , conjoin + [ property (closeTo (one * returning) two) + | (one, two) <- zip oneValues twoValues + ] + , conjoin + [ case expectation of + FiniteExpectation value -> + property + (closeTo (hit / (1 - returning)) value) + InfiniteExpectation -> property False + | (hit, expectation) <- zip hitValues expectations + ] + ] + ] + + describe "boundedLaw" $ do + it "is a point mass at zero for bound zero" $ + distributionWeights + ( Visit.boundedLaw + 0 + (DistributionMap.pointMass (0 :: Finite 2)) + twoCycle + (== 0) + ) + `shouldBe` [(0, 1)] + + it "counts the initial state at a positive bound" $ + distributionWeights + (Visit.boundedLaw 1 mixedInitial twoCycle (== 0)) + `shouldBe` [(0, 0.75), (1, 0.25)] + + it "counts deterministic visits at times zero through bound minus one" $ do + let initial = DistributionMap.pointMass (0 :: Finite 2) + distributionWeights (Visit.boundedLaw 1 initial twoCycle (== 0)) + `shouldBe` [(1, 1)] + distributionWeights (Visit.boundedLaw 2 initial twoCycle (== 0)) + `shouldBe` [(1, 1)] + distributionWeights (Visit.boundedLaw 3 initial twoCycle (== 0)) + `shouldBe` [(2, 1)] + + it "computes an exact law on an infinite random walk" $ + distributionWeights + ( Visit.boundedLaw + 3 + (DistributionMap.pointMass (0 :: Integer)) + simpleRandomWalk + (== 0) + ) + `shouldBe` [(1, 0.5), (2, 0.5)] + + prop "has total mass one and no count above the bound (random @3)" $ + forAll (choose (0, 5 :: Int)) $ \rawBound -> + forAll (genTransitionRows 3) $ \rawMatrix -> + case fromRows rawMatrix :: + Either TransitionMatrixError (TransitionMatrix (Finite 3)) of + Left err -> counterexample (show err) False + Right matrix -> + let bound = fromIntegral rawBound + law = + Visit.boundedLaw + bound + (DistributionMap.pointMass (0 :: Finite 3)) + matrix + (== 0) + weights = distributionWeights law + in conjoin + [ property (closeTo 1 (sum (map snd weights))) + , property (all ((<= bound) . fst) weights) + ] + + describe "boundedProbability" $ do + it "looks up one coordinate of the count distribution" $ do + let initial = DistributionMap.pointMass (0 :: Integer) + Visit.boundedProbability 3 (EqualTo 1) initial simpleRandomWalk (== 0) + `shouldSatisfy` closeTo 0.5 + Visit.boundedProbability 3 (EqualTo 2) initial simpleRandomWalk (== 0) + `shouldSatisfy` closeTo 0.5 + Visit.boundedProbability 3 (EqualTo 3) initial simpleRandomWalk (== 0) + `shouldBe` 0 + + it "agrees for a matrix and its equivalent kernel" $ do + let initial = DistributionMap.pointMass (0 :: Finite 2) + kernel = asKernel twoCycle + sequence_ + [ Visit.boundedProbability bound (EqualTo count) initial twoCycle (== 0) + `shouldBe` Visit.boundedProbability bound (EqualTo count) initial kernel (== 0) + | bound <- [0 .. 5] + , count <- [0 .. bound] + ] + + describe "boundedExpectation" $ do + it "is the expectation of the random-walk count law" $ + Visit.boundedExpectation + 3 + (DistributionMap.pointMass (0 :: Integer)) + simpleRandomWalk + (== 0) + `shouldSatisfy` closeTo 1.5 + + prop "equals the sum of finite-time visit probabilities (random @3)" $ + forAll (choose (0, 5 :: Int)) $ \rawBound -> + forAll (genTransitionRows 3) $ \rawMatrix -> + case fromRows rawMatrix :: + Either TransitionMatrixError (TransitionMatrix (Finite 3)) of + Left err -> counterexample (show err) False + Right matrix -> + let bound = fromIntegral rawBound + initial = DistributionMap.pointMass (0 :: Finite 3) + expectation = + Visit.boundedExpectation bound initial matrix (== 0) + marginalSum = + sum + [ FT.probability initial matrix [FT.At (fromIntegral time) 0] + | time <- [0 .. rawBound - 1] + ] + in property (closeTo marginalSum expectation) + + describe "occupationMatrix" $ do + it "matches the closed form of the transient block" $ + Visit.occupationMatrix transientVisitChain + `shouldSatisfy` matchesOccupation + [ [Just (4 / 3), Just 0, Nothing] + , [Just (2 / 3), Just 1, Nothing] + , [Just 0, Just 0, Nothing] + ] + + it "is infinite everywhere when no state is transient" $ + Visit.occupationMatrix twoCycle + `shouldSatisfy` matchesOccupation + [ [Nothing, Nothing] + , [Nothing, Nothing] + ] + + it "shares reachability across each recurrent class" $ + Visit.occupationMatrix recurrentVisitChain + `shouldSatisfy` matchesOccupation + [ [Just (4 / 3), Just (2 / 3), Nothing, Nothing] + , [Just (2 / 3), Just (4 / 3), Nothing, Nothing] + , [Just 0, Just 0, Nothing, Just 0] + , [Just 0, Just 0, Just 0, Nothing] + ] + + prop "agrees with totalExpectation entry by entry" $ + forAll (genTransitionRows 3) $ \m -> + case fromRows m :: + Either TransitionMatrixError (TransitionMatrix (Finite 3)) of + Left err -> counterexample (show err) False + Right p -> + case Visit.occupationMatrix p of + -- A refused solve is a documented outcome. + Left _ -> property True + Right rows -> + conjoin + [ counterexample + (show (i, j, entry)) + (agreesWithSingle entry (Visit.totalExpectationGivenInitialState p j i)) + | (i, row) <- zip (finites :: [Finite 3]) rows + , (j, entry) <- zip (finites :: [Finite 3]) row + ] + +-- Nothing stands for InfiniteExpectation; Just v for a finite entry near v. +matchesOccupation :: + [[Maybe Double]] -> + Either error [[Expectation]] -> + Bool +matchesOccupation _ (Left _) = False +matchesOccupation expected (Right actual) = + length expected == length actual + && and (zipWith matchesRow expected actual) + where + matchesRow e a = length e == length a && and (zipWith matchesEntry e a) + matchesEntry (Just v) x = expectationCloseTo v x + matchesEntry Nothing InfiniteExpectation = True + matchesEntry Nothing _ = False + +agreesWithSingle :: Expectation -> Either error Expectation -> Bool +agreesWithSingle _ (Left _) = True +agreesWithSingle InfiniteExpectation (Right InfiniteExpectation) = True +agreesWithSingle (FiniteExpectation x) (Right (FiniteExpectation y)) = closeTo x y +agreesWithSingle _ _ = False diff --git a/test/Dtmc/Distribution/InterfaceSpec.hs b/test/Dtmc/Distribution/InterfaceSpec.hs new file mode 100644 --- /dev/null +++ b/test/Dtmc/Distribution/InterfaceSpec.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE TypeApplications #-} + +module Dtmc.Distribution.InterfaceSpec ( + spec, +) where + +import Data.Finite ( + Finite, + ) +import Dtmc.Distribution ( + Distribution (..), + DistributionError, + ) +import Dtmc.Distribution.Map ( + DistributionMap, + fromList, + fromDistribution, + ) +import Dtmc.Distribution.Vector qualified as Vector +import Test.Hspec ( + Spec, + describe, + it, + shouldBe, + ) + +spec :: Spec +spec = + describe "Distribution interface" $ do + let vector = + either (error . show) id $ + Vector.fromList @(Finite 3) [0.2, 0, 0.8] + mapDistribution = + either + (error . show) + id + ( fromList [(0, 0.2), (2, 0.8)] :: + Either DistributionError (DistributionMap (Finite 3)) + ) + + it "exposes the same weights and support for both representations" $ do + distributionWeights vector `shouldBe` distributionWeights mapDistribution + support vector `shouldBe` support mapDistribution + + it "converts both representations to the same canonical map" $ do + fromDistribution vector `shouldBe` mapDistribution + fromDistribution mapDistribution `shouldBe` mapDistribution + + it "converts a dense law without changing its weights" $ + distributionWeights (fromDistribution vector) + `shouldBe` [(0, 0.2), (2, 0.8)] diff --git a/test/Dtmc/Distribution/MapSpec.hs b/test/Dtmc/Distribution/MapSpec.hs new file mode 100644 --- /dev/null +++ b/test/Dtmc/Distribution/MapSpec.hs @@ -0,0 +1,109 @@ +module Dtmc.Distribution.MapSpec ( + spec, +) where + +import Data.Map.Strict qualified as Map +import Dtmc.Distribution ( + Distribution (..), + DistributionError (..), + ) +import Dtmc.Distribution.Map ( + DistributionMap, + fromList, + mapStates, + pointMass, + toMap, + ) +import Dtmc.Simplex ( + SimplexError (..), + ) +import Dtmc.TestSupport ( + approxEq, + ) +import Test.Hspec ( + Spec, + describe, + expectationFailure, + it, + shouldBe, + shouldSatisfy, + ) + +spec :: Spec +spec = + describe "DistributionMap" $ do + it "combines duplicates and stores canonical ascending entries" $ do + let distribution = + either (error . show) id $ + fromList + [('b', 0.2), ('a', 0.5), ('b', 0.3), ('c', 0)] + distributionWeights distribution `shouldBe` [('a', 0.5), ('b', 0.5)] + support distribution `shouldBe` ['a', 'b'] + Map.toAscList (toMap distribution) + `shouldBe` [('a', 0.5), ('b', 0.5)] + + it "returns zero for an absent state" $ + probabilityAt (pointMass "present") "absent" + `shouldBe` 0 + + it "pushes weights through a state mapping" $ + case + ( fromList [(-1, 0.5), (1, 0.5)] :: + Either DistributionError (DistributionMap Int) + ) + of + Right steps -> + distributionWeights (mapStates (+ 10) steps) + `shouldBe` [(9, 0.5), (11, 0.5)] + Left err -> + expectationFailure + ("expected acceptance, got " <> show err) + + it "combines weights whose states map to the same target" $ + case + ( fromList [(0, 0.25), (1, 0.25), (2, 0.5)] :: + Either DistributionError (DistributionMap Int) + ) + of + Right distribution -> + distributionWeights (mapStates (`mod` 2) distribution) + `shouldBe` [(0, 0.75), (1, 0.25)] + Left err -> + expectationFailure + ("expected acceptance, got " <> show err) + + it "rejects an empty law" $ + (fromList [] :: Either DistributionError (DistributionMap Int)) + `shouldSatisfy` either (const True) (const False) + + it "uses the shared error type" $ + fromList ([] :: [(Int, Double)]) + `shouldBe` Left (DistributionError (SumOffBy 0)) + + it "removes weights repaired to zero" $ + case fromList [('a', -1e-17), ('b', 1)] of + Right distribution -> + Map.toAscList (toMap distribution) + `shouldBe` [('b', 1)] + Left err -> + expectationFailure + ("expected acceptance, got " <> show err) + + it "normalises an accepted combined total near one" $ + case fromList [('a', 0.5), ('b', 0.5 - 5e-10)] of + Right distribution -> + approxEq + 1e-12 + (sum (Map.elems (toMap distribution))) + 1 + `shouldBe` True + Left err -> + expectationFailure + ("expected acceptance, got " <> show err) + + it "reports a non-finite combined weight by ascending state index" $ + case fromList [('b', 1), ('a', 0 / 0), ('a', 0)] of + Left err -> + err `shouldBe` DistributionError (NonFiniteEntry 0) + Right _ -> + expectationFailure "expected rejection" diff --git a/test/Dtmc/Distribution/VectorSpec.hs b/test/Dtmc/Distribution/VectorSpec.hs new file mode 100644 --- /dev/null +++ b/test/Dtmc/Distribution/VectorSpec.hs @@ -0,0 +1,305 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TypeApplications #-} + +module Dtmc.Distribution.VectorSpec ( + spec, +) where + +import Data.Finite ( + Finite, + ) +import Dtmc.Distribution ( + Distribution (..), + ) +import Dtmc.Distribution.Map qualified as DistributionMap +import Dtmc.Distribution.Vector ( + DistributionVectorError (..), + fromList, + toList, + ) +import Dtmc.Simplex ( + SimplexError (..), + ) +import Dtmc.State ( + FiniteState, + finiteStates, + ) +import Dtmc.TestSupport ( + approxEq, + bumpSmallest, + genSimplexPoint, + testTolerance, + ) +import GHC.Generics ( + Generic, + ) +import Test.Hspec ( + Spec, + describe, + expectationFailure, + it, + shouldBe, + ) +import Test.Hspec.QuickCheck ( + prop, + ) +import Test.QuickCheck ( + counterexample, + forAll, + property, + ) + +data NamedState = NamedA | NamedB | NamedC + deriving (Eq, Ord, Show, Generic) + +instance FiniteState NamedState + +spec :: Spec +spec = do + describe "fromList" $ do + it "reports too few weights against the state cardinality" $ + case fromList @NamedState [0.5, 0.5] of + Left err -> + err `shouldBe` WrongLength 3 2 + Right _ -> + expectationFailure "expected rejection" + + it "checks the length before the simplex invariant" $ + case fromList @NamedState [0.5, 0.5, 0.5, 0.5] of + Left err -> + err `shouldBe` WrongLength 3 4 + Right _ -> + expectationFailure "expected rejection" + + prop "rejects any length other than the state cardinality" $ + forAll (genSimplexPoint 3) $ \entries -> + case fromList @(Finite 3) (take 2 entries) of + Left err -> + counterexample (show err) (err == WrongLength 3 2) + Right _ -> + counterexample "expected rejection" False + + it "reports a total outside tolerance" $ + case fromList @NamedState [0.8, 0, 0] of + Left (InWeights (SumOffBy total)) -> + total `shouldBe` 0.8 + result -> + expectationFailure + ("expected InWeights SumOffBy, got " <> show result) + + it "rejects an empty vector" $ + case fromList @(Finite 0) [] of + Left err -> + err `shouldBe` InWeights (SumOffBy 0) + Right _ -> + expectationFailure "expected rejection" + + it "clamps a tiny negative rounding error" $ + case fromList @(Finite 2) [-1e-17, 1] of + Right distribution -> + toList distribution + `shouldBe` [0, 1] + Left err -> + expectationFailure + ("expected acceptance, got " <> show err) + + it "normalises an accepted total near one" $ + case fromList @(Finite 2) [0.5, 0.5 - 5e-10] of + Right distribution -> do + let stored = + toList distribution + approxEq 1e-12 (sum stored) 1 `shouldBe` True + stored == [0.5, 0.5 - 5e-10] `shouldBe` False + Left err -> + expectationFailure + ("expected acceptance, got " <> show err) + + it "reports NaN at its coordinate" $ + case fromList @(Finite 2) [0 / 0, 1] of + Left err -> + err `shouldBe` InWeights (NonFiniteEntry 0) + Right _ -> + expectationFailure "expected rejection" + + it "reports infinity at its coordinate" $ + case fromList @(Finite 2) [1, 1 / 0] of + Left err -> + err `shouldBe` InWeights (NonFiniteEntry 1) + Right _ -> + expectationFailure "expected rejection" + + it "reports an entry above one" $ + case fromList @(Finite 2) [1.5, -0.5] of + Left err -> + err + `shouldBe` InWeights (EntryAboveOne 0 1.5) + Right _ -> + expectationFailure "expected rejection" + + prop "accepts normalised vectors" $ + forAll (genSimplexPoint 3) $ \entries -> + case fromList @(Finite 3) entries of + Right _ -> + property True + Left err -> + counterexample + ("generated vector was rejected: " <> show err) + False + + prop "rejects vectors whose sum is too large" $ + forAll (genSimplexPoint 3) $ \entries -> + case fromList @(Finite 3) (bumpSmallest 1e-6 entries) of + Left (InWeights (SumOffBy _)) -> + property True + result -> + counterexample + ("expected InWeights SumOffBy, got " <> show result) + False + + prop "rejects genuinely negative entries" $ + forAll (genSimplexPoint 3) $ \entries -> + let invalid = + case entries of + _ : rest -> (-1e-6) : rest + [] -> [] + in case fromList @(Finite 3) invalid of + Left (InWeights (NegativeEntry 0 _)) -> + property True + result -> + counterexample + ("expected InWeights NegativeEntry 0, got " <> show result) + False + + prop "stores a canonical vector close to the accepted input" $ + forAll (genSimplexPoint 3) $ \entries -> + case fromList @(Finite 3) entries of + Right distribution -> + let stored = toList distribution + in counterexample ("stored vector: " <> show stored) $ + property + ( all (\entry -> entry >= 0 && entry <= 1) stored + && approxEq 1e-12 (sum stored) 1 + && and + ( zipWith + (approxEq testTolerance) + stored + entries + ) + ) + Left err -> + counterexample + ("generated vector was rejected: " <> show err) + False + + describe "fromList and toList are a positional pair" $ do + prop "fromList accepts whatever toList produced (random @3)" $ + forAll (genSimplexPoint 3) $ \entries -> + case fromList @(Finite 3) entries of + Right distribution -> + case fromList @(Finite 3) (toList distribution) of + Right again -> + counterexample (show (toList again)) $ + property + ( and + ( zipWith + (approxEq testTolerance) + (toList again) + (toList distribution) + ) + ) + Left err -> + counterexample + ("round trip was rejected: " <> show err) + False + Left err -> + counterexample + ("generated vector was rejected: " <> show err) + False + + describe "labelled construction through the sparse representation" $ do + it "combines duplicates and fills missing states with zero" $ + case DistributionMap.fromList + [(NamedC, 0.5), (NamedA, 0.25), (NamedA, 0.25)] of + Left err -> + expectationFailure + ("expected acceptance, got " <> show err) + Right sparse -> + case fromList + [probabilityAt sparse state | state <- finiteStates] of + Right distribution -> do + toList distribution `shouldBe` [0.5, 0, 0.5] + distributionWeights distribution + `shouldBe` [(NamedA, 0.5), (NamedC, 0.5)] + Left err -> + expectationFailure + ("expected acceptance, got " <> show err) + + prop "agrees with the sparse representation coordinate for coordinate" $ + forAll (genSimplexPoint 3) $ \entries -> + case DistributionMap.fromList + (zip (finiteStates @NamedState) entries) of + Left err -> + counterexample ("sparse rejected: " <> show err) False + Right sparse -> + case fromList @NamedState entries of + Right dense -> + counterexample (show (toList dense)) $ + property + ( and + [ approxEq + testTolerance + (probabilityAt sparse state) + (probabilityAt dense state) + | state <- finiteStates + ] + ) + Left err -> + counterexample + ("dense rejected: " <> show err) + False + + describe "probabilityAt" $ do + let known = + either (error . show) id $ + fromList @(Finite 3) [0.2, 0.5, 0.3] + + it "returns each coordinate of a known distribution" $ do + approxEq testTolerance (probabilityAt known 0) 0.2 `shouldBe` True + approxEq testTolerance (probabilityAt known 1) 0.5 `shouldBe` True + approxEq testTolerance (probabilityAt known 2) 0.3 `shouldBe` True + + it "reads the first and last valid states" $ do + approxEq testTolerance (probabilityAt known minBound) 0.2 + `shouldBe` True + approxEq testTolerance (probabilityAt known maxBound) 0.3 + `shouldBe` True + + it "returns canonical stored values after tolerated repair" $ do + let tolerated = + either (error . show) id $ + fromList @(Finite 2) [-1e-17, 1] + + probabilityAt tolerated 0 `shouldBe` 0 + probabilityAt tolerated 1 `shouldBe` 1 + + describe "named finite states" $ do + let namedDistribution = + either (error . show) id $ + fromList @NamedState [0.2, 0, 0.8] + indexedDistribution = + either (error . show) id $ + fromList @(Finite 3) [0.2, 0, 0.8] + + it "indexes coordinates by state constructors" $ do + probabilityAt namedDistribution NamedA `shouldBe` 0.2 + probabilityAt namedDistribution NamedB `shouldBe` 0 + probabilityAt namedDistribution NamedC `shouldBe` 0.8 + + it "reports weights and support in constructor order" $ do + distributionWeights namedDistribution + `shouldBe` [(NamedA, 0.2), (NamedC, 0.8)] + support namedDistribution `shouldBe` [NamedA, NamedC] + + it "matches the low-level indexed representation coordinate for coordinate" $ + map (probabilityAt namedDistribution) [NamedA, NamedB, NamedC] + `shouldBe` map (probabilityAt indexedDistribution) [0, 1, 2] diff --git a/test/Dtmc/DynamicsSpec.hs b/test/Dtmc/DynamicsSpec.hs new file mode 100644 --- /dev/null +++ b/test/Dtmc/DynamicsSpec.hs @@ -0,0 +1,244 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module Dtmc.DynamicsSpec ( + spec, +) where + +import Data.Finite ( + Finite, + finites, + ) +import Dtmc.Analysis.FiniteTime ( + stepProbability, + ) +import Dtmc.Distribution ( + distributionWeights, + probabilityAt, + ) +import Dtmc.Distribution.Map qualified as DistributionMap +import Dtmc.Distribution.Vector ( + DistributionVector, + ) +import Dtmc.Distribution.Vector qualified as Vector +import Dtmc.Dynamics ( + evolveN, + evolveVector, + evolveVectorN, + ) +import Dtmc.State ( + FiniteState, + ) +import Dtmc.TestSupport ( + approxDistributionEq, + approxEq, + chunksOf, + genSimplexPoint, + genTransitionRows, + testTolerance, + ) +import Dtmc.Transition.Kernel qualified as Kernel +import Dtmc.Transition.Matrix ( + TransitionMatrix, + fromRows, + ) +import GHC.Generics ( + Generic, + ) +import Test.Hspec ( + Spec, + describe, + it, + shouldBe, + shouldSatisfy, + ) +import Test.Hspec.QuickCheck ( + prop, + ) +import Test.QuickCheck ( + choose, + counterexample, + forAll, + property, + ) + +data NamedPosition = LowerPosition | UpperPosition + deriving (Eq, Ord, Show, Generic) + +instance FiniteState NamedPosition + +checked :: (Show error) => Either error value -> value +checked = either (error . show) id + +finiteChain :: TransitionMatrix (Finite 3) +finiteChain = + checked $ + fromRows + ( chunksOf + 3 + [ 0.5 + , 0.5 + , 0 + , 0 + , 0.2 + , 0.8 + , 1 + , 0 + , 0 + ] + ) + +finiteInitial :: DistributionVector (Finite 3) +finiteInitial = + checked (Vector.fromList [0.6, 0.3, 0.1]) + +kernelChain :: Kernel.TransitionKernel (Finite 3) +kernelChain = + Kernel.fromLaws $ \source -> + checked $ + DistributionMap.fromList + [ (destination, stepProbability finiteChain source destination) + | destination <- finites + ] + +mapInitial :: DistributionMap.DistributionMap (Finite 3) +mapInitial = + checked $ + DistributionMap.fromList + [(state, probabilityAt finiteInitial state) | state <- finites] + +simpleRandomWalk :: Kernel.TransitionKernel Integer +simpleRandomWalk = + Kernel.fromLaws $ \state -> + checked + (DistributionMap.fromList [(state - 1, 0.5), (state + 1, 0.5)]) + +closeTo :: Double -> Double -> Bool +closeTo = approxEq testTolerance + +twoState :: TransitionMatrix (Finite 2) +twoState = + either (error . show) id $ + fromRows + (chunksOf 2 [0.9, 0.1, 0.4, 0.6]) + +namedInitial :: DistributionVector NamedPosition +namedInitial = + either (error . show) id $ + Vector.fromList @NamedPosition [1, 0] + +namedTwoState :: TransitionMatrix NamedPosition +namedTwoState = + either (error . show) id $ + fromRows @NamedPosition + (chunksOf 2 [0.9, 0.1, 0.4, 0.6]) + +spec :: Spec +spec = do + describe "evolveVector" $ do + prop "keeps the distribution on the simplex" $ + forAll ((,) <$> genSimplexPoint 3 <*> genTransitionRows 3) $ + \(vector, matrix) -> + case (Vector.fromList @(Finite 3) vector, fromRows matrix) of + (Right mu, Right p) -> + case Vector.fromList @(Finite 3) + (Vector.toList (evolveVector mu p)) of + Right _ -> + property True + Left err -> + counterexample + ("evolved distribution left the simplex: " <> show err) + False + result -> + counterexample + ("generated input was rejected: " <> show result) + False + + it "matches a hand-computed two-state step" $ do + let mu = + either (error . show) id $ + Vector.fromList @(Finite 2) [1, 0] + + Vector.toList (evolveVector mu twoState) + `shouldBe` [0.9, 0.1] + + it "preserves named states while evolving the dense vector" $ do + probabilityAt (evolveVector namedInitial namedTwoState) LowerPosition + `shouldBe` 0.9 + probabilityAt (evolveVector namedInitial namedTwoState) UpperPosition + `shouldBe` 0.1 + + describe "evolveVectorN" $ do + it "leaves a distribution unchanged after zero steps" $ do + let mu = + either (error . show) id $ + Vector.fromList @(Finite 2) [0.25, 0.75] + + approxDistributionEq + 1e-12 + (evolveVectorN 0 mu twoState) + mu + `shouldBe` True + + prop "agrees with iterating evolveVector" + $ forAll + ( (,,) + <$> choose (0, 6 :: Int) + <*> genSimplexPoint 3 + <*> genTransitionRows 3 + ) + $ \(k, vector, matrix) -> + case (Vector.fromList @(Finite 3) vector, fromRows matrix) of + (Right mu, Right p) -> + let iterated = + iterate (`evolveVector` p) mu !! k + in property $ + approxDistributionEq + 1e-9 + (evolveVectorN (fromIntegral k) mu p) + iterated + result -> + counterexample + ("generated input was rejected: " <> show result) + False + + prop "composes m steps then n steps" + $ forAll + ( (,,,) + <$> choose (0, 4 :: Int) + <*> choose (0, 4 :: Int) + <*> genSimplexPoint 3 + <*> genTransitionRows 3 + ) + $ \(m, n, vector, matrix) -> + case (Vector.fromList @(Finite 3) vector, fromRows matrix) of + (Right mu, Right p) -> + property $ + approxDistributionEq + 1e-9 + (evolveVectorN (fromIntegral (m + n)) mu p) + ( evolveVectorN + (fromIntegral n) + (evolveVectorN (fromIntegral m) mu p) + p + ) + result -> + counterexample + ("generated input was rejected: " <> show result) + False + + describe "evolve/evolveN" $ do + it "evolves an infinite-state random walk without enumerating its state space" $ + distributionWeights + (evolveN 2 (DistributionMap.pointMass 0) simpleRandomWalk) + `shouldBe` [(-2, 0.25), (0, 0.5), (2, 0.25)] + + it "agrees across equivalent matrix and kernel representations" $ + sequence_ + [ probabilityAt (evolveN time mapInitial kernelChain) state + `shouldSatisfy` closeTo + (probabilityAt (evolveVectorN time finiteInitial finiteChain) state) + | time <- [0 .. 4] + , state <- finites :: [Finite 3] + ] diff --git a/test/Dtmc/IntegrationSpec.hs b/test/Dtmc/IntegrationSpec.hs new file mode 100644 --- /dev/null +++ b/test/Dtmc/IntegrationSpec.hs @@ -0,0 +1,321 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Dtmc.IntegrationSpec ( + spec, +) where + +import Dtmc.Analysis.Classification ( + absorbingStates, + reachesAny, + ) +import Dtmc.Analysis.Event ( + DiscreteEvent (..), + ) +import Dtmc.Analysis.Expectation ( + Expectation (..), + ) +import Dtmc.Analysis.FiniteTime qualified as FT +import Dtmc.Analysis.HittingTime qualified as Hit +import Dtmc.Analysis.Stationary ( + stationaryDistributions, + ) +import Dtmc.Analysis.VisitCount qualified as Visit +import Dtmc.Distribution ( + Distribution (..), + ) +import Dtmc.Distribution.Vector ( + DistributionVector, + ) +import Dtmc.Distribution.Vector qualified as Vector +import Dtmc.State ( + FiniteState, + ) +import Dtmc.TestSupport ( + chunksOf, + ) +import Dtmc.Transition.Matrix ( + TransitionMatrix, + fromRows, + ) +import GHC.Generics ( + Generic, + ) +import Numeric.Natural ( + Natural, + ) +import Test.Hspec ( + Spec, + describe, + it, + shouldBe, + ) + +checked :: (Show error) => Either error value -> value +checked = either (error . show) id + +data CafeState + = Thinking + | Menu + | Drink + | Food + | PlainWaffle + | ChocolateWaffle + | Leave + deriving (Eq, Ord, Show, Generic) + +instance FiniteState CafeState + +data FruitState + = Apple + | Pear + | Banana + | Mango + | Kiwi + | Watermelon + | Grapefruit + deriving (Eq, Ord, Show, Generic) + +instance FiniteState FruitState + +data Weather = Dry | Wet + deriving (Eq, Ord, Show, Generic) + +instance FiniteState Weather + +weatherTransition :: TransitionMatrix Weather +weatherTransition = + checked + ( fromRows + (chunksOf 2 [0.9, 0.1, 0.4, 0.6]) + ) + +weatherStationary :: DistributionVector Weather +weatherStationary = + case checked (stationaryDistributions weatherTransition) of + [(_, distribution)] -> distribution + _ -> error "weather transition does not have a unique stationary distribution" + +fruitTransition :: TransitionMatrix FruitState +fruitTransition = + checked + ( fromRows + ( chunksOf + 7 + [ 0 + , 0 + , 1 / 2 + , 1 / 2 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 1 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 1 / 3 + , 1 / 3 + , 1 / 3 + , 0 + , 0 + , 0 + , 0 + , 0 + , 2 / 3 + , 1 / 3 + , 0 + , 1 + , 0 + , 0 + , 0 + , 0 + , 0 + , 1 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 1 + , 0 + , 0 + , 0 + , 0 + , 0 + ] + ) + ) + +appleToMangoProbability :: Int -> Double +appleToMangoProbability n = + 5 / 7 - 3 / 14 * ((-(1 / 6)) ^ n) + +mangoToPearProbability :: Int -> Double +mangoToPearProbability n = + 3 / 7 - 2 / 21 * ((-(1 / 6)) ^ n) + +cafeInitial :: DistributionVector CafeState +cafeInitial = + checked + ( Vector.fromList [1, 0, 0, 0, 0, 0, 0] + ) + +cafeTransition :: TransitionMatrix CafeState +cafeTransition = + checked + ( fromRows + ( chunksOf + 7 + [ 0 + , 1 / 5 + , 0 + , 1 / 5 + , 1 / 5 + , 1 / 5 + , 1 / 5 + , 1 / 5 + , 0 + , 2 / 5 + , 0 + , 2 / 5 + , 0 + , 0 + , 0 + , 0 + , 0 + , 1 / 2 + , 0 + , 0 + , 1 / 2 + , 1 / 2 + , 0 + , 0 + , 0 + , 0 + , 1 / 2 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 1 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 1 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 1 + ] + ) + ) + +spec :: Spec +spec = + describe "public module integration" $ do + it "computes a stationary distribution" $ do + abs (probabilityAt weatherStationary Dry - 0.8) < 1e-12 + `shouldBe` True + abs (probabilityAt weatherStationary Wet - 0.2) < 1e-12 + `shouldBe` True + + it "matches the apple-to-mango transition closed form" $ + mapM_ + ( \n -> + abs + ( FT.nStepProbability + (3 * n + 1) + fruitTransition + Apple + Mango + - appleToMangoProbability (fromIntegral n) + ) + < 1e-12 + `shouldBe` True + ) + ([0, 1, 2, 3, 675] :: [Natural]) + + it "matches the mango-to-pear transition closed form" $ + mapM_ + ( \n -> + abs + ( FT.nStepProbability + (3 * n + 2) + fruitTransition + Mango + Pear + - mangoToPearProbability (fromIntegral n) + ) + < 1e-12 + `shouldBe` True + ) + ([0, 1, 2, 3, 4] :: [Natural]) + + it "runs the seven-state cafe analysis entirely with named states" $ do + probabilityAt cafeInitial Thinking `shouldBe` 1 + reachesAny cafeTransition Thinking [Leave] `shouldBe` True + absorbingStates cafeTransition `shouldBe` [Leave] + abs + (checked (Hit.eventualProbabilityGivenInitialState cafeTransition [Leave] Thinking) - 1) + < 1e-12 + `shouldBe` True + abs + ( checked + (Hit.eventualProbabilityGivenInitialState cafeTransition [Drink] Thinking) + - 4 / 43 + ) + < 1e-12 + `shouldBe` True + abs + ( checked + ( Hit.raceProbabilityGivenInitialState + cafeTransition + [PlainWaffle, ChocolateWaffle] + [Drink, Leave] + Thinking + ) + - 29 / 43 + ) + < 1e-12 + `shouldBe` True + + it "uses qualified finite-horizon visit-count analysis" $ + Visit.boundedExpectation 1 cafeInitial cafeTransition (== Thinking) + `shouldBe` 1 + + it "uses qualified infinite-horizon total visit-count analysis" $ do + checked (Visit.infiniteProbabilityGivenInitialState weatherTransition Dry Wet) + `shouldBe` 1 + checked (Visit.totalProbabilityGivenInitialState (EqualTo 1) weatherTransition Dry Wet) + `shouldBe` 0 + checked (Visit.totalExpectationGivenInitialState weatherTransition Dry Wet) + `shouldBe` InfiniteExpectation + + it "uses qualified conditional-probability errors" $ + FT.probabilityGiven + cafeInitial + cafeTransition + [] + [FT.At 0 Leave] + `shouldBe` Left FT.ZeroProbabilityCondition + + it "uses qualified timed-observation probabilities" $ + FT.probability cafeInitial cafeTransition [FT.At 0 Thinking] + `shouldBe` 1 diff --git a/test/Dtmc/SimulationSpec.hs b/test/Dtmc/SimulationSpec.hs new file mode 100644 --- /dev/null +++ b/test/Dtmc/SimulationSpec.hs @@ -0,0 +1,287 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TypeApplications #-} + +module Dtmc.SimulationSpec ( + spec, +) where + +import Control.Monad ( + replicateM, + ) +import Control.Monad.ST ( + runST, + ) +import Data.Finite ( + Finite, + ) +import Dtmc.Distribution ( + Distribution (..), + ) +import Dtmc.Distribution.Map ( + pointMass, + fromDistribution, + ) +import Dtmc.Distribution.Vector qualified as Vector +import Dtmc.Simulation ( + SimulationError (..), + sample, + simulate, + step, + ) +import Dtmc.State (FiniteState) +import Dtmc.TestSupport ( + chunksOf, + ) +import Dtmc.Transition.Kernel qualified as Kernel +import Dtmc.Transition.Matrix ( + TransitionMatrix, + fromRows, + ) +import GHC.Generics (Generic) +import Numeric.Natural ( + Natural, + ) +import System.Random.MWC qualified as MWC +import Test.Hspec ( + Spec, + describe, + it, + shouldBe, + ) + +data NamedSample = FirstSample | SecondSample | ThirdSample + deriving (Eq, Ord, Show, Generic) + +instance FiniteState NamedSample + +newtype UncheckedDistribution + = UncheckedDistribution [(Int, Double)] + +instance Distribution UncheckedDistribution where + type DistributionState UncheckedDistribution = Int + + probabilityAt (UncheckedDistribution entries) state = + sum + [ weight + | (storedState, weight) <- entries + , storedState == state + ] + + distributionWeights (UncheckedDistribution entries) = entries + +checkedSimulation :: (Monad m) => m (Either SimulationError value) -> m value +checkedSimulation action = do + result <- action + pure (either (error . show) id result) + +cyclicThree :: TransitionMatrix (Finite 3) +cyclicThree = + either (error . show) id $ + fromRows + ( chunksOf + 3 + [ 0 + , 1 + , 0 + , 0 + , 0 + , 1 + , 1 + , 0 + , 0 + ] + ) + +namedCyclicThree :: TransitionMatrix NamedSample +namedCyclicThree = + either (error . show) id $ + fromRows @NamedSample + (chunksOf 3 [0, 1, 0, 0, 0, 1, 1, 0, 0]) + +absorbingTwo :: TransitionMatrix (Finite 2) +absorbingTwo = + either (error . show) id $ + fromRows + ( chunksOf + 2 + [ 1 + , 0 + , 0.3 + , 0.7 + ] + ) + +threeCycleOrbit :: [Finite 3] +threeCycleOrbit = runST $ do + generator <- MWC.create + first <- checkedSimulation (step cyclicThree 0 generator) + second <- checkedSimulation (step cyclicThree first generator) + third <- checkedSimulation (step cyclicThree second generator) + pure [first, second, third] + +namedThreeCycleOrbit :: [NamedSample] +namedThreeCycleOrbit = runST $ do + generator <- MWC.create + first <- checkedSimulation (step namedCyclicThree FirstSample generator) + second <- checkedSimulation (step namedCyclicThree first generator) + third <- checkedSimulation (step namedCyclicThree second generator) + pure [first, second, third] + +absorbingSamples :: [Finite 2] +absorbingSamples = runST $ do + generator <- MWC.create + replicateM 50 (checkedSimulation (step absorbingTwo 0 generator)) + +pointMassSamples :: [Finite 3] +pointMassSamples = runST $ do + generator <- MWC.create + let distribution = + either (error . show) id $ + Vector.fromList @(Finite 3) [0, 1, 0] + replicateM 20 (checkedSimulation (sample distribution generator)) + +namedPointMassSamples :: [NamedSample] +namedPointMassSamples = runST $ do + generator <- MWC.create + let distribution = + either (error . show) id $ + Vector.fromList @NamedSample [0, 1, 0] + replicateM 20 (checkedSimulation (sample distribution generator)) + +mapPointMassSamples :: [Natural] +mapPointMassSamples = runST $ do + generator <- MWC.create + replicateM 20 (checkedSimulation (sample (pointMass 7) generator)) + +sampleUnchecked :: [(Int, Double)] -> Either SimulationError Int +sampleUnchecked entries = runST $ do + generator <- MWC.create + sample (UncheckedDistribution entries) generator + +invalidSampleAndGeneratorState :: (Either SimulationError Int, Bool) +invalidSampleAndGeneratorState = runST $ do + generator <- MWC.create + before <- MWC.save generator + result <- sample (UncheckedDistribution []) generator + after <- MWC.save generator + pure (result, before == after) + +zeroStepAndGeneratorState :: (Either SimulationError [Finite 3], Bool) +zeroStepAndGeneratorState = runST $ do + generator <- MWC.create + before <- MWC.save generator + result <- + simulate + 0 + ( error "zero-step simulation evaluated its kernel" :: + TransitionMatrix (Finite 3) + ) + 0 + generator + after <- MWC.save generator + pure (result, before == after) + +emptyKernel :: Kernel.TransitionKernel Int +emptyKernel = + Kernel.fromLaws + (const (fromDistribution (UncheckedDistribution []))) + +spec :: Spec +spec = do + describe "sample" $ do + it "samples a dense point mass" $ + pointMassSamples `shouldBe` replicate 20 1 + + it "samples a dense point mass as a named state" $ + namedPointMassSamples `shouldBe` replicate 20 SecondSample + + it "samples a map-backed point mass through the same function" $ + mapPointMassSamples `shouldBe` replicate 20 7 + + it "repairs a tolerated negative weight" $ + sampleUnchecked [(1, -1e-12), (2, 1)] + `shouldBe` Right 2 + + it "rejects empty stored support" $ + sampleUnchecked [] + `shouldBe` Left EmptySupport + + it "rejects a non-finite weight by index" $ do + sampleUnchecked [(1, 0 / 0), (2, 1)] + `shouldBe` Left (NonFiniteWeight 0) + sampleUnchecked [(1, 1), (2, 1 / 0)] + `shouldBe` Left (NonFiniteWeight 1) + + it "rejects a weight below the repair tolerance" $ + sampleUnchecked [(1, -1e-6), (2, 1)] + `shouldBe` Left (NegativeWeight 0 (-1e-6)) + + it "rejects a non-positive repaired total" $ + sampleUnchecked [(1, 0), (2, -1e-12)] + `shouldBe` Left (NonPositiveTotal 0) + + it "rejects overflow in the total" $ + sampleUnchecked + [(1, 1.7976931348623157e308), (2, 1.7976931348623157e308)] + `shouldBe` Left NonFiniteTotal + + it "does not advance the generator when validation fails" $ do + let (result, unchanged) = invalidSampleAndGeneratorState + result `shouldBe` Left EmptySupport + unchanged `shouldBe` True + + describe "step" $ do + it "follows a deterministic three-cycle" $ + threeCycleOrbit `shouldBe` [1, 2, 0] + + it "follows a deterministic cycle over named states" $ + namedThreeCycleOrbit + `shouldBe` [SecondSample, ThirdSample, FirstSample] + + it "never leaves an absorbing state" $ + absorbingSamples `shouldBe` replicate 50 0 + + it "runs in ST through PrimMonad" $ + length threeCycleOrbit `shouldBe` 3 + + it "returns a transition-law validation failure" $ + runST + ( do + generator <- MWC.create + step emptyKernel 0 generator + ) + `shouldBe` Left EmptySupport + + describe "simulate" $ do + it "simulates a finite matrix through the shared interface" $ + let trajectory = runST $ do + generator <- MWC.create + checkedSimulation (simulate 4 cyclicThree 0 generator) + in trajectory `shouldBe` [0, 1, 2, 0, 1] + + it "returns the initial state plus the requested kernel transitions" $ + let trajectory = runST $ do + generator <- MWC.create + checkedSimulation + ( simulate + 4 + ( Kernel.fromLaws + (pointMass . (\state -> (state + 1) `mod` (3 :: Int))) + ) + 0 + generator + ) + in trajectory `shouldBe` [0, 1, 2, 0, 1] + + it "does not inspect the kernel or advance the generator at zero steps" $ do + let (result, unchanged) = zeroStepAndGeneratorState + result `shouldBe` Right [0] + unchanged `shouldBe` True + + it "stops at the first invalid transition law" $ + runST + ( do + generator <- MWC.create + simulate 3 emptyKernel 0 generator + ) + `shouldBe` Left EmptySupport diff --git a/test/Dtmc/StateSpec.hs b/test/Dtmc/StateSpec.hs new file mode 100644 --- /dev/null +++ b/test/Dtmc/StateSpec.hs @@ -0,0 +1,135 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE EmptyDataDeriving #-} +{-# LANGUAGE TypeApplications #-} + +module Dtmc.StateSpec ( + spec, +) where + +import Data.Finite ( + Finite, + finites, + getFinite, + ) +import Data.List ( + sort, + ) +import Data.Proxy ( + Proxy (Proxy), + ) +import Dtmc.State ( + Cardinality, + FiniteState, + finiteStates, + stateAt, + stateIndex, + ) +import GHC.Generics ( + Generic, + ) +import GHC.TypeNats ( + natVal, + ) +import Test.Hspec ( + Spec, + describe, + it, + shouldBe, + ) + +data Empty + deriving (Eq, Ord, Show, Generic) + +data One = One + deriving (Eq, Ord, Show, Generic) + +data Three = A | B | C + deriving (Eq, Ord, Show, Generic, FiniteState) + +instance FiniteState Empty + +instance FiniteState One + +spec :: Spec +spec = do + describe "generic FiniteState" $ do + it "can be derived directly in the state declaration" $ + finiteStates @Three `shouldBe` [A, B, C] + + it "derives cardinalities for empty, singleton, and sum types" $ do + natVal (Proxy @(Cardinality Empty)) `shouldBe` 0 + natVal (Proxy @(Cardinality One)) `shouldBe` 1 + natVal (Proxy @(Cardinality Three)) `shouldBe` 3 + + it "enumerates states in constructor order" $ + finiteStates @Three `shouldBe` [A, B, C] + + it "uses the same order as a stock Ord instance" $ + finiteStates @Three `shouldBe` sort (finiteStates @Three) + + it "round-trips every state through its finite index" $ + map (stateAt . stateIndex) (finiteStates @Three) + `shouldBe` finiteStates @Three + + it "round-trips every finite index through its state" $ + map (stateIndex . stateAt @Three) finites `shouldBe` finites + + it "assigns consecutive zero-based indices" $ + map (getFinite . stateIndex) (finiteStates @Three) + `shouldBe` [0, 1, 2] + + it "supports empty and singleton state types" $ do + finiteStates @Empty `shouldBe` [] + finiteStates @One `shouldBe` [One] + stateAt (stateIndex One) `shouldBe` One + + describe "Empty laws" (finiteStateLaws @Empty) + describe "One laws" (finiteStateLaws @One) + describe "Three laws" (finiteStateLaws @Three) + + describe "Finite identity instance" $ do + it "preserves enumeration and both conversions" $ do + finiteStates @(Finite 3) `shouldBe` finites + map stateIndex (finites @3) `shouldBe` finites + map stateAt (finites @3) `shouldBe` finites + + it "supports Finite 0" $ + finiteStates @(Finite 0) `shouldBe` [] + + describe "Finite 0 laws" (finiteStateLaws @(Finite 0)) + describe "Finite 3 laws" (finiteStateLaws @(Finite 3)) + + describe "base instances" $ do + it "use their standard constructor order" $ do + finiteStates @() `shouldBe` [()] + finiteStates @Bool `shouldBe` [False, True] + finiteStates @Ordering `shouldBe` [LT, EQ, GT] + + describe "() laws" (finiteStateLaws @()) + describe "Bool laws" (finiteStateLaws @Bool) + describe "Ordering laws" (finiteStateLaws @Ordering) + +finiteStateLaws :: + forall state. + (FiniteState state, Show state) => + Spec +finiteStateLaws = do + it "enumerates every finite index in canonical order" $ + finiteStates @state + `shouldBe` map (stateAt @state) (finites @(Cardinality state)) + + it "round-trips every state through its index" $ + map (stateAt . stateIndex) (finiteStates @state) + `shouldBe` finiteStates @state + + it "round-trips every index through its state" $ + map (stateIndex . stateAt @state) (finites @(Cardinality state)) + `shouldBe` finites @(Cardinality state) + + it "enumerates states in strictly ascending order" $ + and (zipWith (<) states (drop 1 states)) `shouldBe` True + where + states = finiteStates @state diff --git a/test/Dtmc/TestSupport.hs b/test/Dtmc/TestSupport.hs new file mode 100644 --- /dev/null +++ b/test/Dtmc/TestSupport.hs @@ -0,0 +1,284 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module Dtmc.TestSupport ( + testTolerance, + approxEq, + approxDistributionEq, + approxTransitionMatrixEq, + genSimplexPoint, + genTransitionRows, + chunksOf, + bumpSmallest, + bumpSmallestInFirstRow, + setFirstEntry, + hitProbabilityByState, + hitEventualProbabilityByState, + hitRaceProbabilityByState, + hitExpectationByState, + returnProbabilityByState, + returnEventualProbabilityByState, + returnExpectationByState, + visitTotalProbabilityByState, + visitInfiniteProbabilityByState, + visitTotalExpectationByState, + absorptionProbabilityByState, + absorptionExpectationByState, +) where + +import Dtmc.Analysis.Absorption qualified as Absorption +import Dtmc.Analysis.Event ( + DiscreteEvent, + ) +import Dtmc.Analysis.Expectation ( + Expectation, + ) +import Dtmc.Analysis.HittingTime qualified as Hit +import Dtmc.Analysis.LinearSystem ( + LinearSystemError, + ) +import Dtmc.Analysis.ReturnTime qualified as Return +import Dtmc.Analysis.VisitCount qualified as Visit +import Dtmc.Distribution.Vector ( + DistributionVector, + toList, + ) +import Dtmc.State ( + FiniteState, + finiteStates, + ) +import Dtmc.Transition.Matrix ( + TransitionMatrix, + toRows, + ) +import Test.QuickCheck ( + Gen, + choose, + frequency, + vectorOf, + ) + +hitProbabilityByState :: + forall state. + (FiniteState state) => + DiscreteEvent -> + TransitionMatrix state -> + [state] -> + [Double] +hitProbabilityByState event matrix targets = + [ Hit.probabilityGivenInitialState event matrix (`elem` targets) initial + | initial <- finiteStates + ] + +hitEventualProbabilityByState :: + forall state. + (FiniteState state) => + TransitionMatrix state -> + [state] -> + Either LinearSystemError [Double] +hitEventualProbabilityByState matrix targets = + traverse + (Hit.eventualProbabilityGivenInitialState matrix targets) + finiteStates + +hitRaceProbabilityByState :: + forall state. + (FiniteState state) => + TransitionMatrix state -> + [state] -> + [state] -> + Either LinearSystemError [Double] +hitRaceProbabilityByState matrix successful competing = + traverse + (Hit.raceProbabilityGivenInitialState matrix successful competing) + finiteStates + +hitExpectationByState :: + forall state. + (FiniteState state) => + TransitionMatrix state -> + [state] -> + Either LinearSystemError [Expectation] +hitExpectationByState matrix targets = + traverse + (Hit.expectationGivenInitialState matrix targets) + finiteStates + +returnProbabilityByState :: + forall state. + (FiniteState state) => + DiscreteEvent -> + TransitionMatrix state -> + [Double] +returnProbabilityByState event matrix = + [ Return.probabilityGivenInitialState event matrix initial + | initial <- finiteStates + ] + +returnEventualProbabilityByState :: + forall state. + (FiniteState state) => + TransitionMatrix state -> + Either LinearSystemError [Double] +returnEventualProbabilityByState matrix = + traverse + (Return.eventualProbabilityGivenInitialState matrix) + finiteStates + +returnExpectationByState :: + forall state. + (FiniteState state) => + TransitionMatrix state -> + Either LinearSystemError [Expectation] +returnExpectationByState matrix = + traverse + (Return.expectationGivenInitialState matrix) + finiteStates + +visitTotalProbabilityByState :: + forall state. + (FiniteState state) => + DiscreteEvent -> + TransitionMatrix state -> + state -> + Either LinearSystemError [Double] +visitTotalProbabilityByState event matrix target = + traverse + (Visit.totalProbabilityGivenInitialState event matrix target) + finiteStates + +visitInfiniteProbabilityByState :: + forall state. + (FiniteState state) => + TransitionMatrix state -> + state -> + Either LinearSystemError [Double] +visitInfiniteProbabilityByState matrix target = + traverse + (Visit.infiniteProbabilityGivenInitialState matrix target) + finiteStates + +visitTotalExpectationByState :: + forall state. + (FiniteState state) => + TransitionMatrix state -> + state -> + Either LinearSystemError [Expectation] +visitTotalExpectationByState matrix target = + traverse + (Visit.totalExpectationGivenInitialState matrix target) + finiteStates + +absorptionProbabilityByState :: + forall state. + (FiniteState state) => + TransitionMatrix state -> + state -> + Either LinearSystemError [Double] +absorptionProbabilityByState matrix target = + traverse + (Absorption.probabilityGivenInitialState matrix target) + finiteStates + +absorptionExpectationByState :: + forall state. + (FiniteState state) => + TransitionMatrix state -> + Either LinearSystemError [Expectation] +absorptionExpectationByState matrix = + traverse + (Absorption.expectationGivenInitialState matrix) + finiteStates + +{- | Absolute slack the tests use when comparing floating-point results. Kept +independent of the library's private validation threshold so a change there +cannot silently mask a regression here; the two happen to share a value. +-} +testTolerance :: Double +testTolerance = 1e-9 + +{- | Absolute-tolerance comparison of two scalar 'Double' results, matching the +@abs (x - y) <= tolerance@ convention of the vector and matrix helpers. +-} +approxEq :: Double -> Double -> Double -> Bool +approxEq tolerance left right = + abs (left - right) <= tolerance + +genSimplexPoint :: Int -> Gen [Double] +genSimplexPoint dimension = do + entries <- vectorOf dimension genEntry + let total = sum entries + if total == 0 + then genSimplexPoint dimension + else pure (map (/ total) entries) + where + genEntry = + frequency + [ (3, pure 0) + , (7, choose (0, 1000)) + ] + +{- | Generate a square grid of weights whose rows are probability vectors, +ready for 'Dtmc.Transition.Matrix.fromRows'. +-} +genTransitionRows :: Int -> Gen [[Double]] +genTransitionRows dimension = + vectorOf dimension (genSimplexPoint dimension) + +-- | Split a flat row-major list into rows of the given width. +chunksOf :: Int -> [value] -> [[value]] +chunksOf width values + | width <= 0 || null values = [] + | otherwise = row : chunksOf width rest + where + (row, rest) = splitAt width values + +bumpSmallest :: Double -> [Double] -> [Double] +bumpSmallest _ [] = [] +bumpSmallest amount entries = + zipWith bump [0 :: Int ..] entries + where + smallestIndex = + snd (minimum (zip entries [0 :: Int ..])) + + bump index entry + | index == smallestIndex = entry + amount + | otherwise = entry + +bumpSmallestInFirstRow :: + Double -> + [[Double]] -> + [[Double]] +bumpSmallestInFirstRow _ [] = [] +bumpSmallestInFirstRow amount (row : rows) = + bumpSmallest amount row : rows + +setFirstEntry :: + Double -> + [[Double]] -> + [[Double]] +setFirstEntry value ((_ : rest) : rows) = + (value : rest) : rows +setFirstEntry _ rows = rows + +approxTransitionMatrixEq :: + Double -> + TransitionMatrix state -> + TransitionMatrix state -> + Bool +approxTransitionMatrixEq tolerance left right = + and (zipWith close (entries left) (entries right)) + where + entries = concat . toRows + close x y = abs (x - y) <= tolerance + +approxDistributionEq :: + Double -> + DistributionVector state -> + DistributionVector state -> + Bool +approxDistributionEq tolerance left right = + and (zipWith close (entries left) (entries right)) + where + entries = toList + close x y = abs (x - y) <= tolerance diff --git a/test/Dtmc/Transition/InterfaceSpec.hs b/test/Dtmc/Transition/InterfaceSpec.hs new file mode 100644 --- /dev/null +++ b/test/Dtmc/Transition/InterfaceSpec.hs @@ -0,0 +1,128 @@ +{-# LANGUAGE TypeApplications #-} + +module Dtmc.Transition.InterfaceSpec ( + spec, +) where + +import Data.Finite ( + Finite, + finites, + ) +import Dtmc.Analysis.FiniteTime ( + stepProbability, + ) +import Dtmc.Distribution qualified as Distribution +import Dtmc.Distribution.Map qualified as DistributionMap +import Dtmc.TestSupport ( + approxEq, + chunksOf, + genTransitionRows, + ) +import Dtmc.Transition qualified as Transition +import Dtmc.Transition.Kernel qualified as Kernel +import Dtmc.Transition.Matrix ( + TransitionMatrix, + TransitionMatrixError, + fromRows, + ) +import Test.Hspec ( + Spec, + describe, + it, + shouldBe, + ) +import Test.Hspec.QuickCheck ( + prop, + ) +import Test.QuickCheck ( + conjoin, + counterexample, + forAll, + ) + +checked :: (Show error) => Either error value -> value +checked = either (error . show) id + +finiteChain :: TransitionMatrix (Finite 3) +finiteChain = + checked $ + fromRows + ( chunksOf + 3 + [ 0.5 + , 0.5 + , 0 + , 0 + , 0.2 + , 0.8 + , 1 + , 0 + , 0 + ] + ) + +asTransitionKernel :: + TransitionMatrix (Finite 3) -> + Kernel.TransitionKernel (Finite 3) +asTransitionKernel matrix = + Kernel.fromLaws $ \source -> + checked $ + DistributionMap.fromList + [ (destination, stepProbability matrix source destination) + | destination <- finites + ] + +spec :: Spec +spec = + describe "Transition interface" $ do + it "exposes a matrix row as a finite-support transition law" $ + Distribution.distributionWeights (Transition.transitionLaw finiteChain 1) + `shouldBe` [(1, 0.2), (2, 0.8)] + + it "exposes a source-dependent kernel through the same operation" $ + let kernel = + Kernel.fromLaws $ \source -> + checked $ + DistributionMap.fromList + [(source, 0.25), (source + 1, 0.75 :: Double)] + in Distribution.distributionWeights (Transition.transitionLaw kernel (4 :: Int)) + `shouldBe` [(4, 0.25), (5, 0.75)] + + it "exposes deterministic kernels as point-mass laws" $ + Distribution.distributionWeights + ( Transition.transitionLaw + (Kernel.fromLaws (DistributionMap.pointMass . (+ 1))) + (4 :: Int) + ) + `shouldBe` [(5, 1)] + + prop "gives matrices and equivalent kernels approximately equal laws" $ + forAll (genTransitionRows 3) $ \rawMatrix -> + case fromRows rawMatrix :: + Either TransitionMatrixError (TransitionMatrix (Finite 3)) of + Left problem -> counterexample (show problem) False + Right matrix -> + let kernel = asTransitionKernel matrix + in conjoin + [ let matrixLaw = + Transition.transitionLaw matrix source + kernelLaw = + Transition.transitionLaw kernel source + in counterexample ("source: " <> show source) $ + Distribution.support matrixLaw + == Distribution.support kernelLaw + && and + [ approxEq + 1e-12 + ( Distribution.probabilityAt + matrixLaw + destination + ) + ( Distribution.probabilityAt + kernelLaw + destination + ) + | destination <- finites :: [Finite 3] + ] + | source <- finites :: [Finite 3] + ] diff --git a/test/Dtmc/Transition/KernelSpec.hs b/test/Dtmc/Transition/KernelSpec.hs new file mode 100644 --- /dev/null +++ b/test/Dtmc/Transition/KernelSpec.hs @@ -0,0 +1,47 @@ +module Dtmc.Transition.KernelSpec ( + spec, +) where + +import Dtmc.Distribution qualified as Distribution +import Dtmc.Distribution.Map qualified as DistributionMap +import Dtmc.Transition qualified as Transition +import Dtmc.Transition.Kernel qualified as Kernel +import Test.Hspec ( + Spec, + describe, + it, + shouldBe, + ) + +checked :: (Show error) => Either error value -> value +checked = either (error . show) id + +simpleRandomWalk :: Kernel.TransitionKernel Integer +simpleRandomWalk = + Kernel.fromLaws $ \state -> + checked + (DistributionMap.fromList [(state - 1, 0.5), (state + 1, 0.5)]) + +spec :: Spec +spec = + describe "TransitionKernel" $ do + it "preserves source-dependent transition laws" $ + let kernel = + Kernel.fromLaws $ \source -> + checked $ + DistributionMap.fromList + [(source - 1, 0.4), (source + 1, 0.6 :: Double)] + in Distribution.distributionWeights (Transition.transitionLaw kernel (10 :: Integer)) + `shouldBe` [(9, 0.4), (11, 0.6)] + + it "constructs deterministic point-mass transitions" $ + Distribution.distributionWeights + ( Transition.transitionLaw + (Kernel.fromLaws (DistributionMap.pointMass . (* 2))) + (6 :: Integer) + ) + `shouldBe` [(12, 1)] + + it "supports locally finite laws on an infinite state type" $ + Distribution.distributionWeights (Transition.transitionLaw simpleRandomWalk 0) + `shouldBe` [(-1, 0.5), (1, 0.5)] diff --git a/test/Dtmc/Transition/MatrixSpec.hs b/test/Dtmc/Transition/MatrixSpec.hs new file mode 100644 --- /dev/null +++ b/test/Dtmc/Transition/MatrixSpec.hs @@ -0,0 +1,426 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TypeApplications #-} + +module Dtmc.Transition.MatrixSpec ( + spec, +) where + +import Data.Finite ( + Finite, + ) +import Dtmc.Distribution ( + distributionWeights, + ) +import Dtmc.Distribution.Map qualified as DistributionMap +import Dtmc.Distribution.Vector qualified as Vector +import Dtmc.Simplex (SimplexError (..)) +import Dtmc.State ( + FiniteState, + ) +import Dtmc.TestSupport ( + approxEq, + approxTransitionMatrixEq, + bumpSmallestInFirstRow, + chunksOf, + genTransitionRows, + setFirstEntry, + testTolerance, + ) +import Dtmc.Transition.Kernel qualified as Kernel +import Dtmc.Transition.Matrix ( + TransitionMatrix, + TransitionMatrixError (..), + compose, + fromKernel, + fromRows, + identity, + power, + rowAt, + toRows, + ) +import GHC.Generics ( + Generic, + ) +import Test.Hspec ( + Spec, + describe, + expectationFailure, + it, + shouldBe, + ) +import Test.Hspec.QuickCheck ( + prop, + ) +import Test.QuickCheck ( + choose, + conjoin, + counterexample, + forAll, + property, + ) + +data NamedPhase = PhaseA | PhaseB | PhaseC + deriving (Eq, Ord, Show, Generic) + +instance FiniteState NamedPhase + +cyclicThree :: TransitionMatrix (Finite 3) +cyclicThree = + either (error . show) id $ + fromRows + (chunksOf 3 [0, 1, 0, 0, 0, 1, 1, 0, 0]) + +namedCycle :: TransitionMatrix NamedPhase +namedCycle = + either (error . show) id $ + fromRows @NamedPhase + (chunksOf 3 [0, 1, 0, 0, 0, 1, 1, 0, 0]) + +twoState :: TransitionMatrix (Finite 2) +twoState = + either (error . show) id $ + fromRows + (chunksOf 2 [0.9, 0.1, 0.4, 0.6]) + +twoStateSquared :: TransitionMatrix (Finite 2) +twoStateSquared = + either (error . show) id $ + fromRows + (chunksOf 2 [0.85, 0.15, 0.6, 0.4]) + +spec :: Spec +spec = do + describe "fromKernel" $ do + let successor state = + case state of + PhaseA -> PhaseB + PhaseB -> PhaseC + PhaseC -> PhaseA + materialised = + fromKernel + (Kernel.fromLaws (DistributionMap.pointMass . successor)) :: + TransitionMatrix NamedPhase + + it "materialises a finite deterministic kernel" $ + approxTransitionMatrixEq 0 materialised namedCycle `shouldBe` True + + it "exposes rows without hmatrix types" $ + toRows materialised + `shouldBe` [[0, 1, 0], [0, 0, 1], [1, 0, 0]] + + it "materialises the empty finite chain" $ + toRows + ( fromKernel (Kernel.fromLaws DistributionMap.pointMass) :: + TransitionMatrix (Finite 0) + ) + `shouldBe` [] + + describe "fromRows" $ do + it "constructs the empty finite chain" $ + case fromRows @(Finite 0) [] of + Right transitionMatrix -> toRows transitionMatrix `shouldBe` [] + Left err -> expectationFailure ("expected acceptance, got " <> show err) + + it "reports too few rows before inspecting their widths" $ + case fromRows @(Finite 2) [[1]] of + Left err -> err `shouldBe` WrongRowCount 2 1 + Right _ -> expectationFailure "expected rejection" + + it "reports too many rows before inspecting their widths" $ + case fromRows @(Finite 2) [[1, 0], [0, 1], [1]] of + Left err -> err `shouldBe` WrongRowCount 2 3 + Right _ -> expectationFailure "expected rejection" + + it "reports the first row with the wrong width" $ + case fromRows @(Finite 2) [[1, 0, 0], [1]] of + Left err -> err `shouldBe` WrongRowWidth 0 2 3 + Right _ -> expectationFailure "expected rejection" + + it "reports a later row with the wrong width" $ + case fromRows @(Finite 2) [[1, 0], [1]] of + Left err -> err `shouldBe` WrongRowWidth 1 2 1 + Right _ -> expectationFailure "expected rejection" + + prop "stores canonical rows close to the accepted input" $ + forAll (genTransitionRows 3) $ \matrix -> + case fromRows @(Finite 3) matrix of + Right transitionMatrix -> + let storedRows = toRows transitionMatrix + inputRows = matrix + closeRow left right = + and + ( zipWith + (approxEq testTolerance) + left + right + ) + in counterexample ("stored rows: " <> show storedRows) $ + property + ( all + ( \row -> + all + (\entry -> entry >= 0 && entry <= 1) + row + && approxEq 1e-12 (sum row) 1 + ) + storedRows + && and (zipWith closeRow storedRows inputRows) + ) + Left err -> + counterexample + ("generated matrix was rejected: " <> show err) + False + + it "canonicalises tolerated error independently in each row" $ + case fromRows @(Finite 2) + (chunksOf 2 [-5e-10, 1 + 5e-10, 0.5, 0.5 - 5e-10]) of + Right transitionMatrix -> do + let rows = toRows transitionMatrix + case rows of + firstRow : secondRow : _ -> do + firstRow `shouldBe` [0, 1] + approxEq 1e-12 (sum secondRow) 1 `shouldBe` True + _ -> + expectationFailure "expected two rows" + Left err -> + expectationFailure + ("expected acceptance, got " <> show err) + + it "reports a non-finite coordinate with its row and column" $ + case fromRows @(Finite 2) + (chunksOf 2 [1, 0, 0, 1 / 0]) of + Left err -> + err `shouldBe` InRow 1 (NonFiniteEntry 1) + Right _ -> + expectationFailure "expected rejection" + + prop "identifies a row whose sum is invalid" $ + forAll (genTransitionRows 3) $ \matrix -> + let invalid = bumpSmallestInFirstRow 1e-6 matrix + in case fromRows @(Finite 3) invalid of + Left (InRow 0 (SumOffBy _)) -> + property True + result -> + counterexample + ("expected InRow 0 SumOffBy, got " <> show result) + False + + prop "identifies a negative entry by row and column" $ + forAll (genTransitionRows 3) $ \matrix -> + let invalid = setFirstEntry (-1e-6) matrix + in case fromRows @(Finite 3) invalid of + Left (InRow 0 (NegativeEntry 0 _)) -> + property True + result -> + counterexample + ("expected InRow 0 NegativeEntry 0, got " <> show result) + False + + describe "compose" $ do + prop "is closed under multiplication" + $ forAll + ((,) <$> genTransitionRows 3 <*> genTransitionRows 3) + $ \(left, right) -> + case (fromRows @(Finite 3) left, fromRows @(Finite 3) right) of + (Right leftMatrix, Right rightMatrix) -> + case fromRows @(Finite 3) + (toRows (compose leftMatrix rightMatrix)) of + Right _ -> + property True + Left err -> + counterexample + ("matrix product was rejected: " <> show err) + False + result -> + counterexample + ("generated matrix was rejected: " <> show result) + False + + prop "approximately equals itself at zero tolerance" $ + forAll (genTransitionRows 3) $ \matrix -> + case fromRows @(Finite 3) matrix of + Right transitionMatrix -> + property + ( approxTransitionMatrixEq + 0 + transitionMatrix + transitionMatrix + ) + Left err -> + counterexample + ("generated matrix was rejected: " <> show err) + False + + describe "TransitionMatrix Semigroup" $ do + prop "composition is approximately associative" + $ forAll + ( (,,) + <$> genTransitionRows 3 + <*> genTransitionRows 3 + <*> genTransitionRows 3 + ) + $ \(matrixA, matrixB, matrixC) -> + case ( fromRows @(Finite 3) matrixA + , fromRows @(Finite 3) matrixB + , fromRows @(Finite 3) matrixC + ) of + (Right a, Right b, Right c) -> + property $ + approxTransitionMatrixEq + 1e-9 + ((a <> b) <> c) + (a <> (b <> c)) + result -> + counterexample + ("generated matrices were rejected: " <> show result) + False + + describe "TransitionMatrix Monoid" $ do + prop "has a left identity" $ + forAll (genTransitionRows 3) $ \matrix -> + case fromRows @(Finite 3) matrix of + Right p -> + property $ + approxTransitionMatrixEq + 1e-12 + (mempty <> p) + p + Left err -> + counterexample + ("generated matrix was rejected: " <> show err) + False + + prop "has a right identity" $ + forAll (genTransitionRows 3) $ \matrix -> + case fromRows @(Finite 3) matrix of + Right p -> + property $ + approxTransitionMatrixEq + 1e-12 + (p <> mempty) + p + Left err -> + counterexample + ("generated matrix was rejected: " <> show err) + False + + it "uses the identity transition matrix as mempty" $ + approxTransitionMatrixEq + 1e-12 + (mempty :: TransitionMatrix (Finite 2)) + identity + `shouldBe` True + + describe "power" $ do + it "returns the identity at exponent zero" $ + approxTransitionMatrixEq + 1e-12 + (power 0 twoState) + identity + `shouldBe` True + + it "returns the matrix itself at exponent one" $ + approxTransitionMatrixEq + 1e-12 + (power 1 twoState) + twoState + `shouldBe` True + + it "matches a hand-computed square" $ + approxTransitionMatrixEq + 1e-9 + (power 2 twoState) + twoStateSquared + `shouldBe` True + + prop "stays stochastic for small exponents" $ + forAll ((,) <$> choose (0, 6 :: Int) <*> genTransitionRows 3) $ + \(k, matrix) -> + case fromRows @(Finite 3) matrix of + Right p -> + case fromRows @(Finite 3) + (toRows (power (fromIntegral k) p)) of + Right _ -> + property True + Left err -> + counterexample + ("power left the stochastic set: " <> show err) + False + Left err -> + counterexample + ("generated matrix was rejected: " <> show err) + False + + prop "satisfies the power addition law" + $ forAll + ( (,,) + <$> choose (0, 6 :: Int) + <*> choose (0, 6 :: Int) + <*> genTransitionRows 3 + ) + $ \(m, n, matrix) -> + case fromRows @(Finite 3) matrix of + Right p -> + property $ + approxTransitionMatrixEq + 1e-9 + (power (fromIntegral (m + n)) p) + ( power (fromIntegral m) p + <> power (fromIntegral n) p + ) + Left err -> + counterexample + ("generated matrix was rejected: " <> show err) + False + + describe "rowAt" $ do + it "reads rows rather than columns" $ + Vector.toList (rowAt cyclicThree 0) + `shouldBe` [0, 1, 0] + + it "returns each row of the three-cycle" $ do + let row index = Vector.toList (rowAt cyclicThree index) + + row 0 `shouldBe` [0, 1, 0] + row 1 `shouldBe` [0, 0, 1] + row 2 `shouldBe` [1, 0, 0] + + prop "always returns a valid distribution" $ + forAll (genTransitionRows 3) $ \matrix -> + case fromRows @(Finite 3) matrix of + Right transitionMatrix -> + conjoin + [ case Vector.fromList @(Finite 3) + (Vector.toList (rowAt transitionMatrix index)) of + Right _ -> + property True + Left err -> + counterexample + ("row was rejected: " <> show err) + False + | index <- [0 .. 2] + ] + Left err -> + counterexample + ("generated matrix was rejected: " <> show err) + False + + describe "named finite states" $ do + it "returns a row labelled by named constructors" $ + distributionWeights (rowAt namedCycle PhaseA) + `shouldBe` [(PhaseB, 1)] + + it "preserves the named state type through powers" $ + distributionWeights (rowAt (power 2 namedCycle) PhaseA) + `shouldBe` [(PhaseC, 1)] + + it "provides a named identity matrix" $ + distributionWeights (rowAt (identity @NamedPhase) PhaseB) + `shouldBe` [(PhaseB, 1)] + + it "composes matrices without changing their named state type" $ + approxTransitionMatrixEq + 0 + (namedCycle <> identity) + namedCycle + `shouldBe` True diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}