{-# 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.Keys (KeyHash, KeyRole (StakePool))
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 (EraCrypto era) ->
  EpochState era ->
  Coin ->
  ActiveSlotCoeff ->
  Word64 ->
  PulsingRewUpdate (EraCrypto era)
startStep :: forall era.
EraGov era =>
EpochSize
-> BlocksMade (EraCrypto era)
-> EpochState era
-> Coin
-> ActiveSlotCoeff
-> Word64
-> PulsingRewUpdate (EraCrypto era)
startStep EpochSize
slotsPerEpoch b :: BlocksMade (EraCrypto era)
b@(BlocksMade Map (KeyHash 'StakePool (EraCrypto era)) Natural
b') es :: EpochState era
es@(EpochState AccountState
acnt LedgerState era
ls SnapShots (EraCrypto era)
ss NonMyopic (EraCrypto era)
nm) Coin
maxSupply ActiveSlotCoeff
asc Word64
secparam =
  let SnapShot Stake (EraCrypto era)
stake VMap
  VB
  VB
  (Credential 'Staking (EraCrypto era))
  (KeyHash 'StakePool (EraCrypto era))
delegs VMap
  VB
  VB
  (KeyHash 'StakePool (EraCrypto era))
  (PoolParams (EraCrypto era))
poolParams = forall c. SnapShots c -> SnapShot c
ssStakeGo SnapShots (EraCrypto era)
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
$ forall c.
Stake c -> VMap VB VP (Credential 'Staking c) (CompactForm Coin)
unStake Stake (EraCrypto era)
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 (EraCrypto era)) 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 = forall c. SnapShots c -> Coin
ssFee SnapShots (EraCrypto era)
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 = forall c. Stake c -> Coin
sumAllStake Stake (EraCrypto era)
stake
      totalStake :: Coin
totalStake = forall era. EpochState era -> Coin -> Coin
circulation EpochState era
es Coin
maxSupply
      stakePerPool :: Map (KeyHash 'StakePool (EraCrypto era)) Coin
stakePerPool = forall c.
VMap VB VB (Credential 'Staking c) (KeyHash 'StakePool c)
-> Stake c -> Map (KeyHash 'StakePool c) Coin
sumStakePerPool VMap
  VB
  VB
  (Credential 'Staking (EraCrypto era))
  (KeyHash 'StakePool (EraCrypto era))
delegs Stake (EraCrypto era)
stake
      mkPoolRewardInfoCurry :: PoolParams (EraCrypto era)
-> Either StakeShare (PoolRewardInfo (EraCrypto era))
mkPoolRewardInfoCurry =
        forall era.
EraPParams era =>
PParams era
-> Coin
-> BlocksMade (EraCrypto era)
-> Natural
-> Stake (EraCrypto era)
-> VMap
     VB
     VB
     (Credential 'Staking (EraCrypto era))
     (KeyHash 'StakePool (EraCrypto era))
-> Map (KeyHash 'StakePool (EraCrypto era)) Coin
-> Coin
-> Coin
-> PoolParams (EraCrypto era)
-> Either StakeShare (PoolRewardInfo (EraCrypto era))
mkPoolRewardInfo
          PParams era
pr
          Coin
_R
          BlocksMade (EraCrypto era)
b
          (forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
blocksMade)
          Stake (EraCrypto era)
stake
          VMap
  VB
  VB
  (Credential 'Staking (EraCrypto era))
  (KeyHash 'StakePool (EraCrypto era))
delegs
          Map (KeyHash 'StakePool (EraCrypto era)) 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 (EraCrypto era))
  (Either StakeShare (PoolRewardInfo (EraCrypto era)))
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 (EraCrypto era)
-> Either StakeShare (PoolRewardInfo (EraCrypto era))
mkPoolRewardInfoCurry VMap
  VB
  VB
  (KeyHash 'StakePool (EraCrypto era))
  (PoolParams (EraCrypto era))
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 (EraCrypto era))
  (PoolRewardInfo (EraCrypto era))
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 (EraCrypto era))
  (Either StakeShare (PoolRewardInfo (EraCrypto era)))
allPoolInfo
      getSigma :: PoolRewardInfo c -> Rational
getSigma = StakeShare -> Rational
unStakeShare forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c. PoolRewardInfo c -> StakeShare
poolRelativeStake
      makeLikelihoods :: Either StakeShare (PoolRewardInfo (EraCrypto era)) -> 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 (EraCrypto era)
info ->
          Natural -> Double -> EpochSize -> Likelihood
likelihood
            (forall c. PoolRewardInfo c -> Natural
poolBlocks PoolRewardInfo (EraCrypto era)
info)
            (ActiveSlotCoeff -> Rational -> UnitInterval -> Double
leaderProbability ActiveSlotCoeff
asc (forall {c}. PoolRewardInfo c -> Rational
getSigma PoolRewardInfo (EraCrypto era)
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 (EraCrypto era)) 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 (EraCrypto era)) -> Likelihood
makeLikelihoods VMap
  VB
  VB
  (KeyHash 'StakePool (EraCrypto era))
  (Either StakeShare (PoolRewardInfo (EraCrypto era)))
allPoolInfo
      -- We now compute the leader rewards for each stake pool.
      collectLRs :: Map
  (Credential 'Staking (EraCrypto era))
  (Set (Reward (EraCrypto era)))
-> PoolRewardInfo (EraCrypto era)
-> Map
     (Credential 'Staking (EraCrypto era))
     (Set (Reward (EraCrypto era)))
collectLRs Map
  (Credential 'Staking (EraCrypto era))
  (Set (Reward (EraCrypto era)))
acc PoolRewardInfo (EraCrypto era)
poolRI =
        let rewardAccount :: Credential 'Staking (EraCrypto era)
rewardAccount = forall c. RewardAccount c -> Credential 'Staking c
raCredential forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c. PoolParams c -> RewardAccount c
ppRewardAccount forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c. PoolRewardInfo c -> PoolParams c
poolPs forall a b. (a -> b) -> a -> b
$ PoolRewardInfo (EraCrypto era)
poolRI
            packageLeaderReward :: PoolRewardInfo c -> Set (Reward c)
packageLeaderReward = forall a. a -> Set a
Set.singleton forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c. LeaderOnlyReward c -> Reward c
leaderRewardToGeneral forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c. PoolRewardInfo c -> LeaderOnlyReward c
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 (EraCrypto era)
rewardAccount forall k c v. k -> UView c k v -> Bool
`UM.member` forall era.
DState era
-> UView
     (EraCrypto era) (Credential 'Staking (EraCrypto era)) 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 (EraCrypto era)
rewardAccount
                  (forall {c}. PoolRewardInfo c -> Set (Reward c)
packageLeaderReward PoolRewardInfo (EraCrypto era)
poolRI)
                  Map
  (Credential 'Staking (EraCrypto era))
  (Set (Reward (EraCrypto era)))
acc
              else Map
  (Credential 'Staking (EraCrypto era))
  (Set (Reward (EraCrypto era)))
acc
      -- The data in 'RewardSnapShot' will be used to finish up the reward calculation
      -- once all the member rewards are complete.
      rewsnap :: RewardSnapShot (EraCrypto era)
rewsnap =
        RewardSnapShot
          { rewFees :: Coin
rewFees = forall c. SnapShots c -> Coin
ssFee SnapShots (EraCrypto era)
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 (EraCrypto era)
rewNonMyopic = NonMyopic (EraCrypto era)
nm
          , rewDeltaR1 :: Coin
rewDeltaR1 = Coin
deltaR1
          , rewR :: Coin
rewR = Coin
_R
          , rewDeltaT1 :: Coin
rewDeltaT1 = Integer -> Coin
Coin Integer
deltaT1
          , rewLikelihoods :: Map (KeyHash 'StakePool (EraCrypto era)) Likelihood
rewLikelihoods = Map (KeyHash 'StakePool (EraCrypto era)) Likelihood
newLikelihoods
          , rewLeaders :: Map
  (Credential 'Staking (EraCrypto era))
  (Set (Reward (EraCrypto era)))
rewLeaders = forall a b k. (a -> b -> a) -> a -> Map k b -> a
Map.foldl' Map
  (Credential 'Staking (EraCrypto era))
  (Set (Reward (EraCrypto era)))
-> PoolRewardInfo (EraCrypto era)
-> Map
     (Credential 'Staking (EraCrypto era))
     (Set (Reward (EraCrypto era)))
collectLRs forall a. Monoid a => a
mempty Map
  (KeyHash 'StakePool (EraCrypto era))
  (PoolRewardInfo (EraCrypto era))
blockProducingPoolInfo
          }
      -- The data in 'FreeVars' to supply individual stake pool members with
      -- the neccessary information to compute their individual rewards.
      free :: FreeVars (EraCrypto era)
free =
        forall c.
VMap VB VB (Credential 'Staking c) (KeyHash 'StakePool c)
-> Set (Credential 'Staking c)
-> Coin
-> ProtVer
-> Map (KeyHash 'StakePool c) (PoolRewardInfo c)
-> FreeVars c
FreeVars
          VMap
  VB
  VB
  (Credential 'Staking (EraCrypto era))
  (KeyHash 'StakePool (EraCrypto era))
delegs
          (forall c k v. UView c k v -> Set k
UM.domain forall a b. (a -> b) -> a -> b
$ forall era.
DState era
-> UView
     (EraCrypto era) (Credential 'Staking (EraCrypto era)) 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 (EraCrypto era))
  (PoolRewardInfo (EraCrypto era))
blockProducingPoolInfo
      pulser :: Pulser (EraCrypto era)
      pulser :: Pulser (EraCrypto era)
pulser =
        forall ans c (m :: * -> *).
(ans ~ RewardAns c, m ~ ShelleyBase) =>
Int
-> FreeVars c
-> VMap VB VP (Credential 'Staking c) (CompactForm Coin)
-> ans
-> RewardPulser c m ans
RSLP
          Int
pulseSize
          FreeVars (EraCrypto era)
free
          (forall c.
Stake c -> VMap VB VP (Credential 'Staking c) (CompactForm Coin)
unStake Stake (EraCrypto era)
stake)
          (forall c.
Map (Credential 'Staking c) (Reward c)
-> RewardEvent c -> RewardAns c
RewardAns forall k a. Map k a
Map.empty forall k a. Map k a
Map.empty)
   in forall c. RewardSnapShot c -> Pulser c -> PulsingRewUpdate c
Pulsing RewardSnapShot (EraCrypto era)
rewsnap Pulser (EraCrypto era)
pulser

-- Phase 2

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

-- Phase 3

completeStep ::
  PulsingRewUpdate c ->
  ShelleyBase (PulsingRewUpdate c, RewardEvent c)
completeStep :: forall c.
PulsingRewUpdate c
-> ShelleyBase (PulsingRewUpdate c, RewardEvent c)
completeStep (Complete RewardUpdate c
r) = forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall c. RewardUpdate c -> PulsingRewUpdate c
Complete RewardUpdate c
r, forall a. Monoid a => a
mempty)
completeStep (Pulsing RewardSnapShot c
rewsnap Pulser c
pulser) = do
  (RewardUpdate c
p2, !RewardEvent c
event) <- forall c.
PulsingRewUpdate c -> ShelleyBase (RewardUpdate c, RewardEvent c)
completeRupd (forall c. RewardSnapShot c -> Pulser c -> PulsingRewUpdate c
Pulsing RewardSnapShot c
rewsnap Pulser c
pulser)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall c. RewardUpdate c -> PulsingRewUpdate c
Complete RewardUpdate c
p2, RewardEvent c
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 c ->
  ShelleyBase (RewardUpdate c, RewardEvent c)
completeRupd :: forall c.
PulsingRewUpdate c -> ShelleyBase (RewardUpdate c, RewardEvent c)
completeRupd (Complete RewardUpdate c
x) = forall (f :: * -> *) a. Applicative f => a -> f a
pure (RewardUpdate c
x, forall a. Monoid a => a
mempty)
completeRupd
  ( Pulsing
      RewardSnapShot
        { rewDeltaR1 :: forall c. RewardSnapShot c -> Coin
rewDeltaR1 = Coin
deltaR1
        , rewFees :: forall c. RewardSnapShot c -> Coin
rewFees = Coin
feesSS
        , rewR :: forall c. RewardSnapShot c -> Coin
rewR = Coin
oldr
        , rewDeltaT1 :: forall c. RewardSnapShot c -> Coin
rewDeltaT1 = Coin Integer
deltaT1
        , rewNonMyopic :: forall c. RewardSnapShot c -> NonMyopic c
rewNonMyopic = NonMyopic c
nm
        , rewLikelihoods :: forall c. RewardSnapShot c -> Map (KeyHash 'StakePool c) Likelihood
rewLikelihoods = Map (KeyHash 'StakePool c) Likelihood
newLikelihoods
        , rewLeaders :: forall c.
RewardSnapShot c -> Map (Credential 'Staking c) (Set (Reward c))
rewLeaders = RewardEvent c
lrewards
        , rewProtocolVersion :: forall c. RewardSnapShot c -> ProtVer
rewProtocolVersion = ProtVer
protVer
        }
      pulser :: Pulser c
pulser@(RSLP Int
_size FreeVars c
_free VMap VB VP (Credential 'Staking c) (CompactForm Coin)
_source (RewardAns Map (Credential 'Staking c) (Reward c)
prev RewardEvent c
_now)) -- If prev is Map.empty, we have never pulsed.
    ) = do
    RewardAns Map (Credential 'Staking c) (Reward c)
rs_ RewardEvent c
events <- forall (pulse :: (* -> *) -> * -> *) (m :: * -> *) ans.
(Pulsable pulse, Monad m) =>
pulse m ans -> m ans
completeM Pulser c
pulser
    let rs' :: RewardEvent c
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 c) (Reward c)
rs_
    let rs'' :: RewardEvent c
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 c
rs' RewardEvent c
lrewards
    let !events' :: RewardEvent c
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 c
events RewardEvent c
lrewards

    let deltaR2 :: Coin
deltaR2 = Coin
oldr forall t. Val t => t -> t -> t
<-> forall c.
ProtVer -> Map (Credential 'Staking c) (Set (Reward c)) -> Coin
sumRewards ProtVer
protVer RewardEvent c
rs''
    let neverpulsed :: Bool
neverpulsed = forall k a. Map k a -> Bool
Map.null Map (Credential 'Staking c) (Reward c)
prev
        !newevent :: RewardEvent c
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 c
rs' RewardEvent c
events'
            else RewardEvent c
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 c
rs = RewardEvent c
rs''
          , deltaF :: DeltaCoin
deltaF = forall m. Group m => m -> m
invert (Coin -> DeltaCoin
toDeltaCoin Coin
feesSS)
          , nonMyopic :: NonMyopic c
nonMyopic = forall c.
NonMyopic c
-> Coin -> Map (KeyHash 'StakePool c) Likelihood -> NonMyopic c
updateNonMyopic NonMyopic c
nm Coin
oldr Map (KeyHash 'StakePool c) Likelihood
newLikelihoods
          }
      , RewardEvent c
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 (EraCrypto era) ->
  EpochState era ->
  Coin ->
  ActiveSlotCoeff ->
  Word64 ->
  ShelleyBase (RewardUpdate (EraCrypto era))
createRUpd :: forall era.
EraGov era =>
EpochSize
-> BlocksMade (EraCrypto era)
-> EpochState era
-> Coin
-> ActiveSlotCoeff
-> Word64
-> ShelleyBase (RewardUpdate (EraCrypto era))
createRUpd EpochSize
slotsPerEpoch BlocksMade (EraCrypto era)
blocksmade EpochState era
epstate Coin
maxSupply ActiveSlotCoeff
asc Word64
secparam = do
  let step1 :: PulsingRewUpdate (EraCrypto era)
step1 = forall era.
EraGov era =>
EpochSize
-> BlocksMade (EraCrypto era)
-> EpochState era
-> Coin
-> ActiveSlotCoeff
-> Word64
-> PulsingRewUpdate (EraCrypto era)
startStep EpochSize
slotsPerEpoch BlocksMade (EraCrypto era)
blocksmade EpochState era
epstate Coin
maxSupply ActiveSlotCoeff
asc Word64
secparam
  (PulsingRewUpdate (EraCrypto era)
step2, RewardEvent (EraCrypto era)
_event) <- forall c.
PulsingRewUpdate c
-> ShelleyBase (PulsingRewUpdate c, RewardEvent c)
pulseStep PulsingRewUpdate (EraCrypto era)
step1
  case PulsingRewUpdate (EraCrypto era)
step2 of
    Complete RewardUpdate (EraCrypto era)
r -> forall (f :: * -> *) a. Applicative f => a -> f a
pure RewardUpdate (EraCrypto era)
r
    Pulsing RewardSnapShot (EraCrypto era)
rewsnap Pulser (EraCrypto era)
pulser -> forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall c.
PulsingRewUpdate c -> ShelleyBase (RewardUpdate c, RewardEvent c)
completeRupd (forall c. RewardSnapShot c -> Pulser c -> PulsingRewUpdate c
Pulsing RewardSnapShot (EraCrypto era)
rewsnap Pulser (EraCrypto era)
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 (EraCrypto era)
_ NonMyopic (EraCrypto era)
_) 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 c ->
  Coin ->
  Map (KeyHash 'StakePool c) Likelihood ->
  NonMyopic c
updateNonMyopic :: forall c.
NonMyopic c
-> Coin -> Map (KeyHash 'StakePool c) Likelihood -> NonMyopic c
updateNonMyopic NonMyopic c
nm Coin
rPot_ Map (KeyHash 'StakePool c) Likelihood
newLikelihoods =
  NonMyopic c
nm
    { likelihoodsNM :: Map (KeyHash 'StakePool c) Likelihood
likelihoodsNM = Map (KeyHash 'StakePool c) Likelihood
updatedLikelihoods
    , rewardPotNM :: Coin
rewardPotNM = Coin
rPot_
    }
  where
    history :: Map (KeyHash 'StakePool c) Likelihood
history = forall c. NonMyopic c -> Map (KeyHash 'StakePool c) Likelihood
likelihoodsNM NonMyopic c
nm
    performance :: KeyHash 'StakePool c -> Likelihood -> Likelihood
performance KeyHash 'StakePool c
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 c
kh Map (KeyHash 'StakePool c) Likelihood
history)
        forall a. Semigroup a => a -> a -> a
<> Likelihood
newPerf
    updatedLikelihoods :: Map (KeyHash 'StakePool c) Likelihood
updatedLikelihoods = forall k a b. (k -> a -> b) -> Map k a -> Map k b
Map.mapWithKey KeyHash 'StakePool c -> Likelihood -> Likelihood
performance Map (KeyHash 'StakePool c) Likelihood
newLikelihoods