Add proposal-deposit to SPO voting stake calc.

* Add individualPoolStakeCoin field to IndividualPoolStake as numerator. * Add pdTotal field to PoolDistr as denominator. * Change calculatePoolDistr' to include the numerator and denominator. * Update computeDRepDistr to include updating PoolDistr numerator and denominator with proposal-deposits. * Update spoAcceptedRatio to calculate in terms of the numerator/ denominator pair instead of Rational.
IntersectMBO · May 7, 2024 · 819b897 · 819b897
1 parent 71b8cb1
commit 819b897
Show file tree

Hide file tree

Showing 36 changed files with 300 additions and 162 deletions.
diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Governance/DRepPulser.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Governance/DRepPulser.hs
@@ -62,7 +62,7 @@ import Cardano.Ledger.Core
 import Cardano.Ledger.Credential (Credential (..))
 import Cardano.Ledger.DRep (DRep (..), DRepState (..))
 import Cardano.Ledger.Keys (KeyRole (..))
-import Cardano.Ledger.PoolDistr (PoolDistr (..))
+import Cardano.Ledger.PoolDistr
 import Cardano.Ledger.UMap
 import qualified Cardano.Ledger.UMap as UMap
 import Control.DeepSeq (NFData (..), deepseq)
@@ -177,26 +177,49 @@ computeDRepDistr ::
   Map (Credential 'Staking c) (CompactForm Coin) ->
   Map (Credential 'DRepRole c) (DRepState c) ->
   Map (Credential 'Staking c) (CompactForm Coin) ->
+  PoolDistr c ->
   Map (DRep c) (CompactForm Coin) ->
   Map (Credential 'Staking c) (UMElem c) ->
-  Map (DRep c) (CompactForm Coin)
-computeDRepDistr stakeDistr regDReps proposalDeposits dRepDistr uMapChunk =
-  Map.foldlWithKey' go dRepDistr uMapChunk
+  (Map (DRep c) (CompactForm Coin), PoolDistr c)
+computeDRepDistr stakeDistr regDReps proposalDeposits poolDistr dRepDistr uMapChunk =
+  Map.foldlWithKey' go (dRepDistr, poolDistr) uMapChunk
   where
-    go accum stakeCred umElem =
+    go (drepAccum, poolAccum) stakeCred umElem =
       let stake = fromMaybe (CompactCoin 0) $ Map.lookup stakeCred stakeDistr
           proposalDeposit = fromMaybe (CompactCoin 0) $ Map.lookup stakeCred proposalDeposits
           stakeAndDeposits = addCompact stake proposalDeposit
-       in case umElemDRepDelegatedReward umElem of
-            Just (r, drep@DRepAlwaysAbstain) ->
-              Map.insertWith addCompact drep (addCompact stakeAndDeposits r) accum
-            Just (r, drep@DRepAlwaysNoConfidence) ->
-              Map.insertWith addCompact drep (addCompact stakeAndDeposits r) accum
-            Just (r, drep@(DRepCredential drepCred))
-              | Map.member drepCred regDReps ->
-                  Map.insertWith addCompact drep (addCompact stakeAndDeposits r) accum
-              | otherwise -> accum
-            Nothing -> accum
+       in case umElemDelegations umElem of
+            Nothing -> (drepAccum, poolAccum)
+            Just (RewardDelegationSPO spo _r) ->
+              ( drepAccum
+              , addToPoolDistr spo proposalDeposit poolAccum
+              )
+            Just (RewardDelegationDRep drep r) ->
+              ( addToDRepDistr drep (addCompact stakeAndDeposits r) drepAccum
+              , poolAccum
+              )
+            Just (RewardDelegationBoth spo drep r) ->
+              ( addToDRepDistr drep (addCompact stakeAndDeposits r) drepAccum
+              , addToPoolDistr spo proposalDeposit poolAccum
+              )
+    addToPoolDistr spo ccoin distr =
+      -- Only add the proposal deposits to the CompactCoin numerator and
+      -- denominator and not the rational In order not to interfere with rewards
+      -- calculation of any kind.
+      case Map.lookup spo $ distr ^. poolDistrDistrL of
+        Nothing -> distr -- Impossible! Because, a delegation to an SPO would also appear in the PoolDistr
+        Just ips ->
+          distr
+            & poolDistrDistrL %~ Map.insert spo (ips & individualPoolStakeCoinL <>~ ccoin)
+            & poolDistrTotalL <>~ ccoin
+    addToDRepDistr drep ccoin distr =
+      let updatedDistr = Map.insertWith addCompact drep ccoin distr
+       in case drep of
+            DRepAlwaysAbstain -> updatedDistr
+            DRepAlwaysNoConfidence -> updatedDistr
+            DRepCredential cred
+              | Map.member cred regDReps -> updatedDistr
+              | otherwise -> distr
 
 -- | The type of a Pulser which uses 'computeDRepDistr' as its underlying
 -- function. Note that we use two type equality (~) constraints to fix both
@@ -249,8 +272,14 @@ instance Pulsable (DRepPulser era) where
     | done pulser = pure pulser {dpIndex = 0}
     | otherwise =
         let !chunk = Map.take dpPulseSize $ Map.drop dpIndex $ UMap.umElems dpUMap
-            dRepDistr = computeDRepDistr dpStakeDistr dpDRepState dpProposalDeposits dpDRepDistr chunk
-         in pure (pulser {dpIndex = dpIndex + dpPulseSize, dpDRepDistr = dRepDistr})
+            (dRepDistr, poolDistr) =
+              computeDRepDistr dpStakeDistr dpDRepState dpProposalDeposits dpStakePoolDistr dpDRepDistr chunk
+         in pure $
+              pulser
+                { dpIndex = dpIndex + dpPulseSize
+                , dpDRepDistr = dRepDistr
+                , dpStakePoolDistr = poolDistr
+                }
 
   completeM x@(DRepPulser {}) = pure (snd $ finishDRepPulser @era (DRPulsing x))
 
@@ -320,11 +349,12 @@ finishDRepPulser (DRPulsing (DRepPulser {..})) =
   (PulsingSnapshot dpProposals finalDRepDistr dpDRepState, ratifyState')
   where
     !leftOver = Map.drop dpIndex $ umElems dpUMap
-    !finalDRepDistr = computeDRepDistr dpStakeDistr dpDRepState dpProposalDeposits dpDRepDistr leftOver
+    (!finalDRepDistr, !finalStakePoolDistr) =
+      computeDRepDistr dpStakeDistr dpDRepState dpProposalDeposits dpStakePoolDistr dpDRepDistr leftOver
     !ratifyEnv =
       RatifyEnv
         { reStakeDistr = dpStakeDistr
-        , reStakePoolDistr = dpStakePoolDistr
+        , reStakePoolDistr = finalStakePoolDistr
         , reDRepDistr = finalDRepDistr
         , reDRepState = dpDRepState
         , reCurrentEpoch = dpCurrentEpoch

diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Governance/Internal.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Governance/Internal.hs
@@ -545,7 +545,7 @@ deriving instance Show (RatifyEnv era)
 deriving instance Eq (RatifyEnv era)
 
 instance Default (RatifyEnv era) where
-  def = RatifyEnv Map.empty (PoolDistr Map.empty) Map.empty Map.empty (EpochNo 0) def
+  def = RatifyEnv Map.empty (PoolDistr Map.empty mempty) Map.empty Map.empty (EpochNo 0) def
 
 instance Typeable era => NoThunks (RatifyEnv era) where
   showTypeOf _ = "RatifyEnv"

diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/NewEpoch.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/NewEpoch.hs
@@ -139,7 +139,7 @@ instance
           (BlocksMade Map.empty)
           def
           SNothing
-          (PoolDistr Map.empty)
+          (PoolDistr Map.empty mempty)
           def
     ]
 

diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Ratify.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Ratify.hs
@@ -71,7 +71,7 @@ import Cardano.Ledger.Conway.Rules.Enact (EnactSignal (..), EnactState (..))
 import Cardano.Ledger.Credential (Credential (..))
 import Cardano.Ledger.DRep (DRep (..), DRepState (..))
 import Cardano.Ledger.Keys (KeyRole (..))
-import Cardano.Ledger.PoolDistr (PoolDistr (..), individualPoolStake)
+import Cardano.Ledger.PoolDistr (PoolDistr (..), individualPoolStakeCoin)
 import Cardano.Ledger.Slot (EpochNo (..))
 import Cardano.Ledger.Val (Val (..), (<+>))
 import Control.State.Transition.Extended (
@@ -85,7 +85,6 @@ import Control.State.Transition.Extended (
 import Data.Foldable (Foldable (..))
 import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
-import Data.Monoid (Sum (..))
 import Data.Ratio ((%))
 import qualified Data.Sequence as Seq
 import qualified Data.Sequence.Strict as SSeq
@@ -208,19 +207,23 @@ spoAcceptedRatio
     | abstainVotesRatio == 1 = 0 -- guard against the degenerate case when all abstain.
     | otherwise = yesVotesRatio / (1 - abstainVotesRatio)
     where
-      PoolDistr stakePoolDistr = reStakePoolDistr
-      (Sum yesVotesRatio, Sum abstainVotesRatio) =
-        Map.foldMapWithKey getVotesStakePerStakePoolDistr stakePoolDistr
-      getVotesStakePerStakePoolDistr poolId distr =
-        let d = Sum $ individualPoolStake distr
+      PoolDistr stakePoolDistr (CompactCoin totalActiveStake) = reStakePoolDistr
+      (yesVotesRatio, abstainVotesRatio) =
+        ( toInteger yesVotes % toInteger totalActiveStake
+        , toInteger abstainVotes % toInteger totalActiveStake
+        )
+      (CompactCoin yesVotes, CompactCoin abstainVotes) =
+        Map.foldlWithKey' getVotesStakePerStakePoolDistr (mempty, mempty) stakePoolDistr
+      getVotesStakePerStakePoolDistr (!yess, !abstains) poolId distr =
+        let d = individualPoolStakeCoin distr
             vote = Map.lookup poolId gasStakePoolVotes
          in case vote of
               Nothing
-                | HardForkInitiation {} <- pProcGovAction -> mempty
-                | otherwise -> (mempty, d)
-              Just VoteNo -> mempty
-              Just VoteYes -> (d, mempty)
-              Just Abstain -> (mempty, d)
+                | HardForkInitiation {} <- pProcGovAction -> (yess, abstains)
+                | otherwise -> (yess, abstains <> d)
+              Just VoteNo -> (yess, abstains)
+              Just VoteYes -> (yess <> d, abstains)
+              Just Abstain -> (yess, abstains <> d)
 
 dRepAccepted ::
   ConwayEraPParams era => RatifyEnv era -> RatifyState era -> GovActionState era -> Bool

diff --git a/eras/conway/impl/test/Test/Cardano/Ledger/Conway/DRepRatifySpec.hs b/eras/conway/impl/test/Test/Cardano/Ledger/Conway/DRepRatifySpec.hs
@@ -325,4 +325,10 @@ genPctsOf100 = do
 
 emptyRatifyEnv :: forall era. RatifyEnv era
 emptyRatifyEnv =
-  RatifyEnv Map.empty (PoolDistr Map.empty) Map.empty Map.empty (EpochNo 0) (CommitteeState Map.empty)
+  RatifyEnv
+    Map.empty
+    (PoolDistr Map.empty mempty)
+    Map.empty
+    Map.empty
+    (EpochNo 0)
+    (CommitteeState Map.empty)
diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/API/ByronTranslation.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/API/ByronTranslation.hs
@@ -110,7 +110,7 @@ translateToShelleyLedgerState transCtxt epochNo cvs =
     , nesBcur = BlocksMade Map.empty
     , nesEs = epochState
     , nesRu = SNothing
-    , nesPd = PoolDistr Map.empty
+    , nesPd = PoolDistr Map.empty mempty
     , -- At this point, we compute the stashed AVVM addresses, while we are able
       -- to do a linear scan of the UTxO, and stash them away for use at the
       -- Shelley/Allegra boundary.

diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/API/Genesis.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/API/Genesis.hs
@@ -100,7 +100,7 @@ initialStateFromGenesis sg ag =
         def
     )
     SNothing
-    (PoolDistr Map.empty)
+    (PoolDistr Map.empty mempty)
     def
   where
     initialEpochNo = EpochNo 0

diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/API/Wallet.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/API/Wallet.hs
@@ -201,19 +201,19 @@ poolsByTotalStakeFraction ::
   NewEpochState era ->
   PoolDistr (EraCrypto era)
 poolsByTotalStakeFraction globals ss =
-  PoolDistr poolsByTotalStake
+  PoolDistr poolsByTotalStake activeStake -- QESTION: Should the denominator be `totalStake` here instead?
   where
     snap@(EB.SnapShot stake _ _) = currentSnapshot ss
     Coin totalStake = getTotalStake globals ss
-    Coin activeStake = EB.sumAllStake stake
-    stakeRatio = activeStake % totalStake
-    PoolDistr poolsByActiveStake = calculatePoolDistr snap
+    activeStake = EB.sumAllStake stake
+    stakeRatio = unCoin (fromCompact activeStake) % totalStake
+    PoolDistr poolsByActiveStake _totalActiveStake = calculatePoolDistr snap
     poolsByTotalStake = Map.map toTotalStakeFrac poolsByActiveStake
     toTotalStakeFrac ::
       IndividualPoolStake (EraCrypto era) ->
       IndividualPoolStake (EraCrypto era)
-    toTotalStakeFrac (IndividualPoolStake s vrf) =
-      IndividualPoolStake (s * stakeRatio) vrf
+    toTotalStakeFrac (IndividualPoolStake s c vrf) =
+      IndividualPoolStake (s * stakeRatio) c vrf
 
 -- | Calculate the current total stake.
 getTotalStake :: Globals -> NewEpochState era -> Coin
@@ -255,7 +255,7 @@ getNonMyopicMemberRewards globals ss =
           ,
             ( percentile' (histLookup k)
             , p
-            , toShare . EB.sumAllStake $ EB.poolStake k delegs stake
+            , toShare . fromCompact . EB.sumAllStake $ EB.poolStake k delegs stake
             )
           )
         | (k, p) <- VMap.toAscList poolParams
@@ -392,7 +392,7 @@ getRewardInfoPools globals ss =
             unPerformanceEstimate $ percentile' $ histLookup key
         }
       where
-        pstake = EB.sumAllStake $ EB.poolStake key delegs stakes
+        pstake = fromCompact $ EB.sumAllStake $ EB.poolStake key delegs stakes
         ostake = sumPoolOwnersStake poolp stakes
 
 -- | Calculate stake pool rewards from the snapshot labeled `go`.

diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/LedgerState/PulsingReward.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/LedgerState/PulsingReward.hs
@@ -161,7 +161,7 @@ startStep slotsPerEpoch b@(BlocksMade b') es@(EpochState acnt ls ss nm) maxSuppl
           delegs
           stakePerPool
           totalStake
-          activestake
+          $ UM.fromCompact activestake
       -- We map over the registered stake pools to compute the revelant
       -- stake pool specific values.
       allPoolInfo = VMap.map mkPoolRewardInfoCurry poolParams

diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/NewEpoch.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/NewEpoch.hs
@@ -150,7 +150,7 @@ instance
           (BlocksMade Map.empty)
           def
           SNothing
-          (PoolDistr Map.empty)
+          (PoolDistr Map.empty mempty)
           def
     ]
 

diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Transition.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Transition.hs
@@ -282,7 +282,7 @@ createInitialState tc =
             , esNonMyopic = def
             }
       , nesRu = SNothing
-      , nesPd = PoolDistr Map.empty
+      , nesPd = PoolDistr Map.empty mempty
       , stashedAVVMAddresses = def
       }
   where

diff --git a/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/ImpTest.hs b/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/ImpTest.hs
@@ -444,15 +444,18 @@ initShelleyImpNES =
             (activeSlotCoeff testGlobals)
             10
     , nesPd =
-        PoolDistr $
-          Map.fromList
-            [
-              ( testKeyHash
-              , IndividualPoolStake
-                  1
-                  (mkHashVerKeyVRF @era 0)
-              )
-            ]
+        PoolDistr
+          ( Map.fromList
+              [
+                ( testKeyHash
+                , IndividualPoolStake
+                    1
+                    (CompactCoin 1)
+                    (mkHashVerKeyVRF @era 0)
+                )
+              ]
+          )
+          (CompactCoin 1)
     , nesEs = epochState
     , nesEL = 0
     , nesBprev = BlocksMade (Map.singleton testKeyHash 10)

diff --git a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Examples/Consensus.hs b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Examples/Consensus.hs
@@ -248,15 +248,18 @@ exampleProposedPParamsUpdates =
 
 examplePoolDistr :: forall c. PraosCrypto c => PoolDistr c
 examplePoolDistr =
-  PoolDistr $
-    Map.fromList
-      [
-        ( mkKeyHash 1
-        , IndividualPoolStake
-            1
-            (hashVerKeyVRF (vrfVerKey (aikVrf (exampleKeys @c))))
-        )
-      ]
+  PoolDistr
+    ( Map.fromList
+        [
+          ( mkKeyHash 1
+          , IndividualPoolStake
+              1
+              (CompactCoin 1)
+              (hashVerKeyVRF (vrfVerKey (aikVrf (exampleKeys @c))))
+          )
+        ]
+    )
+    (CompactCoin 1)
 
 exampleNonMyopicRewards ::
   forall c.

diff --git a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rewards.hs b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rewards.hs
@@ -484,7 +484,7 @@ rewardOld
   slotsPerEpoch = (rewards', hs)
     where
       totalBlocks = sum b
-      Coin activeStake = sumAllStake stake
+      Coin activeStake = fromCompact $ sumAllStake stake
       results ::
         [ ( KeyHash 'StakePool (EraCrypto era)
           , Maybe (Map (Credential 'Staking (EraCrypto era)) Coin)
@@ -497,7 +497,7 @@ rewardOld
             sigmaA = if activeStake == 0 then 0 else fromIntegral pstake % fromIntegral activeStake
             blocksProduced = Map.lookup hk b
             actgr = poolStake hk delegs stake
-            Coin pstake = sumAllStake actgr
+            Coin pstake = fromCompact $ sumAllStake actgr
             rewardMap = case blocksProduced of
               Nothing -> Nothing -- This is equivalent to calling rewarOnePool with n = 0
               Just n ->
@@ -784,7 +784,7 @@ reward
           delegs
           stakePerPool
           totalStake
-          activeStake
+          (fromCompact activeStake)
           pool
       free =
         FreeVars

diff --git a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/Chain.hs b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/Chain.hs
@@ -233,7 +233,7 @@ initialShelleyState lab e utxo reserves genDelegs pp initNonce =
             & futurePParamsEpochStateL .~ PotentialPParamsUpdate Nothing
         )
         SNothing
-        (PoolDistr Map.empty)
+        (PoolDistr Map.empty mempty)
         def
     )
     cs