deltaq (empty) → 1.0.0.0
raw patch · 15 files changed
+2120/−0 lines, 15 filesdep +Chartdep +QuickCheckdep +base
Dependencies added: Chart, QuickCheck, base, bytestring, cassava, criterion, deepseq, deltaq, hspec, hvega, lattices, optparse-applicative, probability-polynomial, statistics, vector
Files
- CHANGELOG.md +6/−0
- LICENSE +28/−0
- README.md +6/−0
- benchmark/Benchmark/Plot.hs +146/−0
- benchmark/Main.hs +96/−0
- deltaq.cabal +112/−0
- src/DeltaQ.hs +114/−0
- src/DeltaQ/Class.hs +352/−0
- src/DeltaQ/Methods.hs +85/−0
- src/DeltaQ/PiecewisePolynomial.hs +268/−0
- src/DeltaQ/Plot.hs +257/−0
- test/DeltaQ/ClassSpec.hs +76/−0
- test/DeltaQ/MethodsSpec.hs +64/−0
- test/DeltaQ/PiecewisePolynomialSpec.hs +509/−0
- test/Spec.hs +1/−0
+ CHANGELOG.md view
@@ -0,0 +1,6 @@+# Revision history for `deltaq`++## 1.0.0.0 — 2024-12-23++* Initial release of the domain-specific language for ∆Q System Development.+* Implementation based on `probability-polynomial`.
+ LICENSE view
@@ -0,0 +1,28 @@+BSD 3-Clause License++Copyright (c) 2003-2024, Predictable Network Solutions Ltd.++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.
+ README.md view
@@ -0,0 +1,6 @@+∆Q System Development is a paradigm for developing distributed systems+that meet performance requirements.++The `deltaq` package (pronounced "Delta Q")+implements a domain specific language (DSL) in Haskell+for specfying outcomes and evaluating their performance characteristics.
+ benchmark/Benchmark/Plot.hs view
@@ -0,0 +1,146 @@+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}++{-|+Copyright : Predictable Network Solutions Ltd., 2003-2024+License : BSD-3-Clause+Description : Plotting utilities for benchmark results.+-}+module Benchmark.Plot where++import Data.String+ ( fromString+ )++import qualified Data.ByteString.Lazy as BL+import qualified Data.Csv as C+import qualified Data.Vector as V+import qualified Graphics.Vega.VegaLite as G++{-----------------------------------------------------------------------------+ Data+------------------------------------------------------------------------------}+type Time = Double -- in seconds++data Measurement = Measurement+ { mName :: String+ -- ^ Name used for grouping the expression+ , mTime :: Time+ -- ^ Time required to evaluate the expression to Normal Form.+ , mExpressionSize :: Int+ -- ^ Size of the expression as we write it down.+ , mValueComplexity :: Int+ -- ^ Complexity of the value represented by the expression.+ }+ deriving (Eq, Show, Read)++{-----------------------------------------------------------------------------+ Read+------------------------------------------------------------------------------}+readCsv :: FilePath -> String -> IO [Measurement]+readCsv fpath op = do+ file <- BL.readFile fpath+ let Right (_, measurements) = C.decodeByName file+ pure $ filter ((op ==) . mName) $ V.toList measurements++instance C.FromNamedRecord Measurement where+ parseNamedRecord r =+ mkMeasurement <$> r C..: "Name" <*> r C..: "Mean"+ where+ mkMeasurement name time =+ Measurement+ { mName = take 4 name+ , mTime = time+ , mExpressionSize = size+ , mValueComplexity = size -- FIXME: Record complexities.+ }+ where+ size = read $ drop (length prefix) $ name+ prefix = ".>>./m = " :: String++{-----------------------------------------------------------------------------+ Plot+------------------------------------------------------------------------------}+-- | Plot all operations in the current directory.+plotAllOperations :: FilePath -> [Measurement] -> IO ()+plotAllOperations dir xs = do+ plotOp "sequentially" ".>>."+ plotOp "lastToFinish" "./\\."+ plotOp "firstToFinish" ".\\/."+ where+ plotOp name ticker = do+ let ys = filter ((ticker == ) . mName) xs+ plotExprToHtmlFile (dir <> "/expr-" <> name <> ".html") ys+ plotComplexityToHtmlFile (dir <> "/complexity-" <> name <> ".html") ys++-- | Time against expression size.+plotExprToHtmlFile :: FilePath -> [Measurement] -> IO ()+plotExprToHtmlFile fpath measurements =+ G.toHtmlFile fpath . G.toVegaLite $+ [ enc []+ , G.title ("Operation " <> fromString name) []+ , G.layer [ values, points ]+ , G.height 300+ , G.width 400+ ]+ where+ enc = G.encoding+ . G.position G.X+ [ G.PName "M"+ , G.PmType G.Quantitative+ , G.PAxis [ G.AxTickMinStep 1 ]+ ]+ . G.position G.Y [ G.PName "Time / ms", G.PmType G.Quantitative ]+ mkData xfs = G.dataFromColumns []+ . G.dataColumn "M" (G.Numbers xs)+ . G.dataColumn "Time / ms" (G.Numbers fs)+ $ []+ where (xs, fs) = unzip xfs++ name = mName $ head measurements+ xys = map (\m -> (fromIntegral $ mExpressionSize m, 1000 * mTime m)) measurements++ values = G.asSpec+ [ mkData xys+ , G.mark G.Line []+ ]+ points = G.asSpec+ [ mkData xys+ , G.mark G.Circle []+ ]++-- | Time against complexity.+plotComplexityToHtmlFile :: FilePath -> [Measurement] -> IO ()+plotComplexityToHtmlFile fpath measurements =+ G.toHtmlFile fpath . G.toVegaLite $+ [ enc []+ , G.title ("Operation " <> fromString name) []+ , G.layer [ values, points ]+ , G.height 300+ , G.width 400+ ]+ where+ enc = G.encoding+ . G.position G.X+ [ G.PName "Complexity"+ , G.PmType G.Quantitative+ , G.PAxis [ G.AxTickMinStep 1 ]+ ]+ . G.position G.Y [ G.PName "Time / ms", G.PmType G.Quantitative ]+ mkData xfs = G.dataFromColumns []+ . G.dataColumn "Complexity" (G.Numbers xs)+ . G.dataColumn "Time / ms" (G.Numbers fs)+ $ []+ where (xs, fs) = unzip xfs++ name = mName $ head measurements+ xys = map (\m -> (fromIntegral $ mValueComplexity m, 1000 * mTime m)) measurements++ values = G.asSpec+ [ mkData xys+ , G.mark G.Line []+ ]+ points = G.asSpec+ [ mkData xys+ , G.mark G.Circle []+ ]
+ benchmark/Main.hs view
@@ -0,0 +1,96 @@+{-|+Copyright : Predictable Network Solutions Ltd., 2003-2024+License : BSD-3-Clause+Description : Main benchmark of 'DQ'.+-}+module Main (main) where++import Benchmark.Plot+ ( Measurement (..)+ )+import Data.Traversable+ ( for+ )+import DeltaQ.Class+ ( DeltaQ (..)+ , Outcome (..)+ )+import DeltaQ.PiecewisePolynomial+ ( DQ+ , complexity+ )++import qualified Statistics.Types as Stat+import qualified Criterion as C+import qualified Criterion.Main as C+import qualified Criterion.Types as C+import qualified Options.Applicative as O++{-----------------------------------------------------------------------------+ Main+------------------------------------------------------------------------------}+-- | Command line arguments for the basic benchmark.+data BenchmarkArgs = BenchmarkArgs+ { resultFile :: FilePath+ }++benchmarkOptions :: O.Parser BenchmarkArgs+benchmarkOptions =+ BenchmarkArgs+ <$> O.strOption+ ( O.long "output"+ <> O.short 'o'+ <> O.metavar "FILENAME"+ <> O.help "File for benchmark results"+ )++commandLineOptions :: O.ParserInfo BenchmarkArgs+commandLineOptions =+ O.info (benchmarkOptions O.<**> O.helper)+ ( O.fullDesc+ <> O.progDesc "Run a benchmark of the `deltaq` package"+ <> O.header "basic - a benchmark for `deltaq`" )++main :: IO ()+main = do+ args <- O.execParser commandLineOptions+ measurements <- concat <$> sequence+ [ measureOp ".\\/." (.\/.) 20+ , measureOp "./\\." (./\.) 20+ , measureOp ".>>." (.>>.) 9+ ]+ writeFile (resultFile args) $ show measurements++{-----------------------------------------------------------------------------+ Benchmark+ Plumbing+------------------------------------------------------------------------------}+measureOp :: String -> (DQ -> DQ -> DQ) -> Int -> IO [Measurement]+measureOp name op mm = do+ for [0 .. mm] $ \m -> do+ let mkExpression = replicateOp op+ putStrLn $ "Measurement: " <> name <> ", m = " <> show m+ report <- C.benchmarkWith' config $ C.nf mkExpression m+ pure $ Measurement+ { mName = name+ , mTime = getTime report+ , mExpressionSize = m+ , mValueComplexity = complexity (mkExpression m)+ }+ where+ getTime = + Stat.estPoint . C.anMean . C.reportAnalysis + config = C.defaultConfig { C.timeLimit = 10 / fromIntegral mm }++{-----------------------------------------------------------------------------+ Benchmark+ Expressions+------------------------------------------------------------------------------}+-- | Construct an expression that applies a given binary operation+-- \( m \) times.+replicateOp :: (DQ -> DQ -> DQ) -> Int -> DQ+replicateOp _ 0 = uniform 0 1+replicateOp op m =+ uniform x 1 `op` replicateOp op (m-1)+ where+ x = 1 - 1 / fromIntegral m
+ deltaq.cabal view
@@ -0,0 +1,112 @@+cabal-version: 3.0+name: deltaq++-- Package Versioning Policy: https://pvp.haskell.org+-- PVP summary: +-+------- breaking API changes+-- | | +----- non-breaking API additions+-- | | | +--- code changes with no API change+version: 1.0.0.0+synopsis: Framework for ∆Q System Development+description:+ ∆Q System Development is a paradigm for developing distributed systems+ that meet performance requirements.++ In this paradigm,+ the system designer starts by defining high-level outcomes,+ explores different refinements into combinations of lower-level outcomes,+ and evaluates their performance characteristics.++ The `deltaq` package (pronounced "Delta Q") provides+ data types and functions for++ * outcomes and their combinations+ * evaluating the performance characteristics of outcomes,+ specifically the probability distribution of their completion times++category: DeltaQ, Distributed Systems, Probability+homepage: https://github.com/DeltaQ-SD/deltaq+license: BSD-3-Clause+license-file: LICENSE+copyright: Predictable Network Solutions Ltd., 2003-2024+author: Neil Davies, Heinrich Apfelmus+maintainer: neil.davies@pnsol.ccom++extra-doc-files:+ CHANGELOG.md+ README.md++tested-with:+ , GHC == 9.10.1++common warnings+ ghc-options: -Wall++source-repository head+ type: git+ location: git://github.com/DeltaQ-SD/deltaq.git+ subdir: lib/deltaq++library+ import: warnings+ hs-source-dirs: src+ default-language: Haskell2010+ build-depends:+ , base >= 4.14.3.0 && < 5+ , deepseq >= 1.4.4.0 && < 1.6+ , Chart >= 1.8 && < 2.0+ , lattices >= 2.2 && < 2.3+ , probability-polynomial >= 1.0 && < 1.1++ exposed-modules:+ DeltaQ+ DeltaQ.Class+ DeltaQ.Methods+ DeltaQ.PiecewisePolynomial+ DeltaQ.Plot++test-suite test+ import: warnings+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ default-language: Haskell2010++ build-tool-depends: hspec-discover:hspec-discover++ build-depends:+ , base+ , deltaq+ , probability-polynomial+ , hspec >= 2.11.0 && < 2.12+ , QuickCheck >= 2.14 && < 2.16++ main-is:+ Spec.hs++ other-modules:+ DeltaQ.ClassSpec+ DeltaQ.MethodsSpec+ DeltaQ.PiecewisePolynomialSpec++benchmark basic+ import: warnings+ type: exitcode-stdio-1.0+ hs-source-dirs: benchmark+ default-language: Haskell2010++ build-depends:+ , base+ , bytestring >= 0.11 && < 0.13+ , deltaq+ , cassava >= 0.5.3.2 && < 0.6+ , criterion >= 1.6 && < 1.7+ , deepseq+ , hvega >= 0.12 && < 0.13+ , optparse-applicative >= 0.18.1.0 && < 0.19+ , statistics >= 0.16 && < 0.17+ , vector >= 0.12 && < 0.14++ main-is:+ Main.hs++ other-modules:+ Benchmark.Plot
+ src/DeltaQ.hs view
@@ -0,0 +1,114 @@+{-|+Copyright : Predictable Network Solutions Ltd., 2003-2024+License : BSD-3-Clause++This module brings data types and functions+for ∆Q System Development into scope.++Specifically,++ * type classes in "DeltaQ.Class"++ * 'Outcome' for outcomes and their combinations+ * 'DeltaQ' for probability distribution of completion times++ * type class instance in "DeltaQ.PiecewisePolynomial"++ * @'DQ'@ for a probability distribution with numeric type @Rational@.+ This type represents a mixed discrete / continuous probability distribution+ where the continuous part is represented in terms of piecewise polynomials.++ * common methods for analysis and construction in "DeltaQ.Methods"++ * plotting utilities in "DeltaQ.Plot"++ * 'plotCDFWithQuantiles' for plotting an instance of 'DeltaQ'+ with quantiles highlighted.++-}+module DeltaQ+ ( -- * Example+ -- $example++ -- * Modules+ module DeltaQ.Class+ , module DeltaQ.Methods+ , module DeltaQ.Plot+ , module DeltaQ.PiecewisePolynomial+ ) where++import DeltaQ.Class+import DeltaQ.Methods+import DeltaQ.PiecewisePolynomial+import DeltaQ.Plot++{-$example++In order to demonstrate the use of this module,+we explore a __real-world example__+which occurred during the design of the Cardano blockchain.++Problem: We want to design a __computer network__+through which we can send a __message__+from any computer A to any other computer Z.++However, instead of connecting each pair of computers through a direct+TCP/IP link, we want to save on connection cables+and only connect each computer to a fixed number of other computers;+these computers are called /neighbors/ and+this number is called the /node degree/ @d@ of our network.+A message from computer A to computer Z will+first be sent to one of the @d@ neighbors of A,+then be __relayed__ to one of the neighbor's neighbors,+and so on until it reaches Z.+hrough the network.++How much __time__ does it take to send the message+from computer A to computer Z through the network?+How should we choose the parameter @d@ in order to improve this time?+How can we refine the network design in other ways?++This questions can be answered by using this module.++@+import DeltaQ+@++We start with an __estimate__ based on __measured__ transfer times.+Depending on geographic distance and location,+a __direct TCP/IP connection__ may delive a message within+different amounts of time.+We distinguish between `short`, `medium` and `long` distance.+For sending a block of 64k bytes of data,+representative times are (in seconds)++> short, medium, long :: DQ+> short = wait 0.024 -- seconds+> medium = wait 0.143 -- seconds+> long = wait 0.531 -- seconds++(These are delay times for the data to arrive,+not roundtrip times for the sending computer to receive+an acknowledgment.)++If we assume that a direct TCP/IP connection between computers has+an equal probability of being `short`, `medium`, or `long`,+the probability distribution of delay times for a __single hop__ is++> hop :: DQ+> hop = choices [(1/3, short), (1/3, medium), (1/3, long)]++The distribution of delay times for a __sequence of hops__ is++> hops :: Int -> DQ+> hops 1 = hop+> hops n = hop .>>. hops (n-1)++For example, the probability of five hops to succeed within 2 seconds+is++> > fromRational (successWithin (hops 5) 2) :: Double+> 0.9547325102880658+++-}
+ src/DeltaQ/Class.hs view
@@ -0,0 +1,352 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}++{-|+Copyright : Predictable Network Solutions Ltd., 2003-2024+License : BSD-3-Clause+Description : Type classes for outcomes and their completion times.++Type classes++* 'Outcome' — outcomes their combinations.+* 'DeltaQ' — probability distributions of completion times.++-}+module DeltaQ.Class+ ( -- * Type classes+ -- ** Outcome+ Outcome (..)++ -- ** DeltaQ+ , Eventually (..)+ , eventually+ , eventuallyFromMaybe+ , maybeFromEventually++ , DeltaQ (..)++ -- * Properties+ -- $properties++ -- ** Outcome+ -- $properties-outcome++ -- ** DeltaQ+ -- $properties-deltaq+ ) where++{-----------------------------------------------------------------------------+ Outcome+------------------------------------------------------------------------------}++infixl 1 .>>. -- less tight+infixr 2 .\/.+infixr 3 ./\. -- more tight++-- | An 'Outcome' is the result of an activity that takes time,+-- such as a distributed computation, communication, bus ride, … .+--+-- 'Outcome's can be composed in sequence or in parallel.+class (Ord (Duration o), Num (Duration o)) => Outcome o where+ -- | Numerical type representing times in \( [0,+∞) \).+ --+ -- For example 'Double' or 'Rational'.+ type Duration o++ -- | The outcome that never finishes.+ never :: o++ -- | The outcome that succeeds after waiting for a fixed amount of time.+ wait :: Duration o -> o++ -- | Sequential composition:+ --+ -- First run the outcome on the left,+ -- then run the outcome on the right.+ sequentially :: o -> o -> o++ -- | Infix operator synonym for 'sequentially'.+ (.>>.) :: o -> o -> o+ (.>>.) = sequentially++ -- | Parallel composition, first to finish:+ --+ -- Run two outcomes in parallel,+ -- finish as soon as any one of them finishes.+ firstToFinish :: o -> o -> o++ -- | Infix operator synonym for 'firstToFinish'.+ (.\/.) :: o -> o -> o+ (.\/.) = firstToFinish++ -- | Parallel composiiton, last to finish:+ --+ -- Run two outcomes in parallel,+ -- finish after all of them have finished.+ lastToFinish :: o -> o -> o++ -- | Infix operator synonym for 'lastToFinish'.+ (./\.) :: o -> o -> o+ (./\.) = lastToFinish++{-----------------------------------------------------------------------------+ Eventually+------------------------------------------------------------------------------}+-- | 'Eventually' represents a value that either eventually occurs+-- or is eventually abandoned.+--+-- Similar to the 'Maybe' type, but with a different 'Ord' instance:+-- @Occurs x < Abandoned@ for all @x@.+--+data Eventually a+ = Occurs a+ | Abandoned+ deriving (Eq, Show)++-- | For all @x@, we have @Occurs x < Abandoned@.+instance Ord a => Ord (Eventually a) where+ compare Abandoned Abandoned = EQ+ compare Abandoned (Occurs _) = GT+ compare (Occurs _) Abandoned = LT+ compare (Occurs x) (Occurs y) = compare x y++instance Functor Eventually where+ fmap _ Abandoned = Abandoned+ fmap f (Occurs x) = Occurs (f x)++-- |+-- > Abandoned <*> _ = Abandoned+-- > _ <*> Abandoned = Abandoned+instance Applicative Eventually where+ pure = Occurs++ Abandoned <*> Abandoned = Abandoned+ Abandoned <*> (Occurs _) = Abandoned+ (Occurs _) <*> Abandoned = Abandoned+ (Occurs f) <*> (Occurs y) = Occurs (f y)++-- | Helper function to eliminate 'Eventually'.+--+-- See also: 'maybe'.+eventually :: b -> (a -> b) -> Eventually a -> b+eventually b _ Abandoned = b+eventually _ f (Occurs x) = f x++-- | Helper function that converts 'Maybe' to 'Eventually'.+eventuallyFromMaybe :: Maybe a -> Eventually a+eventuallyFromMaybe Nothing = Abandoned+eventuallyFromMaybe (Just x) = Occurs x++-- | Helper function that converts 'Eventually' to 'Maybe'.+maybeFromEventually :: Eventually a -> Maybe a+maybeFromEventually Abandoned = Nothing+maybeFromEventually (Occurs x) = Just x++{-----------------------------------------------------------------------------+ DeltaQ+------------------------------------------------------------------------------}++-- | 'DeltaQ' — quality attenuation.+--+-- 'DeltaQ' is a probability distribution of time.+--+-- Specifically, 'DeltaQ' is the probability distribution+-- of finish times for an outcome.+class ( Ord (Probability o)+ , Enum (Probability o)+ , Num (Probability o)+ , Fractional (Probability o)+ , Outcome o+ )+ => DeltaQ o+ where+ -- | Numerical type representing probabilities in \( [0,1] \).+ --+ -- For example 'Double' or 'Rational'.+ type Probability o++ -- | Left-biased random choice.+ --+ -- @choice p@ chooses the left argument with probablity @p@+ -- and the right argument with probability @(1-p)@.+ choice :: Probability o -> o -> o -> o++ -- | Random choice between multiple alternatives+ --+ -- @choices [(w_1, o_1), (w_2, o_2), …]@ chooses randomly between multiple+ -- outcomes. The probability @p_i@ for choosing the outcome @o_i@ is+ -- determined by the weights as @p_i = w_i / (w_1 + w_2 + …)@.+ choices :: [(Probability o, o)] -> o+ choices [] = never+ choices wos =+ foldr (uncurry choice) never+ $ zipWith (\wtot (w, o) -> (w / wtot, o)) ws wos+ where+ ws = scanr1 (+) (map fst wos)++ -- | Uniform probability distribution on a time interval.+ uniform :: Duration o -> Duration o -> o++ -- | Probability of /not/ finishing.+ failure :: o -> Probability o++ -- | Probability of finishing within the given time @t@.+ --+ -- \"Within\" is inclusive,+ -- i.e. this returns the probability that the finishing time is @<= t@.+ successWithin :: o -> Duration o -> Probability o++ -- | Given a probability @p@, return the smallest time @t@+ -- such that the probability of completing within that time+ -- is at least @p@.+ --+ -- Return 'Abandoned' if the given probability+ -- exceeds the probability of finishing.+ quantile :: o -> Probability o -> Eventually (Duration o)++ -- | The earliest finish time with non-zero probability.+ --+ -- Return 'Abandoned' if the outcome is 'never'.+ earliest :: o -> Eventually (Duration o)++ -- | The last finish time which still has non-zero probability to occur.+ --+ -- Return 'Abandoned' if arbitrarily late times are possible.+ deadline :: o -> Eventually (Duration o)++{-----------------------------------------------------------------------------+ Properties+------------------------------------------------------------------------------}+{-$properties+All instances of the above type classes are expected to satisfy+the following properties.++For instances that use approximate arithmetic+such as floating point arithmetic or fixed precision arithmetic,+equality may be up to numerical accuracy.+-}++{-$properties-outcome++'never'++> never .>>. y = never+> never ./\. y = never+> never .\/. y = y+>+> x .>>. never = never+> x ./\. never = never+> x .\/. never = x++'wait'++> wait t .>>. wait s = wait (t+s)+> wait t ./\. wait s = wait (max t s)+> wait t .\/. wait s = wait (min t s)++'(.>>.)'++> (x .>>. y) .>>. z = x .>>. (y .>>. z)++'(./\.)'++> (x ./\. y) ./\. z = x ./\. (y ./\. z)+>+> x ./\. y = y ./\. x++'(.\/.)'++> (x .\/. y) .\/. z = x .\/. (y .\/. z)+>+> x .\/. y = y .\/. x++-}++{-$properties-deltaq++'choice'++> choice 1 x y = x+> choice 0 x y = y+>+> choice p x y .>>. z = choice p (x .>>. z) (y .>>. z)+> choice p x y ./\. z = choice p (x ./\. z) (y ./\. z)+> choice p x y .\/. z = choice p (x .\/. z) (y .\/. z)++'choices'++> choices [] = never+> choices ((w,o) : wos) = choice p o (choices wos)+> where p = w / (w + sum (map fst wos))++'uniform'++> wait t .>>. uniform r s = uniform (t+r) (t+s)+> uniform r s .>>. wait t = uniform (r+t) (s+t)++'failure'++> failure never = 1+> failure (wait t) = 0+> failure (x .>>. y) = 1 - (1 - failure x) * (1 - failure y)+> failure (x ./\. y) = 1 - (1 - failure x) * (1 - failure y)+> failure (x .\/. y) = failure x * failure y+>+> failure (choice p x y) = p * failure x + (1-p) * failure y+> failure (uniform r s) = 0++'successWithin'++> successWithin never t = 0+> successWithin (wait s) t = if t < s then 0 else 1+>+> successWithin (x ./\. y) t =+> successWithin t x * successWithin t y+> successWithin (x .\/. y) t =+> 1 - (1 - successWithin t x) * (1 - successWithin t y)+>+> successWithin (choice p x y) t =+> p * successWithin t x + (1-p) * successWithin t y+> successWithin (uniform r s) t+> | t < r = 0+> | r <= t && t < s = (t-r) / (s-r)+> | s <= t = 1++'quantile'++> p <= q implies quantile o p <= quantile o q+>+> quantile x 0 = Occurs 0+> quantile never p = Abandoned if p > 0+> quantile (wait t) p = Occurs t if p > 0+>+> quantile (uniform r s) p = r + p*(s-t) if p > 0, r <= s++'earliest'++> earliest never = Abandoned+> earliest (wait t) = Occurs t+> earliest (x .>>. y) = (+) <$> earliest x <*> earliest y+> earliest (x ./\. y) = max (earliest x) (earliest y)+> earliest (x .\/. y) = min (earliest x) (earliest y)+>+> earliest (choice p x y) = min (earliest x) (earliest y) if p ≠ 0, p ≠ 1+> earliest (uniform r s) = Occurs r if r <= s++'deadline'++> deadline never = Abandoned+> deadline (wait t) = Occurs t+> deadline (x .>>. y) = (+) <$> deadline x <*> deadline y+> deadline (x ./\. y) = max (deadline x) (deadline y)+>+> deadline (x .\/. y) = min (deadline x) (deadline y)+> if failure x = 0, failure y = 0+>+> deadline (choice p x y) = max (deadline x) (deadline y)+> if p ≠ 0, p ≠ 1, failure x = 0, failure y = 0+>+>+> deadline (uniform r s) = Occurs s if r <= s++-}
+ src/DeltaQ/Methods.hs view
@@ -0,0 +1,85 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++{-|+Copyright : Predictable Network Solutions Ltd., 2003-2024+License : BSD-3-Clause+Description : Methods for analysis and construction.++This module collects common methods+for constructing 'DeltaQ' and analyzing them.+-}+module DeltaQ.Methods+ ( -- * Slack / Hazard+ meetsRequirement+ , SlackOrHazard (..)+ , isSlack+ , isHazard+ ) where++import DeltaQ.Class+ ( DeltaQ (..)+ , Eventually (..)+ , Outcome (..)+ , eventually+ )++{-----------------------------------------------------------------------------+ Methods+ Slack / Hazard+------------------------------------------------------------------------------}+-- | The \"slack or hazard\" represents the distance between+-- a reference point in (time, probability) space+-- and a given 'DeltaQ'.+--+-- * 'Slack' represents the case where the 'DeltaQ' __meets__+-- the performance requirements set by the reference point.+-- * 'Hazard' represents the case where the 'DeltaQ' __fails__ to meet+-- the performance requirements set by the reference point.+--+-- Both cases include information of how far the reference point is+-- away.+data SlackOrHazard o+ = Slack (Duration o) (Probability o)+ -- ^ We have some slack.+ -- Specifically, we have 'Duration' at the same probability as the reference,+ -- and 'Probability' at the same duration as the reference.+ | Hazard (Eventually (Duration o)) (Probability o)+ -- ^ We fail to meet the reference point.+ -- Specifically,+ -- we overshoot by 'Duration' at the same probability as the reference,+ -- and by 'Probability' at the same duration as the reference.++deriving instance (Eq (Duration o), Eq (Probability o))+ => Eq (SlackOrHazard o)++deriving instance (Show (Duration o), Show (Probability o))+ => Show (SlackOrHazard o)++-- | Test whether the given 'SlackOrHazard' is 'Slack'.+isSlack :: SlackOrHazard o -> Bool+isSlack (Slack _ _) = True+isSlack _ = False++-- | Test whether the given 'SlackOrHazard' is 'Hazard'.+isHazard :: SlackOrHazard o -> Bool+isHazard (Hazard _ _) = True+isHazard _ = False++-- | Compute \"slack or hazard\" with respect to a given reference point.+meetsRequirement+ :: DeltaQ o => o -> (Duration o, Probability o) -> SlackOrHazard o+meetsRequirement o (t,p)+ | dp >= 0 = Slack dt dp+ | Abandoned <- t' = Hazard Abandoned (negate dp)+ | otherwise = Hazard (Occurs $ negate dt) (negate dp)+ where+ dp = p' - p+ dt = t - eventually err id t'++ t' = quantile o p+ p' = o `successWithin` t++ err = error "distanceToReference: inconsistency"
+ src/DeltaQ/PiecewisePolynomial.hs view
@@ -0,0 +1,268 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++{-|+Copyright : Predictable Network Solutions Ltd., 2020-2024+License : BSD-3-Clause+Description : Instances via piecewise polynomials.++@'DQ'@ is a probability distribution of completion time+using the numeric type @Rational@.+This type represents a mixed discrete / continuous probability distribution+where the continuous part is represented in terms of piecewise polynomials.+-}+module DeltaQ.PiecewisePolynomial+ ( -- * Type+ DQ+ , distribution+ , fromPositiveMeasure+ , unsafeFromPositiveMeasure++ -- * Operations+ , meetsQTA+ , Moments (..)+ , moments++ -- * Internal+ , complexity+ ) where++import Algebra.PartialOrd+ ( PartialOrd (..)+ )+import Data.Maybe+ ( fromMaybe+ )+import DeltaQ.Class+ ( DeltaQ (..)+ , Outcome (..)+ , eventuallyFromMaybe+ )+import Control.DeepSeq+ ( NFData+ )+import Numeric.Function.Piecewise+ ( Piecewise+ )+import Numeric.Measure.Finite.Mixed+ ( Measure+ )+import Numeric.Polynomial.Simple+ ( Poly+ )+import Numeric.Probability.Moments+ ( Moments (..)+ )++import qualified Data.Function.Class as Function+import qualified Numeric.Function.Piecewise as Piecewise+import qualified Numeric.Measure.Finite.Mixed as Measure+import qualified Numeric.Measure.Probability as Prob+import qualified Numeric.Polynomial.Simple as Poly++{-----------------------------------------------------------------------------+ Type+------------------------------------------------------------------------------}+-- | Probability distribution of durations.+newtype DQ = DQ (Measure Rational)+ deriving (Eq, Show, NFData)++-- | Get the distribution function as piecewise function of polynomials.+distribution :: DQ -> Piecewise (Poly Rational)+distribution (DQ m) = Measure.distribution m++-- | Interpret a finite, signed 'Measure' as a probability distribution.+--+-- In order to admit an interpretation as probability, the measure needs+-- to be positive.+-- This condition is checked, and if it does not hold,+-- the function returns 'Nothing'.+fromPositiveMeasure :: Measure Rational -> Maybe DQ+fromPositiveMeasure m+ | Measure.isPositive m = Just (unsafeFromPositiveMeasure m)+ | otherwise = Nothing++-- | Interpret a finite, positive 'Measure' as a probability distribution.+--+-- /The precondition that the measure is positive is not checked!/+unsafeFromPositiveMeasure :: Measure Rational -> DQ+unsafeFromPositiveMeasure = DQ++-- | Helper function for lifting a binary operation on distribution functions.+onDistribution2+ :: (a ~ Rational)+ => String+ -> (Piecewise (Poly a) -> Piecewise (Poly a) -> Piecewise (Poly a))+ -> DQ -> DQ -> DQ+onDistribution2 err f (DQ mx) (DQ my) =+ DQ+ $ fromMaybe impossible+ $ Measure.fromDistribution+ $ f (Measure.distribution mx) (Measure.distribution my)+ where+ impossible = error $ "impossible: not a finite measure in " <> err++-- | Size of the representation of a probability distribution,+-- i.e. number of pieces of the piecewise function and degrees+-- of the polynomials.+--+-- This quantity is relevant to stating and analyzing+-- the asymptotic time complexity of operations.+complexity :: DQ -> Int+complexity (DQ m) = sum (map complexityOfPiece pieces)+ where+ pieces = Piecewise.toAscPieces $ Measure.distribution m+ complexityOfPiece = (+1) . max 0 . Poly.degree . snd++{-----------------------------------------------------------------------------+ Operations+------------------------------------------------------------------------------}+instance Outcome DQ where+ type Duration DQ = Rational++ never = DQ Measure.zero++ wait t = DQ $ Measure.dirac t++ sequentially (DQ mx) (DQ my) = DQ (Measure.convolve mx my)++ firstToFinish = onDistribution2 "firstToFinish" $ \x y -> x + y - x * y++ lastToFinish = onDistribution2 "lastToFinish" (*)++instance DeltaQ DQ where+ type Probability DQ = Rational++ choice p = onDistribution2 "choice" $ \x y ->+ scale p x + scale (1 - p) y+ where+ scale = Piecewise.mapPieces . Poly.scale++ uniform a = DQ . Measure.uniform a++ successWithin (DQ m) = Function.eval (Measure.distribution m)++ failure (DQ m) = 1 - Measure.total m++ quantile (DQ m) p =+ eventuallyFromMaybe+ $ quantileFromMonotone (Measure.distribution m) p++ earliest (DQ m) = eventuallyFromMaybe $ fmap fst $ Measure.support m++ deadline (DQ m)= eventuallyFromMaybe $ fmap snd $ Measure.support m++-- | Partial order of cumulative distribution functions.+--+-- @'leq' x y@ holds if and only if for all completion times @t@,+-- the probability to succeed within the time @t@+-- is always larger (or equal) for @x@ compared to @y@.+-- In other words, @x@ has a higher probability of completing faster.+--+-- > x `leq` y <=> ∀ t. successWithin x t >= successWithin y t+instance PartialOrd DQ where+ m1 `leq` m2 =+ all isNonNegativeOnSegment+ $ toSegments+ $ distribution m1 - distribution m2++{-----------------------------------------------------------------------------+ Operations+ Helper functions+------------------------------------------------------------------------------}+-- | Helper type for segements of a piecewise functions.+data Segment a b+ = Jump a (b,b)+ | Polynomial (a,a) (b,b) (Poly a)+ | End a b+ deriving (Eq, Show)++-- | Helper function that elaborates a piecewise function+-- into a list of segments.+toSegments :: (a ~ Rational) => Piecewise (Poly a) -> [Segment a a]+toSegments = goJump 0 . Piecewise.toAscPieces+ where+ goJump _ [] = []+ goJump prev ((x1, o) : xos)+ | y1 - y0 > 0 = Jump x1 (y0, y1) : nexts+ | otherwise = nexts+ where+ y1 = Poly.eval o x1+ y0 = Poly.eval prev x1+ nexts = goPoly x1 y1 o xos++ goPoly x1 y1 o [] =+ End x1 y1 : goJump o []+ goPoly x1 y1 o xos@((x2, _) : _) =+ Polynomial (x1, x2) (y1, Poly.eval o x2) o : goJump o xos+ -- TODO: What about the case where y1 == y2, i.e. a constant Polynomial?++{-----------------------------------------------------------------------------+ Operations+ quantile+------------------------------------------------------------------------------}+-- | Compute a quantile from a monotonically increasing function.+quantileFromMonotone :: (a ~ Rational) => Piecewise (Poly a) -> a -> Maybe a+quantileFromMonotone pieces = findInSegments segments+ where+ segments = toSegments pieces++ findInSegments _ 0+ = Just 0+ findInSegments [] _+ = Nothing+ findInSegments (Jump x1 (y1, y2) : xys) y+ | y1 < y && y <= y2 = Just x1+ | otherwise = findInSegments xys y+ findInSegments (Polynomial (x1, x2) (y1, y2) o : xys) y+ | y1 < y && y <= y2 = Poly.root precision y (x1, x2) o+ | otherwise = findInSegments xys y+ findInSegments (End x1 y1 : _) y+ | y1 == y = Just x1+ | otherwise = Nothing++precision :: Rational+precision = 1 / 10^(10 :: Integer)++{-----------------------------------------------------------------------------+ Operations+ meetsQTA+------------------------------------------------------------------------------}+-- | Test whether the given probability distribution of completion times+-- is equal to or better than a given+-- __quantitative timeliness agreement__ (QTA).+--+-- Synonym for `leq` of the partial order,+--+-- > p `meetsQTA` qta = p `leq` qta+meetsQTA :: DQ -> DQ -> Bool+meetsQTA = leq++isNonNegativeOnSegment :: (a ~ Rational) => Segment a a -> Bool+isNonNegativeOnSegment (Jump _ (y1, y2)) =+ y1 >= 0 && y2 >= 0+isNonNegativeOnSegment (Polynomial (x1, x2) _ poly) =+ compareToZero == Just GT || compareToZero == Just EQ+ where+ compareToZero = Poly.compareToZero (x1, x2, poly)+isNonNegativeOnSegment (End _ y) =+ y >= 0++{-----------------------------------------------------------------------------+ Operations+ Moments+------------------------------------------------------------------------------}+-- | Compute the success probability of a 'DQ',+-- and the first commonly used 'Moments' of the+-- probability distribution conditioned on success.+moments :: DQ -> (Rational, Moments Rational)+moments (DQ m)+ | success == 0 =+ (0, Moments{mean = 0, variance = 0, skewness = 0, kurtosis = 1})+ | otherwise =+ (success, Prob.moments conditional)+ where+ success = Measure.total m+ conditional = Prob.unsafeFromMeasure $ Measure.scale (1/success) m
+ src/DeltaQ/Plot.hs view
@@ -0,0 +1,257 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}++{-|+Copyright : Predictable Network Solutions Ltd., 2003-2024+License : BSD-3-Clause+Description : Plot 'DeltaQ'.++Plot instances of 'DeltaQ' using "Graphics.Rendering.Chart".+-}+module DeltaQ.Plot+ ( plotCDF+ , plotCDFs+ , plotCDFWithQuantiles+ , plotInverseCDF+ , plotInverseCDFs+ , plotInverseCDFWithQuantiles+ ) where++import DeltaQ.Class+ ( Outcome (Duration)+ , DeltaQ (..)+ , Eventually (..)+ , eventually+ , maybeFromEventually+ )+import Graphics.Rendering.Chart.Easy+ ( (.=)+ )++import qualified Graphics.Rendering.Chart.Easy as G++{-----------------------------------------------------------------------------+ Plot+ CDF+------------------------------------------------------------------------------}+-- | Plot the cumulative distribution function (CDF) of a 'DeltaQ',+-- with title.+plotCDF+ :: ( DeltaQ o+ , Enum (Duration o)+ , Fractional (Duration o)+ , Real (Duration o)+ , Real (Probability o)+ )+ => String -- ^ Title+ -> o -- ^ Outcome to plot+ -> G.Layout Double Double+plotCDF title o =+ plotCDFs title [("", o)]++-- | Plot multiple CDFs in a single plot,+-- with title.+plotCDFs+ :: ( DeltaQ o+ , Enum (Duration o)+ , Fractional (Duration o)+ , Real (Duration o)+ , Real (Probability o)+ )+ => String -- ^ Title+ -> [(String, o)] -- ^ Outcomes with names+ -> G.Layout Double Double+plotCDFs title namedOutcomes = G.execEC $ do+ G.layout_title .= title+ add_x_axis (map snd namedOutcomes)+ G.layout_y_axis . G.laxis_title .= "Cumulative Probabilty"+ mapM_ plotOne namedOutcomes+ where+ cv1 = fromRational . toRational+ cv2 = fromRational . toRational+ plotOne (t, o) = G.plot $ G.line t [[(cv1 a, cv2 b) | (a, b) <- toXY o]]++-- | Plot the cumulative distribution function (CDF) of a 'DeltaQ',+-- with title, and annotated with quantiles.+plotCDFWithQuantiles+ :: ( DeltaQ o+ , Enum (Duration o)+ , Fractional (Duration o)+ , Real (Duration o)+ , Real (Probability o)+ )+ => String -- ^ Title+ -> [Probability o] -- ^ Quantiles to highlight+ -> o -- ^ Outcome to plot+ -> G.Layout Double Double+plotCDFWithQuantiles title quantiles o = G.execEC $ do+ G.layout_title .= title+ add_x_axis [o]+ G.layout_y_axis . G.laxis_title .= "Cumulative Probabilty"+ G.plot $ G.line "" [[(cv1 a, cv2 b) | (a, b) <- toXY o]]+ mapM_ plotQuantile quantiles+ where+ cv1 = fromRational . toRational+ cv2 = fromRational . toRational+ plotQuantile y = case quantile o y of+ Abandoned -> pure ()+ Occurs x -> G.plot $ pure $ focusOnPoint (cv1 x, cv2 y)++{-----------------------------------------------------------------------------+ Plot+ Inverse CDF+------------------------------------------------------------------------------}+-- | Plot the inverse cumulative distribution function (CDF) of a 'DeltaQ',+-- with title.+--+-- Visualizes the tail of the distribution better.+plotInverseCDF+ :: ( DeltaQ o+ , Enum (Duration o)+ , Fractional (Duration o)+ , Real (Duration o)+ , Real (Probability o)+ )+ => String -- ^ Title+ -> o -- ^ Outcome+ -> G.Layout Double G.LogValue+plotInverseCDF title o =+ plotInverseCDFs title [("", o)]++-- | Plot the mulltiple inverse CDFs of a 'DeltaQ',+-- with title.+--+-- Visualizes the tail of the distribution better.+plotInverseCDFs+ :: ( DeltaQ o+ , Enum (Duration o)+ , Fractional (Duration o)+ , Real (Duration o)+ , Real (Probability o)+ )+ => String -- ^ Title+ -> [(String, o)] -- Outcomes with names+ -> G.Layout Double G.LogValue+plotInverseCDFs title namedOutcomes = G.execEC $ do+ G.layout_title .= title+ add_x_axis (map snd namedOutcomes)+ G.layout_y_axis . G.laxis_title .= "Log Inverse Cumulative Probabilty"+ mapM_ plotOne namedOutcomes+ where+ cv1 = fromRational . toRational+ cv2 = fromRational . toRational+ plotOne (t, o) = G.plot $ G.line t [[(cv1 a, 1 - cv2 b) | (a, b) <- toXY o]]++-- | Plot the cumulative distribution function (CDF) of a 'DeltaQ',+-- with title, and annotated with quantiles.+--+-- Visualizes the tail of the distribution better.+plotInverseCDFWithQuantiles+ :: ( DeltaQ o+ , Enum (Duration o)+ , Fractional (Duration o)+ , Real (Duration o)+ , Real (Probability o)+ )+ => String -- ^ Title+ -> [Probability o] -- ^ Quantiles to highlight+ -> o -- ^ Outcome to plot+ -> G.Layout Double G.LogValue+plotInverseCDFWithQuantiles title quantiles o = G.execEC $ do+ G.layout_title .= title+ add_x_axis [o]+ G.layout_y_axis . G.laxis_title .= "Log Inverse Cumulative Probabilty"+ G.plot $ G.line "" [[(cv1 a, 1 - cv2 b) | (a, b) <- toXY o]]+ mapM_ plotQuantile quantiles+ where+ cv1 = fromRational . toRational+ cv2 = fromRational . toRational+ plotQuantile y = case quantile o y of+ Abandoned -> pure ()+ Occurs x -> G.plot $ pure $ focusOnPoint (cv1 x, cv2 (1 - y))++{-----------------------------------------------------------------------------+ Helper functions+ Plot+------------------------------------------------------------------------------}+-- | Add a common @x@-axis to the plot.+add_x_axis + :: (DeltaQ o, Real (Duration o), Fractional (Duration o), G.PlotValue y)+ => [o]+ -> G.EC (G.Layout Double y) ()+add_x_axis outcomes = do+ G.layout_x_axis . G.laxis_title .= "Time (s)"+ G.layout_x_axis+ . G.laxis_generate+ .= maybe G.autoAxis (\u' -> G.scaledAxis G.def (0, 1.05 * u')) maxX+ where+ fromDuration = fromRational . toRational+ maxX = case outcomes of+ [] -> Nothing+ _ -> + fmap fromDuration+ $ maximum+ $ map (maybeFromEventually . deadline) outcomes++-- | Focus on a point by plotting dashed lines that connect it to the axes.+focusOnPoint+ :: (G.PlotValue x, G.PlotValue y)+ => (x,y) -> G.PlotLines x y+focusOnPoint (x,y) = G.execEC $ do+ G.plot_lines_style . G.line_color .= G.opaque G.black+ G.plot_lines_style . G.line_dashes .= [5, 5]+ G.plot_lines_limit_values .=+ [ [(G.LMin, G.LValue y), (G.LValue x, G.LValue y)]+ , [(G.LValue x, G.LValue y), (G.LValue x, G.LMin)]+ ]++{-----------------------------------------------------------------------------+ Helper functions+ Calculations+------------------------------------------------------------------------------}+-- | Create a graph for an 'Outcome', with sensible defaults for plotting.+toXY+ :: (DeltaQ o, Enum (Duration o), Fractional (Duration o))+ => o+ -> [(Duration o, Probability o)]+toXY = toXY' 2048 0.05++-- | Create a graph for an 'Outcome', given some parameters.+toXY'+ :: (DeltaQ o, Enum (Duration o), Fractional (Duration o))+ => Int -- ^ Number of points to plot.+ -> Double -- ^ \"Overshoot\" (as a fraction of the range)+ -> o -- ^ Outcome to convert+ -> [(Duration o, Probability o)]+toXY' numPoints overshoot o =+ deduplicate $ leftEdge <> middle <> rightEdge+ where+ range = upperX - lowerX+ eps = range / fromIntegral numPoints+ lowerX = eventually 0 id $ earliest o+ upperX = eventually halfLifeCarbon14 id $ deadline o+ halfLifeCarbon14 = 5730 * 365 * 24 * 60 * 60+ success = 1 - failure o+ sw = successWithin o+ leftEdge =+ [(0, 0), (lowerX - eps, 0), (lowerX, sw lowerX)]+ rightEdge =+ [ (upperX, success)+ , (upperX + (fromRational . toRational $ overshoot) * range, success)+ ]+ middle+ | eps <= 0 = []+ | otherwise =+ [ (x, sw x)+ | x <- [lowerX + eps, lowerX + 2*eps .. upperX - eps]+ ]++-- | Remove neighboring occurrences of the same element from the list.+deduplicate :: Eq a => [a] -> [a]+deduplicate [] = []+deduplicate (x : xs) = x : dedup' x xs+ where+ dedup' _ [] = []+ dedup' y (y' : ys)+ | y == y' = dedup' y ys+ | otherwise = y' : dedup' y' ys
+ test/DeltaQ/ClassSpec.hs view
@@ -0,0 +1,76 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -Wno-orphans #-}++{-|+Copyright : Predictable Network Solutions Ltd., 2003-2024+License : BSD-3-Clause+-}+module DeltaQ.ClassSpec+ ( spec+ ) where++import Prelude++import DeltaQ.Class+ ( Eventually (..)+ , eventually+ , eventuallyFromMaybe+ , maybeFromEventually+ )+import Test.Hspec+ ( Spec+ , describe+ , it+ )+import Test.QuickCheck+ ( Arbitrary (..)+ , (===)+ , property+ )++{-----------------------------------------------------------------------------+ Tests+------------------------------------------------------------------------------}+spec :: Spec+spec = do+ describe "Eventually" $ do+ describe "eventuallyFromMaybe" $ do+ let morphism = eventuallyFromMaybe++ it "Eq" $ property $+ \(mx :: Maybe Integer) my ->+ (morphism mx == morphism my)+ === (mx == my)++ it "Functor" $ property $+ \(mx :: Maybe Integer) ->+ let f = (2*)+ in fmap f (morphism mx)+ === morphism (fmap f mx)++ it "Applicative, pure" $ property $+ \(x :: Integer) ->+ pure x+ === morphism (pure x)++ it "Applicative, (<*>)" $ property $+ \(mx :: Maybe Integer) my ->+ let f = (+)+ in (f <$> morphism mx <*> morphism my)+ === morphism (f <$> mx <*> my)++ it "maybeFromEventually . eventuallyFromMaybe" $ property $+ \(mx :: Maybe Bool) ->+ maybeFromEventually (eventuallyFromMaybe mx)+ === mx++ it "eventually Abandoned Occurs = id" $ property $+ \(ex :: Eventually Bool) ->+ eventually Abandoned Occurs ex + === ex++{-----------------------------------------------------------------------------+ Tests+------------------------------------------------------------------------------}+instance Arbitrary a => Arbitrary (Eventually a) where+ arbitrary = eventuallyFromMaybe <$> arbitrary
+ test/DeltaQ/MethodsSpec.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -Wno-orphans #-}++{-|+Copyright : Predictable Network Solutions Ltd., 2003-2024+License : BSD-3-Clause+-}+module DeltaQ.MethodsSpec+ ( spec+ ) where++import Prelude++import DeltaQ.Class+ ( Eventually (..)+ , DeltaQ (..)+ , Outcome (..)+ )+import DeltaQ.PiecewisePolynomial+ ( DQ+ )+import DeltaQ.Methods+ ( SlackOrHazard (..)+ , meetsRequirement+ )+import Test.Hspec+ ( Spec+ , describe+ , it+ )+import Test.QuickCheck+ ( NonNegative (..)+ , Positive (..)+ , property+ , withMaxSuccess+ )++{-----------------------------------------------------------------------------+ Tests+------------------------------------------------------------------------------}+spec :: Spec+spec = do+ describe "SlackOrHazard" $ do+ it "never, hazard" $ withMaxSuccess 1 $ property $+ let deltaq = never :: DQ+ in case deltaq `meetsRequirement` (1, 0.9) of+ Hazard Abandoned dp -> dp >= 0+ _ -> False++ it "uniform, slack" $ property $+ \(NonNegative r) (Positive d) ->+ let s = r + d+ deltaq = uniform r s :: DQ+ in case deltaq `meetsRequirement` (s + d, 0.9) of+ Slack dt dp -> dp >= 0 && dt >= 0+ _ -> False++ it "uniform, hazard" $ property $+ \(NonNegative r) (Positive d) ->+ let s = r + d+ deltaq = uniform r s :: DQ+ in case deltaq `meetsRequirement` (0, 0.9) of+ Hazard (Occurs dt) dp -> dt >= 0 && dp >= 0+ _ -> False
+ test/DeltaQ/PiecewisePolynomialSpec.hs view
@@ -0,0 +1,509 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# OPTIONS_GHC -Wno-orphans #-}++{-|+Copyright : Predictable Network Solutions Ltd., 2020-2024+License : BSD-3-Clause+-}+module DeltaQ.PiecewisePolynomialSpec+ ( spec+ ) where++import Prelude++import Data.Maybe+ ( fromJust+ )+import Data.Ratio+ ( (%)+ )+import DeltaQ.Class+ ( DeltaQ (..)+ , Eventually (..)+ , Outcome (..)+ )+import DeltaQ.PiecewisePolynomial+ ( DQ+ , complexity+ , distribution+ , fromPositiveMeasure+ , meetsQTA+ , moments+ )+import Numeric.Probability.Moments+ ( Moments (..)+ )+import Test.Hspec+ ( Spec+ , describe+ , it+ )+import Test.QuickCheck+ ( Arbitrary+ , Gen+ , NonNegative (..)+ , Positive (..)+ , Property+ , (===)+ , (==>)+ , (.&&.)+ , arbitrary+ , choose+ , chooseInteger+ , frequency+ , getSize+ , mapSize+ , oneof+ , property+ , scale+ , vectorOf+ , withMaxSuccess+ )++import qualified Numeric.Measure.Finite.Mixed as Measure++{-----------------------------------------------------------------------------+ Tests+------------------------------------------------------------------------------}+infix 0 .===++-- | '(===)' with constrained types.+(.===) :: DQ -> DQ -> Property+(.===) = (===)++spec :: Spec+spec = do+ describe "general DeltaQ properties" specProperties+ describe "DQ specifics" specImplementation++specProperties :: Spec+specProperties = do+ describe "never" $ do+ it "x .>>. never" $ property $+ \x ->+ (x .>>. never) .=== never++ it "x ./\\. never" $ property $+ \x ->+ (x ./\. never) .=== never++ it "x .\\/. never" $ property $+ \x ->+ (x .\/. never) .=== x++ it "never .>>. x" $ property $+ \x ->+ (never .>>. x) .=== never++ it "never ./\\. x" $ property $+ \x ->+ (never ./\. x) .=== never++ it "never .\\/. x" $ property $+ \x ->+ (never .\/. x) .=== x++ describe "wait" $ do+ it ".>>." $ property $+ \(NonNegative t) (NonNegative s) ->+ (wait t .>>. wait s) .=== wait (t+s)++ it "./\\." $ property $+ \(NonNegative t) (NonNegative s) ->+ (wait t ./\. wait s) .=== wait (max t s)++ it ".\\/." $ property $+ \(NonNegative t) (NonNegative s) ->+ (wait t .\/. wait s) .=== wait (min t s)++ describe ".>>." $ do+ it "associativity" $ property $ mapSize (`div` 3) $+ \x y z ->+ (x .>>. y) .>>. z .=== x .>>. (y .>>. z)++ describe "./\\." $ do+ it "associativity" $ property $+ \x y z ->+ (x ./\. y) ./\. z .=== x ./\. (y ./\. z)++ it "commutativity" $ property $+ \x y ->+ x ./\. y .=== y ./\. x++ describe ".\\/." $ do+ it "associativity" $ property $+ \x y z ->+ (x .\/. y) .\/. z .=== x .\/. (y .\/. z)++ it "commutativity" $ property $+ \x y ->+ x .\/. y .=== y .\/. x++ describe "choice" $ do+ it "choice 1" $ property $+ \x y ->+ choice 1 x y .=== x++ it "choice 0" $ property $+ \x y ->+ choice 0 x y .=== y++ it ".>>." $ property $ mapSize (`div` 3) $+ \(Probability p) x y z ->+ choice p x y .>>. z .=== choice p (x .>>. z) (y .>>. z)++ it "./\\." $ property $+ \(Probability p) x y z ->+ choice p x y ./\. z .=== choice p (x ./\. z) (y ./\. z)++ it ".\\/." $ property $+ \(Probability p) x y z ->+ choice p x y .\/. z .=== choice p (x .\/. z) (y .\/. z)++ describe "choices" $ do+ it "choices []" $ property $+ (choices [] .=== never)++ it "choices ((w,o):wos)" $ property $ mapSize (`div` 2) $+ \ (Positive (w :: Rational))+ (o :: DQ)+ (wos' :: [(Positive Rational, DQ)]) ->+ let wos = map (\(Positive w', o') -> (w',o')) wos'+ ws = map fst wos+ p = w / (w + sum ws)+ in+ choices ((w,o):wos)+ .=== choice p o (choices wos)++ describe "uniform" $ do+ it "wait .>>. uniform" $ property $+ \(NonNegative r) (Positive d) (NonNegative t) ->+ let s = r + d in+ (wait t .>>. uniform r s) .=== uniform (t+r) (t+s)++ it "uniform .>>. wait" $ property $+ \(NonNegative r) (Positive d) (NonNegative t) ->+ let s = r + d in+ (uniform r s .>>. wait t) .=== uniform (r+t) (s+t)++ describe "failure" $ do+ let failure' :: DQ -> Rational+ failure' = failure++ it "never" $ property $+ failure' never === 1++ it "wait" $ property $+ \(NonNegative t) ->+ failure' (wait t) === 0++ it ".>>." $ property $+ \x y ->+ failure' (x .>>. y)+ === 1 - (1 - failure' x) * (1 - failure' y)++ it "./\\." $ property $+ \x y ->+ failure' (x ./\. y)+ === 1 - (1 - failure' x) * (1 - failure' y)++ it ".\\/." $ property $+ \x y ->+ failure' (x .\/. y)+ === failure' x * failure' y++ it "choice" $ property $+ \(Probability p) x y ->+ failure' (choice p x y)+ === p * failure' x + (1-p) * failure' y++ it "uniform" $ property $+ \(NonNegative r) (Positive d) ->+ let s = r + d in+ failure' (uniform r s) === 0++ describe "successWithin" $ do+ let successWithin' :: DQ -> Rational -> Rational+ successWithin' = successWithin++ it "never" $ property $+ \(NonNegative t) ->+ successWithin' never t === 0++ it "wait" $ property $+ \(NonNegative t) (NonNegative s) ->+ successWithin' (wait s) t === if t < s then 0 else 1++ it "./\\." $ property $+ \(NonNegative t) x y ->+ successWithin' (x ./\. y) t+ === successWithin' x t * successWithin' y t++ it ".\\/." $ property $+ \(NonNegative t) x y ->+ successWithin' (x .\/. y) t+ === 1 - (1 - successWithin' x t) * (1 - successWithin' y t)++ it "choice" $ property $+ \(NonNegative t) (Probability p) x y ->+ successWithin' (choice p x y) t+ === p * successWithin' x t + (1-p) * successWithin' y t++ it "uniform" $ property $ + let successWithin2 r s t+ | t < r = 0+ | r <= t && t < s = (t-r) / (s-r)+ | s <= t = 1+ | otherwise = error "impossible"+ in \(NonNegative t) (NonNegative r) (Positive d) ->+ let s = r + d+ in successWithin' (uniform r s) t+ === successWithin2 r s t++ describe "quantile" $ do+ let quantile' :: DQ -> Rational -> Eventually Rational+ quantile' = quantile++ it "0" $ property $+ \o ->+ quantile' o 0 === Occurs 0++ it "monotonic" $ property $+ \o (Probability p) (Probability q) ->+ let p' = min p q+ q' = max p q+ in+ p' <= q' ==> quantile' o p' <= quantile' o q'++ it "never" $ property $+ \(Probability p) ->+ p > 0 ==>+ quantile' never p === Abandoned++ it "wait" $ property $+ \(Probability p) (NonNegative t) ->+ p > 0 ==>+ quantile' (wait t) p === Occurs t++ it "uniform" $ property $+ \(Probability p) (NonNegative r) (Positive d) ->+ let s = r + d in + p > 0 ==>+ quantile' (uniform r s) p+ === Occurs (r + p*(s-r))++ describe "earliest" $ do+ let earliest' :: DQ -> Eventually Rational+ earliest' = earliest++ it "never" $ property $+ earliest' never === Abandoned++ it "wait" $ property $+ \(NonNegative t) ->+ earliest' (wait t) === Occurs t++ it ".>>." $ property $+ \x y ->+ earliest' (x .>>. y)+ === ((+) <$> earliest' x <*> earliest' y)++ it "./\\." $ property $+ \x y ->+ earliest' (x ./\. y)+ === max (earliest' x) (earliest' y)++ it ".\\/." $ property $+ \x y ->+ earliest' (x .\/. y)+ === min (earliest' x) (earliest' y)++ it "choice" $ property $+ \(Probability p) x y ->+ (0 < p && p < 1) ==>+ (earliest' (choice p x y)+ === min (earliest' x) (earliest' y))++ it "uniform" $ property $+ \(NonNegative r) (NonNegative s) ->+ earliest' (uniform r s) === Occurs (min r s)++ describe "deadline" $ do+ let deadline' :: DQ -> Eventually Rational+ deadline' = deadline++ it "never" $ property $+ deadline' never === Abandoned++ it "wait" $ property $+ \(NonNegative t) ->+ deadline' (wait t) === Occurs t++ it ".>>." $ property $+ \x y ->+ deadline' (x .>>. y)+ === ((+) <$> deadline' x <*> deadline' y)++ it "./\\." $ property $+ \x y ->+ deadline' (x ./\. y)+ === max (deadline' x) (deadline' y)++ it ".\\/." $ property $+ \x y ->+ (failure x == 0 && failure y == 0) ==>+ deadline' (x .\/. y)+ === min (deadline' x) (deadline' y)++ it "choice" $ property $+ \(Probability p) x y ->+ (0 < p && p < 1 && failure x == 0 && failure y == 0) ==>+ deadline' (choice p x y)+ === max (deadline' x) (deadline' y)++ it "uniform" $ property $+ \(NonNegative r) (NonNegative s) ->+ deadline' (uniform r s) === Occurs (max r s)++ describe "stress tests" $ do+ it "orders of magnitude" $ withMaxSuccess 1 $ property $+ let waitPower2 :: Int -> (Rational, DQ)+ waitPower2 k = ((1/2)^k, wait (2^k))++ n = 20+ o = choices $ map waitPower2 [1..n]+ in+ deadline o === Occurs (2^n)+ .&&. failure o === 0+ .&&. quantile o (1 - 1/4) === Occurs 4++specImplementation :: Spec+specImplementation = do+ describe "fromPositiveMeasure" $ do+ it "fails on negative measure" $ property $+ \(NonNegative r) (Positive d) ->+ let s = r + d in+ fromPositiveMeasure+ (Measure.scale (-1) (Measure.uniform r s))+ === Nothing++ describe "fromPositiveMeasure . distribution" $ do+ it "uniform" $ property $+ \(NonNegative r) (Positive d) ->+ let s = r + d+ id' =+ fromPositiveMeasure+ . fromJust+ . Measure.fromDistribution+ . distribution+ in+ id' (uniform r s) === Just (uniform r s)++ describe "meetsQTA" $ do+ it "never" $ property $+ \x ->+ x `meetsQTA` never === True++ it "uniform" $ property $+ \(NonNegative r) (Positive d) (Positive d2) ->+ let s = r + d+ s2 = s + d2+ in+ uniform s r `meetsQTA` uniform r s2 === True++ it "wait .>>." $ property $+ \x (NonNegative t) ->+ x `meetsQTA` (wait t .>>. x) === True++ it "choice never" $ property $+ \x (Probability p) ->+ x `meetsQTA` choice p never x === True++ it "./\\." $ property $+ \x y ->+ x `meetsQTA` (x ./\. y)++ it ".\\/." $ property $+ \x y ->+ (x .\/. y) `meetsQTA` x++ describe "moments" $ do+ it "never" $ withMaxSuccess 1 $ property $+ fst (moments never) === 0++ it "wait" $ property $+ \(NonNegative t) ->+ let ms = Moments{mean = t, variance = 0, skewness = 0, kurtosis = 1}+ in moments (wait t) === (1, ms)++ describe "complexity" $ do+ it "grows exponentially with .>>." $ withMaxSuccess 1 $ property $+ let power2 (n :: Int) = choice (1/2) (wait 0) (wait (2^n))+ convolved (m :: Int) = foldr1 (.>>.) $ map power2 [1..m]+ in+ complexity (power2 1) <= 4+ .&&. complexity (convolved 10) >= 2^(10 :: Int)++{-----------------------------------------------------------------------------+ Random generators+------------------------------------------------------------------------------}+data Prob = Probability Rational+ deriving (Eq, Show)++instance Arbitrary Prob where+ arbitrary = Probability <$> genProbability++instance Arbitrary DQ where+ arbitrary = scale (`div` 11) genDeltaQ++-- | Generate a random 'DeltaQ' by generating a random expression.+genDeltaQ+ :: (DeltaQ o, Arbitrary (Duration o), Probability o ~ Rational)+ => Gen o+genDeltaQ = do+ size <- getSize+ genDeltaQFromList =<< vectorOf size genSimpleOutcome++-- | Generate a simple probability distribution using 'uniform'.+genUniform :: (DeltaQ o, Arbitrary (Duration o)) => Gen o+genUniform = do+ NonNegative a <- arbitrary+ Positive d <- arbitrary+ pure $ uniform a (a + d)++-- | Generate a deterministic outcome 'wait'.+genWait :: (Outcome o, Arbitrary (Duration o)) => Gen o+genWait = do+ NonNegative a <- arbitrary+ pure $ wait a++-- | Generate a simple outcome — one of 'uniform', 'wait', or 'never'.+genSimpleOutcome :: (DeltaQ o, Arbitrary (Duration o)) => Gen o+genSimpleOutcome =+ frequency [(20, genUniform), (4, genWait), (1, pure never)]++-- | Generate a random probability between (0,1) an+genProbability :: Gen Rational+genProbability = do+ denominator <- chooseInteger (1,2^(20 :: Int))+ numerator <- chooseInteger (0, denominator)+ pure (numerator % denominator)++-- | Generate a random 'DeltaQ' by combining a given list+-- of outcomes with random operations.+genDeltaQFromList :: (DeltaQ o, Probability o ~ Rational) => [o] -> Gen o+genDeltaQFromList [] = pure never+genDeltaQFromList [x] = pure x+genDeltaQFromList xs = do+ n <- choose (1, length xs - 1)+ let (ys, zs) = splitAt n xs+ genOp <*> genDeltaQFromList ys <*> genDeltaQFromList zs+ where+ genChoice = do+ p <- genProbability+ pure $ choice p + genOp = oneof [pure (.>>.), pure (./\.), pure (.\/.), genChoice]
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}