{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} module Shelley.Spec.Ledger.Rewards ( desirability, PerformanceEstimate (..), NonMyopic (..), emptyNonMyopic, getTopRankedPools, StakeShare (..), mkApparentPerformance, reward, nonMyopicStake, nonMyopicMemberRew, percentile', Histogram (..), LogWeight (..), likelihood, applyDecay, Likelihood (..), leaderProbability, ) where import Cardano.Binary ( FromCBOR (..), ToCBOR (..), decodeDouble, encodeDouble, encodeListLen, ) import Cardano.Ledger.Era (Crypto, Era) import Cardano.Ledger.Val ((<->)) import Cardano.Slotting.Slot (EpochSize) import Control.DeepSeq (NFData) import Control.Iterate.SetAlgebra (eval, (◁)) import Data.Foldable (find, fold) import Data.Function (on) import Data.List (sortBy) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Maybe (catMaybes, fromMaybe) import Data.Ratio ((%)) import qualified Data.Sequence as Seq import Data.Sequence.Strict (StrictSeq) import qualified Data.Sequence.Strict as StrictSeq import Data.Set (Set) import qualified Data.Set as Set import GHC.Generics (Generic) import NoThunks.Class (NoThunks (..)) import Numeric.Natural (Natural) import Quiet import Shelley.Spec.Ledger.BaseTypes ( ActiveSlotCoeff, UnitInterval, activeSlotVal, unitIntervalToRational, ) import Shelley.Spec.Ledger.Coin ( Coin (..), coinToRational, rationalToCoinViaFloor, ) import Shelley.Spec.Ledger.Credential (Credential (..)) import Shelley.Spec.Ledger.Delegation.PoolParams (poolSpec) import Shelley.Spec.Ledger.EpochBoundary ( BlocksMade (..), Stake (..), maxPool, poolStake, ) import Shelley.Spec.Ledger.Keys (KeyHash, KeyRole (..)) import Shelley.Spec.Ledger.PParams (PParams, _a0, _d, _nOpt) import Shelley.Spec.Ledger.Serialization ( decodeRecordNamed, decodeSeq, encodeFoldable, ) import Shelley.Spec.Ledger.TxBody (PoolParams (..), getRwdCred) newtype LogWeight = LogWeight {LogWeight -> Float unLogWeight :: Float} deriving (LogWeight -> LogWeight -> Bool (LogWeight -> LogWeight -> Bool) -> (LogWeight -> LogWeight -> Bool) -> Eq LogWeight forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a /= :: LogWeight -> LogWeight -> Bool $c/= :: LogWeight -> LogWeight -> Bool == :: LogWeight -> LogWeight -> Bool $c== :: LogWeight -> LogWeight -> Bool Eq, (forall x. LogWeight -> Rep LogWeight x) -> (forall x. Rep LogWeight x -> LogWeight) -> Generic LogWeight forall x. Rep LogWeight x -> LogWeight forall x. LogWeight -> Rep LogWeight x forall a. (forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a $cto :: forall x. Rep LogWeight x -> LogWeight $cfrom :: forall x. LogWeight -> Rep LogWeight x Generic, Eq LogWeight Eq LogWeight -> (LogWeight -> LogWeight -> Ordering) -> (LogWeight -> LogWeight -> Bool) -> (LogWeight -> LogWeight -> Bool) -> (LogWeight -> LogWeight -> Bool) -> (LogWeight -> LogWeight -> Bool) -> (LogWeight -> LogWeight -> LogWeight) -> (LogWeight -> LogWeight -> LogWeight) -> Ord LogWeight LogWeight -> LogWeight -> Bool LogWeight -> LogWeight -> Ordering LogWeight -> LogWeight -> LogWeight forall a. Eq a -> (a -> a -> Ordering) -> (a -> a -> Bool) -> (a -> a -> Bool) -> (a -> a -> Bool) -> (a -> a -> Bool) -> (a -> a -> a) -> (a -> a -> a) -> Ord a min :: LogWeight -> LogWeight -> LogWeight $cmin :: LogWeight -> LogWeight -> LogWeight max :: LogWeight -> LogWeight -> LogWeight $cmax :: LogWeight -> LogWeight -> LogWeight >= :: LogWeight -> LogWeight -> Bool $c>= :: LogWeight -> LogWeight -> Bool > :: LogWeight -> LogWeight -> Bool $c> :: LogWeight -> LogWeight -> Bool <= :: LogWeight -> LogWeight -> Bool $c<= :: LogWeight -> LogWeight -> Bool < :: LogWeight -> LogWeight -> Bool $c< :: LogWeight -> LogWeight -> Bool compare :: LogWeight -> LogWeight -> Ordering $ccompare :: LogWeight -> LogWeight -> Ordering $cp1Ord :: Eq LogWeight Ord, Integer -> LogWeight LogWeight -> LogWeight LogWeight -> LogWeight -> LogWeight (LogWeight -> LogWeight -> LogWeight) -> (LogWeight -> LogWeight -> LogWeight) -> (LogWeight -> LogWeight -> LogWeight) -> (LogWeight -> LogWeight) -> (LogWeight -> LogWeight) -> (LogWeight -> LogWeight) -> (Integer -> LogWeight) -> Num LogWeight forall a. (a -> a -> a) -> (a -> a -> a) -> (a -> a -> a) -> (a -> a) -> (a -> a) -> (a -> a) -> (Integer -> a) -> Num a fromInteger :: Integer -> LogWeight $cfromInteger :: Integer -> LogWeight signum :: LogWeight -> LogWeight $csignum :: LogWeight -> LogWeight abs :: LogWeight -> LogWeight $cabs :: LogWeight -> LogWeight negate :: LogWeight -> LogWeight $cnegate :: LogWeight -> LogWeight * :: LogWeight -> LogWeight -> LogWeight $c* :: LogWeight -> LogWeight -> LogWeight - :: LogWeight -> LogWeight -> LogWeight $c- :: LogWeight -> LogWeight -> LogWeight + :: LogWeight -> LogWeight -> LogWeight $c+ :: LogWeight -> LogWeight -> LogWeight Num, LogWeight -> () (LogWeight -> ()) -> NFData LogWeight forall a. (a -> ()) -> NFData a rnf :: LogWeight -> () $crnf :: LogWeight -> () NFData, Context -> LogWeight -> IO (Maybe ThunkInfo) Proxy LogWeight -> String (Context -> LogWeight -> IO (Maybe ThunkInfo)) -> (Context -> LogWeight -> IO (Maybe ThunkInfo)) -> (Proxy LogWeight -> String) -> NoThunks LogWeight forall a. (Context -> a -> IO (Maybe ThunkInfo)) -> (Context -> a -> IO (Maybe ThunkInfo)) -> (Proxy a -> String) -> NoThunks a showTypeOf :: Proxy LogWeight -> String $cshowTypeOf :: Proxy LogWeight -> String wNoThunks :: Context -> LogWeight -> IO (Maybe ThunkInfo) $cwNoThunks :: Context -> LogWeight -> IO (Maybe ThunkInfo) noThunks :: Context -> LogWeight -> IO (Maybe ThunkInfo) $cnoThunks :: Context -> LogWeight -> IO (Maybe ThunkInfo) NoThunks, Typeable LogWeight Typeable LogWeight -> (LogWeight -> Encoding) -> ((forall t. ToCBOR t => Proxy t -> Size) -> Proxy LogWeight -> Size) -> ((forall t. ToCBOR t => Proxy t -> Size) -> Proxy [LogWeight] -> Size) -> ToCBOR LogWeight LogWeight -> Encoding (forall t. ToCBOR t => Proxy t -> Size) -> Proxy [LogWeight] -> Size (forall t. ToCBOR t => Proxy t -> Size) -> Proxy LogWeight -> Size forall a. Typeable a -> (a -> Encoding) -> ((forall t. ToCBOR t => Proxy t -> Size) -> Proxy a -> Size) -> ((forall t. ToCBOR t => Proxy t -> Size) -> Proxy [a] -> Size) -> ToCBOR a encodedListSizeExpr :: (forall t. ToCBOR t => Proxy t -> Size) -> Proxy [LogWeight] -> Size $cencodedListSizeExpr :: (forall t. ToCBOR t => Proxy t -> Size) -> Proxy [LogWeight] -> Size encodedSizeExpr :: (forall t. ToCBOR t => Proxy t -> Size) -> Proxy LogWeight -> Size $cencodedSizeExpr :: (forall t. ToCBOR t => Proxy t -> Size) -> Proxy LogWeight -> Size toCBOR :: LogWeight -> Encoding $ctoCBOR :: LogWeight -> Encoding $cp1ToCBOR :: Typeable LogWeight ToCBOR, Typeable LogWeight Decoder s LogWeight Typeable LogWeight -> (forall s. Decoder s LogWeight) -> (Proxy LogWeight -> Text) -> FromCBOR LogWeight Proxy LogWeight -> Text forall s. Decoder s LogWeight forall a. Typeable a -> (forall s. Decoder s a) -> (Proxy a -> Text) -> FromCBOR a label :: Proxy LogWeight -> Text $clabel :: Proxy LogWeight -> Text fromCBOR :: Decoder s LogWeight $cfromCBOR :: forall s. Decoder s LogWeight $cp1FromCBOR :: Typeable LogWeight FromCBOR) deriving (Int -> LogWeight -> ShowS [LogWeight] -> ShowS LogWeight -> String (Int -> LogWeight -> ShowS) -> (LogWeight -> String) -> ([LogWeight] -> ShowS) -> Show LogWeight forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [LogWeight] -> ShowS $cshowList :: [LogWeight] -> ShowS show :: LogWeight -> String $cshow :: LogWeight -> String showsPrec :: Int -> LogWeight -> ShowS $cshowsPrec :: Int -> LogWeight -> ShowS Show) via Quiet LogWeight toLogWeight :: Double -> LogWeight toLogWeight :: Double -> LogWeight toLogWeight Double d = Float -> LogWeight LogWeight (Double -> Float forall a b. (Real a, Fractional b) => a -> b realToFrac (Double -> Float) -> Double -> Float forall a b. (a -> b) -> a -> b $ Double -> Double forall a. Floating a => a -> a log Double d) fromLogWeight :: LogWeight -> Double fromLogWeight :: LogWeight -> Double fromLogWeight (LogWeight Float l) = Double -> Double forall a. Floating a => a -> a exp (Float -> Double forall a b. (Real a, Fractional b) => a -> b realToFrac Float l) newtype Histogram = Histogram {Histogram -> StrictSeq LogWeight unHistogram :: StrictSeq LogWeight} deriving (Histogram -> Histogram -> Bool (Histogram -> Histogram -> Bool) -> (Histogram -> Histogram -> Bool) -> Eq Histogram forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a /= :: Histogram -> Histogram -> Bool $c/= :: Histogram -> Histogram -> Bool == :: Histogram -> Histogram -> Bool $c== :: Histogram -> Histogram -> Bool Eq, Int -> Histogram -> ShowS [Histogram] -> ShowS Histogram -> String (Int -> Histogram -> ShowS) -> (Histogram -> String) -> ([Histogram] -> ShowS) -> Show Histogram forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [Histogram] -> ShowS $cshowList :: [Histogram] -> ShowS show :: Histogram -> String $cshow :: Histogram -> String showsPrec :: Int -> Histogram -> ShowS $cshowsPrec :: Int -> Histogram -> ShowS Show, (forall x. Histogram -> Rep Histogram x) -> (forall x. Rep Histogram x -> Histogram) -> Generic Histogram forall x. Rep Histogram x -> Histogram forall x. Histogram -> Rep Histogram x forall a. (forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a $cto :: forall x. Rep Histogram x -> Histogram $cfrom :: forall x. Histogram -> Rep Histogram x Generic) newtype Likelihood = Likelihood {Likelihood -> StrictSeq LogWeight unLikelihood :: StrictSeq LogWeight} -- TODO: replace with small data structure deriving (Int -> Likelihood -> ShowS [Likelihood] -> ShowS Likelihood -> String (Int -> Likelihood -> ShowS) -> (Likelihood -> String) -> ([Likelihood] -> ShowS) -> Show Likelihood forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [Likelihood] -> ShowS $cshowList :: [Likelihood] -> ShowS show :: Likelihood -> String $cshow :: Likelihood -> String showsPrec :: Int -> Likelihood -> ShowS $cshowsPrec :: Int -> Likelihood -> ShowS Show, (forall x. Likelihood -> Rep Likelihood x) -> (forall x. Rep Likelihood x -> Likelihood) -> Generic Likelihood forall x. Rep Likelihood x -> Likelihood forall x. Likelihood -> Rep Likelihood x forall a. (forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a $cto :: forall x. Rep Likelihood x -> Likelihood $cfrom :: forall x. Likelihood -> Rep Likelihood x Generic, Likelihood -> () (Likelihood -> ()) -> NFData Likelihood forall a. (a -> ()) -> NFData a rnf :: Likelihood -> () $crnf :: Likelihood -> () NFData) instance NoThunks Likelihood instance Eq Likelihood where == :: Likelihood -> Likelihood -> Bool (==) = StrictSeq LogWeight -> StrictSeq LogWeight -> Bool forall a. Eq a => a -> a -> Bool (==) (StrictSeq LogWeight -> StrictSeq LogWeight -> Bool) -> (Likelihood -> StrictSeq LogWeight) -> Likelihood -> Likelihood -> Bool forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c `on` Likelihood -> StrictSeq LogWeight unLikelihood (Likelihood -> StrictSeq LogWeight) -> (Likelihood -> Likelihood) -> Likelihood -> StrictSeq LogWeight forall b c a. (b -> c) -> (a -> b) -> a -> c . Likelihood -> Likelihood normalizeLikelihood instance Semigroup Likelihood where (Likelihood StrictSeq LogWeight x) <> :: Likelihood -> Likelihood -> Likelihood <> (Likelihood StrictSeq LogWeight y) = Likelihood -> Likelihood normalizeLikelihood (Likelihood -> Likelihood) -> Likelihood -> Likelihood forall a b. (a -> b) -> a -> b $ StrictSeq LogWeight -> Likelihood Likelihood ((LogWeight -> LogWeight -> LogWeight) -> StrictSeq LogWeight -> StrictSeq LogWeight -> StrictSeq LogWeight forall a b c. (a -> b -> c) -> StrictSeq a -> StrictSeq b -> StrictSeq c strictSeqZipWith LogWeight -> LogWeight -> LogWeight forall a. Num a => a -> a -> a (+) StrictSeq LogWeight x StrictSeq LogWeight y) instance Monoid Likelihood where mempty :: Likelihood mempty = StrictSeq LogWeight -> Likelihood Likelihood (StrictSeq LogWeight -> Likelihood) -> StrictSeq LogWeight -> Likelihood forall a b. (a -> b) -> a -> b $ Seq LogWeight -> StrictSeq LogWeight forall a. Seq a -> StrictSeq a StrictSeq.toStrict (Seq LogWeight -> StrictSeq LogWeight) -> Seq LogWeight -> StrictSeq LogWeight forall a b. (a -> b) -> a -> b $ Int -> LogWeight -> Seq LogWeight forall a. Int -> a -> Seq a Seq.replicate (StrictSeq Double -> Int forall (t :: * -> *) a. Foldable t => t a -> Int length StrictSeq Double samplePositions) (Float -> LogWeight LogWeight Float 0) -- TODO should be defined in @Data.Sequence.Strict@ strictSeqZipWith :: (a -> b -> c) -> StrictSeq a -> StrictSeq b -> StrictSeq c strictSeqZipWith :: (a -> b -> c) -> StrictSeq a -> StrictSeq b -> StrictSeq c strictSeqZipWith a -> b -> c f StrictSeq a x StrictSeq b y = Seq c -> StrictSeq c forall a. Seq a -> StrictSeq a StrictSeq.toStrict ((a -> b -> c) -> Seq a -> Seq b -> Seq c forall a b c. (a -> b -> c) -> Seq a -> Seq b -> Seq c Seq.zipWith a -> b -> c f (StrictSeq a -> Seq a forall a. StrictSeq a -> Seq a StrictSeq.getSeq StrictSeq a x) (StrictSeq b -> Seq b forall a. StrictSeq a -> Seq a StrictSeq.getSeq StrictSeq b y)) normalizeLikelihood :: Likelihood -> Likelihood normalizeLikelihood :: Likelihood -> Likelihood normalizeLikelihood (Likelihood StrictSeq LogWeight xs) = StrictSeq LogWeight -> Likelihood Likelihood (StrictSeq LogWeight -> Likelihood) -> StrictSeq LogWeight -> Likelihood forall a b. (a -> b) -> a -> b $ (\LogWeight x -> LogWeight x LogWeight -> LogWeight -> LogWeight forall a. Num a => a -> a -> a - LogWeight m) (LogWeight -> LogWeight) -> StrictSeq LogWeight -> StrictSeq LogWeight forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> StrictSeq LogWeight xs where m :: LogWeight m = StrictSeq LogWeight -> LogWeight forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a minimum StrictSeq LogWeight xs instance ToCBOR Likelihood where toCBOR :: Likelihood -> Encoding toCBOR (Likelihood StrictSeq LogWeight logweights) = StrictSeq LogWeight -> Encoding forall a (f :: * -> *). (ToCBOR a, Foldable f) => f a -> Encoding encodeFoldable StrictSeq LogWeight logweights instance FromCBOR Likelihood where fromCBOR :: Decoder s Likelihood fromCBOR = StrictSeq LogWeight -> Likelihood Likelihood (StrictSeq LogWeight -> Likelihood) -> (Seq LogWeight -> StrictSeq LogWeight) -> Seq LogWeight -> Likelihood forall b c a. (b -> c) -> (a -> b) -> a -> c . Seq LogWeight -> StrictSeq LogWeight forall a. Seq a -> StrictSeq a StrictSeq.toStrict (Seq LogWeight -> Likelihood) -> Decoder s (Seq LogWeight) -> Decoder s Likelihood forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Decoder s LogWeight -> Decoder s (Seq LogWeight) forall s a. Decoder s a -> Decoder s (Seq a) decodeSeq Decoder s LogWeight forall a s. FromCBOR a => Decoder s a fromCBOR leaderProbability :: ActiveSlotCoeff -> Rational -> UnitInterval -> Double leaderProbability :: ActiveSlotCoeff -> Rational -> UnitInterval -> Double leaderProbability ActiveSlotCoeff activeSlotCoeff Rational relativeStake UnitInterval decentralizationParameter = (Double 1 Double -> Double -> Double forall a. Num a => a -> a -> a - (Double 1 Double -> Double -> Double forall a. Num a => a -> a -> a - Double asc) Double -> Double -> Double forall a. Floating a => a -> a -> a ** Double s) Double -> Double -> Double forall a. Num a => a -> a -> a * (Double 1 Double -> Double -> Double forall a. Num a => a -> a -> a - Double d') where d' :: Double d' = Rational -> Double forall a b. (Real a, Fractional b) => a -> b realToFrac (Rational -> Double) -> (UnitInterval -> Rational) -> UnitInterval -> Double forall b c a. (b -> c) -> (a -> b) -> a -> c . UnitInterval -> Rational unitIntervalToRational (UnitInterval -> Double) -> UnitInterval -> Double forall a b. (a -> b) -> a -> b $ UnitInterval decentralizationParameter asc :: Double asc = Rational -> Double forall a b. (Real a, Fractional b) => a -> b realToFrac (Rational -> Double) -> (ActiveSlotCoeff -> Rational) -> ActiveSlotCoeff -> Double forall b c a. (b -> c) -> (a -> b) -> a -> c . UnitInterval -> Rational unitIntervalToRational (UnitInterval -> Rational) -> (ActiveSlotCoeff -> UnitInterval) -> ActiveSlotCoeff -> Rational forall b c a. (b -> c) -> (a -> b) -> a -> c . ActiveSlotCoeff -> UnitInterval activeSlotVal (ActiveSlotCoeff -> Double) -> ActiveSlotCoeff -> Double forall a b. (a -> b) -> a -> b $ ActiveSlotCoeff activeSlotCoeff s :: Double s = Rational -> Double forall a b. (Real a, Fractional b) => a -> b realToFrac Rational relativeStake samplePositions :: StrictSeq Double samplePositions :: StrictSeq Double samplePositions = (\Double x -> (Double x Double -> Double -> Double forall a. Num a => a -> a -> a + Double 0.5) Double -> Double -> Double forall a. Fractional a => a -> a -> a / Double 100.0) (Double -> Double) -> StrictSeq Double -> StrictSeq Double forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> [Double] -> StrictSeq Double forall a. [a] -> StrictSeq a StrictSeq.fromList [Double 0.0 .. Double 99.0] likelihood :: Natural -> -- number of blocks produced this epoch Double -> -- chance we're allowed to produce a block in this slot EpochSize -> Likelihood likelihood :: Natural -> Double -> EpochSize -> Likelihood likelihood Natural blocks Double t EpochSize slotsPerEpoch = StrictSeq LogWeight -> Likelihood Likelihood (StrictSeq LogWeight -> Likelihood) -> StrictSeq LogWeight -> Likelihood forall a b. (a -> b) -> a -> b $ Double -> LogWeight sample (Double -> LogWeight) -> StrictSeq Double -> StrictSeq LogWeight forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> StrictSeq Double samplePositions where -- The likelihood function L(x) is the probability of observing the data we got -- under the assumption that the underlying pool performance is equal to x. -- L(x) = C(n,m) * (tx)^n * (1-tx)^m -- where -- t is the chance we're allowed to produce a block -- n is the number of slots in which a block was produced -- m is the number of slots in which a block was not produced -- (slots per epoch minus n) -- C(n,m) is a coefficient that will be irrelevant -- Since the likelihood function only matters up to a scalar multiple, we will -- will divide out C(n,m) t^n and use the following instead: -- L(x) = x^n * (1-tx)^m -- We represent this function using 100 sample points, but to avoid very -- large exponents, we store the log of the value instead of the value itself. -- log(L(x)) = log [ x^n * (1-tx)^m ] -- = n * log(x) + m * log(1 - tx) -- TODO: worry more about loss of floating point precision -- -- example: -- a pool has relative stake of 1 / 1,000,000 (~ 30k ada of 35b ada) -- f = active slot coefficient = 1/20 -- t = 1 - (1-f)^(1/1,000,000) n :: Double n = Natural -> Double forall a b. (Integral a, Num b) => a -> b fromIntegral Natural blocks m :: Double m = EpochSize -> Double forall a b. (Integral a, Num b) => a -> b fromIntegral (EpochSize -> Double) -> EpochSize -> Double forall a b. (a -> b) -> a -> b $ EpochSize slotsPerEpoch EpochSize -> EpochSize -> EpochSize forall a. Num a => a -> a -> a - Natural -> EpochSize forall a b. (Integral a, Num b) => a -> b fromIntegral Natural blocks l :: Double -> Double l :: Double -> Double l Double x = Double n Double -> Double -> Double forall a. Num a => a -> a -> a * Double -> Double forall a. Floating a => a -> a log Double x Double -> Double -> Double forall a. Num a => a -> a -> a + Double m Double -> Double -> Double forall a. Num a => a -> a -> a * Double -> Double forall a. Floating a => a -> a log (Double 1 Double -> Double -> Double forall a. Num a => a -> a -> a - Double t Double -> Double -> Double forall a. Num a => a -> a -> a * Double x) sample :: Double -> LogWeight sample Double position = Float -> LogWeight LogWeight (Double -> Float forall a b. (Real a, Fractional b) => a -> b realToFrac (Double -> Float) -> Double -> Float forall a b. (a -> b) -> a -> b $ Double -> Double l Double position) -- | Decay previous likelihood applyDecay :: Float -> Likelihood -> Likelihood applyDecay :: Float -> Likelihood -> Likelihood applyDecay Float decay (Likelihood StrictSeq LogWeight logWeights) = StrictSeq LogWeight -> Likelihood Likelihood (StrictSeq LogWeight -> Likelihood) -> StrictSeq LogWeight -> Likelihood forall a b. (a -> b) -> a -> b $ Float -> LogWeight -> LogWeight mul Float decay (LogWeight -> LogWeight) -> StrictSeq LogWeight -> StrictSeq LogWeight forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> StrictSeq LogWeight logWeights where mul :: Float -> LogWeight -> LogWeight mul Float x (LogWeight Float f) = Float -> LogWeight LogWeight (Float x Float -> Float -> Float forall a. Num a => a -> a -> a * Float f) posteriorDistribution :: Histogram -> Likelihood -> Histogram posteriorDistribution :: Histogram -> Likelihood -> Histogram posteriorDistribution (Histogram StrictSeq LogWeight points) (Likelihood StrictSeq LogWeight likelihoods) = Histogram -> Histogram normalize (Histogram -> Histogram) -> Histogram -> Histogram forall a b. (a -> b) -> a -> b $ StrictSeq LogWeight -> Histogram Histogram (StrictSeq LogWeight -> Histogram) -> StrictSeq LogWeight -> Histogram forall a b. (a -> b) -> a -> b $ (LogWeight -> LogWeight -> LogWeight) -> StrictSeq LogWeight -> StrictSeq LogWeight -> StrictSeq LogWeight forall a b c. (a -> b -> c) -> StrictSeq a -> StrictSeq b -> StrictSeq c strictSeqZipWith LogWeight -> LogWeight -> LogWeight forall a. Num a => a -> a -> a (+) StrictSeq LogWeight points StrictSeq LogWeight likelihoods -- | Normalize the histogram so that the total area is 1 normalize :: Histogram -> Histogram normalize :: Histogram -> Histogram normalize (Histogram StrictSeq LogWeight values) = StrictSeq LogWeight -> Histogram Histogram (StrictSeq LogWeight -> Histogram) -> StrictSeq LogWeight -> Histogram forall a b. (a -> b) -> a -> b $ (\LogWeight x -> LogWeight x LogWeight -> LogWeight -> LogWeight forall a. Num a => a -> a -> a - LogWeight logArea) (LogWeight -> LogWeight) -> StrictSeq LogWeight -> StrictSeq LogWeight forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> StrictSeq LogWeight values' where m :: LogWeight m = StrictSeq LogWeight -> LogWeight forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a maximum StrictSeq LogWeight values values' :: StrictSeq LogWeight values' = (\LogWeight x -> LogWeight x LogWeight -> LogWeight -> LogWeight forall a. Num a => a -> a -> a - LogWeight m) (LogWeight -> LogWeight) -> StrictSeq LogWeight -> StrictSeq LogWeight forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> StrictSeq LogWeight values logArea :: LogWeight logArea = Double -> LogWeight toLogWeight Double area area :: Double area = Double -> StrictSeq Double -> Double forall (f :: * -> *). (Functor f, Foldable f) => Double -> f Double -> Double reimannSum Double 0.01 (LogWeight -> Double fromLogWeight (LogWeight -> Double) -> StrictSeq LogWeight -> StrictSeq Double forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> StrictSeq LogWeight values') -- | Calculate the k percentile for this distribution. -- k is a value between 0 and 1. The 0 percentile is 0 and the 1 percentile is 1 percentile :: Double -> Histogram -> Likelihood -> PerformanceEstimate percentile :: Double -> Histogram -> Likelihood -> PerformanceEstimate percentile Double p Histogram prior Likelihood likelihoods = Double -> PerformanceEstimate PerformanceEstimate (Double -> PerformanceEstimate) -> ((Double, Double) -> Double) -> (Double, Double) -> PerformanceEstimate forall b c a. (b -> c) -> (a -> b) -> a -> c . (Double, Double) -> Double forall a b. (a, b) -> a fst ((Double, Double) -> PerformanceEstimate) -> (Double, Double) -> PerformanceEstimate forall a b. (a -> b) -> a -> b $ (Double, Double) -> Maybe (Double, Double) -> (Double, Double) forall a. a -> Maybe a -> a fromMaybe (Double 1, Double 1) (Maybe (Double, Double) -> (Double, Double)) -> Maybe (Double, Double) -> (Double, Double) forall a b. (a -> b) -> a -> b $ ((Double, Double) -> Bool) -> Seq (Double, Double) -> Maybe (Double, Double) forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a find (\(Double _x, Double fx) -> Double fx Double -> Double -> Bool forall a. Ord a => a -> a -> Bool > Double p) Seq (Double, Double) cdf where (Histogram StrictSeq LogWeight values) = Histogram -> Likelihood -> Histogram posteriorDistribution Histogram prior Likelihood likelihoods cdf :: Seq (Double, Double) cdf = Seq Double -> Seq Double -> Seq (Double, Double) forall a b. Seq a -> Seq b -> Seq (a, b) Seq.zip (StrictSeq Double -> Seq Double forall a. StrictSeq a -> Seq a StrictSeq.getSeq StrictSeq Double samplePositions) (StrictSeq Double -> Seq Double forall a. StrictSeq a -> Seq a StrictSeq.getSeq ((Double -> Double -> Double) -> Double -> StrictSeq Double -> StrictSeq Double forall a b. (a -> b -> a) -> a -> StrictSeq b -> StrictSeq a StrictSeq.scanl Double -> Double -> Double forall a. Num a => a -> a -> a (+) Double 0 (LogWeight -> Double fromLogWeight (LogWeight -> Double) -> StrictSeq LogWeight -> StrictSeq Double forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> StrictSeq LogWeight values))) percentile' :: Likelihood -> PerformanceEstimate percentile' :: Likelihood -> PerformanceEstimate percentile' = Double -> Histogram -> Likelihood -> PerformanceEstimate percentile Double 0.5 Histogram h where h :: Histogram h = Histogram -> Histogram normalize (Histogram -> Histogram) -> (StrictSeq LogWeight -> Histogram) -> StrictSeq LogWeight -> Histogram forall b c a. (b -> c) -> (a -> b) -> a -> c . StrictSeq LogWeight -> Histogram Histogram (StrictSeq LogWeight -> Histogram) -> StrictSeq LogWeight -> Histogram forall a b. (a -> b) -> a -> b $ Double -> Double -> Double -> LogWeight forall a. (Real a, Floating a) => a -> a -> a -> LogWeight logBeta Double 40 Double 1 (Double -> LogWeight) -> StrictSeq Double -> StrictSeq LogWeight forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> StrictSeq Double samplePositions -- Beta(n,m)(x) = C * x^(n-1)*(1-x)^(m-1) -- log( Beta(n,m)(x) ) = (n-1) * log x + (m-1) * log (1-x) logBeta :: a -> a -> a -> LogWeight logBeta a n a m a x = Float -> LogWeight LogWeight (Float -> LogWeight) -> (a -> Float) -> a -> LogWeight forall b c a. (b -> c) -> (a -> b) -> a -> c . a -> Float forall a b. (Real a, Fractional b) => a -> b realToFrac (a -> LogWeight) -> a -> LogWeight forall a b. (a -> b) -> a -> b $ (a n a -> a -> a forall a. Num a => a -> a -> a -a 1) a -> a -> a forall a. Num a => a -> a -> a * a -> a forall a. Floating a => a -> a log a x a -> a -> a forall a. Num a => a -> a -> a + (a m a -> a -> a forall a. Num a => a -> a -> a -a 1) a -> a -> a forall a. Num a => a -> a -> a * a -> a forall a. Floating a => a -> a log (a 1 a -> a -> a forall a. Num a => a -> a -> a - a x) reimannSum :: (Functor f, Foldable f) => Double -> f Double -> Double reimannSum :: Double -> f Double -> Double reimannSum Double width f Double heights = f Double -> Double forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a sum (f Double -> Double) -> f Double -> Double forall a b. (a -> b) -> a -> b $ (Double -> Double) -> f Double -> f Double forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap (Double width Double -> Double -> Double forall a. Num a => a -> a -> a *) f Double heights -- | This is a estimate of the proportion of allowed blocks a pool will -- make in the future. It is used for ranking pools in delegation. newtype PerformanceEstimate = PerformanceEstimate {PerformanceEstimate -> Double unPerformanceEstimate :: Double} deriving (Int -> PerformanceEstimate -> ShowS [PerformanceEstimate] -> ShowS PerformanceEstimate -> String (Int -> PerformanceEstimate -> ShowS) -> (PerformanceEstimate -> String) -> ([PerformanceEstimate] -> ShowS) -> Show PerformanceEstimate forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [PerformanceEstimate] -> ShowS $cshowList :: [PerformanceEstimate] -> ShowS show :: PerformanceEstimate -> String $cshow :: PerformanceEstimate -> String showsPrec :: Int -> PerformanceEstimate -> ShowS $cshowsPrec :: Int -> PerformanceEstimate -> ShowS Show, PerformanceEstimate -> PerformanceEstimate -> Bool (PerformanceEstimate -> PerformanceEstimate -> Bool) -> (PerformanceEstimate -> PerformanceEstimate -> Bool) -> Eq PerformanceEstimate forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a /= :: PerformanceEstimate -> PerformanceEstimate -> Bool $c/= :: PerformanceEstimate -> PerformanceEstimate -> Bool == :: PerformanceEstimate -> PerformanceEstimate -> Bool $c== :: PerformanceEstimate -> PerformanceEstimate -> Bool Eq, (forall x. PerformanceEstimate -> Rep PerformanceEstimate x) -> (forall x. Rep PerformanceEstimate x -> PerformanceEstimate) -> Generic PerformanceEstimate forall x. Rep PerformanceEstimate x -> PerformanceEstimate forall x. PerformanceEstimate -> Rep PerformanceEstimate x forall a. (forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a $cto :: forall x. Rep PerformanceEstimate x -> PerformanceEstimate $cfrom :: forall x. PerformanceEstimate -> Rep PerformanceEstimate x Generic, Context -> PerformanceEstimate -> IO (Maybe ThunkInfo) Proxy PerformanceEstimate -> String (Context -> PerformanceEstimate -> IO (Maybe ThunkInfo)) -> (Context -> PerformanceEstimate -> IO (Maybe ThunkInfo)) -> (Proxy PerformanceEstimate -> String) -> NoThunks PerformanceEstimate forall a. (Context -> a -> IO (Maybe ThunkInfo)) -> (Context -> a -> IO (Maybe ThunkInfo)) -> (Proxy a -> String) -> NoThunks a showTypeOf :: Proxy PerformanceEstimate -> String $cshowTypeOf :: Proxy PerformanceEstimate -> String wNoThunks :: Context -> PerformanceEstimate -> IO (Maybe ThunkInfo) $cwNoThunks :: Context -> PerformanceEstimate -> IO (Maybe ThunkInfo) noThunks :: Context -> PerformanceEstimate -> IO (Maybe ThunkInfo) $cnoThunks :: Context -> PerformanceEstimate -> IO (Maybe ThunkInfo) NoThunks) instance ToCBOR PerformanceEstimate where toCBOR :: PerformanceEstimate -> Encoding toCBOR = Double -> Encoding encodeDouble (Double -> Encoding) -> (PerformanceEstimate -> Double) -> PerformanceEstimate -> Encoding forall b c a. (b -> c) -> (a -> b) -> a -> c . PerformanceEstimate -> Double unPerformanceEstimate instance FromCBOR PerformanceEstimate where fromCBOR :: Decoder s PerformanceEstimate fromCBOR = Double -> PerformanceEstimate PerformanceEstimate (Double -> PerformanceEstimate) -> Decoder s Double -> Decoder s PerformanceEstimate forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Decoder s Double forall s. Decoder s Double decodeDouble data NonMyopic era = NonMyopic { NonMyopic era -> Map (KeyHash 'StakePool (Crypto era)) Likelihood likelihoodsNM :: !(Map (KeyHash 'StakePool (Crypto era)) Likelihood), NonMyopic era -> Coin rewardPotNM :: !Coin } deriving (Int -> NonMyopic era -> ShowS [NonMyopic era] -> ShowS NonMyopic era -> String (Int -> NonMyopic era -> ShowS) -> (NonMyopic era -> String) -> ([NonMyopic era] -> ShowS) -> Show (NonMyopic era) forall era. Int -> NonMyopic era -> ShowS forall era. [NonMyopic era] -> ShowS forall era. NonMyopic era -> String forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [NonMyopic era] -> ShowS $cshowList :: forall era. [NonMyopic era] -> ShowS show :: NonMyopic era -> String $cshow :: forall era. NonMyopic era -> String showsPrec :: Int -> NonMyopic era -> ShowS $cshowsPrec :: forall era. Int -> NonMyopic era -> ShowS Show, NonMyopic era -> NonMyopic era -> Bool (NonMyopic era -> NonMyopic era -> Bool) -> (NonMyopic era -> NonMyopic era -> Bool) -> Eq (NonMyopic era) forall era. NonMyopic era -> NonMyopic era -> Bool forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a /= :: NonMyopic era -> NonMyopic era -> Bool $c/= :: forall era. NonMyopic era -> NonMyopic era -> Bool == :: NonMyopic era -> NonMyopic era -> Bool $c== :: forall era. NonMyopic era -> NonMyopic era -> Bool Eq, (forall x. NonMyopic era -> Rep (NonMyopic era) x) -> (forall x. Rep (NonMyopic era) x -> NonMyopic era) -> Generic (NonMyopic era) forall x. Rep (NonMyopic era) x -> NonMyopic era forall x. NonMyopic era -> Rep (NonMyopic era) x forall a. (forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a forall era x. Rep (NonMyopic era) x -> NonMyopic era forall era x. NonMyopic era -> Rep (NonMyopic era) x $cto :: forall era x. Rep (NonMyopic era) x -> NonMyopic era $cfrom :: forall era x. NonMyopic era -> Rep (NonMyopic era) x Generic) emptyNonMyopic :: NonMyopic era emptyNonMyopic :: NonMyopic era emptyNonMyopic = Map (KeyHash 'StakePool (Crypto era)) Likelihood -> Coin -> NonMyopic era forall era. Map (KeyHash 'StakePool (Crypto era)) Likelihood -> Coin -> NonMyopic era NonMyopic Map (KeyHash 'StakePool (Crypto era)) Likelihood forall k a. Map k a Map.empty (Integer -> Coin Coin Integer 0) instance NoThunks (NonMyopic era) instance NFData (NonMyopic era) instance Era era => ToCBOR (NonMyopic era) where toCBOR :: NonMyopic era -> Encoding toCBOR NonMyopic { likelihoodsNM :: forall era. NonMyopic era -> Map (KeyHash 'StakePool (Crypto era)) Likelihood likelihoodsNM = Map (KeyHash 'StakePool (Crypto era)) Likelihood aps, rewardPotNM :: forall era. NonMyopic era -> Coin rewardPotNM = Coin rp } = Word -> Encoding encodeListLen Word 3 Encoding -> Encoding -> Encoding forall a. Semigroup a => a -> a -> a <> Map (KeyHash 'StakePool (Crypto era)) Likelihood -> Encoding forall a. ToCBOR a => a -> Encoding toCBOR Map (KeyHash 'StakePool (Crypto era)) Likelihood aps Encoding -> Encoding -> Encoding forall a. Semigroup a => a -> a -> a <> Coin -> Encoding forall a. ToCBOR a => a -> Encoding toCBOR Coin rp instance Era era => FromCBOR (NonMyopic era) where fromCBOR :: Decoder s (NonMyopic era) fromCBOR = do Text -> (NonMyopic era -> Int) -> Decoder s (NonMyopic era) -> Decoder s (NonMyopic era) forall a s. Text -> (a -> Int) -> Decoder s a -> Decoder s a decodeRecordNamed Text "NonMyopic" (Int -> NonMyopic era -> Int forall a b. a -> b -> a const Int 3) (Decoder s (NonMyopic era) -> Decoder s (NonMyopic era)) -> Decoder s (NonMyopic era) -> Decoder s (NonMyopic era) forall a b. (a -> b) -> a -> b $ do Map (KeyHash 'StakePool (Crypto era)) Likelihood aps <- Decoder s (Map (KeyHash 'StakePool (Crypto era)) Likelihood) forall a s. FromCBOR a => Decoder s a fromCBOR Coin rp <- Decoder s Coin forall a s. FromCBOR a => Decoder s a fromCBOR NonMyopic era -> Decoder s (NonMyopic era) forall (f :: * -> *) a. Applicative f => a -> f a pure (NonMyopic era -> Decoder s (NonMyopic era)) -> NonMyopic era -> Decoder s (NonMyopic era) forall a b. (a -> b) -> a -> b $ NonMyopic :: forall era. Map (KeyHash 'StakePool (Crypto era)) Likelihood -> Coin -> NonMyopic era NonMyopic { likelihoodsNM :: Map (KeyHash 'StakePool (Crypto era)) Likelihood likelihoodsNM = Map (KeyHash 'StakePool (Crypto era)) Likelihood aps, rewardPotNM :: Coin rewardPotNM = Coin rp } -- | Desirability calculation for non-myopic utily, -- corresponding to f^~ in section 5.6.1 of -- "Design Specification for Delegation and Incentives in Cardano" desirability :: PParams era -> Coin -> PoolParams era -> PerformanceEstimate -> Coin -> Double desirability :: PParams era -> Coin -> PoolParams era -> PerformanceEstimate -> Coin -> Double desirability PParams era pp Coin r PoolParams era pool (PerformanceEstimate Double p) (Coin Integer totalStake) = if Double fTilde Double -> Double -> Bool forall a. Ord a => a -> a -> Bool <= Double cost then Double 0 else (Double fTilde Double -> Double -> Double forall a. Num a => a -> a -> a - Double cost) Double -> Double -> Double forall a. Num a => a -> a -> a * (Double 1 Double -> Double -> Double forall a. Num a => a -> a -> a - Double margin) where fTilde :: Double fTilde = Double fTildeNumer Double -> Double -> Double forall a. Fractional a => a -> a -> a / Double fTildeDenom fTildeNumer :: Double fTildeNumer = Double p Double -> Double -> Double forall a. Num a => a -> a -> a * Rational -> Double forall a. Fractional a => Rational -> a fromRational (Coin -> Rational coinToRational Coin r Rational -> Rational -> Rational forall a. Num a => a -> a -> a * (Rational z0 Rational -> Rational -> Rational forall a. Num a => a -> a -> a + Rational -> Rational -> Rational forall a. Ord a => a -> a -> a min Rational s Rational z0 Rational -> Rational -> Rational forall a. Num a => a -> a -> a * Rational a0)) fTildeDenom :: Double fTildeDenom = Rational -> Double forall a. Fractional a => Rational -> a fromRational (Rational -> Double) -> Rational -> Double forall a b. (a -> b) -> a -> b $ Rational 1 Rational -> Rational -> Rational forall a. Num a => a -> a -> a + Rational a0 cost :: Double cost = (Rational -> Double forall a. Fractional a => Rational -> a fromRational (Rational -> Double) -> (PoolParams era -> Rational) -> PoolParams era -> Double forall b c a. (b -> c) -> (a -> b) -> a -> c . Coin -> Rational coinToRational (Coin -> Rational) -> (PoolParams era -> Coin) -> PoolParams era -> Rational forall b c a. (b -> c) -> (a -> b) -> a -> c . PoolParams era -> Coin forall era. PoolParams era -> Coin _poolCost) PoolParams era pool margin :: Double margin = (Rational -> Double forall a. Fractional a => Rational -> a fromRational (Rational -> Double) -> (PoolParams era -> Rational) -> PoolParams era -> Double forall b c a. (b -> c) -> (a -> b) -> a -> c . UnitInterval -> Rational unitIntervalToRational (UnitInterval -> Rational) -> (PoolParams era -> UnitInterval) -> PoolParams era -> Rational forall b c a. (b -> c) -> (a -> b) -> a -> c . PoolParams era -> UnitInterval forall era. PoolParams era -> UnitInterval _poolMargin) PoolParams era pool tot :: Integer tot = Integer -> Integer -> Integer forall a. Ord a => a -> a -> a max Integer 1 (Integer -> Integer forall a b. (Integral a, Num b) => a -> b fromIntegral Integer totalStake) Coin Integer pledge = PoolParams era -> Coin forall era. PoolParams era -> Coin _poolPledge PoolParams era pool s :: Rational s = Integer -> Integer forall a b. (Integral a, Num b) => a -> b fromIntegral Integer pledge Integer -> Integer -> Rational forall a. Integral a => a -> a -> Ratio a % Integer tot a0 :: HKD Identity Rational a0 = PParams era -> HKD Identity Rational forall (f :: * -> *) era. PParams' f era -> HKD f Rational _a0 PParams era pp z0 :: Rational z0 = Integer 1 Integer -> Integer -> Rational forall a. Integral a => a -> a -> Ratio a % Integer -> Integer -> Integer forall a. Ord a => a -> a -> a max Integer 1 (Natural -> Integer forall a b. (Integral a, Num b) => a -> b fromIntegral (PParams era -> HKD Identity Natural forall (f :: * -> *) era. PParams' f era -> HKD f Natural _nOpt PParams era pp)) -- | Computes the top ranked stake pools -- corresponding to section 5.6.1 of -- "Design Specification for Delegation and Incentives in Cardano" getTopRankedPools :: Coin -> Coin -> PParams era -> Map (KeyHash 'StakePool (Crypto era)) (PoolParams era) -> Map (KeyHash 'StakePool (Crypto era)) PerformanceEstimate -> Set (KeyHash 'StakePool (Crypto era)) getTopRankedPools :: Coin -> Coin -> PParams era -> Map (KeyHash 'StakePool (Crypto era)) (PoolParams era) -> Map (KeyHash 'StakePool (Crypto era)) PerformanceEstimate -> Set (KeyHash 'StakePool (Crypto era)) getTopRankedPools Coin rPot Coin totalStake PParams era pp Map (KeyHash 'StakePool (Crypto era)) (PoolParams era) poolParams Map (KeyHash 'StakePool (Crypto era)) PerformanceEstimate aps = [KeyHash 'StakePool (Crypto era)] -> Set (KeyHash 'StakePool (Crypto era)) forall a. Ord a => [a] -> Set a Set.fromList ([KeyHash 'StakePool (Crypto era)] -> Set (KeyHash 'StakePool (Crypto era))) -> [KeyHash 'StakePool (Crypto era)] -> Set (KeyHash 'StakePool (Crypto era)) forall a b. (a -> b) -> a -> b $ ((KeyHash 'StakePool (Crypto era), Double) -> KeyHash 'StakePool (Crypto era)) -> [(KeyHash 'StakePool (Crypto era), Double)] -> [KeyHash 'StakePool (Crypto era)] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap (KeyHash 'StakePool (Crypto era), Double) -> KeyHash 'StakePool (Crypto era) forall a b. (a, b) -> a fst ([(KeyHash 'StakePool (Crypto era), Double)] -> [KeyHash 'StakePool (Crypto era)]) -> [(KeyHash 'StakePool (Crypto era), Double)] -> [KeyHash 'StakePool (Crypto era)] forall a b. (a -> b) -> a -> b $ Int -> [(KeyHash 'StakePool (Crypto era), Double)] -> [(KeyHash 'StakePool (Crypto era), Double)] forall a. Int -> [a] -> [a] take (Natural -> Int forall a b. (Integral a, Num b) => a -> b fromIntegral (Natural -> Int) -> Natural -> Int forall a b. (a -> b) -> a -> b $ PParams era -> HKD Identity Natural forall (f :: * -> *) era. PParams' f era -> HKD f Natural _nOpt PParams era pp) (((KeyHash 'StakePool (Crypto era), Double) -> (KeyHash 'StakePool (Crypto era), Double) -> Ordering) -> [(KeyHash 'StakePool (Crypto era), Double)] -> [(KeyHash 'StakePool (Crypto era), Double)] forall a. (a -> a -> Ordering) -> [a] -> [a] sortBy ((Double -> Double -> Ordering) -> Double -> Double -> Ordering forall a b c. (a -> b -> c) -> b -> a -> c flip Double -> Double -> Ordering forall a. Ord a => a -> a -> Ordering compare (Double -> Double -> Ordering) -> ((KeyHash 'StakePool (Crypto era), Double) -> Double) -> (KeyHash 'StakePool (Crypto era), Double) -> (KeyHash 'StakePool (Crypto era), Double) -> Ordering forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c `on` (KeyHash 'StakePool (Crypto era), Double) -> Double forall a b. (a, b) -> b snd) [(KeyHash 'StakePool (Crypto era), Double)] rankings) where pdata :: [(KeyHash 'StakePool (Crypto era), (PoolParams era, PerformanceEstimate))] pdata = Map (KeyHash 'StakePool (Crypto era)) (PoolParams era, PerformanceEstimate) -> [(KeyHash 'StakePool (Crypto era), (PoolParams era, PerformanceEstimate))] forall k a. Map k a -> [(k, a)] Map.toList (Map (KeyHash 'StakePool (Crypto era)) (PoolParams era, PerformanceEstimate) -> [(KeyHash 'StakePool (Crypto era), (PoolParams era, PerformanceEstimate))]) -> Map (KeyHash 'StakePool (Crypto era)) (PoolParams era, PerformanceEstimate) -> [(KeyHash 'StakePool (Crypto era), (PoolParams era, PerformanceEstimate))] forall a b. (a -> b) -> a -> b $ (PoolParams era -> PerformanceEstimate -> (PoolParams era, PerformanceEstimate)) -> Map (KeyHash 'StakePool (Crypto era)) (PoolParams era) -> Map (KeyHash 'StakePool (Crypto era)) PerformanceEstimate -> Map (KeyHash 'StakePool (Crypto era)) (PoolParams era, PerformanceEstimate) forall k a b c. Ord k => (a -> b -> c) -> Map k a -> Map k b -> Map k c Map.intersectionWith (,) Map (KeyHash 'StakePool (Crypto era)) (PoolParams era) poolParams Map (KeyHash 'StakePool (Crypto era)) PerformanceEstimate aps rankings :: [(KeyHash 'StakePool (Crypto era), Double)] rankings = [ ( KeyHash 'StakePool (Crypto era) hk, PParams era -> Coin -> PoolParams era -> PerformanceEstimate -> Coin -> Double forall era. PParams era -> Coin -> PoolParams era -> PerformanceEstimate -> Coin -> Double desirability PParams era pp Coin rPot PoolParams era pool PerformanceEstimate ap Coin totalStake ) | (KeyHash 'StakePool (Crypto era) hk, (PoolParams era pool, PerformanceEstimate ap)) <- [(KeyHash 'StakePool (Crypto era), (PoolParams era, PerformanceEstimate))] pdata ] -- | StakeShare type newtype = { :: Rational} deriving ((forall x. StakeShare -> Rep StakeShare x) -> (forall x. Rep StakeShare x -> StakeShare) -> Generic StakeShare forall x. Rep StakeShare x -> StakeShare forall x. StakeShare -> Rep StakeShare x forall a. (forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a $cto :: forall x. Rep StakeShare x -> StakeShare $cfrom :: forall x. StakeShare -> Rep StakeShare x Generic, Eq StakeShare Eq StakeShare -> (StakeShare -> StakeShare -> Ordering) -> (StakeShare -> StakeShare -> Bool) -> (StakeShare -> StakeShare -> Bool) -> (StakeShare -> StakeShare -> Bool) -> (StakeShare -> StakeShare -> Bool) -> (StakeShare -> StakeShare -> StakeShare) -> (StakeShare -> StakeShare -> StakeShare) -> Ord StakeShare StakeShare -> StakeShare -> Bool StakeShare -> StakeShare -> Ordering StakeShare -> StakeShare -> StakeShare forall a. Eq a -> (a -> a -> Ordering) -> (a -> a -> Bool) -> (a -> a -> Bool) -> (a -> a -> Bool) -> (a -> a -> Bool) -> (a -> a -> a) -> (a -> a -> a) -> Ord a min :: StakeShare -> StakeShare -> StakeShare $cmin :: StakeShare -> StakeShare -> StakeShare max :: StakeShare -> StakeShare -> StakeShare $cmax :: StakeShare -> StakeShare -> StakeShare >= :: StakeShare -> StakeShare -> Bool $c>= :: StakeShare -> StakeShare -> Bool > :: StakeShare -> StakeShare -> Bool $c> :: StakeShare -> StakeShare -> Bool <= :: StakeShare -> StakeShare -> Bool $c<= :: StakeShare -> StakeShare -> Bool < :: StakeShare -> StakeShare -> Bool $c< :: StakeShare -> StakeShare -> Bool compare :: StakeShare -> StakeShare -> Ordering $ccompare :: StakeShare -> StakeShare -> Ordering $cp1Ord :: Eq StakeShare Ord, StakeShare -> StakeShare -> Bool (StakeShare -> StakeShare -> Bool) -> (StakeShare -> StakeShare -> Bool) -> Eq StakeShare forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a /= :: StakeShare -> StakeShare -> Bool $c/= :: StakeShare -> StakeShare -> Bool == :: StakeShare -> StakeShare -> Bool $c== :: StakeShare -> StakeShare -> Bool Eq, Context -> StakeShare -> IO (Maybe ThunkInfo) Proxy StakeShare -> String (Context -> StakeShare -> IO (Maybe ThunkInfo)) -> (Context -> StakeShare -> IO (Maybe ThunkInfo)) -> (Proxy StakeShare -> String) -> NoThunks StakeShare forall a. (Context -> a -> IO (Maybe ThunkInfo)) -> (Context -> a -> IO (Maybe ThunkInfo)) -> (Proxy a -> String) -> NoThunks a showTypeOf :: Proxy StakeShare -> String $cshowTypeOf :: Proxy StakeShare -> String wNoThunks :: Context -> StakeShare -> IO (Maybe ThunkInfo) $cwNoThunks :: Context -> StakeShare -> IO (Maybe ThunkInfo) noThunks :: Context -> StakeShare -> IO (Maybe ThunkInfo) $cnoThunks :: Context -> StakeShare -> IO (Maybe ThunkInfo) NoThunks) deriving (Int -> StakeShare -> ShowS [StakeShare] -> ShowS StakeShare -> String (Int -> StakeShare -> ShowS) -> (StakeShare -> String) -> ([StakeShare] -> ShowS) -> Show StakeShare forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [StakeShare] -> ShowS $cshowList :: [StakeShare] -> ShowS show :: StakeShare -> String $cshow :: StakeShare -> String showsPrec :: Int -> StakeShare -> ShowS $cshowsPrec :: Int -> StakeShare -> ShowS Show) via Quiet StakeShare -- | Calculate pool reward mkApparentPerformance :: UnitInterval -> Rational -> Natural -> Natural -> Rational mkApparentPerformance :: UnitInterval -> Rational -> Natural -> Natural -> Rational mkApparentPerformance UnitInterval d_ Rational sigma Natural blocksN Natural blocksTotal | Rational sigma Rational -> Rational -> Bool forall a. Eq a => a -> a -> Bool == Rational 0 = Rational 0 | UnitInterval -> Rational unitIntervalToRational UnitInterval d_ Rational -> Rational -> Bool forall a. Ord a => a -> a -> Bool < Rational 0.8 = Rational beta Rational -> Rational -> Rational forall a. Fractional a => a -> a -> a / Rational sigma | Bool otherwise = Rational 1 where beta :: Rational beta = Natural -> Rational forall a b. (Integral a, Num b) => a -> b fromIntegral Natural blocksN Rational -> Rational -> Rational forall a. Fractional a => a -> a -> a / Natural -> Rational forall a b. (Integral a, Num b) => a -> b fromIntegral (Natural -> Natural -> Natural forall a. Ord a => a -> a -> a max Natural 1 Natural blocksTotal) -- | Calculate pool leader reward leaderRew :: Coin -> PoolParams era -> StakeShare -> StakeShare -> Coin leaderRew :: Coin -> PoolParams era -> StakeShare -> StakeShare -> Coin leaderRew Coin f PoolParams era pool (StakeShare Rational s) (StakeShare Rational sigma) | Coin f Coin -> Coin -> Bool forall a. Ord a => a -> a -> Bool <= Coin c = Coin f | Bool otherwise = Coin c Coin -> Coin -> Coin forall a. Semigroup a => a -> a -> a <> Rational -> Coin rationalToCoinViaFloor (Coin -> Rational coinToRational (Coin f Coin -> Coin -> Coin forall t. Val t => t -> t -> t <-> Coin c) Rational -> Rational -> Rational forall a. Num a => a -> a -> a * (Rational m' Rational -> Rational -> Rational forall a. Num a => a -> a -> a + (Rational 1 Rational -> Rational -> Rational forall a. Num a => a -> a -> a - Rational m') Rational -> Rational -> Rational forall a. Num a => a -> a -> a * Rational s Rational -> Rational -> Rational forall a. Fractional a => a -> a -> a / Rational sigma)) where (Coin c, UnitInterval m, Coin _) = PoolParams era -> (Coin, UnitInterval, Coin) forall era. PoolParams era -> (Coin, UnitInterval, Coin) poolSpec PoolParams era pool m' :: Rational m' = UnitInterval -> Rational unitIntervalToRational UnitInterval m -- | Calculate pool member reward memberRew :: Coin -> PoolParams era -> StakeShare -> StakeShare -> Coin memberRew :: Coin -> PoolParams era -> StakeShare -> StakeShare -> Coin memberRew (Coin Integer f') PoolParams era pool (StakeShare Rational t) (StakeShare Rational sigma) | Integer f' Integer -> Integer -> Bool forall a. Ord a => a -> a -> Bool <= Integer c = Coin forall a. Monoid a => a mempty | Bool otherwise = Rational -> Coin rationalToCoinViaFloor (Rational -> Coin) -> Rational -> Coin forall a b. (a -> b) -> a -> b $ Integer -> Rational forall a b. (Integral a, Num b) => a -> b fromIntegral (Integer f' Integer -> Integer -> Integer forall a. Num a => a -> a -> a - Integer c) Rational -> Rational -> Rational forall a. Num a => a -> a -> a * (Rational 1 Rational -> Rational -> Rational forall a. Num a => a -> a -> a - Rational m') Rational -> Rational -> Rational forall a. Num a => a -> a -> a * Rational t Rational -> Rational -> Rational forall a. Fractional a => a -> a -> a / Rational sigma where (Coin Integer c, UnitInterval m, Coin _) = PoolParams era -> (Coin, UnitInterval, Coin) forall era. PoolParams era -> (Coin, UnitInterval, Coin) poolSpec PoolParams era pool m' :: Rational m' = UnitInterval -> Rational unitIntervalToRational UnitInterval m -- | Reward one pool rewardOnePool :: PParams era -> Coin -> Natural -> Natural -> PoolParams era -> Stake era -> Rational -> Rational -> Coin -> Set (Credential 'Staking era) -> Map (Credential 'Staking era) Coin rewardOnePool :: PParams era -> Coin -> Natural -> Natural -> PoolParams era -> Stake era -> Rational -> Rational -> Coin -> Set (Credential 'Staking era) -> Map (Credential 'Staking era) Coin rewardOnePool PParams era pp Coin r Natural blocksN Natural blocksTotal PoolParams era pool (Stake Map (Credential 'Staking era) Coin stake) Rational sigma Rational sigmaA (Coin Integer totalStake) Set (Credential 'Staking era) addrsRew = Map (Credential 'Staking era) Coin rewards' where Coin Integer ostake = (Coin -> KeyHash 'Staking (Crypto era) -> Coin) -> Coin -> Set (KeyHash 'Staking (Crypto era)) -> Coin forall a b. (a -> b -> a) -> a -> Set b -> a Set.foldl' (\Coin c KeyHash 'Staking (Crypto era) o -> Coin c Coin -> Coin -> Coin forall a. Semigroup a => a -> a -> a <> (Coin -> Maybe Coin -> Coin forall a. a -> Maybe a -> a fromMaybe Coin forall a. Monoid a => a mempty (Maybe Coin -> Coin) -> Maybe Coin -> Coin forall a b. (a -> b) -> a -> b $ Credential 'Staking era -> Map (Credential 'Staking era) Coin -> Maybe Coin forall k a. Ord k => k -> Map k a -> Maybe a Map.lookup (KeyHash 'Staking (Crypto era) -> Credential 'Staking era forall (kr :: KeyRole) era. KeyHash kr (Crypto era) -> Credential kr era KeyHashObj KeyHash 'Staking (Crypto era) o) Map (Credential 'Staking era) Coin stake)) Coin forall a. Monoid a => a mempty (PoolParams era -> Set (KeyHash 'Staking (Crypto era)) forall era. PoolParams era -> Set (KeyHash 'Staking (Crypto era)) _poolOwners PoolParams era pool) Coin Integer pledge = PoolParams era -> Coin forall era. PoolParams era -> Coin _poolPledge PoolParams era pool pr :: Rational pr = Integer -> Integer forall a b. (Integral a, Num b) => a -> b fromIntegral Integer pledge Integer -> Integer -> Rational forall a. Integral a => a -> a -> Ratio a % Integer -> Integer forall a b. (Integral a, Num b) => a -> b fromIntegral Integer totalStake (Coin Integer maxP) = if Integer pledge Integer -> Integer -> Bool forall a. Ord a => a -> a -> Bool <= Integer ostake then PParams era -> Coin -> Rational -> Rational -> Coin forall era. PParams era -> Coin -> Rational -> Rational -> Coin maxPool PParams era pp Coin r Rational sigma Rational pr else Coin forall a. Monoid a => a mempty appPerf :: Rational appPerf = UnitInterval -> Rational -> Natural -> Natural -> Rational mkApparentPerformance (PParams era -> HKD Identity UnitInterval forall (f :: * -> *) era. PParams' f era -> HKD f UnitInterval _d PParams era pp) Rational sigmaA Natural blocksN Natural blocksTotal poolR :: Coin poolR = Rational -> Coin rationalToCoinViaFloor (Rational appPerf Rational -> Rational -> Rational forall a. Num a => a -> a -> a * Integer -> Rational forall a b. (Integral a, Num b) => a -> b fromIntegral Integer maxP) tot :: Integer tot = Integer -> Integer forall a b. (Integral a, Num b) => a -> b fromIntegral Integer totalStake mRewards :: Map (Credential 'Staking era) Coin mRewards = [(Credential 'Staking era, Coin)] -> Map (Credential 'Staking era) Coin forall k a. Ord k => [(k, a)] -> Map k a Map.fromList [ ( Credential 'Staking era hk, Coin -> PoolParams era -> StakeShare -> StakeShare -> Coin forall era. Coin -> PoolParams era -> StakeShare -> StakeShare -> Coin memberRew Coin poolR PoolParams era pool (Rational -> StakeShare StakeShare (Integer -> Integer forall a b. (Integral a, Num b) => a -> b fromIntegral Integer c Integer -> Integer -> Rational forall a. Integral a => a -> a -> Ratio a % Integer tot)) (Rational -> StakeShare StakeShare Rational sigma) ) | (Credential 'Staking era hk, Coin Integer c) <- Map (Credential 'Staking era) Coin -> [(Credential 'Staking era, Coin)] forall k a. Map k a -> [(k, a)] Map.toList Map (Credential 'Staking era) Coin stake, Credential 'Staking era -> Bool notPoolOwner Credential 'Staking era hk ] notPoolOwner :: Credential 'Staking era -> Bool notPoolOwner (KeyHashObj KeyHash 'Staking (Crypto era) hk) = KeyHash 'Staking (Crypto era) hk KeyHash 'Staking (Crypto era) -> Set (KeyHash 'Staking (Crypto era)) -> Bool forall a. Ord a => a -> Set a -> Bool `Set.notMember` PoolParams era -> Set (KeyHash 'Staking (Crypto era)) forall era. PoolParams era -> Set (KeyHash 'Staking (Crypto era)) _poolOwners PoolParams era pool notPoolOwner (ScriptHashObj ScriptHash era _) = Bool False iReward :: Coin iReward = Coin -> PoolParams era -> StakeShare -> StakeShare -> Coin forall era. Coin -> PoolParams era -> StakeShare -> StakeShare -> Coin leaderRew Coin poolR PoolParams era pool (Rational -> StakeShare StakeShare (Rational -> StakeShare) -> Rational -> StakeShare forall a b. (a -> b) -> a -> b $ Integer -> Integer forall a b. (Integral a, Num b) => a -> b fromIntegral Integer ostake Integer -> Integer -> Rational forall a. Integral a => a -> a -> Ratio a % Integer tot) (Rational -> StakeShare StakeShare Rational sigma) potentialRewards :: Map (Credential 'Staking era) Coin potentialRewards = Credential 'Staking era -> Coin -> Map (Credential 'Staking era) Coin -> Map (Credential 'Staking era) Coin forall k a. Ord k => k -> a -> Map k a -> Map k a Map.insert (RewardAcnt era -> Credential 'Staking era forall era. RewardAcnt era -> Credential 'Staking era getRwdCred (RewardAcnt era -> Credential 'Staking era) -> RewardAcnt era -> Credential 'Staking era forall a b. (a -> b) -> a -> b $ PoolParams era -> RewardAcnt era forall era. PoolParams era -> RewardAcnt era _poolRAcnt PoolParams era pool) Coin iReward Map (Credential 'Staking era) Coin mRewards rewards' :: Map (Credential 'Staking era) Coin rewards' = (Coin -> Bool) -> Map (Credential 'Staking era) Coin -> Map (Credential 'Staking era) Coin forall a k. (a -> Bool) -> Map k a -> Map k a Map.filter (Coin -> Coin -> Bool forall a. Eq a => a -> a -> Bool /= Integer -> Coin Coin Integer 0) (Map (Credential 'Staking era) Coin -> Map (Credential 'Staking era) Coin) -> Map (Credential 'Staking era) Coin -> Map (Credential 'Staking era) Coin forall a b. (a -> b) -> a -> b $ Exp (Map (Credential 'Staking era) Coin) -> Map (Credential 'Staking era) Coin forall s t. Embed s t => Exp t -> s eval (Set (Credential 'Staking era) addrsRew Set (Credential 'Staking era) -> Map (Credential 'Staking era) Coin -> Exp (Map (Credential 'Staking era) Coin) forall k s1 s2 (f :: * -> * -> *) v. (Ord k, HasExp s1 (Sett k ()), HasExp s2 (f k v)) => s1 -> s2 -> Exp (f k v) ◁ Map (Credential 'Staking era) Coin potentialRewards) reward :: PParams era -> BlocksMade era -> Coin -> Set (Credential 'Staking era) -> Map (KeyHash 'StakePool (Crypto era)) (PoolParams era) -> Stake era -> Map (Credential 'Staking era) (KeyHash 'StakePool (Crypto era)) -> Coin -> ActiveSlotCoeff -> EpochSize -> ( Map (Credential 'Staking era) Coin, Map (KeyHash 'StakePool (Crypto era)) Likelihood ) reward :: PParams era -> BlocksMade era -> Coin -> Set (Credential 'Staking era) -> Map (KeyHash 'StakePool (Crypto era)) (PoolParams era) -> Stake era -> Map (Credential 'Staking era) (KeyHash 'StakePool (Crypto era)) -> Coin -> ActiveSlotCoeff -> EpochSize -> (Map (Credential 'Staking era) Coin, Map (KeyHash 'StakePool (Crypto era)) Likelihood) reward PParams era pp (BlocksMade Map (KeyHash 'StakePool (Crypto era)) Natural b) Coin r Set (Credential 'Staking era) addrsRew Map (KeyHash 'StakePool (Crypto era)) (PoolParams era) poolParams Stake era stake Map (Credential 'Staking era) (KeyHash 'StakePool (Crypto era)) delegs (Coin Integer totalStake) ActiveSlotCoeff asc EpochSize slotsPerEpoch = (Map (Credential 'Staking era) Coin rewards', Map (KeyHash 'StakePool (Crypto era)) Likelihood hs) where totalBlocks :: Natural totalBlocks = Map (KeyHash 'StakePool (Crypto era)) Natural -> Natural forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a sum Map (KeyHash 'StakePool (Crypto era)) Natural b Coin Integer activeStake = Map (Credential 'Staking era) Coin -> Coin forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m fold (Map (Credential 'Staking era) Coin -> Coin) -> (Stake era -> Map (Credential 'Staking era) Coin) -> Stake era -> Coin forall b c a. (b -> c) -> (a -> b) -> a -> c . Stake era -> Map (Credential 'Staking era) Coin forall era. Stake era -> Map (Credential 'Staking era) Coin unStake (Stake era -> Coin) -> Stake era -> Coin forall a b. (a -> b) -> a -> b $ Stake era stake results :: [(KeyHash 'StakePool (Crypto era), Maybe (Map (Credential 'Staking era) Coin), Likelihood)] results = do (KeyHash 'StakePool (Crypto era) hk, PoolParams era pparams) <- Map (KeyHash 'StakePool (Crypto era)) (PoolParams era) -> [(KeyHash 'StakePool (Crypto era), PoolParams era)] forall k a. Map k a -> [(k, a)] Map.toList Map (KeyHash 'StakePool (Crypto era)) (PoolParams era) poolParams let sigma :: Rational sigma = if Integer totalStake Integer -> Integer -> Bool forall a. Eq a => a -> a -> Bool == Integer 0 then Rational 0 else Integer -> Integer forall a b. (Integral a, Num b) => a -> b fromIntegral Integer pstake Integer -> Integer -> Rational forall a. Integral a => a -> a -> Ratio a % Integer -> Integer forall a b. (Integral a, Num b) => a -> b fromIntegral Integer totalStake sigmaA :: Rational sigmaA = if Integer activeStake Integer -> Integer -> Bool forall a. Eq a => a -> a -> Bool == Integer 0 then Rational 0 else Integer -> Integer forall a b. (Integral a, Num b) => a -> b fromIntegral Integer pstake Integer -> Integer -> Rational forall a. Integral a => a -> a -> Ratio a % Integer -> Integer forall a b. (Integral a, Num b) => a -> b fromIntegral Integer activeStake blocksProduced :: Maybe Natural blocksProduced = KeyHash 'StakePool (Crypto era) -> Map (KeyHash 'StakePool (Crypto era)) Natural -> Maybe Natural forall k a. Ord k => k -> Map k a -> Maybe a Map.lookup KeyHash 'StakePool (Crypto era) hk Map (KeyHash 'StakePool (Crypto era)) Natural b actgr :: Stake era actgr@(Stake Map (Credential 'Staking era) Coin s) = KeyHash 'StakePool (Crypto era) -> Map (Credential 'Staking era) (KeyHash 'StakePool (Crypto era)) -> Stake era -> Stake era forall era. KeyHash 'StakePool (Crypto era) -> Map (Credential 'Staking era) (KeyHash 'StakePool (Crypto era)) -> Stake era -> Stake era poolStake KeyHash 'StakePool (Crypto era) hk Map (Credential 'Staking era) (KeyHash 'StakePool (Crypto era)) delegs Stake era stake Coin Integer pstake = Map (Credential 'Staking era) Coin -> Coin forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m fold Map (Credential 'Staking era) Coin s rewardMap :: Maybe (Map (Credential 'Staking era) Coin) rewardMap = case Maybe Natural blocksProduced of Maybe Natural Nothing -> Maybe (Map (Credential 'Staking era) Coin) forall a. Maybe a Nothing -- This is equivalent to calling rewarOnePool with n = 0 Just Natural n -> Map (Credential 'Staking era) Coin -> Maybe (Map (Credential 'Staking era) Coin) forall a. a -> Maybe a Just (Map (Credential 'Staking era) Coin -> Maybe (Map (Credential 'Staking era) Coin)) -> Map (Credential 'Staking era) Coin -> Maybe (Map (Credential 'Staking era) Coin) forall a b. (a -> b) -> a -> b $ PParams era -> Coin -> Natural -> Natural -> PoolParams era -> Stake era -> Rational -> Rational -> Coin -> Set (Credential 'Staking era) -> Map (Credential 'Staking era) Coin forall era. PParams era -> Coin -> Natural -> Natural -> PoolParams era -> Stake era -> Rational -> Rational -> Coin -> Set (Credential 'Staking era) -> Map (Credential 'Staking era) Coin rewardOnePool PParams era pp Coin r Natural n Natural totalBlocks PoolParams era pparams Stake era actgr Rational sigma Rational sigmaA (Integer -> Coin Coin Integer totalStake) Set (Credential 'Staking era) addrsRew ls :: Likelihood ls = Natural -> Double -> EpochSize -> Likelihood likelihood (Natural -> Maybe Natural -> Natural forall a. a -> Maybe a -> a fromMaybe Natural 0 Maybe Natural blocksProduced) (ActiveSlotCoeff -> Rational -> UnitInterval -> Double leaderProbability ActiveSlotCoeff asc Rational sigma (PParams era -> HKD Identity UnitInterval forall (f :: * -> *) era. PParams' f era -> HKD f UnitInterval _d PParams era pp)) EpochSize slotsPerEpoch (KeyHash 'StakePool (Crypto era), Maybe (Map (Credential 'Staking era) Coin), Likelihood) -> [(KeyHash 'StakePool (Crypto era), Maybe (Map (Credential 'Staking era) Coin), Likelihood)] forall (f :: * -> *) a. Applicative f => a -> f a pure (KeyHash 'StakePool (Crypto era) hk, Maybe (Map (Credential 'Staking era) Coin) rewardMap, Likelihood ls) rewards' :: Map (Credential 'Staking era) Coin rewards' = [Map (Credential 'Staking era) Coin] -> Map (Credential 'Staking era) Coin forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m fold ([Map (Credential 'Staking era) Coin] -> Map (Credential 'Staking era) Coin) -> [Map (Credential 'Staking era) Coin] -> Map (Credential 'Staking era) Coin forall a b. (a -> b) -> a -> b $ [Maybe (Map (Credential 'Staking era) Coin)] -> [Map (Credential 'Staking era) Coin] forall a. [Maybe a] -> [a] catMaybes ([Maybe (Map (Credential 'Staking era) Coin)] -> [Map (Credential 'Staking era) Coin]) -> [Maybe (Map (Credential 'Staking era) Coin)] -> [Map (Credential 'Staking era) Coin] forall a b. (a -> b) -> a -> b $ ((KeyHash 'StakePool (Crypto era), Maybe (Map (Credential 'Staking era) Coin), Likelihood) -> Maybe (Map (Credential 'Staking era) Coin)) -> [(KeyHash 'StakePool (Crypto era), Maybe (Map (Credential 'Staking era) Coin), Likelihood)] -> [Maybe (Map (Credential 'Staking era) Coin)] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap (\(KeyHash 'StakePool (Crypto era) _, Maybe (Map (Credential 'Staking era) Coin) x, Likelihood _) -> Maybe (Map (Credential 'Staking era) Coin) x) [(KeyHash 'StakePool (Crypto era), Maybe (Map (Credential 'Staking era) Coin), Likelihood)] results hs :: Map (KeyHash 'StakePool (Crypto era)) Likelihood hs = [(KeyHash 'StakePool (Crypto era), Likelihood)] -> Map (KeyHash 'StakePool (Crypto era)) Likelihood forall k a. Ord k => [(k, a)] -> Map k a Map.fromList ([(KeyHash 'StakePool (Crypto era), Likelihood)] -> Map (KeyHash 'StakePool (Crypto era)) Likelihood) -> [(KeyHash 'StakePool (Crypto era), Likelihood)] -> Map (KeyHash 'StakePool (Crypto era)) Likelihood forall a b. (a -> b) -> a -> b $ ((KeyHash 'StakePool (Crypto era), Maybe (Map (Credential 'Staking era) Coin), Likelihood) -> (KeyHash 'StakePool (Crypto era), Likelihood)) -> [(KeyHash 'StakePool (Crypto era), Maybe (Map (Credential 'Staking era) Coin), Likelihood)] -> [(KeyHash 'StakePool (Crypto era), Likelihood)] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap (\(KeyHash 'StakePool (Crypto era) hk, Maybe (Map (Credential 'Staking era) Coin) _, Likelihood l) -> (KeyHash 'StakePool (Crypto era) hk, Likelihood l)) [(KeyHash 'StakePool (Crypto era), Maybe (Map (Credential 'Staking era) Coin), Likelihood)] results -- | Compute the Non-Myopic Pool Stake -- -- This function implements non-myopic stake calculation in section 5.6.2 -- of "Design Specification for Delegation and Incentives in Cardano". -- Note that the protocol parameters are implicit in the design document. -- Additionally, instead of passing a rank r to compare with k, -- we pass the top k desirable pools and check for membership. nonMyopicStake :: PParams era -> StakeShare -> StakeShare -> StakeShare -> KeyHash 'StakePool (Crypto era) -> Set (KeyHash 'StakePool (Crypto era)) -> StakeShare nonMyopicStake :: PParams era -> StakeShare -> StakeShare -> StakeShare -> KeyHash 'StakePool (Crypto era) -> Set (KeyHash 'StakePool (Crypto era)) -> StakeShare nonMyopicStake PParams era pp (StakeShare Rational s) (StakeShare Rational sigma) (StakeShare Rational t) KeyHash 'StakePool (Crypto era) kh Set (KeyHash 'StakePool (Crypto era)) topPools = let z0 :: Rational z0 = Integer 1 Integer -> Integer -> Rational forall a. Integral a => a -> a -> Ratio a % Integer -> Integer -> Integer forall a. Ord a => a -> a -> a max Integer 1 (Natural -> Integer forall a b. (Integral a, Num b) => a -> b fromIntegral (PParams era -> HKD Identity Natural forall (f :: * -> *) era. PParams' f era -> HKD f Natural _nOpt PParams era pp)) in if KeyHash 'StakePool (Crypto era) kh KeyHash 'StakePool (Crypto era) -> Set (KeyHash 'StakePool (Crypto era)) -> Bool forall a. Ord a => a -> Set a -> Bool `Set.member` Set (KeyHash 'StakePool (Crypto era)) topPools then Rational -> StakeShare StakeShare (Rational -> Rational -> Rational forall a. Ord a => a -> a -> a max (Rational sigma Rational -> Rational -> Rational forall a. Num a => a -> a -> a + Rational t) Rational z0) else Rational -> StakeShare StakeShare (Rational s Rational -> Rational -> Rational forall a. Num a => a -> a -> a + Rational t) -- | Compute the Non-Myopic Pool Member Reward -- -- This function implements equation (3) in section 5.6.4 -- of "Design Specification for Delegation and Incentives in Cardano". -- Note that the protocol parameters and the reward pot are implicit -- in the design document. Additionally, instead of passing a rank -- r to compare with k, we pass the top k desirable pools and -- check for membership. nonMyopicMemberRew :: PParams era -> Coin -> PoolParams era -> StakeShare -> StakeShare -> StakeShare -> Set (KeyHash 'StakePool (Crypto era)) -> PerformanceEstimate -> Coin nonMyopicMemberRew :: PParams era -> Coin -> PoolParams era -> StakeShare -> StakeShare -> StakeShare -> Set (KeyHash 'StakePool (Crypto era)) -> PerformanceEstimate -> Coin nonMyopicMemberRew PParams era pp Coin rPot PoolParams era pool StakeShare s StakeShare sigma StakeShare t Set (KeyHash 'StakePool (Crypto era)) topPools (PerformanceEstimate Double p) = let nm :: StakeShare nm = PParams era -> StakeShare -> StakeShare -> StakeShare -> KeyHash 'StakePool (Crypto era) -> Set (KeyHash 'StakePool (Crypto era)) -> StakeShare forall era. PParams era -> StakeShare -> StakeShare -> StakeShare -> KeyHash 'StakePool (Crypto era) -> Set (KeyHash 'StakePool (Crypto era)) -> StakeShare nonMyopicStake PParams era pp StakeShare s StakeShare sigma StakeShare t (PoolParams era -> KeyHash 'StakePool (Crypto era) forall era. PoolParams era -> KeyHash 'StakePool (Crypto era) _poolId PoolParams era pool) Set (KeyHash 'StakePool (Crypto era)) topPools f :: Coin f = PParams era -> Coin -> Rational -> Rational -> Coin forall era. PParams era -> Coin -> Rational -> Rational -> Coin maxPool PParams era pp Coin rPot (StakeShare -> Rational unStakeShare StakeShare nm) (StakeShare -> Rational unStakeShare StakeShare s) fHat :: Integer fHat = Double -> Integer forall a b. (RealFrac a, Integral b) => a -> b floor (Double p Double -> Double -> Double forall a. Num a => a -> a -> a * (Rational -> Double forall a. Fractional a => Rational -> a fromRational (Rational -> Double) -> (Coin -> Rational) -> Coin -> Double forall b c a. (b -> c) -> (a -> b) -> a -> c . Coin -> Rational coinToRational) Coin f) in Coin -> PoolParams era -> StakeShare -> StakeShare -> Coin forall era. Coin -> PoolParams era -> StakeShare -> StakeShare -> Coin memberRew (Integer -> Coin Coin Integer fHat) PoolParams era pool StakeShare t StakeShare nm