Allow the tx-cost executable to be computed deterministically (#1711)

Adds an optional `--seed` argument to the `tx-cost` executable so we can
compute the cost deterministically.

This will be used by the `tx-cost-difference` CI task recently added in
#1703 .

Note that I haven't updated the CI invocation here because the "old"
(i.e. master) branch won't contain the argument. I'll do that in a
subsequent PR, and that PR itself will demonstrate that it works
(hopefully!)

---

<!-- Consider each and tick it off one way or the other -->
* [x] CHANGELOG updated or not needed
* [x] Documentation updated or not needed
* [x] Haddocks updated or not needed
* [x] No new TODOs introduced or explained herafter

hydra-node/bench/tx-cost/Main.hs

@@ -9,6 +9,7 @@ import Hydra.Plutus.Orphans ()
 import Options.Applicative (
   Parser,
   ParserInfo,
+  auto,
   execParser,
   fullDesc,
   header,
@@ -17,13 +18,16 @@ import Options.Applicative (
   info,
   long,
   metavar,
+  option,
   progDesc,
   short,
   strOption,
  )
 import System.Directory (createDirectoryIfMissing, doesDirectoryExist)
 import System.FilePath ((</>))
 import System.IO.Unsafe (unsafePerformIO)
+import Test.QuickCheck.Gen (Gen (MkGen), chooseAny, generate)
+import Test.QuickCheck.Random (mkQCGen)
 import TxCost (
   computeAbortCost,
   computeCloseCost,
@@ -35,7 +39,7 @@ import TxCost (
   computeInitCost,
  )
 
-newtype Options = Options {outputDirectory :: Maybe FilePath}
+data Options = Options {outputDirectory :: Maybe FilePath, seed :: Maybe Int}
 
 txCostOptionsParser :: Parser Options
 txCostOptionsParser =
@@ -50,6 +54,15 @@ txCostOptionsParser =
                 \ If none is given, output is sent to stdout"
           )
       )
+    <*> optional
+      ( option
+          auto
+          ( long "seed"
+              <> short 's'
+              <> metavar "INT"
+              <> help "A seed value"
+          )
+      )
 
 logFilterOptions :: ParserInfo Options
 logFilterOptions =
@@ -67,21 +80,24 @@ logFilterOptions =
 main :: IO ()
 main =
   execParser logFilterOptions >>= \case
-    Options{outputDirectory = Nothing} -> writeTransactionCostMarkdown stdout
-    Options{outputDirectory = Just outputDir} -> do
+    Options{outputDirectory = Nothing, seed = seed} -> writeTransactionCostMarkdown seed stdout
+    Options{outputDirectory = Just outputDir, seed = seed} -> do
       unlessM (doesDirectoryExist outputDir) $ createDirectoryIfMissing True outputDir
-      withFile (outputDir </> "transaction-cost.md") WriteMode writeTransactionCostMarkdown
+      withFile (outputDir </> "transaction-cost.md") WriteMode (writeTransactionCostMarkdown seed)
 
-writeTransactionCostMarkdown :: Handle -> IO ()
-writeTransactionCostMarkdown hdl = do
-  initC <- costOfInit
-  commitC <- costOfCommit
-  collectComC <- costOfCollectCom
-  decrementC <- costOfDecrement
-  closeC <- costOfClose
-  contestC <- costOfContest
-  abortC <- costOfAbort
-  fanoutC <- costOfFanOut
+writeTransactionCostMarkdown :: Maybe Int -> Handle -> IO ()
+writeTransactionCostMarkdown mseed hdl = do
+  seed <- case mseed of
+    Nothing -> generate chooseAny
+    Just s -> pure s
+  let initC = costOfInit seed
+  let commitC = costOfCommit seed
+  let collectComC = costOfCollectCom seed
+  let decrementC = costOfDecrement seed
+  let closeC = costOfClose seed
+  let contestC = costOfContest seed
+  let abortC = costOfAbort seed
+  let fanoutC = costOfFanOut seed
   hPut hdl $
     encodeUtf8 $
       unlines $
@@ -153,8 +169,11 @@ scriptSizes =
     , depositScriptSize
     } = scriptInfo
 
-costOfInit :: IO Text
-costOfInit = markdownInitCost <$> computeInitCost
+genFromSeed :: Gen a -> Int -> a
+genFromSeed (MkGen g) seed = g (mkQCGen seed) 30
+
+costOfInit :: Int -> Text
+costOfInit = markdownInitCost . genFromSeed computeInitCost
  where
   markdownInitCost stats =
     unlines $
@@ -179,8 +198,8 @@ costOfInit = markdownInitCost <$> computeInitCost
           )
           stats
 
-costOfCommit :: IO Text
-costOfCommit = markdownCommitCost <$> computeCommitCost
+costOfCommit :: Int -> Text
+costOfCommit = markdownCommitCost . genFromSeed computeCommitCost
  where
   markdownCommitCost stats =
     unlines $
@@ -206,8 +225,8 @@ costOfCommit = markdownCommitCost <$> computeCommitCost
           )
           stats
 
-costOfCollectCom :: IO Text
-costOfCollectCom = markdownCollectComCost <$> computeCollectComCost
+costOfCollectCom :: Int -> Text
+costOfCollectCom = markdownCollectComCost . genFromSeed computeCollectComCost
  where
   markdownCollectComCost stats =
     unlines $
@@ -234,8 +253,8 @@ costOfCollectCom = markdownCollectComCost <$> computeCollectComCost
           )
           stats
 
-costOfDecrement :: IO Text
-costOfDecrement = markdownDecrementCost <$> computeDecrementCost
+costOfDecrement :: Int -> Text
+costOfDecrement = markdownDecrementCost . genFromSeed computeDecrementCost
  where
   markdownDecrementCost stats =
     unlines $
@@ -260,8 +279,8 @@ costOfDecrement = markdownDecrementCost <$> computeDecrementCost
           )
           stats
 
-costOfClose :: IO Text
-costOfClose = markdownClose <$> computeCloseCost
+costOfClose :: Int -> Text
+costOfClose = markdownClose . genFromSeed computeCloseCost
  where
   markdownClose stats =
     unlines $
@@ -286,8 +305,8 @@ costOfClose = markdownClose <$> computeCloseCost
           )
           stats
 
-costOfContest :: IO Text
-costOfContest = markdownContest <$> computeContestCost
+costOfContest :: Int -> Text
+costOfContest = markdownContest . genFromSeed computeContestCost
  where
   markdownContest stats =
     unlines $
@@ -312,8 +331,8 @@ costOfContest = markdownContest <$> computeContestCost
           )
           stats
 
-costOfAbort :: IO Text
-costOfAbort = markdownAbortCost <$> computeAbortCost
+costOfAbort :: Int -> Text
+costOfAbort = markdownAbortCost . genFromSeed computeAbortCost
  where
   markdownAbortCost stats =
     unlines $
@@ -339,8 +358,8 @@ costOfAbort = markdownAbortCost <$> computeAbortCost
           )
           stats
 
-costOfFanOut :: IO Text
-costOfFanOut = markdownFanOutCost <$> computeFanOutCost
+costOfFanOut :: Int -> Text
+costOfFanOut = markdownFanOutCost . genFromSeed computeFanOutCost
  where
   markdownFanOutCost stats =
     unlines $

hydra-node/bench/tx-cost/TxCost.hs

@@ -63,16 +63,15 @@ import Hydra.Tx.Snapshot (genConfirmedSnapshot)
 import PlutusLedgerApi.V2 (toBuiltinData)
 import PlutusTx.Builtins (lengthOfByteString, serialiseData)
 import Test.Hydra.Tx.Gen (genOutput, genUTxOAdaOnlyOfSize)
-import Test.QuickCheck (generate)
 
-computeInitCost :: IO [(NumParties, TxSize, MemUnit, CpuUnit, Coin)]
+computeInitCost :: Gen [(NumParties, TxSize, MemUnit, CpuUnit, Coin)]
 computeInitCost = do
   interesting <- catMaybes <$> mapM compute [1, 2, 3, 5, 10]
   limit <- maybeToList . getFirst <$> foldMapM (fmap First . compute) [100, 99 .. 11]
   pure $ interesting <> limit
  where
   compute numParties = do
-    (tx, knownUtxo) <- generate $ genInitTx' numParties
+    (tx, knownUtxo) <- genInitTx' numParties
     case checkSizeAndEvaluate tx knownUtxo of
       Just (txSize, memUnit, cpuUnit, minFee) ->
         pure $ Just (NumParties numParties, txSize, memUnit, cpuUnit, minFee)
@@ -87,15 +86,15 @@ computeInitCost = do
     let utxo = UTxO.singleton (seedInput, seedOutput)
     pure (initialize cctx seedInput (ctxParticipants ctx) (ctxHeadParameters ctx), utxo)
 
-computeCommitCost :: IO [(NumUTxO, TxSize, MemUnit, CpuUnit, Coin)]
+computeCommitCost :: Gen [(NumUTxO, TxSize, MemUnit, CpuUnit, Coin)]
 computeCommitCost = do
   interesting <- catMaybes <$> mapM compute [1, 2, 3, 5, 10]
   limit <- maybeToList . getFirst <$> foldMapM (fmap First . compute) [100, 99 .. 11]
   pure $ interesting <> limit
  where
   compute numUTxO = do
-    utxo <- generate $ genUTxOAdaOnlyOfSize numUTxO
-    (commitTx, knownUtxo) <- generate $ genCommitTx utxo
+    utxo <- genUTxOAdaOnlyOfSize numUTxO
+    (commitTx, knownUtxo) <- genCommitTx utxo
     case commitTx of
       Left _ -> pure Nothing
       Right tx ->
@@ -113,12 +112,12 @@ computeCommitCost = do
         knownUTxO = getKnownUTxO stInitial <> getKnownUTxO cctx
     pure (commit cctx headId knownUTxO utxo, knownUTxO)
 
-computeCollectComCost :: IO [(NumParties, Natural, TxSize, MemUnit, CpuUnit, Coin)]
+computeCollectComCost :: Gen [(NumParties, Natural, TxSize, MemUnit, CpuUnit, Coin)]
 computeCollectComCost =
   catMaybes <$> mapM compute [1 .. 10]
  where
   compute numParties = do
-    (utxo, tx, knownUtxo) <- generate $ genCollectComTx numParties
+    (utxo, tx, knownUtxo) <- genCollectComTx numParties
     case checkSizeAndEvaluate tx knownUtxo of
       Just (txSize, memUnit, cpuUnit, minFee) ->
         pure $ Just (NumParties numParties, serializedSize utxo, txSize, memUnit, cpuUnit, minFee)
@@ -136,45 +135,45 @@ computeCollectComCost =
     let spendableUTxO = getKnownUTxO stInitialized
     pure (fold committedUTxOs, unsafeCollect cctx headId (ctxHeadParameters ctx) utxoToCollect spendableUTxO, getKnownUTxO stInitialized <> getKnownUTxO cctx)
 
-computeDecrementCost :: IO [(NumParties, TxSize, MemUnit, CpuUnit, Coin)]
+computeDecrementCost :: Gen [(NumParties, TxSize, MemUnit, CpuUnit, Coin)]
 computeDecrementCost = do
   interesting <- catMaybes <$> mapM compute [1, 2, 3, 5, 10]
   limit <- maybeToList . getFirst <$> foldMapM (fmap First . compute) [50, 49 .. 11]
   pure $ interesting <> limit
  where
   compute numParties = do
     -- TODO: add decrementedOutputs to the result
-    (ctx, _decrementedOutputs, st, _, tx) <- generate $ genDecrementTx numParties
+    (ctx, _decrementedOutputs, st, _, tx) <- genDecrementTx numParties
     let utxo = getKnownUTxO st <> getKnownUTxO ctx
     case checkSizeAndEvaluate tx utxo of
       Just (txSize, memUnit, cpuUnit, minFee) ->
         pure $ Just (NumParties numParties, txSize, memUnit, cpuUnit, minFee)
       Nothing ->
         pure Nothing
 
-computeCloseCost :: IO [(NumParties, TxSize, MemUnit, CpuUnit, Coin)]
+computeCloseCost :: Gen [(NumParties, TxSize, MemUnit, CpuUnit, Coin)]
 computeCloseCost = do
   interesting <- catMaybes <$> mapM compute [1, 2, 3, 5, 10]
   limit <- maybeToList . getFirst <$> foldMapM (fmap First . compute) [50, 49 .. 11]
   pure $ interesting <> limit
  where
   compute numParties = do
-    (ctx, st, _, tx, _sn) <- generate $ genCloseTx numParties
+    (ctx, st, _, tx, _sn) <- genCloseTx numParties
     let utxo = getKnownUTxO st <> getKnownUTxO ctx
     case checkSizeAndEvaluate tx utxo of
       Just (txSize, memUnit, cpuUnit, minFee) ->
         pure $ Just (NumParties numParties, txSize, memUnit, cpuUnit, minFee)
       Nothing ->
         pure Nothing
 
-computeContestCost :: IO [(NumParties, TxSize, MemUnit, CpuUnit, Coin)]
+computeContestCost :: Gen [(NumParties, TxSize, MemUnit, CpuUnit, Coin)]
 computeContestCost = do
   interesting <- catMaybes <$> mapM compute [1, 2, 3, 5, 10]
   limit <- maybeToList . getFirst <$> foldMapM (fmap First . compute) [50, 49 .. 11]
   pure $ interesting <> limit
  where
   compute numParties = do
-    (tx, utxo) <- generate $ genContestTx numParties
+    (tx, utxo) <- genContestTx numParties
     case checkSizeAndEvaluate tx utxo of
       Just (txSize, memUnit, cpuUnit, minFee) ->
         pure $ Just (NumParties numParties, txSize, memUnit, cpuUnit, minFee)
@@ -192,14 +191,14 @@ computeContestCost = do
     let contestUtxo = getKnownUTxO stClosed <> getKnownUTxO cctx
     pure (unsafeContest cctx contestUtxo headId cp 0 snapshot pointInTime, contestUtxo)
 
-computeAbortCost :: IO [(NumParties, TxSize, MemUnit, CpuUnit, Coin)]
+computeAbortCost :: Gen [(NumParties, TxSize, MemUnit, CpuUnit, Coin)]
 computeAbortCost =
   -- NOTE: We can't even close with one party right now, so no point in
   -- determining interesting values
   catMaybes <$> forM [1 .. 100] compute
  where
   compute numParties = do
-    (tx, utxo) <- generate $ genAbortTx numParties
+    (tx, utxo) <- genAbortTx numParties
     case checkSizeAndEvaluate tx utxo of
       Just (txSize, memUnit, cpuUnit, minFee) -> do
         pure $ Just (NumParties numParties, txSize, memUnit, cpuUnit, minFee)
@@ -217,7 +216,7 @@ computeAbortCost =
     let spendableUTxO = getKnownUTxO stInitialized <> getKnownUTxO cctx
     pure (unsafeAbort cctx seedTxIn spendableUTxO (fold committed), spendableUTxO)
 
-computeFanOutCost :: IO [(NumParties, NumUTxO, Natural, TxSize, MemUnit, CpuUnit, Coin)]
+computeFanOutCost :: Gen [(NumParties, NumUTxO, Natural, TxSize, MemUnit, CpuUnit, Coin)]
 computeFanOutCost = do
   interesting <- catMaybes <$> mapM (uncurry compute) [(p, u) | p <- [numberOfParties], u <- [0, 1, 5, 10, 20, 30, 40, 50]]
   limit <-
@@ -231,7 +230,7 @@ computeFanOutCost = do
   numberOfParties = 10
 
   compute parties numElems = do
-    (utxo, tx, knownUTxO) <- generate $ genFanoutTx parties numElems
+    (utxo, tx, knownUTxO) <- genFanoutTx parties numElems
     let utxoSerializedSize = serializedSize utxo
     case checkSizeAndEvaluate tx knownUTxO of
       Just (txSize, memUnit, cpuUnit, minFee) ->