{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

-- |
-- Module      : Test.Cardano.Ledger.Shelley.Examples.TwoPools
-- Description : Two Pools Example
--
-- Example demonstrating a particular delegation scenario involving
-- two pools. Both pools select a reward account which is *not*
-- a pool owner, and which delegates to one of the pools.
module Test.Cardano.Ledger.Shelley.Examples.TwoPools (
  twoPoolsExample,
  twoPoolsExampleExtended,
)
where

import Cardano.Ledger.BaseTypes (
  BlocksMade (..),
  BoundedRational (..),
  Globals (..),
  Network (..),
  Nonce,
  ProtVer (..),
  StrictMaybe (..),
  activeSlotVal,
  mkCertIxPartial,
  natVersion,
  (⭒),
 )
import Cardano.Ledger.Block (Block, bheader)
import Cardano.Ledger.Coin (
  Coin (..),
  CompactForm (CompactCoin),
  DeltaCoin (..),
  compactCoinOrError,
  rationalToCoinViaFloor,
  toDeltaCoin,
 )
import Cardano.Ledger.Credential (Credential, Ptr (..), SlotNo32 (..))
import qualified Cardano.Ledger.EpochBoundary as EB
import Cardano.Ledger.Keys (asWitness, coerceKeyRole)
import Cardano.Ledger.PoolDistr (
  IndividualPoolStake (..),
  PoolDistr (..),
 )
import Cardano.Ledger.PoolParams (PoolParams (..))
import Cardano.Ledger.Shelley
import Cardano.Ledger.Shelley.Core
import Cardano.Ledger.Shelley.LedgerState (
  PulsingRewUpdate (..),
  RewardUpdate (..),
  completeStep,
  emptyRewardUpdate,
 )
import Cardano.Ledger.Shelley.PoolRank (
  Likelihood (..),
  NonMyopic (..),
  leaderProbability,
  likelihood,
 )
import Cardano.Ledger.Shelley.Rewards (
  StakeShare (..),
  aggregateRewards,
  leaderRew,
  memberRew,
  mkApparentPerformance,
  sumRewards,
 )
import Cardano.Ledger.Shelley.Tx (
  ShelleyTx (..),
 )
import Cardano.Ledger.Shelley.TxBody (RewardAccount (..), ShelleyTxBody (..))
import Cardano.Ledger.Shelley.TxOut (ShelleyTxOut (..))
import Cardano.Ledger.Shelley.TxWits (
  addrWits,
 )
import Cardano.Ledger.Slot (
  BlockNo (..),
  EpochNo (..),
  SlotNo (..),
 )
import Cardano.Ledger.TxIn (TxIn (..))
import Cardano.Ledger.UTxO (UTxO (..))
import Cardano.Ledger.Val ((<+>), (<->), (<×>))
import qualified Cardano.Ledger.Val as Val
import Cardano.Protocol.TPraos.BHeader (BHeader, bhHash, hashHeaderToNonce)
import Cardano.Protocol.TPraos.OCert (KESPeriod (..))
import Data.Default (def)
import Data.Group (invert)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Ratio ((%))
import qualified Data.Sequence.Strict as StrictSeq
import Data.Set (Set)
import qualified Data.Set as Set
import GHC.Stack (HasCallStack)
import Lens.Micro ((&), (.~), (^.))
import Test.Cardano.Ledger.Core.KeyPair (mkWitnessesVKey)
import Test.Cardano.Ledger.Shelley.ConcreteCryptoTypes (C, MockCrypto)
import Test.Cardano.Ledger.Shelley.Examples (CHAINExample (..), testCHAINExample)
import qualified Test.Cardano.Ledger.Shelley.Examples.Cast as Cast
import qualified Test.Cardano.Ledger.Shelley.Examples.Combinators as C
import Test.Cardano.Ledger.Shelley.Examples.Federation (
  coreNodeKeysBySchedule,
 )
import Test.Cardano.Ledger.Shelley.Examples.Init (
  initSt,
  lastByronHeaderHash,
  nonce0,
  ppEx,
 )
import Test.Cardano.Ledger.Shelley.Examples.PoolLifetime (makeCompletedPulser, mkStake)
import Test.Cardano.Ledger.Shelley.Generator.Core (
  AllIssuerKeys (..),
  NatNonce (..),
  genesisCoins,
  mkBlockFakeVRF,
  mkOCert,
 )
import Test.Cardano.Ledger.Shelley.Generator.EraGen (genesisId)
import Test.Cardano.Ledger.Shelley.Generator.ShelleyEraGen ()
import Test.Cardano.Ledger.Shelley.Rules.Chain (ChainState (..))
import Test.Cardano.Ledger.Shelley.Utils (
  epochSize,
  getBlockNonce,
  maxLLSupply,
  runShelleyBase,
  testGlobals,
  unsafeBoundRational,
 )
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.HUnit (Assertion, testCase, (@?=))

aliceInitCoin :: Coin
aliceInitCoin :: Coin
aliceInitCoin = Integer -> Coin
Coin Integer
10_000_000_000_000_000

bobInitCoin :: Coin
bobInitCoin :: Coin
bobInitCoin = Integer -> Coin
Coin Integer
1_000_000_000_000_000

carlInitCoin :: Coin
carlInitCoin :: Coin
carlInitCoin = Integer -> Coin
Coin Integer
5_000_000_000_000_000

initUTxO :: UTxO C
initUTxO :: UTxO C
initUTxO =
  forall era. TxId -> [TxOut era] -> UTxO era
genesisCoins
    TxId
genesisId
    [ forall era.
(HasCallStack, Era era, Val (Value era)) =>
Addr -> Value era -> ShelleyTxOut era
ShelleyTxOut Addr
Cast.aliceAddr (forall t s. Inject t s => t -> s
Val.inject Coin
aliceInitCoin)
    , forall era.
(HasCallStack, Era era, Val (Value era)) =>
Addr -> Value era -> ShelleyTxOut era
ShelleyTxOut Addr
Cast.bobAddr (forall t s. Inject t s => t -> s
Val.inject Coin
bobInitCoin)
    , forall era.
(HasCallStack, Era era, Val (Value era)) =>
Addr -> Value era -> ShelleyTxOut era
ShelleyTxOut Addr
Cast.carlAddr (forall t s. Inject t s => t -> s
Val.inject Coin
carlInitCoin)
    ]

initStTwoPools :: ChainState C
initStTwoPools :: ChainState C
initStTwoPools = forall era.
(EraTxOut era, ProtVerAtMost era 4, ProtVerAtMost era 6,
 Default (StashedAVVMAddresses era), EraGov era) =>
UTxO era -> ChainState era
initSt UTxO C
initUTxO

--
-- Block 1, Slot 10, Epoch 0
--

aliceCoinEx1 :: Coin
aliceCoinEx1 :: Coin
aliceCoinEx1 =
  Coin
aliceInitCoin
    forall t. Val t => t -> t -> t
<-> ((Integer
2 :: Integer) forall t i. (Val t, Integral i) => i -> t -> t
<×> Integer -> Coin
Coin Integer
250)
    forall t. Val t => t -> t -> t
<-> ((Integer
3 :: Integer) forall t i. (Val t, Integral i) => i -> t -> t
<×> Integer -> Coin
Coin Integer
7)
    forall t. Val t => t -> t -> t
<-> Coin
feeTx1

feeTx1 :: Coin
feeTx1 :: Coin
feeTx1 = Integer -> Coin
Coin Integer
3

alicePoolParams' :: PoolParams
alicePoolParams' :: PoolParams
alicePoolParams' = PoolParams
Cast.alicePoolParams {ppRewardAccount :: RewardAccount
ppRewardAccount = Network -> Credential 'Staking -> RewardAccount
RewardAccount Network
Testnet Credential 'Staking
Cast.carlSHK}

bobPoolParams' :: PoolParams
bobPoolParams' :: PoolParams
bobPoolParams' = PoolParams
Cast.bobPoolParams {ppRewardAccount :: RewardAccount
ppRewardAccount = Network -> Credential 'Staking -> RewardAccount
RewardAccount Network
Testnet Credential 'Staking
Cast.carlSHK}

txbodyEx1 :: TxBody C
txbodyEx1 :: TxBody C
txbodyEx1 =
  forall era.
(EraTxOut era, EncCBOR (TxCert era)) =>
Set TxIn
-> StrictSeq (TxOut era)
-> StrictSeq (TxCert era)
-> Withdrawals
-> Coin
-> SlotNo
-> StrictMaybe (Update era)
-> StrictMaybe TxAuxDataHash
-> ShelleyTxBody era
ShelleyTxBody
    (forall a. Ord a => [a] -> Set a
Set.fromList [TxId -> TxIx -> TxIn
TxIn TxId
genesisId forall a. Bounded a => a
minBound])
    (forall a. [a] -> StrictSeq a
StrictSeq.fromList [forall era.
(HasCallStack, Era era, Val (Value era)) =>
Addr -> Value era -> ShelleyTxOut era
ShelleyTxOut Addr
Cast.aliceAddr (forall t s. Inject t s => t -> s
Val.inject Coin
aliceCoinEx1)])
    ( forall a. [a] -> StrictSeq a
StrictSeq.fromList
        [ forall era.
ShelleyEraTxCert era =>
Credential 'Staking -> TxCert era
RegTxCert Credential 'Staking
Cast.aliceSHK
        , forall era.
ShelleyEraTxCert era =>
Credential 'Staking -> TxCert era
RegTxCert Credential 'Staking
Cast.bobSHK
        , forall era.
ShelleyEraTxCert era =>
Credential 'Staking -> TxCert era
RegTxCert Credential 'Staking
Cast.carlSHK
        , forall era. EraTxCert era => PoolParams -> TxCert era
RegPoolTxCert PoolParams
alicePoolParams'
        , forall era. EraTxCert era => PoolParams -> TxCert era
RegPoolTxCert PoolParams
bobPoolParams'
        , forall era.
ShelleyEraTxCert era =>
Credential 'Staking -> KeyHash 'StakePool -> TxCert era
DelegStakeTxCert Credential 'Staking
Cast.aliceSHK (forall c (r :: KeyRole). AllIssuerKeys c r -> KeyHash r
aikColdKeyHash AllIssuerKeys MockCrypto 'StakePool
Cast.alicePoolKeys)
        , forall era.
ShelleyEraTxCert era =>
Credential 'Staking -> KeyHash 'StakePool -> TxCert era
DelegStakeTxCert Credential 'Staking
Cast.bobSHK (forall c (r :: KeyRole). AllIssuerKeys c r -> KeyHash r
aikColdKeyHash AllIssuerKeys MockCrypto 'StakePool
Cast.bobPoolKeys)
        , forall era.
ShelleyEraTxCert era =>
Credential 'Staking -> KeyHash 'StakePool -> TxCert era
DelegStakeTxCert Credential 'Staking
Cast.carlSHK (forall c (r :: KeyRole). AllIssuerKeys c r -> KeyHash r
aikColdKeyHash AllIssuerKeys MockCrypto 'StakePool
Cast.alicePoolKeys)
        ]
    )
    (Map RewardAccount Coin -> Withdrawals
Withdrawals forall k a. Map k a
Map.empty)
    Coin
feeTx1
    (Word64 -> SlotNo
SlotNo Word64
10)
    forall a. StrictMaybe a
SNothing
    forall a. StrictMaybe a
SNothing

txEx1 :: ShelleyTx C
txEx1 :: ShelleyTx C
txEx1 =
  forall era.
EraTx era =>
TxBody era
-> TxWits era -> StrictMaybe (TxAuxData era) -> ShelleyTx era
ShelleyTx
    TxBody C
txbodyEx1
    forall a. Monoid a => a
mempty
      { addrWits :: Set (WitVKey 'Witness)
addrWits =
          forall (kr :: KeyRole).
SafeHash EraIndependentTxBody
-> [KeyPair kr] -> Set (WitVKey 'Witness)
mkWitnessesVKey
            (forall x i. HashAnnotated x i => x -> SafeHash i
hashAnnotated TxBody C
txbodyEx1)
            ( (forall (a :: KeyRole -> *) (r :: KeyRole).
HasKeyRole a =>
a r -> a 'Witness
asWitness forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [KeyPair 'Payment
Cast.alicePay])
                forall a. Semigroup a => a -> a -> a
<> (forall (a :: KeyRole -> *) (r :: KeyRole).
HasKeyRole a =>
a r -> a 'Witness
asWitness forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [KeyPair 'Staking
Cast.aliceStake, KeyPair 'Staking
Cast.bobStake, KeyPair 'Staking
Cast.carlStake])
                forall a. Semigroup a => a -> a -> a
<> (forall (a :: KeyRole -> *) (r :: KeyRole).
HasKeyRole a =>
a r -> a 'Witness
asWitness forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [forall c (r :: KeyRole). AllIssuerKeys c r -> KeyPair r
aikCold AllIssuerKeys MockCrypto 'StakePool
Cast.alicePoolKeys, forall c (r :: KeyRole). AllIssuerKeys c r -> KeyPair r
aikCold AllIssuerKeys MockCrypto 'StakePool
Cast.bobPoolKeys])
            )
      }
    forall a. StrictMaybe a
SNothing

blockEx1 :: HasCallStack => Block (BHeader MockCrypto) C
blockEx1 :: HasCallStack => Block (BHeader MockCrypto) C
blockEx1 =
  forall era (r :: KeyRole) c.
(Crypto c, EraSegWits era, Signable (VRF c) (WithResult Seed),
 Signable (KES c) (BHBody c)) =>
HashHeader
-> AllIssuerKeys c r
-> [Tx era]
-> SlotNo
-> BlockNo
-> Nonce
-> NatNonce
-> UnitInterval
-> Word
-> Word
-> OCert c
-> Block (BHeader c) era
mkBlockFakeVRF
    HashHeader
lastByronHeaderHash
    (forall era.
(HasCallStack, EraPParams era) =>
PParams era -> Word64 -> AllIssuerKeys MockCrypto 'GenesisDelegate
coreNodeKeysBySchedule @C forall era.
(EraPParams era, ProtVerAtMost era 4, ProtVerAtMost era 6) =>
PParams era
ppEx Word64
10)
    [ShelleyTx C
txEx1]
    (Word64 -> SlotNo
SlotNo Word64
10)
    (Word64 -> BlockNo
BlockNo Word64
1)
    Nonce
nonce0
    (Natural -> NatNonce
NatNonce Natural
1)
    forall a. Bounded a => a
minBound
    Word
0
    Word
0
    (forall c (r :: KeyRole).
Crypto c =>
AllIssuerKeys c r -> Word64 -> KESPeriod -> OCert c
mkOCert (forall era.
(HasCallStack, EraPParams era) =>
PParams era -> Word64 -> AllIssuerKeys MockCrypto 'GenesisDelegate
coreNodeKeysBySchedule @C forall era.
(EraPParams era, ProtVerAtMost era 4, ProtVerAtMost era 6) =>
PParams era
ppEx Word64
10) Word64
0 (Word -> KESPeriod
KESPeriod Word
0))

expectedStEx1 :: ChainState C
expectedStEx1 :: ChainState C
expectedStEx1 =
  forall era. Nonce -> ChainState era -> ChainState era
C.evolveNonceUnfrozen (forall era. Block (BHeader MockCrypto) era -> Nonce
getBlockNonce HasCallStack => Block (BHeader MockCrypto) C
blockEx1)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
Block (BHeader MockCrypto) era -> ChainState era -> ChainState era
C.newLab HasCallStack => Block (BHeader MockCrypto) C
blockEx1
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraPParams era =>
PParams era
-> Coin
-> [Credential 'Staking]
-> [PoolParams]
-> ChainState era
-> ChainState era
C.feesAndDeposits
      forall era.
(EraPParams era, ProtVerAtMost era 4, ProtVerAtMost era 6) =>
PParams era
ppEx
      Coin
feeTx1
      [Credential 'Staking
Cast.aliceSHK, Credential 'Staking
Cast.bobSHK, Credential 'Staking
Cast.carlSHK]
      [PoolParams
alicePoolParams', PoolParams
bobPoolParams']
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
(EraTx era, EraGov era) =>
TxBody era -> ChainState era -> ChainState era
C.newUTxO TxBody C
txbodyEx1
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
Credential 'Staking -> Ptr -> ChainState era -> ChainState era
C.newStakeCred Credential 'Staking
Cast.aliceSHK (SlotNo32 -> TxIx -> CertIx -> Ptr
Ptr (Word32 -> SlotNo32
SlotNo32 Word32
10) forall a. Bounded a => a
minBound (HasCallStack => Integer -> CertIx
mkCertIxPartial Integer
0))
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
Credential 'Staking -> Ptr -> ChainState era -> ChainState era
C.newStakeCred Credential 'Staking
Cast.bobSHK (SlotNo32 -> TxIx -> CertIx -> Ptr
Ptr (Word32 -> SlotNo32
SlotNo32 Word32
10) forall a. Bounded a => a
minBound (HasCallStack => Integer -> CertIx
mkCertIxPartial Integer
1))
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
Credential 'Staking -> Ptr -> ChainState era -> ChainState era
C.newStakeCred Credential 'Staking
Cast.carlSHK (SlotNo32 -> TxIx -> CertIx -> Ptr
Ptr (Word32 -> SlotNo32
SlotNo32 Word32
10) forall a. Bounded a => a
minBound (HasCallStack => Integer -> CertIx
mkCertIxPartial Integer
2))
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. PoolParams -> ChainState era -> ChainState era
C.newPool PoolParams
alicePoolParams'
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. PoolParams -> ChainState era -> ChainState era
C.newPool PoolParams
bobPoolParams'
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
Credential 'Staking
-> KeyHash 'StakePool -> ChainState era -> ChainState era
C.delegation Credential 'Staking
Cast.aliceSHK (PoolParams -> KeyHash 'StakePool
ppId PoolParams
alicePoolParams')
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
Credential 'Staking
-> KeyHash 'StakePool -> ChainState era -> ChainState era
C.delegation Credential 'Staking
Cast.bobSHK (PoolParams -> KeyHash 'StakePool
ppId PoolParams
bobPoolParams')
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
Credential 'Staking
-> KeyHash 'StakePool -> ChainState era -> ChainState era
C.delegation Credential 'Staking
Cast.carlSHK (PoolParams -> KeyHash 'StakePool
ppId PoolParams
alicePoolParams')
    forall a b. (a -> b) -> a -> b
$ ChainState C
initStTwoPools

-- === Block 1, Slot 10, Epoch 0
--
-- In the first block of this example, Alice, Bob, and Carl register
-- stake credentials, Alice and Bob register stake pools,
-- Alice and Carl delegate to Alice's pool, and Bob delegates to Bob's pool.
--
-- This is the only block in this example that includes a transaction,
-- and after this block is processed, the UTxO will consist entirely
-- of Alice's new coin aliceCoinEx1, and Bob and Carls initial genesis coins.
twoPools1 :: CHAINExample C
twoPools1 :: CHAINExample C
twoPools1 = forall era.
ChainState era
-> Block (BHeader MockCrypto) era
-> Either
     (NonEmpty (PredicateFailure (CHAIN era))) (ChainState era)
-> CHAINExample era
CHAINExample ChainState C
initStTwoPools HasCallStack => Block (BHeader MockCrypto) C
blockEx1 (forall a b. b -> Either a b
Right ChainState C
expectedStEx1)

--
-- Block 2, Slot 90, Epoch 0
--
blockEx2 :: Block (BHeader MockCrypto) C
blockEx2 :: Block (BHeader MockCrypto) C
blockEx2 =
  forall era (r :: KeyRole) c.
(Crypto c, EraSegWits era, Signable (VRF c) (WithResult Seed),
 Signable (KES c) (BHBody c)) =>
HashHeader
-> AllIssuerKeys c r
-> [Tx era]
-> SlotNo
-> BlockNo
-> Nonce
-> NatNonce
-> UnitInterval
-> Word
-> Word
-> OCert c
-> Block (BHeader c) era
mkBlockFakeVRF
    (forall c. Crypto c => BHeader c -> HashHeader
bhHash forall a b. (a -> b) -> a -> b
$ forall h era. Block h era -> h
bheader HasCallStack => Block (BHeader MockCrypto) C
blockEx1)
    (forall era.
(HasCallStack, EraPParams era) =>
PParams era -> Word64 -> AllIssuerKeys MockCrypto 'GenesisDelegate
coreNodeKeysBySchedule @C forall era.
(EraPParams era, ProtVerAtMost era 4, ProtVerAtMost era 6) =>
PParams era
ppEx Word64
90)
    []
    (Word64 -> SlotNo
SlotNo Word64
90)
    (Word64 -> BlockNo
BlockNo Word64
2)
    Nonce
nonce0
    (Natural -> NatNonce
NatNonce Natural
2)
    forall a. Bounded a => a
minBound
    Word
4
    Word
0
    (forall c (r :: KeyRole).
Crypto c =>
AllIssuerKeys c r -> Word64 -> KESPeriod -> OCert c
mkOCert (forall era.
(HasCallStack, EraPParams era) =>
PParams era -> Word64 -> AllIssuerKeys MockCrypto 'GenesisDelegate
coreNodeKeysBySchedule @C forall era.
(EraPParams era, ProtVerAtMost era 4, ProtVerAtMost era 6) =>
PParams era
ppEx Word64
90) Word64
0 (Word -> KESPeriod
KESPeriod Word
0))

expectedStEx2 :: ChainState C
expectedStEx2 :: ChainState C
expectedStEx2 =
  forall era. Nonce -> ChainState era -> ChainState era
C.evolveNonceFrozen (forall era. Block (BHeader MockCrypto) era -> Nonce
getBlockNonce Block (BHeader MockCrypto) C
blockEx2)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
Block (BHeader MockCrypto) era -> ChainState era -> ChainState era
C.newLab Block (BHeader MockCrypto) C
blockEx2
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. RewardUpdate -> ChainState era -> ChainState era
C.rewardUpdate RewardUpdate
emptyRewardUpdate
    forall a b. (a -> b) -> a -> b
$ ChainState C
expectedStEx1

-- === Block 2, Slot 90, Epoch 0
--
-- Create an empty block near the end of epoch 0 to close out the epoch.
twoPools2 :: CHAINExample C
twoPools2 :: CHAINExample C
twoPools2 = forall era.
ChainState era
-> Block (BHeader MockCrypto) era
-> Either
     (NonEmpty (PredicateFailure (CHAIN era))) (ChainState era)
-> CHAINExample era
CHAINExample ChainState C
expectedStEx1 Block (BHeader MockCrypto) C
blockEx2 (forall a b. b -> Either a b
Right ChainState C
expectedStEx2)

--
-- Block 3, Slot 110, Epoch 1
--

epoch1Nonce :: Nonce
epoch1Nonce :: Nonce
epoch1Nonce = forall era. ChainState era -> Nonce
chainCandidateNonce ChainState C
expectedStEx2

blockEx3 :: Block (BHeader MockCrypto) C
blockEx3 :: Block (BHeader MockCrypto) C
blockEx3 =
  forall era (r :: KeyRole) c.
(Crypto c, EraSegWits era, Signable (VRF c) (WithResult Seed),
 Signable (KES c) (BHBody c)) =>
HashHeader
-> AllIssuerKeys c r
-> [Tx era]
-> SlotNo
-> BlockNo
-> Nonce
-> NatNonce
-> UnitInterval
-> Word
-> Word
-> OCert c
-> Block (BHeader c) era
mkBlockFakeVRF
    (forall c. Crypto c => BHeader c -> HashHeader
bhHash forall a b. (a -> b) -> a -> b
$ forall h era. Block h era -> h
bheader Block (BHeader MockCrypto) C
blockEx2)
    (forall era.
(HasCallStack, EraPParams era) =>
PParams era -> Word64 -> AllIssuerKeys MockCrypto 'GenesisDelegate
coreNodeKeysBySchedule @C forall era.
(EraPParams era, ProtVerAtMost era 4, ProtVerAtMost era 6) =>
PParams era
ppEx Word64
110)
    []
    (Word64 -> SlotNo
SlotNo Word64
110)
    (Word64 -> BlockNo
BlockNo Word64
3)
    Nonce
epoch1Nonce
    (Natural -> NatNonce
NatNonce Natural
3)
    forall a. Bounded a => a
minBound
    Word
5
    Word
0
    (forall c (r :: KeyRole).
Crypto c =>
AllIssuerKeys c r -> Word64 -> KESPeriod -> OCert c
mkOCert (forall era.
(HasCallStack, EraPParams era) =>
PParams era -> Word64 -> AllIssuerKeys MockCrypto 'GenesisDelegate
coreNodeKeysBySchedule @C forall era.
(EraPParams era, ProtVerAtMost era 4, ProtVerAtMost era 6) =>
PParams era
ppEx Word64
110) Word64
0 (Word -> KESPeriod
KESPeriod Word
0))

snapEx3 :: EB.SnapShot
snapEx3 :: SnapShot
snapEx3 =
  EB.SnapShot
    { $sel:ssStake:SnapShot :: Stake
EB.ssStake =
        [(Credential 'Staking, Coin)] -> Stake
mkStake
          [ (Credential 'Staking
Cast.aliceSHK, Coin
aliceCoinEx1)
          , (Credential 'Staking
Cast.bobSHK, Coin
bobInitCoin)
          , (Credential 'Staking
Cast.carlSHK, Coin
carlInitCoin)
          ]
    , $sel:ssDelegations:SnapShot :: VMap VB VB (Credential 'Staking) (KeyHash 'StakePool)
EB.ssDelegations =
        [ (Credential 'Staking
Cast.aliceSHK, forall c (r :: KeyRole). AllIssuerKeys c r -> KeyHash r
aikColdKeyHash AllIssuerKeys MockCrypto 'StakePool
Cast.alicePoolKeys)
        , (Credential 'Staking
Cast.bobSHK, forall c (r :: KeyRole). AllIssuerKeys c r -> KeyHash r
aikColdKeyHash AllIssuerKeys MockCrypto 'StakePool
Cast.bobPoolKeys)
        , (Credential 'Staking
Cast.carlSHK, forall c (r :: KeyRole). AllIssuerKeys c r -> KeyHash r
aikColdKeyHash AllIssuerKeys MockCrypto 'StakePool
Cast.alicePoolKeys)
        ]
    , $sel:ssPoolParams:SnapShot :: VMap VB VB (KeyHash 'StakePool) PoolParams
EB.ssPoolParams =
        [ (forall c (r :: KeyRole). AllIssuerKeys c r -> KeyHash r
aikColdKeyHash AllIssuerKeys MockCrypto 'StakePool
Cast.alicePoolKeys, PoolParams
alicePoolParams')
        , (forall c (r :: KeyRole). AllIssuerKeys c r -> KeyHash r
aikColdKeyHash AllIssuerKeys MockCrypto 'StakePool
Cast.bobPoolKeys, PoolParams
bobPoolParams')
        ]
    }

expectedStEx3 :: ChainState C
expectedStEx3 :: ChainState C
expectedStEx3 =
  forall era.
(ProtVerAtMost era 6, EraGov era) =>
Block (BHeader MockCrypto) era -> ChainState era -> ChainState era
C.newEpoch Block (BHeader MockCrypto) C
blockEx3
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. SnapShot -> Coin -> ChainState era -> ChainState era
C.newSnapshot SnapShot
snapEx3 Coin
feeTx1
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraGov era =>
RewardUpdate -> ChainState era -> ChainState era
C.applyRewardUpdate RewardUpdate
emptyRewardUpdate
    forall a b. (a -> b) -> a -> b
$ ChainState C
expectedStEx2

-- === Block 3, Slot 110, Epoch 1
--
-- Create an empty block at the begining of epoch 1 to trigger the epoch change.
twoPools3 :: CHAINExample C
twoPools3 :: CHAINExample C
twoPools3 = forall era.
ChainState era
-> Block (BHeader MockCrypto) era
-> Either
     (NonEmpty (PredicateFailure (CHAIN era))) (ChainState era)
-> CHAINExample era
CHAINExample ChainState C
expectedStEx2 Block (BHeader MockCrypto) C
blockEx3 (forall a b. b -> Either a b
Right ChainState C
expectedStEx3)

--
-- Block 4, Slot 190, Epoch 1
--

blockEx4 :: Block (BHeader MockCrypto) C
blockEx4 :: Block (BHeader MockCrypto) C
blockEx4 =
  forall era (r :: KeyRole) c.
(Crypto c, EraSegWits era, Signable (VRF c) (WithResult Seed),
 Signable (KES c) (BHBody c)) =>
HashHeader
-> AllIssuerKeys c r
-> [Tx era]
-> SlotNo
-> BlockNo
-> Nonce
-> NatNonce
-> UnitInterval
-> Word
-> Word
-> OCert c
-> Block (BHeader c) era
mkBlockFakeVRF
    (forall c. Crypto c => BHeader c -> HashHeader
bhHash forall a b. (a -> b) -> a -> b
$ forall h era. Block h era -> h
bheader Block (BHeader MockCrypto) C
blockEx3)
    (forall era.
(HasCallStack, EraPParams era) =>
PParams era -> Word64 -> AllIssuerKeys MockCrypto 'GenesisDelegate
coreNodeKeysBySchedule @C forall era.
(EraPParams era, ProtVerAtMost era 4, ProtVerAtMost era 6) =>
PParams era
ppEx Word64
190)
    []
    (Word64 -> SlotNo
SlotNo Word64
190)
    (Word64 -> BlockNo
BlockNo Word64
4)
    Nonce
epoch1Nonce
    (Natural -> NatNonce
NatNonce Natural
4)
    forall a. Bounded a => a
minBound
    Word
9
    Word
0
    (forall c (r :: KeyRole).
Crypto c =>
AllIssuerKeys c r -> Word64 -> KESPeriod -> OCert c
mkOCert (forall era.
(HasCallStack, EraPParams era) =>
PParams era -> Word64 -> AllIssuerKeys MockCrypto 'GenesisDelegate
coreNodeKeysBySchedule @C forall era.
(EraPParams era, ProtVerAtMost era 4, ProtVerAtMost era 6) =>
PParams era
ppEx Word64
190) Word64
0 (Word -> KESPeriod
KESPeriod Word
0))

deltaREx4 :: Coin
deltaREx4 :: Coin
deltaREx4 = Integer -> Coin
Coin Integer
3

rewardUpdateEx4 :: RewardUpdate
rewardUpdateEx4 :: RewardUpdate
rewardUpdateEx4 =
  RewardUpdate
    { deltaT :: DeltaCoin
deltaT = Integer -> DeltaCoin
DeltaCoin Integer
0
    , deltaR :: DeltaCoin
deltaR = Coin -> DeltaCoin
toDeltaCoin Coin
deltaREx4 -- No rewards paid out, fees go to reserves
    , rs :: Map (Credential 'Staking) (Set Reward)
rs = forall k a. Map k a
Map.empty
    , deltaF :: DeltaCoin
deltaF = forall m. Group m => m -> m
invert forall a b. (a -> b) -> a -> b
$ Coin -> DeltaCoin
toDeltaCoin Coin
feeTx1
    , nonMyopic :: NonMyopic
nonMyopic = forall a. Default a => a
def {rewardPotNM :: Coin
rewardPotNM = Coin
feeTx1}
    }

expectedStEx4 :: ChainState C
expectedStEx4 :: ChainState C
expectedStEx4 =
  forall era. Nonce -> ChainState era -> ChainState era
C.evolveNonceFrozen (forall era. Block (BHeader MockCrypto) era -> Nonce
getBlockNonce Block (BHeader MockCrypto) C
blockEx4)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
Block (BHeader MockCrypto) era -> ChainState era -> ChainState era
C.newLab Block (BHeader MockCrypto) C
blockEx4
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. RewardUpdate -> ChainState era -> ChainState era
C.rewardUpdate RewardUpdate
rewardUpdateEx4
    forall a b. (a -> b) -> a -> b
$ ChainState C
expectedStEx3

-- === Block 4, Slot 190, Epoch 1
--
-- Create an empty block near the end of epoch 0 to close out the epoch,
-- preparing the way for the first non-empty pool distribution.
twoPools4 :: CHAINExample C
twoPools4 :: CHAINExample C
twoPools4 = forall era.
ChainState era
-> Block (BHeader MockCrypto) era
-> Either
     (NonEmpty (PredicateFailure (CHAIN era))) (ChainState era)
-> CHAINExample era
CHAINExample ChainState C
expectedStEx3 Block (BHeader MockCrypto) C
blockEx4 (forall a b. b -> Either a b
Right ChainState C
expectedStEx4)

epoch2Nonce :: Nonce
epoch2Nonce :: Nonce
epoch2Nonce =
  forall era. ChainState era -> Nonce
chainCandidateNonce ChainState C
expectedStEx4
    Nonce -> Nonce -> Nonce
⭒ HashHeader -> Nonce
hashHeaderToNonce (forall c. Crypto c => BHeader c -> HashHeader
bhHash forall a b. (a -> b) -> a -> b
$ forall h era. Block h era -> h
bheader Block (BHeader MockCrypto) C
blockEx2)

--
-- Block 5, Slot 221, Epoch 2
--

blockEx5 :: Block (BHeader MockCrypto) C
blockEx5 :: Block (BHeader MockCrypto) C
blockEx5 =
  forall era (r :: KeyRole) c.
(Crypto c, EraSegWits era, Signable (VRF c) (WithResult Seed),
 Signable (KES c) (BHBody c)) =>
HashHeader
-> AllIssuerKeys c r
-> [Tx era]
-> SlotNo
-> BlockNo
-> Nonce
-> NatNonce
-> UnitInterval
-> Word
-> Word
-> OCert c
-> Block (BHeader c) era
mkBlockFakeVRF
    (forall c. Crypto c => BHeader c -> HashHeader
bhHash forall a b. (a -> b) -> a -> b
$ forall h era. Block h era -> h
bheader Block (BHeader MockCrypto) C
blockEx4)
    AllIssuerKeys MockCrypto 'StakePool
Cast.alicePoolKeys
    []
    (Word64 -> SlotNo
SlotNo Word64
221) -- odd slots open for decentralization
    (Word64 -> BlockNo
BlockNo Word64
5)
    Nonce
epoch2Nonce
    (Natural -> NatNonce
NatNonce Natural
5)
    forall a. Bounded a => a
minBound
    Word
11
    Word
10
    (forall c (r :: KeyRole).
Crypto c =>
AllIssuerKeys c r -> Word64 -> KESPeriod -> OCert c
mkOCert AllIssuerKeys MockCrypto 'StakePool
Cast.alicePoolKeys Word64
0 (Word -> KESPeriod
KESPeriod Word
10))

activeStakeEx5 :: Integer
activeStakeEx5 :: Integer
activeStakeEx5 = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Coin -> Integer
unCoin [Coin
aliceCoinEx1, Coin
bobInitCoin, Coin
carlInitCoin]

alicePoolStake :: Rational
alicePoolStake :: Rational
alicePoolStake = (Coin -> Integer
unCoin Coin
aliceCoinEx1 forall a. Num a => a -> a -> a
+ Coin -> Integer
unCoin Coin
carlInitCoin) forall a. Integral a => a -> a -> Ratio a
% Integer
activeStakeEx5

bobPoolStake :: Rational
bobPoolStake :: Rational
bobPoolStake = Coin -> Integer
unCoin Coin
bobInitCoin forall a. Integral a => a -> a -> Ratio a
% Integer
activeStakeEx5

pdEx5 :: PoolDistr
pdEx5 :: PoolDistr
pdEx5 =
  Map (KeyHash 'StakePool) IndividualPoolStake
-> CompactForm Coin -> PoolDistr
PoolDistr
    ( forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
        [
          ( forall c (r :: KeyRole). AllIssuerKeys c r -> KeyHash r
aikColdKeyHash AllIssuerKeys MockCrypto 'StakePool
Cast.alicePoolKeys
          , Rational
-> CompactForm Coin
-> VRFVerKeyHash 'StakePoolVRF
-> IndividualPoolStake
IndividualPoolStake
              Rational
alicePoolStake
              (HasCallStack => Coin -> CompactForm Coin
compactCoinOrError forall a b. (a -> b) -> a -> b
$ Coin
aliceCoinEx1 forall a. Semigroup a => a -> a -> a
<> Coin
carlInitCoin)
              VRFVerKeyHash 'StakePoolVRF
Cast.aliceVRFKeyHash
          )
        ,
          ( forall c (r :: KeyRole). AllIssuerKeys c r -> KeyHash r
aikColdKeyHash AllIssuerKeys MockCrypto 'StakePool
Cast.bobPoolKeys
          , Rational
-> CompactForm Coin
-> VRFVerKeyHash 'StakePoolVRF
-> IndividualPoolStake
IndividualPoolStake
              Rational
bobPoolStake
              (HasCallStack => Coin -> CompactForm Coin
compactCoinOrError Coin
bobInitCoin)
              VRFVerKeyHash 'StakePoolVRF
Cast.bobVRFKeyHash
          )
        ]
    )
    (Word64 -> CompactForm Coin
CompactCoin forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
activeStakeEx5)

expectedStEx5 :: ChainState C
expectedStEx5 :: ChainState C
expectedStEx5 =
  forall era. KeyHash 'StakePool -> ChainState era -> ChainState era
C.incrBlockCount (forall c (r :: KeyRole). AllIssuerKeys c r -> KeyHash r
aikColdKeyHash AllIssuerKeys MockCrypto 'StakePool
Cast.alicePoolKeys)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. SnapShot -> Coin -> ChainState era -> ChainState era
C.newSnapshot SnapShot
snapEx3 (Integer -> Coin
Coin Integer
0)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraGov era =>
RewardUpdate -> ChainState era -> ChainState era
C.applyRewardUpdate RewardUpdate
rewardUpdateEx4
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. PoolDistr -> ChainState era -> ChainState era
C.setPoolDistr PoolDistr
pdEx5
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
KeyHash 'BlockIssuer -> Word64 -> ChainState era -> ChainState era
C.setOCertCounter (forall (a :: KeyRole -> *) (r :: KeyRole) (r' :: KeyRole).
HasKeyRole a =>
a r -> a r'
coerceKeyRole forall a b. (a -> b) -> a -> b
$ forall c (r :: KeyRole). AllIssuerKeys c r -> KeyHash r
aikColdKeyHash AllIssuerKeys MockCrypto 'StakePool
Cast.alicePoolKeys) Word64
0
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
(ProtVerAtMost era 6, EraGov era) =>
Block (BHeader MockCrypto) era -> ChainState era -> ChainState era
C.newEpoch Block (BHeader MockCrypto) C
blockEx5 -- This must be processed before the incrBlockCount
    forall a b. (a -> b) -> a -> b
$ ChainState C
expectedStEx4

-- === Block 5, Slot 220, Epoch 2
--
-- Create the first non-empty pool distribution by starting the epoch 2.
-- Moreover, Alice's pool produces the block.
twoPools5 :: CHAINExample C
twoPools5 :: CHAINExample C
twoPools5 = forall era.
ChainState era
-> Block (BHeader MockCrypto) era
-> Either
     (NonEmpty (PredicateFailure (CHAIN era))) (ChainState era)
-> CHAINExample era
CHAINExample ChainState C
expectedStEx4 Block (BHeader MockCrypto) C
blockEx5 (forall a b. b -> Either a b
Right ChainState C
expectedStEx5)

--
-- Block 6, Slot 295, Epoch 2
--

blockEx6 :: Block (BHeader MockCrypto) C
blockEx6 :: Block (BHeader MockCrypto) C
blockEx6 =
  forall era (r :: KeyRole) c.
(Crypto c, EraSegWits era, Signable (VRF c) (WithResult Seed),
 Signable (KES c) (BHBody c)) =>
HashHeader
-> AllIssuerKeys c r
-> [Tx era]
-> SlotNo
-> BlockNo
-> Nonce
-> NatNonce
-> UnitInterval
-> Word
-> Word
-> OCert c
-> Block (BHeader c) era
mkBlockFakeVRF
    (forall c. Crypto c => BHeader c -> HashHeader
bhHash forall a b. (a -> b) -> a -> b
$ forall h era. Block h era -> h
bheader Block (BHeader MockCrypto) C
blockEx5)
    AllIssuerKeys MockCrypto 'StakePool
Cast.alicePoolKeys
    []
    (Word64 -> SlotNo
SlotNo Word64
295) -- odd slots open for decentralization
    (Word64 -> BlockNo
BlockNo Word64
6)
    Nonce
epoch2Nonce
    (Natural -> NatNonce
NatNonce Natural
6)
    forall a. Bounded a => a
minBound
    Word
14
    Word
14
    (forall c (r :: KeyRole).
Crypto c =>
AllIssuerKeys c r -> Word64 -> KESPeriod -> OCert c
mkOCert AllIssuerKeys MockCrypto 'StakePool
Cast.alicePoolKeys Word64
0 (Word -> KESPeriod
KESPeriod Word
14))

expectedStEx6 :: ChainState C
expectedStEx6 :: ChainState C
expectedStEx6 =
  forall era. Nonce -> ChainState era -> ChainState era
C.evolveNonceFrozen (forall era. Block (BHeader MockCrypto) era -> Nonce
getBlockNonce Block (BHeader MockCrypto) C
blockEx6)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
Block (BHeader MockCrypto) era -> ChainState era -> ChainState era
C.newLab Block (BHeader MockCrypto) C
blockEx6
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
KeyHash 'BlockIssuer -> Word64 -> ChainState era -> ChainState era
C.setOCertCounter (forall (a :: KeyRole -> *) (r :: KeyRole) (r' :: KeyRole).
HasKeyRole a =>
a r -> a r'
coerceKeyRole forall a b. (a -> b) -> a -> b
$ forall c (r :: KeyRole). AllIssuerKeys c r -> KeyHash r
aikColdKeyHash AllIssuerKeys MockCrypto 'StakePool
Cast.alicePoolKeys) Word64
0
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. KeyHash 'StakePool -> ChainState era -> ChainState era
C.incrBlockCount (forall c (r :: KeyRole). AllIssuerKeys c r -> KeyHash r
aikColdKeyHash AllIssuerKeys MockCrypto 'StakePool
Cast.alicePoolKeys)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. RewardUpdate -> ChainState era -> ChainState era
C.rewardUpdate RewardUpdate
emptyRewardUpdate
    forall a b. (a -> b) -> a -> b
$ ChainState C
expectedStEx5

-- === Block 6, Slot 295, Epoch 2
--
-- Alice's pool produces a second block.
twoPools6 :: CHAINExample C
twoPools6 :: CHAINExample C
twoPools6 = forall era.
ChainState era
-> Block (BHeader MockCrypto) era
-> Either
     (NonEmpty (PredicateFailure (CHAIN era))) (ChainState era)
-> CHAINExample era
CHAINExample ChainState C
expectedStEx5 Block (BHeader MockCrypto) C
blockEx6 (forall a b. b -> Either a b
Right ChainState C
expectedStEx6)

--
-- Block 7, Slot 297, Epoch 2
--

blockEx7 :: Block (BHeader MockCrypto) C
blockEx7 :: Block (BHeader MockCrypto) C
blockEx7 =
  forall era (r :: KeyRole) c.
(Crypto c, EraSegWits era, Signable (VRF c) (WithResult Seed),
 Signable (KES c) (BHBody c)) =>
HashHeader
-> AllIssuerKeys c r
-> [Tx era]
-> SlotNo
-> BlockNo
-> Nonce
-> NatNonce
-> UnitInterval
-> Word
-> Word
-> OCert c
-> Block (BHeader c) era
mkBlockFakeVRF
    (forall c. Crypto c => BHeader c -> HashHeader
bhHash forall a b. (a -> b) -> a -> b
$ forall h era. Block h era -> h
bheader @(BHeader MockCrypto) Block (BHeader MockCrypto) C
blockEx6)
    AllIssuerKeys MockCrypto 'StakePool
Cast.bobPoolKeys
    []
    (Word64 -> SlotNo
SlotNo Word64
297) -- odd slots open for decentralization
    (Word64 -> BlockNo
BlockNo Word64
7)
    Nonce
epoch2Nonce
    (Natural -> NatNonce
NatNonce Natural
7)
    forall a. Bounded a => a
minBound
    Word
14
    Word
14
    (forall c (r :: KeyRole).
Crypto c =>
AllIssuerKeys c r -> Word64 -> KESPeriod -> OCert c
mkOCert AllIssuerKeys MockCrypto 'StakePool
Cast.bobPoolKeys Word64
0 (Word -> KESPeriod
KESPeriod Word
14))

expectedStEx7 :: ChainState C
expectedStEx7 :: ChainState C
expectedStEx7 =
  forall era. Nonce -> ChainState era -> ChainState era
C.evolveNonceFrozen (forall era. Block (BHeader MockCrypto) era -> Nonce
getBlockNonce Block (BHeader MockCrypto) C
blockEx7)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
Block (BHeader MockCrypto) era -> ChainState era -> ChainState era
C.newLab Block (BHeader MockCrypto) C
blockEx7
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
KeyHash 'BlockIssuer -> Word64 -> ChainState era -> ChainState era
C.setOCertCounter (forall (a :: KeyRole -> *) (r :: KeyRole) (r' :: KeyRole).
HasKeyRole a =>
a r -> a r'
coerceKeyRole forall a b. (a -> b) -> a -> b
$ forall c (r :: KeyRole). AllIssuerKeys c r -> KeyHash r
aikColdKeyHash AllIssuerKeys MockCrypto 'StakePool
Cast.bobPoolKeys) Word64
0
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. KeyHash 'StakePool -> ChainState era -> ChainState era
C.incrBlockCount (forall c (r :: KeyRole). AllIssuerKeys c r -> KeyHash r
aikColdKeyHash AllIssuerKeys MockCrypto 'StakePool
Cast.bobPoolKeys)
    forall a b. (a -> b) -> a -> b
$ ChainState C
expectedStEx6

-- === Block 7, Slot 295, Epoch 2
--
-- Bob's pool produces a block.
twoPools7 :: CHAINExample C
twoPools7 :: CHAINExample C
twoPools7 = forall era.
ChainState era
-> Block (BHeader MockCrypto) era
-> Either
     (NonEmpty (PredicateFailure (CHAIN era))) (ChainState era)
-> CHAINExample era
CHAINExample ChainState C
expectedStEx6 Block (BHeader MockCrypto) C
blockEx7 (forall a b. b -> Either a b
Right ChainState C
expectedStEx7)

--
-- Block 8, Slot 310, Epoch 3
--

epoch3Nonce :: Nonce
epoch3Nonce :: Nonce
epoch3Nonce =
  forall era. ChainState era -> Nonce
chainCandidateNonce ChainState C
expectedStEx7
    Nonce -> Nonce -> Nonce
⭒ HashHeader -> Nonce
hashHeaderToNonce (forall c. Crypto c => BHeader c -> HashHeader
bhHash forall a b. (a -> b) -> a -> b
$ forall h era. Block h era -> h
bheader Block (BHeader MockCrypto) C
blockEx4)

blockEx8 :: Block (BHeader MockCrypto) C
blockEx8 :: Block (BHeader MockCrypto) C
blockEx8 =
  forall era (r :: KeyRole) c.
(Crypto c, EraSegWits era, Signable (VRF c) (WithResult Seed),
 Signable (KES c) (BHBody c)) =>
HashHeader
-> AllIssuerKeys c r
-> [Tx era]
-> SlotNo
-> BlockNo
-> Nonce
-> NatNonce
-> UnitInterval
-> Word
-> Word
-> OCert c
-> Block (BHeader c) era
mkBlockFakeVRF
    (forall c. Crypto c => BHeader c -> HashHeader
bhHash forall a b. (a -> b) -> a -> b
$ forall h era. Block h era -> h
bheader Block (BHeader MockCrypto) C
blockEx7)
    (forall era.
(HasCallStack, EraPParams era) =>
PParams era -> Word64 -> AllIssuerKeys MockCrypto 'GenesisDelegate
coreNodeKeysBySchedule @C forall era.
(EraPParams era, ProtVerAtMost era 4, ProtVerAtMost era 6) =>
PParams era
ppEx Word64
310)
    []
    (Word64 -> SlotNo
SlotNo Word64
310)
    (Word64 -> BlockNo
BlockNo Word64
8)
    Nonce
epoch3Nonce
    (Natural -> NatNonce
NatNonce Natural
8)
    forall a. Bounded a => a
minBound
    Word
15
    Word
15
    (forall c (r :: KeyRole).
Crypto c =>
AllIssuerKeys c r -> Word64 -> KESPeriod -> OCert c
mkOCert (forall era.
(HasCallStack, EraPParams era) =>
PParams era -> Word64 -> AllIssuerKeys MockCrypto 'GenesisDelegate
coreNodeKeysBySchedule @C forall era.
(EraPParams era, ProtVerAtMost era 4, ProtVerAtMost era 6) =>
PParams era
ppEx Word64
310) Word64
1 (Word -> KESPeriod
KESPeriod Word
15))

expectedStEx8 :: ChainState C
expectedStEx8 :: ChainState C
expectedStEx8 =
  forall era.
(ProtVerAtMost era 6, EraGov era) =>
Block (BHeader MockCrypto) era -> ChainState era -> ChainState era
C.newEpoch Block (BHeader MockCrypto) C
blockEx8
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. SnapShot -> Coin -> ChainState era -> ChainState era
C.newSnapshot SnapShot
snapEx3 (Integer -> Coin
Coin Integer
0)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
KeyHash 'BlockIssuer -> Word64 -> ChainState era -> ChainState era
C.setOCertCounter forall {r' :: KeyRole}. KeyHash r'
coreNodeHK Word64
1
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraGov era =>
RewardUpdate -> ChainState era -> ChainState era
C.applyRewardUpdate RewardUpdate
emptyRewardUpdate
    forall a b. (a -> b) -> a -> b
$ ChainState C
expectedStEx7
  where
    coreNodeHK :: KeyHash r'
coreNodeHK = forall (a :: KeyRole -> *) (r :: KeyRole) (r' :: KeyRole).
HasKeyRole a =>
a r -> a r'
coerceKeyRole forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c (r :: KeyRole). AllIssuerKeys c r -> KeyHash r
aikColdKeyHash forall a b. (a -> b) -> a -> b
$ forall era.
(HasCallStack, EraPParams era) =>
PParams era -> Word64 -> AllIssuerKeys MockCrypto 'GenesisDelegate
coreNodeKeysBySchedule @C forall era.
(EraPParams era, ProtVerAtMost era 4, ProtVerAtMost era 6) =>
PParams era
ppEx Word64
310

-- === Block 8, Slot 310, Epoch 3
--
-- Create an empty block to start epoch 3.
twoPools8 :: CHAINExample C
twoPools8 :: CHAINExample C
twoPools8 = forall era.
ChainState era
-> Block (BHeader MockCrypto) era
-> Either
     (NonEmpty (PredicateFailure (CHAIN era))) (ChainState era)
-> CHAINExample era
CHAINExample ChainState C
expectedStEx7 Block (BHeader MockCrypto) C
blockEx8 (forall a b. b -> Either a b
Right ChainState C
expectedStEx8)

--
-- Block 9, Slot 390, Epoch 3
--

blockEx9 :: Block (BHeader MockCrypto) C
blockEx9 :: Block (BHeader MockCrypto) C
blockEx9 =
  forall era (r :: KeyRole) c.
(Crypto c, EraSegWits era, Signable (VRF c) (WithResult Seed),
 Signable (KES c) (BHBody c)) =>
HashHeader
-> AllIssuerKeys c r
-> [Tx era]
-> SlotNo
-> BlockNo
-> Nonce
-> NatNonce
-> UnitInterval
-> Word
-> Word
-> OCert c
-> Block (BHeader c) era
mkBlockFakeVRF
    (forall c. Crypto c => BHeader c -> HashHeader
bhHash forall a b. (a -> b) -> a -> b
$ forall h era. Block h era -> h
bheader Block (BHeader MockCrypto) C
blockEx8)
    (forall era.
(HasCallStack, EraPParams era) =>
PParams era -> Word64 -> AllIssuerKeys MockCrypto 'GenesisDelegate
coreNodeKeysBySchedule @C forall era.
(EraPParams era, ProtVerAtMost era 4, ProtVerAtMost era 6) =>
PParams era
ppEx Word64
390)
    []
    (Word64 -> SlotNo
SlotNo Word64
390)
    (Word64 -> BlockNo
BlockNo Word64
9)
    Nonce
epoch3Nonce
    (Natural -> NatNonce
NatNonce Natural
9)
    forall a. Bounded a => a
minBound
    Word
19
    Word
19
    (forall c (r :: KeyRole).
Crypto c =>
AllIssuerKeys c r -> Word64 -> KESPeriod -> OCert c
mkOCert (forall era.
(HasCallStack, EraPParams era) =>
PParams era -> Word64 -> AllIssuerKeys MockCrypto 'GenesisDelegate
coreNodeKeysBySchedule @C forall era.
(EraPParams era, ProtVerAtMost era 4, ProtVerAtMost era 6) =>
PParams era
ppEx Word64
390) Word64
2 (Word -> KESPeriod
KESPeriod Word
19))

blocksMadeEpoch3 :: Integer
blocksMadeEpoch3 :: Integer
blocksMadeEpoch3 = Integer
3

expectedBlocks :: Integer
expectedBlocks :: Integer
expectedBlocks =
  forall a b. (RealFrac a, Integral b) => a -> b
floor forall a b. (a -> b) -> a -> b
$
    Rational
0.5
      forall a. Num a => a -> a -> a
* forall r. BoundedRational r => r -> Rational
unboundRational (ActiveSlotCoeff -> PositiveUnitInterval
activeSlotVal forall a b. (a -> b) -> a -> b
$ Globals -> ActiveSlotCoeff
activeSlotCoeff Globals
testGlobals)
      forall a. Num a => a -> a -> a
* forall a b. (Integral a, Num b) => a -> b
fromIntegral (EpochNo -> EpochSize
epochSize forall a b. (a -> b) -> a -> b
$ Word64 -> EpochNo
EpochNo Word64
3)

reserves9 :: Coin
reserves9 :: Coin
reserves9 = Coin
maxLLSupply forall t. Val t => t -> t -> t
<+> Coin
deltaREx4 forall t. Val t => t -> t -> t
<-> (Coin
aliceInitCoin forall t. Val t => t -> t -> t
<+> Coin
bobInitCoin forall t. Val t => t -> t -> t
<+> Coin
carlInitCoin)

deltaR1Ex9 :: Coin
deltaR1Ex9 :: Coin
deltaR1Ex9 =
  Rational -> Coin
rationalToCoinViaFloor forall a b. (a -> b) -> a -> b
$
    (Integer
blocksMadeEpoch3 forall a. Integral a => a -> a -> Ratio a
% Integer
expectedBlocks)
      forall a. Num a => a -> a -> a
* Rational
0.0021
      forall a. Num a => a -> a -> a
* (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. Coin -> Integer
unCoin forall a b. (a -> b) -> a -> b
$ Coin
reserves9)

rPot :: Integer
rPot :: Integer
rPot = Coin -> Integer
unCoin Coin
deltaR1Ex9 -- There were no fees

deltaTEx9 :: Integer
deltaTEx9 :: Integer
deltaTEx9 = forall a b. (RealFrac a, Integral b) => a -> b
floor forall a b. (a -> b) -> a -> b
$ (Double
0.2 :: Double) forall a. Num a => a -> a -> a
* forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
rPot

bigR :: Coin
bigR :: Coin
bigR = Integer -> Coin
Coin forall a b. (a -> b) -> a -> b
$ Integer
rPot forall a. Num a => a -> a -> a
- Integer
deltaTEx9

circulation :: Integer
circulation :: Integer
circulation = Coin -> Integer
unCoin forall a b. (a -> b) -> a -> b
$ Coin
maxLLSupply forall t. Val t => t -> t -> t
<-> Coin
reserves9

aliceStakeShareTot :: Rational
aliceStakeShareTot :: Rational
aliceStakeShareTot = (Coin -> Integer
unCoin Coin
aliceCoinEx1 forall a. Num a => a -> a -> a
+ Coin -> Integer
unCoin Coin
carlInitCoin) forall a. Integral a => a -> a -> Ratio a
% Integer
circulation

bobStakeShareTot :: Rational
bobStakeShareTot :: Rational
bobStakeShareTot = Coin -> Integer
unCoin Coin
bobInitCoin forall a. Integral a => a -> a -> Ratio a
% Integer
circulation

alicePoolRewards :: Coin
alicePoolRewards :: Coin
alicePoolRewards = Rational -> Coin
rationalToCoinViaFloor (Rational
appPerf forall a. Num a => a -> a -> a
* (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. Coin -> Integer
unCoin forall a b. (a -> b) -> a -> b
$ Coin
maxP))
  where
    appPerf :: Rational
appPerf = UnitInterval -> Rational -> Natural -> Natural -> Rational
mkApparentPerformance (forall era.
(EraPParams era, ProtVerAtMost era 4, ProtVerAtMost era 6) =>
PParams era
ppEx @ShelleyEra forall s a. s -> Getting a s a -> a
^. forall era.
(EraPParams era, ProtVerAtMost era 6) =>
Lens' (PParams era) UnitInterval
ppDL) Rational
alicePoolStake Natural
2 Natural
3
    pledge :: Integer
pledge = Coin -> Integer
unCoin forall a b. (a -> b) -> a -> b
$ PoolParams -> Coin
ppPledge PoolParams
alicePoolParams'
    pr :: Rational
pr = Integer
pledge forall a. Integral a => a -> a -> Ratio a
% Integer
circulation
    maxP :: Coin
maxP = forall era.
EraPParams era =>
PParams era -> Coin -> Rational -> Rational -> Coin
EB.maxPool @ShelleyEra forall era.
(EraPParams era, ProtVerAtMost era 4, ProtVerAtMost era 6) =>
PParams era
ppEx Coin
bigR Rational
aliceStakeShareTot Rational
pr

carlMemberRewardsFromAlice :: Coin
carlMemberRewardsFromAlice :: Coin
carlMemberRewardsFromAlice =
  Coin -> PoolParams -> StakeShare -> StakeShare -> Coin
memberRew
    Coin
alicePoolRewards
    PoolParams
alicePoolParams'
    (Rational -> StakeShare
StakeShare forall a b. (a -> b) -> a -> b
$ Coin -> Integer
unCoin Coin
carlInitCoin forall a. Integral a => a -> a -> Ratio a
% Integer
circulation)
    (Rational -> StakeShare
StakeShare Rational
aliceStakeShareTot)

carlLeaderRewardsFromAlice :: Coin
carlLeaderRewardsFromAlice :: Coin
carlLeaderRewardsFromAlice =
  Coin -> PoolParams -> StakeShare -> StakeShare -> Coin
leaderRew
    Coin
alicePoolRewards
    PoolParams
alicePoolParams'
    (Rational -> StakeShare
StakeShare forall a b. (a -> b) -> a -> b
$ Coin -> Integer
unCoin Coin
aliceCoinEx1 forall a. Integral a => a -> a -> Ratio a
% Integer
circulation)
    (Rational -> StakeShare
StakeShare Rational
aliceStakeShareTot)

bobPoolRewards :: Coin
bobPoolRewards :: Coin
bobPoolRewards = Rational -> Coin
rationalToCoinViaFloor (Rational
appPerf forall a. Num a => a -> a -> a
* (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. Coin -> Integer
unCoin forall a b. (a -> b) -> a -> b
$ Coin
maxP))
  where
    appPerf :: Rational
appPerf = UnitInterval -> Rational -> Natural -> Natural -> Rational
mkApparentPerformance (forall era.
(EraPParams era, ProtVerAtMost era 4, ProtVerAtMost era 6) =>
PParams era
ppEx @ShelleyEra forall s a. s -> Getting a s a -> a
^. forall era.
(EraPParams era, ProtVerAtMost era 6) =>
Lens' (PParams era) UnitInterval
ppDL) Rational
bobPoolStake Natural
1 Natural
3
    pledge :: Integer
pledge = Coin -> Integer
unCoin forall a b. (a -> b) -> a -> b
$ PoolParams -> Coin
ppPledge PoolParams
bobPoolParams'
    pr :: Rational
pr = Integer
pledge forall a. Integral a => a -> a -> Ratio a
% Integer
circulation
    maxP :: Coin
maxP = forall era.
EraPParams era =>
PParams era -> Coin -> Rational -> Rational -> Coin
EB.maxPool @ShelleyEra forall era.
(EraPParams era, ProtVerAtMost era 4, ProtVerAtMost era 6) =>
PParams era
ppEx Coin
bigR Rational
bobStakeShareTot Rational
pr

carlLeaderRewardsFromBob :: Coin
carlLeaderRewardsFromBob :: Coin
carlLeaderRewardsFromBob =
  Coin -> PoolParams -> StakeShare -> StakeShare -> Coin
leaderRew
    Coin
bobPoolRewards
    PoolParams
bobPoolParams'
    (Rational -> StakeShare
StakeShare forall a b. (a -> b) -> a -> b
$ Coin -> Integer
unCoin Coin
bobInitCoin forall a. Integral a => a -> a -> Ratio a
% Integer
circulation)
    (Rational -> StakeShare
StakeShare Rational
bobStakeShareTot)

alicePerfEx9 :: Likelihood
alicePerfEx9 :: Likelihood
alicePerfEx9 = Natural -> Double -> EpochSize -> Likelihood
likelihood Natural
blocks Double
t (EpochNo -> EpochSize
epochSize forall a b. (a -> b) -> a -> b
$ Word64 -> EpochNo
EpochNo Word64
3)
  where
    blocks :: Natural
blocks = Natural
2
    t :: Double
t = ActiveSlotCoeff -> Rational -> UnitInterval -> Double
leaderProbability ActiveSlotCoeff
f Rational
alicePoolStake (forall r.
(HasCallStack, Typeable r, BoundedRational r) =>
Rational -> r
unsafeBoundRational Rational
0.5)
    f :: ActiveSlotCoeff
f = Globals -> ActiveSlotCoeff
activeSlotCoeff Globals
testGlobals

bobPerfEx9 :: Likelihood
bobPerfEx9 :: Likelihood
bobPerfEx9 = Natural -> Double -> EpochSize -> Likelihood
likelihood Natural
blocks Double
t (EpochNo -> EpochSize
epochSize forall a b. (a -> b) -> a -> b
$ Word64 -> EpochNo
EpochNo Word64
3)
  where
    blocks :: Natural
blocks = Natural
1
    t :: Double
t = ActiveSlotCoeff -> Rational -> UnitInterval -> Double
leaderProbability ActiveSlotCoeff
f Rational
bobPoolStake (forall r.
(HasCallStack, Typeable r, BoundedRational r) =>
Rational -> r
unsafeBoundRational Rational
0.5)
    f :: ActiveSlotCoeff
f = Globals -> ActiveSlotCoeff
activeSlotCoeff Globals
testGlobals

nonMyopicEx9 :: NonMyopic
nonMyopicEx9 :: NonMyopic
nonMyopicEx9 =
  Map (KeyHash 'StakePool) Likelihood -> Coin -> NonMyopic
NonMyopic
    ( forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
        [ (forall c (r :: KeyRole). AllIssuerKeys c r -> KeyHash r
aikColdKeyHash AllIssuerKeys MockCrypto 'StakePool
Cast.alicePoolKeys, Likelihood
alicePerfEx9)
        , (forall c (r :: KeyRole). AllIssuerKeys c r -> KeyHash r
aikColdKeyHash AllIssuerKeys MockCrypto 'StakePool
Cast.bobPoolKeys, Likelihood
bobPerfEx9)
        ]
    )
    Coin
bigR

rewardUpdateEx9 ::
  PParams C ->
  Map (Credential 'Staking) (Set Reward) ->
  RewardUpdate
rewardUpdateEx9 :: PParams C -> Map (Credential 'Staking) (Set Reward) -> RewardUpdate
rewardUpdateEx9 PParams C
pp Map (Credential 'Staking) (Set Reward)
rewards =
  RewardUpdate
    { deltaT :: DeltaCoin
deltaT = Integer -> DeltaCoin
DeltaCoin Integer
deltaTEx9
    , deltaR :: DeltaCoin
deltaR = forall m. Group m => m -> m
invert (Coin -> DeltaCoin
toDeltaCoin Coin
deltaR1Ex9) forall a. Semigroup a => a -> a -> a
<> Coin -> DeltaCoin
toDeltaCoin Coin
deltaR2Ex9
    , rs :: Map (Credential 'Staking) (Set Reward)
rs = Map (Credential 'Staking) (Set Reward)
rewards
    , deltaF :: DeltaCoin
deltaF = Integer -> DeltaCoin
DeltaCoin Integer
0
    , nonMyopic :: NonMyopic
nonMyopic = NonMyopic
nonMyopicEx9
    }
  where
    pv :: ProtVer
pv = PParams C
pp forall s a. s -> Getting a s a -> a
^. forall era. EraPParams era => Lens' (PParams era) ProtVer
ppProtocolVersionL
    deltaR2Ex9 :: Coin
deltaR2Ex9 = Coin
bigR forall t. Val t => t -> t -> t
<-> ProtVer -> Map (Credential 'Staking) (Set Reward) -> Coin
sumRewards ProtVer
pv Map (Credential 'Staking) (Set Reward)
rewards

pulserEx9 :: PParams C -> PulsingRewUpdate
pulserEx9 :: PParams C -> PulsingRewUpdate
pulserEx9 PParams C
pp =
  forall era.
EraGov era =>
BlocksMade -> ChainState era -> PulsingRewUpdate
makeCompletedPulser
    ( Map (KeyHash 'StakePool) Natural -> BlocksMade
BlocksMade forall a b. (a -> b) -> a -> b
$
        forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
          [(forall c (r :: KeyRole). AllIssuerKeys c r -> KeyHash r
aikColdKeyHash AllIssuerKeys MockCrypto 'StakePool
Cast.alicePoolKeys, Natural
2), (forall c (r :: KeyRole). AllIssuerKeys c r -> KeyHash r
aikColdKeyHash AllIssuerKeys MockCrypto 'StakePool
Cast.bobPoolKeys, Natural
1)]
    )
    ChainState C
expectedStEx8'
  where
    expectedStEx8' :: ChainState C
expectedStEx8' = forall era.
EraGov era =>
PParams era -> ChainState era -> ChainState era
C.setPrevPParams PParams C
pp ChainState C
expectedStEx8

expectedStEx9 :: PParams C -> ChainState C
expectedStEx9 :: PParams C -> ChainState C
expectedStEx9 PParams C
pp =
  forall era. Nonce -> ChainState era -> ChainState era
C.evolveNonceFrozen (forall era. Block (BHeader MockCrypto) era -> Nonce
getBlockNonce Block (BHeader MockCrypto) C
blockEx9)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
Block (BHeader MockCrypto) era -> ChainState era -> ChainState era
C.newLab Block (BHeader MockCrypto) C
blockEx9
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
KeyHash 'BlockIssuer -> Word64 -> ChainState era -> ChainState era
C.setOCertCounter forall {r' :: KeyRole}. KeyHash r'
coreNodeHK Word64
2
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. PulsingRewUpdate -> ChainState era -> ChainState era
C.pulserUpdate (PParams C -> PulsingRewUpdate
pulserEx9 PParams C
pp)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraGov era => ChainState era -> ChainState era
C.solidifyProposals
    forall a b. (a -> b) -> a -> b
$ ChainState C
expectedStEx8
  where
    coreNodeHK :: KeyHash r'
coreNodeHK = forall (a :: KeyRole -> *) (r :: KeyRole) (r' :: KeyRole).
HasKeyRole a =>
a r -> a r'
coerceKeyRole forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c (r :: KeyRole). AllIssuerKeys c r -> KeyHash r
aikColdKeyHash forall a b. (a -> b) -> a -> b
$ forall era.
(HasCallStack, EraPParams era) =>
PParams era -> Word64 -> AllIssuerKeys MockCrypto 'GenesisDelegate
coreNodeKeysBySchedule @C forall era.
(EraPParams era, ProtVerAtMost era 4, ProtVerAtMost era 6) =>
PParams era
ppEx Word64
390

-- === Block 9, Slot 390, Epoch 3
--
-- 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.
twoPools9 :: CHAINExample C
twoPools9 :: CHAINExample C
twoPools9 = forall era.
ChainState era
-> Block (BHeader MockCrypto) era
-> Either
     (NonEmpty (PredicateFailure (CHAIN era))) (ChainState era)
-> CHAINExample era
CHAINExample ChainState C
expectedStEx8 Block (BHeader MockCrypto) C
blockEx9 (forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ PParams C -> ChainState C
expectedStEx9 forall era.
(EraPParams era, ProtVerAtMost era 4, ProtVerAtMost era 6) =>
PParams era
ppEx)

--
-- Now test with Aggregation
--
carlsRewards :: Set Reward
carlsRewards :: Set Reward
carlsRewards =
  forall a. Ord a => [a] -> Set a
Set.fromList
    [ RewardType -> KeyHash 'StakePool -> Coin -> Reward
Reward RewardType
MemberReward (forall c (r :: KeyRole). AllIssuerKeys c r -> KeyHash r
aikColdKeyHash AllIssuerKeys MockCrypto 'StakePool
Cast.alicePoolKeys) Coin
carlMemberRewardsFromAlice
    , RewardType -> KeyHash 'StakePool -> Coin -> Reward
Reward RewardType
LeaderReward (forall c (r :: KeyRole). AllIssuerKeys c r -> KeyHash r
aikColdKeyHash AllIssuerKeys MockCrypto 'StakePool
Cast.alicePoolKeys) Coin
carlLeaderRewardsFromAlice
    , RewardType -> KeyHash 'StakePool -> Coin -> Reward
Reward RewardType
LeaderReward (forall c (r :: KeyRole). AllIssuerKeys c r -> KeyHash r
aikColdKeyHash AllIssuerKeys MockCrypto 'StakePool
Cast.bobPoolKeys) Coin
carlLeaderRewardsFromBob
    ]

rsEx9Agg :: Map (Credential 'Staking) (Set Reward)
rsEx9Agg :: Map (Credential 'Staking) (Set Reward)
rsEx9Agg = forall k a. k -> a -> Map k a
Map.singleton Credential 'Staking
Cast.carlSHK Set Reward
carlsRewards

ppProtVer3 :: PParams C
ppProtVer3 :: PParams C
ppProtVer3 = forall era.
(EraPParams era, ProtVerAtMost era 4, ProtVerAtMost era 6) =>
PParams era
ppEx forall a b. a -> (a -> b) -> b
& forall era. EraPParams era => Lens' (PParams era) ProtVer
ppProtocolVersionL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Version -> Natural -> ProtVer
ProtVer (forall (v :: Natural).
(KnownNat v, MinVersion <= v, v <= MaxVersion) =>
Version
natVersion @3) Natural
0

expectedStEx8Agg :: ChainState C
expectedStEx8Agg :: ChainState C
expectedStEx8Agg = forall era.
EraGov era =>
PParams era -> ChainState era -> ChainState era
C.setPrevPParams PParams C
ppProtVer3 ChainState C
expectedStEx8

expectedStEx9Agg :: ChainState C
expectedStEx9Agg :: ChainState C
expectedStEx9Agg = forall era. EraGov era => ChainState era -> ChainState era
C.solidifyProposals forall a b. (a -> b) -> a -> b
$ forall era.
EraGov era =>
PParams era -> ChainState era -> ChainState era
C.setPrevPParams PParams C
ppProtVer3 (PParams C -> ChainState C
expectedStEx9 PParams C
ppProtVer3)

-- 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 :: CHAINExample C
twoPools9Agg :: CHAINExample C
twoPools9Agg = forall era.
ChainState era
-> Block (BHeader MockCrypto) era
-> Either
     (NonEmpty (PredicateFailure (CHAIN era))) (ChainState era)
-> CHAINExample era
CHAINExample ChainState C
expectedStEx8Agg Block (BHeader MockCrypto) C
blockEx9 (forall a b. b -> Either a b
Right ChainState C
expectedStEx9Agg)

testAggregateRewardsLegacy :: HasCallStack => Assertion
testAggregateRewardsLegacy :: HasCallStack => Assertion
testAggregateRewardsLegacy = do
  let expectedReward :: Coin
expectedReward = Coin
carlLeaderRewardsFromBob
  Coin
expectedReward forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= Reward -> Coin
rewardAmount (forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum Set Reward
carlsRewards)
  ProtVer
-> Map (Credential 'Staking) (Set Reward)
-> Map (Credential 'Staking) Coin
aggregateRewards (forall era.
(EraPParams era, ProtVerAtMost era 4, ProtVerAtMost era 6) =>
PParams era
ppEx forall s a. s -> Getting a s a -> a
^. forall era. EraPParams era => Lens' (PParams era) ProtVer
ppProtocolVersionL @C) Map (Credential 'Staking) (Set Reward)
rsEx9Agg
    forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= forall k a. k -> a -> Map k a
Map.singleton Credential 'Staking
Cast.carlSHK Coin
expectedReward

testAggregateRewardsNew :: Assertion
testAggregateRewardsNew :: Assertion
testAggregateRewardsNew =
  ProtVer
-> Map (Credential 'Staking) (Set Reward)
-> Map (Credential 'Staking) Coin
aggregateRewards (PParams C
ppProtVer3 forall s a. s -> Getting a s a -> a
^. forall era. EraPParams era => Lens' (PParams era) ProtVer
ppProtocolVersionL @C) Map (Credential 'Staking) (Set Reward)
rsEx9Agg
    forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= forall k a. k -> a -> Map k a
Map.singleton Credential 'Staking
Cast.carlSHK (forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Reward -> Coin
rewardAmount Set Reward
carlsRewards)

--
-- Two Pools Test Group
--

twoPoolsExample :: TestTree
twoPoolsExample :: TestTree
twoPoolsExample =
  TestName -> [TestTree] -> TestTree
testGroup
    TestName
"two pools"
    [ TestName -> Assertion -> TestTree
testCase TestName
"create non-aggregated pulser" forall a b. (a -> b) -> a -> b
$ HasCallStack => CHAINExample C -> Assertion
testCHAINExample CHAINExample C
twoPools9
    , TestName -> Assertion -> TestTree
testCase TestName
"non-aggregated pulser is correct" forall a b. (a -> b) -> a -> b
$
        RewardUpdate -> PulsingRewUpdate
Complete (PParams C -> Map (Credential 'Staking) (Set Reward) -> RewardUpdate
rewardUpdateEx9 forall era.
(EraPParams era, ProtVerAtMost era 4, ProtVerAtMost era 6) =>
PParams era
ppEx Map (Credential 'Staking) (Set Reward)
rsEx9Agg)
          forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= (forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ShelleyBase a -> a
runShelleyBase forall b c a. (b -> c) -> (a -> b) -> a -> c
. PulsingRewUpdate
-> ShelleyBase
     (PulsingRewUpdate, Map (Credential 'Staking) (Set Reward))
completeStep forall a b. (a -> b) -> a -> b
$ PParams C -> PulsingRewUpdate
pulserEx9 forall era.
(EraPParams era, ProtVerAtMost era 4, ProtVerAtMost era 6) =>
PParams era
ppEx)
    , TestName -> Assertion -> TestTree
testCase TestName
"aggregated pulser is correct" forall a b. (a -> b) -> a -> b
$
        RewardUpdate -> PulsingRewUpdate
Complete (PParams C -> Map (Credential 'Staking) (Set Reward) -> RewardUpdate
rewardUpdateEx9 PParams C
ppProtVer3 Map (Credential 'Staking) (Set Reward)
rsEx9Agg)
          forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= (forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ShelleyBase a -> a
runShelleyBase forall b c a. (b -> c) -> (a -> b) -> a -> c
. PulsingRewUpdate
-> ShelleyBase
     (PulsingRewUpdate, Map (Credential 'Staking) (Set Reward))
completeStep forall a b. (a -> b) -> a -> b
$ PParams C -> PulsingRewUpdate
pulserEx9 PParams C
ppProtVer3)
    , TestName -> Assertion -> TestTree
testCase TestName
"create aggregated pulser" forall a b. (a -> b) -> a -> b
$ HasCallStack => CHAINExample C -> Assertion
testCHAINExample CHAINExample C
twoPools9Agg
    , TestName -> Assertion -> TestTree
testCase TestName
"create legacy aggregatedRewards" HasCallStack => Assertion
testAggregateRewardsLegacy
    , TestName -> Assertion -> TestTree
testCase TestName
"create new aggregatedRewards" Assertion
testAggregateRewardsNew
    ]

-- This test group tests each block individually, which is really only
-- helpful for debugging purposes.
twoPoolsExampleExtended :: TestTree
twoPoolsExampleExtended :: TestTree
twoPoolsExampleExtended =
  TestName -> [TestTree] -> TestTree
testGroup
    TestName
"two pools extended"
    [ TestName -> Assertion -> TestTree
testCase TestName
"initial registrations" forall a b. (a -> b) -> a -> b
$ HasCallStack => CHAINExample C -> Assertion
testCHAINExample CHAINExample C
twoPools1
    , TestName -> Assertion -> TestTree
testCase TestName
"delegate stake and create reward update" forall a b. (a -> b) -> a -> b
$ HasCallStack => CHAINExample C -> Assertion
testCHAINExample CHAINExample C
twoPools2
    , TestName -> Assertion -> TestTree
testCase TestName
"new epoch changes" forall a b. (a -> b) -> a -> b
$ HasCallStack => CHAINExample C -> Assertion
testCHAINExample CHAINExample C
twoPools3
    , TestName -> Assertion -> TestTree
testCase TestName
"second reward update" forall a b. (a -> b) -> a -> b
$ HasCallStack => CHAINExample C -> Assertion
testCHAINExample CHAINExample C
twoPools4
    , TestName -> Assertion -> TestTree
testCase TestName
"nonempty pool distr" forall a b. (a -> b) -> a -> b
$ HasCallStack => CHAINExample C -> Assertion
testCHAINExample CHAINExample C
twoPools5
    , TestName -> Assertion -> TestTree
testCase TestName
"alice produces a block" forall a b. (a -> b) -> a -> b
$ HasCallStack => CHAINExample C -> Assertion
testCHAINExample CHAINExample C
twoPools6
    , TestName -> Assertion -> TestTree
testCase TestName
"bob produces a block" forall a b. (a -> b) -> a -> b
$ HasCallStack => CHAINExample C -> Assertion
testCHAINExample CHAINExample C
twoPools7
    , TestName -> Assertion -> TestTree
testCase TestName
"prelude to the first nontrivial rewards" forall a b. (a -> b) -> a -> b
$ HasCallStack => CHAINExample C -> Assertion
testCHAINExample CHAINExample C
twoPools8
    , TestName -> Assertion -> TestTree
testCase TestName
"create non-aggregated rewards" forall a b. (a -> b) -> a -> b
$ HasCallStack => CHAINExample C -> Assertion
testCHAINExample CHAINExample C
twoPools9
    , TestName -> Assertion -> TestTree
testCase TestName
"create aggregated rewards" forall a b. (a -> b) -> a -> b
$ HasCallStack => CHAINExample C -> Assertion
testCHAINExample CHAINExample C
twoPools9Agg
    ]