{-# 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 ((^.))
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
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)))
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
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)
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
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
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
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
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
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
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
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
}
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
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
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)
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)
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))
) = 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
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
)
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)
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