{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}

module Cardano.Ledger.Shelley.PoolRank (
  desirability,
  PerformanceEstimate (..),
  NonMyopic (..),
  getTopRankedPools,
  getTopRankedPoolsVMap,
  nonMyopicStake,
  nonMyopicMemberRew,
  percentile',
  Histogram (..),
  LogWeight (..),
  likelihood,
  applyDecay,
  Likelihood (..),
  leaderProbability,
)
where

import Cardano.Ledger.BaseTypes (
  ActiveSlotCoeff,
  BoundedRational (..),
  NonNegativeInterval,
  UnitInterval,
  activeSlotVal,
 )
import Cardano.Ledger.Binary (
  DecCBOR (decCBOR),
  DecShareCBOR (Share, decSharePlusCBOR),
  EncCBOR (encCBOR),
  Interns,
  decSharePlusLensCBOR,
  decodeDouble,
  decodeRecordNamedT,
  encodeDouble,
  encodeListLen,
  toMemptyLens,
 )
import Cardano.Ledger.Coin (Coin (..), coinToRational)
import Cardano.Ledger.Core (Era (..), EraPParams, PParams, ppA0L, ppNOptL)
import Cardano.Ledger.Crypto (Crypto)
import Cardano.Ledger.EpochBoundary (maxPool)
import Cardano.Ledger.Keys (KeyHash, KeyRole (..))
import Cardano.Ledger.PoolParams (PoolParams (..))
import Cardano.Ledger.Shelley.Rewards (StakeShare (..), memberRew)
import Cardano.Slotting.Slot (EpochSize (..))
import Control.DeepSeq (NFData)
import Control.Monad.Trans
import Data.Aeson (FromJSON, KeyValue, ToJSON (..), object, pairs, (.=))
import Data.Default.Class (Default, def)
import Data.Foldable (find)
import Data.Function (on)
import Data.List (sortBy)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Maybe (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 qualified Data.VMap as VMap
import GHC.Generics (Generic)
import Lens.Micro ((^.), _1)
import NoThunks.Class (NoThunks (..))
import Numeric.Natural (Natural)
import Quiet

newtype LogWeight = LogWeight {LogWeight -> Float
unLogWeight :: Float}
  deriving (LogWeight -> LogWeight -> Bool
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. 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
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
Ord, Integer -> LogWeight
LogWeight -> LogWeight
LogWeight -> LogWeight -> 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 -> ()
forall a. (a -> ()) -> NFData a
rnf :: LogWeight -> ()
$crnf :: LogWeight -> ()
NFData, Context -> LogWeight -> IO (Maybe ThunkInfo)
Proxy LogWeight -> String
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
LogWeight -> Encoding
(forall t. EncCBOR t => Proxy t -> Size)
-> Proxy [LogWeight] -> Size
(forall t. EncCBOR t => Proxy t -> Size) -> Proxy LogWeight -> Size
forall a.
Typeable a
-> (a -> Encoding)
-> ((forall t. EncCBOR t => Proxy t -> Size) -> Proxy a -> Size)
-> ((forall t. EncCBOR t => Proxy t -> Size) -> Proxy [a] -> Size)
-> EncCBOR a
encodedListSizeExpr :: (forall t. EncCBOR t => Proxy t -> Size)
-> Proxy [LogWeight] -> Size
$cencodedListSizeExpr :: (forall t. EncCBOR t => Proxy t -> Size)
-> Proxy [LogWeight] -> Size
encodedSizeExpr :: (forall t. EncCBOR t => Proxy t -> Size) -> Proxy LogWeight -> Size
$cencodedSizeExpr :: (forall t. EncCBOR t => Proxy t -> Size) -> Proxy LogWeight -> Size
encCBOR :: LogWeight -> Encoding
$cencCBOR :: LogWeight -> Encoding
EncCBOR, Typeable LogWeight
Proxy LogWeight -> Text
forall s. Decoder s LogWeight
forall a.
Typeable a
-> (forall s. Decoder s a)
-> (forall s. Proxy a -> Decoder s ())
-> (Proxy a -> Text)
-> DecCBOR a
forall s. Proxy LogWeight -> Decoder s ()
label :: Proxy LogWeight -> Text
$clabel :: Proxy LogWeight -> Text
dropCBOR :: forall s. Proxy LogWeight -> Decoder s ()
$cdropCBOR :: forall s. Proxy LogWeight -> Decoder s ()
decCBOR :: forall s. Decoder s LogWeight
$cdecCBOR :: forall s. Decoder s LogWeight
DecCBOR, [LogWeight] -> Encoding
[LogWeight] -> Value
LogWeight -> Bool
LogWeight -> Encoding
LogWeight -> Value
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
omitField :: LogWeight -> Bool
$comitField :: LogWeight -> Bool
toEncodingList :: [LogWeight] -> Encoding
$ctoEncodingList :: [LogWeight] -> Encoding
toJSONList :: [LogWeight] -> Value
$ctoJSONList :: [LogWeight] -> Value
toEncoding :: LogWeight -> Encoding
$ctoEncoding :: LogWeight -> Encoding
toJSON :: LogWeight -> Value
$ctoJSON :: LogWeight -> Value
ToJSON, Maybe LogWeight
Value -> Parser [LogWeight]
Value -> Parser LogWeight
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
omittedField :: Maybe LogWeight
$comittedField :: Maybe LogWeight
parseJSONList :: Value -> Parser [LogWeight]
$cparseJSONList :: Value -> Parser [LogWeight]
parseJSON :: Value -> Parser LogWeight
$cparseJSON :: Value -> Parser LogWeight
FromJSON)
  deriving (Int -> LogWeight -> ShowS
[LogWeight] -> ShowS
LogWeight -> String
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 (forall a b. (Real a, Fractional b) => a -> b
realToFrac forall a b. (a -> b) -> a -> b
$ forall a. Floating a => a -> a
log Double
d)

fromLogWeight :: LogWeight -> Double
fromLogWeight :: LogWeight -> Double
fromLogWeight (LogWeight Float
l) = forall a. Floating a => a -> a
exp (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
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
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. 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
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
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
Ord, 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 -> ()
forall a. (a -> ()) -> NFData a
rnf :: Likelihood -> ()
$crnf :: Likelihood -> ()
NFData, Typeable Likelihood
Likelihood -> Encoding
(forall t. EncCBOR t => Proxy t -> Size)
-> Proxy [Likelihood] -> Size
(forall t. EncCBOR t => Proxy t -> Size)
-> Proxy Likelihood -> Size
forall a.
Typeable a
-> (a -> Encoding)
-> ((forall t. EncCBOR t => Proxy t -> Size) -> Proxy a -> Size)
-> ((forall t. EncCBOR t => Proxy t -> Size) -> Proxy [a] -> Size)
-> EncCBOR a
encodedListSizeExpr :: (forall t. EncCBOR t => Proxy t -> Size)
-> Proxy [Likelihood] -> Size
$cencodedListSizeExpr :: (forall t. EncCBOR t => Proxy t -> Size)
-> Proxy [Likelihood] -> Size
encodedSizeExpr :: (forall t. EncCBOR t => Proxy t -> Size)
-> Proxy Likelihood -> Size
$cencodedSizeExpr :: (forall t. EncCBOR t => Proxy t -> Size)
-> Proxy Likelihood -> Size
encCBOR :: Likelihood -> Encoding
$cencCBOR :: Likelihood -> Encoding
EncCBOR, Typeable Likelihood
Proxy Likelihood -> Text
forall s. Decoder s Likelihood
forall a.
Typeable a
-> (forall s. Decoder s a)
-> (forall s. Proxy a -> Decoder s ())
-> (Proxy a -> Text)
-> DecCBOR a
forall s. Proxy Likelihood -> Decoder s ()
label :: Proxy Likelihood -> Text
$clabel :: Proxy Likelihood -> Text
dropCBOR :: forall s. Proxy Likelihood -> Decoder s ()
$cdropCBOR :: forall s. Proxy Likelihood -> Decoder s ()
decCBOR :: forall s. Decoder s Likelihood
$cdecCBOR :: forall s. Decoder s Likelihood
DecCBOR)

instance NoThunks Likelihood

instance Eq Likelihood where
  == :: Likelihood -> Likelihood -> Bool
(==) = forall a. Eq a => a -> a -> Bool
(==) forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Likelihood -> StrictSeq LogWeight
unLikelihood 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 forall a b. (a -> b) -> a -> b
$ StrictSeq LogWeight -> Likelihood
Likelihood (forall a b c.
(a -> b -> c) -> StrictSeq a -> StrictSeq b -> StrictSeq c
StrictSeq.zipWith forall a. Num a => a -> a -> a
(+) StrictSeq LogWeight
x StrictSeq LogWeight
y)

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

instance ToJSON Likelihood where
  toJSON :: Likelihood -> Value
toJSON = forall a. ToJSON a => a -> Value
toJSON forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap LogWeight -> Double
fromLogWeight forall b c a. (b -> c) -> (a -> b) -> a -> c
. Likelihood -> StrictSeq LogWeight
unLikelihood
  toEncoding :: Likelihood -> Encoding
toEncoding = forall a. ToJSON a => a -> Encoding
toEncoding forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap LogWeight -> Double
fromLogWeight forall b c a. (b -> c) -> (a -> b) -> a -> c
. Likelihood -> StrictSeq LogWeight
unLikelihood

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

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

samplePositions :: StrictSeq Double
samplePositions :: StrictSeq Double
samplePositions = (\Double
x -> (Double
x forall a. Num a => a -> a -> a
+ Double
0.5) forall a. Fractional a => a -> a -> a
/ Double
100.0) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 forall a b. (a -> b) -> a -> b
$
    Double -> LogWeight
sample 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 = forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
blocks
    m :: Double
m = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ EpochSize -> Word64
unEpochSize EpochSize
slotsPerEpoch forall a. Num a => a -> a -> a
- forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
blocks
    l :: Double -> Double
    l :: Double -> Double
l Double
x = Double
n forall a. Num a => a -> a -> a
* forall a. Floating a => a -> a
log Double
x forall a. Num a => a -> a -> a
+ Double
m forall a. Num a => a -> a -> a
* forall a. Floating a => a -> a
log (Double
1 forall a. Num a => a -> a -> a
- Double
t forall a. Num a => a -> a -> a
* Double
x)
    sample :: Double -> LogWeight
sample Double
position = Float -> LogWeight
LogWeight (forall a b. (Real a, Fractional b) => a -> b
realToFrac 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 forall a b. (a -> b) -> a -> b
$ Float -> LogWeight -> LogWeight
mul Float
decay 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 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 forall a b. (a -> b) -> a -> b
$
    StrictSeq LogWeight -> Histogram
Histogram forall a b. (a -> b) -> a -> b
$
      forall a b c.
(a -> b -> c) -> StrictSeq a -> StrictSeq b -> StrictSeq c
StrictSeq.zipWith 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 forall a b. (a -> b) -> a -> b
$ (\LogWeight
x -> LogWeight
x forall a. Num a => a -> a -> a
- LogWeight
logArea) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictSeq LogWeight
values'
  where
    m :: LogWeight
m = forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum StrictSeq LogWeight
values
    values' :: StrictSeq LogWeight
values' = (\LogWeight
x -> LogWeight
x forall a. Num a => a -> a -> a
- LogWeight
m) 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 = forall (f :: * -> *).
(Functor f, Foldable f) =>
Double -> f Double -> Double
reimannSum Double
0.01 (LogWeight -> Double
fromLogWeight 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$
    forall a. a -> Maybe a -> a
fromMaybe (Double
1, Double
1) forall a b. (a -> b) -> a -> b
$
      forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\(Double
_x, Double
fx) -> Double
fx 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 =
      forall a b. Seq a -> Seq b -> Seq (a, b)
Seq.zip
        (forall a. StrictSeq a -> Seq a
StrictSeq.fromStrict StrictSeq Double
samplePositions)
        (forall a. StrictSeq a -> Seq a
StrictSeq.fromStrict (forall a b. (a -> b -> a) -> a -> StrictSeq b -> StrictSeq a
StrictSeq.scanl forall a. Num a => a -> a -> a
(+) Double
0 (LogWeight -> Double
fromLogWeight 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. StrictSeq LogWeight -> Histogram
Histogram forall a b. (a -> b) -> a -> b
$ forall {a}. (Real a, Floating a) => a -> a -> a -> LogWeight
logBeta Double
40 Double
1 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Real a, Fractional b) => a -> b
realToFrac forall a b. (a -> b) -> a -> b
$ (a
n forall a. Num a => a -> a -> a
- a
1) forall a. Num a => a -> a -> a
* forall a. Floating a => a -> a
log a
x forall a. Num a => a -> a -> a
+ (a
m forall a. Num a => a -> a -> a
- a
1) forall a. Num a => a -> a -> a
* forall a. Floating a => a -> a
log (a
1 forall a. Num a => a -> a -> a
- a
x)

reimannSum :: (Functor f, Foldable f) => Double -> f Double -> Double
reimannSum :: forall (f :: * -> *).
(Functor f, Foldable f) =>
Double -> f Double -> Double
reimannSum Double
width f Double
heights = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Double
width 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
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
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. 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
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 EncCBOR PerformanceEstimate where
  encCBOR :: PerformanceEstimate -> Encoding
encCBOR = Double -> Encoding
encodeDouble forall b c a. (b -> c) -> (a -> b) -> a -> c
. PerformanceEstimate -> Double
unPerformanceEstimate

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

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

instance Default (NonMyopic c) where
  def :: NonMyopic c
def = forall c.
Map (KeyHash 'StakePool c) Likelihood -> Coin -> NonMyopic c
NonMyopic forall k a. Map k a
Map.empty (Integer -> Coin
Coin Integer
0)

instance NoThunks (NonMyopic c)

instance NFData (NonMyopic c)

instance Crypto c => EncCBOR (NonMyopic c) where
  encCBOR :: NonMyopic c -> Encoding
encCBOR
    NonMyopic
      { likelihoodsNM :: forall c. NonMyopic c -> Map (KeyHash 'StakePool c) Likelihood
likelihoodsNM = Map (KeyHash 'StakePool c) Likelihood
aps
      , rewardPotNM :: forall c. NonMyopic c -> Coin
rewardPotNM = Coin
rp
      } =
      Word -> Encoding
encodeListLen Word
2
        forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR Map (KeyHash 'StakePool c) Likelihood
aps
        forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR Coin
rp

instance Crypto c => DecShareCBOR (NonMyopic c) where
  type Share (NonMyopic c) = Interns (KeyHash 'StakePool c)
  decSharePlusCBOR :: forall s. StateT (Share (NonMyopic c)) (Decoder s) (NonMyopic c)
decSharePlusCBOR = do
    forall (m :: (* -> *) -> * -> *) s a.
(MonadTrans m, Monad (m (Decoder s))) =>
Text -> (a -> Int) -> m (Decoder s) a -> m (Decoder s) a
decodeRecordNamedT Text
"NonMyopic" (forall a b. a -> b -> a
const Int
2) forall a b. (a -> b) -> a -> b
$ do
      Map (KeyHash 'StakePool c) Likelihood
likelihoodsNM <- forall b bs s.
DecShareCBOR b =>
Lens' bs (Share b) -> StateT bs (Decoder s) b
decSharePlusLensCBOR (forall a b c. Monoid a => Lens' a b -> Lens' c b -> Lens' c a
toMemptyLens forall s t a b. Field1 s t a b => Lens s t a b
_1 forall a. a -> a
id)
      Coin
rewardPotNM <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a s. DecCBOR a => Decoder s a
decCBOR
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ NonMyopic {Map (KeyHash 'StakePool c) Likelihood
likelihoodsNM :: Map (KeyHash 'StakePool c) Likelihood
likelihoodsNM :: Map (KeyHash 'StakePool c) Likelihood
likelihoodsNM, Coin
rewardPotNM :: Coin
rewardPotNM :: Coin
rewardPotNM}

instance Crypto crypto => ToJSON (NonMyopic crypto) where
  toJSON :: NonMyopic crypto -> Value
toJSON = [Pair] -> Value
object forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e a crypto.
(KeyValue e a, Crypto crypto) =>
NonMyopic crypto -> [a]
toNonMyopicPair
  toEncoding :: NonMyopic crypto -> Encoding
toEncoding = Series -> Encoding
pairs forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Monoid a => [a] -> a
mconcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e a crypto.
(KeyValue e a, Crypto crypto) =>
NonMyopic crypto -> [a]
toNonMyopicPair

toNonMyopicPair :: (KeyValue e a, Crypto crypto) => NonMyopic crypto -> [a]
toNonMyopicPair :: forall e a crypto.
(KeyValue e a, Crypto crypto) =>
NonMyopic crypto -> [a]
toNonMyopicPair nm :: NonMyopic crypto
nm@(NonMyopic Map (KeyHash 'StakePool crypto) Likelihood
_ Coin
_) =
  let NonMyopic {Map (KeyHash 'StakePool crypto) Likelihood
likelihoodsNM :: Map (KeyHash 'StakePool crypto) Likelihood
likelihoodsNM :: forall c. NonMyopic c -> Map (KeyHash 'StakePool c) Likelihood
likelihoodsNM, Coin
rewardPotNM :: Coin
rewardPotNM :: forall c. NonMyopic c -> Coin
rewardPotNM} = NonMyopic crypto
nm
   in [ Key
"likelihoodsNM" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Map (KeyHash 'StakePool crypto) Likelihood
likelihoodsNM
      , Key
"rewardPotNM" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Coin
rewardPotNM
      ]

-- | Desirability calculation for non-myopic utility,
-- corresponding to f^~ in section 5.6.1 of
-- "Design Specification for Delegation and Incentives in Cardano"
desirability ::
  (NonNegativeInterval, Natural) ->
  Coin ->
  PoolParams c ->
  PerformanceEstimate ->
  Coin ->
  Double
desirability :: forall c.
(NonNegativeInterval, Natural)
-> Coin -> PoolParams c -> PerformanceEstimate -> Coin -> Double
desirability (NonNegativeInterval
a0, Natural
nOpt) Coin
r PoolParams c
pool (PerformanceEstimate Double
p) (Coin Integer
totalStake) =
  if Double
fTilde forall a. Ord a => a -> a -> Bool
<= Double
cost
    then Double
0
    else (Double
fTilde forall a. Num a => a -> a -> a
- Double
cost) forall a. Num a => a -> a -> a
* (Double
1 forall a. Num a => a -> a -> a
- Double
margin)
  where
    fTilde :: Double
fTilde = Double
fTildeNumer forall a. Fractional a => a -> a -> a
/ Double
fTildeDenom
    fTildeNumer :: Double
fTildeNumer = Double
p forall a. Num a => a -> a -> a
* forall a. Fractional a => Rational -> a
fromRational (Coin -> Rational
coinToRational Coin
r forall a. Num a => a -> a -> a
* (Rational
z0 forall a. Num a => a -> a -> a
+ forall a. Ord a => a -> a -> a
min Rational
s Rational
z0 forall a. Num a => a -> a -> a
* forall r. BoundedRational r => r -> Rational
unboundRational NonNegativeInterval
a0))
    fTildeDenom :: Double
fTildeDenom = forall a. Fractional a => Rational -> a
fromRational forall a b. (a -> b) -> a -> b
$ Rational
1 forall a. Num a => a -> a -> a
+ forall r. BoundedRational r => r -> Rational
unboundRational NonNegativeInterval
a0
    cost :: Double
cost = (forall a. Fractional a => Rational -> a
fromRational forall b c a. (b -> c) -> (a -> b) -> a -> c
. Coin -> Rational
coinToRational forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c. PoolParams c -> Coin
ppCost) PoolParams c
pool
    margin :: Double
margin = (forall a. Fractional a => Rational -> a
fromRational forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall r. BoundedRational r => r -> Rational
unboundRational forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c. PoolParams c -> UnitInterval
ppMargin) PoolParams c
pool
    tot :: Integer
tot = forall a. Ord a => a -> a -> a
max Integer
1 (forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
totalStake)
    Coin Integer
pledge = forall c. PoolParams c -> Coin
ppPledge PoolParams c
pool
    s :: Rational
s = forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
pledge forall a. Integral a => a -> a -> Ratio a
% Integer
tot
    z0 :: Rational
z0 = Integer
1 forall a. Integral a => a -> a -> Ratio a
% forall a. Ord a => a -> a -> a
max Integer
1 (forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
nOpt)

-- | Computes the top ranked stake pools
-- corresponding to section 5.6.1 of
-- "Design Specification for Delegation and Incentives in Cardano"
getTopRankedPools ::
  EraPParams era =>
  Coin ->
  Coin ->
  PParams era ->
  Map (KeyHash 'StakePool c) (PoolParams c) ->
  Map (KeyHash 'StakePool c) PerformanceEstimate ->
  Set (KeyHash 'StakePool c)
getTopRankedPools :: forall era c.
EraPParams era =>
Coin
-> Coin
-> PParams era
-> Map (KeyHash 'StakePool c) (PoolParams c)
-> Map (KeyHash 'StakePool c) PerformanceEstimate
-> Set (KeyHash 'StakePool c)
getTopRankedPools Coin
rPot Coin
totalStake PParams era
pp Map (KeyHash 'StakePool c) (PoolParams c)
poolParams Map (KeyHash 'StakePool c) PerformanceEstimate
aps =
  let pdata :: [(KeyHash 'StakePool c, (PoolParams c, PerformanceEstimate))]
pdata = forall k a. Map k a -> [(k, a)]
Map.toAscList forall a b. (a -> b) -> a -> b
$ forall k a b c.
Ord k =>
(a -> b -> c) -> Map k a -> Map k b -> Map k c
Map.intersectionWith (,) Map (KeyHash 'StakePool c) (PoolParams c)
poolParams Map (KeyHash 'StakePool c) PerformanceEstimate
aps
   in forall era c.
EraPParams era =>
Coin
-> Coin
-> PParams era
-> [(KeyHash 'StakePool c, (PoolParams c, PerformanceEstimate))]
-> Set (KeyHash 'StakePool c)
getTopRankedPoolsInternal Coin
rPot Coin
totalStake PParams era
pp [(KeyHash 'StakePool c, (PoolParams c, PerformanceEstimate))]
pdata

getTopRankedPoolsVMap ::
  EraPParams era =>
  Coin ->
  Coin ->
  PParams era ->
  VMap.VMap VMap.VB VMap.VB (KeyHash 'StakePool (EraCrypto era)) (PoolParams (EraCrypto era)) ->
  Map (KeyHash 'StakePool (EraCrypto era)) PerformanceEstimate ->
  Set (KeyHash 'StakePool (EraCrypto era))
getTopRankedPoolsVMap :: forall era.
EraPParams era =>
Coin
-> Coin
-> PParams era
-> VMap
     VB
     VB
     (KeyHash 'StakePool (EraCrypto era))
     (PoolParams (EraCrypto era))
-> Map (KeyHash 'StakePool (EraCrypto era)) PerformanceEstimate
-> Set (KeyHash 'StakePool (EraCrypto era))
getTopRankedPoolsVMap Coin
rPot Coin
totalStake PParams era
pp VMap
  VB
  VB
  (KeyHash 'StakePool (EraCrypto era))
  (PoolParams (EraCrypto era))
poolParams Map (KeyHash 'StakePool (EraCrypto era)) PerformanceEstimate
aps =
  let pdata :: [(KeyHash 'StakePool (EraCrypto era),
  (PoolParams (EraCrypto era), PerformanceEstimate))]
pdata = [(KeyHash 'StakePool (EraCrypto era)
kh, (PoolParams (EraCrypto era)
pps, PerformanceEstimate
a)) | (KeyHash 'StakePool (EraCrypto era)
kh, PerformanceEstimate
a) <- forall k a. Map k a -> [(k, a)]
Map.toAscList Map (KeyHash 'StakePool (EraCrypto era)) PerformanceEstimate
aps, Just PoolParams (EraCrypto era)
pps <- [forall k (kv :: * -> *) (vv :: * -> *) v.
(Ord k, Vector kv k, Vector vv v) =>
k -> VMap kv vv k v -> Maybe v
VMap.lookup KeyHash 'StakePool (EraCrypto era)
kh VMap
  VB
  VB
  (KeyHash 'StakePool (EraCrypto era))
  (PoolParams (EraCrypto era))
poolParams]]
   in forall era c.
EraPParams era =>
Coin
-> Coin
-> PParams era
-> [(KeyHash 'StakePool c, (PoolParams c, PerformanceEstimate))]
-> Set (KeyHash 'StakePool c)
getTopRankedPoolsInternal Coin
rPot Coin
totalStake PParams era
pp [(KeyHash 'StakePool (EraCrypto era),
  (PoolParams (EraCrypto era), PerformanceEstimate))]
pdata

getTopRankedPoolsInternal ::
  EraPParams era =>
  Coin ->
  Coin ->
  PParams era ->
  [(KeyHash 'StakePool c, (PoolParams c, PerformanceEstimate))] ->
  Set (KeyHash 'StakePool c)
getTopRankedPoolsInternal :: forall era c.
EraPParams era =>
Coin
-> Coin
-> PParams era
-> [(KeyHash 'StakePool c, (PoolParams c, PerformanceEstimate))]
-> Set (KeyHash 'StakePool c)
getTopRankedPoolsInternal Coin
rPot Coin
totalStake PParams era
pp [(KeyHash 'StakePool c, (PoolParams c, PerformanceEstimate))]
pdata =
  forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$
    forall a b. (a, b) -> a
fst
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Int -> [a] -> [a]
take (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ PParams era
pp forall s a. s -> Getting a s a -> a
^. forall era. EraPParams era => Lens' (PParams era) Natural
ppNOptL) (forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. Ord a => a -> a -> Ordering
compare forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` forall a b. (a, b) -> b
snd) [(KeyHash 'StakePool c, Double)]
rankings)
  where
    rankings :: [(KeyHash 'StakePool c, Double)]
rankings =
      [ ( KeyHash 'StakePool c
hk
        , forall c.
(NonNegativeInterval, Natural)
-> Coin -> PoolParams c -> PerformanceEstimate -> Coin -> Double
desirability (PParams era
pp forall s a. s -> Getting a s a -> a
^. forall era.
EraPParams era =>
Lens' (PParams era) NonNegativeInterval
ppA0L, PParams era
pp forall s a. s -> Getting a s a -> a
^. forall era. EraPParams era => Lens' (PParams era) Natural
ppNOptL) Coin
rPot PoolParams c
pool PerformanceEstimate
ap Coin
totalStake
        )
      | (KeyHash 'StakePool c
hk, (PoolParams c
pool, PerformanceEstimate
ap)) <- [(KeyHash 'StakePool c, (PoolParams c, PerformanceEstimate))]
pdata
      ]

-- | 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 ::
  EraPParams era =>
  PParams era ->
  StakeShare ->
  StakeShare ->
  StakeShare ->
  KeyHash 'StakePool c ->
  Set (KeyHash 'StakePool c) ->
  StakeShare
nonMyopicStake :: forall era c.
EraPParams era =>
PParams era
-> StakeShare
-> StakeShare
-> StakeShare
-> KeyHash 'StakePool c
-> Set (KeyHash 'StakePool c)
-> StakeShare
nonMyopicStake PParams era
pp (StakeShare Rational
s) (StakeShare Rational
sigma) (StakeShare Rational
t) KeyHash 'StakePool c
kh Set (KeyHash 'StakePool c)
topPools =
  let z0 :: Rational
z0 = Integer
1 forall a. Integral a => a -> a -> Ratio a
% forall a. Ord a => a -> a -> a
max Integer
1 (forall a b. (Integral a, Num b) => a -> b
fromIntegral (PParams era
pp forall s a. s -> Getting a s a -> a
^. forall era. EraPParams era => Lens' (PParams era) Natural
ppNOptL))
   in if KeyHash 'StakePool c
kh forall a. Ord a => a -> Set a -> Bool
`Set.member` Set (KeyHash 'StakePool c)
topPools
        then Rational -> StakeShare
StakeShare (forall a. Ord a => a -> a -> a
max (Rational
sigma forall a. Num a => a -> a -> a
+ Rational
t) Rational
z0)
        else Rational -> StakeShare
StakeShare (Rational
s 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 ::
  EraPParams era =>
  PParams era ->
  Coin ->
  PoolParams c ->
  StakeShare ->
  StakeShare ->
  StakeShare ->
  Set (KeyHash 'StakePool c) ->
  PerformanceEstimate ->
  Coin
nonMyopicMemberRew :: forall era c.
EraPParams era =>
PParams era
-> Coin
-> PoolParams c
-> StakeShare
-> StakeShare
-> StakeShare
-> Set (KeyHash 'StakePool c)
-> PerformanceEstimate
-> Coin
nonMyopicMemberRew
  PParams era
pp
  Coin
rPot
  PoolParams c
pool
  StakeShare
s
  StakeShare
sigma
  StakeShare
t
  Set (KeyHash 'StakePool c)
topPools
  (PerformanceEstimate Double
p) =
    let nm :: StakeShare
nm = forall era c.
EraPParams era =>
PParams era
-> StakeShare
-> StakeShare
-> StakeShare
-> KeyHash 'StakePool c
-> Set (KeyHash 'StakePool c)
-> StakeShare
nonMyopicStake PParams era
pp StakeShare
s StakeShare
sigma StakeShare
t (forall c. PoolParams c -> KeyHash 'StakePool c
ppId PoolParams c
pool) Set (KeyHash 'StakePool c)
topPools
        f :: Coin
f = forall era.
EraPParams 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 = forall a b. (RealFrac a, Integral b) => a -> b
floor (Double
p forall a. Num a => a -> a -> a
* (forall a. Fractional a => Rational -> a
fromRational forall b c a. (b -> c) -> (a -> b) -> a -> c
. Coin -> Rational
coinToRational) Coin
f)
     in forall c. Coin -> PoolParams c -> StakeShare -> StakeShare -> Coin
memberRew (Integer -> Coin
Coin Integer
fHat) PoolParams c
pool StakeShare
t StakeShare
nm