{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-- |
-- Copyright: © 2022 IOHK
-- License: Apache-2.0
--
-- This module provides a maximum likelhood estimator for pool performance.
--
-- Copy & paste of the original implementation in
--
-- @cardano-ledger/eras/shelley/impl/src/Cardano/Ledger/Shelley/PoolRank.hs@
--
-- The copy was made in order to reduce (transitive) dependencies.
module Cardano.Pool.Rank.Likelihood
    ( -- * Pool performance estimate from historical block production
      BlockProduction (..)
    , PerformanceEstimate (..)
    , estimatePoolPerformance

    -- * Likelihood computations
    , LogWeight (..)
    , Likelihood (..)
    , likelihood
    , applyDecay
    , Histogram (..)
    , percentile'
    )
    where

import Prelude

import Cardano.Wallet.Primitive.Types
    ( ActiveSlotCoefficient (..)
    , DecentralizationLevel
    , EpochLength (..)
    , SlottingParameters (..)
    , getFederationPercentage
    )
import Control.DeepSeq
    ( NFData )
import Data.Foldable
    ( find )
import Data.Function
    ( on )
import Data.List
    ( foldl' )
import Data.Maybe
    ( fromMaybe )
import Data.Quantity
    ( Percentage (..) )
import Data.Sequence
    ( Seq )
import Data.Sequence.Strict
    ( StrictSeq )
import GHC.Generics
    ( Generic )
import NoThunks.Class
    ( NoThunks (..) )
import Numeric.Natural
    ( Natural )
import Quiet

import qualified Data.Sequence as Seq
import qualified Data.Sequence.Strict as StrictSeq

{-------------------------------------------------------------------------------
    Estimating pool performance
-------------------------------------------------------------------------------}
-- | Information about block production of a pool in one epoch.
data BlockProduction = BlockProduction
    { BlockProduction -> Natural
blocksProduced :: !Natural
        -- ^ Blocks produced in the given epoch.
    , BlockProduction -> Rational
stakeRelative :: !Rational
        -- ^ Relative stake of the pool that was relevant for block production.
        -- (i.e. from the "set" snapshot).
    }

-- | Estimate the performance of a pool from historical block production data.
--
-- Assumes that the 'SlottingParameters' are constant through the given
-- history.
estimatePoolPerformance
    :: SlottingParameters
    -> DecentralizationLevel
    -> Seq BlockProduction
        -- ^ Historical block production data. Most recent data comes /first/.
        -- Recent performance weighs more than past performance:
        --
        -- * Block production from > 25 epochs ago has less than 10% influence
        -- on the likelihoods.
        -- * Block production from > 50 epochs ago has less than 1% influence
        -- on the likelihoods and can be ignored.
    -> PerformanceEstimate
estimatePoolPerformance :: SlottingParameters
-> DecentralizationLevel
-> Seq BlockProduction
-> PerformanceEstimate
estimatePoolPerformance SlottingParameters
sp DecentralizationLevel
d Seq BlockProduction
history =
    Likelihood -> PerformanceEstimate
percentile' (Likelihood -> PerformanceEstimate)
-> Likelihood -> PerformanceEstimate
forall a b. (a -> b) -> a -> b
$ (Likelihood -> BlockProduction -> Likelihood)
-> Likelihood -> Seq BlockProduction -> Likelihood
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Likelihood -> BlockProduction -> Likelihood
considerEpoch Likelihood
forall a. Monoid a => a
mempty (Seq BlockProduction -> Seq BlockProduction
forall a. Seq a -> Seq a
Seq.reverse Seq BlockProduction
history)
  where
    considerEpoch :: Likelihood -> BlockProduction -> Likelihood
considerEpoch Likelihood
li BlockProduction
perf = Float -> Likelihood -> Likelihood
applyDecay Float
decayFactor Likelihood
li Likelihood -> Likelihood -> Likelihood
forall a. Semigroup a => a -> a -> a
<> BlockProduction -> Likelihood
likelihood' BlockProduction
perf

    prob :: BlockProduction -> Double
prob BlockProduction
perf = ActiveSlotCoeff -> Rational -> Rational -> Double
leaderProbability
        (ActiveSlotCoefficient -> ActiveSlotCoeff
toActiveSlotCoeff (ActiveSlotCoefficient -> ActiveSlotCoeff)
-> ActiveSlotCoefficient -> ActiveSlotCoeff
forall a b. (a -> b) -> a -> b
$ SlottingParameters -> ActiveSlotCoefficient
getActiveSlotCoefficient SlottingParameters
sp)
        (BlockProduction -> Rational
stakeRelative BlockProduction
perf)
        (Percentage -> Rational
getPercentage (Percentage -> Rational) -> Percentage -> Rational
forall a b. (a -> b) -> a -> b
$ DecentralizationLevel -> Percentage
getFederationPercentage DecentralizationLevel
d)
    likelihood' :: BlockProduction -> Likelihood
likelihood' BlockProduction
perf = Natural -> Double -> EpochSize -> Likelihood
likelihood
        (BlockProduction -> Natural
blocksProduced BlockProduction
perf)
        (BlockProduction -> Double
prob BlockProduction
perf)
        (Word32 -> EpochSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> EpochSize) -> Word32 -> EpochSize
forall a b. (a -> b) -> a -> b
$ EpochLength -> Word32
unEpochLength (EpochLength -> Word32) -> EpochLength -> Word32
forall a b. (a -> b) -> a -> b
$ SlottingParameters -> EpochLength
getEpochLength SlottingParameters
sp)

decayFactor :: Float
decayFactor :: Float
decayFactor = Float
0.9

{-------------------------------------------------------------------------------
    Support types
    for copy, to avoid changing it too much
-------------------------------------------------------------------------------}
type EpochSize = Integer
type UnitInterval = Rational
type PositiveUnitInterval = Rational

unboundRational :: Rational -> Rational
unboundRational :: Rational -> Rational
unboundRational = Rational -> Rational
forall a. a -> a
id

toActiveSlotCoeff :: ActiveSlotCoefficient -> ActiveSlotCoeff
toActiveSlotCoeff :: ActiveSlotCoefficient -> ActiveSlotCoeff
toActiveSlotCoeff (ActiveSlotCoefficient Double
x) = Rational -> ActiveSlotCoeff
ActiveSlotCoeff (Double -> Rational
forall a b. (Real a, Fractional b) => a -> b
realToFrac Double
x)

newtype ActiveSlotCoeff = ActiveSlotCoeff
    { ActiveSlotCoeff -> Rational
activeSlotVal :: PositiveUnitInterval }

{-------------------------------------------------------------------------------
    Copied material
    Almost exact copy, except for
    * missing from/toCBOR instances
    * reimannSum -> riemannSum 🤓
-------------------------------------------------------------------------------}
-- ---- begin copy ----
newtype LogWeight = LogWeight {LogWeight -> Float
unLogWeight :: Float}
  deriving (LogWeight -> LogWeight -> Bool
(LogWeight -> LogWeight -> Bool)
-> (LogWeight -> LogWeight -> Bool) -> Eq LogWeight
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LogWeight -> LogWeight -> Bool
$c/= :: LogWeight -> LogWeight -> Bool
== :: LogWeight -> LogWeight -> Bool
$c== :: LogWeight -> LogWeight -> Bool
Eq, (forall x. LogWeight -> Rep LogWeight x)
-> (forall x. Rep LogWeight x -> LogWeight) -> Generic LogWeight
forall x. Rep LogWeight x -> LogWeight
forall x. LogWeight -> Rep LogWeight x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep LogWeight x -> LogWeight
$cfrom :: forall x. LogWeight -> Rep LogWeight x
Generic, Eq LogWeight
Eq LogWeight
-> (LogWeight -> LogWeight -> Ordering)
-> (LogWeight -> LogWeight -> Bool)
-> (LogWeight -> LogWeight -> Bool)
-> (LogWeight -> LogWeight -> Bool)
-> (LogWeight -> LogWeight -> Bool)
-> (LogWeight -> LogWeight -> LogWeight)
-> (LogWeight -> LogWeight -> LogWeight)
-> Ord LogWeight
LogWeight -> LogWeight -> Bool
LogWeight -> LogWeight -> Ordering
LogWeight -> LogWeight -> LogWeight
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: LogWeight -> LogWeight -> LogWeight
$cmin :: LogWeight -> LogWeight -> LogWeight
max :: LogWeight -> LogWeight -> LogWeight
$cmax :: LogWeight -> LogWeight -> LogWeight
>= :: LogWeight -> LogWeight -> Bool
$c>= :: LogWeight -> LogWeight -> Bool
> :: LogWeight -> LogWeight -> Bool
$c> :: LogWeight -> LogWeight -> Bool
<= :: LogWeight -> LogWeight -> Bool
$c<= :: LogWeight -> LogWeight -> Bool
< :: LogWeight -> LogWeight -> Bool
$c< :: LogWeight -> LogWeight -> Bool
compare :: LogWeight -> LogWeight -> Ordering
$ccompare :: LogWeight -> LogWeight -> Ordering
$cp1Ord :: Eq LogWeight
Ord, EpochSize -> LogWeight
LogWeight -> LogWeight
LogWeight -> LogWeight -> LogWeight
(LogWeight -> LogWeight -> LogWeight)
-> (LogWeight -> LogWeight -> LogWeight)
-> (LogWeight -> LogWeight -> LogWeight)
-> (LogWeight -> LogWeight)
-> (LogWeight -> LogWeight)
-> (LogWeight -> LogWeight)
-> (EpochSize -> LogWeight)
-> Num LogWeight
forall a.
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (EpochSize -> a)
-> Num a
fromInteger :: EpochSize -> LogWeight
$cfromInteger :: EpochSize -> LogWeight
signum :: LogWeight -> LogWeight
$csignum :: LogWeight -> LogWeight
abs :: LogWeight -> LogWeight
$cabs :: LogWeight -> LogWeight
negate :: LogWeight -> LogWeight
$cnegate :: LogWeight -> LogWeight
* :: LogWeight -> LogWeight -> LogWeight
$c* :: LogWeight -> LogWeight -> LogWeight
- :: LogWeight -> LogWeight -> LogWeight
$c- :: LogWeight -> LogWeight -> LogWeight
+ :: LogWeight -> LogWeight -> LogWeight
$c+ :: LogWeight -> LogWeight -> LogWeight
Num, LogWeight -> ()
(LogWeight -> ()) -> NFData LogWeight
forall a. (a -> ()) -> NFData a
rnf :: LogWeight -> ()
$crnf :: LogWeight -> ()
NFData, Context -> LogWeight -> IO (Maybe ThunkInfo)
Proxy LogWeight -> String
(Context -> LogWeight -> IO (Maybe ThunkInfo))
-> (Context -> LogWeight -> IO (Maybe ThunkInfo))
-> (Proxy LogWeight -> String)
-> NoThunks LogWeight
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
showTypeOf :: Proxy LogWeight -> String
$cshowTypeOf :: Proxy LogWeight -> String
wNoThunks :: Context -> LogWeight -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> LogWeight -> IO (Maybe ThunkInfo)
noThunks :: Context -> LogWeight -> IO (Maybe ThunkInfo)
$cnoThunks :: Context -> LogWeight -> IO (Maybe ThunkInfo)
NoThunks)
  deriving (Int -> LogWeight -> ShowS
[LogWeight] -> ShowS
LogWeight -> String
(Int -> LogWeight -> ShowS)
-> (LogWeight -> String)
-> ([LogWeight] -> ShowS)
-> Show LogWeight
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LogWeight] -> ShowS
$cshowList :: [LogWeight] -> ShowS
show :: LogWeight -> String
$cshow :: LogWeight -> String
showsPrec :: Int -> LogWeight -> ShowS
$cshowsPrec :: Int -> LogWeight -> ShowS
Show) via Quiet LogWeight

toLogWeight :: Double -> LogWeight
toLogWeight :: Double -> LogWeight
toLogWeight Double
d = Float -> LogWeight
LogWeight (Double -> Float
forall a b. (Real a, Fractional b) => a -> b
realToFrac (Double -> Float) -> Double -> Float
forall a b. (a -> b) -> a -> b
$ Double -> Double
forall a. Floating a => a -> a
log Double
d)

fromLogWeight :: LogWeight -> Double
fromLogWeight :: LogWeight -> Double
fromLogWeight (LogWeight Float
l) = Double -> Double
forall a. Floating a => a -> a
exp (Float -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac Float
l)

newtype Histogram = Histogram {Histogram -> StrictSeq LogWeight
unHistogram :: StrictSeq LogWeight}
  deriving (Histogram -> Histogram -> Bool
(Histogram -> Histogram -> Bool)
-> (Histogram -> Histogram -> Bool) -> Eq Histogram
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Histogram -> Histogram -> Bool
$c/= :: Histogram -> Histogram -> Bool
== :: Histogram -> Histogram -> Bool
$c== :: Histogram -> Histogram -> Bool
Eq, Int -> Histogram -> ShowS
[Histogram] -> ShowS
Histogram -> String
(Int -> Histogram -> ShowS)
-> (Histogram -> String)
-> ([Histogram] -> ShowS)
-> Show Histogram
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Histogram] -> ShowS
$cshowList :: [Histogram] -> ShowS
show :: Histogram -> String
$cshow :: Histogram -> String
showsPrec :: Int -> Histogram -> ShowS
$cshowsPrec :: Int -> Histogram -> ShowS
Show, (forall x. Histogram -> Rep Histogram x)
-> (forall x. Rep Histogram x -> Histogram) -> Generic Histogram
forall x. Rep Histogram x -> Histogram
forall x. Histogram -> Rep Histogram x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Histogram x -> Histogram
$cfrom :: forall x. Histogram -> Rep Histogram x
Generic)

newtype Likelihood = Likelihood {Likelihood -> StrictSeq LogWeight
unLikelihood :: StrictSeq LogWeight}
  -- TODO: replace with small data structure
  deriving (Int -> Likelihood -> ShowS
[Likelihood] -> ShowS
Likelihood -> String
(Int -> Likelihood -> ShowS)
-> (Likelihood -> String)
-> ([Likelihood] -> ShowS)
-> Show Likelihood
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Likelihood] -> ShowS
$cshowList :: [Likelihood] -> ShowS
show :: Likelihood -> String
$cshow :: Likelihood -> String
showsPrec :: Int -> Likelihood -> ShowS
$cshowsPrec :: Int -> Likelihood -> ShowS
Show, Eq Likelihood
Eq Likelihood
-> (Likelihood -> Likelihood -> Ordering)
-> (Likelihood -> Likelihood -> Bool)
-> (Likelihood -> Likelihood -> Bool)
-> (Likelihood -> Likelihood -> Bool)
-> (Likelihood -> Likelihood -> Bool)
-> (Likelihood -> Likelihood -> Likelihood)
-> (Likelihood -> Likelihood -> Likelihood)
-> Ord Likelihood
Likelihood -> Likelihood -> Bool
Likelihood -> Likelihood -> Ordering
Likelihood -> Likelihood -> Likelihood
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Likelihood -> Likelihood -> Likelihood
$cmin :: Likelihood -> Likelihood -> Likelihood
max :: Likelihood -> Likelihood -> Likelihood
$cmax :: Likelihood -> Likelihood -> Likelihood
>= :: Likelihood -> Likelihood -> Bool
$c>= :: Likelihood -> Likelihood -> Bool
> :: Likelihood -> Likelihood -> Bool
$c> :: Likelihood -> Likelihood -> Bool
<= :: Likelihood -> Likelihood -> Bool
$c<= :: Likelihood -> Likelihood -> Bool
< :: Likelihood -> Likelihood -> Bool
$c< :: Likelihood -> Likelihood -> Bool
compare :: Likelihood -> Likelihood -> Ordering
$ccompare :: Likelihood -> Likelihood -> Ordering
$cp1Ord :: Eq Likelihood
Ord, (forall x. Likelihood -> Rep Likelihood x)
-> (forall x. Rep Likelihood x -> Likelihood) -> Generic Likelihood
forall x. Rep Likelihood x -> Likelihood
forall x. Likelihood -> Rep Likelihood x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Likelihood x -> Likelihood
$cfrom :: forall x. Likelihood -> Rep Likelihood x
Generic, Likelihood -> ()
(Likelihood -> ()) -> NFData Likelihood
forall a. (a -> ()) -> NFData a
rnf :: Likelihood -> ()
$crnf :: Likelihood -> ()
NFData)

instance NoThunks Likelihood

instance Eq Likelihood where
  == :: Likelihood -> Likelihood -> Bool
(==) = StrictSeq LogWeight -> StrictSeq LogWeight -> Bool
forall a. Eq a => a -> a -> Bool
(==) (StrictSeq LogWeight -> StrictSeq LogWeight -> Bool)
-> (Likelihood -> StrictSeq LogWeight)
-> Likelihood
-> Likelihood
-> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Likelihood -> StrictSeq LogWeight
unLikelihood (Likelihood -> StrictSeq LogWeight)
-> (Likelihood -> Likelihood) -> Likelihood -> StrictSeq LogWeight
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Likelihood -> Likelihood
normalizeLikelihood

instance Semigroup Likelihood where
  (Likelihood StrictSeq LogWeight
x) <> :: Likelihood -> Likelihood -> Likelihood
<> (Likelihood StrictSeq LogWeight
y) =
    Likelihood -> Likelihood
normalizeLikelihood (Likelihood -> Likelihood) -> Likelihood -> Likelihood
forall a b. (a -> b) -> a -> b
$ StrictSeq LogWeight -> Likelihood
Likelihood ((LogWeight -> LogWeight -> LogWeight)
-> StrictSeq LogWeight
-> StrictSeq LogWeight
-> StrictSeq LogWeight
forall a b c.
(a -> b -> c) -> StrictSeq a -> StrictSeq b -> StrictSeq c
StrictSeq.zipWith LogWeight -> LogWeight -> LogWeight
forall a. Num a => a -> a -> a
(+) StrictSeq LogWeight
x StrictSeq LogWeight
y)

instance Monoid Likelihood where
  mempty :: Likelihood
mempty = StrictSeq LogWeight -> Likelihood
Likelihood (StrictSeq LogWeight -> Likelihood)
-> StrictSeq LogWeight -> Likelihood
forall a b. (a -> b) -> a -> b
$ Seq LogWeight -> StrictSeq LogWeight
forall a. Seq a -> StrictSeq a
StrictSeq.forceToStrict (Seq LogWeight -> StrictSeq LogWeight)
-> Seq LogWeight -> StrictSeq LogWeight
forall a b. (a -> b) -> a -> b
$ Int -> LogWeight -> Seq LogWeight
forall a. Int -> a -> Seq a
Seq.replicate (StrictSeq Double -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length StrictSeq Double
samplePositions) (Float -> LogWeight
LogWeight Float
0)

normalizeLikelihood :: Likelihood -> Likelihood
normalizeLikelihood :: Likelihood -> Likelihood
normalizeLikelihood (Likelihood StrictSeq LogWeight
xs) = StrictSeq LogWeight -> Likelihood
Likelihood (StrictSeq LogWeight -> Likelihood)
-> StrictSeq LogWeight -> Likelihood
forall a b. (a -> b) -> a -> b
$ (\LogWeight
x -> LogWeight
x LogWeight -> LogWeight -> LogWeight
forall a. Num a => a -> a -> a
- LogWeight
m) (LogWeight -> LogWeight)
-> StrictSeq LogWeight -> StrictSeq LogWeight
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictSeq LogWeight
xs
  where
    m :: LogWeight
m = StrictSeq LogWeight -> LogWeight
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum StrictSeq LogWeight
xs

leaderProbability :: ActiveSlotCoeff -> Rational -> UnitInterval -> Double
leaderProbability :: ActiveSlotCoeff -> Rational -> Rational -> Double
leaderProbability ActiveSlotCoeff
activeSlotCoeff Rational
relativeStake Rational
decentralizationParameter =
  (Double
1 Double -> Double -> Double
forall a. Num a => a -> a -> a
- (Double
1 Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
asc) Double -> Double -> Double
forall a. Floating a => a -> a -> a
** Double
s) Double -> Double -> Double
forall a. Num a => a -> a -> a
* (Double
1 Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
d')
  where
    d' :: Double
d' = Rational -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac (Rational -> Double)
-> (Rational -> Rational) -> Rational -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rational -> Rational
unboundRational (Rational -> Double) -> Rational -> Double
forall a b. (a -> b) -> a -> b
$ Rational
decentralizationParameter
    asc :: Double
asc = Rational -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac (Rational -> Double)
-> (ActiveSlotCoeff -> Rational) -> ActiveSlotCoeff -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rational -> Rational
unboundRational (Rational -> Rational)
-> (ActiveSlotCoeff -> Rational) -> ActiveSlotCoeff -> Rational
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ActiveSlotCoeff -> Rational
activeSlotVal (ActiveSlotCoeff -> Double) -> ActiveSlotCoeff -> Double
forall a b. (a -> b) -> a -> b
$ ActiveSlotCoeff
activeSlotCoeff
    s :: Double
s = Rational -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac Rational
relativeStake

samplePositions :: StrictSeq Double
samplePositions :: StrictSeq Double
samplePositions = (\Double
x -> (Double
x Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
0.5) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
100.0) (Double -> Double) -> StrictSeq Double -> StrictSeq Double
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Double] -> StrictSeq Double
forall a. [a] -> StrictSeq a
StrictSeq.fromList [Double
0.0 .. Double
99.0]

likelihood ::
  Natural -> -- number of blocks produced this epoch
  Double -> -- chance we're allowed to produce a block in this slot
  EpochSize ->
  Likelihood
likelihood :: Natural -> Double -> EpochSize -> Likelihood
likelihood Natural
blocks Double
t EpochSize
slotsPerEpoch =
  StrictSeq LogWeight -> Likelihood
Likelihood (StrictSeq LogWeight -> Likelihood)
-> StrictSeq LogWeight -> Likelihood
forall a b. (a -> b) -> a -> b
$
    Double -> LogWeight
sample (Double -> LogWeight) -> StrictSeq Double -> StrictSeq LogWeight
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictSeq Double
samplePositions
  where
    -- The likelihood function L(x) is the probability of observing the data we got
    -- under the assumption that the underlying pool performance is equal to x.
    -- L(x) = C(n,m) * (tx)^n * (1-tx)^m
    -- where
    -- t is the chance we're allowed to produce a block
    -- n is the number of slots in which a block was produced
    -- m is the number of slots in which a block was not produced
    --      (slots per epoch minus n)
    -- C(n,m) is a coefficient that will be irrelevant
    -- Since the likelihood function only matters up to a scalar multiple, we will
    -- will divide out C(n,m) t^n and use the following instead:
    -- L(x) = x^n * (1-tx)^m
    -- We represent this function using 100 sample points, but to avoid very
    -- large exponents, we store the log of the value instead of the value itself.
    -- log(L(x)) = log [ x^n * (1-tx)^m ]
    --           = n * log(x) + m * log(1 - tx)
    -- TODO: worry more about loss of floating point precision
    --
    -- example:
    -- a pool has relative stake of 1 / 1,000,000 (~ 30k ada of 35b ada)
    -- f = active slot coefficient = 1/20
    -- t = 1 - (1-f)^(1/1,000,000)
    n :: Double
n = Natural -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
blocks
    m :: Double
m = EpochSize -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (EpochSize -> Double) -> EpochSize -> Double
forall a b. (a -> b) -> a -> b
$ EpochSize
slotsPerEpoch EpochSize -> EpochSize -> EpochSize
forall a. Num a => a -> a -> a
- Natural -> EpochSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
blocks
    l :: Double -> Double
    l :: Double -> Double
l Double
x = Double
n Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double -> Double
forall a. Floating a => a -> a
log Double
x Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
m Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double -> Double
forall a. Floating a => a -> a
log (Double
1 Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
t Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
x)
    sample :: Double -> LogWeight
sample Double
position = Float -> LogWeight
LogWeight (Double -> Float
forall a b. (Real a, Fractional b) => a -> b
realToFrac (Double -> Float) -> Double -> Float
forall a b. (a -> b) -> a -> b
$ Double -> Double
l Double
position)

-- | Decay previous likelihood
applyDecay :: Float -> Likelihood -> Likelihood
applyDecay :: Float -> Likelihood -> Likelihood
applyDecay Float
decay (Likelihood StrictSeq LogWeight
logWeights) = StrictSeq LogWeight -> Likelihood
Likelihood (StrictSeq LogWeight -> Likelihood)
-> StrictSeq LogWeight -> Likelihood
forall a b. (a -> b) -> a -> b
$ Float -> LogWeight -> LogWeight
mul Float
decay (LogWeight -> LogWeight)
-> StrictSeq LogWeight -> StrictSeq LogWeight
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictSeq LogWeight
logWeights
  where
    mul :: Float -> LogWeight -> LogWeight
mul Float
x (LogWeight Float
f) = Float -> LogWeight
LogWeight (Float
x Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
f)

posteriorDistribution :: Histogram -> Likelihood -> Histogram
posteriorDistribution :: Histogram -> Likelihood -> Histogram
posteriorDistribution (Histogram StrictSeq LogWeight
points) (Likelihood StrictSeq LogWeight
likelihoods) =
  Histogram -> Histogram
normalize (Histogram -> Histogram) -> Histogram -> Histogram
forall a b. (a -> b) -> a -> b
$
    StrictSeq LogWeight -> Histogram
Histogram (StrictSeq LogWeight -> Histogram)
-> StrictSeq LogWeight -> Histogram
forall a b. (a -> b) -> a -> b
$ (LogWeight -> LogWeight -> LogWeight)
-> StrictSeq LogWeight
-> StrictSeq LogWeight
-> StrictSeq LogWeight
forall a b c.
(a -> b -> c) -> StrictSeq a -> StrictSeq b -> StrictSeq c
StrictSeq.zipWith LogWeight -> LogWeight -> LogWeight
forall a. Num a => a -> a -> a
(+) StrictSeq LogWeight
points StrictSeq LogWeight
likelihoods

-- | Normalize the histogram so that the total area is 1
normalize :: Histogram -> Histogram
normalize :: Histogram -> Histogram
normalize (Histogram StrictSeq LogWeight
values) = StrictSeq LogWeight -> Histogram
Histogram (StrictSeq LogWeight -> Histogram)
-> StrictSeq LogWeight -> Histogram
forall a b. (a -> b) -> a -> b
$ (\LogWeight
x -> LogWeight
x LogWeight -> LogWeight -> LogWeight
forall a. Num a => a -> a -> a
- LogWeight
logArea) (LogWeight -> LogWeight)
-> StrictSeq LogWeight -> StrictSeq LogWeight
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictSeq LogWeight
values'
  where
    m :: LogWeight
m = StrictSeq LogWeight -> LogWeight
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum StrictSeq LogWeight
values
    values' :: StrictSeq LogWeight
values' = (\LogWeight
x -> LogWeight
x LogWeight -> LogWeight -> LogWeight
forall a. Num a => a -> a -> a
- LogWeight
m) (LogWeight -> LogWeight)
-> StrictSeq LogWeight -> StrictSeq LogWeight
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictSeq LogWeight
values
    logArea :: LogWeight
logArea = Double -> LogWeight
toLogWeight Double
area
    area :: Double
area = Double -> StrictSeq Double -> Double
forall (f :: * -> *).
(Functor f, Foldable f) =>
Double -> f Double -> Double
riemannSum Double
0.01 (LogWeight -> Double
fromLogWeight (LogWeight -> Double) -> StrictSeq LogWeight -> StrictSeq Double
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictSeq LogWeight
values')

-- | Calculate the k percentile for this distribution.
-- k is a value between 0 and 1. The 0 percentile is 0 and the 1 percentile is 1
percentile :: Double -> Histogram -> Likelihood -> PerformanceEstimate
percentile :: Double -> Histogram -> Likelihood -> PerformanceEstimate
percentile Double
p Histogram
prior Likelihood
likelihoods =
  Double -> PerformanceEstimate
PerformanceEstimate (Double -> PerformanceEstimate)
-> ((Double, Double) -> Double)
-> (Double, Double)
-> PerformanceEstimate
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Double, Double) -> Double
forall a b. (a, b) -> a
fst ((Double, Double) -> PerformanceEstimate)
-> (Double, Double) -> PerformanceEstimate
forall a b. (a -> b) -> a -> b
$
    (Double, Double) -> Maybe (Double, Double) -> (Double, Double)
forall a. a -> Maybe a -> a
fromMaybe (Double
1, Double
1) (Maybe (Double, Double) -> (Double, Double))
-> Maybe (Double, Double) -> (Double, Double)
forall a b. (a -> b) -> a -> b
$
      ((Double, Double) -> Bool)
-> Seq (Double, Double) -> Maybe (Double, Double)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\(Double
_x, Double
fx) -> Double
fx Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
p) Seq (Double, Double)
cdf
  where
    (Histogram StrictSeq LogWeight
values) = Histogram -> Likelihood -> Histogram
posteriorDistribution Histogram
prior Likelihood
likelihoods
    cdf :: Seq (Double, Double)
cdf =
      Seq Double -> Seq Double -> Seq (Double, Double)
forall a b. Seq a -> Seq b -> Seq (a, b)
Seq.zip
        (StrictSeq Double -> Seq Double
forall a. StrictSeq a -> Seq a
StrictSeq.fromStrict StrictSeq Double
samplePositions)
        (StrictSeq Double -> Seq Double
forall a. StrictSeq a -> Seq a
StrictSeq.fromStrict ((Double -> Double -> Double)
-> Double -> StrictSeq Double -> StrictSeq Double
forall a b. (a -> b -> a) -> a -> StrictSeq b -> StrictSeq a
StrictSeq.scanl Double -> Double -> Double
forall a. Num a => a -> a -> a
(+) Double
0 (LogWeight -> Double
fromLogWeight (LogWeight -> Double) -> StrictSeq LogWeight -> StrictSeq Double
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictSeq LogWeight
values)))

percentile' :: Likelihood -> PerformanceEstimate
percentile' :: Likelihood -> PerformanceEstimate
percentile' = Double -> Histogram -> Likelihood -> PerformanceEstimate
percentile Double
0.5 Histogram
h
  where
    h :: Histogram
h = Histogram -> Histogram
normalize (Histogram -> Histogram)
-> (StrictSeq LogWeight -> Histogram)
-> StrictSeq LogWeight
-> Histogram
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StrictSeq LogWeight -> Histogram
Histogram (StrictSeq LogWeight -> Histogram)
-> StrictSeq LogWeight -> Histogram
forall a b. (a -> b) -> a -> b
$ Double -> Double -> Double -> LogWeight
forall a. (Real a, Floating a) => a -> a -> a -> LogWeight
logBeta Double
40 Double
1 (Double -> LogWeight) -> StrictSeq Double -> StrictSeq LogWeight
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictSeq Double
samplePositions
    -- Beta(n,m)(x) = C * x^(n-1)*(1-x)^(m-1)
    -- log( Beta(n,m)(x) ) = (n-1) * log x + (m-1) * log (1-x)
    logBeta :: a -> a -> a -> LogWeight
logBeta a
n a
m a
x = Float -> LogWeight
LogWeight (Float -> LogWeight) -> (a -> Float) -> a -> LogWeight
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Float
forall a b. (Real a, Fractional b) => a -> b
realToFrac (a -> LogWeight) -> a -> LogWeight
forall a b. (a -> b) -> a -> b
$ (a
n a -> a -> a
forall a. Num a => a -> a -> a
- a
1) a -> a -> a
forall a. Num a => a -> a -> a
* a -> a
forall a. Floating a => a -> a
log a
x a -> a -> a
forall a. Num a => a -> a -> a
+ (a
m a -> a -> a
forall a. Num a => a -> a -> a
- a
1) a -> a -> a
forall a. Num a => a -> a -> a
* a -> a
forall a. Floating a => a -> a
log (a
1 a -> a -> a
forall a. Num a => a -> a -> a
- a
x)

riemannSum :: (Functor f, Foldable f) => Double -> f Double -> Double
riemannSum :: Double -> f Double -> Double
riemannSum Double
width f Double
heights = f Double -> Double
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (f Double -> Double) -> f Double -> Double
forall a b. (a -> b) -> a -> b
$ (Double -> Double) -> f Double -> f Double
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Double
width Double -> Double -> Double
forall a. Num a => a -> a -> a
*) f Double
heights

-- | This is a estimate of the proportion of allowed blocks a pool will
-- make in the future. It is used for ranking pools in delegation.
newtype PerformanceEstimate = PerformanceEstimate {PerformanceEstimate -> Double
unPerformanceEstimate :: Double}
  deriving (Int -> PerformanceEstimate -> ShowS
[PerformanceEstimate] -> ShowS
PerformanceEstimate -> String
(Int -> PerformanceEstimate -> ShowS)
-> (PerformanceEstimate -> String)
-> ([PerformanceEstimate] -> ShowS)
-> Show PerformanceEstimate
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PerformanceEstimate] -> ShowS
$cshowList :: [PerformanceEstimate] -> ShowS
show :: PerformanceEstimate -> String
$cshow :: PerformanceEstimate -> String
showsPrec :: Int -> PerformanceEstimate -> ShowS
$cshowsPrec :: Int -> PerformanceEstimate -> ShowS
Show, PerformanceEstimate -> PerformanceEstimate -> Bool
(PerformanceEstimate -> PerformanceEstimate -> Bool)
-> (PerformanceEstimate -> PerformanceEstimate -> Bool)
-> Eq PerformanceEstimate
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PerformanceEstimate -> PerformanceEstimate -> Bool
$c/= :: PerformanceEstimate -> PerformanceEstimate -> Bool
== :: PerformanceEstimate -> PerformanceEstimate -> Bool
$c== :: PerformanceEstimate -> PerformanceEstimate -> Bool
Eq, (forall x. PerformanceEstimate -> Rep PerformanceEstimate x)
-> (forall x. Rep PerformanceEstimate x -> PerformanceEstimate)
-> Generic PerformanceEstimate
forall x. Rep PerformanceEstimate x -> PerformanceEstimate
forall x. PerformanceEstimate -> Rep PerformanceEstimate x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep PerformanceEstimate x -> PerformanceEstimate
$cfrom :: forall x. PerformanceEstimate -> Rep PerformanceEstimate x
Generic, Context -> PerformanceEstimate -> IO (Maybe ThunkInfo)
Proxy PerformanceEstimate -> String
(Context -> PerformanceEstimate -> IO (Maybe ThunkInfo))
-> (Context -> PerformanceEstimate -> IO (Maybe ThunkInfo))
-> (Proxy PerformanceEstimate -> String)
-> NoThunks PerformanceEstimate
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
showTypeOf :: Proxy PerformanceEstimate -> String
$cshowTypeOf :: Proxy PerformanceEstimate -> String
wNoThunks :: Context -> PerformanceEstimate -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> PerformanceEstimate -> IO (Maybe ThunkInfo)
noThunks :: Context -> PerformanceEstimate -> IO (Maybe ThunkInfo)
$cnoThunks :: Context -> PerformanceEstimate -> IO (Maybe ThunkInfo)
NoThunks)
-- ---- end copy ----