two pool example

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

@@ -22,6 +22,8 @@ module Shelley.Spec.Ledger.Rewards
     applyDecay,
     Likelihood (..),
     leaderProbability,
+    leaderRew,
+    memberRew,
   )
 where
 
@@ -72,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
@@ -419,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 ::
@@ -490,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/shelley-spec-ledger-test.cabal

@@ -118,6 +118,7 @@ test-suite shelley-spec-ledger-test
       Test.Shelley.Spec.Ledger.Examples.Mir
       Test.Shelley.Spec.Ledger.Examples.PoolLifetime
       Test.Shelley.Spec.Ledger.Examples.PoolReReg
+      Test.Shelley.Spec.Ledger.Examples.TwoPools
       Test.Shelley.Spec.Ledger.Examples.Updates
       Test.Shelley.Spec.Ledger.Fees
       Test.Shelley.Spec.Ledger.LegacyOverlay

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

@@ -24,6 +24,9 @@ module Test.Shelley.Spec.Ledger.Examples.Cast
     bobStake,
     bobSHK,
     bobAddr,
+    bobPoolKeys,
+    bobPoolParams,
+    bobVRFKeyHash,
     carlPay,
     carlStake,
     carlSHK,
@@ -164,6 +167,39 @@ bobAddr = mkAddr (bobPay, bobStake)
 bobSHK :: Era era => Credential 'Staking era
 bobSHK = (KeyHashObj . hashKey . vKey) bobStake
 
+-- | Bob's stake pool keys (cold keys, VRF keys, hot KES keys)
+bobPoolKeys :: CC.Crypto crypto => AllIssuerKeys crypto 'StakePool
+bobPoolKeys =
+  AllIssuerKeys
+    (KeyPair vkCold skCold)
+    (mkVRFKeyPair (2, 0, 0, 0, 2))
+    [(KESPeriod 0, mkKESKeyPair (2, 0, 0, 0, 3))]
+    (hashKey vkCold)
+  where
+    (skCold, vkCold) = mkKeyPair (2, 0, 0, 0, 1)
+
+-- | Bob's stake pool parameters
+bobPoolParams :: forall era. Era era => PoolParams era
+bobPoolParams =
+  PoolParams
+    { _poolId = (hashKey . vKey . cold) bobPoolKeys,
+      _poolVrf = hashVerKeyVRF . snd $ vrf (bobPoolKeys @(Crypto era)),
+      _poolPledge = Coin 2,
+      _poolCost = Coin 1,
+      _poolMargin = unsafeMkUnitInterval 0.1,
+      _poolRAcnt = RewardAcnt Testnet bobSHK,
+      _poolOwners = Set.singleton $ (hashKey . vKey) bobStake,
+      _poolRelays = StrictSeq.empty,
+      _poolMD = SNothing
+    }
+
+-- | Bob's VRF key hash
+bobVRFKeyHash ::
+  forall crypto.
+  CC.Crypto crypto =>
+  Hash crypto (VerKeyVRF crypto)
+bobVRFKeyHash = hashVerKeyVRF (snd $ vrf (bobPoolKeys @crypto))
+
 -- Carl's payment key pair
 carlPay :: CC.Crypto crypto => KeyPair 'Payment crypto
 carlPay = KeyPair vk sk

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.