aggregate rewards

shelley/chain-and-ledger/executable-spec/shelley-spec-ledger.cabal

@@ -40,6 +40,7 @@ library
     Shelley.Spec.Ledger.Delegation.PoolParams
     Shelley.Spec.Ledger.EpochBoundary
     Shelley.Spec.Ledger.Genesis
+    Shelley.Spec.Ledger.HardForks
     Shelley.Spec.Ledger.Hashing
     Shelley.Spec.Ledger.Keys
     Shelley.Spec.Ledger.LedgerState

shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/HardForks.hs

@@ -0,0 +1,9 @@
+module Shelley.Spec.Ledger.HardForks
+  ( aggregatedRewards,
+  )
+where
+
+import Shelley.Spec.Ledger.PParams (PParams, PParams' (..), ProtVer (..))
+
+aggregatedRewards :: PParams era -> Bool
+aggregatedRewards pp = pvMajor (_protocolVersion pp) > 2

shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/Rewards.hs

@@ -74,6 +74,7 @@ import Shelley.Spec.Ledger.EpochBoundary
     maxPool,
     poolStake,
   )
+import qualified Shelley.Spec.Ledger.HardForks as HardForks
 import Shelley.Spec.Ledger.Keys (KeyHash, KeyRole (..))
 import Shelley.Spec.Ledger.PParams (PParams, _a0, _d, _nOpt)
 import Shelley.Spec.Ledger.Serialization
@@ -421,17 +422,18 @@ rewardOnePool
           ]
       notPoolOwner (KeyHashObj hk) = hk `Set.notMember` _poolOwners pool
       notPoolOwner (ScriptHashObj _) = False
-      iReward =
+      lReward =
         leaderRew
           poolR
           pool
           (StakeShare $ fromIntegral ostake % tot)
           (StakeShare sigma)
+      f =
+        if HardForks.aggregatedRewards pp
+          then Map.insertWith (<>)
+          else Map.insert
       potentialRewards =
-        Map.insert
-          (getRwdCred $ _poolRAcnt pool)
-          iReward
-          mRewards
+        f (getRwdCred $ _poolRAcnt pool) lReward mRewards
       rewards' = Map.filter (/= Coin 0) $ eval (addrsRew ◁ potentialRewards)
 
 reward ::
@@ -492,7 +494,11 @@ reward
                 (leaderProbability asc sigma (_d pp))
                 slotsPerEpoch
         pure (hk, rewardMap, ls)
-      rewards' = fold $ catMaybes $ fmap (\(_, x, _) -> x) results
+      f =
+        if HardForks.aggregatedRewards pp
+          then Map.unionsWith (<>)
+          else Map.unions
+      rewards' = f . catMaybes $ fmap (\(_, x, _) -> x) results
       hs = Map.fromList $ fmap (\(hk, _, l) -> (hk, l)) results
 
 -- | Compute the Non-Myopic Pool Stake

shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/Examples/Combinators.hs

@@ -36,6 +36,7 @@ module Test.Shelley.Spec.Ledger.Examples.Combinators
     setCurrentProposals,
     setFutureProposals,
     setPParams,
+    setPrevPParams,
     setFutureGenDeleg,
     adoptFutureGenDeleg,
   )
@@ -659,6 +660,21 @@ setPParams pp cs = cs {chainNes = nes'}
     es' = es {esPp = pp}
     nes' = nes {nesEs = es'}
 
+-- | = Set the Previous Protocol Proposals
+--
+-- Set the previous protocol parameters.
+setPrevPParams ::
+  forall era.
+  PParams era ->
+  ChainState era ->
+  ChainState era
+setPrevPParams pp cs = cs {chainNes = nes'}
+  where
+    nes = chainNes cs
+    es = nesEs nes
+    es' = es {esPrevPp = pp}
+    nes' = nes {nesEs = es'}
+
 -- | = Set a future genesis delegation.
 setFutureGenDeleg ::
   forall era.

shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/Examples/TwoPools.hs

@@ -64,7 +64,7 @@ import Shelley.Spec.Ledger.LedgerState
     emptyRewardUpdate,
   )
 import Shelley.Spec.Ledger.OCert (KESPeriod (..))
-import Shelley.Spec.Ledger.PParams (PParams' (..))
+import Shelley.Spec.Ledger.PParams (PParams' (..), ProtVer (..))
 import Shelley.Spec.Ledger.Rewards
   ( Likelihood (..),
     NonMyopic (..),
@@ -73,6 +73,7 @@ import Shelley.Spec.Ledger.Rewards
     leaderProbability,
     leaderRew,
     likelihood,
+    memberRew,
     mkApparentPerformance,
   )
 import Shelley.Spec.Ledger.STS.Chain (ChainState (..))
@@ -622,6 +623,9 @@ circulation = unCoin $ maxLLSupply <-> reserves9
 aliceStakeShareTot :: Rational
 aliceStakeShareTot = (unCoin aliceCoinEx1 + unCoin carlInitCoin) % circulation
 
+bobStakeShareTot :: Rational
+bobStakeShareTot = unCoin bobInitCoin % circulation
+
 alicePoolRewards :: forall era. Era era => Coin
 alicePoolRewards = rationalToCoinViaFloor (appPerf * (fromIntegral . unCoin $ maxP))
   where
@@ -630,6 +634,14 @@ alicePoolRewards = rationalToCoinViaFloor (appPerf * (fromIntegral . unCoin $ ma
     pr = pledge % circulation
     maxP = EB.maxPool ppEx bigR aliceStakeShareTot pr
 
+carlMemberRewardsFromAlice :: forall era. Era era => Coin
+carlMemberRewardsFromAlice =
+  memberRew
+    (alicePoolRewards @era)
+    (alicePoolParams' @era)
+    (StakeShare $ unCoin carlInitCoin % circulation)
+    (StakeShare aliceStakeShareTot)
+
 carlLeaderRewardsFromAlice :: forall era. Era era => Coin
 carlLeaderRewardsFromAlice =
   leaderRew
@@ -638,6 +650,22 @@ carlLeaderRewardsFromAlice =
     (StakeShare $ unCoin aliceCoinEx1 % circulation)
     (StakeShare aliceStakeShareTot)
 
+bobPoolRewards :: forall era. Era era => Coin
+bobPoolRewards = rationalToCoinViaFloor (appPerf * (fromIntegral . unCoin $ maxP))
+  where
+    appPerf = mkApparentPerformance (_d ppEx) bobPoolStake 1 3
+    pledge = fromIntegral . unCoin . _poolPledge $ bobPoolParams' @era
+    pr = pledge % circulation
+    maxP = EB.maxPool ppEx bigR bobStakeShareTot pr
+
+carlLeaderRewardsFromBob :: forall era. Era era => Coin
+carlLeaderRewardsFromBob =
+  leaderRew
+    (bobPoolRewards @era)
+    (bobPoolParams' @era)
+    (StakeShare $ unCoin bobInitCoin % circulation)
+    (StakeShare bobStakeShareTot)
+
 alicePerfEx9 :: Likelihood
 alicePerfEx9 = likelihood blocks t (epochSize $ EpochNo 3)
   where
@@ -702,6 +730,33 @@ expectedStEx9 rewards =
 twoPools9 :: forall era. (ShelleyTest era, ExMock (Crypto era)) => CHAINExample era
 twoPools9 = CHAINExample expectedStEx8 blockEx9 (Right $ expectedStEx9 rsEx9)
 
+--
+-- Now test with Aggregation
+--
+
+rsEx9Agg :: forall era. Era era => Map (Credential 'Staking era) Coin
+rsEx9Agg =
+  Map.singleton
+    Cast.carlSHK
+    ( carlMemberRewardsFromAlice @era
+        <> carlLeaderRewardsFromAlice @era
+        <> carlLeaderRewardsFromBob @era
+    )
+
+expectedStEx8Agg :: forall era. (ShelleyTest era, ExMock (Crypto era)) => ChainState era
+expectedStEx8Agg = C.setPrevPParams (ppEx {_protocolVersion = ProtVer 3 0}) expectedStEx8
+
+expectedStEx9Agg :: forall era. (ShelleyTest era, ExMock (Crypto era)) => ChainState era
+expectedStEx9Agg =
+  C.setPrevPParams
+    (ppEx {_protocolVersion = ProtVer 3 0})
+    (expectedStEx9 rsEx9Agg)
+
+-- Create the first non-trivial reward update. The rewards demonstrate the
+-- results of the delegation scenario that was constructed in the first and only transaction.
+twoPools9Agg :: forall era. (ShelleyTest era, ExMock (Crypto era)) => CHAINExample era
+twoPools9Agg = CHAINExample expectedStEx8Agg blockEx9 (Right expectedStEx9Agg)
+
 --
 -- Two Pools Test Group
 --
@@ -710,7 +765,9 @@ twoPoolsExample :: TestTree
 twoPoolsExample =
   testGroup
     "two pools"
-    [testCase "create a nontrivial rewards" $ testCHAINExample twoPools9]
+    [ testCase "create non-aggregated rewards" $ testCHAINExample twoPools9,
+      testCase "create aggregated rewards" $ testCHAINExample twoPools9Agg
+    ]
 
 -- This test group tests each block individually, which is really only
 -- helpful for debugging purposes.
@@ -726,5 +783,6 @@ twoPoolsExampleExtended =
       testCase "alice produces a block" $ testCHAINExample twoPools6,
       testCase "bob produces a block" $ testCHAINExample twoPools7,
       testCase "prelude to the first nontrivial rewards" $ testCHAINExample twoPools8,
-      testCase "create a nontrivial rewards" $ testCHAINExample twoPools9
+      testCase "create non-aggregated rewards" $ testCHAINExample twoPools9,
+      testCase "create aggregated rewards" $ testCHAINExample twoPools9Agg
     ]