Make ticking a bit more realistic in Imp tests

eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/ImpTest.hs

@@ -259,7 +259,7 @@ import Data.List.NonEmpty (NonEmpty)
 import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
 import Data.Maybe (catMaybes, isNothing, mapMaybe)
-import Data.Ratio ((%))
+import Data.Ratio (denominator, numerator, (%))
 import Data.Sequence.Strict (StrictSeq (..))
 import qualified Data.Sequence.Strict as SSeq
 import qualified Data.Set as Set
@@ -1343,27 +1343,46 @@ passTick = do
   impLastTickL += 1
   impNESL .= nes
 
+-- | Win with supplied probability
+gambleWithProbability ::
+  HasStatefulGen g m =>
+  -- | Probability with which this action should produce `True`
+  UnitInterval ->
+  m Bool
+gambleWithProbability probability = do
+  let p = unboundRational probability
+  n <- uniformRM (1, denominator p)
+  pure (n <= numerator p)
+
 -- | Runs the TICK rule until the next epoch is reached
 passEpoch ::
   forall era.
   (ShelleyEraImp era, HasCallStack) =>
   ImpTestM era ()
 passEpoch = do
+  globals <- use impGlobalsL
+  preNES <- gets impNES
   let
-    tickUntilNewEpoch curEpochNo = do
-      oldNES <- getsNES id
-      passTick @era
-      newEpochNo <- getsNES nesELL
-      if newEpochNo > curEpochNo
+    curEpochNo = preNES ^. nesELL
+    ticksPerSlot =
+      positiveUnitIntervalRelaxToUnitInterval (activeSlotVal (activeSlotCoeff globals))
+    tickUntilNewEpoch = do
+      tickHasBlock <- gambleWithProbability ticksPerSlot
+      if tickHasBlock
         then do
-          globals <- use impGlobalsL
-          newNES <- getsNES id
-          asks itePostEpochBoundaryHook >>= (\f -> f globals (TRC ((), oldNES, newEpochNo)) newNES)
-        else tickUntilNewEpoch curEpochNo
-  preNES <- gets impNES
-  let startEpoch = preNES ^. nesELL
-  logDoc $ "Entering " <> ansiExpr (succ startEpoch)
-  tickUntilNewEpoch startEpoch
+          oldNES <- getsNES id
+          passTick @era
+          newEpochNo <- getsNES nesELL
+          if newEpochNo > curEpochNo
+            then do
+              newNES <- getsNES id
+              asks itePostEpochBoundaryHook >>= (\f -> f globals (TRC ((), oldNES, newEpochNo)) newNES)
+            else tickUntilNewEpoch
+        else do
+          impLastTickL += 1
+          tickUntilNewEpoch
+  logDoc $ "Entering " <> ansiExpr (succ curEpochNo)
+  tickUntilNewEpoch
   gets impNES >>= epochBoundaryCheck preNES
 
 epochBoundaryCheck ::
@@ -1869,7 +1888,8 @@ whenMajorVersion ::
   , MinVersion <= v
   , v <= MaxVersion
   ) =>
-  ImpTestM era () -> ImpTestM era ()
+  ImpTestM era () ->
+  ImpTestM era ()
 whenMajorVersion a = do
   pv <- getProtVer
   when (pvMajor pv == natVersion @v) a
@@ -1881,7 +1901,8 @@ whenMajorVersionAtLeast ::
   , MinVersion <= v
   , v <= MaxVersion
   ) =>
-  ImpTestM era () -> ImpTestM era ()
+  ImpTestM era () ->
+  ImpTestM era ()
 whenMajorVersionAtLeast a = do
   pv <- getProtVer
   when (pvMajor pv >= natVersion @v) a
@@ -1893,7 +1914,8 @@ whenMajorVersionAtMost ::
   , MinVersion <= v
   , v <= MaxVersion
   ) =>
-  ImpTestM era () -> ImpTestM era ()
+  ImpTestM era () ->
+  ImpTestM era ()
 whenMajorVersionAtMost a = do
   pv <- getProtVer
   when (pvMajor pv <= natVersion @v) a
@@ -1905,7 +1927,8 @@ unlessMajorVersion ::
   , MinVersion <= v
   , v <= MaxVersion
   ) =>
-  ImpTestM era () -> ImpTestM era ()
+  ImpTestM era () ->
+  ImpTestM era ()
 unlessMajorVersion a = do
   pv <- getProtVer
   unless (pvMajor pv == natVersion @v) a

libs/cardano-ledger-core/CHANGELOG.md

@@ -2,6 +2,7 @@
 
 ## 1.19.0.0
 
+* Add `positiveUnitIntervalRelaxToUnitInterval`, `positiveUnitIntervalRelaxToPositiveInterval` and  `positiveIntervalRelaxToNonNegativeInterval`
 * Add `cddl` sub-library.
 * Limit `DecCBORGroup` decoding of `ProtVer` fields to `Word32` starting from protocol version `12`
 * Change `Relation` type to only be visible at the type level

libs/cardano-ledger-core/src/Cardano/Ledger/BaseTypes.hs

@@ -37,6 +37,9 @@ module Cardano.Ledger.BaseTypes (
   PositiveUnitInterval,
   PositiveInterval,
   NonNegativeInterval,
+  positiveUnitIntervalRelaxToUnitInterval,
+  positiveUnitIntervalRelaxToPositiveInterval,
+  positiveIntervalRelaxToNonNegativeInterval,
   BoundedRational (..),
   fpPrecision,
   integralToBounded,
@@ -485,6 +488,15 @@ instance Bounded (BoundedRatio PositiveUnitInterval Word64) where
   minBound = positiveIntervalEpsilon
   maxBound = BoundedRatio (1 % 1)
 
+positiveUnitIntervalRelaxToUnitInterval :: PositiveUnitInterval -> UnitInterval
+positiveUnitIntervalRelaxToUnitInterval = coerce
+
+positiveUnitIntervalRelaxToPositiveInterval :: PositiveUnitInterval -> PositiveInterval
+positiveUnitIntervalRelaxToPositiveInterval = coerce
+
+positiveIntervalRelaxToNonNegativeInterval :: PositiveInterval -> NonNegativeInterval
+positiveIntervalRelaxToNonNegativeInterval = coerce
+
 -- | Type to represent a value in the unit interval [0; 1]
 newtype UnitInterval
   = UnitInterval (BoundedRatio UnitInterval Word64)