diff --git a/plutus-core/plutus-core.cabal b/plutus-core/plutus-core.cabal index c8821547feb..4520d49083a 100644 --- a/plutus-core/plutus-core.cabal +++ b/plutus-core/plutus-core.cabal @@ -711,6 +711,7 @@ library plutus-core-testlib PlutusCore.Generators.QuickCheck.GenerateTypes PlutusCore.Generators.QuickCheck.GenTm PlutusCore.Generators.QuickCheck.ShrinkTypes + PlutusCore.Generators.QuickCheck.Split PlutusCore.Generators.QuickCheck.Substitutions PlutusCore.Generators.QuickCheck.Unification PlutusCore.Generators.QuickCheck.Utils diff --git a/plutus-core/plutus-core/test/Generators/QuickCheck/Utils.hs b/plutus-core/plutus-core/test/Generators/QuickCheck/Utils.hs index 45ed4d7cc96..95d50209ec2 100644 --- a/plutus-core/plutus-core/test/Generators/QuickCheck/Utils.hs +++ b/plutus-core/plutus-core/test/Generators/QuickCheck/Utils.hs @@ -2,32 +2,55 @@ module Generators.QuickCheck.Utils where +import PlutusPrelude + +import PlutusCore.Data +import PlutusCore.Generators.QuickCheck.Builtin import PlutusCore.Generators.QuickCheck.Utils -import Data.Coerce import Test.Tasty import Test.Tasty.QuickCheck --- | Test that both 'multiSplit1' and 'multiSplit' produce a list such that 'concat'ing it gives +-- | Test that both 'multiSplit1' and 'multiSplit0' produce a list such that 'concat'ing it gives -- back the input. test_multiSplitSound :: TestTree test_multiSplitSound = testGroup "soundness" $ do (name, split) <- [ ("multiSplit1", coerce $ multiSplit1 @Int) - , ("multiSplit", multiSplit 0.1) + , ("multiSplit0", multiSplit0 0.1) ] pure . testProperty name $ \(xs :: [Int]) -> withMaxSuccess 10000 . forAll (split xs) $ \aSplit -> xs === concat aSplit --- | Show the distribution of lists generated by 'multiSplit' for a list of the given length. +-- | Show the distribution of lists generated by a split function for a list of the given length. test_listDistribution :: Int -> ([()] -> Gen [[()]]) -> Int -> TestTree test_listDistribution numRuns split n = testProperty ("for a list of length " ++ show n) $ withMaxSuccess numRuns . forAll (split $ replicate n ()) $ \aSplit -> label (show $ map length aSplit) True +-- | Count the number of 'I' and 'B' nodes in a 'Data' object. +countIandBs :: Data -> Int +countIandBs = go 0 where + go :: Int -> Data -> Int + go acc (Constr _ ds) = foldl' go acc ds + go acc (Map ps) = foldl' (\acc' (d1, d2) -> go (go acc' d1) d2) acc ps + go acc (List ds) = foldl' go acc ds + go acc (I _) = acc + 1 + go acc (B _) = acc + 1 + +-- | Test the number of 'I' and 'B' nodes in a 'Data' generated from a @spine :: [()]@ equals the +-- length of the spine. Ensures that the 'Data' generator is not exponential in 'B' and 'I' nodes +-- (exponentiality in other nodes will not get caught by this test). +test_arbitraryDataExpectedLeafs :: TestTree +test_arbitraryDataExpectedLeafs = + testProperty "'arbitrary @Data' has the expected number of 'B' and 'I' leaves" $ + withMaxSuccess 1000 . mapSize (* 5) $ \spine -> + forAll (genDataFromSpine spine) $ \dat -> + countIandBs dat === length spine + test_multiSplitDistribution :: TestTree test_multiSplitDistribution = testGroup "distribution of values generated by" @@ -38,15 +61,16 @@ test_multiSplitDistribution = , test_listDistribution 10000 (coerce $ multiSplit1 @()) 4 , test_listDistribution 10000 (coerce $ multiSplit1 @()) 5 ] - , testGroup "multiSplit" - [ test_listDistribution 1000 (multiSplit 0.1) 1 - , test_listDistribution 1000 (multiSplit 0.05) 2 - , test_listDistribution 1000 (multiSplit 0.01) 3 + , testGroup "multiSplit0" + [ test_listDistribution 1000 (multiSplit0 0.1) 1 + , test_listDistribution 1000 (multiSplit0 0.05) 2 + , test_listDistribution 1000 (multiSplit0 0.01) 3 ] ] test_utils :: TestTree test_utils = testGroup "utils" - [ test_multiSplitSound + [ test_arbitraryDataExpectedLeafs + , test_multiSplitSound , test_multiSplitDistribution ] diff --git a/plutus-core/plutus-ir/test/PlutusCore/Generators/QuickCheck/BuiltinsTests.hs b/plutus-core/plutus-ir/test/PlutusCore/Generators/QuickCheck/BuiltinsTests.hs index bbee5bce61b..7b610dd3285 100644 --- a/plutus-core/plutus-ir/test/PlutusCore/Generators/QuickCheck/BuiltinsTests.hs +++ b/plutus-core/plutus-ir/test/PlutusCore/Generators/QuickCheck/BuiltinsTests.hs @@ -2,12 +2,11 @@ module PlutusCore.Generators.QuickCheck.BuiltinsTests where import PlutusCore.Data -import PlutusCore.Generators.QuickCheck +import PlutusCore.Generators.QuickCheck () import Codec.Serialise import Test.QuickCheck -- | This mainly tests that the `Data` generator isn't non-terminating or too slow. prop_genData :: Property -prop_genData = withMaxSuccess 3000 $ forAll arbitrary $ \(d :: Data) -> - d == deserialise (serialise d) +prop_genData = withMaxSuccess 3000 $ \(d :: Data) -> d === deserialise (serialise d) diff --git a/plutus-core/testlib/PlutusCore/Generators/QuickCheck/Builtin.hs b/plutus-core/testlib/PlutusCore/Generators/QuickCheck/Builtin.hs index c001c29e3a0..2179cc30880 100644 --- a/plutus-core/testlib/PlutusCore/Generators/QuickCheck/Builtin.hs +++ b/plutus-core/testlib/PlutusCore/Generators/QuickCheck/Builtin.hs @@ -10,16 +10,17 @@ module PlutusCore.Generators.QuickCheck.Builtin where +import PlutusPrelude + import PlutusCore hiding (Constr) import PlutusCore.Builtin import PlutusCore.Crypto.BLS12_381.G1 qualified as BLS12_381.G1 import PlutusCore.Crypto.BLS12_381.G2 qualified as BLS12_381.G2 import PlutusCore.Crypto.BLS12_381.Pairing qualified as BLS12_381.Pairing import PlutusCore.Data -import PlutusCore.Generators.QuickCheck.Common (genList) +import PlutusCore.Generators.QuickCheck.Split (multiSplit0, multiSplit1, multiSplit1In) import Data.ByteString (ByteString, empty) -import Data.Coerce import Data.Int import Data.Kind qualified as GHC import Data.Maybe @@ -27,51 +28,10 @@ import Data.Proxy import Data.Text (Text) import Data.Text qualified as Text import Data.Text.Encoding qualified as Text -import Data.Word import Test.QuickCheck import Test.QuickCheck.Instances.ByteString () import Universe -instance Arbitrary Data where - arbitrary = sized genData - shrink = genericShrink - -genData :: Int -> Gen Data -genData depth = - oneof $ - [genI, genB] - <> [ genRec | depth > 1, genRec <- - [ genListData (depth `div` 2) - , genMapData (depth `div` 2) - , genConstrData (depth `div` 2) - ] - ] - where - genI = I <$> arbitraryBuiltin - genB = B <$> arbitraryBuiltin - -genListWithMaxDepth :: Int -> (Int -> Gen a) -> Gen [a] -genListWithMaxDepth depth gen = - -- The longer the list, the smaller the elements. - frequency - [ (100, genList 0 5 (gen depth)) - , (10, genList 0 50 (gen (depth `div` 2))) - , (1, genList 0 500 (gen (depth `div` 4))) - ] - -genListData :: Int -> Gen Data -genListData depth = List <$> genListWithMaxDepth depth genData - -genMapData :: Int -> Gen Data -genMapData depth = - Map <$> genListWithMaxDepth depth (\d -> (,) <$> genData d <*> genData d) - -genConstrData :: Int -> Gen Data -genConstrData depth = - Constr - <$> (fromIntegral <$> arbitrary @Word64) - <*> genListWithMaxDepth depth genData - -- | Same as 'Arbitrary' but specifically for Plutus built-in types, so that we are not tied to -- the default implementation of the methods for a built-in type. class ArbitraryBuiltin a where @@ -106,12 +66,63 @@ instance for 'Int64' does: For this reason we use 'Int64' when dealing with QuickCheck. -} +-- | A list of ranges: @[(0, 10), (11, 100), (101, 1000), ... (10^n + 1, high)]@ when +-- @base = 10@. +magnitudesPositive :: Integral a => a -> a -> [(a, a)] +magnitudesPositive base high = + zipWith (\lo hi -> (lo + 1, hi)) borders (tail borders) + where + preborders = tail . takeWhile (< high `div` base) $ iterate (* base) 1 + borders = -1 : preborders ++ [last preborders * base, high] + +-- | Like 'chooseBoundedIntegral', but doesn't require the 'Bounded' constraint (and hence is slower +-- for 'Word64' and 'Int64'). +chooseIntegral :: Integral a => (a, a) -> Gen a +chooseIntegral (lo, hi) = fromInteger <$> chooseInteger (toInteger lo, toInteger hi) + +-- | Generate asymptotically greater positive numbers with exponentially lower chance. +arbitraryPositive :: Integral a => a -> a -> Gen a +arbitraryPositive base high = + frequency . zip freqs . reverse . map chooseIntegral $ magnitudesPositive base high + where + freqs = map floor $ iterate (* 1.3) (2 :: Double) + +-- | Generate asymptotically greater negative numbers with exponentially lower chance. +arbitraryNegative :: Integral a => a -> a -> Gen a +arbitraryNegative base high = negate <$> arbitraryPositive base high + +-- | Generate asymptotically greater numbers with exponentially lower chance. +arbitrarySigned :: Integral a => a -> a -> Gen a +arbitrarySigned base high = oneof [arbitraryPositive base high, arbitraryNegative base high] + +-- | Same as 'shrinkIntegral' except includes the square root of the given number (or of its +-- negative if the number is negative, in which case the square root is negated too). We need the +-- former because 'shrinkIntegral' at most divides the number by two, which makes the number smaller +-- way too slow, hence we add square root to speed up the process. +-- +-- >>> shrinkIntegralFast (0 :: Integer) +-- [] +-- >>> shrinkIntegralFast (1 :: Integer) +-- [0] +-- >>> shrinkIntegralFast (9 :: Integer) +-- [0,3,5,7,8] +-- >>> shrinkIntegralFast (-10000 :: Integer) +-- [0,10000,-100,-5000,-7500,-8750,-9375,-9688,-9844,-9922,-9961,-9981,-9991,-9996,-9998,-9999] +shrinkIntegralFast :: Integral a => a -> [a] +shrinkIntegralFast x = concat + [ [0 | x /= 0] + , [-x | x < 0] + , [signum x * floor (sqrt @Double $ fromIntegral xA) | let xA = abs x, xA > 4] + , drop 1 . map (x -) . takeWhile (/= 0) $ iterate (`quot` 2) x + ] + instance ArbitraryBuiltin Integer where arbitraryBuiltin = frequency [ (4, arbitrary @Integer) -- See Note [QuickCheck and integral types]. - , (1, fromIntegral <$> arbitrary @Int64) + , (1, fromIntegral <$> arbitrarySigned 10 (maxBound :: Int64)) ] + shrinkBuiltin = shrinkIntegralFast -- | -- @@ -125,6 +136,63 @@ instance ArbitraryBuiltin ByteString where arbitraryBuiltin = Text.encodeUtf8 <$> arbitraryBuiltin shrinkBuiltin = map Text.encodeUtf8 . shrinkBuiltin . Text.decodeUtf8 +-- | Generate a tag for the 'Constr' constructor. +genConstrTag :: Gen Integer +genConstrTag = frequency + [ -- We want to generate most plausible constructor IDs most often. + (6, chooseInteger (0, 2)) + , -- Less plausible -- less often. + (3, chooseInteger (3, 5)) + , -- And some meaningless garbage occasionally just to have good coverage. + (1, abs <$> arbitraryBuiltin) + ] + +-- | Generate a 'Data' object using a @spine :: [()]@ as a hint. It's helpful to make the spine a +-- list of units rather than a 'Word' or something, because we have useful functions for arbitrary +-- list splitting. +genDataFromSpine :: [()] -> Gen Data +genDataFromSpine [] = + oneof + [ Constr <$> genConstrTag <*> pure [] + , pure $ List [] + , pure $ Map [] + ] +genDataFromSpine [()] = oneof [I <$> arbitraryBuiltin, B <$> arbitraryBuiltin] +genDataFromSpine els = oneof + [ Constr <$> genConstrTag <*> (multiSplit0 0.1 els >>= traverse genDataFromSpine) + , List <$> (multiSplit0 0.1 els >>= traverse genDataFromSpine) + , do + elss <- multiSplit1 els + Map <$> frequency + [ -- Generate maps from 'ByteString's most often. + (6, for elss $ \(NonEmpty els') -> + (,) . B <$> arbitraryBuiltin <*> genDataFromSpine (drop 1 els')) + , -- Generate maps from 'Integer's less often. + (3, for elss $ \(NonEmpty els') -> + (,) . I <$> arbitraryBuiltin <*> genDataFromSpine (drop 1 els')) + , -- Occasionally generate maps with random nonsense in place of keys. + (1, for elss $ \(NonEmpty els') -> do + splitRes <- multiSplit1In 2 els' + case splitRes of + [] -> + (,) <$> genDataFromSpine [] <*> genDataFromSpine [] + [NonEmpty elsL'] -> + (,) <$> genDataFromSpine elsL' <*> genDataFromSpine [] + [NonEmpty elsL', NonEmpty elsR'] -> + (,) <$> genDataFromSpine elsL' <*> genDataFromSpine elsR' + _ -> error "Panic: 'multiSplit1In 2' returned a list longer than 2 elements") + ] + ] + +instance Arbitrary Data where + arbitrary = arbitrary >>= genDataFromSpine + + shrink (Constr i ds) = ds ++ map (Constr i) (shrink ds) + shrink (Map ps) = map fst ps ++ map snd ps ++ map Map (shrink ps) + shrink (List ds) = ds ++ map List (shrink ds) + shrink (I i) = map I (shrink i) + shrink (B b) = I 0 : map B (shrink b) + instance ArbitraryBuiltin BLS12_381.G1.Element where arbitraryBuiltin = BLS12_381.G1.hashToGroup <$> arbitrary <*> pure Data.ByteString.empty >>= \case @@ -168,11 +236,20 @@ instance ArbitraryBuiltin a => Arbitrary (AsArbitraryBuiltin a) where -- We could do this and the next one generically using 'ElaborateBuiltin', but it would be more -- code, so we keep it simple. instance ArbitraryBuiltin a => ArbitraryBuiltin [a] where - arbitraryBuiltin = coerce $ arbitrary @[AsArbitraryBuiltin a] + arbitraryBuiltin = do + spine <- arbitrary + let len = length spine + for spine $ \() -> + -- Scale the elements, so that generating a list of lists of lists doesn't take + -- exponential size (and thus time). + scale (`div` len) . coerce $ arbitrary @(AsArbitraryBuiltin a) shrinkBuiltin = coerce $ shrink @[AsArbitraryBuiltin a] instance (ArbitraryBuiltin a, ArbitraryBuiltin b) => ArbitraryBuiltin (a, b) where - arbitraryBuiltin = coerce $ arbitrary @(AsArbitraryBuiltin a, AsArbitraryBuiltin b) + arbitraryBuiltin = do + (,) + <$> coerce (scale (`div` 2) $ arbitrary @(AsArbitraryBuiltin a)) + <*> coerce (scale (`div` 2) $ arbitrary @(AsArbitraryBuiltin b)) shrinkBuiltin = coerce $ shrink @(AsArbitraryBuiltin a, AsArbitraryBuiltin b) -- | Either a fail to generate anything or a built-in type of a given kind. @@ -194,8 +271,12 @@ eraseMaybeSomeTypeOf (JustSomeType uni) = Just $ SomeTypeIn uni -- | Generate a 'DefaultUniApply' if possible. genDefaultUniApply :: KnownKind k => Gen (MaybeSomeTypeOf k) genDefaultUniApply = do - mayFun <- scale (`div` 2) arbitrary - mayArg <- scale (`div` 2) arbitrary :: Gen (MaybeSomeTypeOf GHC.Type) + -- We don't scale the function, because sizes don't matter for application heads anyway, plus + -- the function may itself be an application and we certainly don't want type arguments that + -- come first to be smaller than those that come latter as that would make no sense. + mayFun <- arbitrary + -- We don't want to generate deeply nested built-in types, hence the scaling. + mayArg <- scale (`div` 5) arbitrary :: Gen (MaybeSomeTypeOf GHC.Type) pure $ case (mayFun, mayArg) of (JustSomeType fun, JustSomeType arg) -> JustSomeType $ fun `DefaultUniApply` arg _ -> NothingSomeType diff --git a/plutus-core/testlib/PlutusCore/Generators/QuickCheck/Split.hs b/plutus-core/testlib/PlutusCore/Generators/QuickCheck/Split.hs new file mode 100644 index 00000000000..c42aa71189f --- /dev/null +++ b/plutus-core/testlib/PlutusCore/Generators/QuickCheck/Split.hs @@ -0,0 +1,199 @@ +{-# LANGUAGE TypeApplications #-} + +module PlutusCore.Generators.QuickCheck.Split where + +import Control.Monad +import Data.Bifunctor +import Data.Coerce (coerce) +import Data.List (sortBy) +import Data.Ord (comparing) +import Test.QuickCheck + +-- | Up to what length a list is considered \"short\". +smallLength :: Int +smallLength = 6 + +-- | Generate a sublist of the given size of the given list. Preserves the order of elements. +sublistN :: Int -> [a] -> Gen [a] +sublistN lenRes + = fmap (map snd . sortBy (comparing fst) . take lenRes) + . shuffle + . zip [0 :: Int ..] + +-- | Calculate the maximum number of chunks to split a list of the given list into. +toMaxChunkNumber :: Int -> Int +toMaxChunkNumber len + -- For short lists we take the maximum number of chunks to be the length of the list, + -- i.e. the maximum number of chunks grows at a maximum speed for short lists. + | len <= smallLength = len + -- For longer lists the maximum number of chunks grows slower. We don't really want to split a + -- 50-element list into each of 1..50 number of chunks. + | len <= smallLength ^ (2 :: Int) = smallLength + len `div` smallLength + -- For long lists it grows even slower. + | otherwise = smallLength + round @Double (sqrt $ fromIntegral len) + +-- | Calculate the number of ways to divide a list of length @len@ into @chunkNum@ chunks. +-- Equals to @C(len - 1, chunksNum - 1)@. +toChunkNumber :: Int -> Int -> Int +toChunkNumber len chunkNum = + product [len - 1, len - 2 .. len - chunkNum + 1] `div` + product [chunkNum - 1, chunkNum - 2 .. 2] + +-- | Return a list of pairs, each of which consists of +-- +-- 1. the frequency at which a chunk length needs to be picked by the generation machinery +-- 2. the chunk length itself +-- +-- >>> toChunkFrequencies (-1) +-- [] +-- >>> toChunkFrequencies 0 +-- [] +-- >>> toChunkFrequencies 1 +-- [(1,1)] +-- >>> toChunkFrequencies 5 +-- [(1,1),(4,2),(6,3),(4,4),(1,5)] +-- >>> toChunkFrequencies 10 +-- [(3,1),(6,2),(9,3),(12,4),(15,5),(18,6),(21,7)] +-- >>> toChunkFrequencies 50 +-- [(3,1),(4,2),(5,3),(6,4),(7,5),(8,6),(9,7),(10,8),(11,9),(12,10),(13,11),(14,12),(15,13)] +toChunkFrequencies :: Int -> [(Int, Int)] +toChunkFrequencies len + -- For short lists we calculate exact chunk numbers and use those as frequencies in order to get + -- uniform distribution of list lengths (which does not lead to uniform distribution of lengths + -- of subtrees, since subtrees with small total count of elements get generated much more often + -- than those with a big total count of elements, particularly because the latter contain the + -- former). + | len <= smallLength = map (\num -> (toChunkNumber len num, num)) chunks + | otherwise = + let -- The probability of "splitting" a list into a single sublist (i.e. simply 'pure') is + -- about 3%. + singleElemProb = 3 + -- Computing @delta@ in order for each subsequent chunk length to get picked a bit more + -- likely, so that we generate longer forests more often when we can. For not-too-long + -- lists the frequencies add up to roughly 100. For long lists the sum of frequencies + -- can be significantly greater than 100 making the chance of generating a single + -- sublist less than 3%. + deltaN = chunkMax * (chunkMax - 1) `div` 2 + delta = max 1 $ (100 - chunkMax * singleElemProb) `div` deltaN + in zip (iterate (+ delta) singleElemProb) chunks + where + chunkMax = toMaxChunkNumber len + chunks = [1 .. chunkMax] + +-- | Split the given list in chunks. The length of each chunk, apart from the final one, is taken +-- from the first argument. +-- +-- >>> toChunks [3, 1] "abcdef" +-- ["abc","d","ef"] +toChunks :: [Int] -> [a] -> [[a]] +toChunks [] xs = [xs] +toChunks (n : ns) xs = chunk : toChunks ns xs' where + (chunk, xs') = splitAt n xs + +-- | Split a list into the given number of chunks. Concatenating the resulting lists gives back the +-- original one. Doesn't generate empty chunks. +multiSplit1In :: Int -> [a] -> Gen [NonEmptyList a] +multiSplit1In _ [] = pure [] +multiSplit1In chunkNum xs = do + let len = length xs + -- Pick a list of breakpoints. + breakpoints <- sublistN (chunkNum - 1) [1 .. len - 1] + -- Turn the list of breakpoints into a list of chunk lengths. + let chunkLens = zipWith (-) breakpoints (0 : breakpoints) + -- Chop the argument into chunks according to the list of chunk lengths. + pure . coerce $ toChunks chunkLens xs + +-- | Split a list into chunks at random. Concatenating the resulting lists gives back the original +-- one. Doesn't generate empty chunks. +multiSplit1 :: [a] -> Gen [NonEmptyList a] +multiSplit1 xs = do + -- Pick a number of chunks. + chunkNum <- frequency . map (fmap pure) . toChunkFrequencies $ length xs + multiSplit1In chunkNum xs + +-- | Return the left and the right halves of the given list. The first argument controls whether +-- the middle element of a list having an odd length goes into the left half or the right one. +-- +-- >>> halve True [1 :: Int] +-- ([1],[]) +-- >>> halve True [1, 2 :: Int] +-- ([1],[2]) +-- >>> halve True [1, 2, 3 :: Int] +-- ([1,2],[3]) +-- >>> halve False [1 :: Int] +-- ([],[1]) +-- >>> halve False [1, 2 :: Int] +-- ([1],[2]) +-- >>> halve False [1, 2, 3 :: Int] +-- ([1],[2,3]) +halve :: Bool -> [a] -> ([a], [a]) +halve isOddToLeft xs0 = go xs0 xs0 where + go (_ : _ : xsFast) (x : xsSlow) = first (x :) $ go xsFast xsSlow + go [_] (x : xsSlow) | isOddToLeft = ([x], xsSlow) + go _ xsSlow = ([], xsSlow) + +-- | Insert a value into a list an arbitrary number of times. The first argument controls whether +-- to allow inserting at the beginning of the list, the second argument is the probability of +-- inserting an element at the end of the list. +insertManyPreferRight :: forall a. Bool -> Double -> a -> [a] -> Gen [a] +insertManyPreferRight keepPrefix lastProb y xs0 = go keepPrefix initWeight xs0 where + -- The weight of the "insert @y@ operation" operation at the beginning of the list. + initWeight = 10 + -- How more likely we're to insert an element when moving one element forward in the list. + -- Should we make it dependent on the length of the list? Maybe it's fine. + scaling = 1.1 + -- The weight of the "insert @y@ operation" operation at the end of the list. + topWeight = scaling ** fromIntegral (length xs0) * initWeight + -- The weight of the "do nothing" operation. + noopWeight = floor $ topWeight * (1 / lastProb - 1) + + go :: Bool -> Double -> [a] -> Gen [a] + go keep weight xs = do + doCons <- frequency [(floor weight, pure True), (noopWeight, pure False)] + if doCons + -- If we don't want to insert elements into the head of the list, then we simply ignore + -- the generated one and carry on. Ugly, but works. + then ([y | keep] ++) <$> go keep weight xs + else case xs of + [] -> pure [] + x : xs' -> (x :) <$> go True (weight * scaling) xs' + +-- | Insert a value into a list an arbitrary number of times. The first argument controls whether +-- to allow inserting at the end of the list, the second argument is the probability of +-- inserting an element at the beginning of the list. +insertManyPreferLeft :: Bool -> Double -> a -> [a] -> Gen [a] +insertManyPreferLeft keepSuffix headProb y = + fmap reverse . insertManyPreferRight keepSuffix headProb y . reverse + +-- | Insert a value into a list an arbitrary number of times. The first argument is the probability +-- of inserting an element at an end of the list (i.e. either the beginning or the end, not +-- combined). See 'multiSplit1' for what this function allows us to do. +insertManyPreferEnds :: Double -> a -> [a] -> Gen [a] +-- Cut the list in half, insert into the left half skewing generation towards the beginning, insert +-- into the right half skewing generation towards the end, then append the results of those two +-- operations, so that we get a list where additional elements are more likely to occur close to +-- the sides. +insertManyPreferEnds endProb y xs = do + -- In order not to get skewed results we sometimes put the middle element of the list into its + -- first half and sometimes into its second half. + isOddToLeft <- arbitrary + let (xsL, xsR) = halve isOddToLeft xs + -- If the list has even length, then it was cut into two halves of equal length meaning one slot + -- for to put an element in appears twice: at the end of the left half and at the beginning of + -- the right one. Hence in order to avoid skeweness we don't put anything into this slot at the + -- end of the left half. + -- Maybe we do want to skew generation to favor the middle of the list like we do for its ends, + -- but then we need to do that intentionally and systematically, not randomly and a little bit. + xsL' <- insertManyPreferLeft (length xsL /= length xsR) endProb y xsL + xsR' <- insertManyPreferRight True endProb y xsR + pure $ xsL' ++ xsR' + +-- | Split a list into chunks at random. Concatenating the resulting lists gives back the original +-- one. Generates empty chunks. The first argument is the probability of generating at least one +-- empty chunk as the first element of the resulting list. It is also the probability of generating +-- an empty chunk as the last element of the resulting list. The probability of generating empty +-- chunks decreases as we go from either of the ends of the resulting list (this is so that we are +-- more likely to hit a corner case related to handling elements at the beginning or the end of a +-- list). +multiSplit0 :: Double -> [a] -> Gen [[a]] +multiSplit0 endProb = multiSplit1 >=> insertManyPreferEnds endProb [] . coerce diff --git a/plutus-core/testlib/PlutusCore/Generators/QuickCheck/Utils.hs b/plutus-core/testlib/PlutusCore/Generators/QuickCheck/Utils.hs index 82f91f18cf4..76b7de4f7f5 100644 --- a/plutus-core/testlib/PlutusCore/Generators/QuickCheck/Utils.hs +++ b/plutus-core/testlib/PlutusCore/Generators/QuickCheck/Utils.hs @@ -1,10 +1,13 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} -module PlutusCore.Generators.QuickCheck.Utils where +module PlutusCore.Generators.QuickCheck.Utils + ( module PlutusCore.Generators.QuickCheck.Utils + , module Export + ) where import PlutusCore.Default +import PlutusCore.Generators.QuickCheck.Split as Export import PlutusCore.MkPlc hiding (error) import PlutusCore.Name import PlutusCore.Pretty @@ -14,11 +17,7 @@ import PlutusIR.Compiler.Datatype import PlutusIR.Core.Instance.Pretty.Readable import PlutusIR.Subst -import Control.Monad -import Data.Bifunctor -import Data.Coerce (coerce) import Data.Kind qualified as GHC -import Data.List (sort) import Data.List.NonEmpty (NonEmpty (..)) import Data.Set (Set) import Data.Set qualified as Set @@ -27,6 +26,16 @@ import Data.String import Prettyprinter import Test.QuickCheck +-- | Generate a list of the given length, all arguments of which are distinct. Takes O(n^2) time +-- or more if the generator is likely to generate equal values. +uniqueVectorOf :: Eq a => Int -> Gen a -> Gen [a] +uniqueVectorOf i0 genX = go [] i0 where + go acc i + | i <= 0 = pure acc + | otherwise = do + x <- genX `suchThat` (`notElem` acc) + go (x : acc) (i - 1) + -- | Show a `Doc` when a property fails. ceDoc :: Testable t => Doc ann -> t -> Property ceDoc d = counterexample (render d) @@ -128,182 +137,3 @@ matchType d@(Datatype _ (TyVarDecl _ a _) xs m cs) = (m, destrTy) mconcat [setOf ftvTy ty | VarDecl _ _ ty <- cs] maxUsed = maxUsedUnique fvs destrTy = runQuote $ markNonFresh maxUsed >> mkDestructorTy d - --- | Generate a list of the given length, all arguments of which are distinct. Takes O(n^2) time. -uniqueVectorOf :: Eq a => Int -> Gen a -> Gen [a] -uniqueVectorOf i0 genX = go [] i0 where - go acc i - | i <= 0 = pure acc - | otherwise = do - x <- genX `suchThat` (`notElem` acc) - go (x : acc) (i - 1) - --- | Up to what length a list is considered \"short\". -smallLength :: Int -smallLength = 6 - --- | Calculate the maximum number of chunks to split a list of the given list into. -toMaxChunkNumber :: Int -> Int -toMaxChunkNumber len - -- For short lists we take the maximum number of chunks to be the length of the list, - -- i.e. the maximum number of chunks grows at a maximum speed for short lists. - | len <= smallLength = len - -- For longer lists the maximum number of chunks grows slower. We don't really want to split a - -- 50-element list into each of 1..50 number of chunks. - | len <= smallLength ^ (2 :: Int) = smallLength + len `div` smallLength - -- For long lists it grows even slower. - | otherwise = smallLength + round @Double (sqrt $ fromIntegral len) - --- | Calculate the number of ways to divide a list of length @len@ into @chunkNum@ chunks. --- Equals to @C(len - 1, chunksNum - 1)@. -toChunkNumber :: Int -> Int -> Int -toChunkNumber len chunkNum = - product [len - 1, len - 2 .. len - chunkNum + 1] `div` - product [chunkNum - 1, chunkNum - 2 .. 2] - --- | Return a list of pairs, each of which consists of --- --- 1. the frequency at which a chunk length needs to be picked by the generation machinery --- 2. the chunk length itself --- --- >>> toChunkFrequencies 5 --- [(1,1),(4,2),(6,3),(4,4),(1,5)] --- >>> toChunkFrequencies 10 --- [(3,1),(6,2),(9,3),(12,4),(15,5),(18,6),(21,7)] --- >>> toChunkFrequencies 50 --- [(3,1),(4,2),(5,3),(6,4),(7,5),(8,6),(9,7),(10,8),(11,9),(12,10),(13,11),(14,12),(15,13)] -toChunkFrequencies :: Int -> [(Int, Int)] -toChunkFrequencies len - -- For short lists we calculate exact chunk numbers and use those as frequencies in order to get - -- uniform distribution of list lengths (which does not lead to uniform distribution of lengths - -- of subtrees, since subtrees with small total count of elements get generated much more often - -- than those with a big total count of elements, particularly because the latter contain the - -- former). - | len <= smallLength = map (\num -> (toChunkNumber len num, num)) chunks - | otherwise = - let -- The probability of "splitting" a list into a single sublist (i.e. simply 'pure') is - -- about 3%. - singleElemProb = 3 - -- Computing @delta@ in order for each subsequent chunk length to get picked a bit more - -- likely, so that we generate longer forests more often when we can. For not-too-long - -- lists the frequencies add up to roughly 100. For long lists the sum of frequencies - -- can be significantly greater than 100 making the chance of generating a single - -- sublist less than 3%. - deltaN = chunkMax * (chunkMax - 1) `div` 2 - delta = max 1 $ (100 - chunkMax * singleElemProb) `div` deltaN - in zip (iterate (+ delta) singleElemProb) chunks - where - chunkMax = toMaxChunkNumber len - chunks = [1 .. chunkMax] - --- | Split the given list in chunks. The length of each chunk, apart from the final one, is taken --- from the first argument. --- --- >>> toChunks [3, 1] "abcdef" --- ["abc","d","ef"] -toChunks :: [Int] -> [a] -> [[a]] -toChunks [] xs = [xs] -toChunks (n : ns) xs = chunk : toChunks ns xs' where - (chunk, xs') = splitAt n xs - --- | Split a list into chunks at random. Concatenating the resulting lists gives back the original --- one. Doesn't generate empty chunks. -multiSplit1 :: [a] -> Gen [NonEmptyList a] -multiSplit1 [] = pure [] -multiSplit1 xs = do - let len = length xs - -- Pick a number of chunks. - chunkNum <- frequency . map (fmap pure) $ toChunkFrequencies len - -- Pick a list of breakpoints. - breakpoints <- sort <$> uniqueVectorOf (chunkNum - 1) (choose (1, len - 1)) - -- Turn the list of breakpoints into a list of chunk lengths. - let chunkLens = zipWith (-) breakpoints (0 : breakpoints) - -- Chop the argument into chunks according to the list of chunk lengths. - pure . coerce $ toChunks chunkLens xs - --- | Return the left and the right halves of the given list. The first argument controls whether --- the middle element of a list having an odd length goes into the left half or the right one. --- --- >>> halve True [1 :: Int] --- ([1],[]) --- >>> halve True [1, 2 :: Int] --- ([1],[2]) --- >>> halve True [1, 2, 3 :: Int] --- ([1,2],[3]) --- >>> halve False [1 :: Int] --- ([],[1]) --- >>> halve False [1, 2 :: Int] --- ([1],[2]) --- >>> halve False [1, 2, 3 :: Int] --- ([1],[2,3]) -halve :: Bool -> [a] -> ([a], [a]) -halve isOddToLeft xs0 = go xs0 xs0 where - go (_ : _ : xsFast) (x : xsSlow) = first (x :) $ go xsFast xsSlow - go [_] (x : xsSlow) | isOddToLeft = ([x], xsSlow) - go _ xsSlow = ([], xsSlow) - --- | Insert a value into a list an arbitrary number of times. The first argument controls whether --- to allow inserting at the beginning of the list, the second argument is the probability of --- inserting an element at the end of the list. -insertManyPreferRight :: forall a. Bool -> Double -> a -> [a] -> Gen [a] -insertManyPreferRight keepPrefix lastProb y xs0 = go keepPrefix initWeight xs0 where - -- The weight of the "insert @y@ operation" operation at the beginning of the list. - initWeight = 10 - -- How more likely we're to insert an element when moving one element forward in the list. - -- Should we make it dependent on the length of the list? Maybe it's fine. - scaling = 1.1 - -- The weight of the "insert @y@ operation" operation at the end of the list. - topWeight = scaling ** fromIntegral (length xs0) * initWeight - -- The weight of the "do nothing" operation. - noopWeight = floor $ topWeight * (1 / lastProb - 1) - - go :: Bool -> Double -> [a] -> Gen [a] - go keep weight xs = do - doCons <- frequency [(floor weight, pure True), (noopWeight, pure False)] - if doCons - -- If we don't want to insert elements into the head of the list, then we simply ignore - -- the generated one and carry on. Ugly, but works. - then ([y | keep] ++) <$> go keep weight xs - else case xs of - [] -> pure [] - x : xs' -> (x :) <$> go True (weight * scaling) xs' - --- | Insert a value into a list an arbitrary number of times. The first argument controls whether --- to allow inserting at the end of the list, the second argument is the probability of --- inserting an element at the beginning of the list. -insertManyPreferLeft :: Bool -> Double -> a -> [a] -> Gen [a] -insertManyPreferLeft keepSuffix headProb y = - fmap reverse . insertManyPreferRight keepSuffix headProb y . reverse - --- | Insert a value into a list an arbitrary number of times. The first argument is the probability --- of inserting an element at an end of the list (i.e. either the beginning or the end, not --- combined). See 'multiSplit' for what this function allows us to do. -insertManyPreferEnds :: Double -> a -> [a] -> Gen [a] --- Cut the list in half, insert into the left half skewing generation towards the beginning, insert --- into the right half skewing generation towards the end, then append the results of those two --- operations, so that we get a list where additional elements are more likely to occur close to --- the sides. -insertManyPreferEnds endProb y xs = do - -- In order not to get skewed results we sometimes put the middle element of the list into its - -- first half and sometimes into its second half. - isOddToLeft <- arbitrary - let (xsL, xsR) = halve isOddToLeft xs - -- If the list has even length, then it was cut into two halves of equal length meaning one slot - -- for to put an element in appears twice: at the end of the left half and at the beginning of - -- the right one. Hence in order to avoid skeweness we don't put anything into this slot at the - -- end of the left half. - -- Maybe we do want to skew generation to favor the middle of the list like we do for its ends, - -- but then we need to do that intentionally and systematically, not randomly and a little bit. - xsL' <- insertManyPreferLeft (length xsL /= length xsR) endProb y xsL - xsR' <- insertManyPreferRight True endProb y xsR - pure $ xsL' ++ xsR' - --- | Split a list into chunks at random. Concatenating the resulting lists gives back the original --- one. Generates empty chunks. The first argument is the probability of generating at least one --- empty chunk as the first element of the resulting list. It is also the probability of generating --- an empty chunk as the last element of the resulting list. The probability of generating empty --- chunks decreases as we go from either of the ends of the resulting list (this is so that we are --- more likely to hit a corner case related to handling elements at the beginning or the end of a --- list). -multiSplit :: Double -> [a] -> Gen [[a]] -multiSplit endProb = multiSplit1 >=> insertManyPreferEnds endProb [] . coerce diff --git a/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Costing.hs b/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Costing.hs index 3960673589a..572540b2ecc 100644 --- a/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Costing.hs +++ b/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Costing.hs @@ -12,7 +12,7 @@ import PlutusCore.Evaluation.Machine.ExBudget import PlutusCore.Evaluation.Machine.ExBudgetStream import PlutusCore.Evaluation.Machine.ExMemory import PlutusCore.Evaluation.Machine.ExMemoryUsage -import PlutusCore.Generators.QuickCheck.Builtin () +import PlutusCore.Generators.QuickCheck.Builtin (magnitudesPositive) import PlutusCore.Generators.QuickCheck.Utils import Data.Bifunctor @@ -53,10 +53,10 @@ toExBudgetList = NonEmpty . go where -- | A list of ranges: @(0, 10) : (11, 100) : (101, 1000) : ... : [(10^18, maxBound)]@. magnitudes :: [(SatInt, SatInt)] -magnitudes = zipWith (\low high -> (low + 1, high)) borders (tail borders) - where - borders :: [SatInt] - borders = -1 : tail (takeWhile (< maxBound) $ iterate (* 10) 1) ++ [maxBound] +magnitudes + = map (bimap fromInteger fromInteger) + . magnitudesPositive 10 + $ fromSatInt (maxBound :: SatInt) -- | Return the range (in the sense of 'magnitudes') in which the given 'SatInt' belongs. E.g. -- diff --git a/plutus-ledger-api/testlib/PlutusLedgerApi/Test/V1/Value.hs b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/V1/Value.hs index fb2580815b8..3386e38947b 100644 --- a/plutus-ledger-api/testlib/PlutusLedgerApi/Test/V1/Value.hs +++ b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/V1/Value.hs @@ -9,7 +9,7 @@ import PlutusLedgerApi.V1 import PlutusTx.AssocMap qualified as AssocMap import PlutusTx.List qualified as ListTx -import PlutusCore.Generators.QuickCheck.Utils (multiSplit, uniqueVectorOf) +import PlutusCore.Generators.QuickCheck.Utils (multiSplit0, uniqueVectorOf) import Data.ByteString.Base16 qualified as Base16 import Data.ByteString.Char8 qualified as BS8 @@ -84,7 +84,7 @@ instance Arbitrary Value where arbitrary = do -- Generate values for all of the 'TokenName's in the final 'Value' and split them into a -- list of lists. - faceValues <- multiSplit 0.2 . map unFaceValue =<< arbitrary + faceValues <- multiSplit0 0.2 . map unFaceValue =<< arbitrary -- Generate 'TokenName's and 'CurrencySymbol's. currencies <- uniqueNames CurrencySymbol =<< traverse (uniqueNames TokenName) faceValues pure $ listsToValue currencies