diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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`. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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. diff --git a/benchmark/Benchmark/Plot.hs b/benchmark/Benchmark/Plot.hs new file mode 100644 --- /dev/null +++ b/benchmark/Benchmark/Plot.hs @@ -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 [] + ] diff --git a/benchmark/Main.hs b/benchmark/Main.hs new file mode 100644 --- /dev/null +++ b/benchmark/Main.hs @@ -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 diff --git a/deltaq.cabal b/deltaq.cabal new file mode 100644 --- /dev/null +++ b/deltaq.cabal @@ -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 diff --git a/src/DeltaQ.hs b/src/DeltaQ.hs new file mode 100644 --- /dev/null +++ b/src/DeltaQ.hs @@ -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 + + +-} diff --git a/src/DeltaQ/Class.hs b/src/DeltaQ/Class.hs new file mode 100644 --- /dev/null +++ b/src/DeltaQ/Class.hs @@ -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 + +-} diff --git a/src/DeltaQ/Methods.hs b/src/DeltaQ/Methods.hs new file mode 100644 --- /dev/null +++ b/src/DeltaQ/Methods.hs @@ -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" diff --git a/src/DeltaQ/PiecewisePolynomial.hs b/src/DeltaQ/PiecewisePolynomial.hs new file mode 100644 --- /dev/null +++ b/src/DeltaQ/PiecewisePolynomial.hs @@ -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 diff --git a/src/DeltaQ/Plot.hs b/src/DeltaQ/Plot.hs new file mode 100644 --- /dev/null +++ b/src/DeltaQ/Plot.hs @@ -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 diff --git a/test/DeltaQ/ClassSpec.hs b/test/DeltaQ/ClassSpec.hs new file mode 100644 --- /dev/null +++ b/test/DeltaQ/ClassSpec.hs @@ -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 diff --git a/test/DeltaQ/MethodsSpec.hs b/test/DeltaQ/MethodsSpec.hs new file mode 100644 --- /dev/null +++ b/test/DeltaQ/MethodsSpec.hs @@ -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 diff --git a/test/DeltaQ/PiecewisePolynomialSpec.hs b/test/DeltaQ/PiecewisePolynomialSpec.hs new file mode 100644 --- /dev/null +++ b/test/DeltaQ/PiecewisePolynomialSpec.hs @@ -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] 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 #-}