{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Cardano.Ledger.Shelley.LedgerState.PulsingReward (
  startStep,
  pulseStep,
  completeStep,
  createRUpd,
  completeRupd,
  circulation,
  updateNonMyopic,
  decayFactor,
)
where

import Cardano.Ledger.Address (RewardAccount (..), raCredential)
import Cardano.Ledger.BaseTypes (
  ActiveSlotCoeff,
  BlocksMade (..),
  BoundedRational (..),
  ShelleyBase,
  activeSlotVal,
 )
import Cardano.Ledger.CertState (
  CertState (..),
  rewards,
 )
import Cardano.Ledger.Coin (
  Coin (..),
  DeltaCoin (..),
  rationalToCoinViaFloor,
  toDeltaCoin,
 )
import Cardano.Ledger.Core
import Cardano.Ledger.EpochBoundary (
  SnapShot (..),
  SnapShots (..),
  Stake (..),
  sumAllStake,
  sumStakePerPool,
 )
import Cardano.Ledger.PoolParams (PoolParams (..))
import Cardano.Ledger.Shelley.Governance (EraGov)
import qualified Cardano.Ledger.Shelley.HardForks as HardForks
import Cardano.Ledger.Shelley.LedgerState.Types
import Cardano.Ledger.Shelley.PoolRank (
  Likelihood (..),
  NonMyopic (..),
  applyDecay,
  leaderProbability,
  likelihood,
 )
import Cardano.Ledger.Shelley.RewardUpdate (
  FreeVars (..),
  Pulser,
  PulsingRewUpdate (..),
  RewardAns (..),
  RewardEvent,
  RewardPulser (..),
  RewardSnapShot (..),
  RewardUpdate (..),
 )
import Cardano.Ledger.Shelley.Rewards (
  PoolRewardInfo (..),
  StakeShare (..),
  leaderRewardToGeneral,
  mkPoolRewardInfo,
  sumRewards,
 )
import Cardano.Ledger.Slot (EpochSize (..))
import qualified Cardano.Ledger.UMap as UM
import Cardano.Ledger.Val ((<->))
import Data.Group (invert)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Pulse (Pulsable (..), completeM)
import Data.Ratio ((%))
import qualified Data.Set as Set
import qualified Data.VMap as VMap
import Data.Word (Word64)
import Lens.Micro ((^.))

-- =============================
-- To prevent a huge pause, at the stability point, we spread out the
-- Calculation of rewards over many blocks. We do this in 3 phases. Phase 1
-- of a reward upate is a pure computation, computing some parameters which
-- become fixed at the time when we reach the stability point. One of these
-- parameters is a Pulser, i.e. a computation that when pulseM'ed computes
-- a portion of what is required, so that the whole compuation can be spread out in time.

startStep ::
  forall era.
  EraGov era =>
  EpochSize ->
  BlocksMade ->
  EpochState era ->
  Coin ->
  ActiveSlotCoeff ->
  Word64 ->
  PulsingRewUpdate
startStep :: forall era.
EraGov era =>
EpochSize
-> BlocksMade
-> EpochState era
-> Coin
-> ActiveSlotCoeff
-> Word64
-> PulsingRewUpdate
startStep EpochSize
slotsPerEpoch b :: BlocksMade
b@(BlocksMade Map (KeyHash 'StakePool) Natural
b') es :: EpochState era
es@(EpochState AccountState
acnt LedgerState era
ls SnapShots
ss NonMyopic
nm) Coin
maxSupply ActiveSlotCoeff
asc Word64
secparam =
  let SnapShot Stake
stake VMap VB VB (Credential 'Staking) (KeyHash 'StakePool)
delegs VMap VB VB (KeyHash 'StakePool) PoolParams
poolParams = SnapShots -> SnapShot
ssStakeGo SnapShots
ss
      numStakeCreds, k :: Rational
      numStakeCreds :: Rational
numStakeCreds = forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall (kv :: * -> *) k (vv :: * -> *) v.
Vector kv k =>
VMap kv vv k v -> Int
VMap.size forall a b. (a -> b) -> a -> b
$ Stake -> VMap VB VP (Credential 'Staking) (CompactForm Coin)
unStake Stake
stake)
      k :: Rational
k = forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
secparam
      -- We expect approximately 10k-many blocks to be produced each epoch.
      -- The reward calculation begins (4k/f)-many slots into the epoch,
      -- and we guarantee that it ends (2k/f)-many slots before the end
      -- of the epoch (to allow tools such as db-sync to see the reward
      -- values in advance of them being applied to the ledger state).
      --
      -- Therefore to evenly space out the reward calculation, we divide
      -- the number of stake credentials by 4k in order to determine how many
      -- stake credential rewards we should calculate each block.
      -- If it does not finish in this amount of time, the calculation is
      -- forced to completion.
      pulseSize :: Int
pulseSize = forall a. Ord a => a -> a -> a
max Int
1 (forall a b. (RealFrac a, Integral b) => a -> b
ceiling (Rational
numStakeCreds forall a. Fractional a => a -> a -> a
/ (Rational
4 forall a. Num a => a -> a -> a
* Rational
k)))
      -- We now compute the amount of total rewards that can potentially be given
      -- out this epoch, and the adjustments to the reserves and the treasury.
      Coin Integer
reserves = AccountState -> Coin
asReserves AccountState
acnt
      ds :: DState era
ds = forall era. CertState era -> DState era
certDState forall a b. (a -> b) -> a -> b
$ forall era. LedgerState era -> CertState era
lsCertState LedgerState era
ls
      -- reserves and rewards change
      pr :: PParams era
pr = EpochState era
es forall s a. s -> Getting a s a -> a
^. forall era. EraGov era => Lens' (EpochState era) (PParams era)
prevPParamsEpochStateL
      deltaR1 :: Coin
deltaR1 =
        Rational -> Coin
rationalToCoinViaFloor forall a b. (a -> b) -> a -> b
$
          forall a. Ord a => a -> a -> a
min Rational
1 Rational
eta
            forall a. Num a => a -> a -> a
* forall r. BoundedRational r => r -> Rational
unboundRational (PParams era
pr forall s a. s -> Getting a s a -> a
^. forall era. EraPParams era => Lens' (PParams era) UnitInterval
ppRhoL)
            forall a. Num a => a -> a -> a
* forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
reserves
      d :: Rational
d = forall r. BoundedRational r => r -> Rational
unboundRational (PParams era
pr forall s a. s -> Getting a s a -> a
^. forall era.
EraPParams era =>
SimpleGetter (PParams era) UnitInterval
ppDG)
      expectedBlocks :: Integer
expectedBlocks =
        forall a b. (RealFrac a, Integral b) => a -> b
floor forall a b. (a -> b) -> a -> b
$
          (Rational
1 forall a. Num a => a -> a -> a
- Rational
d) forall a. Num a => a -> a -> a
* forall r. BoundedRational r => r -> Rational
unboundRational (ActiveSlotCoeff -> PositiveUnitInterval
activeSlotVal ActiveSlotCoeff
asc) forall a. Num a => a -> a -> a
* forall a b. (Integral a, Num b) => a -> b
fromIntegral (EpochSize -> Word64
unEpochSize EpochSize
slotsPerEpoch)
      -- TODO asc is a global constant, and slotsPerEpoch should not change often at all,
      -- it would be nice to not have to compute expectedBlocks every epoch
      blocksMade :: Integer
blocksMade = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall a b k. (a -> b -> b) -> b -> Map k a -> b
Map.foldr forall a. Num a => a -> a -> a
(+) Natural
0 Map (KeyHash 'StakePool) Natural
b' :: Integer
      eta :: Rational
eta
        | forall r. BoundedRational r => r -> Rational
unboundRational (PParams era
pr forall s a. s -> Getting a s a -> a
^. forall era.
EraPParams era =>
SimpleGetter (PParams era) UnitInterval
ppDG) forall a. Ord a => a -> a -> Bool
>= Rational
0.8 = Rational
1
        | Bool
otherwise = Integer
blocksMade forall a. Integral a => a -> a -> Ratio a
% Integer
expectedBlocks
      Coin Integer
rPot = SnapShots -> Coin
ssFee SnapShots
ss forall a. Semigroup a => a -> a -> a
<> Coin
deltaR1
      deltaT1 :: Integer
deltaT1 = forall a b. (RealFrac a, Integral b) => a -> b
floor forall a b. (a -> b) -> a -> b
$ forall r. BoundedRational r => r -> Rational
unboundRational (PParams era
pr forall s a. s -> Getting a s a -> a
^. forall era. EraPParams era => Lens' (PParams era) UnitInterval
ppTauL) forall a. Num a => a -> a -> a
* forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
rPot
      _R :: Coin
_R = Integer -> Coin
Coin forall a b. (a -> b) -> a -> b
$ Integer
rPot forall a. Num a => a -> a -> a
- Integer
deltaT1
      -- We now compute stake pool specific values that are needed for computing
      -- member and leader rewards.
      activeStake :: Coin
activeStake = Stake -> Coin
sumAllStake Stake
stake
      totalStake :: Coin
totalStake = forall era. EpochState era -> Coin -> Coin
circulation EpochState era
es Coin
maxSupply
      stakePerPool :: Map (KeyHash 'StakePool) Coin
stakePerPool = VMap VB VB (Credential 'Staking) (KeyHash 'StakePool)
-> Stake -> Map (KeyHash 'StakePool) Coin
sumStakePerPool VMap VB VB (Credential 'Staking) (KeyHash 'StakePool)
delegs Stake
stake
      mkPoolRewardInfoCurry :: PoolParams -> Either StakeShare PoolRewardInfo
mkPoolRewardInfoCurry =
        forall era.
EraPParams era =>
PParams era
-> Coin
-> BlocksMade
-> Natural
-> Stake
-> VMap VB VB (Credential 'Staking) (KeyHash 'StakePool)
-> Map (KeyHash 'StakePool) Coin
-> Coin
-> Coin
-> PoolParams
-> Either StakeShare PoolRewardInfo
mkPoolRewardInfo
          PParams era
pr
          Coin
_R
          BlocksMade
b
          (forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
blocksMade)
          Stake
stake
          VMap VB VB (Credential 'Staking) (KeyHash 'StakePool)
delegs
          Map (KeyHash 'StakePool) Coin
stakePerPool
          Coin
totalStake
          Coin
activeStake
      -- We map over the registered stake pools to compute the revelant
      -- stake pool specific values.
      allPoolInfo :: VMap VB VB (KeyHash 'StakePool) (Either StakeShare PoolRewardInfo)
allPoolInfo = forall (vv :: * -> *) a b (kv :: * -> *) k.
(Vector vv a, Vector vv b) =>
(a -> b) -> VMap kv vv k a -> VMap kv vv k b
VMap.map PoolParams -> Either StakeShare PoolRewardInfo
mkPoolRewardInfoCurry VMap VB VB (KeyHash 'StakePool) PoolParams
poolParams

      -- Stake pools that do not produce any blocks get no rewards,
      -- but some information is still needed from non-block-producing
      -- pools for the ranking algorithm used by the wallets.
      blockProducingPoolInfo :: Map (KeyHash 'StakePool) PoolRewardInfo
blockProducingPoolInfo = forall (kv :: * -> *) k (vv :: * -> *) v.
(Vector kv k, Vector vv v) =>
VMap kv vv k v -> Map k v
VMap.toMap forall a b. (a -> b) -> a -> b
$ forall (kv :: * -> *) k (vv :: * -> *) a b.
(Vector kv k, Vector vv a, Vector vv b) =>
(a -> Maybe b) -> VMap kv vv k a -> VMap kv vv k b
VMap.mapMaybe (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) forall a. a -> Maybe a
Just) VMap VB VB (KeyHash 'StakePool) (Either StakeShare PoolRewardInfo)
allPoolInfo
      getSigma :: PoolRewardInfo -> Rational
getSigma = StakeShare -> Rational
unStakeShare forall b c a. (b -> c) -> (a -> b) -> a -> c
. PoolRewardInfo -> StakeShare
poolRelativeStake
      makeLikelihoods :: Either StakeShare PoolRewardInfo -> Likelihood
makeLikelihoods = \case
        -- This pool produced no blocks this epoch
        Left (StakeShare Rational
sigma) ->
          Natural -> Double -> EpochSize -> Likelihood
likelihood
            Natural
0
            (ActiveSlotCoeff -> Rational -> UnitInterval -> Double
leaderProbability ActiveSlotCoeff
asc Rational
sigma forall a b. (a -> b) -> a -> b
$ PParams era
pr forall s a. s -> Getting a s a -> a
^. forall era.
EraPParams era =>
SimpleGetter (PParams era) UnitInterval
ppDG)
            EpochSize
slotsPerEpoch
        -- This pool produced at least one block this epoch
        Right PoolRewardInfo
info ->
          Natural -> Double -> EpochSize -> Likelihood
likelihood
            (PoolRewardInfo -> Natural
poolBlocks PoolRewardInfo
info)
            (ActiveSlotCoeff -> Rational -> UnitInterval -> Double
leaderProbability ActiveSlotCoeff
asc (PoolRewardInfo -> Rational
getSigma PoolRewardInfo
info) forall a b. (a -> b) -> a -> b
$ PParams era
pr forall s a. s -> Getting a s a -> a
^. forall era.
EraPParams era =>
SimpleGetter (PParams era) UnitInterval
ppDG)
            EpochSize
slotsPerEpoch
      newLikelihoods :: Map (KeyHash 'StakePool) Likelihood
newLikelihoods = forall (kv :: * -> *) k (vv :: * -> *) v.
(Vector kv k, Vector vv v) =>
VMap kv vv k v -> Map k v
VMap.toMap forall a b. (a -> b) -> a -> b
$ forall (vv :: * -> *) a b (kv :: * -> *) k.
(Vector vv a, Vector vv b) =>
(a -> b) -> VMap kv vv k a -> VMap kv vv k b
VMap.map Either StakeShare PoolRewardInfo -> Likelihood
makeLikelihoods VMap VB VB (KeyHash 'StakePool) (Either StakeShare PoolRewardInfo)
allPoolInfo
      -- We now compute the leader rewards for each stake pool.
      collectLRs :: RewardEvent -> PoolRewardInfo -> RewardEvent
collectLRs RewardEvent
acc PoolRewardInfo
poolRI =
        let rewardAccount :: Credential 'Staking
rewardAccount = RewardAccount -> Credential 'Staking
raCredential forall b c a. (b -> c) -> (a -> b) -> a -> c
. PoolParams -> RewardAccount
ppRewardAccount forall b c a. (b -> c) -> (a -> b) -> a -> c
. PoolRewardInfo -> PoolParams
poolPs forall a b. (a -> b) -> a -> b
$ PoolRewardInfo
poolRI
            packageLeaderReward :: PoolRewardInfo -> Set Reward
packageLeaderReward = forall a. a -> Set a
Set.singleton forall b c a. (b -> c) -> (a -> b) -> a -> c
. LeaderOnlyReward -> Reward
leaderRewardToGeneral forall b c a. (b -> c) -> (a -> b) -> a -> c
. PoolRewardInfo -> LeaderOnlyReward
poolLeaderReward
         in if ProtVer -> Bool
HardForks.forgoRewardPrefilter (PParams era
pr forall s a. s -> Getting a s a -> a
^. forall era. EraPParams era => Lens' (PParams era) ProtVer
ppProtocolVersionL)
              Bool -> Bool -> Bool
|| Credential 'Staking
rewardAccount forall k v. k -> UView k v -> Bool
`UM.member` forall era. DState era -> UView (Credential 'Staking) RDPair
rewards DState era
ds
              then
                forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith
                  forall a. Ord a => Set a -> Set a -> Set a
Set.union
                  Credential 'Staking
rewardAccount
                  (PoolRewardInfo -> Set Reward
packageLeaderReward PoolRewardInfo
poolRI)
                  RewardEvent
acc
              else RewardEvent
acc
      -- The data in 'RewardSnapShot' will be used to finish up the reward calculation
      -- once all the member rewards are complete.
      rewsnap :: RewardSnapShot
rewsnap =
        RewardSnapShot
          { rewFees :: Coin
rewFees = SnapShots -> Coin
ssFee SnapShots
ss
          , rewProtocolVersion :: ProtVer
rewProtocolVersion = PParams era
pr forall s a. s -> Getting a s a -> a
^. forall era. EraPParams era => Lens' (PParams era) ProtVer
ppProtocolVersionL
          , rewNonMyopic :: NonMyopic
rewNonMyopic = NonMyopic
nm
          , rewDeltaR1 :: Coin
rewDeltaR1 = Coin
deltaR1
          , rewR :: Coin
rewR = Coin
_R
          , rewDeltaT1 :: Coin
rewDeltaT1 = Integer -> Coin
Coin Integer
deltaT1
          , rewLikelihoods :: Map (KeyHash 'StakePool) Likelihood
rewLikelihoods = Map (KeyHash 'StakePool) Likelihood
newLikelihoods
          , rewLeaders :: RewardEvent
rewLeaders = forall a b k. (a -> b -> a) -> a -> Map k b -> a
Map.foldl' RewardEvent -> PoolRewardInfo -> RewardEvent
collectLRs forall a. Monoid a => a
mempty Map (KeyHash 'StakePool) PoolRewardInfo
blockProducingPoolInfo
          }
      -- The data in 'FreeVars' to supply individual stake pool members with
      -- the neccessary information to compute their individual rewards.
      free :: FreeVars
free =
        VMap VB VB (Credential 'Staking) (KeyHash 'StakePool)
-> Set (Credential 'Staking)
-> Coin
-> ProtVer
-> Map (KeyHash 'StakePool) PoolRewardInfo
-> FreeVars
FreeVars
          VMap VB VB (Credential 'Staking) (KeyHash 'StakePool)
delegs
          (forall k v. UView k v -> Set k
UM.domain forall a b. (a -> b) -> a -> b
$ forall era. DState era -> UView (Credential 'Staking) RDPair
rewards DState era
ds)
          Coin
totalStake
          (PParams era
pr forall s a. s -> Getting a s a -> a
^. forall era. EraPParams era => Lens' (PParams era) ProtVer
ppProtocolVersionL)
          Map (KeyHash 'StakePool) PoolRewardInfo
blockProducingPoolInfo
      pulser :: Pulser
      pulser :: Pulser
pulser =
        forall ans (m :: * -> *).
(ans ~ RewardAns, m ~ ReaderT Globals Identity) =>
Int
-> FreeVars
-> VMap VB VP (Credential 'Staking) (CompactForm Coin)
-> ans
-> RewardPulser m ans
RSLP
          Int
pulseSize
          FreeVars
free
          (Stake -> VMap VB VP (Credential 'Staking) (CompactForm Coin)
unStake Stake
stake)
          (Map (Credential 'Staking) Reward -> RewardEvent -> RewardAns
RewardAns forall k a. Map k a
Map.empty forall k a. Map k a
Map.empty)
   in RewardSnapShot -> Pulser -> PulsingRewUpdate
Pulsing RewardSnapShot
rewsnap Pulser
pulser

-- Phase 2

-- | Run the pulser for a bit. If is has nothing left to do, complete it.
pulseStep ::
  PulsingRewUpdate ->
  ShelleyBase (PulsingRewUpdate, RewardEvent)
pulseStep :: PulsingRewUpdate -> ShelleyBase (PulsingRewUpdate, RewardEvent)
pulseStep (Complete RewardUpdate
r_) = forall (f :: * -> *) a. Applicative f => a -> f a
pure (RewardUpdate -> PulsingRewUpdate
Complete RewardUpdate
r_, forall a. Monoid a => a
mempty)
pulseStep p :: PulsingRewUpdate
p@(Pulsing RewardSnapShot
_ Pulser
pulser) | forall (pulse :: (* -> *) -> * -> *) (m :: * -> *) ans.
Pulsable pulse =>
pulse m ans -> Bool
done Pulser
pulser = PulsingRewUpdate -> ShelleyBase (PulsingRewUpdate, RewardEvent)
completeStep PulsingRewUpdate
p
pulseStep (Pulsing RewardSnapShot
rewsnap Pulser
pulser) = do
  -- The pulser might compute provenance, but using pulseM here does not compute it
  p2 :: Pulser
p2@(RSLP Int
_ FreeVars
_ VMap VB VP (Credential 'Staking) (CompactForm Coin)
_ (RewardAns Map (Credential 'Staking) Reward
_ RewardEvent
event)) <- forall (pulse :: (* -> *) -> * -> *) (m :: * -> *) ans.
(Pulsable pulse, Monad m) =>
pulse m ans -> m (pulse m ans)
pulseM Pulser
pulser
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (RewardSnapShot -> Pulser -> PulsingRewUpdate
Pulsing RewardSnapShot
rewsnap Pulser
p2, RewardEvent
event)

-- Phase 3

completeStep ::
  PulsingRewUpdate ->
  ShelleyBase (PulsingRewUpdate, RewardEvent)
completeStep :: PulsingRewUpdate -> ShelleyBase (PulsingRewUpdate, RewardEvent)
completeStep (Complete RewardUpdate
r) = forall (f :: * -> *) a. Applicative f => a -> f a
pure (RewardUpdate -> PulsingRewUpdate
Complete RewardUpdate
r, forall a. Monoid a => a
mempty)
completeStep (Pulsing RewardSnapShot
rewsnap Pulser
pulser) = do
  (RewardUpdate
p2, !RewardEvent
event) <- PulsingRewUpdate -> ShelleyBase (RewardUpdate, RewardEvent)
completeRupd (RewardSnapShot -> Pulser -> PulsingRewUpdate
Pulsing RewardSnapShot
rewsnap Pulser
pulser)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (RewardUpdate -> PulsingRewUpdate
Complete RewardUpdate
p2, RewardEvent
event)

-- | Phase 3 of reward update has several parts
--   a) completeM the pulser (in case there are still computions to run)
--   b) Combine the pulser provenance with the RewardProvenance
--   c) Construct the final RewardUpdate
--   d) Add the leader rewards to both the events and the computed Rewards
completeRupd ::
  PulsingRewUpdate ->
  ShelleyBase (RewardUpdate, RewardEvent)
completeRupd :: PulsingRewUpdate -> ShelleyBase (RewardUpdate, RewardEvent)
completeRupd (Complete RewardUpdate
x) = forall (f :: * -> *) a. Applicative f => a -> f a
pure (RewardUpdate
x, forall a. Monoid a => a
mempty)
completeRupd
  ( Pulsing
      RewardSnapShot
        { rewDeltaR1 :: RewardSnapShot -> Coin
rewDeltaR1 = Coin
deltaR1
        , rewFees :: RewardSnapShot -> Coin
rewFees = Coin
feesSS
        , rewR :: RewardSnapShot -> Coin
rewR = Coin
oldr
        , rewDeltaT1 :: RewardSnapShot -> Coin
rewDeltaT1 = Coin Integer
deltaT1
        , rewNonMyopic :: RewardSnapShot -> NonMyopic
rewNonMyopic = NonMyopic
nm
        , rewLikelihoods :: RewardSnapShot -> Map (KeyHash 'StakePool) Likelihood
rewLikelihoods = Map (KeyHash 'StakePool) Likelihood
newLikelihoods
        , rewLeaders :: RewardSnapShot -> RewardEvent
rewLeaders = RewardEvent
lrewards
        , rewProtocolVersion :: RewardSnapShot -> ProtVer
rewProtocolVersion = ProtVer
protVer
        }
      pulser :: Pulser
pulser@(RSLP Int
_size FreeVars
_free VMap VB VP (Credential 'Staking) (CompactForm Coin)
_source (RewardAns Map (Credential 'Staking) Reward
prev RewardEvent
_now)) -- If prev is Map.empty, we have never pulsed.
    ) = do
    RewardAns Map (Credential 'Staking) Reward
rs_ RewardEvent
events <- forall (pulse :: (* -> *) -> * -> *) (m :: * -> *) ans.
(Pulsable pulse, Monad m) =>
pulse m ans -> m ans
completeM Pulser
pulser
    let rs' :: RewardEvent
rs' = forall a b k. (a -> b) -> Map k a -> Map k b
Map.map forall a. a -> Set a
Set.singleton Map (Credential 'Staking) Reward
rs_
    let rs'' :: RewardEvent
rs'' = forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith forall a. Ord a => Set a -> Set a -> Set a
Set.union RewardEvent
rs' RewardEvent
lrewards
    let !events' :: RewardEvent
events' = forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith forall a. Ord a => Set a -> Set a -> Set a
Set.union RewardEvent
events RewardEvent
lrewards

    let deltaR2 :: Coin
deltaR2 = Coin
oldr forall t. Val t => t -> t -> t
<-> ProtVer -> RewardEvent -> Coin
sumRewards ProtVer
protVer RewardEvent
rs''
    let neverpulsed :: Bool
neverpulsed = forall k a. Map k a -> Bool
Map.null Map (Credential 'Staking) Reward
prev
        !newevent :: RewardEvent
newevent =
          if Bool
neverpulsed -- If we have never pulsed then everything in the computed needs to added to the event
            then forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith forall a. Ord a => Set a -> Set a -> Set a
Set.union RewardEvent
rs' RewardEvent
events'
            else RewardEvent
events'
    forall (f :: * -> *) a. Applicative f => a -> f a
pure
      ( RewardUpdate
          { deltaT :: DeltaCoin
deltaT = Integer -> DeltaCoin
DeltaCoin Integer
deltaT1
          , deltaR :: DeltaCoin
deltaR = forall m. Group m => m -> m
invert (Coin -> DeltaCoin
toDeltaCoin Coin
deltaR1) forall a. Semigroup a => a -> a -> a
<> Coin -> DeltaCoin
toDeltaCoin Coin
deltaR2
          , rs :: RewardEvent
rs = RewardEvent
rs''
          , deltaF :: DeltaCoin
deltaF = forall m. Group m => m -> m
invert (Coin -> DeltaCoin
toDeltaCoin Coin
feesSS)
          , nonMyopic :: NonMyopic
nonMyopic = NonMyopic
-> Coin -> Map (KeyHash 'StakePool) Likelihood -> NonMyopic
updateNonMyopic NonMyopic
nm Coin
oldr Map (KeyHash 'StakePool) Likelihood
newLikelihoods
          }
      , RewardEvent
newevent
      )

-- | To create a reward update, run all 3 phases
--   This function is not used in the rules, so it ignores RewardEvents
createRUpd ::
  forall era.
  EraGov era =>
  EpochSize ->
  BlocksMade ->
  EpochState era ->
  Coin ->
  ActiveSlotCoeff ->
  Word64 ->
  ShelleyBase RewardUpdate
createRUpd :: forall era.
EraGov era =>
EpochSize
-> BlocksMade
-> EpochState era
-> Coin
-> ActiveSlotCoeff
-> Word64
-> ShelleyBase RewardUpdate
createRUpd EpochSize
slotsPerEpoch BlocksMade
blocksmade EpochState era
epstate Coin
maxSupply ActiveSlotCoeff
asc Word64
secparam = do
  let step1 :: PulsingRewUpdate
step1 = forall era.
EraGov era =>
EpochSize
-> BlocksMade
-> EpochState era
-> Coin
-> ActiveSlotCoeff
-> Word64
-> PulsingRewUpdate
startStep EpochSize
slotsPerEpoch BlocksMade
blocksmade EpochState era
epstate Coin
maxSupply ActiveSlotCoeff
asc Word64
secparam
  (PulsingRewUpdate
step2, RewardEvent
_event) <- PulsingRewUpdate -> ShelleyBase (PulsingRewUpdate, RewardEvent)
pulseStep PulsingRewUpdate
step1
  case PulsingRewUpdate
step2 of
    Complete RewardUpdate
r -> forall (f :: * -> *) a. Applicative f => a -> f a
pure RewardUpdate
r
    Pulsing RewardSnapShot
rewsnap Pulser
pulser -> forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PulsingRewUpdate -> ShelleyBase (RewardUpdate, RewardEvent)
completeRupd (RewardSnapShot -> Pulser -> PulsingRewUpdate
Pulsing RewardSnapShot
rewsnap Pulser
pulser)

-- | Calculate the current circulation
--
-- This is used in the rewards calculation, and for API endpoints for pool ranking.
circulation :: EpochState era -> Coin -> Coin
circulation :: forall era. EpochState era -> Coin -> Coin
circulation (EpochState AccountState
acnt LedgerState era
_ SnapShots
_ NonMyopic
_) Coin
supply =
  Coin
supply forall t. Val t => t -> t -> t
<-> AccountState -> Coin
asReserves AccountState
acnt

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

updateNonMyopic ::
  NonMyopic ->
  Coin ->
  Map (KeyHash 'StakePool) Likelihood ->
  NonMyopic
updateNonMyopic :: NonMyopic
-> Coin -> Map (KeyHash 'StakePool) Likelihood -> NonMyopic
updateNonMyopic NonMyopic
nm Coin
rPot_ Map (KeyHash 'StakePool) Likelihood
newLikelihoods =
  NonMyopic
nm
    { likelihoodsNM :: Map (KeyHash 'StakePool) Likelihood
likelihoodsNM = Map (KeyHash 'StakePool) Likelihood
updatedLikelihoods
    , rewardPotNM :: Coin
rewardPotNM = Coin
rPot_
    }
  where
    history :: Map (KeyHash 'StakePool) Likelihood
history = NonMyopic -> Map (KeyHash 'StakePool) Likelihood
likelihoodsNM NonMyopic
nm
    performance :: KeyHash 'StakePool -> Likelihood -> Likelihood
performance KeyHash 'StakePool
kh Likelihood
newPerf =
      forall b a. b -> (a -> b) -> Maybe a -> b
maybe
        forall a. Monoid a => a
mempty
        (Float -> Likelihood -> Likelihood
applyDecay Float
decayFactor)
        (forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup KeyHash 'StakePool
kh Map (KeyHash 'StakePool) Likelihood
history)
        forall a. Semigroup a => a -> a -> a
<> Likelihood
newPerf
    updatedLikelihoods :: Map (KeyHash 'StakePool) Likelihood
updatedLikelihoods = forall k a b. (k -> a -> b) -> Map k a -> Map k b
Map.mapWithKey KeyHash 'StakePool -> Likelihood -> Likelihood
performance Map (KeyHash 'StakePool) Likelihood
newLikelihoods