{-# 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
    (.>>.) = o -> o -> o
forall o. Outcome o => 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
    (.\/.) = o -> o -> o
forall o. Outcome o => 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
    (./\.) = o -> o -> o
forall o. Outcome o => 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 (Eventually a -> Eventually a -> Bool
(Eventually a -> Eventually a -> Bool)
-> (Eventually a -> Eventually a -> Bool) -> Eq (Eventually a)
forall a. Eq a => Eventually a -> Eventually a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => Eventually a -> Eventually a -> Bool
== :: Eventually a -> Eventually a -> Bool
$c/= :: forall a. Eq a => Eventually a -> Eventually a -> Bool
/= :: Eventually a -> Eventually a -> Bool
Eq, Int -> Eventually a -> ShowS
[Eventually a] -> ShowS
Eventually a -> String
(Int -> Eventually a -> ShowS)
-> (Eventually a -> String)
-> ([Eventually a] -> ShowS)
-> Show (Eventually a)
forall a. Show a => Int -> Eventually a -> ShowS
forall a. Show a => [Eventually a] -> ShowS
forall a. Show a => Eventually a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> Eventually a -> ShowS
showsPrec :: Int -> Eventually a -> ShowS
$cshow :: forall a. Show a => Eventually a -> String
show :: Eventually a -> String
$cshowList :: forall a. Show a => [Eventually a] -> ShowS
showList :: [Eventually a] -> ShowS
Show)

-- | For all @x@, we have @Occurs x < Abandoned@.
instance Ord a => Ord (Eventually a) where
    compare :: Eventually a -> Eventually a -> Ordering
compare Eventually a
Abandoned Eventually a
Abandoned = Ordering
EQ
    compare Eventually a
Abandoned (Occurs a
_) = Ordering
GT
    compare (Occurs a
_) Eventually a
Abandoned = Ordering
LT
    compare (Occurs a
x) (Occurs a
y) = a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
compare a
x a
y

instance Functor Eventually where
    fmap :: forall a b. (a -> b) -> Eventually a -> Eventually b
fmap a -> b
_ Eventually a
Abandoned = Eventually b
forall a. Eventually a
Abandoned
    fmap a -> b
f (Occurs a
x) = b -> Eventually b
forall a. a -> Eventually a
Occurs (a -> b
f a
x)

-- |
-- > Abandoned <*> _ = Abandoned
-- > _ <*> Abandoned = Abandoned
instance Applicative Eventually where
    pure :: forall a. a -> Eventually a
pure = a -> Eventually a
forall a. a -> Eventually a
Occurs

    Eventually (a -> b)
Abandoned <*> :: forall a b. Eventually (a -> b) -> Eventually a -> Eventually b
<*> Eventually a
Abandoned = Eventually b
forall a. Eventually a
Abandoned
    Eventually (a -> b)
Abandoned <*> (Occurs a
_) = Eventually b
forall a. Eventually a
Abandoned
    (Occurs a -> b
_) <*> Eventually a
Abandoned = Eventually b
forall a. Eventually a
Abandoned
    (Occurs a -> b
f) <*> (Occurs a
y) = b -> Eventually b
forall a. a -> Eventually a
Occurs (a -> b
f a
y)

-- | Helper function to eliminate 'Eventually'.
--
-- See also: 'maybe'.
eventually :: b -> (a -> b) -> Eventually a -> b
eventually :: forall b a. b -> (a -> b) -> Eventually a -> b
eventually b
b a -> b
_ Eventually a
Abandoned = b
b
eventually b
_ a -> b
f (Occurs a
x) = a -> b
f a
x

-- | Helper function that converts 'Maybe' to 'Eventually'.
eventuallyFromMaybe :: Maybe a -> Eventually a
eventuallyFromMaybe :: forall a. Maybe a -> Eventually a
eventuallyFromMaybe Maybe a
Nothing = Eventually a
forall a. Eventually a
Abandoned
eventuallyFromMaybe (Just a
x) = a -> Eventually a
forall a. a -> Eventually a
Occurs a
x

-- | Helper function that converts 'Eventually' to 'Maybe'.
maybeFromEventually :: Eventually a -> Maybe a
maybeFromEventually :: forall a. Eventually a -> Maybe a
maybeFromEventually Eventually a
Abandoned = Maybe a
forall a. Maybe a
Nothing
maybeFromEventually (Occurs a
x) = a -> Maybe a
forall a. a -> Maybe a
Just a
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 [] = o
forall o. Outcome o => o
never
    choices [(Probability o, o)]
wos =
        ((Probability o, o) -> o -> o) -> o -> [(Probability o, o)] -> o
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((Probability o -> o -> o -> o) -> (Probability o, o) -> o -> o
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Probability o -> o -> o -> o
forall o. DeltaQ o => Probability o -> o -> o -> o
choice) o
forall o. Outcome o => o
never
        ([(Probability o, o)] -> o) -> [(Probability o, o)] -> o
forall a b. (a -> b) -> a -> b
$ (Probability o -> (Probability o, o) -> (Probability o, o))
-> [Probability o] -> [(Probability o, o)] -> [(Probability o, o)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Probability o
wtot (Probability o
w, o
o) -> (Probability o
w Probability o -> Probability o -> Probability o
forall a. Fractional a => a -> a -> a
/ Probability o
wtot, o
o)) [Probability o]
ws [(Probability o, o)]
wos
      where
        ws :: [Probability o]
ws = (Probability o -> Probability o -> Probability o)
-> [Probability o] -> [Probability o]
forall a. (a -> a -> a) -> [a] -> [a]
scanr1 Probability o -> Probability o -> Probability o
forall a. Num a => a -> a -> a
(+) (((Probability o, o) -> Probability o)
-> [(Probability o, o)] -> [Probability o]
forall a b. (a -> b) -> [a] -> [b]
map (Probability o, o) -> Probability o
forall a b. (a, b) -> a
fst [(Probability o, o)]
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

-}