Make ticking a bit more realistic in Imp tests

Current implementation of ticking in ImpSpec is a bit naive, since it
calls `TICK` rule for every slot. This is not only slow, but it also
does not match the reality. On an actual running node TICK is called
on every block, which happens on average every `1/activeSlotCoefficient`
number of slots. On mainnet this is about every 20 slots or every 20
seconds.

Switching to this approach makes imp tests significantly faster, namely
about 80% faster on the example of Conway imp tests.

Author: lehins

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`
 * Limit `DecCBORGroup` decoding of `ProtVer` fields to `Word32` starting from protocol version `12`
 * Change `Relation` type to only be visible at the type level
 * Change `KeyRole` 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)