Skip to content

Commit

Permalink
Merge #2536
Browse files Browse the repository at this point in the history
2536: Split change outputs with asset quantities exceeding the maximum r=jonathanknowles a=jonathanknowles

# Issue Number

#2532
ADP-726

# Overview

Although quantities of individual assets are effectively unlimited, a transaction on the blockchain can never include an asset quantity greater than `maxBound :: Word64`.

This PR tweaks the coin selection algorithm to detect change bundles containing excessively large asset quantities.

If such a change bundle is detected, we now split the change bundle up into smaller bundles using [equipartitioning](https://en.wiktionary.org/wiki/equipartition).

# Example

Let's suppose the maximum allowable token quantity is **`5`**, and we have a change map with the following quantities:

```haskell
[("a", 11), ("b", 5), ("c", 12)]
```

In this case, we must divide the map into **_at least three_** smaller maps in order to not exceed the maximum allowable token quantity.

Under the equipartitioning scheme, this would give us:

```haskell
[("a", 3), ("b", 1), ("c", 4)]
[("a", 4), ("b", 2), ("c", 4)]
[("a", 4), ("b", 2), ("c", 4)]
```

Note that while the overall sum is preserved, the individual bundles are almost equal, **_but not quite_**: this is because `11` and `5` are not divisible by `3`. We must therefore accept a small loss of proportionality in the result.

# Details

An **_equipartition_** of a bundle **_b_** is a _partition_ into multiple bundles, where for every asset **_a_** in the set of assets contained in **_b_**, the difference between the following quantities is either _zero_ or _one_ :

- The smallest quantity of asset **_a_** in the resultant bundles
- The greatest quantity of asset **_a_** in the resultant bundles

In order to determine the number of parts in which to split a given bundle, we choose the **_smallest_** number of parts that still allows us satisfy the goal of not exceeding the maximum allowable quantity in any given bundle.

# Performance

In order to avoid evaluating a partition for every single change output, we **_short circuit_** in the event that there is no token quantity greater than the maximum allowable quantity:

```haskell
equipartitionTokenMapWithMaxQuantity m (TokenQuantity maxQuantity)
    | maxQuantity == 0 =
        maxQuantityZeroError
    | currentMaxQuantity <= maxQuantity =
        m :| []
    | otherwise =
        equipartitionTokenMap m (() :| replicate extraPartCount ())
```

# Testing

## Property tests

Equipartitioning behaviour is tested by the following property tests:
- `prop_equipartitionTokenBundle*`
- `prop_equipartitionTokenMap*`

## Unit tests

As a sanity check, this PR also provides unit tests for `performSelection` with inputs containing token quantities that are close to the maximum, and demonstrates that change bundles are correctly partitioned in the results.

Co-authored-by: Jonathan Knowles <[email protected]>
iohk-bors[bot] and jonathanknowles authored Feb 27, 2021
2 parents e45ff29 + 9cf72cb commit 1b42a42
Showing 2 changed files with 736 additions and 2 deletions.
232 changes: 231 additions & 1 deletion lib/core/src/Cardano/Wallet/Primitive/CoinSelection/MA/RoundRobin.hs
Original file line number Diff line number Diff line change
@@ -53,6 +53,14 @@ module Cardano.Wallet.Primitive.CoinSelection.MA.RoundRobin
, makeChangeForNonUserSpecifiedAsset
, assignCoinsToChangeMaps

-- * Partitioning
, equipartitionNatural
, equipartitionTokenBundleWithMaxQuantity
, equipartitionTokenBundlesWithMaxQuantity
, equipartitionTokenMap
, equipartitionTokenMapWithMaxQuantity
, equipartitionTokenQuantity

-- * Grouping and ungrouping
, groupByKey
, ungroupByKey
@@ -64,6 +72,9 @@ module Cardano.Wallet.Primitive.CoinSelection.MA.RoundRobin
-- * Accessors
, fullBalance

-- * Constants
, maxTxOutTokenQuantity

-- * Utility classes
, AssetCount (..)

@@ -108,8 +119,12 @@ import Data.Maybe
( fromMaybe )
import Data.Ord
( comparing )
import Data.Ratio
( (%) )
import Data.Set
( Set )
import Data.Word
( Word64 )
import Fmt
( Buildable (..)
, Builder
@@ -855,11 +870,27 @@ makeChange minCoinFor requiredCost mExtraCoinSource inputBundles outputBundles
-- Next, sort the list into ascending order of asset count, which moves
-- any empty maps to the start of the list:
& NE.sortWith (AssetCount . fst)
-- Finally, combine the existing list with the change maps for non-user
-- Next, combine the existing list with the change maps for non-user
-- specified assets, which are already sorted into ascending order of
-- asset count:
& NE.zipWith (\m1 (m2, c) -> (m1 <> m2, c))
changeForNonUserSpecifiedAssets
-- Finally, if there are any maps with excessive token quantities, then
-- split these maps up along with their corresponding output coins:
& splitMapsWithExcessiveQuantities
where
splitMapsWithExcessiveQuantities
:: NonEmpty (TokenMap, Coin) -> NonEmpty (TokenMap, Coin)
splitMapsWithExcessiveQuantities =
-- For the sake of convenience when splitting up change maps and
-- output coins (which are treated as weights), treat each change
-- map and its corresponding output coin as a token bundle.
fmap unbundle . split . fmap bundle
where
bundle (m, c) = TokenBundle c m
unbundle (TokenBundle c m) = (m, c)
split = flip equipartitionTokenBundlesWithMaxQuantity
maxTxOutTokenQuantity

-- Change for user-specified assets: assets that were present in the
-- original set of user-specified outputs ('outputsToCover').
@@ -1145,6 +1176,195 @@ makeChangeForCoin targets excess =
weights :: NonEmpty Natural
weights = coinToNatural <$> targets

--------------------------------------------------------------------------------
-- Equipartitioning
--------------------------------------------------------------------------------

-- An /equipartition/ of a value 'v' (of some type) is a /partition/ of that
-- value into 'n' smaller values whose /sizes/ differ by no more than 1. The
-- the notion of /size/ is dependent on the type of value 'v'.
--
-- In this section, equipartitions have the following properties:
--
-- 1. The length is observed:
-- >>> length (equipartition v n) == n
--
-- 2. The sum is preserved:
-- >>> sum (equipartition v n) == v
--
-- 3. Each resulting value is less than or equal to the original value:
-- >>> all (`leq` v) (equipartition v n)
--
-- 4. The resultant list is sorted into ascending order when values are
-- compared with the 'leq' function.
--
--------------------------------------------------------------------------------

-- | Computes the equipartition of a coin into 'n' smaller coins.
--
equipartitionCoin
:: HasCallStack
=> Coin
-- ^ The coin to be partitioned.
-> NonEmpty a
-- ^ Represents the number of portions in which to partition the coin.
-> NonEmpty Coin
-- ^ The partitioned coins.
equipartitionCoin c =
-- Note: the natural-to-coin conversion is safe, as equipartitioning always
-- guarantees to produce values that are less than or equal to the original
-- value.
fmap unsafeNaturalToCoin . equipartitionNatural (coinToNatural c)

-- | Computes the equipartition of a natural number into 'n' smaller numbers.
--
equipartitionNatural
:: HasCallStack
=> Natural
-- ^ The natural number to be partitioned.
-> NonEmpty a
-- ^ Represents the number of portions in which to partition the number.
-> NonEmpty Natural
-- ^ The partitioned numbers.
equipartitionNatural n count =
-- Note: due to the behaviour of the underlying partition algorithm, a
-- simple list reversal is enough to ensure that the resultant list is
-- sorted in ascending order.
NE.reverse $ unsafePartitionNatural n (1 <$ count)

-- | Computes the equipartition of a token map into 'n' smaller maps.
--
-- Each asset is partitioned independently.
--
equipartitionTokenMap
:: HasCallStack
=> TokenMap
-- ^ The map to be partitioned.
-> NonEmpty a
-- ^ Represents the number of portions in which to partition the map.
-> NonEmpty TokenMap
-- ^ The partitioned maps.
equipartitionTokenMap m count =
F.foldl' accumulate (TokenMap.empty <$ count) (TokenMap.toFlatList m)
where
accumulate
:: NonEmpty TokenMap
-> (AssetId, TokenQuantity)
-> NonEmpty TokenMap
accumulate maps (asset, quantity) = NE.zipWith (<>) maps $
TokenMap.singleton asset <$>
equipartitionTokenQuantity quantity count

-- | Computes the equipartition of a token quantity into 'n' smaller quantities.
--
equipartitionTokenQuantity
:: HasCallStack
=> TokenQuantity
-- ^ The token quantity to be partitioned.
-> NonEmpty a
-- ^ Represents the number of portions in which to partition the quantity.
-> NonEmpty TokenQuantity
-- ^ The partitioned quantities.
equipartitionTokenQuantity q =
fmap TokenQuantity . equipartitionNatural (unTokenQuantity q)

--------------------------------------------------------------------------------
-- Equipartitioning according to a maximum token quantity
--------------------------------------------------------------------------------

-- | Computes the equipartition of a token bundle into 'n' smaller bundles,
-- according to the given maximum token quantity.
--
-- The value 'n' is computed automatically, and is the minimum value required
-- to achieve the goal that no token quantity in any of the resulting bundles
-- exceeds the maximum allowable token quantity.
--
equipartitionTokenBundleWithMaxQuantity
:: TokenBundle
-> TokenQuantity
-- ^ Maximum allowable token quantity.
-> NonEmpty TokenBundle
-- ^ The partitioned bundles.
equipartitionTokenBundleWithMaxQuantity b maxQuantity =
NE.zipWith TokenBundle cs ms
where
cs = equipartitionCoin (view #coin b) ms
ms = equipartitionTokenMapWithMaxQuantity (view #tokens b) maxQuantity

-- | Applies 'equipartitionTokenBundleWithMaxQuantity' to a list of bundles.
--
-- Only token bundles containing quantities that exceed the maximum token
-- quantity will be partitioned.
--
-- If none of the bundles in the given list contain a quantity that exceeds
-- the maximum token quantity, this function will return the original list.
--
equipartitionTokenBundlesWithMaxQuantity
:: NonEmpty TokenBundle
-- ^ Token bundles.
-> TokenQuantity
-- ^ Maximum allowable token quantity.
-> NonEmpty TokenBundle
-- ^ The partitioned bundles.
equipartitionTokenBundlesWithMaxQuantity bs maxQuantity =
(`equipartitionTokenBundleWithMaxQuantity` maxQuantity) =<< bs

-- | Computes the equipartition of a token map into 'n' smaller maps, according
-- to the given maximum token quantity.
--
-- The value 'n' is computed automatically, and is the minimum value required
-- to achieve the goal that no token quantity in any of the resulting maps
-- exceeds the maximum allowable token quantity.
--
equipartitionTokenMapWithMaxQuantity
:: TokenMap
-> TokenQuantity
-- ^ Maximum allowable token quantity.
-> NonEmpty TokenMap
-- ^ The partitioned maps.
equipartitionTokenMapWithMaxQuantity m (TokenQuantity maxQuantity)
| maxQuantity == 0 =
maxQuantityZeroError
| currentMaxQuantity <= maxQuantity =
m :| []
| otherwise =
equipartitionTokenMap m (() :| replicate extraPartCount ())
where
TokenQuantity currentMaxQuantity = TokenMap.maximumQuantity m

extraPartCount :: Int
extraPartCount = floor $ pred currentMaxQuantity % maxQuantity

maxQuantityZeroError = error $ unwords
[ "equipartitionTokenMapWithMaxQuantity:"
, "the maximum allowable token quantity cannot be zero."
]

--------------------------------------------------------------------------------
-- Unsafe partitioning
--------------------------------------------------------------------------------

-- | Partitions a natural number into a number of parts, where the size of each
-- part is proportional to the size of its corresponding element in the given
-- list of weights, and the number of parts is equal to the number of weights.
--
-- Throws a run-time error if the sum of weights is equal to zero.
--
unsafePartitionNatural
:: HasCallStack
=> Natural
-- ^ Natural number to partition
-> NonEmpty Natural
-- ^ List of weights
-> NonEmpty Natural
unsafePartitionNatural target =
fromMaybe zeroWeightSumError . partitionNatural target
where
zeroWeightSumError = error $ unwords
[ "unsafePartitionNatural:"
, "specified weights must have a non-zero sum."
]

--------------------------------------------------------------------------------
-- Grouping and ungrouping
--------------------------------------------------------------------------------
@@ -1219,6 +1439,16 @@ newtype AssetCount a = AssetCount
{ unAssetCount :: a }
deriving (Eq, Show)

--------------------------------------------------------------------------------
-- Constants
--------------------------------------------------------------------------------

-- | The greatest token quantity that can be encoded within an output bundle of
-- a transaction.
--
maxTxOutTokenQuantity :: TokenQuantity
maxTxOutTokenQuantity = TokenQuantity $ fromIntegral (maxBound :: Word64)

--------------------------------------------------------------------------------
-- Utility functions
--------------------------------------------------------------------------------
Original file line number Diff line number Diff line change
@@ -2,12 +2,14 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{- HLINT ignore "Use camelCase" -}

module Cardano.Wallet.Primitive.CoinSelection.MA.RoundRobinSpec
( spec
@@ -33,20 +35,29 @@ import Cardano.Wallet.Primitive.CoinSelection.MA.RoundRobin
, assetSelectionLens
, assignCoinsToChangeMaps
, coinSelectionLens
, equipartitionNatural
, equipartitionTokenBundleWithMaxQuantity
, equipartitionTokenBundlesWithMaxQuantity
, equipartitionTokenMap
, equipartitionTokenMapWithMaxQuantity
, equipartitionTokenQuantity
, fullBalance
, groupByKey
, makeChange
, makeChangeForCoin
, makeChangeForNonUserSpecifiedAsset
, makeChangeForUserSpecifiedAsset
, mapMaybe
, maxTxOutTokenQuantity
, performSelection
, prepareOutputsWith
, runRoundRobin
, runSelection
, runSelectionStep
, ungroupByKey
)
import Cardano.Wallet.Primitive.Types.Address
( Address (..) )
import Cardano.Wallet.Primitive.Types.Coin
( Coin (..), addCoin )
import Cardano.Wallet.Primitive.Types.Coin.Gen
@@ -74,7 +85,7 @@ import Cardano.Wallet.Primitive.Types.TokenQuantity
import Cardano.Wallet.Primitive.Types.TokenQuantity.Gen
( genTokenQuantitySmallPositive, shrinkTokenQuantitySmallPositive )
import Cardano.Wallet.Primitive.Types.Tx
( TxOut, txOutCoin )
( TxIn (..), TxOut (..), txOutCoin )
import Cardano.Wallet.Primitive.Types.Tx.Gen
( genTxOutSmallRange, shrinkTxOutSmallRange )
import Cardano.Wallet.Primitive.Types.UTxOIndex
@@ -103,6 +114,8 @@ import Data.Map.Strict
( Map )
import Data.Maybe
( isJust )
import Data.Ratio
( (%) )
import Data.Set
( Set )
import Data.Tuple
@@ -130,6 +143,7 @@ import Test.QuickCheck
, Property
, applyFun
, arbitraryBoundedEnum
, arbitrarySizedNatural
, checkCoverage
, choose
, conjoin
@@ -143,10 +157,12 @@ import Test.QuickCheck
, label
, oneof
, property
, shrinkIntegral
, shrinkList
, suchThat
, withMaxSuccess
, (.&&.)
, (.||.)
, (===)
, (==>)
)
@@ -159,7 +175,9 @@ import Test.Utils.Laws

import qualified Cardano.Wallet.Primitive.Types.TokenBundle as TokenBundle
import qualified Cardano.Wallet.Primitive.Types.TokenMap as TokenMap
import qualified Cardano.Wallet.Primitive.Types.TokenQuantity as TokenQuantity
import qualified Cardano.Wallet.Primitive.Types.UTxOIndex as UTxOIndex
import qualified Data.ByteString.Char8 as B8
import qualified Data.Foldable as F
import qualified Data.List as L
import qualified Data.List.NonEmpty as NE
@@ -254,6 +272,11 @@ spec = describe "Cardano.Wallet.Primitive.CoinSelection.MA.RoundRobinSpec" $
it "prop_coinSelectonLens_givesPriorityToCoins" $
property prop_coinSelectionLens_givesPriorityToCoins

parallel $ describe "Boundary tests" $ do

unitTests "testBoundaries"
unit_testBoundaries

parallel $ describe "Making change" $ do

it "prop_makeChange_identity" $
@@ -298,6 +321,59 @@ spec = describe "Cardano.Wallet.Primitive.CoinSelection.MA.RoundRobinSpec" $
unitTests "makeChangeForUserSpecifiedAsset"
unit_makeChangeForUserSpecifiedAsset

parallel $ describe "Equipartitioning natural numbers" $ do

it "prop_equipartitionNatural_fair" $
property prop_equipartitionNatural_fair
it "prop_equipartitionNatural_length" $
property prop_equipartitionNatural_length
it "prop_equipartitionNatural_order" $
property prop_equipartitionNatural_order
it "prop_equipartitionNatural_sum" $
property prop_equipartitionNatural_sum

parallel $ describe "Equipartitioning token maps" $ do

it "prop_equipartitionTokenMap_fair" $
property prop_equipartitionTokenMap_fair
it "prop_equipartitionTokenMap_length" $
property prop_equipartitionTokenMap_length
it "prop_equipartitionTokenMap_order" $
property prop_equipartitionTokenMap_order
it "prop_equipartitionTokenMap_sum" $
property prop_equipartitionTokenMap_sum

parallel $ describe "Equipartitioning token bundles by max quantity" $ do

describe "Individual token bundles" $ do

it "prop_equipartitionTokenBundleWithMaxQuantity_length" $
property prop_equipartitionTokenBundleWithMaxQuantity_length
it "prop_equipartitionTokenBundleWithMaxQuantity_order" $
property prop_equipartitionTokenBundleWithMaxQuantity_order
it "prop_equipartitionTokenBundleWithMaxQuantity_sum" $
property prop_equipartitionTokenBundleWithMaxQuantity_sum

describe "Lists of token bundles" $ do

it "prop_equipartitionTokenBundlesWithMaxQuantity_length" $
property prop_equipartitionTokenBundlesWithMaxQuantity_length
it "prop_equipartitionTokenBundlesWithMaxQuantity_sum" $
property prop_equipartitionTokenBundlesWithMaxQuantity_sum

parallel $ describe "Equipartitioning token maps by max quantity" $ do

it "prop_equipartitionTokenMapWithMaxQuantity_coverage" $
property prop_equipartitionTokenMapWithMaxQuantity_coverage
it "prop_equipartitionTokenMapWithMaxQuantity_length" $
property prop_equipartitionTokenMapWithMaxQuantity_length
it "prop_equipartitionTokenMapWithMaxQuantity_max" $
property prop_equipartitionTokenMapWithMaxQuantity_max
it "prop_equipartitionTokenMapWithMaxQuantity_order" $
property prop_equipartitionTokenMapWithMaxQuantity_order
it "prop_equipartitionTokenMapWithMaxQuantity_sum" $
property prop_equipartitionTokenMapWithMaxQuantity_sum

parallel $ describe "Grouping and ungrouping" $ do

it "prop_groupByKey_ungroupByKey" $
@@ -1008,6 +1084,203 @@ prop_coinSelectionLens_givesPriorityToCoins (Blind (Small u)) =
lens = coinSelectionLens NoLimit Nothing minimumCoinQuantity
minimumCoinQuantity = Coin 1

--------------------------------------------------------------------------------
-- Boundary tests
--------------------------------------------------------------------------------

unit_testBoundaries :: [Expectation]
unit_testBoundaries = mkBoundaryTestExpectation <$> boundaryTestMatrix

data BoundaryTestData = BoundaryTestData
{ boundaryTestCriteria
:: BoundaryTestCriteria
, boundaryTestExpectedResult
:: BoundaryTestResult
}
deriving (Eq, Show)

data BoundaryTestCriteria = BoundaryTestCriteria
{ boundaryTestOutputs
:: [BoundaryTestEntry]
, boundaryTestUTxO
:: [BoundaryTestEntry]
}
deriving (Eq, Show)

data BoundaryTestResult = BoundaryTestResult
{ boundaryTestInputs
:: [BoundaryTestEntry]
, boundaryTestChange
:: [BoundaryTestEntry]
}
deriving (Eq, Show)

type BoundaryTestEntry = (Coin, [(AssetId, TokenQuantity)])

mkBoundaryTestExpectation :: BoundaryTestData -> Expectation
mkBoundaryTestExpectation (BoundaryTestData criteria expectedResult) = do
actualResult <- performSelection
noMinCoin (mkCostFor NoCost) (encodeBoundaryTestCriteria criteria)
fmap decodeBoundaryTestResult actualResult `shouldBe` Right expectedResult

encodeBoundaryTestCriteria :: BoundaryTestCriteria -> SelectionCriteria
encodeBoundaryTestCriteria c = SelectionCriteria
{ outputsToCover = NE.fromList $
zipWith TxOut
(dummyAddresses)
(uncurry TokenBundle.fromFlatList <$> boundaryTestOutputs c)
, utxoAvailable = UTxOIndex.fromSequence $ zip dummyTxIns $
zipWith TxOut
(dummyAddresses)
(uncurry TokenBundle.fromFlatList <$> boundaryTestUTxO c)
, selectionLimit =
NoLimit
, extraCoinSource =
Nothing
}
where
dummyAddresses :: [Address]
dummyAddresses = [Address (B8.pack $ show x) | x :: Word64 <- [0 ..]]

dummyTxIns :: [TxIn]
dummyTxIns = [TxIn (Hash "") x | x <- [0 ..]]

decodeBoundaryTestResult :: SelectionResult TokenBundle -> BoundaryTestResult
decodeBoundaryTestResult r = BoundaryTestResult
{ boundaryTestInputs = L.sort $ NE.toList $
TokenBundle.toFlatList . view #tokens . snd <$> view #inputsSelected r
, boundaryTestChange =
TokenBundle.toFlatList <$> view #changeGenerated r
}

boundaryTestMatrix :: [BoundaryTestData]
boundaryTestMatrix =
[ boundaryTest1
, boundaryTest2
, boundaryTest3
, boundaryTest4
]

-- Reach (but do not exceed) the maximum token quantity by selecting inputs
-- with the following quantities:
--
-- - Quantity #1: 1
-- - Quantity #2: maximum token quantity - 1
--
-- We expect no splitting of token bundles.
--
boundaryTest1 :: BoundaryTestData
boundaryTest1 = BoundaryTestData
{ boundaryTestCriteria = BoundaryTestCriteria {..}
, boundaryTestExpectedResult = BoundaryTestResult {..}
}
where
assetA = AssetId (UnsafeTokenPolicyId $ Hash "A") (UnsafeTokenName "1")
(q1, q2) = (TokenQuantity 1, TokenQuantity.pred maxTxOutTokenQuantity)
boundaryTestOutputs =
[ (Coin 1_500_000, []) ]
boundaryTestUTxO =
[ (Coin 1_000_000, [(assetA, q1)])
, (Coin 1_000_000, [(assetA, q2)])
]
boundaryTestInputs =
[ (Coin 1_000_000, [(assetA, q1)])
, (Coin 1_000_000, [(assetA, q2)])
]
boundaryTestChange =
[ (Coin 500_000, [(assetA, maxTxOutTokenQuantity)]) ]

-- Reach (but do not exceed) the maximum token quantity by selecting inputs
-- with the following quantities:
--
-- - Quantity #1: floor (maximum token quantity / 2)
-- - Quantity #2: ceiling (maximum token quantity / 2)
--
-- We expect no splitting of token bundles.
--
boundaryTest2 :: BoundaryTestData
boundaryTest2 = BoundaryTestData
{ boundaryTestCriteria = BoundaryTestCriteria {..}
, boundaryTestExpectedResult = BoundaryTestResult {..}
}
where
assetA = AssetId (UnsafeTokenPolicyId $ Hash "A") (UnsafeTokenName "1")
q1 :| [q2] = equipartitionTokenQuantity maxTxOutTokenQuantity (() :| [()])
boundaryTestOutputs =
[ (Coin 1_500_000, []) ]
boundaryTestUTxO =
[ (Coin 1_000_000, [(assetA, q1)])
, (Coin 1_000_000, [(assetA, q2)])
]
boundaryTestInputs =
[ (Coin 1_000_000, [(assetA, q1)])
, (Coin 1_000_000, [(assetA, q2)])
]
boundaryTestChange =
[ (Coin 500_000, [(assetA, maxTxOutTokenQuantity)]) ]

-- Slightly exceed the maximum token quantity by selecting inputs with the
-- following quantities:
--
-- - Quantity #1: 1
-- - Quantity #2: maximum token quantity
--
-- We expect splitting of change bundles.
--
boundaryTest3 :: BoundaryTestData
boundaryTest3 = BoundaryTestData
{ boundaryTestCriteria = BoundaryTestCriteria {..}
, boundaryTestExpectedResult = BoundaryTestResult {..}
}
where
assetA = AssetId (UnsafeTokenPolicyId $ Hash "A") (UnsafeTokenName "1")
q1 :| [q2] = equipartitionTokenQuantity
(TokenQuantity.succ maxTxOutTokenQuantity) (() :| [()])
boundaryTestOutputs =
[ (Coin 1_500_000, []) ]
boundaryTestUTxO =
[ (Coin 1_000_000, [(assetA, TokenQuantity 1)])
, (Coin 1_000_000, [(assetA, maxTxOutTokenQuantity)])
]
boundaryTestInputs =
[ (Coin 1_000_000, [(assetA, TokenQuantity 1)])
, (Coin 1_000_000, [(assetA, maxTxOutTokenQuantity)])
]
boundaryTestChange =
[ (Coin 250_000, [(assetA, q1)])
, (Coin 250_000, [(assetA, q2)])
]

-- Reach (but do not exceed) exactly twice the maximum token quantity by
-- selecting inputs with the following quantities:
--
-- - Quantity #1: maximum token quantity
-- - Quantity #2: maximum token quantity
--
-- We expect splitting of change bundles.
--
boundaryTest4 :: BoundaryTestData
boundaryTest4 = BoundaryTestData
{ boundaryTestCriteria = BoundaryTestCriteria {..}
, boundaryTestExpectedResult = BoundaryTestResult {..}
}
where
assetA = AssetId (UnsafeTokenPolicyId $ Hash "A") (UnsafeTokenName "1")
boundaryTestOutputs =
[ (Coin 1_500_000, []) ]
boundaryTestUTxO =
[ (Coin 1_000_000, [(assetA, maxTxOutTokenQuantity)])
, (Coin 1_000_000, [(assetA, maxTxOutTokenQuantity)])
]
boundaryTestInputs =
[ (Coin 1_000_000, [(assetA, maxTxOutTokenQuantity)])
, (Coin 1_000_000, [(assetA, maxTxOutTokenQuantity)])
]
boundaryTestChange =
[ (Coin 250_000, [(assetA, maxTxOutTokenQuantity)])
, (Coin 250_000, [(assetA, maxTxOutTokenQuantity)])
]

--------------------------------------------------------------------------------
-- Making change
--------------------------------------------------------------------------------
@@ -1576,6 +1849,233 @@ unit_makeChangeForUserSpecifiedAsset =
assetC :: AssetId
assetC = AssetId (UnsafeTokenPolicyId $ Hash "A") (UnsafeTokenName "2")

--------------------------------------------------------------------------------
-- Equipartitioning natural numbers
--------------------------------------------------------------------------------

-- Test that natural numbers are equipartitioned fairly:
--
-- Each portion must be within unity of the ideal portion.
--
prop_equipartitionNatural_fair
:: Natural -> NonEmpty () -> Property
prop_equipartitionNatural_fair n count = (.||.)
(difference === 0)
(difference === 1)
where
difference :: Natural
difference = F.maximum results - F.minimum results

results :: NonEmpty Natural
results = equipartitionNatural n count

prop_equipartitionNatural_length :: Natural -> NonEmpty () -> Property
prop_equipartitionNatural_length n count =
NE.length (equipartitionNatural n count) === NE.length count

prop_equipartitionNatural_order :: Natural -> NonEmpty () -> Property
prop_equipartitionNatural_order n count =
NE.sort results === results
where
results = equipartitionNatural n count

prop_equipartitionNatural_sum :: Natural -> NonEmpty () -> Property
prop_equipartitionNatural_sum n count =
F.sum (equipartitionNatural n count) === n

--------------------------------------------------------------------------------
-- Equipartitioning token maps
--------------------------------------------------------------------------------

-- Test that token maps are equipartitioned fairly:
--
-- Each token quantity portion must be within unity of the ideal portion.
--
prop_equipartitionTokenMap_fair :: TokenMap -> NonEmpty () -> Property
prop_equipartitionTokenMap_fair m count = property $
isZeroOrOne maximumDifference
where
-- Here we take advantage of the fact that the resultant maps are sorted
-- into ascending order when compared with the 'leq' function.
--
-- Consequently:
--
-- - the head map will be the smallest;
-- - the last map will be the greatest.
--
-- Therefore, subtracting the head map from the last map will produce a map
-- where each token quantity is equal to the difference between:
--
-- - the smallest quantity of that token in the resulting maps;
-- - the greatest quantity of that token in the resulting maps.
--
differences :: TokenMap
differences = NE.last results `TokenMap.unsafeSubtract` NE.head results

isZeroOrOne :: TokenQuantity -> Bool
isZeroOrOne (TokenQuantity q) = q == 0 || q == 1

maximumDifference :: TokenQuantity
maximumDifference = TokenMap.maximumQuantity differences

results = equipartitionTokenMap m count

prop_equipartitionTokenMap_length :: TokenMap -> NonEmpty () -> Property
prop_equipartitionTokenMap_length m count =
NE.length (equipartitionTokenMap m count) === NE.length count

prop_equipartitionTokenMap_order :: TokenMap -> NonEmpty () -> Property
prop_equipartitionTokenMap_order m count = property $
inAscendingPartialOrder (equipartitionTokenMap m count)

prop_equipartitionTokenMap_sum :: TokenMap -> NonEmpty () -> Property
prop_equipartitionTokenMap_sum m count =
F.fold (equipartitionTokenMap m count) === m

--------------------------------------------------------------------------------
-- Equipartitioning token bundles according to a maximum quantity
--------------------------------------------------------------------------------

-- | Computes the number of parts that 'equipartitionTokenBundleWithMaxQuantity'
-- should return.
--
equipartitionTokenBundleWithMaxQuantity_expectedLength
:: TokenBundle -> TokenQuantity -> Int
equipartitionTokenBundleWithMaxQuantity_expectedLength m =
equipartitionTokenMapWithMaxQuantity_expectedLength
(view #tokens m)

prop_equipartitionTokenBundleWithMaxQuantity_length
:: TokenBundle -> TokenQuantity -> Property
prop_equipartitionTokenBundleWithMaxQuantity_length m maxQuantity =
maxQuantity > TokenQuantity.zero ==>
length (equipartitionTokenBundleWithMaxQuantity m maxQuantity)
=== equipartitionTokenBundleWithMaxQuantity_expectedLength
m maxQuantity

prop_equipartitionTokenBundleWithMaxQuantity_order
:: TokenBundle -> TokenQuantity -> Property
prop_equipartitionTokenBundleWithMaxQuantity_order m maxQuantity =
maxQuantity > TokenQuantity.zero ==>
inAscendingPartialOrder
(equipartitionTokenBundleWithMaxQuantity m maxQuantity)

prop_equipartitionTokenBundleWithMaxQuantity_sum
:: TokenBundle -> TokenQuantity -> Property
prop_equipartitionTokenBundleWithMaxQuantity_sum m maxQuantity =
maxQuantity > TokenQuantity.zero ==>
F.fold (equipartitionTokenBundleWithMaxQuantity m maxQuantity) === m

--------------------------------------------------------------------------------
-- Equipartitioning lists of token bundles according to a maximum quantity
--------------------------------------------------------------------------------

prop_equipartitionTokenBundlesWithMaxQuantity_length
:: NonEmpty TokenBundle -> TokenQuantity -> Property
prop_equipartitionTokenBundlesWithMaxQuantity_length input maxQuantityAllowed =
maxQuantityAllowed > TokenQuantity.zero ==> checkCoverage $ property $
cover 5 (lengthOutput > lengthInput)
"length has increased" $
cover 5 (lengthOutput == lengthInput)
"length has remained the same" $
case compare lengthOutput lengthInput of
GT -> (&&)
(maxQuantityAllowed < maxQuantityInput)
(maxQuantityAllowed >= maxQuantityOutput)
EQ -> (&&)
(maxQuantityAllowed >= maxQuantityInput)
(input == output)
LT ->
error "length has unexpectedly decreased"
where
lengthInput =
NE.length input
lengthOutput =
NE.length output
maxQuantityInput =
F.maximum (TokenMap.maximumQuantity . view #tokens <$> input)
maxQuantityOutput =
F.maximum (TokenMap.maximumQuantity . view #tokens <$> output)
output =
equipartitionTokenBundlesWithMaxQuantity input maxQuantityAllowed

prop_equipartitionTokenBundlesWithMaxQuantity_sum
:: NonEmpty TokenBundle -> TokenQuantity -> Property
prop_equipartitionTokenBundlesWithMaxQuantity_sum ms maxQuantity =
maxQuantity > TokenQuantity.zero ==>
F.fold (equipartitionTokenBundlesWithMaxQuantity ms maxQuantity)
=== F.fold ms

--------------------------------------------------------------------------------
-- Equipartitioning token maps according to a maximum quantity
--------------------------------------------------------------------------------

-- | Computes the number of parts that 'equipartitionTokenMapWithMaxQuantity'
-- should return.
--
equipartitionTokenMapWithMaxQuantity_expectedLength
:: TokenMap -> TokenQuantity -> Int
equipartitionTokenMapWithMaxQuantity_expectedLength
m (TokenQuantity maxQuantity) =
max 1 $ ceiling $ currentMaxQuantity % maxQuantity
where
TokenQuantity currentMaxQuantity = TokenMap.maximumQuantity m

prop_equipartitionTokenMapWithMaxQuantity_coverage
:: TokenMap -> TokenQuantity -> Property
prop_equipartitionTokenMapWithMaxQuantity_coverage m maxQuantity =
maxQuantity > TokenQuantity.zero ==>
checkCoverage $
cover 8 (maxQuantity == TokenQuantity 1)
"Maximum allowable quantity == 1" $
cover 8 (maxQuantity == TokenQuantity 2)
"Maximum allowable quantity == 2" $
cover 8 (maxQuantity >= TokenQuantity 3)
"Maximum allowable quantity >= 3" $
cover 8 (expectedLength == 1)
"Expected number of parts == 1" $
cover 8 (expectedLength == 2)
"Expected number of parts == 2" $
cover 8 (expectedLength >= 3)
"Expected number of parts >= 3" $
property $ expectedLength > 0
where
expectedLength = equipartitionTokenMapWithMaxQuantity_expectedLength
m maxQuantity

prop_equipartitionTokenMapWithMaxQuantity_length
:: TokenMap -> TokenQuantity -> Property
prop_equipartitionTokenMapWithMaxQuantity_length m maxQuantity =
maxQuantity > TokenQuantity.zero ==>
length (equipartitionTokenMapWithMaxQuantity m maxQuantity)
=== equipartitionTokenMapWithMaxQuantity_expectedLength
m maxQuantity

prop_equipartitionTokenMapWithMaxQuantity_max
:: TokenMap -> TokenQuantity -> Property
prop_equipartitionTokenMapWithMaxQuantity_max m maxQuantity =
maxQuantity > TokenQuantity.zero ==>
checkCoverage $
cover 10 (maxResultQuantity == maxQuantity)
"At least one resultant token map has a maximal quantity" $
property $ maxResultQuantity <= maxQuantity
where
results = equipartitionTokenMapWithMaxQuantity m maxQuantity
maxResultQuantity = F.maximum (TokenMap.maximumQuantity <$> results)

prop_equipartitionTokenMapWithMaxQuantity_order
:: TokenMap -> TokenQuantity -> Property
prop_equipartitionTokenMapWithMaxQuantity_order m maxQuantity =
maxQuantity > TokenQuantity.zero ==>
inAscendingPartialOrder
(equipartitionTokenMapWithMaxQuantity m maxQuantity)

prop_equipartitionTokenMapWithMaxQuantity_sum
:: TokenMap -> TokenQuantity -> Property
prop_equipartitionTokenMapWithMaxQuantity_sum m maxQuantity =
maxQuantity > TokenQuantity.zero ==>
F.fold (equipartitionTokenMapWithMaxQuantity m maxQuantity) === m

--------------------------------------------------------------------------------
-- Grouping and ungrouping
--------------------------------------------------------------------------------
@@ -1788,6 +2288,10 @@ instance Arbitrary AssetId where
arbitrary = genAssetIdSmallRange
shrink = shrinkAssetIdSmallRange

instance Arbitrary Natural where
arbitrary = arbitrarySizedNatural
shrink = shrinkIntegral

instance Arbitrary MakeChangeData where
arbitrary = genMakeChangeData

0 comments on commit 1b42a42

Please sign in to comment.