{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
{-# 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,
  NonZero (..),
  UnitInterval,
  activeSlotVal,
  knownNonZero,
  knownNonZeroBounded,
  nonZeroOr,
  toIntegerNonZero,
  (%.),
 )
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 (EraPParams, PParams, ppA0L, ppNOptL)
import Cardano.Ledger.Keys (KeyHash, KeyRole (..))
import Cardano.Ledger.PoolParams (PoolParams (..))
import Cardano.Ledger.Shelley.Rewards (StakeShare (..), memberRew)
import Cardano.Ledger.State (maxPool)
import Cardano.Slotting.Slot (EpochSize (..))
import Control.DeepSeq (NFData)
import Control.Monad.Trans
import Data.Aeson (FromJSON, KeyValue, ToJSON (..), object, pairs, (.=))
import Data.Default (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 Data.Word (Word16)
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
(LogWeight -> LogWeight -> Bool)
-> (LogWeight -> LogWeight -> Bool) -> Eq LogWeight
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: LogWeight -> LogWeight -> Bool
== :: LogWeight -> LogWeight -> Bool
$c/= :: LogWeight -> LogWeight -> Bool
/= :: 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
$cfrom :: forall x. LogWeight -> Rep LogWeight x
from :: forall x. LogWeight -> Rep LogWeight x
$cto :: forall x. Rep LogWeight x -> LogWeight
to :: forall x. Rep LogWeight x -> LogWeight
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
$ccompare :: LogWeight -> LogWeight -> Ordering
compare :: LogWeight -> LogWeight -> Ordering
$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
>= :: LogWeight -> LogWeight -> Bool
$cmax :: LogWeight -> LogWeight -> LogWeight
max :: LogWeight -> LogWeight -> LogWeight
$cmin :: LogWeight -> LogWeight -> LogWeight
min :: LogWeight -> LogWeight -> 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
$c+ :: LogWeight -> LogWeight -> LogWeight
+ :: LogWeight -> LogWeight -> LogWeight
$c- :: LogWeight -> LogWeight -> LogWeight
- :: LogWeight -> LogWeight -> LogWeight
$c* :: LogWeight -> LogWeight -> LogWeight
* :: LogWeight -> LogWeight -> LogWeight
$cnegate :: LogWeight -> LogWeight
negate :: LogWeight -> LogWeight
$cabs :: LogWeight -> LogWeight
abs :: LogWeight -> LogWeight
$csignum :: LogWeight -> LogWeight
signum :: LogWeight -> LogWeight
$cfromInteger :: Integer -> LogWeight
fromInteger :: Integer -> LogWeight
Num, LogWeight -> ()
(LogWeight -> ()) -> NFData LogWeight
forall a. (a -> ()) -> NFData a
$crnf :: LogWeight -> ()
rnf :: 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
$cnoThunks :: Context -> LogWeight -> IO (Maybe ThunkInfo)
noThunks :: Context -> LogWeight -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> LogWeight -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> LogWeight -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy LogWeight -> String
showTypeOf :: Proxy LogWeight -> String
NoThunks, Typeable LogWeight
Typeable LogWeight =>
(LogWeight -> Encoding)
-> ((forall t. EncCBOR t => Proxy t -> Size)
    -> Proxy LogWeight -> Size)
-> ((forall t. EncCBOR t => Proxy t -> Size)
    -> Proxy [LogWeight] -> Size)
-> EncCBOR 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
$cencCBOR :: LogWeight -> Encoding
encCBOR :: LogWeight -> Encoding
$cencodedSizeExpr :: (forall t. EncCBOR t => Proxy t -> Size) -> Proxy LogWeight -> Size
encodedSizeExpr :: (forall t. EncCBOR t => Proxy t -> Size) -> Proxy LogWeight -> Size
$cencodedListSizeExpr :: (forall t. EncCBOR t => Proxy t -> Size)
-> Proxy [LogWeight] -> Size
encodedListSizeExpr :: (forall t. EncCBOR t => Proxy t -> Size)
-> Proxy [LogWeight] -> Size
EncCBOR, Typeable LogWeight
Typeable LogWeight =>
(forall s. Decoder s LogWeight)
-> (forall s. Proxy LogWeight -> Decoder s ())
-> (Proxy LogWeight -> Text)
-> DecCBOR 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 ()
$cdecCBOR :: forall s. Decoder s LogWeight
decCBOR :: forall s. Decoder s LogWeight
$cdropCBOR :: forall s. Proxy LogWeight -> Decoder s ()
dropCBOR :: forall s. Proxy LogWeight -> Decoder s ()
$clabel :: Proxy LogWeight -> Text
label :: Proxy LogWeight -> Text
DecCBOR, [LogWeight] -> Value
[LogWeight] -> Encoding
LogWeight -> Bool
LogWeight -> Value
LogWeight -> Encoding
(LogWeight -> Value)
-> (LogWeight -> Encoding)
-> ([LogWeight] -> Value)
-> ([LogWeight] -> Encoding)
-> (LogWeight -> Bool)
-> ToJSON LogWeight
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: LogWeight -> Value
toJSON :: LogWeight -> Value
$ctoEncoding :: LogWeight -> Encoding
toEncoding :: LogWeight -> Encoding
$ctoJSONList :: [LogWeight] -> Value
toJSONList :: [LogWeight] -> Value
$ctoEncodingList :: [LogWeight] -> Encoding
toEncodingList :: [LogWeight] -> Encoding
$comitField :: LogWeight -> Bool
omitField :: LogWeight -> Bool
ToJSON, Maybe LogWeight
Value -> Parser [LogWeight]
Value -> Parser LogWeight
(Value -> Parser LogWeight)
-> (Value -> Parser [LogWeight])
-> Maybe LogWeight
-> FromJSON LogWeight
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser LogWeight
parseJSON :: Value -> Parser LogWeight
$cparseJSONList :: Value -> Parser [LogWeight]
parseJSONList :: Value -> Parser [LogWeight]
$comittedField :: Maybe LogWeight
omittedField :: Maybe LogWeight
FromJSON)
  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
$cshowsPrec :: Int -> LogWeight -> ShowS
showsPrec :: Int -> LogWeight -> ShowS
$cshow :: LogWeight -> String
show :: LogWeight -> String
$cshowList :: [LogWeight] -> ShowS
showList :: [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
$c== :: Histogram -> Histogram -> Bool
== :: Histogram -> Histogram -> Bool
$c/= :: Histogram -> Histogram -> Bool
/= :: 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
$cshowsPrec :: Int -> Histogram -> ShowS
showsPrec :: Int -> Histogram -> ShowS
$cshow :: Histogram -> String
show :: Histogram -> String
$cshowList :: [Histogram] -> ShowS
showList :: [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
$cfrom :: forall x. Histogram -> Rep Histogram x
from :: forall x. Histogram -> Rep Histogram x
$cto :: forall x. Rep Histogram x -> Histogram
to :: forall x. Rep Histogram x -> Histogram
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
$cshowsPrec :: Int -> Likelihood -> ShowS
showsPrec :: Int -> Likelihood -> ShowS
$cshow :: Likelihood -> String
show :: Likelihood -> String
$cshowList :: [Likelihood] -> ShowS
showList :: [Likelihood] -> ShowS
Show, Eq Likelihood
Eq Likelihood =>
(Likelihood -> Likelihood -> Ordering)
-> (Likelihood -> Likelihood -> Bool)
-> (Likelihood -> Likelihood -> Bool)
-> (Likelihood -> Likelihood -> Bool)
-> (Likelihood -> Likelihood -> Bool)
-> (Likelihood -> Likelihood -> Likelihood)
-> (Likelihood -> Likelihood -> Likelihood)
-> Ord Likelihood
Likelihood -> Likelihood -> Bool
Likelihood -> Likelihood -> Ordering
Likelihood -> Likelihood -> Likelihood
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Likelihood -> Likelihood -> Ordering
compare :: Likelihood -> Likelihood -> Ordering
$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
>= :: Likelihood -> Likelihood -> Bool
$cmax :: Likelihood -> Likelihood -> Likelihood
max :: Likelihood -> Likelihood -> Likelihood
$cmin :: Likelihood -> Likelihood -> Likelihood
min :: Likelihood -> Likelihood -> Likelihood
Ord, (forall x. Likelihood -> Rep Likelihood x)
-> (forall x. Rep Likelihood x -> Likelihood) -> Generic Likelihood
forall x. Rep Likelihood x -> Likelihood
forall x. Likelihood -> Rep Likelihood x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Likelihood -> Rep Likelihood x
from :: forall x. Likelihood -> Rep Likelihood x
$cto :: forall x. Rep Likelihood x -> Likelihood
to :: forall x. Rep Likelihood x -> Likelihood
Generic, Likelihood -> ()
(Likelihood -> ()) -> NFData Likelihood
forall a. (a -> ()) -> NFData a
$crnf :: Likelihood -> ()
rnf :: Likelihood -> ()
NFData, Typeable Likelihood
Typeable Likelihood =>
(Likelihood -> Encoding)
-> ((forall t. EncCBOR t => Proxy t -> Size)
    -> Proxy Likelihood -> Size)
-> ((forall t. EncCBOR t => Proxy t -> Size)
    -> Proxy [Likelihood] -> Size)
-> EncCBOR 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
$cencCBOR :: Likelihood -> Encoding
encCBOR :: Likelihood -> Encoding
$cencodedSizeExpr :: (forall t. EncCBOR t => Proxy t -> Size)
-> Proxy Likelihood -> Size
encodedSizeExpr :: (forall t. EncCBOR t => Proxy t -> Size)
-> Proxy Likelihood -> Size
$cencodedListSizeExpr :: (forall t. EncCBOR t => Proxy t -> Size)
-> Proxy [Likelihood] -> Size
encodedListSizeExpr :: (forall t. EncCBOR t => Proxy t -> Size)
-> Proxy [Likelihood] -> Size
EncCBOR, Typeable Likelihood
Typeable Likelihood =>
(forall s. Decoder s Likelihood)
-> (forall s. Proxy Likelihood -> Decoder s ())
-> (Proxy Likelihood -> Text)
-> DecCBOR 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 ()
$cdecCBOR :: forall s. Decoder s Likelihood
decCBOR :: forall s. Decoder s Likelihood
$cdropCBOR :: forall s. Proxy Likelihood -> Decoder s ()
dropCBOR :: forall s. Proxy Likelihood -> Decoder s ()
$clabel :: Proxy Likelihood -> Text
label :: Proxy Likelihood -> Text
DecCBOR)

instance NoThunks Likelihood

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

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

instance Monoid Likelihood where
  mempty :: Likelihood
mempty = StrictSeq LogWeight -> Likelihood
Likelihood (StrictSeq LogWeight -> Likelihood)
-> StrictSeq LogWeight -> Likelihood
forall a b. (a -> b) -> a -> b
$ Seq LogWeight -> StrictSeq LogWeight
forall a. Seq a -> StrictSeq a
StrictSeq.forceToStrict (Seq LogWeight -> StrictSeq LogWeight)
-> Seq LogWeight -> StrictSeq LogWeight
forall a b. (a -> b) -> a -> b
$ Int -> LogWeight -> Seq LogWeight
forall a. Int -> a -> Seq a
Seq.replicate (StrictSeq Double -> Int
forall a. StrictSeq a -> Int
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 = StrictSeq Double -> Value
forall a. ToJSON a => a -> Value
toJSON (StrictSeq Double -> Value)
-> (Likelihood -> StrictSeq Double) -> Likelihood -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LogWeight -> Double) -> StrictSeq LogWeight -> StrictSeq Double
forall a b. (a -> b) -> StrictSeq a -> StrictSeq b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap LogWeight -> Double
fromLogWeight (StrictSeq LogWeight -> StrictSeq Double)
-> (Likelihood -> StrictSeq LogWeight)
-> Likelihood
-> StrictSeq Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Likelihood -> StrictSeq LogWeight
unLikelihood
  toEncoding :: Likelihood -> Encoding
toEncoding = StrictSeq Double -> Encoding
forall a. ToJSON a => a -> Encoding
toEncoding (StrictSeq Double -> Encoding)
-> (Likelihood -> StrictSeq Double) -> Likelihood -> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LogWeight -> Double) -> StrictSeq LogWeight -> StrictSeq Double
forall a b. (a -> b) -> StrictSeq a -> StrictSeq b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap LogWeight -> Double
fromLogWeight (StrictSeq LogWeight -> StrictSeq Double)
-> (Likelihood -> StrictSeq LogWeight)
-> Likelihood
-> StrictSeq Double
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 (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 a. Ord a => StrictSeq a -> a
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 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
forall r. BoundedRational r => r -> Rational
unboundRational (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
. PositiveUnitInterval -> Rational
forall r. BoundedRational r => r -> Rational
unboundRational (PositiveUnitInterval -> Rational)
-> (ActiveSlotCoeff -> PositiveUnitInterval)
-> ActiveSlotCoeff
-> Rational
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ActiveSlotCoeff -> PositiveUnitInterval
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 = Word64 -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Double) -> Word64 -> Double
forall a b. (a -> b) -> a -> b
$ EpochSize -> Word64
unEpochSize EpochSize
slotsPerEpoch Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Natural -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
blocks
    l :: Double -> Double
    l :: Double -> Double
l Double
x = Double
n Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double -> Double
forall a. Floating a => a -> a
log Double
x Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
m Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double -> Double
forall a. Floating a => a -> a
log (Double
1 Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
t Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
x)
    sample :: Double -> LogWeight
sample Double
position = Float -> LogWeight
LogWeight (Double -> Float
forall a b. (Real a, Fractional b) => a -> b
realToFrac (Double -> Float) -> Double -> Float
forall a b. (a -> b) -> a -> b
$ Double -> Double
l Double
position)

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

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

-- | Normalize the histogram so that the total area is 1
normalize :: Histogram -> Histogram
normalize :: Histogram -> Histogram
normalize (Histogram StrictSeq LogWeight
values) = StrictSeq LogWeight -> Histogram
Histogram (StrictSeq LogWeight -> Histogram)
-> StrictSeq LogWeight -> Histogram
forall a b. (a -> b) -> a -> b
$ (\LogWeight
x -> LogWeight
x LogWeight -> LogWeight -> LogWeight
forall a. Num a => a -> a -> a
- LogWeight
logArea) (LogWeight -> LogWeight)
-> StrictSeq LogWeight -> StrictSeq LogWeight
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictSeq LogWeight
values'
  where
    m :: LogWeight
m = StrictSeq LogWeight -> LogWeight
forall a. Ord a => StrictSeq a -> a
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.fromStrict StrictSeq Double
samplePositions)
        (StrictSeq Double -> Seq Double
forall a. StrictSeq a -> Seq a
StrictSeq.fromStrict ((Double -> Double -> Double)
-> Double -> StrictSeq Double -> StrictSeq Double
forall a b. (a -> b -> a) -> a -> StrictSeq b -> StrictSeq a
StrictSeq.scanl Double -> Double -> Double
forall a. Num a => a -> a -> a
(+) Double
0 (LogWeight -> Double
fromLogWeight (LogWeight -> Double) -> StrictSeq LogWeight -> StrictSeq Double
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictSeq LogWeight
values)))

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

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 = f Double -> Double
forall a. Num a => f a -> a
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 a b. (a -> b) -> f a -> f b
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
$cshowsPrec :: Int -> PerformanceEstimate -> ShowS
showsPrec :: Int -> PerformanceEstimate -> ShowS
$cshow :: PerformanceEstimate -> String
show :: PerformanceEstimate -> String
$cshowList :: [PerformanceEstimate] -> ShowS
showList :: [PerformanceEstimate] -> ShowS
Show, PerformanceEstimate -> PerformanceEstimate -> Bool
(PerformanceEstimate -> PerformanceEstimate -> Bool)
-> (PerformanceEstimate -> PerformanceEstimate -> Bool)
-> Eq PerformanceEstimate
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PerformanceEstimate -> PerformanceEstimate -> Bool
== :: PerformanceEstimate -> PerformanceEstimate -> Bool
$c/= :: PerformanceEstimate -> PerformanceEstimate -> Bool
/= :: 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
$cfrom :: forall x. PerformanceEstimate -> Rep PerformanceEstimate x
from :: forall x. PerformanceEstimate -> Rep PerformanceEstimate x
$cto :: forall x. Rep PerformanceEstimate x -> PerformanceEstimate
to :: forall x. Rep PerformanceEstimate x -> PerformanceEstimate
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
$cnoThunks :: Context -> PerformanceEstimate -> IO (Maybe ThunkInfo)
noThunks :: Context -> PerformanceEstimate -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> PerformanceEstimate -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> PerformanceEstimate -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy PerformanceEstimate -> String
showTypeOf :: Proxy PerformanceEstimate -> String
NoThunks)

instance EncCBOR PerformanceEstimate where
  encCBOR :: PerformanceEstimate -> Encoding
encCBOR = Double -> Encoding
encodeDouble (Double -> Encoding)
-> (PerformanceEstimate -> Double)
-> PerformanceEstimate
-> Encoding
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 (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 = NonMyopic
  { NonMyopic -> Map (KeyHash 'StakePool) Likelihood
likelihoodsNM :: !(Map (KeyHash 'StakePool) Likelihood)
  , NonMyopic -> Coin
rewardPotNM :: !Coin
  }
  deriving (Int -> NonMyopic -> ShowS
[NonMyopic] -> ShowS
NonMyopic -> String
(Int -> NonMyopic -> ShowS)
-> (NonMyopic -> String)
-> ([NonMyopic] -> ShowS)
-> Show NonMyopic
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> NonMyopic -> ShowS
showsPrec :: Int -> NonMyopic -> ShowS
$cshow :: NonMyopic -> String
show :: NonMyopic -> String
$cshowList :: [NonMyopic] -> ShowS
showList :: [NonMyopic] -> ShowS
Show, NonMyopic -> NonMyopic -> Bool
(NonMyopic -> NonMyopic -> Bool)
-> (NonMyopic -> NonMyopic -> Bool) -> Eq NonMyopic
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: NonMyopic -> NonMyopic -> Bool
== :: NonMyopic -> NonMyopic -> Bool
$c/= :: NonMyopic -> NonMyopic -> Bool
/= :: NonMyopic -> NonMyopic -> Bool
Eq, (forall x. NonMyopic -> Rep NonMyopic x)
-> (forall x. Rep NonMyopic x -> NonMyopic) -> Generic NonMyopic
forall x. Rep NonMyopic x -> NonMyopic
forall x. NonMyopic -> Rep NonMyopic x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. NonMyopic -> Rep NonMyopic x
from :: forall x. NonMyopic -> Rep NonMyopic x
$cto :: forall x. Rep NonMyopic x -> NonMyopic
to :: forall x. Rep NonMyopic x -> NonMyopic
Generic)

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

instance NoThunks NonMyopic

instance NFData NonMyopic

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

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

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

toNonMyopicPair :: KeyValue e a => NonMyopic -> [a]
toNonMyopicPair :: forall e a. KeyValue e a => NonMyopic -> [a]
toNonMyopicPair nm :: NonMyopic
nm@(NonMyopic Map (KeyHash 'StakePool) Likelihood
_ Coin
_) =
  let NonMyopic {Map (KeyHash 'StakePool) Likelihood
likelihoodsNM :: NonMyopic -> Map (KeyHash 'StakePool) Likelihood
likelihoodsNM :: Map (KeyHash 'StakePool) Likelihood
likelihoodsNM, Coin
rewardPotNM :: NonMyopic -> Coin
rewardPotNM :: Coin
rewardPotNM} = NonMyopic
nm
   in [ Key
"likelihoodsNM" Key -> Map (KeyHash 'StakePool) Likelihood -> a
forall v. ToJSON v => Key -> v -> a
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Map (KeyHash 'StakePool) Likelihood
likelihoodsNM
      , Key
"rewardPotNM" Key -> Coin -> a
forall v. ToJSON v => Key -> v -> a
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 ->
  NonZero Word16 ->
  Coin ->
  PoolParams ->
  PerformanceEstimate ->
  Coin ->
  Double
desirability :: NonNegativeInterval
-> NonZero Word16
-> Coin
-> PoolParams
-> PerformanceEstimate
-> Coin
-> Double
desirability NonNegativeInterval
a0 NonZero Word16
nOpt Coin
r PoolParams
pool (PerformanceEstimate Double
p) Coin
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
    -- This division is safe, because 1 <= fTildeDenom <= 2
    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
* NonNegativeInterval -> Rational
forall r. BoundedRational r => r -> Rational
unboundRational NonNegativeInterval
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
+ NonNegativeInterval -> Rational
forall r. BoundedRational r => r -> Rational
unboundRational NonNegativeInterval
a0
    cost :: Double
cost = (Rational -> Double
forall a. Fractional a => Rational -> a
fromRational (Rational -> Double)
-> (PoolParams -> Rational) -> PoolParams -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Coin -> Rational
coinToRational (Coin -> Rational)
-> (PoolParams -> Coin) -> PoolParams -> Rational
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PoolParams -> Coin
ppCost) PoolParams
pool
    margin :: Double
margin = (Rational -> Double
forall a. Fractional a => Rational -> a
fromRational (Rational -> Double)
-> (PoolParams -> Rational) -> PoolParams -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnitInterval -> Rational
forall r. BoundedRational r => r -> Rational
unboundRational (UnitInterval -> Rational)
-> (PoolParams -> UnitInterval) -> PoolParams -> Rational
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PoolParams -> UnitInterval
ppMargin) PoolParams
pool
    Coin Integer
pledge = PoolParams -> Coin
ppPledge PoolParams
pool
    s :: Rational
s = Integer -> Integer
forall a. Integral a => a -> Integer
toInteger Integer
pledge Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
% Integer -> Integer -> Integer
forall a. Ord a => a -> a -> a
max Integer
1 (Coin -> Integer
unCoin Coin
totalStake)
    z0 :: Rational
z0 = Integer
1 Integer -> NonZero Integer -> Rational
forall a. Integral a => a -> NonZero a -> Ratio a
%. NonZero Word16 -> NonZero Integer
forall a. Integral a => NonZero a -> NonZero Integer
toIntegerNonZero NonZero Word16
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) PoolParams ->
  Map (KeyHash 'StakePool) PerformanceEstimate ->
  Set (KeyHash 'StakePool)
getTopRankedPools :: forall era.
EraPParams era =>
Coin
-> Coin
-> PParams era
-> Map (KeyHash 'StakePool) PoolParams
-> Map (KeyHash 'StakePool) PerformanceEstimate
-> Set (KeyHash 'StakePool)
getTopRankedPools Coin
rPot Coin
totalStake PParams era
pp Map (KeyHash 'StakePool) PoolParams
poolParams Map (KeyHash 'StakePool) PerformanceEstimate
aps =
  let pdata :: [(KeyHash 'StakePool, (PoolParams, PerformanceEstimate))]
pdata = Map (KeyHash 'StakePool) (PoolParams, PerformanceEstimate)
-> [(KeyHash 'StakePool, (PoolParams, PerformanceEstimate))]
forall k a. Map k a -> [(k, a)]
Map.toAscList (Map (KeyHash 'StakePool) (PoolParams, PerformanceEstimate)
 -> [(KeyHash 'StakePool, (PoolParams, PerformanceEstimate))])
-> Map (KeyHash 'StakePool) (PoolParams, PerformanceEstimate)
-> [(KeyHash 'StakePool, (PoolParams, PerformanceEstimate))]
forall a b. (a -> b) -> a -> b
$ (PoolParams
 -> PerformanceEstimate -> (PoolParams, PerformanceEstimate))
-> Map (KeyHash 'StakePool) PoolParams
-> Map (KeyHash 'StakePool) PerformanceEstimate
-> Map (KeyHash 'StakePool) (PoolParams, 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) PoolParams
poolParams Map (KeyHash 'StakePool) PerformanceEstimate
aps
   in Coin
-> Coin
-> PParams era
-> [(KeyHash 'StakePool, (PoolParams, PerformanceEstimate))]
-> Set (KeyHash 'StakePool)
forall era.
EraPParams era =>
Coin
-> Coin
-> PParams era
-> [(KeyHash 'StakePool, (PoolParams, PerformanceEstimate))]
-> Set (KeyHash 'StakePool)
getTopRankedPoolsInternal Coin
rPot Coin
totalStake PParams era
pp [(KeyHash 'StakePool, (PoolParams, PerformanceEstimate))]
pdata

getTopRankedPoolsVMap ::
  EraPParams era =>
  Coin ->
  Coin ->
  PParams era ->
  VMap.VMap VMap.VB VMap.VB (KeyHash 'StakePool) PoolParams ->
  Map (KeyHash 'StakePool) PerformanceEstimate ->
  Set (KeyHash 'StakePool)
getTopRankedPoolsVMap :: forall era.
EraPParams era =>
Coin
-> Coin
-> PParams era
-> VMap VB VB (KeyHash 'StakePool) PoolParams
-> Map (KeyHash 'StakePool) PerformanceEstimate
-> Set (KeyHash 'StakePool)
getTopRankedPoolsVMap Coin
rPot Coin
totalStake PParams era
pp VMap VB VB (KeyHash 'StakePool) PoolParams
poolParams Map (KeyHash 'StakePool) PerformanceEstimate
aps =
  let pdata :: [(KeyHash 'StakePool, (PoolParams, PerformanceEstimate))]
pdata = [(KeyHash 'StakePool
kh, (PoolParams
pps, PerformanceEstimate
a)) | (KeyHash 'StakePool
kh, PerformanceEstimate
a) <- Map (KeyHash 'StakePool) PerformanceEstimate
-> [(KeyHash 'StakePool, PerformanceEstimate)]
forall k a. Map k a -> [(k, a)]
Map.toAscList Map (KeyHash 'StakePool) PerformanceEstimate
aps, Just PoolParams
pps <- [KeyHash 'StakePool
-> VMap VB VB (KeyHash 'StakePool) PoolParams -> Maybe PoolParams
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
kh VMap VB VB (KeyHash 'StakePool) PoolParams
poolParams]]
   in Coin
-> Coin
-> PParams era
-> [(KeyHash 'StakePool, (PoolParams, PerformanceEstimate))]
-> Set (KeyHash 'StakePool)
forall era.
EraPParams era =>
Coin
-> Coin
-> PParams era
-> [(KeyHash 'StakePool, (PoolParams, PerformanceEstimate))]
-> Set (KeyHash 'StakePool)
getTopRankedPoolsInternal Coin
rPot Coin
totalStake PParams era
pp [(KeyHash 'StakePool, (PoolParams, PerformanceEstimate))]
pdata

getTopRankedPoolsInternal ::
  EraPParams era =>
  Coin ->
  Coin ->
  PParams era ->
  [(KeyHash 'StakePool, (PoolParams, PerformanceEstimate))] ->
  Set (KeyHash 'StakePool)
getTopRankedPoolsInternal :: forall era.
EraPParams era =>
Coin
-> Coin
-> PParams era
-> [(KeyHash 'StakePool, (PoolParams, PerformanceEstimate))]
-> Set (KeyHash 'StakePool)
getTopRankedPoolsInternal Coin
rPot Coin
totalStake PParams era
pp [(KeyHash 'StakePool, (PoolParams, PerformanceEstimate))]
pdata =
  [KeyHash 'StakePool] -> Set (KeyHash 'StakePool)
forall a. Ord a => [a] -> Set a
Set.fromList ([KeyHash 'StakePool] -> Set (KeyHash 'StakePool))
-> [KeyHash 'StakePool] -> Set (KeyHash 'StakePool)
forall a b. (a -> b) -> a -> b
$
    (KeyHash 'StakePool, Double) -> KeyHash 'StakePool
forall a b. (a, b) -> a
fst
      ((KeyHash 'StakePool, Double) -> KeyHash 'StakePool)
-> [(KeyHash 'StakePool, Double)] -> [KeyHash 'StakePool]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int
-> [(KeyHash 'StakePool, Double)] -> [(KeyHash 'StakePool, Double)]
forall a. Int -> [a] -> [a]
take (Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16 -> Int) -> Word16 -> Int
forall a b. (a -> b) -> a -> b
$ PParams era
pp PParams era -> Getting Word16 (PParams era) Word16 -> Word16
forall s a. s -> Getting a s a -> a
^. Getting Word16 (PParams era) Word16
forall era. EraPParams era => Lens' (PParams era) Word16
Lens' (PParams era) Word16
ppNOptL) (((KeyHash 'StakePool, Double)
 -> (KeyHash 'StakePool, Double) -> Ordering)
-> [(KeyHash 'StakePool, Double)] -> [(KeyHash 'StakePool, 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, Double) -> Double)
-> (KeyHash 'StakePool, Double)
-> (KeyHash 'StakePool, Double)
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (KeyHash 'StakePool, Double) -> Double
forall a b. (a, b) -> b
snd) [(KeyHash 'StakePool, Double)]
rankings)
  where
    rankings :: [(KeyHash 'StakePool, Double)]
rankings =
      [ ( KeyHash 'StakePool
hk
        , NonNegativeInterval
-> NonZero Word16
-> Coin
-> PoolParams
-> PerformanceEstimate
-> Coin
-> Double
desirability
            (PParams era
pp PParams era
-> Getting NonNegativeInterval (PParams era) NonNegativeInterval
-> NonNegativeInterval
forall s a. s -> Getting a s a -> a
^. Getting NonNegativeInterval (PParams era) NonNegativeInterval
forall era.
EraPParams era =>
Lens' (PParams era) NonNegativeInterval
Lens' (PParams era) NonNegativeInterval
ppA0L)
            ((PParams era
pp PParams era -> Getting Word16 (PParams era) Word16 -> Word16
forall s a. s -> Getting a s a -> a
^. Getting Word16 (PParams era) Word16
forall era. EraPParams era => Lens' (PParams era) Word16
Lens' (PParams era) Word16
ppNOptL) Word16 -> NonZero Word16 -> NonZero Word16
forall a. HasZero a => a -> NonZero a -> NonZero a
`nonZeroOr` forall (n :: Natural) a.
(KnownNat n, 1 <= n, WithinBounds n a, Num a) =>
NonZero a
knownNonZeroBounded @1)
            Coin
rPot
            PoolParams
pool
            PerformanceEstimate
ap
            Coin
totalStake
        )
      | (KeyHash 'StakePool
hk, (PoolParams
pool, PerformanceEstimate
ap)) <- [(KeyHash 'StakePool, (PoolParams, 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 ->
  Set (KeyHash 'StakePool) ->
  StakeShare
nonMyopicStake :: forall era.
EraPParams era =>
PParams era
-> StakeShare
-> StakeShare
-> StakeShare
-> KeyHash 'StakePool
-> Set (KeyHash 'StakePool)
-> StakeShare
nonMyopicStake PParams era
pp (StakeShare Rational
s) (StakeShare Rational
sigma) (StakeShare Rational
t) KeyHash 'StakePool
kh Set (KeyHash 'StakePool)
topPools =
  let z0 :: Rational
z0 = Integer
1 Integer -> NonZero Integer -> Rational
forall a. Integral a => a -> NonZero a -> Ratio a
%. (Word16 -> Integer
forall a. Integral a => a -> Integer
toInteger (PParams era
pp PParams era -> Getting Word16 (PParams era) Word16 -> Word16
forall s a. s -> Getting a s a -> a
^. Getting Word16 (PParams era) Word16
forall era. EraPParams era => Lens' (PParams era) Word16
Lens' (PParams era) Word16
ppNOptL) Integer -> NonZero Integer -> NonZero Integer
forall a. HasZero a => a -> NonZero a -> NonZero a
`nonZeroOr` forall (n :: Natural). (KnownNat n, 1 <= n) => NonZero Integer
knownNonZero @1)
   in if KeyHash 'StakePool
kh KeyHash 'StakePool -> Set (KeyHash 'StakePool) -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set (KeyHash 'StakePool)
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 ::
  EraPParams era =>
  PParams era ->
  Coin ->
  PoolParams ->
  StakeShare ->
  StakeShare ->
  StakeShare ->
  Set (KeyHash 'StakePool) ->
  PerformanceEstimate ->
  Coin
nonMyopicMemberRew :: forall era.
EraPParams era =>
PParams era
-> Coin
-> PoolParams
-> StakeShare
-> StakeShare
-> StakeShare
-> Set (KeyHash 'StakePool)
-> PerformanceEstimate
-> Coin
nonMyopicMemberRew
  PParams era
pp
  Coin
rPot
  PoolParams
pool
  StakeShare
s
  StakeShare
sigma
  StakeShare
t
  Set (KeyHash 'StakePool)
topPools
  (PerformanceEstimate Double
p) =
    let nm :: StakeShare
nm = PParams era
-> StakeShare
-> StakeShare
-> StakeShare
-> KeyHash 'StakePool
-> Set (KeyHash 'StakePool)
-> StakeShare
forall era.
EraPParams era =>
PParams era
-> StakeShare
-> StakeShare
-> StakeShare
-> KeyHash 'StakePool
-> Set (KeyHash 'StakePool)
-> StakeShare
nonMyopicStake PParams era
pp StakeShare
s StakeShare
sigma StakeShare
t (PoolParams -> KeyHash 'StakePool
ppId PoolParams
pool) Set (KeyHash 'StakePool)
topPools
        f :: Coin
f = PParams era -> Coin -> Rational -> Rational -> Coin
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 = Double -> Integer
forall b. Integral b => Double -> b
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 -> StakeShare -> StakeShare -> Coin
memberRew (Integer -> Coin
Coin Integer
fHat) PoolParams
pool StakeShare
t StakeShare
nm