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