{-# 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 (..),
  rationalToCoinViaFloor,
  toDeltaCoin,
 )
import Cardano.Ledger.Credential (Credential, Ptr (..))
import Cardano.Ledger.Crypto
import qualified Cardano.Ledger.EpochBoundary as EB
import Cardano.Ledger.Keys (KeyRole (..), asWitness, coerceKeyRole)
import Cardano.Ledger.PoolDistr (
  IndividualPoolStake (..),
  PoolDistr (..),
 )
import Cardano.Ledger.PoolParams (PoolParams (..))
import Cardano.Ledger.SafeHash (hashAnnotated)
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, C_Crypto, ExMock)
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 (EraCrypto era) -> [TxOut era] -> UTxO era
genesisCoins
    forall c. HashAlgorithm (HASH c) => TxId c
genesisId
    [ forall era.
(HasCallStack, Era era, Val (Value era)) =>
Addr (EraCrypto era) -> Value era -> ShelleyTxOut era
ShelleyTxOut forall c. Crypto c => Addr c
Cast.aliceAddr (forall t s. Inject t s => t -> s
Val.inject Coin
aliceInitCoin)
    , forall era.
(HasCallStack, Era era, Val (Value era)) =>
Addr (EraCrypto era) -> Value era -> ShelleyTxOut era
ShelleyTxOut forall c. Crypto c => Addr c
Cast.bobAddr (forall t s. Inject t s => t -> s
Val.inject Coin
bobInitCoin)
    , forall era.
(HasCallStack, Era era, Val (Value era)) =>
Addr (EraCrypto era) -> Value era -> ShelleyTxOut era
ShelleyTxOut forall c. Crypto c => Addr c
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' :: Crypto c => PoolParams c
alicePoolParams' :: forall c. Crypto c => PoolParams c
alicePoolParams' = forall c. Crypto c => PoolParams c
Cast.alicePoolParams {ppRewardAccount :: RewardAccount c
ppRewardAccount = forall c. Network -> Credential 'Staking c -> RewardAccount c
RewardAccount Network
Testnet forall c. Crypto c => Credential 'Staking c
Cast.carlSHK}

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

txbodyEx1 :: TxBody C
txbodyEx1 :: TxBody C
txbodyEx1 =
  forall era.
(EraTxOut era, EncCBOR (TxCert era)) =>
Set (TxIn (EraCrypto era))
-> StrictSeq (TxOut era)
-> StrictSeq (TxCert era)
-> Withdrawals (EraCrypto era)
-> Coin
-> SlotNo
-> StrictMaybe (Update era)
-> StrictMaybe (AuxiliaryDataHash (EraCrypto era))
-> ShelleyTxBody era
ShelleyTxBody
    (forall a. Ord a => [a] -> Set a
Set.fromList [forall c. TxId c -> TxIx -> TxIn c
TxIn forall c. HashAlgorithm (HASH c) => TxId c
genesisId forall a. Bounded a => a
minBound])
    (forall a. [a] -> StrictSeq a
StrictSeq.fromList [forall era.
(HasCallStack, Era era, Val (Value era)) =>
Addr (EraCrypto era) -> Value era -> ShelleyTxOut era
ShelleyTxOut forall c. Crypto c => Addr c
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 =>
StakeCredential (EraCrypto era) -> TxCert era
RegTxCert forall c. Crypto c => Credential 'Staking c
Cast.aliceSHK
        , forall era.
ShelleyEraTxCert era =>
StakeCredential (EraCrypto era) -> TxCert era
RegTxCert forall c. Crypto c => Credential 'Staking c
Cast.bobSHK
        , forall era.
ShelleyEraTxCert era =>
StakeCredential (EraCrypto era) -> TxCert era
RegTxCert forall c. Crypto c => Credential 'Staking c
Cast.carlSHK
        , forall era.
EraTxCert era =>
PoolParams (EraCrypto era) -> TxCert era
RegPoolTxCert forall c. Crypto c => PoolParams c
alicePoolParams'
        , forall era.
EraTxCert era =>
PoolParams (EraCrypto era) -> TxCert era
RegPoolTxCert forall c. Crypto c => PoolParams c
bobPoolParams'
        , forall era.
ShelleyEraTxCert era =>
StakeCredential (EraCrypto era)
-> KeyHash 'StakePool (EraCrypto era) -> TxCert era
DelegStakeTxCert forall c. Crypto c => Credential 'Staking c
Cast.aliceSHK (forall v (r :: KeyRole). AllIssuerKeys v r -> KeyHash r v
aikColdKeyHash forall c. Crypto c => AllIssuerKeys c 'StakePool
Cast.alicePoolKeys)
        , forall era.
ShelleyEraTxCert era =>
StakeCredential (EraCrypto era)
-> KeyHash 'StakePool (EraCrypto era) -> TxCert era
DelegStakeTxCert forall c. Crypto c => Credential 'Staking c
Cast.bobSHK (forall v (r :: KeyRole). AllIssuerKeys v r -> KeyHash r v
aikColdKeyHash forall c. Crypto c => AllIssuerKeys c 'StakePool
Cast.bobPoolKeys)
        , forall era.
ShelleyEraTxCert era =>
StakeCredential (EraCrypto era)
-> KeyHash 'StakePool (EraCrypto era) -> TxCert era
DelegStakeTxCert forall c. Crypto c => Credential 'Staking c
Cast.carlSHK (forall v (r :: KeyRole). AllIssuerKeys v r -> KeyHash r v
aikColdKeyHash forall c. Crypto c => AllIssuerKeys c 'StakePool
Cast.alicePoolKeys)
        ]
    )
    (forall c. Map (RewardAccount c) Coin -> Withdrawals c
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 (EraCrypto C))
addrWits =
          forall c (kr :: KeyRole).
(Crypto c, DSignable c (Hash (HASH c) EraIndependentTxBody)) =>
SafeHash c EraIndependentTxBody
-> [KeyPair kr c] -> Set (WitVKey 'Witness c)
mkWitnessesVKey
            (forall x index c.
(HashAnnotated x index c, HashAlgorithm (HASH c)) =>
x -> SafeHash c index
hashAnnotated TxBody C
txbodyEx1)
            ( (forall (a :: KeyRole -> * -> *) (r :: KeyRole) c.
HasKeyRole a =>
a r c -> a 'Witness c
asWitness forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [forall c. Crypto c => KeyPair 'Payment c
Cast.alicePay])
                forall a. Semigroup a => a -> a -> a
<> (forall (a :: KeyRole -> * -> *) (r :: KeyRole) c.
HasKeyRole a =>
a r c -> a 'Witness c
asWitness forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [forall c. Crypto c => KeyPair 'Staking c
Cast.aliceStake, forall c. Crypto c => KeyPair 'Staking c
Cast.bobStake, forall c. Crypto c => KeyPair 'Staking c
Cast.carlStake])
                forall a. Semigroup a => a -> a -> a
<> (forall (a :: KeyRole -> * -> *) (r :: KeyRole) c.
HasKeyRole a =>
a r c -> a 'Witness c
asWitness forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [forall v (r :: KeyRole). AllIssuerKeys v r -> KeyPair r v
aikCold forall c. Crypto c => AllIssuerKeys c 'StakePool
Cast.alicePoolKeys, forall v (r :: KeyRole). AllIssuerKeys v r -> KeyPair r v
aikCold forall c. Crypto c => AllIssuerKeys c 'StakePool
Cast.bobPoolKeys])
            )
      }
    forall a. StrictMaybe a
SNothing

blockEx1 :: HasCallStack => Block (BHeader C_Crypto) C
blockEx1 :: HasCallStack => Block (BHeader C_Crypto) C
blockEx1 =
  forall era (r :: KeyRole).
(EraSegWits era, Signable (VRF (EraCrypto era)) (WithResult Seed),
 Signable (KES (EraCrypto era)) (BHBody (EraCrypto era))) =>
HashHeader (EraCrypto era)
-> AllIssuerKeys (EraCrypto era) r
-> [Tx era]
-> SlotNo
-> BlockNo
-> Nonce
-> NatNonce
-> UnitInterval
-> Word
-> Word
-> OCert (EraCrypto era)
-> Block (BHeader (EraCrypto era)) era
mkBlockFakeVRF
    forall c. Crypto c => HashHeader c
lastByronHeaderHash
    (forall era.
(HasCallStack, EraPParams era) =>
PParams era
-> Word64 -> AllIssuerKeys (EraCrypto era) '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)
    (forall c. Crypto c => Nonce
nonce0 @C_Crypto)
    (Natural -> NatNonce
NatNonce Natural
1)
    forall a. Bounded a => a
minBound
    Word
0
    Word
0
    (forall c (r :: KeyRole).
(Crypto c, Signable (DSIGN c) (OCertSignable c)) =>
AllIssuerKeys c r -> Word64 -> KESPeriod -> OCert c
mkOCert (forall era.
(HasCallStack, EraPParams era) =>
PParams era
-> Word64 -> AllIssuerKeys (EraCrypto era) '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. Era era => Block (BHeader (EraCrypto era)) era -> Nonce
getBlockNonce HasCallStack => Block (BHeader C_Crypto) C
blockEx1)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
Era era =>
Block (BHeader (EraCrypto era)) era
-> ChainState era -> ChainState era
C.newLab HasCallStack => Block (BHeader C_Crypto) C
blockEx1
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraPParams era =>
PParams era
-> Coin
-> [Credential 'Staking (EraCrypto era)]
-> [PoolParams (EraCrypto era)]
-> ChainState era
-> ChainState era
C.feesAndDeposits
      forall era.
(EraPParams era, ProtVerAtMost era 4, ProtVerAtMost era 6) =>
PParams era
ppEx
      Coin
feeTx1
      [forall c. Crypto c => Credential 'Staking c
Cast.aliceSHK, forall c. Crypto c => Credential 'Staking c
Cast.bobSHK, forall c. Crypto c => Credential 'Staking c
Cast.carlSHK]
      [forall c. Crypto c => PoolParams c
alicePoolParams', forall c. Crypto c => PoolParams c
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 (EraCrypto era)
-> Ptr -> ChainState era -> ChainState era
C.newStakeCred forall c. Crypto c => Credential 'Staking c
Cast.aliceSHK (SlotNo -> TxIx -> CertIx -> Ptr
Ptr (Word64 -> SlotNo
SlotNo Word64
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 (EraCrypto era)
-> Ptr -> ChainState era -> ChainState era
C.newStakeCred forall c. Crypto c => Credential 'Staking c
Cast.bobSHK (SlotNo -> TxIx -> CertIx -> Ptr
Ptr (Word64 -> SlotNo
SlotNo Word64
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 (EraCrypto era)
-> Ptr -> ChainState era -> ChainState era
C.newStakeCred forall c. Crypto c => Credential 'Staking c
Cast.carlSHK (SlotNo -> TxIx -> CertIx -> Ptr
Ptr (Word64 -> SlotNo
SlotNo Word64
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 (EraCrypto era) -> ChainState era -> ChainState era
C.newPool forall c. Crypto c => PoolParams c
alicePoolParams'
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
PoolParams (EraCrypto era) -> ChainState era -> ChainState era
C.newPool forall c. Crypto c => PoolParams c
bobPoolParams'
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
Credential 'Staking (EraCrypto era)
-> KeyHash 'StakePool (EraCrypto era)
-> ChainState era
-> ChainState era
C.delegation forall c. Crypto c => Credential 'Staking c
Cast.aliceSHK (forall c. PoolParams c -> KeyHash 'StakePool c
ppId forall c. Crypto c => PoolParams c
alicePoolParams')
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
Credential 'Staking (EraCrypto era)
-> KeyHash 'StakePool (EraCrypto era)
-> ChainState era
-> ChainState era
C.delegation forall c. Crypto c => Credential 'Staking c
Cast.bobSHK (forall c. PoolParams c -> KeyHash 'StakePool c
ppId forall c. Crypto c => PoolParams c
bobPoolParams')
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
Credential 'Staking (EraCrypto era)
-> KeyHash 'StakePool (EraCrypto era)
-> ChainState era
-> ChainState era
C.delegation forall c. Crypto c => Credential 'Staking c
Cast.carlSHK (forall c. PoolParams c -> KeyHash 'StakePool c
ppId forall c. Crypto c => PoolParams c
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 (BHeader C_Crypto) C
twoPools1 :: CHAINExample (BHeader C_Crypto) C
twoPools1 = forall h era.
ChainState era
-> Block h era
-> Either
     (NonEmpty (PredicateFailure (CHAIN era))) (ChainState era)
-> CHAINExample h era
CHAINExample ChainState C
initStTwoPools HasCallStack => Block (BHeader C_Crypto) C
blockEx1 (forall a b. b -> Either a b
Right ChainState C
expectedStEx1)

--
-- Block 2, Slot 90, Epoch 0
--
blockEx2 :: Block (BHeader C_Crypto) C
blockEx2 :: Block (BHeader C_Crypto) C
blockEx2 =
  forall era (r :: KeyRole).
(EraSegWits era, Signable (VRF (EraCrypto era)) (WithResult Seed),
 Signable (KES (EraCrypto era)) (BHBody (EraCrypto era))) =>
HashHeader (EraCrypto era)
-> AllIssuerKeys (EraCrypto era) r
-> [Tx era]
-> SlotNo
-> BlockNo
-> Nonce
-> NatNonce
-> UnitInterval
-> Word
-> Word
-> OCert (EraCrypto era)
-> Block (BHeader (EraCrypto era)) era
mkBlockFakeVRF
    (forall c. Crypto c => BHeader c -> HashHeader c
bhHash forall a b. (a -> b) -> a -> b
$ forall h era. Block h era -> h
bheader HasCallStack => Block (BHeader C_Crypto) C
blockEx1)
    (forall era.
(HasCallStack, EraPParams era) =>
PParams era
-> Word64 -> AllIssuerKeys (EraCrypto era) '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)
    (forall c. Crypto c => Nonce
nonce0 @C_Crypto)
    (Natural -> NatNonce
NatNonce Natural
2)
    forall a. Bounded a => a
minBound
    Word
4
    Word
0
    (forall c (r :: KeyRole).
(Crypto c, Signable (DSIGN c) (OCertSignable c)) =>
AllIssuerKeys c r -> Word64 -> KESPeriod -> OCert c
mkOCert (forall era.
(HasCallStack, EraPParams era) =>
PParams era
-> Word64 -> AllIssuerKeys (EraCrypto era) '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. Era era => Block (BHeader (EraCrypto era)) era -> Nonce
getBlockNonce Block (BHeader C_Crypto) C
blockEx2)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
Era era =>
Block (BHeader (EraCrypto era)) era
-> ChainState era -> ChainState era
C.newLab Block (BHeader C_Crypto) C
blockEx2
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
RewardUpdate (EraCrypto era) -> ChainState era -> ChainState era
C.rewardUpdate forall c. RewardUpdate c
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 (BHeader C_Crypto) C
twoPools2 :: CHAINExample (BHeader C_Crypto) C
twoPools2 = forall h era.
ChainState era
-> Block h era
-> Either
     (NonEmpty (PredicateFailure (CHAIN era))) (ChainState era)
-> CHAINExample h era
CHAINExample ChainState C
expectedStEx1 Block (BHeader C_Crypto) 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 C_Crypto) C
blockEx3 :: Block (BHeader C_Crypto) C
blockEx3 =
  forall era (r :: KeyRole).
(EraSegWits era, Signable (VRF (EraCrypto era)) (WithResult Seed),
 Signable (KES (EraCrypto era)) (BHBody (EraCrypto era))) =>
HashHeader (EraCrypto era)
-> AllIssuerKeys (EraCrypto era) r
-> [Tx era]
-> SlotNo
-> BlockNo
-> Nonce
-> NatNonce
-> UnitInterval
-> Word
-> Word
-> OCert (EraCrypto era)
-> Block (BHeader (EraCrypto era)) era
mkBlockFakeVRF
    (forall c. Crypto c => BHeader c -> HashHeader c
bhHash forall a b. (a -> b) -> a -> b
$ forall h era. Block h era -> h
bheader @(BHeader C_Crypto) Block (BHeader C_Crypto) C
blockEx2)
    (forall era.
(HasCallStack, EraPParams era) =>
PParams era
-> Word64 -> AllIssuerKeys (EraCrypto era) '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, Signable (DSIGN c) (OCertSignable c)) =>
AllIssuerKeys c r -> Word64 -> KESPeriod -> OCert c
mkOCert (forall era.
(HasCallStack, EraPParams era) =>
PParams era
-> Word64 -> AllIssuerKeys (EraCrypto era) '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 :: ExMock c => EB.SnapShot c
snapEx3 :: forall c. ExMock c => SnapShot c
snapEx3 =
  EB.SnapShot
    { $sel:ssStake:SnapShot :: Stake c
EB.ssStake =
        forall c. [(Credential 'Staking c, Coin)] -> Stake c
mkStake
          [ (forall c. Crypto c => Credential 'Staking c
Cast.aliceSHK, Coin
aliceCoinEx1)
          , (forall c. Crypto c => Credential 'Staking c
Cast.bobSHK, Coin
bobInitCoin)
          , (forall c. Crypto c => Credential 'Staking c
Cast.carlSHK, Coin
carlInitCoin)
          ]
    , $sel:ssDelegations:SnapShot :: VMap VB VB (Credential 'Staking c) (KeyHash 'StakePool c)
EB.ssDelegations =
        [ (forall c. Crypto c => Credential 'Staking c
Cast.aliceSHK, forall v (r :: KeyRole). AllIssuerKeys v r -> KeyHash r v
aikColdKeyHash forall c. Crypto c => AllIssuerKeys c 'StakePool
Cast.alicePoolKeys)
        , (forall c. Crypto c => Credential 'Staking c
Cast.bobSHK, forall v (r :: KeyRole). AllIssuerKeys v r -> KeyHash r v
aikColdKeyHash forall c. Crypto c => AllIssuerKeys c 'StakePool
Cast.bobPoolKeys)
        , (forall c. Crypto c => Credential 'Staking c
Cast.carlSHK, forall v (r :: KeyRole). AllIssuerKeys v r -> KeyHash r v
aikColdKeyHash forall c. Crypto c => AllIssuerKeys c 'StakePool
Cast.alicePoolKeys)
        ]
    , $sel:ssPoolParams:SnapShot :: VMap VB VB (KeyHash 'StakePool c) (PoolParams c)
EB.ssPoolParams =
        [ (forall v (r :: KeyRole). AllIssuerKeys v r -> KeyHash r v
aikColdKeyHash forall c. Crypto c => AllIssuerKeys c 'StakePool
Cast.alicePoolKeys, forall c. Crypto c => PoolParams c
alicePoolParams')
        , (forall v (r :: KeyRole). AllIssuerKeys v r -> KeyHash r v
aikColdKeyHash forall c. Crypto c => AllIssuerKeys c 'StakePool
Cast.bobPoolKeys, forall c. Crypto c => PoolParams c
bobPoolParams')
        ]
    }

expectedStEx3 :: ChainState C
expectedStEx3 :: ChainState C
expectedStEx3 =
  forall era.
(ProtVerAtMost era 6, EraGov era) =>
Block (BHeader (EraCrypto era)) era
-> ChainState era -> ChainState era
C.newEpoch Block (BHeader C_Crypto) C
blockEx3
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
SnapShot (EraCrypto era)
-> Coin -> ChainState era -> ChainState era
C.newSnapshot forall c. ExMock c => SnapShot c
snapEx3 Coin
feeTx1
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraGov era =>
RewardUpdate (EraCrypto era) -> ChainState era -> ChainState era
C.applyRewardUpdate forall c. RewardUpdate c
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 (BHeader C_Crypto) C
twoPools3 :: CHAINExample (BHeader C_Crypto) C
twoPools3 = forall h era.
ChainState era
-> Block h era
-> Either
     (NonEmpty (PredicateFailure (CHAIN era))) (ChainState era)
-> CHAINExample h era
CHAINExample ChainState C
expectedStEx2 Block (BHeader C_Crypto) C
blockEx3 (forall a b. b -> Either a b
Right ChainState C
expectedStEx3)

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

blockEx4 :: Block (BHeader C_Crypto) C
blockEx4 :: Block (BHeader C_Crypto) C
blockEx4 =
  forall era (r :: KeyRole).
(EraSegWits era, Signable (VRF (EraCrypto era)) (WithResult Seed),
 Signable (KES (EraCrypto era)) (BHBody (EraCrypto era))) =>
HashHeader (EraCrypto era)
-> AllIssuerKeys (EraCrypto era) r
-> [Tx era]
-> SlotNo
-> BlockNo
-> Nonce
-> NatNonce
-> UnitInterval
-> Word
-> Word
-> OCert (EraCrypto era)
-> Block (BHeader (EraCrypto era)) era
mkBlockFakeVRF
    (forall c. Crypto c => BHeader c -> HashHeader c
bhHash forall a b. (a -> b) -> a -> b
$ forall h era. Block h era -> h
bheader @(BHeader C_Crypto) Block (BHeader C_Crypto) C
blockEx3)
    (forall era.
(HasCallStack, EraPParams era) =>
PParams era
-> Word64 -> AllIssuerKeys (EraCrypto era) '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, Signable (DSIGN c) (OCertSignable c)) =>
AllIssuerKeys c r -> Word64 -> KESPeriod -> OCert c
mkOCert (forall era.
(HasCallStack, EraPParams era) =>
PParams era
-> Word64 -> AllIssuerKeys (EraCrypto era) '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 :: forall c. RewardUpdate c
rewardUpdateEx4 :: forall c. RewardUpdate c
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 c) (Set (Reward c))
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 c
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. Era era => Block (BHeader (EraCrypto era)) era -> Nonce
getBlockNonce Block (BHeader C_Crypto) C
blockEx4)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
Era era =>
Block (BHeader (EraCrypto era)) era
-> ChainState era -> ChainState era
C.newLab Block (BHeader C_Crypto) C
blockEx4
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
RewardUpdate (EraCrypto era) -> ChainState era -> ChainState era
C.rewardUpdate forall c. RewardUpdate c
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 (BHeader C_Crypto) C
twoPools4 :: CHAINExample (BHeader C_Crypto) C
twoPools4 = forall h era.
ChainState era
-> Block h era
-> Either
     (NonEmpty (PredicateFailure (CHAIN era))) (ChainState era)
-> CHAINExample h era
CHAINExample ChainState C
expectedStEx3 Block (BHeader C_Crypto) 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
⭒ forall c. HashHeader c -> Nonce
hashHeaderToNonce (forall c. Crypto c => BHeader c -> HashHeader c
bhHash forall a b. (a -> b) -> a -> b
$ forall h era. Block h era -> h
bheader Block (BHeader C_Crypto) C
blockEx2)

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

blockEx5 :: Block (BHeader C_Crypto) C
blockEx5 :: Block (BHeader C_Crypto) C
blockEx5 =
  forall era (r :: KeyRole).
(EraSegWits era, Signable (VRF (EraCrypto era)) (WithResult Seed),
 Signable (KES (EraCrypto era)) (BHBody (EraCrypto era))) =>
HashHeader (EraCrypto era)
-> AllIssuerKeys (EraCrypto era) r
-> [Tx era]
-> SlotNo
-> BlockNo
-> Nonce
-> NatNonce
-> UnitInterval
-> Word
-> Word
-> OCert (EraCrypto era)
-> Block (BHeader (EraCrypto era)) era
mkBlockFakeVRF
    (forall c. Crypto c => BHeader c -> HashHeader c
bhHash forall a b. (a -> b) -> a -> b
$ forall h era. Block h era -> h
bheader @(BHeader C_Crypto) Block (BHeader C_Crypto) C
blockEx4)
    forall c. Crypto c => AllIssuerKeys c '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, Signable (DSIGN c) (OCertSignable c)) =>
AllIssuerKeys c r -> Word64 -> KESPeriod -> OCert c
mkOCert forall c. Crypto c => AllIssuerKeys c '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 :: forall c. Crypto c => PoolDistr c
pdEx5 :: forall c. Crypto c => PoolDistr c
pdEx5 =
  forall c.
Map (KeyHash 'StakePool c) (IndividualPoolStake c)
-> CompactForm Coin -> PoolDistr c
PoolDistr
    ( forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
        [
          ( forall v (r :: KeyRole). AllIssuerKeys v r -> KeyHash r v
aikColdKeyHash forall a b. (a -> b) -> a -> b
$ forall c. Crypto c => AllIssuerKeys c 'StakePool
Cast.alicePoolKeys @c
          , forall c.
Rational
-> CompactForm Coin
-> VRFVerKeyHash 'StakePoolVRF c
-> IndividualPoolStake c
IndividualPoolStake
              Rational
alicePoolStake
              (Word64 -> CompactForm Coin
CompactCoin forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Coin -> Integer
unCoin Coin
aliceCoinEx1 forall a. Num a => a -> a -> a
+ Coin -> Integer
unCoin Coin
carlInitCoin)
              (forall c. Crypto c => VRFVerKeyHash 'StakePoolVRF c
Cast.aliceVRFKeyHash @c)
          )
        ,
          ( forall v (r :: KeyRole). AllIssuerKeys v r -> KeyHash r v
aikColdKeyHash forall a b. (a -> b) -> a -> b
$ forall c. Crypto c => AllIssuerKeys c 'StakePool
Cast.bobPoolKeys @c
          , forall c.
Rational
-> CompactForm Coin
-> VRFVerKeyHash 'StakePoolVRF c
-> IndividualPoolStake c
IndividualPoolStake
              Rational
bobPoolStake
              (Word64 -> CompactForm Coin
CompactCoin forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Coin -> Integer
unCoin Coin
bobInitCoin)
              (forall c. Crypto c => VRFVerKeyHash 'StakePoolVRF c
Cast.bobVRFKeyHash @c)
          )
        ]
    )
    (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 (EraCrypto era)
-> ChainState era -> ChainState era
C.incrBlockCount (forall v (r :: KeyRole). AllIssuerKeys v r -> KeyHash r v
aikColdKeyHash forall c. Crypto c => AllIssuerKeys c 'StakePool
Cast.alicePoolKeys)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
SnapShot (EraCrypto era)
-> Coin -> ChainState era -> ChainState era
C.newSnapshot forall c. ExMock c => SnapShot c
snapEx3 (Integer -> Coin
Coin Integer
0)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraGov era =>
RewardUpdate (EraCrypto era) -> ChainState era -> ChainState era
C.applyRewardUpdate forall c. RewardUpdate c
rewardUpdateEx4
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
PoolDistr (EraCrypto era) -> ChainState era -> ChainState era
C.setPoolDistr forall c. Crypto c => PoolDistr c
pdEx5
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
KeyHash 'BlockIssuer (EraCrypto era)
-> Word64 -> ChainState era -> ChainState era
C.setOCertCounter (forall (a :: KeyRole -> * -> *) (r :: KeyRole) c (r' :: KeyRole).
HasKeyRole a =>
a r c -> a r' c
coerceKeyRole forall a b. (a -> b) -> a -> b
$ forall v (r :: KeyRole). AllIssuerKeys v r -> KeyHash r v
aikColdKeyHash forall c. Crypto c => AllIssuerKeys c 'StakePool
Cast.alicePoolKeys) Word64
0
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
(ProtVerAtMost era 6, EraGov era) =>
Block (BHeader (EraCrypto era)) era
-> ChainState era -> ChainState era
C.newEpoch Block (BHeader C_Crypto) 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 (BHeader C_Crypto) C
twoPools5 :: CHAINExample (BHeader C_Crypto) C
twoPools5 = forall h era.
ChainState era
-> Block h era
-> Either
     (NonEmpty (PredicateFailure (CHAIN era))) (ChainState era)
-> CHAINExample h era
CHAINExample ChainState C
expectedStEx4 Block (BHeader C_Crypto) C
blockEx5 (forall a b. b -> Either a b
Right ChainState C
expectedStEx5)

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

blockEx6 :: Block (BHeader C_Crypto) C
blockEx6 :: Block (BHeader C_Crypto) C
blockEx6 =
  forall era (r :: KeyRole).
(EraSegWits era, Signable (VRF (EraCrypto era)) (WithResult Seed),
 Signable (KES (EraCrypto era)) (BHBody (EraCrypto era))) =>
HashHeader (EraCrypto era)
-> AllIssuerKeys (EraCrypto era) r
-> [Tx era]
-> SlotNo
-> BlockNo
-> Nonce
-> NatNonce
-> UnitInterval
-> Word
-> Word
-> OCert (EraCrypto era)
-> Block (BHeader (EraCrypto era)) era
mkBlockFakeVRF
    (forall c. Crypto c => BHeader c -> HashHeader c
bhHash forall a b. (a -> b) -> a -> b
$ forall h era. Block h era -> h
bheader @(BHeader C_Crypto) Block (BHeader C_Crypto) C
blockEx5)
    forall c. Crypto c => AllIssuerKeys c '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, Signable (DSIGN c) (OCertSignable c)) =>
AllIssuerKeys c r -> Word64 -> KESPeriod -> OCert c
mkOCert forall c. Crypto c => AllIssuerKeys c '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. Era era => Block (BHeader (EraCrypto era)) era -> Nonce
getBlockNonce Block (BHeader C_Crypto) C
blockEx6)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
Era era =>
Block (BHeader (EraCrypto era)) era
-> ChainState era -> ChainState era
C.newLab Block (BHeader C_Crypto) C
blockEx6
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
KeyHash 'BlockIssuer (EraCrypto era)
-> Word64 -> ChainState era -> ChainState era
C.setOCertCounter (forall (a :: KeyRole -> * -> *) (r :: KeyRole) c (r' :: KeyRole).
HasKeyRole a =>
a r c -> a r' c
coerceKeyRole forall a b. (a -> b) -> a -> b
$ forall v (r :: KeyRole). AllIssuerKeys v r -> KeyHash r v
aikColdKeyHash forall c. Crypto c => AllIssuerKeys c 'StakePool
Cast.alicePoolKeys) Word64
0
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
KeyHash 'StakePool (EraCrypto era)
-> ChainState era -> ChainState era
C.incrBlockCount (forall v (r :: KeyRole). AllIssuerKeys v r -> KeyHash r v
aikColdKeyHash forall c. Crypto c => AllIssuerKeys c 'StakePool
Cast.alicePoolKeys)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
RewardUpdate (EraCrypto era) -> ChainState era -> ChainState era
C.rewardUpdate forall c. RewardUpdate c
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 (BHeader C_Crypto) C
twoPools6 :: CHAINExample (BHeader C_Crypto) C
twoPools6 = forall h era.
ChainState era
-> Block h era
-> Either
     (NonEmpty (PredicateFailure (CHAIN era))) (ChainState era)
-> CHAINExample h era
CHAINExample ChainState C
expectedStEx5 Block (BHeader C_Crypto) C
blockEx6 (forall a b. b -> Either a b
Right ChainState C
expectedStEx6)

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

blockEx7 :: Block (BHeader C_Crypto) C
blockEx7 :: Block (BHeader C_Crypto) C
blockEx7 =
  forall era (r :: KeyRole).
(EraSegWits era, Signable (VRF (EraCrypto era)) (WithResult Seed),
 Signable (KES (EraCrypto era)) (BHBody (EraCrypto era))) =>
HashHeader (EraCrypto era)
-> AllIssuerKeys (EraCrypto era) r
-> [Tx era]
-> SlotNo
-> BlockNo
-> Nonce
-> NatNonce
-> UnitInterval
-> Word
-> Word
-> OCert (EraCrypto era)
-> Block (BHeader (EraCrypto era)) era
mkBlockFakeVRF
    (forall c. Crypto c => BHeader c -> HashHeader c
bhHash forall a b. (a -> b) -> a -> b
$ forall h era. Block h era -> h
bheader @(BHeader C_Crypto) Block (BHeader C_Crypto) C
blockEx6)
    forall c. Crypto c => AllIssuerKeys c '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, Signable (DSIGN c) (OCertSignable c)) =>
AllIssuerKeys c r -> Word64 -> KESPeriod -> OCert c
mkOCert forall c. Crypto c => AllIssuerKeys c '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. Era era => Block (BHeader (EraCrypto era)) era -> Nonce
getBlockNonce Block (BHeader C_Crypto) C
blockEx7)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
Era era =>
Block (BHeader (EraCrypto era)) era
-> ChainState era -> ChainState era
C.newLab Block (BHeader C_Crypto) C
blockEx7
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
KeyHash 'BlockIssuer (EraCrypto era)
-> Word64 -> ChainState era -> ChainState era
C.setOCertCounter (forall (a :: KeyRole -> * -> *) (r :: KeyRole) c (r' :: KeyRole).
HasKeyRole a =>
a r c -> a r' c
coerceKeyRole forall a b. (a -> b) -> a -> b
$ forall v (r :: KeyRole). AllIssuerKeys v r -> KeyHash r v
aikColdKeyHash forall c. Crypto c => AllIssuerKeys c 'StakePool
Cast.bobPoolKeys) Word64
0
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
KeyHash 'StakePool (EraCrypto era)
-> ChainState era -> ChainState era
C.incrBlockCount (forall v (r :: KeyRole). AllIssuerKeys v r -> KeyHash r v
aikColdKeyHash forall c. Crypto c => AllIssuerKeys c '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 (BHeader C_Crypto) C
twoPools7 :: CHAINExample (BHeader C_Crypto) C
twoPools7 = forall h era.
ChainState era
-> Block h era
-> Either
     (NonEmpty (PredicateFailure (CHAIN era))) (ChainState era)
-> CHAINExample h era
CHAINExample ChainState C
expectedStEx6 Block (BHeader C_Crypto) 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
⭒ forall c. HashHeader c -> Nonce
hashHeaderToNonce (forall c. Crypto c => BHeader c -> HashHeader c
bhHash forall a b. (a -> b) -> a -> b
$ forall h era. Block h era -> h
bheader Block (BHeader C_Crypto) C
blockEx4)

blockEx8 :: Block (BHeader C_Crypto) C
blockEx8 :: Block (BHeader C_Crypto) C
blockEx8 =
  forall era (r :: KeyRole).
(EraSegWits era, Signable (VRF (EraCrypto era)) (WithResult Seed),
 Signable (KES (EraCrypto era)) (BHBody (EraCrypto era))) =>
HashHeader (EraCrypto era)
-> AllIssuerKeys (EraCrypto era) r
-> [Tx era]
-> SlotNo
-> BlockNo
-> Nonce
-> NatNonce
-> UnitInterval
-> Word
-> Word
-> OCert (EraCrypto era)
-> Block (BHeader (EraCrypto era)) era
mkBlockFakeVRF
    (forall c. Crypto c => BHeader c -> HashHeader c
bhHash forall a b. (a -> b) -> a -> b
$ forall h era. Block h era -> h
bheader @(BHeader C_Crypto) Block (BHeader C_Crypto) C
blockEx7)
    (forall era.
(HasCallStack, EraPParams era) =>
PParams era
-> Word64 -> AllIssuerKeys (EraCrypto era) '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, Signable (DSIGN c) (OCertSignable c)) =>
AllIssuerKeys c r -> Word64 -> KESPeriod -> OCert c
mkOCert (forall era.
(HasCallStack, EraPParams era) =>
PParams era
-> Word64 -> AllIssuerKeys (EraCrypto era) '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 (EraCrypto era)) era
-> ChainState era -> ChainState era
C.newEpoch Block (BHeader C_Crypto) C
blockEx8
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
SnapShot (EraCrypto era)
-> Coin -> ChainState era -> ChainState era
C.newSnapshot forall c. ExMock c => SnapShot c
snapEx3 (Integer -> Coin
Coin Integer
0)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
KeyHash 'BlockIssuer (EraCrypto era)
-> Word64 -> ChainState era -> ChainState era
C.setOCertCounter forall {r' :: KeyRole}. KeyHash r' C_Crypto
coreNodeHK Word64
1
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraGov era =>
RewardUpdate (EraCrypto era) -> ChainState era -> ChainState era
C.applyRewardUpdate forall c. RewardUpdate c
emptyRewardUpdate
    forall a b. (a -> b) -> a -> b
$ ChainState C
expectedStEx7
  where
    coreNodeHK :: KeyHash r' C_Crypto
coreNodeHK = forall (a :: KeyRole -> * -> *) (r :: KeyRole) c (r' :: KeyRole).
HasKeyRole a =>
a r c -> a r' c
coerceKeyRole forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall v (r :: KeyRole). AllIssuerKeys v r -> KeyHash r v
aikColdKeyHash forall a b. (a -> b) -> a -> b
$ forall era.
(HasCallStack, EraPParams era) =>
PParams era
-> Word64 -> AllIssuerKeys (EraCrypto era) '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 (BHeader C_Crypto) C
twoPools8 :: CHAINExample (BHeader C_Crypto) C
twoPools8 = forall h era.
ChainState era
-> Block h era
-> Either
     (NonEmpty (PredicateFailure (CHAIN era))) (ChainState era)
-> CHAINExample h era
CHAINExample ChainState C
expectedStEx7 Block (BHeader C_Crypto) C
blockEx8 (forall a b. b -> Either a b
Right ChainState C
expectedStEx8)

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

blockEx9 :: Block (BHeader C_Crypto) C
blockEx9 :: Block (BHeader C_Crypto) C
blockEx9 =
  forall era (r :: KeyRole).
(EraSegWits era, Signable (VRF (EraCrypto era)) (WithResult Seed),
 Signable (KES (EraCrypto era)) (BHBody (EraCrypto era))) =>
HashHeader (EraCrypto era)
-> AllIssuerKeys (EraCrypto era) r
-> [Tx era]
-> SlotNo
-> BlockNo
-> Nonce
-> NatNonce
-> UnitInterval
-> Word
-> Word
-> OCert (EraCrypto era)
-> Block (BHeader (EraCrypto era)) era
mkBlockFakeVRF
    (forall c. Crypto c => BHeader c -> HashHeader c
bhHash forall a b. (a -> b) -> a -> b
$ forall h era. Block h era -> h
bheader @(BHeader C_Crypto) Block (BHeader C_Crypto) C
blockEx8)
    (forall era.
(HasCallStack, EraPParams era) =>
PParams era
-> Word64 -> AllIssuerKeys (EraCrypto era) '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, Signable (DSIGN c) (OCertSignable c)) =>
AllIssuerKeys c r -> Word64 -> KESPeriod -> OCert c
mkOCert (forall era.
(HasCallStack, EraPParams era) =>
PParams era
-> Word64 -> AllIssuerKeys (EraCrypto era) '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 :: forall c. ExMock c => Coin
alicePoolRewards :: forall c. ExMock c => 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 c) 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 = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. Coin -> Integer
unCoin forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c. PoolParams c -> Coin
ppPledge forall a b. (a -> b) -> a -> b
$ forall c. Crypto c => PoolParams c
alicePoolParams' @c
    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 c) forall era.
(EraPParams era, ProtVerAtMost era 4, ProtVerAtMost era 6) =>
PParams era
ppEx Coin
bigR Rational
aliceStakeShareTot Rational
pr

carlMemberRewardsFromAlice :: forall c. ExMock c => Coin
carlMemberRewardsFromAlice :: forall c. ExMock c => Coin
carlMemberRewardsFromAlice =
  forall c. Coin -> PoolParams c -> StakeShare -> StakeShare -> Coin
memberRew
    (forall c. ExMock c => Coin
alicePoolRewards @c)
    (forall c. Crypto c => PoolParams c
alicePoolParams' @c)
    (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 :: forall c. ExMock c => Coin
carlLeaderRewardsFromAlice :: forall c. ExMock c => Coin
carlLeaderRewardsFromAlice =
  forall c. Coin -> PoolParams c -> StakeShare -> StakeShare -> Coin
leaderRew
    (forall c. ExMock c => Coin
alicePoolRewards @c)
    (forall c. Crypto c => PoolParams c
alicePoolParams' @c)
    (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 :: forall c. ExMock c => Coin
bobPoolRewards :: forall c. ExMock c => 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 c) 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 = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. Coin -> Integer
unCoin forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c. PoolParams c -> Coin
ppPledge forall a b. (a -> b) -> a -> b
$ forall c. Crypto c => PoolParams c
bobPoolParams' @c
    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 c) forall era.
(EraPParams era, ProtVerAtMost era 4, ProtVerAtMost era 6) =>
PParams era
ppEx Coin
bigR Rational
bobStakeShareTot Rational
pr

carlLeaderRewardsFromBob :: forall c. ExMock c => Coin
carlLeaderRewardsFromBob :: forall c. ExMock c => Coin
carlLeaderRewardsFromBob =
  forall c. Coin -> PoolParams c -> StakeShare -> StakeShare -> Coin
leaderRew
    (forall c. ExMock c => Coin
bobPoolRewards @c)
    (forall c. Crypto c => PoolParams c
bobPoolParams' @c)
    (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 :: forall c. ExMock c => NonMyopic c
nonMyopicEx9 :: forall c. ExMock c => NonMyopic c
nonMyopicEx9 =
  forall c.
Map (KeyHash 'StakePool c) Likelihood -> Coin -> NonMyopic c
NonMyopic
    ( forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
        [ (forall v (r :: KeyRole). AllIssuerKeys v r -> KeyHash r v
aikColdKeyHash forall c. Crypto c => AllIssuerKeys c 'StakePool
Cast.alicePoolKeys, Likelihood
alicePerfEx9)
        , (forall v (r :: KeyRole). AllIssuerKeys v r -> KeyHash r v
aikColdKeyHash forall c. Crypto c => AllIssuerKeys c 'StakePool
Cast.bobPoolKeys, Likelihood
bobPerfEx9)
        ]
    )
    Coin
bigR

rewardUpdateEx9 ::
  PParams C ->
  Map (Credential 'Staking C_Crypto) (Set (Reward C_Crypto)) ->
  RewardUpdate C_Crypto
rewardUpdateEx9 :: PParams C
-> Map (Credential 'Staking C_Crypto) (Set (Reward C_Crypto))
-> RewardUpdate C_Crypto
rewardUpdateEx9 PParams C
pp Map (Credential 'Staking C_Crypto) (Set (Reward C_Crypto))
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 C_Crypto) (Set (Reward C_Crypto))
rs = Map (Credential 'Staking C_Crypto) (Set (Reward C_Crypto))
rewards
    , deltaF :: DeltaCoin
deltaF = Integer -> DeltaCoin
DeltaCoin Integer
0
    , nonMyopic :: NonMyopic C_Crypto
nonMyopic = forall c. ExMock c => NonMyopic c
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
<-> forall c.
ProtVer -> Map (Credential 'Staking c) (Set (Reward c)) -> Coin
sumRewards ProtVer
pv Map (Credential 'Staking C_Crypto) (Set (Reward C_Crypto))
rewards

pulserEx9 :: PParams C -> PulsingRewUpdate (EraCrypto C)
pulserEx9 :: PParams C -> PulsingRewUpdate (EraCrypto C)
pulserEx9 PParams C
pp =
  forall era.
EraGov era =>
BlocksMade (EraCrypto era)
-> ChainState era -> PulsingRewUpdate (EraCrypto era)
makeCompletedPulser
    ( forall c. Map (KeyHash 'StakePool c) Natural -> BlocksMade c
BlocksMade forall a b. (a -> b) -> a -> b
$
        forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
          [(forall v (r :: KeyRole). AllIssuerKeys v r -> KeyHash r v
aikColdKeyHash forall c. Crypto c => AllIssuerKeys c 'StakePool
Cast.alicePoolKeys, Natural
2), (forall v (r :: KeyRole). AllIssuerKeys v r -> KeyHash r v
aikColdKeyHash forall c. Crypto c => AllIssuerKeys c '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. Era era => Block (BHeader (EraCrypto era)) era -> Nonce
getBlockNonce Block (BHeader C_Crypto) C
blockEx9)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
Era era =>
Block (BHeader (EraCrypto era)) era
-> ChainState era -> ChainState era
C.newLab Block (BHeader C_Crypto) C
blockEx9
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
KeyHash 'BlockIssuer (EraCrypto era)
-> Word64 -> ChainState era -> ChainState era
C.setOCertCounter forall {r' :: KeyRole}. KeyHash r' C_Crypto
coreNodeHK Word64
2
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
PulsingRewUpdate (EraCrypto era)
-> ChainState era -> ChainState era
C.pulserUpdate (PParams C -> PulsingRewUpdate (EraCrypto C)
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' C_Crypto
coreNodeHK = forall (a :: KeyRole -> * -> *) (r :: KeyRole) c (r' :: KeyRole).
HasKeyRole a =>
a r c -> a r' c
coerceKeyRole forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall v (r :: KeyRole). AllIssuerKeys v r -> KeyHash r v
aikColdKeyHash forall a b. (a -> b) -> a -> b
$ forall era.
(HasCallStack, EraPParams era) =>
PParams era
-> Word64 -> AllIssuerKeys (EraCrypto era) '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 (BHeader (EraCrypto C)) C
twoPools9 :: CHAINExample (BHeader (EraCrypto C)) C
twoPools9 = forall h era.
ChainState era
-> Block h era
-> Either
     (NonEmpty (PredicateFailure (CHAIN era))) (ChainState era)
-> CHAINExample h era
CHAINExample ChainState C
expectedStEx8 Block (BHeader C_Crypto) 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 :: forall c. ExMock c => Set (Reward c)
carlsRewards :: forall c. ExMock c => Set (Reward c)
carlsRewards =
  forall a. Ord a => [a] -> Set a
Set.fromList
    [ forall c. RewardType -> KeyHash 'StakePool c -> Coin -> Reward c
Reward RewardType
MemberReward (forall v (r :: KeyRole). AllIssuerKeys v r -> KeyHash r v
aikColdKeyHash forall c. Crypto c => AllIssuerKeys c 'StakePool
Cast.alicePoolKeys) (forall c. ExMock c => Coin
carlMemberRewardsFromAlice @c)
    , forall c. RewardType -> KeyHash 'StakePool c -> Coin -> Reward c
Reward RewardType
LeaderReward (forall v (r :: KeyRole). AllIssuerKeys v r -> KeyHash r v
aikColdKeyHash forall c. Crypto c => AllIssuerKeys c 'StakePool
Cast.alicePoolKeys) (forall c. ExMock c => Coin
carlLeaderRewardsFromAlice @c)
    , forall c. RewardType -> KeyHash 'StakePool c -> Coin -> Reward c
Reward RewardType
LeaderReward (forall v (r :: KeyRole). AllIssuerKeys v r -> KeyHash r v
aikColdKeyHash forall c. Crypto c => AllIssuerKeys c 'StakePool
Cast.bobPoolKeys) (forall c. ExMock c => Coin
carlLeaderRewardsFromBob @c)
    ]

rsEx9Agg :: forall c. ExMock c => Map (Credential 'Staking c) (Set (Reward c))
rsEx9Agg :: forall c. ExMock c => Map (Credential 'Staking c) (Set (Reward c))
rsEx9Agg = forall k a. k -> a -> Map k a
Map.singleton forall c. Crypto c => Credential 'Staking c
Cast.carlSHK forall c. ExMock c => Set (Reward c)
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 (BHeader C_Crypto) C
twoPools9Agg :: CHAINExample (BHeader C_Crypto) C
twoPools9Agg = forall h era.
ChainState era
-> Block h era
-> Either
     (NonEmpty (PredicateFailure (CHAIN era))) (ChainState era)
-> CHAINExample h era
CHAINExample ChainState C
expectedStEx8Agg Block (BHeader C_Crypto) 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 = forall c. ExMock c => Coin
carlLeaderRewardsFromBob @(EraCrypto C)
  Coin
expectedReward forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= forall c. Reward c -> Coin
rewardAmount (forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum (forall c. ExMock c => Set (Reward c)
carlsRewards @(EraCrypto C)))
  forall c.
ProtVer
-> Map (Credential 'Staking c) (Set (Reward c))
-> Map (Credential 'Staking c) Coin
aggregateRewards @C_Crypto (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) forall c. ExMock c => Map (Credential 'Staking c) (Set (Reward c))
rsEx9Agg
    forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= forall k a. k -> a -> Map k a
Map.singleton forall c. Crypto c => Credential 'Staking c
Cast.carlSHK Coin
expectedReward

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

--
-- 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 (BHeader C_Crypto) C -> Assertion
testCHAINExample CHAINExample (BHeader (EraCrypto C)) C
twoPools9
    , TestName -> Assertion -> TestTree
testCase TestName
"non-aggregated pulser is correct" forall a b. (a -> b) -> a -> b
$
        forall c. RewardUpdate c -> PulsingRewUpdate c
Complete (PParams C
-> Map (Credential 'Staking C_Crypto) (Set (Reward C_Crypto))
-> RewardUpdate C_Crypto
rewardUpdateEx9 forall era.
(EraPParams era, ProtVerAtMost era 4, ProtVerAtMost era 6) =>
PParams era
ppEx forall c. ExMock c => Map (Credential 'Staking c) (Set (Reward c))
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
. forall c.
PulsingRewUpdate c
-> ShelleyBase (PulsingRewUpdate c, RewardEvent c)
completeStep forall a b. (a -> b) -> a -> b
$ PParams C -> PulsingRewUpdate (EraCrypto C)
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
$
        forall c. RewardUpdate c -> PulsingRewUpdate c
Complete (PParams C
-> Map (Credential 'Staking C_Crypto) (Set (Reward C_Crypto))
-> RewardUpdate C_Crypto
rewardUpdateEx9 PParams C
ppProtVer3 forall c. ExMock c => Map (Credential 'Staking c) (Set (Reward c))
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
. forall c.
PulsingRewUpdate c
-> ShelleyBase (PulsingRewUpdate c, RewardEvent c)
completeStep forall a b. (a -> b) -> a -> b
$ PParams C -> PulsingRewUpdate (EraCrypto C)
pulserEx9 PParams C
ppProtVer3)
    , TestName -> Assertion -> TestTree
testCase TestName
"create aggregated pulser" forall a b. (a -> b) -> a -> b
$ HasCallStack => CHAINExample (BHeader C_Crypto) C -> Assertion
testCHAINExample CHAINExample (BHeader C_Crypto) 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 (BHeader C_Crypto) C -> Assertion
testCHAINExample CHAINExample (BHeader C_Crypto) C
twoPools1
    , TestName -> Assertion -> TestTree
testCase TestName
"delegate stake and create reward update" forall a b. (a -> b) -> a -> b
$ HasCallStack => CHAINExample (BHeader C_Crypto) C -> Assertion
testCHAINExample CHAINExample (BHeader C_Crypto) C
twoPools2
    , TestName -> Assertion -> TestTree
testCase TestName
"new epoch changes" forall a b. (a -> b) -> a -> b
$ HasCallStack => CHAINExample (BHeader C_Crypto) C -> Assertion
testCHAINExample CHAINExample (BHeader C_Crypto) C
twoPools3
    , TestName -> Assertion -> TestTree
testCase TestName
"second reward update" forall a b. (a -> b) -> a -> b
$ HasCallStack => CHAINExample (BHeader C_Crypto) C -> Assertion
testCHAINExample CHAINExample (BHeader C_Crypto) C
twoPools4
    , TestName -> Assertion -> TestTree
testCase TestName
"nonempty pool distr" forall a b. (a -> b) -> a -> b
$ HasCallStack => CHAINExample (BHeader C_Crypto) C -> Assertion
testCHAINExample CHAINExample (BHeader C_Crypto) C
twoPools5
    , TestName -> Assertion -> TestTree
testCase TestName
"alice produces a block" forall a b. (a -> b) -> a -> b
$ HasCallStack => CHAINExample (BHeader C_Crypto) C -> Assertion
testCHAINExample CHAINExample (BHeader C_Crypto) C
twoPools6
    , TestName -> Assertion -> TestTree
testCase TestName
"bob produces a block" forall a b. (a -> b) -> a -> b
$ HasCallStack => CHAINExample (BHeader C_Crypto) C -> Assertion
testCHAINExample CHAINExample (BHeader C_Crypto) C
twoPools7
    , TestName -> Assertion -> TestTree
testCase TestName
"prelude to the first nontrivial rewards" forall a b. (a -> b) -> a -> b
$ HasCallStack => CHAINExample (BHeader C_Crypto) C -> Assertion
testCHAINExample CHAINExample (BHeader C_Crypto) C
twoPools8
    , TestName -> Assertion -> TestTree
testCase TestName
"create non-aggregated rewards" forall a b. (a -> b) -> a -> b
$ HasCallStack => CHAINExample (BHeader C_Crypto) C -> Assertion
testCHAINExample CHAINExample (BHeader (EraCrypto C)) C
twoPools9
    , TestName -> Assertion -> TestTree
testCase TestName
"create aggregated rewards" forall a b. (a -> b) -> a -> b
$ HasCallStack => CHAINExample (BHeader C_Crypto) C -> Assertion
testCHAINExample CHAINExample (BHeader C_Crypto) C
twoPools9Agg
    ]