Make the overlay schedule abstract

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

@@ -35,6 +35,7 @@ library
  Shelley.Spec.Ledger.MetaData
  Shelley.Spec.Ledger.OCert
  Shelley.Spec.Ledger.Orphans
+ Shelley.Spec.Ledger.OverlaySchedule
  Shelley.Spec.Ledger.PParams
  Shelley.Spec.Ledger.Rewards
  Shelley.Spec.Ledger.Scripts

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

@@ -36,7 +36,6 @@ import Control.Monad.Except
 import Control.Monad.Trans.Reader (runReader)
 import Control.State.Transition.Extended (PredicateFailure, TRC (..), applySTS)
 import Data.Either (fromRight)
-import Data.Map.Strict (Map)
 import GHC.Generics (Generic)
 import Shelley.Spec.Ledger.API.Validation
 import Shelley.Spec.Ledger.BaseTypes (Globals, Nonce, Seed)
@@ -47,13 +46,15 @@ import Shelley.Spec.Ledger.Keys (GenDelegs)
 import Shelley.Spec.Ledger.LedgerState
  ( EpochState (..),
  NewEpochState (..),
- OBftSlot,
  getGKeys,
  _delegationState,
  _dstate,
  _genDelegs,
  )
 import Shelley.Spec.Ledger.OCert (OCertSignable)
+import Shelley.Spec.Ledger.OverlaySchedule
+ ( OverlaySchedule,
+ )
 import Shelley.Spec.Ledger.PParams (PParams)
 import qualified Shelley.Spec.Ledger.STS.Prtcl as STS.Prtcl
 import Shelley.Spec.Ledger.STS.Tick (TICK, TickEnv (..))
@@ -64,7 +65,7 @@ import Shelley.Spec.Ledger.Slot (SlotNo)
 -- | Data required by the Transitional Praos protocol from the Shelley ledger.
 data LedgerView crypto = LedgerView
  { lvProtParams :: PParams,
- lvOverlaySched :: Map SlotNo (OBftSlot crypto),
+ lvOverlaySched :: OverlaySchedule crypto,
  lvPoolDistr :: PoolDistr crypto,
  lvGenDelegs :: GenDelegs crypto
  }

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

@@ -66,19 +66,19 @@ import Shelley.Spec.Ledger.LedgerState as X
  LedgerState (..),
  NewEpochEnv (..),
  NewEpochState (..),
- OBftSlot (..),
  PState (..),
  RewardUpdate (..),
  UTxOState (..),
  WitHashes (..),
  )
 import Shelley.Spec.Ledger.OCert as X (OCert (..))
+import Shelley.Spec.Ledger.OverlaySchedule as X
+ ( OBftSlot (..),
+ )
 import Shelley.Spec.Ledger.PParams as X
  ( PParams,
  PParams' (..),
- )
-import Shelley.Spec.Ledger.PParams as X
- ( ProposedPPUpdates (..),
+ ProposedPPUpdates (..),
  Update (..),
  )
 import Shelley.Spec.Ledger.Rewards as X

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

@@ -19,7 +19,6 @@ where
 
 import Cardano.Prelude (NoUnexpectedThunks (..))
 import Control.Arrow (left, right)
-import Control.Iterate.SetAlgebra (dom, eval)
 import Control.Monad.Except
 import Control.Monad.Trans.Reader (runReader)
 import Control.State.Transition.Extended (TRC (..), applySTS, reapplySTS)
@@ -62,14 +61,14 @@ mkTickEnv = STS.TickEnv . LedgerState.getGKeys
 
 mkBbodyEnv ::
  ShelleyState crypto ->
- STS.BbodyEnv
+ STS.BbodyEnv crypto
 mkBbodyEnv
  LedgerState.NewEpochState
  { LedgerState.nesOsched,
  LedgerState.nesEs
  } =
  STS.BbodyEnv
- { STS.bbodySlots = eval (dom nesOsched),
+ { STS.bbodySlots = nesOsched,
  STS.bbodyPp = LedgerState.esPp nesEs,
  STS.bbodyAccount = LedgerState.esAccountState nesEs
  }

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

@@ -37,6 +37,7 @@ import Shelley.Spec.Ledger.LedgerState
  UTxOState (..),
  stakeDistr,
  )
+import Shelley.Spec.Ledger.OverlaySchedule (isOverlaySlot)
 import Shelley.Spec.Ledger.Rewards
  ( NonMyopic (..),
  StakeShare (..),
@@ -137,7 +138,7 @@ getLeaderSchedule globals ss cds poolHash key = Set.filter isLeader epochSlots
  where
  isLeader slotNo =
  let y = VRF.evalCertified () (mkSeed seedL slotNo epochNonce) key
- in Map.notMember slotNo overlaySched
+ in not (isOverlaySlot slotNo overlaySched)
  && checkLeaderValue (VRF.certifiedOutput y) stake f
  stake = maybe 0 individualPoolStake $ Map.lookup poolHash poolDistr
  overlaySched = nesOsched ss

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

@@ -33,7 +33,6 @@ module Shelley.Spec.Ledger.LedgerState
  Ix,
  KeyPairs,
  LedgerState (..),
- OBftSlot (..),
  PPUPState (..),
  PState (..),
  RewardAccounts,
@@ -86,7 +85,6 @@ module Shelley.Spec.Ledger.LedgerState
  --
  NewEpochState (..),
  NewEpochEnv (..),
- overlaySchedule,
  getGKeys,
  updateNES,
  )
@@ -95,19 +93,13 @@ where
 import Cardano.Binary
  ( FromCBOR (..),
  ToCBOR (..),
- TokenType (TypeNull),
- decodeNull,
  encodeListLen,
- encodeNull,
- peekTokenType,
  )
 import Cardano.Prelude (NFData, NoUnexpectedThunks (..))
 import Control.Iterate.SetAlgebra (Bimap, biMapEmpty, dom, eval, forwards, range, (∈), (∪+), (▷), (◁))
 import Control.Monad.Trans.Reader (asks)
 import qualified Data.ByteString.Lazy as BSL (length)
 import Data.Foldable (toList)
-import Data.List.NonEmpty (NonEmpty)
-import qualified Data.List.NonEmpty as NonEmpty
 import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
 import Data.Maybe (fromMaybe)
@@ -162,6 +154,7 @@ import Shelley.Spec.Ledger.Keys
  VKey,
  asWitness,
  )
+import Shelley.Spec.Ledger.OverlaySchedule
 import Shelley.Spec.Ledger.PParams
  ( PParams,
  PParams' (..),
@@ -179,13 +172,9 @@ import Shelley.Spec.Ledger.Rewards
  )
 import Shelley.Spec.Ledger.Serialization (decodeRecordNamed, mapFromCBOR, mapToCBOR)
 import Shelley.Spec.Ledger.Slot
- ( Duration (..),
- EpochNo (..),
+ ( EpochNo (..),
  EpochSize,
  SlotNo (..),
- epochInfoFirst,
- epochInfoSize,
- (+*),
  )
 import Shelley.Spec.Ledger.Tx
  ( Tx (..),
@@ -546,33 +535,6 @@ instance Crypto crypto => FromCBOR (UTxOState crypto) where
  us <- fromCBOR
  pure $ UTxOState ut dp fs us
 
-data OBftSlot crypto
- = NonActiveSlot
- | ActiveSlot !(KeyHash 'Genesis crypto)
- deriving (Show, Eq, Ord, Generic)
-
-instance
- Crypto crypto =>
- ToCBOR (OBftSlot crypto)
- where
- toCBOR NonActiveSlot = encodeNull
- toCBOR (ActiveSlot k) = toCBOR k
-
-instance
- Crypto crypto =>
- FromCBOR (OBftSlot crypto)
- where
- fromCBOR = do
- peekTokenType >>= \case
- TypeNull -> do
- decodeNull
- pure NonActiveSlot
- _ -> ActiveSlot <$> fromCBOR
-
-instance NoUnexpectedThunks (OBftSlot crypto)
-
-instance NFData (OBftSlot crypto)
-
 -- | New Epoch state and environment
 data NewEpochState crypto = NewEpochState
  { -- | Last epoch
@@ -588,7 +550,7 @@ data NewEpochState crypto = NewEpochState
  -- | Stake distribution within the stake pool
  nesPd :: !(PoolDistr crypto),
  -- | Overlay schedule for PBFT vs Praos
- nesOsched :: !(Map SlotNo (OBftSlot crypto))
+ nesOsched :: !(OverlaySchedule crypto)
  }
  deriving (Show, Eq, Generic)
 
@@ -601,7 +563,7 @@ instance Crypto crypto => ToCBOR (NewEpochState crypto) where
  encodeListLen 7 <> toCBOR e <> toCBOR bp <> toCBOR bc <> toCBOR es
  <> toCBOR ru
  <> toCBOR pd
- <> toCBOR (compactOverlaySchedule os)
+ <> toCBOR os
 
 instance Crypto crypto => FromCBOR (NewEpochState crypto) where
  fromCBOR = do
@@ -612,35 +574,9 @@ instance Crypto crypto => FromCBOR (NewEpochState crypto) where
  es <- fromCBOR
  ru <- fromCBOR
  pd <- fromCBOR
- os <- decompactOverlaySchedule <$> fromCBOR
+ os <- fromCBOR
  pure $ NewEpochState e bp bc es ru pd os
 
--- | Convert the overlay schedule to a representation that is more compact
--- when serialised to a bytestring, but less efficient for lookups.
---
--- Each genesis key hash will only be stored once, instead of each time it is
--- assigned to a slot.
-compactOverlaySchedule ::
- Map SlotNo (OBftSlot crypto) ->
- Map (OBftSlot crypto) (NonEmpty SlotNo)
-compactOverlaySchedule =
- Map.foldrWithKey'
- ( \slot obftSlot ->
- Map.insertWith (<>) obftSlot (pure slot)
- )
- Map.empty
-
--- | Inverse of 'compactOverlaySchedule'
-decompactOverlaySchedule ::
- Map (OBftSlot crypto) (NonEmpty SlotNo) ->
- Map SlotNo (OBftSlot crypto)
-decompactOverlaySchedule compact =
- Map.fromList
- [ (slot, obftSlot)
- | (obftSlot, slots) <- Map.toList compact,
- slot <- NonEmpty.toList slots
- ]
-
 getGKeys ::
  NewEpochState crypto ->
  Set (KeyHash 'Genesis crypto)
@@ -1020,44 +956,6 @@ createRUpd slotsPerEpoch b@(BlocksMade b') (EpochState acnt ss ls pr _ nm) total
  nonMyopic = (updateNonMypopic nm _R newLikelihoods (_pstakeGo ss))
  }
 
--- | Overlay schedule
--- This is just a very simple round-robin, evenly spaced schedule.
-overlaySchedule ::
- EpochNo ->
- Set (KeyHash 'Genesis crypto) ->
- PParams ->
- ShelleyBase (Map SlotNo (OBftSlot crypto))
-overlaySchedule e gkeys pp = do
- let dval = intervalValue $ _d pp
- if dval == 0
- then pure Map.empty
- else do
- ei <- asks epochInfo
- slotsPerEpoch <- epochInfoSize ei e
- firstSlotNo <- epochInfoFirst ei e
- asc <- asks activeSlotCoeff
- let numActive = dval * fromIntegral slotsPerEpoch
- dInv = 1 / dval
- ascValue = (intervalValue . activeSlotVal) asc
- toRelativeSlotNo x = (Duration . floor) (dInv * fromInteger x)
- toSlotNo x = firstSlotNo +* toRelativeSlotNo x
- genesisSlots = [toSlotNo x | x <- [0 .. (floor numActive - 1)]]
- numInactivePerActive = floor (1 / ascValue) - 1
- activitySchedule = cycle (True : replicate numInactivePerActive False)
- unassignedSched = zip activitySchedule genesisSlots
- genesisCycle = if Set.null gkeys then [] else cycle (Set.toList gkeys)
- active =
- Map.fromList $
- fmap
- (\(gk, (_, s)) -> (s, ActiveSlot gk))
- (zip genesisCycle (filter fst unassignedSched))
- inactive =
- Map.fromList $
- fmap
- (\x -> (snd x, NonActiveSlot))
- (filter (not . fst) unassignedSched)
- pure $ Map.union active inactive
-
 -- | Update new epoch state
 updateNES ::
  NewEpochState crypto ->