{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

module Test.Cardano.Ledger.Conway.Imp.BbodySpec (spec) where

import Cardano.Ledger.Alonzo.Scripts (eraLanguages)
import Cardano.Ledger.Babbage.Core
import Cardano.Ledger.BaseTypes (Mismatch (..), ProtVer (..), natVersion)
import Cardano.Ledger.Coin (Coin (..))
import Cardano.Ledger.Conway.PParams (ConwayEraPParams (..))
import Cardano.Ledger.Conway.Rules (
  ConwayBbodyPredFailure (..),
  totalRefScriptSizeInBlock,
 )
import Cardano.Ledger.Plutus (hashPlutusScript, withSLanguage)
import Cardano.Ledger.Shelley.Scripts (
  pattern RequireSignature,
 )
import Data.Foldable (for_)
import Data.List (inits)
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.Sequence.Strict as SSeq
import qualified Data.Set as Set
import Data.Traversable (for)
import Data.Word (Word32)
import Lens.Micro ((&), (.~), (^.))
import Test.Cardano.Ledger.Babbage.ImpTest
import Test.Cardano.Ledger.Conway.ImpTest (ConwayEraImp)
import Test.Cardano.Ledger.Core.Utils (txInAt)
import Test.Cardano.Ledger.Imp.Common
import Test.Cardano.Ledger.Plutus.Examples (
  alwaysFailsWithDatum,
  purposeIsWellformedNoDatum,
 )

spec ::
  forall era.
  ConwayEraImp era => SpecWith (ImpInit (LedgerSpec era))
spec :: forall era. ConwayEraImp era => SpecWith (ImpInit (LedgerSpec era))
spec = String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"BBODY" (SpecWith (ImpInit (LedgerSpec era))
 -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
  String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"BodyRefScriptsSizeTooBig" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
    lang <- [Language] -> ImpM (LedgerSpec era) Language
forall (m :: * -> *) a. MonadGen m => [a] -> m a
elements ([Language] -> ImpM (LedgerSpec era) Language)
-> [Language] -> ImpM (LedgerSpec era) Language
forall a b. (a -> b) -> a -> b
$ forall era. AlonzoEraScript era => [Language]
eraLanguages @era
    plutusScript <- withSLanguage lang $ mkPlutusScript @era . purposeIsWellformedNoDatum
    let scriptSize = PlutusScript era -> Int
forall t. SafeToHash t => t -> Int
originalBytesSize PlutusScript era
plutusScript
    pp <- getsPParams id

    -- Determine a number of transactions and a number of times the reference script
    -- needs to be included as an input in each transaction, such that:
    --  * the total exceeds the maximum allowed refScript size per block
    --  * the refScript size per individual transaction doesn't exceed maxRefScriptSizePerTx
    --  * the number of reference inputs doesn't make the transaction exceed maxTxSize
    let
      maxRefScriptSizePerTx = forall a b. (Integral a, Num b) => a -> b
fromIntegral @Word32 @Int (Word32 -> Int) -> Word32 -> Int
forall a b. (a -> b) -> a -> b
$ PParams era
pp PParams era -> Getting Word32 (PParams era) Word32 -> Word32
forall s a. s -> Getting a s a -> a
^. Getting Word32 (PParams era) Word32
forall era.
ConwayEraPParams era =>
SimpleGetter (PParams era) Word32
SimpleGetter (PParams era) Word32
ppMaxRefScriptSizePerTxG
      maxRefScriptSizePerBlock = forall a b. (Integral a, Num b) => a -> b
fromIntegral @Word32 @Int (Word32 -> Int) -> Word32 -> Int
forall a b. (a -> b) -> a -> b
$ PParams era
pp PParams era -> Getting Word32 (PParams era) Word32 -> Word32
forall s a. s -> Getting a s a -> a
^. Getting Word32 (PParams era) Word32
forall era.
ConwayEraPParams era =>
SimpleGetter (PParams era) Word32
SimpleGetter (PParams era) Word32
ppMaxRefScriptSizePerBlockG
      -- we're capping the number of scripts per transaction so that we don't exceed transaction ppMaxTxSizeL
      maxScriptsPerTx = Int
100
      maxSingle = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
maxRefScriptSizePerTx (Int
maxScriptsPerTx Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
scriptSize)

    txScriptCounts <-
      genNumAdditionsExceeding
        scriptSize
        maxSingle
        maxRefScriptSizePerBlock

    txs <- for txScriptCounts $ \Int
n -> do
      -- Instead of using the rootTxIn, we're creating an input for each transaction
      -- so that transactions that will be submitted in a block
      -- can be submitted independently from the ones that prepared the
      -- reference inputs
      txIn <- ImpM (LedgerSpec era) Addr
forall s (m :: * -> *) g.
(HasKeyPairs s, MonadState s m, HasStatefulGen g m, MonadGen m) =>
m Addr
freshKeyAddr_ ImpM (LedgerSpec era) Addr
-> (Addr -> ImpM (LedgerSpec era) TxIn)
-> ImpM (LedgerSpec era) TxIn
forall a b.
ImpM (LedgerSpec era) a
-> (a -> ImpM (LedgerSpec era) b) -> ImpM (LedgerSpec era) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Addr
addr -> Addr -> Coin -> ImpM (LedgerSpec era) TxIn
forall era.
(ShelleyEraImp era, HasCallStack) =>
Addr -> Coin -> ImpTestM era TxIn
sendCoinTo Addr
addr (Integer -> Coin
Coin Integer
100_000_000)
      refIns <- replicateM n $ produceRefScript (fromPlutusScript plutusScript)
      pure $ mkTxWithInputsAndRefInputs [txIn] refIns

    submitFailingBlock
      txs
      [ injectFailure
          ( BodyRefScriptsSizeTooBig $
              Mismatch
                { mismatchSupplied = scriptSize * sum txScriptCounts
                , mismatchExpected = maxRefScriptSizePerBlock
                }
          )
      ]

  String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"BodyRefScriptsSizeTooBig with reference scripts in the same block" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$
    forall (v :: Natural) era.
(EraGov era, KnownNat v, MinVersion <= v, v <= MaxVersion) =>
ImpTestM era () -> ImpTestM era ()
whenMajorVersionAtLeast @11 (ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ())
-> ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$ do
      lang <- [Language] -> ImpM (LedgerSpec era) Language
forall (m :: * -> *) a. MonadGen m => [a] -> m a
elements ([Language] -> ImpM (LedgerSpec era) Language)
-> [Language] -> ImpM (LedgerSpec era) Language
forall a b. (a -> b) -> a -> b
$ forall era. AlonzoEraScript era => [Language]
eraLanguages @era
      Just plutusScript <- pure $ withSLanguage lang $ \SLanguage l
slang ->
        forall era (l :: Language) (m :: * -> *).
(AlonzoEraScript era, PlutusLanguage l, MonadFail m) =>
Plutus l -> m (PlutusScript era)
mkPlutusScript @era (Plutus l -> Maybe (PlutusScript era))
-> Plutus l -> Maybe (PlutusScript era)
forall a b. (a -> b) -> a -> b
$ SLanguage l -> Plutus l
forall (l :: Language). SLanguage l -> Plutus l
purposeIsWellformedNoDatum SLanguage l
slang
      let scriptSize = PlutusScript era -> Int
forall t. SafeToHash t => t -> Int
originalBytesSize PlutusScript era
plutusScript

      pp <- getsPParams id
      let
        maxRefScriptSizePerTx = forall a b. (Integral a, Num b) => a -> b
fromIntegral @Word32 @Int (Word32 -> Int) -> Word32 -> Int
forall a b. (a -> b) -> a -> b
$ PParams era
pp PParams era -> Getting Word32 (PParams era) Word32 -> Word32
forall s a. s -> Getting a s a -> a
^. Getting Word32 (PParams era) Word32
forall era.
ConwayEraPParams era =>
SimpleGetter (PParams era) Word32
SimpleGetter (PParams era) Word32
ppMaxRefScriptSizePerTxG
        maxRefScriptSizePerBlock = forall a b. (Integral a, Num b) => a -> b
fromIntegral @Word32 @Int (Word32 -> Int) -> Word32 -> Int
forall a b. (a -> b) -> a -> b
$ PParams era
pp PParams era -> Getting Word32 (PParams era) Word32 -> Word32
forall s a. s -> Getting a s a -> a
^. Getting Word32 (PParams era) Word32
forall era.
ConwayEraPParams era =>
SimpleGetter (PParams era) Word32
SimpleGetter (PParams era) Word32
ppMaxRefScriptSizePerBlockG
        maxScriptsPerTx = Int
100
        maxSingle = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
maxRefScriptSizePerTx (Int
maxScriptsPerTx Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
scriptSize)
      txScriptCounts <-
        genNumAdditionsExceeding
          scriptSize
          maxSingle
          maxRefScriptSizePerBlock

      let
        -- These txs will be grouped into a block
        buildTxs = [Int]
-> (Int -> ImpM (LedgerSpec era) (Tx TopTx era))
-> ImpM (LedgerSpec era) ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [Int]
txScriptCounts ((Int -> ImpM (LedgerSpec era) (Tx TopTx era))
 -> ImpM (LedgerSpec era) ())
-> (Int -> ImpM (LedgerSpec era) (Tx TopTx era))
-> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$ \Int
n -> do
          refIns <- Int -> ImpM (LedgerSpec era) TxIn -> ImpM (LedgerSpec era) [TxIn]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n (ImpM (LedgerSpec era) TxIn -> ImpM (LedgerSpec era) [TxIn])
-> ImpM (LedgerSpec era) TxIn -> ImpM (LedgerSpec era) [TxIn]
forall a b. (a -> b) -> a -> b
$ Script era -> ImpM (LedgerSpec era) TxIn
forall era.
(ShelleyEraImp era, BabbageEraTxOut era) =>
Script era -> ImpTestM era TxIn
produceRefScript (PlutusScript era -> Script era
forall era. AlonzoEraScript era => PlutusScript era -> Script era
fromPlutusScript PlutusScript era
plutusScript)
          submitTx $
            mkBasicTx mkBasicTxBody
              & bodyTxL . referenceInputsTxBodyL .~ Set.fromList refIns

      withTxsInFailingBlock
        buildTxs
        [ injectFailure
            ( BodyRefScriptsSizeTooBig $
                Mismatch
                  { mismatchSupplied = scriptSize * sum txScriptCounts
                  , mismatchExpected = maxRefScriptSizePerBlock
                  }
            )
        ]

  String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"totalRefScriptSizeInBlock" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
    script <- forall era.
ShelleyEraScript era =>
KeyHash Witness -> NativeScript era
RequireSignature @era (KeyHash Witness -> NativeScript era)
-> ImpM (LedgerSpec era) (KeyHash Witness)
-> ImpM (LedgerSpec era) (NativeScript era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ImpM (LedgerSpec era) (KeyHash Witness)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
    let scriptSize = NativeScript era -> Int
forall t. SafeToHash t => t -> Int
originalBytesSize NativeScript era
script
    scriptSpendIn <- impAddNativeScript script >>= produceScript
    scriptSpendIn2 <- impAddNativeScript script >>= produceScript
    protVer <- getsPParams ppProtocolVersionL

    -- We want to verify that the total size of reference scripts in a list of transactions
    -- remains unchanged before and after applying them to the ledger state.
    -- To do this, we generate the expected transactions, simulate submitting them to obtain
    -- their individual reference script sizes, and then restore the original state -
    -- meaning the transactions are not actually applied.
    -- Finally, we check that the accumulated sizes from both before and after match.
    txsWithSizes <- simulateThenRestore $ do
      let mkTxWithExpectedSize Int
expectedSize ImpM (LedgerSpec era) (Tx TopTx era)
txAction = do
            tx <- ImpM (LedgerSpec era) (Tx TopTx era)
txAction
            totalRefScriptSizeInBlock protVer [tx] <$> getUTxO `shouldReturn` expectedSize
            pure (tx, expectedSize)

      -- submit reference scripts
      refScriptTx1 <-
        mkTxWithExpectedSize 0 $
          produceRefScriptsTx (fromNativeScript script :| [])
      let refScriptTx1In = Int -> Tx TopTx era -> TxIn
forall era (l :: TxLevel).
(HasCallStack, EraTx era) =>
Int -> Tx l era -> TxIn
txInAt Int
0 ((Tx TopTx era, Int) -> Tx TopTx era
forall a b. (a, b) -> a
fst (Tx TopTx era, Int)
refScriptTx1)
      refScriptTx2 <-
        mkTxWithExpectedSize 0 $
          produceRefScriptsTx (fromNativeScript script :| [])
      -- spend script using the reference script
      spendScriptWithRefScriptTx <-
        mkTxWithExpectedSize scriptSize $
          submitTx $
            mkTxWithInputsAndRefInputs [scriptSpendIn] [refScriptTx1In]
      -- spend using two ref inputs
      spendScriptWithTwoRefScriptsTx <-
        mkTxWithExpectedSize (2 * scriptSize) $
          submitTx $
            mkTxWithInputsAndRefInputs [scriptSpendIn2] [refScriptTx1In, txInAt 0 (fst refScriptTx2)]
      -- spend the root utxo
      rootIn <- fst <$> getImpRootTxOut
      spendRootUtxoTx <-
        mkTxWithExpectedSize scriptSize $
          submitTx $
            mkTxWithInputsAndRefInputs [rootIn] [refScriptTx1In]
      -- spend the reference script itself
      -- We must check the size without submitting the transaction,
      -- since applying it removes the reference script from the UTxO
      spendRefScriptTx <-
        mkTxWithExpectedSize scriptSize $
          fixupTx $
            mkTxWithInputsAndRefInputs [refScriptTx1In] [refScriptTx1In]

      let txsWithRefScriptSizes =
            [ (Tx TopTx era, Int)
Item [(Tx TopTx era, Int)]
refScriptTx1
            , (Tx TopTx era, Int)
Item [(Tx TopTx era, Int)]
refScriptTx2
            , (Tx TopTx era, Int)
Item [(Tx TopTx era, Int)]
spendScriptWithRefScriptTx
            , (Tx TopTx era, Int)
Item [(Tx TopTx era, Int)]
spendScriptWithTwoRefScriptsTx
            , (Tx TopTx era, Int)
Item [(Tx TopTx era, Int)]
spendRootUtxoTx
            , (Tx TopTx era, Int)
Item [(Tx TopTx era, Int)]
spendRefScriptTx
            ]

      -- check and return the accumulated reference script size of all transactions,
      -- so we can check that the same sum for the unapplied transactions matches
      let (txs, sizes) = unzip txsWithRefScriptSizes
      totalRefScriptSizeInBlock protVer (SSeq.fromList txs) <$> getUTxO `shouldReturn` sum sizes

      pure txsWithRefScriptSizes

    -- for each prefix of the list, the accumulated sum should match the sum of the applied transactions
    for_ (drop 1 $ inits txsWithSizes) $ \[(Tx TopTx era, Int)]
prefix -> do
      let ([Tx TopTx era]
txs, [Int]
sizes) = [(Tx TopTx era, Int)] -> ([Tx TopTx era], [Int])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Tx TopTx era, Int)]
prefix
          expectedSize :: Int
expectedSize = if ProtVer -> Bool
isPostV10 ProtVer
protVer then [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Int]
sizes else Int
0
      ProtVer -> StrictSeq (Tx TopTx era) -> UTxO era -> Int
forall era.
(AlonzoEraTx era, BabbageEraTxBody era) =>
ProtVer -> StrictSeq (Tx TopTx era) -> UTxO era -> Int
totalRefScriptSizeInBlock ProtVer
protVer ([Tx TopTx era] -> StrictSeq (Tx TopTx era)
forall a. [a] -> StrictSeq a
SSeq.fromList [Tx TopTx era]
txs) (UTxO era -> Int)
-> ImpM (LedgerSpec era) (UTxO era) -> ImpM (LedgerSpec era) Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ImpM (LedgerSpec era) (UTxO era)
forall era. ImpTestM era (UTxO era)
getUTxO ImpM (LedgerSpec era) Int -> Int -> ImpM (LedgerSpec era) ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
m a -> a -> m ()
`shouldReturn` Int
expectedSize

  -- disabled in conformance because submiting phase2-invalid transactions are not supported atm
  -- https://github.com/IntersectMBO/formal-ledger-specifications/issues/910
  -- TODO: Re-enable after issue is resolved, by removing this override
  String
-> ImpM (LedgerSpec era) () -> SpecWith (ImpInit (LedgerSpec era))
forall era.
ShelleyEraImp era =>
String -> ImpTestM era () -> SpecWith (ImpInit (LedgerSpec era))
disableInConformanceIt String
"Use a reference script in a collateral output" (ImpM (LedgerSpec era) () -> SpecWith (ImpInit (LedgerSpec era)))
-> ImpM (LedgerSpec era) () -> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
    protVer <- Lens' (PParams era) ProtVer -> ImpTestM era ProtVer
forall era a. EraGov era => Lens' (PParams era) a -> ImpTestM era a
getsPParams (ProtVer -> f ProtVer) -> PParams era -> f (PParams era)
forall era. EraPParams era => Lens' (PParams era) ProtVer
Lens' (PParams era) ProtVer
ppProtocolVersionL

    -- produce an utxo with a failing script
    lang <- elements $ eraLanguages @era
    failingPlutusTxIn <- withSLanguage lang $ \SLanguage l
slang -> do
      let plutus :: Plutus l
plutus = SLanguage l -> Plutus l
forall (l :: Language). SLanguage l -> Plutus l
alwaysFailsWithDatum SLanguage l
slang
      ScriptHash -> ImpM (LedgerSpec era) TxIn
forall era.
(ShelleyEraImp era, HasCallStack) =>
ScriptHash -> ImpTestM era TxIn
produceScript (ScriptHash -> ImpM (LedgerSpec era) TxIn)
-> ScriptHash -> ImpM (LedgerSpec era) TxIn
forall a b. (a -> b) -> a -> b
$ Plutus l -> ScriptHash
forall (l :: Language). PlutusLanguage l => Plutus l -> ScriptHash
hashPlutusScript Plutus l
plutus

    -- produce a utxo with a succeeding script
    script <- RequireSignature @era <$> freshKeyHash
    scriptTxIn <- impAddNativeScript script >>= produceScript
    let scriptSize = NativeScript era -> Int
forall t. SafeToHash t => t -> Int
originalBytesSize NativeScript era
script

    -- prepare a txout with the succeeding script as reference script
    ProtVer pv _ <- getProtVer
    collRefScriptTxOut <- do
      addr <-
        if pv < natVersion @12
          then freshKeyAddr_
          else freshKeyAddrNoPtr_
      pure $ mkBasicTxOut addr mempty & referenceScriptTxOutL .~ pure (fromNativeScript script)

    txs <- simulateThenRestore $ do
      -- submit an invalid transaction which attempts to consume the failing script
      -- and specifies as collateral return the txout with reference script
      createCollateralTx <-
        submitPhase2Invalid $
          mkBasicTx
            ( mkBasicTxBody
                & inputsTxBodyL .~ [failingPlutusTxIn]
                & collateralReturnTxBodyL .~ pure collRefScriptTxOut
            )
      totalRefScriptSizeInBlock protVer [createCollateralTx] <$> getUTxO `shouldReturn` 0

      -- consume the script, passing the output from the previous collateral as reference input
      let refScriptTxIn = Int -> Tx TopTx era -> TxIn
forall era (l :: TxLevel).
(HasCallStack, EraTx era) =>
Int -> Tx l era -> TxIn
txInAt Int
1 Tx TopTx era
createCollateralTx
      useCollateralTx <- submitTx $ mkTxWithInputsAndRefInputs [scriptTxIn] [refScriptTxIn]
      totalRefScriptSizeInBlock protVer [createCollateralTx, useCollateralTx]
        <$> getUTxO `shouldReturn` scriptSize
      pure [createCollateralTx, useCollateralTx]

    totalRefScriptSizeInBlock protVer (SSeq.fromList txs)
      <$> getUTxO
        `shouldReturn` (if isPostV10 protVer then scriptSize else 0)
  where
    isPostV10 :: ProtVer -> Bool
isPostV10 ProtVer
protVer = ProtVer -> Version
pvMajor ProtVer
protVer Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
>= forall (v :: Natural).
(KnownNat v, MinVersion <= v, v <= MaxVersion) =>
Version
natVersion @11

-- Generate a list of integers such that the sum of their multiples by scale is greater than toExceed
-- and each individual value multiplied by the scale is smaller than maxSingle
genNumAdditionsExceeding :: Int -> Int -> Int -> ImpTestM era [Int]
genNumAdditionsExceeding :: forall era. Int -> Int -> Int -> ImpTestM era [Int]
genNumAdditionsExceeding Int
sc Int
maxSingle Int
toExceed = Int -> [Int] -> ImpM (LedgerSpec era) [Int]
forall {m :: * -> *}. MonadGen m => Int -> [Int] -> m [Int]
go Int
0 []
  where
    go :: Int -> [Int] -> m [Int]
go Int
tot ![Int]
acc
      | Int
tot Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
toExceed = [Int] -> m [Int]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Int] -> m [Int]) -> [Int] -> m [Int]
forall a b. (a -> b) -> a -> b
$ [Int] -> [Int]
forall a. [a] -> [a]
reverse [Int]
acc
      | Bool
otherwise = do
          x <- (Int, Int) -> m Int
forall a. Random a => (a, a) -> m a
forall (g :: * -> *) a. (MonadGen g, Random a) => (a, a) -> g a
choose (Int
1, Int -> Int -> Int
forall a. Ord a => a -> a -> a
min (Int
toExceed Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
sc) (Int
maxSingle Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
sc))
          let !newTot = Int
tot Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
sc
          go newTot (x : acc)