-
Notifications
You must be signed in to change notification settings - Fork 158
/
Rewards.hs
474 lines (432 loc) · 14.6 KB
/
Rewards.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
module Shelley.Spec.Ledger.Rewards
( desirability,
PerformanceEstimate (..),
NonMyopic (..),
emptyNonMyopic,
getTopRankedPools,
StakeShare (..),
mkApparentPerformance,
reward,
nonMyopicStake,
nonMyopicMemberRew,
percentile',
Histogram (..),
LogWeight (..),
likelihood,
Likelihood (..),
leaderProbability,
)
where
import Cardano.Binary
( FromCBOR (..),
ToCBOR (..),
decodeDouble,
encodeDouble,
encodeListLen,
)
import Cardano.Ledger.Era (Era)
import qualified Cardano.Ledger.Val as Val
import Cardano.Prelude (NFData, NoUnexpectedThunks (..))
import Cardano.Slotting.Slot (EpochSize)
import Control.Iterate.SetAlgebra (eval, (◁))
import Data.Foldable (find, fold)
import Data.Function (on)
import Data.List (sortBy)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Maybe (catMaybes, fromMaybe)
import Data.Ratio ((%))
import Data.Sequence (Seq)
import qualified Data.Sequence as Seq
import Data.Set (Set)
import qualified Data.Set as Set
import GHC.Generics (Generic)
import Numeric.Natural (Natural)
import Quiet
import Shelley.Spec.Ledger.BaseTypes
( ActiveSlotCoeff,
UnitInterval,
activeSlotVal,
unitIntervalToRational,
)
import Shelley.Spec.Ledger.Coin
( Coin (..),
coinToRational,
rationalToCoinViaFloor,
)
import Shelley.Spec.Ledger.Credential (Credential (..))
import Shelley.Spec.Ledger.Delegation.PoolParams (poolSpec)
import Shelley.Spec.Ledger.EpochBoundary
( BlocksMade (..),
Stake (..),
maxPool,
poolStake,
)
import Shelley.Spec.Ledger.Keys (KeyHash, KeyRole (..))
import Shelley.Spec.Ledger.PParams (PParams, _a0, _d, _nOpt)
import Shelley.Spec.Ledger.Serialization (decodeRecordNamed, decodeSeq, encodeFoldable)
import Shelley.Spec.Ledger.TxBody (PoolParams (..), getRwdCred)
newtype LogWeight = LogWeight {unLogWeight :: Float}
deriving (Eq, Generic, Ord, Num, NFData, NoUnexpectedThunks, ToCBOR, FromCBOR)
deriving (Show) via Quiet LogWeight
toLogWeight :: Double -> LogWeight
toLogWeight d = LogWeight (realToFrac $ log d)
fromLogWeight :: LogWeight -> Double
fromLogWeight (LogWeight l) = exp (realToFrac l)
data Histogram = Histogram {unHistogram :: Seq LogWeight}
deriving (Eq, Show, Generic)
newtype Likelihood = Likelihood {unLikelihood :: Seq LogWeight}
-- TODO: replace with small data structure
deriving (Show, Generic, NFData)
instance NoUnexpectedThunks Likelihood
instance Eq Likelihood where
(==) = (==) `on` unLikelihood . normalizeLikelihood
instance Semigroup Likelihood where
(Likelihood x) <> (Likelihood y) = normalizeLikelihood $ Likelihood (Seq.zipWith (+) x y)
instance Monoid Likelihood where
mempty = Likelihood $ Seq.replicate (length samplePositions) (LogWeight 0)
normalizeLikelihood :: Likelihood -> Likelihood
normalizeLikelihood (Likelihood xs) = Likelihood $ (\x -> x - m) <$> xs
where
m = minimum xs
instance ToCBOR Likelihood where
toCBOR (Likelihood logweights) = encodeFoldable logweights
instance FromCBOR Likelihood where
fromCBOR = Likelihood <$> decodeSeq fromCBOR
leaderProbability :: ActiveSlotCoeff -> Rational -> UnitInterval -> Double
leaderProbability activeSlotCoeff relativeStake decentralizationParameter =
(1 - (1 - asc) ** s) * (1 - d')
where
d' = realToFrac . unitIntervalToRational $ decentralizationParameter
asc = realToFrac . unitIntervalToRational . activeSlotVal $ activeSlotCoeff
s = realToFrac relativeStake
samplePositions :: [Double]
samplePositions = (\x -> (x + 0.5) / 100.0) <$> [0.0 .. 99.0]
likelihood ::
Natural -> -- number of blocks produced this epoch
Double -> -- chance we're allowed to produce a block in this slot
EpochSize ->
Likelihood
likelihood blocks t slotsPerEpoch = Likelihood . Seq.fromList $ sample <$> samplePositions
where
-- The likelihood function L(x) is the probability of observing the data we got
-- under the assumption that the underlying pool performance is equal to x.
-- L(x) = C(n,m) * (tx)^n * (1-tx)^m
-- where
-- t is the chance we're allowed to produce a block
-- n is the number of slots in which a block was produced
-- m is the number of slots in which a block was not produced
-- (slots per epoch minus n)
-- C(n,m) is a coefficient that will be irrelevant
-- Since the likelihood function only matters up to a scalar multiple, we will
-- will divide out C(n,m) t^n and use the following instead:
-- L(x) = x^n * (1-tx)^m
-- We represent this function using 100 sample points, but to avoid very
-- large exponents, we store the log of the value instead of the value itself.
-- log(L(x)) = log [ x^n * (1-tx)^m ]
-- = n * log(x) + m * log(1 - tx)
-- TODO: worry more about loss of floating point precision
--
-- example:
-- a pool has relative stake of 1 / 1,000,000 (~ 30k ada of 35b ada)
-- f = active slot coefficient = 1/20
-- t = 1 - (1-f)^(1/1,000,000)
n = fromIntegral blocks
m = fromIntegral $ slotsPerEpoch - fromIntegral blocks
l :: Double -> Double
l x = n * log x + m * log (1 - t * x)
sample position = LogWeight (realToFrac $ l position)
posteriorDistribution :: Histogram -> Likelihood -> Histogram
posteriorDistribution (Histogram points) (Likelihood likelihoods) = normalize $ Histogram $ Seq.zipWith (+) points likelihoods
-- TODO decay the histogram
-- | Normalize the histogram so that the total area is 1
normalize :: Histogram -> Histogram
normalize (Histogram values) = Histogram $ (\x -> x - logArea) <$> values
where
logArea = toLogWeight area
area = reimannSum 0.01 (fromLogWeight <$> values)
-- | Calculate the k percentile for this distribution.
-- k is a value between 0 and 1. The 0 percentile is 0 and the 1 percentile is 1
percentile :: Double -> Histogram -> Likelihood -> PerformanceEstimate
percentile p prior likelihoods =
PerformanceEstimate . fst $
fromMaybe (1, 1) $
find (\(_x, fx) -> fx > p) cdf
where
(Histogram values) = posteriorDistribution prior likelihoods
cdf = Seq.zip (Seq.fromList samplePositions) $ Seq.scanl (+) 0 (fromLogWeight <$> values)
percentile' :: Likelihood -> PerformanceEstimate
percentile' = percentile 0.1 h
where
h = normalize . Histogram . Seq.fromList $ logBeta 40 3 <$> samplePositions
-- Beta(n,m)(x) = C * x^(n-1)*(1-x)^(m-1)
-- log( Beta(n,m)(x) ) = (n-1) * log x + (m-1) * log (1-x)
logBeta n m x = LogWeight . realToFrac $ (n -1) * log x + (m -1) * log (1 - x)
reimannSum :: (Functor f, Foldable f) => Double -> f Double -> Double
reimannSum width heights = sum $ fmap (width *) heights
-- | This is a estimate of the proportion of allowed blocks a pool will
-- make in the future. It is used for ranking pools in delegation.
newtype PerformanceEstimate = PerformanceEstimate {unPerformanceEstimate :: Double}
deriving (Show, Eq, Generic, NoUnexpectedThunks)
instance ToCBOR PerformanceEstimate where
toCBOR = encodeDouble . unPerformanceEstimate
instance FromCBOR PerformanceEstimate where
fromCBOR = PerformanceEstimate <$> decodeDouble
data NonMyopic era = NonMyopic
{ likelihoodsNM :: !(Map (KeyHash 'StakePool era) Likelihood),
rewardPotNM :: !Coin
}
deriving (Show, Eq, Generic)
emptyNonMyopic :: NonMyopic era
emptyNonMyopic = NonMyopic Map.empty (Coin 0)
instance NoUnexpectedThunks (NonMyopic era)
instance NFData (NonMyopic era)
instance Era era => ToCBOR (NonMyopic era) where
toCBOR
NonMyopic
{ likelihoodsNM = aps,
rewardPotNM = rp
} =
encodeListLen 3
<> toCBOR aps
<> toCBOR rp
instance Era era => FromCBOR (NonMyopic era) where
fromCBOR = do
decodeRecordNamed "NonMyopic" (const 3) $ do
aps <- fromCBOR
rp <- fromCBOR
pure $
NonMyopic
{ likelihoodsNM = aps,
rewardPotNM = rp
}
-- | Desirability calculation for non-myopic utily,
-- corresponding to f^~ in section 5.6.1 of
-- "Design Specification for Delegation and Incentives in Cardano"
desirability ::
PParams era ->
Coin ->
PoolParams era ->
PerformanceEstimate ->
Coin ->
Double
desirability pp r pool (PerformanceEstimate p) (Coin totalStake) =
if fTilde <= cost
then 0
else (fTilde - cost) * (1 - margin)
where
fTilde = fTildeNumer / fTildeDenom
fTildeNumer = p * fromRational (coinToRational r * (z0 + min s z0 * a0))
fTildeDenom = fromRational $ 1 + a0
cost = (fromRational . coinToRational . _poolCost) pool
margin = (fromRational . unitIntervalToRational . _poolMargin) pool
tot = max 1 (fromIntegral totalStake)
Coin pledge = _poolPledge pool
s = fromIntegral pledge % tot
a0 = _a0 pp
z0 = 1 % max 1 (fromIntegral (_nOpt pp))
-- | Computes the top ranked stake pools
-- corresponding to section 5.6.1 of
-- "Design Specification for Delegation and Incentives in Cardano"
getTopRankedPools ::
Coin ->
Coin ->
PParams era ->
Map (KeyHash 'StakePool era) (PoolParams era) ->
Map (KeyHash 'StakePool era) PerformanceEstimate ->
Set (KeyHash 'StakePool era)
getTopRankedPools rPot totalStake pp poolParams aps =
Set.fromList $
fmap fst $
take (fromIntegral $ _nOpt pp) (sortBy (flip compare `on` snd) rankings)
where
pdata = Map.toList $ Map.intersectionWith (,) poolParams aps
rankings =
[ ( hk,
desirability pp rPot pool ap totalStake
)
| (hk, (pool, ap)) <- pdata
]
-- | StakeShare type
newtype StakeShare = StakeShare {unStakeShare :: Rational}
deriving (Generic, Ord, Eq, NoUnexpectedThunks)
deriving (Show) via Quiet StakeShare
-- | Calculate pool reward
mkApparentPerformance ::
UnitInterval ->
Rational ->
Natural ->
Natural ->
Rational
mkApparentPerformance d_ sigma blocksN blocksTotal
| sigma == 0 = 0
| unitIntervalToRational d_ < 0.8 = beta / sigma
| otherwise = 1
where
beta = fromIntegral blocksN / fromIntegral (max 1 blocksTotal)
-- | Calculate pool leader reward
leaderRew ::
Coin ->
PoolParams era ->
StakeShare ->
StakeShare ->
Coin
leaderRew f pool (StakeShare s) (StakeShare sigma)
| f <= c = f
| otherwise =
c
<> rationalToCoinViaFloor
(coinToRational (f Val.~~ c) * (m' + (1 - m') * s / sigma))
where
(c, m, _) = poolSpec pool
m' = unitIntervalToRational m
-- | Calculate pool member reward
memberRew ::
Coin ->
PoolParams era ->
StakeShare ->
StakeShare ->
Coin
memberRew (Coin f') pool (StakeShare t) (StakeShare sigma)
| f' <= c = mempty
| otherwise = rationalToCoinViaFloor $ fromIntegral (f' - c) * (1 - m') * t / sigma
where
(Coin c, m, _) = poolSpec pool
m' = unitIntervalToRational m
-- | Reward one pool
rewardOnePool ::
PParams era ->
Coin ->
Natural ->
Natural ->
PoolParams era ->
Stake era ->
Rational ->
Rational ->
Coin ->
Set (Credential 'Staking era) ->
Map (Credential 'Staking era) Coin
rewardOnePool pp r blocksN blocksTotal pool (Stake stake) sigma sigmaA (Coin totalStake) addrsRew =
rewards'
where
Coin ostake =
Set.foldl'
(\c o -> c <> (fromMaybe mempty $ Map.lookup (KeyHashObj o) stake))
mempty
(_poolOwners pool)
Coin pledge = _poolPledge pool
pr = fromIntegral pledge % fromIntegral totalStake
(Coin maxP) =
if pledge <= ostake
then maxPool pp r sigma pr
else mempty
appPerf = mkApparentPerformance (_d pp) sigmaA blocksN blocksTotal
poolR = rationalToCoinViaFloor (appPerf * fromIntegral maxP)
tot = fromIntegral totalStake
mRewards =
Map.fromList
[ ( hk,
memberRew poolR pool (StakeShare (fromIntegral c % tot)) (StakeShare sigma)
)
| (hk, Coin c) <- Map.toList stake,
notPoolOwner hk
]
notPoolOwner (KeyHashObj hk) = hk `Set.notMember` _poolOwners pool
notPoolOwner (ScriptHashObj _) = False
iReward = leaderRew poolR pool (StakeShare $ fromIntegral ostake % tot) (StakeShare sigma)
potentialRewards = Map.insert (getRwdCred $ _poolRAcnt pool) iReward mRewards
rewards' = Map.filter (/= Coin 0) $ eval (addrsRew ◁ potentialRewards)
reward ::
PParams era ->
BlocksMade era ->
Coin ->
Set (Credential 'Staking era) ->
Map (KeyHash 'StakePool era) (PoolParams era) ->
Stake era ->
Map (Credential 'Staking era) (KeyHash 'StakePool era) ->
Coin ->
ActiveSlotCoeff ->
EpochSize ->
(Map (Credential 'Staking era) Coin, Map (KeyHash 'StakePool era) Likelihood)
reward
pp
(BlocksMade b)
r
addrsRew
poolParams
stake
delegs
(Coin totalStake)
asc
slotsPerEpoch = (rewards', hs)
where
totalBlocks = sum b
Coin activeStake = fold . unStake $ stake
results = do
(hk, pparams) <- Map.toList poolParams
let sigma = fromIntegral pstake % fromIntegral totalStake
sigmaA = fromIntegral pstake % fromIntegral activeStake
blocksProduced = Map.lookup hk b
actgr@(Stake s) = poolStake hk delegs stake
Coin pstake = fold s
rewardMap = case blocksProduced of
Nothing -> Nothing -- This is equivalent to calling rewarOnePool with n = 0
Just n ->
Just $
rewardOnePool
pp
r
n
totalBlocks
pparams
actgr
sigma
sigmaA
(Coin totalStake)
addrsRew
ls =
likelihood
(fromMaybe 0 blocksProduced)
(leaderProbability asc sigma (_d pp))
slotsPerEpoch
pure (hk, rewardMap, ls)
rewards' = fold $ catMaybes $ fmap (\(_, x, _) -> x) results
hs = Map.fromList $ fmap (\(hk, _, l) -> (hk, l)) results
nonMyopicStake ::
KeyHash 'StakePool era ->
StakeShare ->
StakeShare ->
PParams era ->
Set (KeyHash 'StakePool era) ->
StakeShare
nonMyopicStake kh (StakeShare sigma) (StakeShare s) pp topPools =
let z0 = 1 % max 1 (fromIntegral (_nOpt pp))
in if kh `Set.member` topPools
then StakeShare (max sigma z0)
else StakeShare s
nonMyopicMemberRew ::
PParams era ->
PoolParams era ->
Coin ->
StakeShare ->
StakeShare ->
StakeShare ->
PerformanceEstimate ->
Coin
nonMyopicMemberRew
pp
pool
rPot
(StakeShare s)
(StakeShare t)
(StakeShare nm)
(PerformanceEstimate p) =
let nm' = max t nm -- TODO check with researchers that this is how to handle t > nm
f = maxPool pp rPot nm' s
fHat = floor (p * (fromRational . coinToRational) f)
in memberRew (Coin fHat) pool (StakeShare t) (StakeShare nm')