{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}

module Shelley.Spec.Ledger.Rewards
  ( desirability,
    PerformanceEstimate (..),
    NonMyopic (..),
    emptyNonMyopic,
    getTopRankedPools,
    StakeShare (..),
    mkApparentPerformance,
    reward,
    nonMyopicStake,
    nonMyopicMemberRew,
    percentile',
    Histogram (..),
    LogWeight (..),
    likelihood,
    applyDecay,
    Likelihood (..),
    leaderProbability,
  )
where

import Cardano.Binary
  ( FromCBOR (..),
    ToCBOR (..),
    decodeDouble,
    encodeDouble,
    encodeListLen,
  )
import Cardano.Ledger.Era (Crypto, Era)
import Cardano.Ledger.Val ((<->))
import Cardano.Slotting.Slot (EpochSize)
import Control.DeepSeq (NFData)
import Control.Iterate.SetAlgebra (eval, (◁))
import Data.Foldable (find, fold)
import Data.Function (on)
import Data.List (sortBy)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Maybe (catMaybes, fromMaybe)
import Data.Ratio ((%))
import qualified Data.Sequence as Seq
import Data.Sequence.Strict (StrictSeq)
import qualified Data.Sequence.Strict as StrictSeq
import Data.Set (Set)
import qualified Data.Set as Set
import GHC.Generics (Generic)
import NoThunks.Class (NoThunks (..))
import Numeric.Natural (Natural)
import Quiet
import Shelley.Spec.Ledger.BaseTypes
  ( ActiveSlotCoeff,
    UnitInterval,
    activeSlotVal,
    unitIntervalToRational,
  )
import Shelley.Spec.Ledger.Coin
  ( Coin (..),
    coinToRational,
    rationalToCoinViaFloor,
  )
import Shelley.Spec.Ledger.Credential (Credential (..))
import Shelley.Spec.Ledger.Delegation.PoolParams (poolSpec)
import Shelley.Spec.Ledger.EpochBoundary
  ( BlocksMade (..),
    Stake (..),
    maxPool,
    poolStake,
  )
import Shelley.Spec.Ledger.Keys (KeyHash, KeyRole (..))
import Shelley.Spec.Ledger.PParams (PParams, _a0, _d, _nOpt)
import Shelley.Spec.Ledger.Serialization
  ( decodeRecordNamed,
    decodeSeq,
    encodeFoldable,
  )
import Shelley.Spec.Ledger.TxBody (PoolParams (..), getRwdCred)

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, Integer -> LogWeight
LogWeight -> LogWeight
LogWeight -> LogWeight -> LogWeight
(LogWeight -> LogWeight -> LogWeight)
-> (LogWeight -> LogWeight -> LogWeight)
-> (LogWeight -> LogWeight -> LogWeight)
-> (LogWeight -> LogWeight)
-> (LogWeight -> LogWeight)
-> (LogWeight -> LogWeight)
-> (Integer -> LogWeight)
-> Num LogWeight
forall a.
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (Integer -> a)
-> Num a
fromInteger :: Integer -> LogWeight
$cfromInteger :: Integer -> 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, Typeable LogWeight
Typeable LogWeight
-> (LogWeight -> Encoding)
-> ((forall t. ToCBOR t => Proxy t -> Size)
    -> Proxy LogWeight -> Size)
-> ((forall t. ToCBOR t => Proxy t -> Size)
    -> Proxy [LogWeight] -> Size)
-> ToCBOR LogWeight
LogWeight -> Encoding
(forall t. ToCBOR t => Proxy t -> Size)
-> Proxy [LogWeight] -> Size
(forall t. ToCBOR t => Proxy t -> Size) -> Proxy LogWeight -> Size
forall a.
Typeable a
-> (a -> Encoding)
-> ((forall t. ToCBOR t => Proxy t -> Size) -> Proxy a -> Size)
-> ((forall t. ToCBOR t => Proxy t -> Size) -> Proxy [a] -> Size)
-> ToCBOR a
encodedListSizeExpr :: (forall t. ToCBOR t => Proxy t -> Size)
-> Proxy [LogWeight] -> Size
$cencodedListSizeExpr :: (forall t. ToCBOR t => Proxy t -> Size)
-> Proxy [LogWeight] -> Size
encodedSizeExpr :: (forall t. ToCBOR t => Proxy t -> Size) -> Proxy LogWeight -> Size
$cencodedSizeExpr :: (forall t. ToCBOR t => Proxy t -> Size) -> Proxy LogWeight -> Size
toCBOR :: LogWeight -> Encoding
$ctoCBOR :: LogWeight -> Encoding
$cp1ToCBOR :: Typeable LogWeight
ToCBOR, Typeable LogWeight
Decoder s LogWeight
Typeable LogWeight
-> (forall s. Decoder s LogWeight)
-> (Proxy LogWeight -> Text)
-> FromCBOR LogWeight
Proxy LogWeight -> Text
forall s. Decoder s LogWeight
forall a.
Typeable a
-> (forall s. Decoder s a) -> (Proxy a -> Text) -> FromCBOR a
label :: Proxy LogWeight -> Text
$clabel :: Proxy LogWeight -> Text
fromCBOR :: Decoder s LogWeight
$cfromCBOR :: forall s. Decoder s LogWeight
$cp1FromCBOR :: Typeable LogWeight
FromCBOR)
  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, (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
strictSeqZipWith 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.toStrict (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)

-- TODO should be defined in @Data.Sequence.Strict@
strictSeqZipWith :: (a -> b -> c) -> StrictSeq a -> StrictSeq b -> StrictSeq c
strictSeqZipWith :: (a -> b -> c) -> StrictSeq a -> StrictSeq b -> StrictSeq c
strictSeqZipWith a -> b -> c
f StrictSeq a
x StrictSeq b
y =
  Seq c -> StrictSeq c
forall a. Seq a -> StrictSeq a
StrictSeq.toStrict ((a -> b -> c) -> Seq a -> Seq b -> Seq c
forall a b c. (a -> b -> c) -> Seq a -> Seq b -> Seq c
Seq.zipWith a -> b -> c
f (StrictSeq a -> Seq a
forall a. StrictSeq a -> Seq a
StrictSeq.getSeq StrictSeq a
x) (StrictSeq b -> Seq b
forall a. StrictSeq a -> Seq a
StrictSeq.getSeq StrictSeq b
y))

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

instance ToCBOR Likelihood where
  toCBOR :: Likelihood -> Encoding
toCBOR (Likelihood StrictSeq LogWeight
logweights) = StrictSeq LogWeight -> Encoding
forall a (f :: * -> *). (ToCBOR a, Foldable f) => f a -> Encoding
encodeFoldable StrictSeq LogWeight
logweights

instance FromCBOR Likelihood where
  fromCBOR :: Decoder s Likelihood
fromCBOR = StrictSeq LogWeight -> Likelihood
Likelihood (StrictSeq LogWeight -> Likelihood)
-> (Seq LogWeight -> StrictSeq LogWeight)
-> Seq LogWeight
-> Likelihood
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Seq LogWeight -> StrictSeq LogWeight
forall a. Seq a -> StrictSeq a
StrictSeq.toStrict (Seq LogWeight -> Likelihood)
-> Decoder s (Seq LogWeight) -> Decoder s Likelihood
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s LogWeight -> Decoder s (Seq LogWeight)
forall s a. Decoder s a -> Decoder s (Seq a)
decodeSeq Decoder s LogWeight
forall a s. FromCBOR a => Decoder s a
fromCBOR

leaderProbability :: ActiveSlotCoeff -> Rational -> UnitInterval -> Double
leaderProbability :: ActiveSlotCoeff -> Rational -> UnitInterval -> Double
leaderProbability ActiveSlotCoeff
activeSlotCoeff Rational
relativeStake UnitInterval
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)
-> (UnitInterval -> Rational) -> UnitInterval -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnitInterval -> Rational
unitIntervalToRational (UnitInterval -> Double) -> UnitInterval -> Double
forall a b. (a -> b) -> a -> b
$ UnitInterval
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
. UnitInterval -> Rational
unitIntervalToRational (UnitInterval -> Rational)
-> (ActiveSlotCoeff -> UnitInterval) -> ActiveSlotCoeff -> Rational
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ActiveSlotCoeff -> UnitInterval
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
strictSeqZipWith 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
reimannSum 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.getSeq StrictSeq Double
samplePositions)
        (StrictSeq Double -> Seq Double
forall a. StrictSeq a -> Seq a
StrictSeq.getSeq ((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)

reimannSum :: (Functor f, Foldable f) => Double -> f Double -> Double
reimannSum :: Double -> f Double -> Double
reimannSum 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)

instance ToCBOR PerformanceEstimate where
  toCBOR :: PerformanceEstimate -> Encoding
toCBOR = Double -> Encoding
encodeDouble (Double -> Encoding)
-> (PerformanceEstimate -> Double)
-> PerformanceEstimate
-> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PerformanceEstimate -> Double
unPerformanceEstimate

instance FromCBOR PerformanceEstimate where
  fromCBOR :: Decoder s PerformanceEstimate
fromCBOR = Double -> PerformanceEstimate
PerformanceEstimate (Double -> PerformanceEstimate)
-> Decoder s Double -> Decoder s PerformanceEstimate
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s Double
forall s. Decoder s Double
decodeDouble

data NonMyopic era = NonMyopic
  { NonMyopic era -> Map (KeyHash 'StakePool (Crypto era)) Likelihood
likelihoodsNM :: !(Map (KeyHash 'StakePool (Crypto era)) Likelihood),
    NonMyopic era -> Coin
rewardPotNM :: !Coin
  }
  deriving (Int -> NonMyopic era -> ShowS
[NonMyopic era] -> ShowS
NonMyopic era -> String
(Int -> NonMyopic era -> ShowS)
-> (NonMyopic era -> String)
-> ([NonMyopic era] -> ShowS)
-> Show (NonMyopic era)
forall era. Int -> NonMyopic era -> ShowS
forall era. [NonMyopic era] -> ShowS
forall era. NonMyopic era -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [NonMyopic era] -> ShowS
$cshowList :: forall era. [NonMyopic era] -> ShowS
show :: NonMyopic era -> String
$cshow :: forall era. NonMyopic era -> String
showsPrec :: Int -> NonMyopic era -> ShowS
$cshowsPrec :: forall era. Int -> NonMyopic era -> ShowS
Show, NonMyopic era -> NonMyopic era -> Bool
(NonMyopic era -> NonMyopic era -> Bool)
-> (NonMyopic era -> NonMyopic era -> Bool) -> Eq (NonMyopic era)
forall era. NonMyopic era -> NonMyopic era -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: NonMyopic era -> NonMyopic era -> Bool
$c/= :: forall era. NonMyopic era -> NonMyopic era -> Bool
== :: NonMyopic era -> NonMyopic era -> Bool
$c== :: forall era. NonMyopic era -> NonMyopic era -> Bool
Eq, (forall x. NonMyopic era -> Rep (NonMyopic era) x)
-> (forall x. Rep (NonMyopic era) x -> NonMyopic era)
-> Generic (NonMyopic era)
forall x. Rep (NonMyopic era) x -> NonMyopic era
forall x. NonMyopic era -> Rep (NonMyopic era) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall era x. Rep (NonMyopic era) x -> NonMyopic era
forall era x. NonMyopic era -> Rep (NonMyopic era) x
$cto :: forall era x. Rep (NonMyopic era) x -> NonMyopic era
$cfrom :: forall era x. NonMyopic era -> Rep (NonMyopic era) x
Generic)

emptyNonMyopic :: NonMyopic era
emptyNonMyopic :: NonMyopic era
emptyNonMyopic = Map (KeyHash 'StakePool (Crypto era)) Likelihood
-> Coin -> NonMyopic era
forall era.
Map (KeyHash 'StakePool (Crypto era)) Likelihood
-> Coin -> NonMyopic era
NonMyopic Map (KeyHash 'StakePool (Crypto era)) Likelihood
forall k a. Map k a
Map.empty (Integer -> Coin
Coin Integer
0)

instance NoThunks (NonMyopic era)

instance NFData (NonMyopic era)

instance Era era => ToCBOR (NonMyopic era) where
  toCBOR :: NonMyopic era -> Encoding
toCBOR
    NonMyopic
      { likelihoodsNM :: forall era.
NonMyopic era -> Map (KeyHash 'StakePool (Crypto era)) Likelihood
likelihoodsNM = Map (KeyHash 'StakePool (Crypto era)) Likelihood
aps,
        rewardPotNM :: forall era. NonMyopic era -> Coin
rewardPotNM = Coin
rp
      } =
      Word -> Encoding
encodeListLen Word
3
        Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Map (KeyHash 'StakePool (Crypto era)) Likelihood -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR Map (KeyHash 'StakePool (Crypto era)) Likelihood
aps
        Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Coin -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR Coin
rp

instance Era era => FromCBOR (NonMyopic era) where
  fromCBOR :: Decoder s (NonMyopic era)
fromCBOR = do
    Text
-> (NonMyopic era -> Int)
-> Decoder s (NonMyopic era)
-> Decoder s (NonMyopic era)
forall a s. Text -> (a -> Int) -> Decoder s a -> Decoder s a
decodeRecordNamed Text
"NonMyopic" (Int -> NonMyopic era -> Int
forall a b. a -> b -> a
const Int
3) (Decoder s (NonMyopic era) -> Decoder s (NonMyopic era))
-> Decoder s (NonMyopic era) -> Decoder s (NonMyopic era)
forall a b. (a -> b) -> a -> b
$ do
      Map (KeyHash 'StakePool (Crypto era)) Likelihood
aps <- Decoder s (Map (KeyHash 'StakePool (Crypto era)) Likelihood)
forall a s. FromCBOR a => Decoder s a
fromCBOR
      Coin
rp <- Decoder s Coin
forall a s. FromCBOR a => Decoder s a
fromCBOR
      NonMyopic era -> Decoder s (NonMyopic era)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NonMyopic era -> Decoder s (NonMyopic era))
-> NonMyopic era -> Decoder s (NonMyopic era)
forall a b. (a -> b) -> a -> b
$
        NonMyopic :: forall era.
Map (KeyHash 'StakePool (Crypto era)) Likelihood
-> Coin -> NonMyopic era
NonMyopic
          { likelihoodsNM :: Map (KeyHash 'StakePool (Crypto era)) Likelihood
likelihoodsNM = Map (KeyHash 'StakePool (Crypto era)) Likelihood
aps,
            rewardPotNM :: Coin
rewardPotNM = Coin
rp
          }

-- | Desirability calculation for non-myopic utily,
-- corresponding to f^~ in section 5.6.1 of
-- "Design Specification for Delegation and Incentives in Cardano"
desirability ::
  PParams era ->
  Coin ->
  PoolParams era ->
  PerformanceEstimate ->
  Coin ->
  Double
desirability :: PParams era
-> Coin -> PoolParams era -> PerformanceEstimate -> Coin -> Double
desirability PParams era
pp Coin
r PoolParams era
pool (PerformanceEstimate Double
p) (Coin Integer
totalStake) =
  if Double
fTilde Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
<= Double
cost
    then Double
0
    else (Double
fTilde Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
cost) Double -> Double -> Double
forall a. Num a => a -> a -> a
* (Double
1 Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
margin)
  where
    fTilde :: Double
fTilde = Double
fTildeNumer Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
fTildeDenom
    fTildeNumer :: Double
fTildeNumer = Double
p Double -> Double -> Double
forall a. Num a => a -> a -> a
* Rational -> Double
forall a. Fractional a => Rational -> a
fromRational (Coin -> Rational
coinToRational Coin
r Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* (Rational
z0 Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
+ Rational -> Rational -> Rational
forall a. Ord a => a -> a -> a
min Rational
s Rational
z0 Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* Rational
a0))
    fTildeDenom :: Double
fTildeDenom = Rational -> Double
forall a. Fractional a => Rational -> a
fromRational (Rational -> Double) -> Rational -> Double
forall a b. (a -> b) -> a -> b
$ Rational
1 Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
+ Rational
a0
    cost :: Double
cost = (Rational -> Double
forall a. Fractional a => Rational -> a
fromRational (Rational -> Double)
-> (PoolParams era -> Rational) -> PoolParams era -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Coin -> Rational
coinToRational (Coin -> Rational)
-> (PoolParams era -> Coin) -> PoolParams era -> Rational
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PoolParams era -> Coin
forall era. PoolParams era -> Coin
_poolCost) PoolParams era
pool
    margin :: Double
margin = (Rational -> Double
forall a. Fractional a => Rational -> a
fromRational (Rational -> Double)
-> (PoolParams era -> Rational) -> PoolParams era -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnitInterval -> Rational
unitIntervalToRational (UnitInterval -> Rational)
-> (PoolParams era -> UnitInterval) -> PoolParams era -> Rational
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PoolParams era -> UnitInterval
forall era. PoolParams era -> UnitInterval
_poolMargin) PoolParams era
pool
    tot :: Integer
tot = Integer -> Integer -> Integer
forall a. Ord a => a -> a -> a
max Integer
1 (Integer -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
totalStake)
    Coin Integer
pledge = PoolParams era -> Coin
forall era. PoolParams era -> Coin
_poolPledge PoolParams era
pool
    s :: Rational
s = Integer -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
pledge Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
% Integer
tot
    a0 :: HKD Identity Rational
a0 = PParams era -> HKD Identity Rational
forall (f :: * -> *) era. PParams' f era -> HKD f Rational
_a0 PParams era
pp
    z0 :: Rational
z0 = Integer
1 Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
% Integer -> Integer -> Integer
forall a. Ord a => a -> a -> a
max Integer
1 (Natural -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (PParams era -> HKD Identity Natural
forall (f :: * -> *) era. PParams' f era -> HKD f Natural
_nOpt PParams era
pp))

-- | Computes the top ranked stake pools
-- corresponding to section 5.6.1 of
-- "Design Specification for Delegation and Incentives in Cardano"
getTopRankedPools ::
  Coin ->
  Coin ->
  PParams era ->
  Map (KeyHash 'StakePool (Crypto era)) (PoolParams era) ->
  Map (KeyHash 'StakePool (Crypto era)) PerformanceEstimate ->
  Set (KeyHash 'StakePool (Crypto era))
getTopRankedPools :: Coin
-> Coin
-> PParams era
-> Map (KeyHash 'StakePool (Crypto era)) (PoolParams era)
-> Map (KeyHash 'StakePool (Crypto era)) PerformanceEstimate
-> Set (KeyHash 'StakePool (Crypto era))
getTopRankedPools Coin
rPot Coin
totalStake PParams era
pp Map (KeyHash 'StakePool (Crypto era)) (PoolParams era)
poolParams Map (KeyHash 'StakePool (Crypto era)) PerformanceEstimate
aps =
  [KeyHash 'StakePool (Crypto era)]
-> Set (KeyHash 'StakePool (Crypto era))
forall a. Ord a => [a] -> Set a
Set.fromList ([KeyHash 'StakePool (Crypto era)]
 -> Set (KeyHash 'StakePool (Crypto era)))
-> [KeyHash 'StakePool (Crypto era)]
-> Set (KeyHash 'StakePool (Crypto era))
forall a b. (a -> b) -> a -> b
$
    ((KeyHash 'StakePool (Crypto era), Double)
 -> KeyHash 'StakePool (Crypto era))
-> [(KeyHash 'StakePool (Crypto era), Double)]
-> [KeyHash 'StakePool (Crypto era)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (KeyHash 'StakePool (Crypto era), Double)
-> KeyHash 'StakePool (Crypto era)
forall a b. (a, b) -> a
fst ([(KeyHash 'StakePool (Crypto era), Double)]
 -> [KeyHash 'StakePool (Crypto era)])
-> [(KeyHash 'StakePool (Crypto era), Double)]
-> [KeyHash 'StakePool (Crypto era)]
forall a b. (a -> b) -> a -> b
$
      Int
-> [(KeyHash 'StakePool (Crypto era), Double)]
-> [(KeyHash 'StakePool (Crypto era), Double)]
forall a. Int -> [a] -> [a]
take (Natural -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Natural -> Int) -> Natural -> Int
forall a b. (a -> b) -> a -> b
$ PParams era -> HKD Identity Natural
forall (f :: * -> *) era. PParams' f era -> HKD f Natural
_nOpt PParams era
pp) (((KeyHash 'StakePool (Crypto era), Double)
 -> (KeyHash 'StakePool (Crypto era), Double) -> Ordering)
-> [(KeyHash 'StakePool (Crypto era), Double)]
-> [(KeyHash 'StakePool (Crypto era), Double)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy ((Double -> Double -> Ordering) -> Double -> Double -> Ordering
forall a b c. (a -> b -> c) -> b -> a -> c
flip Double -> Double -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Double -> Double -> Ordering)
-> ((KeyHash 'StakePool (Crypto era), Double) -> Double)
-> (KeyHash 'StakePool (Crypto era), Double)
-> (KeyHash 'StakePool (Crypto era), Double)
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (KeyHash 'StakePool (Crypto era), Double) -> Double
forall a b. (a, b) -> b
snd) [(KeyHash 'StakePool (Crypto era), Double)]
rankings)
  where
    pdata :: [(KeyHash 'StakePool (Crypto era),
  (PoolParams era, PerformanceEstimate))]
pdata = Map
  (KeyHash 'StakePool (Crypto era))
  (PoolParams era, PerformanceEstimate)
-> [(KeyHash 'StakePool (Crypto era),
     (PoolParams era, PerformanceEstimate))]
forall k a. Map k a -> [(k, a)]
Map.toList (Map
   (KeyHash 'StakePool (Crypto era))
   (PoolParams era, PerformanceEstimate)
 -> [(KeyHash 'StakePool (Crypto era),
      (PoolParams era, PerformanceEstimate))])
-> Map
     (KeyHash 'StakePool (Crypto era))
     (PoolParams era, PerformanceEstimate)
-> [(KeyHash 'StakePool (Crypto era),
     (PoolParams era, PerformanceEstimate))]
forall a b. (a -> b) -> a -> b
$ (PoolParams era
 -> PerformanceEstimate -> (PoolParams era, PerformanceEstimate))
-> Map (KeyHash 'StakePool (Crypto era)) (PoolParams era)
-> Map (KeyHash 'StakePool (Crypto era)) PerformanceEstimate
-> Map
     (KeyHash 'StakePool (Crypto era))
     (PoolParams era, PerformanceEstimate)
forall k a b c.
Ord k =>
(a -> b -> c) -> Map k a -> Map k b -> Map k c
Map.intersectionWith (,) Map (KeyHash 'StakePool (Crypto era)) (PoolParams era)
poolParams Map (KeyHash 'StakePool (Crypto era)) PerformanceEstimate
aps
    rankings :: [(KeyHash 'StakePool (Crypto era), Double)]
rankings =
      [ ( KeyHash 'StakePool (Crypto era)
hk,
          PParams era
-> Coin -> PoolParams era -> PerformanceEstimate -> Coin -> Double
forall era.
PParams era
-> Coin -> PoolParams era -> PerformanceEstimate -> Coin -> Double
desirability PParams era
pp Coin
rPot PoolParams era
pool PerformanceEstimate
ap Coin
totalStake
        )
        | (KeyHash 'StakePool (Crypto era)
hk, (PoolParams era
pool, PerformanceEstimate
ap)) <- [(KeyHash 'StakePool (Crypto era),
  (PoolParams era, PerformanceEstimate))]
pdata
      ]

-- | StakeShare type
newtype StakeShare = StakeShare {StakeShare -> Rational
unStakeShare :: Rational}
  deriving ((forall x. StakeShare -> Rep StakeShare x)
-> (forall x. Rep StakeShare x -> StakeShare) -> Generic StakeShare
forall x. Rep StakeShare x -> StakeShare
forall x. StakeShare -> Rep StakeShare x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep StakeShare x -> StakeShare
$cfrom :: forall x. StakeShare -> Rep StakeShare x
Generic, Eq StakeShare
Eq StakeShare
-> (StakeShare -> StakeShare -> Ordering)
-> (StakeShare -> StakeShare -> Bool)
-> (StakeShare -> StakeShare -> Bool)
-> (StakeShare -> StakeShare -> Bool)
-> (StakeShare -> StakeShare -> Bool)
-> (StakeShare -> StakeShare -> StakeShare)
-> (StakeShare -> StakeShare -> StakeShare)
-> Ord StakeShare
StakeShare -> StakeShare -> Bool
StakeShare -> StakeShare -> Ordering
StakeShare -> StakeShare -> StakeShare
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 :: StakeShare -> StakeShare -> StakeShare
$cmin :: StakeShare -> StakeShare -> StakeShare
max :: StakeShare -> StakeShare -> StakeShare
$cmax :: StakeShare -> StakeShare -> StakeShare
>= :: StakeShare -> StakeShare -> Bool
$c>= :: StakeShare -> StakeShare -> Bool
> :: StakeShare -> StakeShare -> Bool
$c> :: StakeShare -> StakeShare -> Bool
<= :: StakeShare -> StakeShare -> Bool
$c<= :: StakeShare -> StakeShare -> Bool
< :: StakeShare -> StakeShare -> Bool
$c< :: StakeShare -> StakeShare -> Bool
compare :: StakeShare -> StakeShare -> Ordering
$ccompare :: StakeShare -> StakeShare -> Ordering
$cp1Ord :: Eq StakeShare
Ord, StakeShare -> StakeShare -> Bool
(StakeShare -> StakeShare -> Bool)
-> (StakeShare -> StakeShare -> Bool) -> Eq StakeShare
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: StakeShare -> StakeShare -> Bool
$c/= :: StakeShare -> StakeShare -> Bool
== :: StakeShare -> StakeShare -> Bool
$c== :: StakeShare -> StakeShare -> Bool
Eq, Context -> StakeShare -> IO (Maybe ThunkInfo)
Proxy StakeShare -> String
(Context -> StakeShare -> IO (Maybe ThunkInfo))
-> (Context -> StakeShare -> IO (Maybe ThunkInfo))
-> (Proxy StakeShare -> String)
-> NoThunks StakeShare
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
showTypeOf :: Proxy StakeShare -> String
$cshowTypeOf :: Proxy StakeShare -> String
wNoThunks :: Context -> StakeShare -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> StakeShare -> IO (Maybe ThunkInfo)
noThunks :: Context -> StakeShare -> IO (Maybe ThunkInfo)
$cnoThunks :: Context -> StakeShare -> IO (Maybe ThunkInfo)
NoThunks)
  deriving (Int -> StakeShare -> ShowS
[StakeShare] -> ShowS
StakeShare -> String
(Int -> StakeShare -> ShowS)
-> (StakeShare -> String)
-> ([StakeShare] -> ShowS)
-> Show StakeShare
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [StakeShare] -> ShowS
$cshowList :: [StakeShare] -> ShowS
show :: StakeShare -> String
$cshow :: StakeShare -> String
showsPrec :: Int -> StakeShare -> ShowS
$cshowsPrec :: Int -> StakeShare -> ShowS
Show) via Quiet StakeShare

-- | Calculate pool reward
mkApparentPerformance ::
  UnitInterval ->
  Rational ->
  Natural ->
  Natural ->
  Rational
mkApparentPerformance :: UnitInterval -> Rational -> Natural -> Natural -> Rational
mkApparentPerformance UnitInterval
d_ Rational
sigma Natural
blocksN Natural
blocksTotal
  | Rational
sigma Rational -> Rational -> Bool
forall a. Eq a => a -> a -> Bool
== Rational
0 = Rational
0
  | UnitInterval -> Rational
unitIntervalToRational UnitInterval
d_ Rational -> Rational -> Bool
forall a. Ord a => a -> a -> Bool
< Rational
0.8 = Rational
beta Rational -> Rational -> Rational
forall a. Fractional a => a -> a -> a
/ Rational
sigma
  | Bool
otherwise = Rational
1
  where
    beta :: Rational
beta = Natural -> Rational
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
blocksN Rational -> Rational -> Rational
forall a. Fractional a => a -> a -> a
/ Natural -> Rational
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Natural -> Natural -> Natural
forall a. Ord a => a -> a -> a
max Natural
1 Natural
blocksTotal)

-- | Calculate pool leader reward
leaderRew ::
  Coin ->
  PoolParams era ->
  StakeShare ->
  StakeShare ->
  Coin
leaderRew :: Coin -> PoolParams era -> StakeShare -> StakeShare -> Coin
leaderRew Coin
f PoolParams era
pool (StakeShare Rational
s) (StakeShare Rational
sigma)
  | Coin
f Coin -> Coin -> Bool
forall a. Ord a => a -> a -> Bool
<= Coin
c = Coin
f
  | Bool
otherwise =
    Coin
c
      Coin -> Coin -> Coin
forall a. Semigroup a => a -> a -> a
<> Rational -> Coin
rationalToCoinViaFloor
        (Coin -> Rational
coinToRational (Coin
f Coin -> Coin -> Coin
forall t. Val t => t -> t -> t
<-> Coin
c) Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* (Rational
m' Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
+ (Rational
1 Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
- Rational
m') Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* Rational
s Rational -> Rational -> Rational
forall a. Fractional a => a -> a -> a
/ Rational
sigma))
  where
    (Coin
c, UnitInterval
m, Coin
_) = PoolParams era -> (Coin, UnitInterval, Coin)
forall era. PoolParams era -> (Coin, UnitInterval, Coin)
poolSpec PoolParams era
pool
    m' :: Rational
m' = UnitInterval -> Rational
unitIntervalToRational UnitInterval
m

-- | Calculate pool member reward
memberRew ::
  Coin ->
  PoolParams era ->
  StakeShare ->
  StakeShare ->
  Coin
memberRew :: Coin -> PoolParams era -> StakeShare -> StakeShare -> Coin
memberRew (Coin Integer
f') PoolParams era
pool (StakeShare Rational
t) (StakeShare Rational
sigma)
  | Integer
f' Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
c = Coin
forall a. Monoid a => a
mempty
  | Bool
otherwise =
    Rational -> Coin
rationalToCoinViaFloor (Rational -> Coin) -> Rational -> Coin
forall a b. (a -> b) -> a -> b
$
      Integer -> Rational
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer
f' Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
c) Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* (Rational
1 Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
- Rational
m') Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* Rational
t Rational -> Rational -> Rational
forall a. Fractional a => a -> a -> a
/ Rational
sigma
  where
    (Coin Integer
c, UnitInterval
m, Coin
_) = PoolParams era -> (Coin, UnitInterval, Coin)
forall era. PoolParams era -> (Coin, UnitInterval, Coin)
poolSpec PoolParams era
pool
    m' :: Rational
m' = UnitInterval -> Rational
unitIntervalToRational UnitInterval
m

-- | Reward one pool
rewardOnePool ::
  PParams era ->
  Coin ->
  Natural ->
  Natural ->
  PoolParams era ->
  Stake era ->
  Rational ->
  Rational ->
  Coin ->
  Set (Credential 'Staking era) ->
  Map (Credential 'Staking era) Coin
rewardOnePool :: PParams era
-> Coin
-> Natural
-> Natural
-> PoolParams era
-> Stake era
-> Rational
-> Rational
-> Coin
-> Set (Credential 'Staking era)
-> Map (Credential 'Staking era) Coin
rewardOnePool
  PParams era
pp
  Coin
r
  Natural
blocksN
  Natural
blocksTotal
  PoolParams era
pool
  (Stake Map (Credential 'Staking era) Coin
stake)
  Rational
sigma
  Rational
sigmaA
  (Coin Integer
totalStake)
  Set (Credential 'Staking era)
addrsRew =
    Map (Credential 'Staking era) Coin
rewards'
    where
      Coin Integer
ostake =
        (Coin -> KeyHash 'Staking (Crypto era) -> Coin)
-> Coin -> Set (KeyHash 'Staking (Crypto era)) -> Coin
forall a b. (a -> b -> a) -> a -> Set b -> a
Set.foldl'
          (\Coin
c KeyHash 'Staking (Crypto era)
o -> Coin
c Coin -> Coin -> Coin
forall a. Semigroup a => a -> a -> a
<> (Coin -> Maybe Coin -> Coin
forall a. a -> Maybe a -> a
fromMaybe Coin
forall a. Monoid a => a
mempty (Maybe Coin -> Coin) -> Maybe Coin -> Coin
forall a b. (a -> b) -> a -> b
$ Credential 'Staking era
-> Map (Credential 'Staking era) Coin -> Maybe Coin
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (KeyHash 'Staking (Crypto era) -> Credential 'Staking era
forall (kr :: KeyRole) era.
KeyHash kr (Crypto era) -> Credential kr era
KeyHashObj KeyHash 'Staking (Crypto era)
o) Map (Credential 'Staking era) Coin
stake))
          Coin
forall a. Monoid a => a
mempty
          (PoolParams era -> Set (KeyHash 'Staking (Crypto era))
forall era. PoolParams era -> Set (KeyHash 'Staking (Crypto era))
_poolOwners PoolParams era
pool)
      Coin Integer
pledge = PoolParams era -> Coin
forall era. PoolParams era -> Coin
_poolPledge PoolParams era
pool
      pr :: Rational
pr = Integer -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
pledge Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
% Integer -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
totalStake
      (Coin Integer
maxP) =
        if Integer
pledge Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
ostake
          then PParams era -> Coin -> Rational -> Rational -> Coin
forall era. PParams era -> Coin -> Rational -> Rational -> Coin
maxPool PParams era
pp Coin
r Rational
sigma Rational
pr
          else Coin
forall a. Monoid a => a
mempty
      appPerf :: Rational
appPerf = UnitInterval -> Rational -> Natural -> Natural -> Rational
mkApparentPerformance (PParams era -> HKD Identity UnitInterval
forall (f :: * -> *) era. PParams' f era -> HKD f UnitInterval
_d PParams era
pp) Rational
sigmaA Natural
blocksN Natural
blocksTotal
      poolR :: Coin
poolR = Rational -> Coin
rationalToCoinViaFloor (Rational
appPerf Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* Integer -> Rational
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
maxP)
      tot :: Integer
tot = Integer -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
totalStake
      mRewards :: Map (Credential 'Staking era) Coin
mRewards =
        [(Credential 'Staking era, Coin)]
-> Map (Credential 'Staking era) Coin
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
          [ ( Credential 'Staking era
hk,
              Coin -> PoolParams era -> StakeShare -> StakeShare -> Coin
forall era.
Coin -> PoolParams era -> StakeShare -> StakeShare -> Coin
memberRew
                Coin
poolR
                PoolParams era
pool
                (Rational -> StakeShare
StakeShare (Integer -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
c Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
% Integer
tot))
                (Rational -> StakeShare
StakeShare Rational
sigma)
            )
            | (Credential 'Staking era
hk, Coin Integer
c) <- Map (Credential 'Staking era) Coin
-> [(Credential 'Staking era, Coin)]
forall k a. Map k a -> [(k, a)]
Map.toList Map (Credential 'Staking era) Coin
stake,
              Credential 'Staking era -> Bool
notPoolOwner Credential 'Staking era
hk
          ]
      notPoolOwner :: Credential 'Staking era -> Bool
notPoolOwner (KeyHashObj KeyHash 'Staking (Crypto era)
hk) = KeyHash 'Staking (Crypto era)
hk KeyHash 'Staking (Crypto era)
-> Set (KeyHash 'Staking (Crypto era)) -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.notMember` PoolParams era -> Set (KeyHash 'Staking (Crypto era))
forall era. PoolParams era -> Set (KeyHash 'Staking (Crypto era))
_poolOwners PoolParams era
pool
      notPoolOwner (ScriptHashObj ScriptHash era
_) = Bool
False
      iReward :: Coin
iReward =
        Coin -> PoolParams era -> StakeShare -> StakeShare -> Coin
forall era.
Coin -> PoolParams era -> StakeShare -> StakeShare -> Coin
leaderRew
          Coin
poolR
          PoolParams era
pool
          (Rational -> StakeShare
StakeShare (Rational -> StakeShare) -> Rational -> StakeShare
forall a b. (a -> b) -> a -> b
$ Integer -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
ostake Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
% Integer
tot)
          (Rational -> StakeShare
StakeShare Rational
sigma)
      potentialRewards :: Map (Credential 'Staking era) Coin
potentialRewards =
        Credential 'Staking era
-> Coin
-> Map (Credential 'Staking era) Coin
-> Map (Credential 'Staking era) Coin
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert
          (RewardAcnt era -> Credential 'Staking era
forall era. RewardAcnt era -> Credential 'Staking era
getRwdCred (RewardAcnt era -> Credential 'Staking era)
-> RewardAcnt era -> Credential 'Staking era
forall a b. (a -> b) -> a -> b
$ PoolParams era -> RewardAcnt era
forall era. PoolParams era -> RewardAcnt era
_poolRAcnt PoolParams era
pool)
          Coin
iReward
          Map (Credential 'Staking era) Coin
mRewards
      rewards' :: Map (Credential 'Staking era) Coin
rewards' = (Coin -> Bool)
-> Map (Credential 'Staking era) Coin
-> Map (Credential 'Staking era) Coin
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter (Coin -> Coin -> Bool
forall a. Eq a => a -> a -> Bool
/= Integer -> Coin
Coin Integer
0) (Map (Credential 'Staking era) Coin
 -> Map (Credential 'Staking era) Coin)
-> Map (Credential 'Staking era) Coin
-> Map (Credential 'Staking era) Coin
forall a b. (a -> b) -> a -> b
$ Exp (Map (Credential 'Staking era) Coin)
-> Map (Credential 'Staking era) Coin
forall s t. Embed s t => Exp t -> s
eval (Set (Credential 'Staking era)
addrsRew Set (Credential 'Staking era)
-> Map (Credential 'Staking era) Coin
-> Exp (Map (Credential 'Staking era) Coin)
forall k s1 s2 (f :: * -> * -> *) v.
(Ord k, HasExp s1 (Sett k ()), HasExp s2 (f k v)) =>
s1 -> s2 -> Exp (f k v)
 Map (Credential 'Staking era) Coin
potentialRewards)

reward ::
  PParams era ->
  BlocksMade era ->
  Coin ->
  Set (Credential 'Staking era) ->
  Map (KeyHash 'StakePool (Crypto era)) (PoolParams era) ->
  Stake era ->
  Map (Credential 'Staking era) (KeyHash 'StakePool (Crypto era)) ->
  Coin ->
  ActiveSlotCoeff ->
  EpochSize ->
  ( Map
      (Credential 'Staking era)
      Coin,
    Map (KeyHash 'StakePool (Crypto era)) Likelihood
  )
reward :: PParams era
-> BlocksMade era
-> Coin
-> Set (Credential 'Staking era)
-> Map (KeyHash 'StakePool (Crypto era)) (PoolParams era)
-> Stake era
-> Map (Credential 'Staking era) (KeyHash 'StakePool (Crypto era))
-> Coin
-> ActiveSlotCoeff
-> EpochSize
-> (Map (Credential 'Staking era) Coin,
    Map (KeyHash 'StakePool (Crypto era)) Likelihood)
reward
  PParams era
pp
  (BlocksMade Map (KeyHash 'StakePool (Crypto era)) Natural
b)
  Coin
r
  Set (Credential 'Staking era)
addrsRew
  Map (KeyHash 'StakePool (Crypto era)) (PoolParams era)
poolParams
  Stake era
stake
  Map (Credential 'Staking era) (KeyHash 'StakePool (Crypto era))
delegs
  (Coin Integer
totalStake)
  ActiveSlotCoeff
asc
  EpochSize
slotsPerEpoch = (Map (Credential 'Staking era) Coin
rewards', Map (KeyHash 'StakePool (Crypto era)) Likelihood
hs)
    where
      totalBlocks :: Natural
totalBlocks = Map (KeyHash 'StakePool (Crypto era)) Natural -> Natural
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum Map (KeyHash 'StakePool (Crypto era)) Natural
b
      Coin Integer
activeStake = Map (Credential 'Staking era) Coin -> Coin
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold (Map (Credential 'Staking era) Coin -> Coin)
-> (Stake era -> Map (Credential 'Staking era) Coin)
-> Stake era
-> Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stake era -> Map (Credential 'Staking era) Coin
forall era. Stake era -> Map (Credential 'Staking era) Coin
unStake (Stake era -> Coin) -> Stake era -> Coin
forall a b. (a -> b) -> a -> b
$ Stake era
stake
      results :: [(KeyHash 'StakePool (Crypto era),
  Maybe (Map (Credential 'Staking era) Coin), Likelihood)]
results = do
        (KeyHash 'StakePool (Crypto era)
hk, PoolParams era
pparams) <- Map (KeyHash 'StakePool (Crypto era)) (PoolParams era)
-> [(KeyHash 'StakePool (Crypto era), PoolParams era)]
forall k a. Map k a -> [(k, a)]
Map.toList Map (KeyHash 'StakePool (Crypto era)) (PoolParams era)
poolParams
        let sigma :: Rational
sigma = if Integer
totalStake Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0 then Rational
0 else Integer -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
pstake Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
% Integer -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
totalStake
            sigmaA :: Rational
sigmaA = if Integer
activeStake Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0 then Rational
0 else Integer -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
pstake Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
% Integer -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
activeStake
            blocksProduced :: Maybe Natural
blocksProduced = KeyHash 'StakePool (Crypto era)
-> Map (KeyHash 'StakePool (Crypto era)) Natural -> Maybe Natural
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup KeyHash 'StakePool (Crypto era)
hk Map (KeyHash 'StakePool (Crypto era)) Natural
b
            actgr :: Stake era
actgr@(Stake Map (Credential 'Staking era) Coin
s) = KeyHash 'StakePool (Crypto era)
-> Map (Credential 'Staking era) (KeyHash 'StakePool (Crypto era))
-> Stake era
-> Stake era
forall era.
KeyHash 'StakePool (Crypto era)
-> Map (Credential 'Staking era) (KeyHash 'StakePool (Crypto era))
-> Stake era
-> Stake era
poolStake KeyHash 'StakePool (Crypto era)
hk Map (Credential 'Staking era) (KeyHash 'StakePool (Crypto era))
delegs Stake era
stake
            Coin Integer
pstake = Map (Credential 'Staking era) Coin -> Coin
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold Map (Credential 'Staking era) Coin
s
            rewardMap :: Maybe (Map (Credential 'Staking era) Coin)
rewardMap = case Maybe Natural
blocksProduced of
              Maybe Natural
Nothing -> Maybe (Map (Credential 'Staking era) Coin)
forall a. Maybe a
Nothing -- This is equivalent to calling rewarOnePool with n = 0
              Just Natural
n ->
                Map (Credential 'Staking era) Coin
-> Maybe (Map (Credential 'Staking era) Coin)
forall a. a -> Maybe a
Just (Map (Credential 'Staking era) Coin
 -> Maybe (Map (Credential 'Staking era) Coin))
-> Map (Credential 'Staking era) Coin
-> Maybe (Map (Credential 'Staking era) Coin)
forall a b. (a -> b) -> a -> b
$
                  PParams era
-> Coin
-> Natural
-> Natural
-> PoolParams era
-> Stake era
-> Rational
-> Rational
-> Coin
-> Set (Credential 'Staking era)
-> Map (Credential 'Staking era) Coin
forall era.
PParams era
-> Coin
-> Natural
-> Natural
-> PoolParams era
-> Stake era
-> Rational
-> Rational
-> Coin
-> Set (Credential 'Staking era)
-> Map (Credential 'Staking era) Coin
rewardOnePool
                    PParams era
pp
                    Coin
r
                    Natural
n
                    Natural
totalBlocks
                    PoolParams era
pparams
                    Stake era
actgr
                    Rational
sigma
                    Rational
sigmaA
                    (Integer -> Coin
Coin Integer
totalStake)
                    Set (Credential 'Staking era)
addrsRew
            ls :: Likelihood
ls =
              Natural -> Double -> EpochSize -> Likelihood
likelihood
                (Natural -> Maybe Natural -> Natural
forall a. a -> Maybe a -> a
fromMaybe Natural
0 Maybe Natural
blocksProduced)
                (ActiveSlotCoeff -> Rational -> UnitInterval -> Double
leaderProbability ActiveSlotCoeff
asc Rational
sigma (PParams era -> HKD Identity UnitInterval
forall (f :: * -> *) era. PParams' f era -> HKD f UnitInterval
_d PParams era
pp))
                EpochSize
slotsPerEpoch
        (KeyHash 'StakePool (Crypto era),
 Maybe (Map (Credential 'Staking era) Coin), Likelihood)
-> [(KeyHash 'StakePool (Crypto era),
     Maybe (Map (Credential 'Staking era) Coin), Likelihood)]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (KeyHash 'StakePool (Crypto era)
hk, Maybe (Map (Credential 'Staking era) Coin)
rewardMap, Likelihood
ls)
      rewards' :: Map (Credential 'Staking era) Coin
rewards' = [Map (Credential 'Staking era) Coin]
-> Map (Credential 'Staking era) Coin
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold ([Map (Credential 'Staking era) Coin]
 -> Map (Credential 'Staking era) Coin)
-> [Map (Credential 'Staking era) Coin]
-> Map (Credential 'Staking era) Coin
forall a b. (a -> b) -> a -> b
$ [Maybe (Map (Credential 'Staking era) Coin)]
-> [Map (Credential 'Staking era) Coin]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (Map (Credential 'Staking era) Coin)]
 -> [Map (Credential 'Staking era) Coin])
-> [Maybe (Map (Credential 'Staking era) Coin)]
-> [Map (Credential 'Staking era) Coin]
forall a b. (a -> b) -> a -> b
$ ((KeyHash 'StakePool (Crypto era),
  Maybe (Map (Credential 'Staking era) Coin), Likelihood)
 -> Maybe (Map (Credential 'Staking era) Coin))
-> [(KeyHash 'StakePool (Crypto era),
     Maybe (Map (Credential 'Staking era) Coin), Likelihood)]
-> [Maybe (Map (Credential 'Staking era) Coin)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(KeyHash 'StakePool (Crypto era)
_, Maybe (Map (Credential 'Staking era) Coin)
x, Likelihood
_) -> Maybe (Map (Credential 'Staking era) Coin)
x) [(KeyHash 'StakePool (Crypto era),
  Maybe (Map (Credential 'Staking era) Coin), Likelihood)]
results
      hs :: Map (KeyHash 'StakePool (Crypto era)) Likelihood
hs = [(KeyHash 'StakePool (Crypto era), Likelihood)]
-> Map (KeyHash 'StakePool (Crypto era)) Likelihood
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(KeyHash 'StakePool (Crypto era), Likelihood)]
 -> Map (KeyHash 'StakePool (Crypto era)) Likelihood)
-> [(KeyHash 'StakePool (Crypto era), Likelihood)]
-> Map (KeyHash 'StakePool (Crypto era)) Likelihood
forall a b. (a -> b) -> a -> b
$ ((KeyHash 'StakePool (Crypto era),
  Maybe (Map (Credential 'Staking era) Coin), Likelihood)
 -> (KeyHash 'StakePool (Crypto era), Likelihood))
-> [(KeyHash 'StakePool (Crypto era),
     Maybe (Map (Credential 'Staking era) Coin), Likelihood)]
-> [(KeyHash 'StakePool (Crypto era), Likelihood)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(KeyHash 'StakePool (Crypto era)
hk, Maybe (Map (Credential 'Staking era) Coin)
_, Likelihood
l) -> (KeyHash 'StakePool (Crypto era)
hk, Likelihood
l)) [(KeyHash 'StakePool (Crypto era),
  Maybe (Map (Credential 'Staking era) Coin), Likelihood)]
results

-- | Compute the Non-Myopic Pool Stake
--
--   This function implements non-myopic stake calculation in section 5.6.2
--   of "Design Specification for Delegation and Incentives in Cardano".
--   Note that the protocol parameters are implicit in the design document.
--   Additionally, instead of passing a rank r to compare with k,
--   we pass the top k desirable pools and check for membership.
nonMyopicStake ::
  PParams era ->
  StakeShare ->
  StakeShare ->
  StakeShare ->
  KeyHash 'StakePool (Crypto era) ->
  Set (KeyHash 'StakePool (Crypto era)) ->
  StakeShare
nonMyopicStake :: PParams era
-> StakeShare
-> StakeShare
-> StakeShare
-> KeyHash 'StakePool (Crypto era)
-> Set (KeyHash 'StakePool (Crypto era))
-> StakeShare
nonMyopicStake PParams era
pp (StakeShare Rational
s) (StakeShare Rational
sigma) (StakeShare Rational
t) KeyHash 'StakePool (Crypto era)
kh Set (KeyHash 'StakePool (Crypto era))
topPools =
  let z0 :: Rational
z0 = Integer
1 Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
% Integer -> Integer -> Integer
forall a. Ord a => a -> a -> a
max Integer
1 (Natural -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (PParams era -> HKD Identity Natural
forall (f :: * -> *) era. PParams' f era -> HKD f Natural
_nOpt PParams era
pp))
   in if KeyHash 'StakePool (Crypto era)
kh KeyHash 'StakePool (Crypto era)
-> Set (KeyHash 'StakePool (Crypto era)) -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set (KeyHash 'StakePool (Crypto era))
topPools
        then Rational -> StakeShare
StakeShare (Rational -> Rational -> Rational
forall a. Ord a => a -> a -> a
max (Rational
sigma Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
+ Rational
t) Rational
z0)
        else Rational -> StakeShare
StakeShare (Rational
s Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
+ Rational
t)

-- | Compute the Non-Myopic Pool Member Reward
--
--   This function implements equation (3) in section 5.6.4
--   of "Design Specification for Delegation and Incentives in Cardano".
--   Note that the protocol parameters and the reward pot are implicit
--   in the design document. Additionally, instead of passing a rank
--   r to compare with k, we pass the top k desirable pools and
--   check for membership.
nonMyopicMemberRew ::
  PParams era ->
  Coin ->
  PoolParams era ->
  StakeShare ->
  StakeShare ->
  StakeShare ->
  Set (KeyHash 'StakePool (Crypto era)) ->
  PerformanceEstimate ->
  Coin
nonMyopicMemberRew :: PParams era
-> Coin
-> PoolParams era
-> StakeShare
-> StakeShare
-> StakeShare
-> Set (KeyHash 'StakePool (Crypto era))
-> PerformanceEstimate
-> Coin
nonMyopicMemberRew
  PParams era
pp
  Coin
rPot
  PoolParams era
pool
  StakeShare
s
  StakeShare
sigma
  StakeShare
t
  Set (KeyHash 'StakePool (Crypto era))
topPools
  (PerformanceEstimate Double
p) =
    let nm :: StakeShare
nm = PParams era
-> StakeShare
-> StakeShare
-> StakeShare
-> KeyHash 'StakePool (Crypto era)
-> Set (KeyHash 'StakePool (Crypto era))
-> StakeShare
forall era.
PParams era
-> StakeShare
-> StakeShare
-> StakeShare
-> KeyHash 'StakePool (Crypto era)
-> Set (KeyHash 'StakePool (Crypto era))
-> StakeShare
nonMyopicStake PParams era
pp StakeShare
s StakeShare
sigma StakeShare
t (PoolParams era -> KeyHash 'StakePool (Crypto era)
forall era. PoolParams era -> KeyHash 'StakePool (Crypto era)
_poolId PoolParams era
pool) Set (KeyHash 'StakePool (Crypto era))
topPools
        f :: Coin
f = PParams era -> Coin -> Rational -> Rational -> Coin
forall era. PParams era -> Coin -> Rational -> Rational -> Coin
maxPool PParams era
pp Coin
rPot (StakeShare -> Rational
unStakeShare StakeShare
nm) (StakeShare -> Rational
unStakeShare StakeShare
s)
        fHat :: Integer
fHat = Double -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
floor (Double
p Double -> Double -> Double
forall a. Num a => a -> a -> a
* (Rational -> Double
forall a. Fractional a => Rational -> a
fromRational (Rational -> Double) -> (Coin -> Rational) -> Coin -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Coin -> Rational
coinToRational) Coin
f)
     in Coin -> PoolParams era -> StakeShare -> StakeShare -> Coin
forall era.
Coin -> PoolParams era -> StakeShare -> StakeShare -> Coin
memberRew (Integer -> Coin
Coin Integer
fHat) PoolParams era
pool StakeShare
t StakeShare
nm