cardano-coin-selection (empty) → 1.0.0

raw patch · 24 files changed

+6015/−0 lines, 24 filesdep +QuickCheckdep +basedep +bytestring

Dependencies added: QuickCheck, base, bytestring, cardano-coin-selection, containers, cryptonite, deepseq, fmt, hspec, memory, quiet, random, text, transformers, vector

Files

• ChangeLog.md +3/−0
• LICENSE +201/−0
• cardano-coin-selection.cabal +103/−0
• src/internal/Internal.hs +20/−0
• src/internal/Internal/Coin.hs +140/−0
• src/internal/Internal/Invariant.hs +35/−0
• src/internal/Internal/Rounding.hs +38/−0
• src/library/Cardano/CoinSelection.hs +399/−0
• src/library/Cardano/CoinSelection/Algorithm.hs +57/−0
• src/library/Cardano/CoinSelection/Algorithm/LargestFirst.hs +280/−0
• src/library/Cardano/CoinSelection/Algorithm/Migration.hs +239/−0
• src/library/Cardano/CoinSelection/Algorithm/RandomImprove.hs +421/−0
• src/library/Cardano/CoinSelection/Fee.hs +713/−0
• src/test/Cardano/CoinSelection/Algorithm/LargestFirstSpec.hs +247/−0
• src/test/Cardano/CoinSelection/Algorithm/MigrationSpec.hs +339/−0
• src/test/Cardano/CoinSelection/Algorithm/RandomImproveSpec.hs +264/−0
• src/test/Cardano/CoinSelection/FeeSpec.hs +1103/−0
• src/test/Cardano/CoinSelection/TypesSpec.hs +257/−0
• src/test/Cardano/CoinSelectionSpec.hs +460/−0
• src/test/Cardano/Test/Utilities.hs +264/−0
• src/test/Internal/CoinSpec.hs +164/−0
• src/test/Spec.hs +1/−0
• src/test/Test/Vector/Shuffle.hs +106/−0
• src/test/Test/Vector/ShuffleSpec.hs +161/−0

@@ -0,0 +1,3 @@+## [1.0.0] - 2020-04-29++Initial release.

@@ -0,0 +1,201 @@+                                 Apache License+                           Version 2.0, January 2004+                        http://www.apache.org/licenses/++   TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION++   1. Definitions.++      "License" shall mean the terms and conditions for use, reproduction,+      and distribution as defined by Sections 1 through 9 of this document.++      "Licensor" shall mean the copyright owner or entity authorized by+      the copyright owner that is granting the License.++      "Legal Entity" shall mean the union of the acting entity and all+      other entities that control, are controlled by, or are under common+      control with that entity. For the purposes of this definition,+      "control" means (i) the power, direct or indirect, to cause the+      direction or management of such entity, whether by contract or+      otherwise, or (ii) ownership of fifty percent (50%) or more of the+      outstanding shares, or (iii) beneficial ownership of such entity.++      "You" (or "Your") shall mean an individual or Legal Entity+      exercising permissions granted by this License.++      "Source" form shall mean the preferred form for making modifications,+      including but not limited to software source code, documentation+      source, and configuration files.++      "Object" form shall mean any form resulting from mechanical+      transformation or translation of a Source form, including but+      not limited to compiled object code, generated documentation,+      and conversions to other media types.++      "Work" shall mean the work of authorship, whether in Source or+      Object form, made available under the License, as indicated by a+      copyright notice that is included in or attached to the work+      (an example is provided in the Appendix below).++      "Derivative Works" shall mean any work, whether in Source or Object+      form, that is based on (or derived from) the Work and for which the+      editorial revisions, annotations, elaborations, or other modifications+      represent, as a whole, an original work of authorship. For the purposes+      of this License, Derivative Works shall not include works that remain+      separable from, or merely link (or bind by name) to the interfaces of,+      the Work and Derivative Works thereof.++      "Contribution" shall mean any work of authorship, including+      the original version of the Work and any modifications or additions+      to that Work or Derivative Works thereof, that is intentionally+      submitted to Licensor for inclusion in the Work by the copyright owner+      or by an individual or Legal Entity authorized to submit on behalf of+      the copyright owner. For the purposes of this definition, "submitted"+      means any form of electronic, verbal, or written communication sent+      to the Licensor or its representatives, including but not limited to+      communication on electronic mailing lists, source code control systems,+      and issue tracking systems that are managed by, or on behalf of, the+      Licensor for the purpose of discussing and improving the Work, but+      excluding communication that is conspicuously marked or otherwise+      designated in writing by the copyright owner as "Not a Contribution."++      "Contributor" shall mean Licensor and any individual or Legal Entity+      on behalf of whom a Contribution has been received by Licensor and+      subsequently incorporated within the Work.++   2. Grant of Copyright License. Subject to the terms and conditions of+      this License, each Contributor hereby grants to You a perpetual,+      worldwide, non-exclusive, no-charge, royalty-free, irrevocable+      copyright license to reproduce, prepare Derivative Works of,+      publicly display, publicly perform, sublicense, and distribute the+      Work and such Derivative Works in Source or Object form.++   3. Grant of Patent License. Subject to the terms and conditions of+      this License, each Contributor hereby grants to You a perpetual,+      worldwide, non-exclusive, no-charge, royalty-free, irrevocable+      (except as stated in this section) patent license to make, have made,+      use, offer to sell, sell, import, and otherwise transfer the Work,+      where such license applies only to those patent claims licensable+      by such Contributor that are necessarily infringed by their+      Contribution(s) alone or by combination of their Contribution(s)+      with the Work to which such Contribution(s) was submitted. If You+      institute patent litigation against any entity (including a+      cross-claim or counterclaim in a lawsuit) alleging that the Work+      or a Contribution incorporated within the Work constitutes direct+      or contributory patent infringement, then any patent licenses+      granted to You under this License for that Work shall terminate+      as of the date such litigation is filed.++   4. Redistribution. You may reproduce and distribute copies of the+      Work or Derivative Works thereof in any medium, with or without+      modifications, and in Source or Object form, provided that You+      meet the following conditions:++      (a) You must give any other recipients of the Work or+          Derivative Works a copy of this License; and++      (b) You must cause any modified files to carry prominent notices+          stating that You changed the files; and++      (c) You must retain, in the Source form of any Derivative Works+          that You distribute, all copyright, patent, trademark, and+          attribution notices from the Source form of the Work,+          excluding those notices that do not pertain to any part of+          the Derivative Works; and++      (d) If the Work includes a "NOTICE" text file as part of its+          distribution, then any Derivative Works that You distribute must+          include a readable copy of the attribution notices contained+          within such NOTICE file, excluding those notices that do not+          pertain to any part of the Derivative Works, in at least one+          of the following places: within a NOTICE text file distributed+          as part of the Derivative Works; within the Source form or+          documentation, if provided along with the Derivative Works; or,+          within a display generated by the Derivative Works, if and+          wherever such third-party notices normally appear. The contents+          of the NOTICE file are for informational purposes only and+          do not modify the License. You may add Your own attribution+          notices within Derivative Works that You distribute, alongside+          or as an addendum to the NOTICE text from the Work, provided+          that such additional attribution notices cannot be construed+          as modifying the License.++      You may add Your own copyright statement to Your modifications and+      may provide additional or different license terms and conditions+      for use, reproduction, or distribution of Your modifications, or+      for any such Derivative Works as a whole, provided Your use,+      reproduction, and distribution of the Work otherwise complies with+      the conditions stated in this License.++   5. Submission of Contributions. Unless You explicitly state otherwise,+      any Contribution intentionally submitted for inclusion in the Work+      by You to the Licensor shall be under the terms and conditions of+      this License, without any additional terms or conditions.+      Notwithstanding the above, nothing herein shall supersede or modify+      the terms of any separate license agreement you may have executed+      with Licensor regarding such Contributions.++   6. Trademarks. This License does not grant permission to use the trade+      names, trademarks, service marks, or product names of the Licensor,+      except as required for reasonable and customary use in describing the+      origin of the Work and reproducing the content of the NOTICE file.++   7. Disclaimer of Warranty. Unless required by applicable law or+      agreed to in writing, Licensor provides the Work (and each+      Contributor provides its Contributions) on an "AS IS" BASIS,+      WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or+      implied, including, without limitation, any warranties or conditions+      of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A+      PARTICULAR PURPOSE. You are solely responsible for determining the+      appropriateness of using or redistributing the Work and assume any+      risks associated with Your exercise of permissions under this License.++   8. Limitation of Liability. In no event and under no legal theory,+      whether in tort (including negligence), contract, or otherwise,+      unless required by applicable law (such as deliberate and grossly+      negligent acts) or agreed to in writing, shall any Contributor be+      liable to You for damages, including any direct, indirect, special,+      incidental, or consequential damages of any character arising as a+      result of this License or out of the use or inability to use the+      Work (including but not limited to damages for loss of goodwill,+      work stoppage, computer failure or malfunction, or any and all+      other commercial damages or losses), even if such Contributor+      has been advised of the possibility of such damages.++   9. Accepting Warranty or Additional Liability. While redistributing+      the Work or Derivative Works thereof, You may choose to offer,+      and charge a fee for, acceptance of support, warranty, indemnity,+      or other liability obligations and/or rights consistent with this+      License. However, in accepting such obligations, You may act only+      on Your own behalf and on Your sole responsibility, not on behalf+      of any other Contributor, and only if You agree to indemnify,+      defend, and hold each Contributor harmless for any liability+      incurred by, or claims asserted against, such Contributor by reason+      of your accepting any such warranty or additional liability.++   END OF TERMS AND CONDITIONS++   APPENDIX: How to apply the Apache License to your work.++      To apply the Apache License to your work, attach the following+      boilerplate notice, with the fields enclosed by brackets "[]"+      replaced with your own identifying information. (Don't include+      the brackets!)  The text should be enclosed in the appropriate+      comment syntax for the file format. We also recommend that a+      file or class name and description of purpose be included on the+      same "printed page" as the copyright notice for easier+      identification within third-party archives.++   Copyright © 2019-2020 IOHK++   Licensed under the Apache License, Version 2.0 (the "License");+   you may not use this file except in compliance with the License.+   You may obtain a copy of the License at++       http://www.apache.org/licenses/LICENSE-2.0++   Unless required by applicable law or agreed to in writing, software+   distributed under the License is distributed on an "AS IS" BASIS,+   WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+   See the License for the specific language governing permissions and+   limitations under the License.

@@ -0,0 +1,103 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.31.2.+--+-- see: https://github.com/sol/hpack+--+-- hash: fa91aa04303b2016d424d05014b688d5845de29176adad56b44a698e849d080a++name:           cardano-coin-selection+version:        1.0.0+synopsis:       Algorithms for coin selection and fee balancing.+description:    Please see the README on GitHub at <https://github.com/input-output-hk/cardano-coin-selection>+category:       Cardano+homepage:       https://github.com/input-output-hk/cardano-coin-selection#readme+bug-reports:    https://github.com/input-output-hk/cardano-coin-selection/issues+author:         IOHK+maintainer:     operations@iohk.io+copyright:      2020 IOHK+license:        Apache-2.0+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    ChangeLog.md++source-repository head+  type: git+  location: https://github.com/input-output-hk/cardano-coin-selection++flag release+  description: Compile executables for a release.+  manual: True+  default: False++library+  exposed-modules:+      Cardano.CoinSelection+      Cardano.CoinSelection.Algorithm+      Cardano.CoinSelection.Algorithm.LargestFirst+      Cardano.CoinSelection.Algorithm.Migration+      Cardano.CoinSelection.Algorithm.RandomImprove+      Cardano.CoinSelection.Fee+      Internal+      Internal.Coin+      Internal.Invariant+      Internal.Rounding+  other-modules:+      Paths_cardano_coin_selection+  hs-source-dirs:+      src/library+      src/internal+  default-extensions: NoImplicitPrelude+  ghc-options: -Wall -Wcompat -fwarn-redundant-constraints+  build-depends:+      base >=4.7 && <5+    , bytestring+    , containers+    , cryptonite+    , deepseq+    , quiet+    , text+    , transformers+  if flag(release)+    ghc-options: -Werror+  default-language: Haskell2010++test-suite unit+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Cardano.CoinSelection.Algorithm.LargestFirstSpec+      Cardano.CoinSelection.Algorithm.MigrationSpec+      Cardano.CoinSelection.Algorithm.RandomImproveSpec+      Cardano.CoinSelection.FeeSpec+      Cardano.CoinSelection.TypesSpec+      Cardano.CoinSelectionSpec+      Cardano.Test.Utilities+      Internal.CoinSpec+      Test.Vector.Shuffle+      Test.Vector.ShuffleSpec+      Paths_cardano_coin_selection+  hs-source-dirs:+      src/test+  default-extensions: NoImplicitPrelude+  ghc-options: -Wall -Wcompat -fwarn-redundant-constraints -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      QuickCheck+    , base >=4.7 && <5+    , bytestring+    , cardano-coin-selection+    , containers+    , cryptonite+    , deepseq+    , fmt+    , hspec+    , memory+    , quiet+    , random+    , text+    , transformers+    , vector+  if flag(release)+    ghc-options: -Werror+  default-language: Haskell2010

@@ -0,0 +1,20 @@+{-# OPTIONS_GHC -fno-warn-unused-imports #-}+{-# OPTIONS_HADDOCK hide #-}++-- |+-- Copyright: © 2018-2020 IOHK+-- License: Apache-2.0+--+-- This module hierarchy provides types and functions that are not intended to+-- be part of the public API.+--+-- Types and functions defined herein are not guaranteed to be forwards or+-- backwards compatible across different versions of the library.+--+module Internal+    ( module Internal.Invariant+    , module Internal.Rounding+    ) where++import Internal.Invariant+import Internal.Rounding

@@ -0,0 +1,140 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE FlexibleInstances #-}+{-# OPTIONS_HADDOCK hide #-}++-- |+-- Copyright: © 2018-2020 IOHK+-- License: Apache-2.0+--+module Internal.Coin+    (+      -- * Types+      Coin++      -- Construction and Deconstruction+    , coinFromIntegral+    , coinFromNatural+    , coinToIntegral+    , coinToNatural++      -- * Unary Operations+    , pred+    , succ++      -- * Binary Operations+    , add+    , sub+    , mul+    , div+    , mod++      -- * Calculating Distances+    , distance++      -- * Value Tests+    , isZero++      -- * Special Values+    , zero+    , one++    ) where++import Prelude hiding+    ( div, fromIntegral, mod, pred, succ )++import GHC.Generics+    ( Generic )+import Numeric.Natural+    ( Natural )+import Quiet+    ( Quiet (Quiet) )++import qualified Prelude++-- | Represents a non-negative integral amount of currency.+--+-- Use 'coinFromNatural' to create a coin from a natural number.+--+-- Use 'coinToNatural' to convert a coin into a natural number.+--+-- @since 1.0.0+newtype Coin = Coin { unCoin :: Natural }+    deriving stock (Eq, Generic, Ord)+    deriving Show via (Quiet Coin)++-- | Creates a coin from an integral number.+--+-- Returns a coin if (and only if) the given input is not negative.+--+coinFromIntegral :: Integral i => i -> Maybe Coin+coinFromIntegral i+    | i >= 0    = Just $ Coin $ Prelude.fromIntegral i+    | otherwise = Nothing++-- | Creates a coin from a natural number.+--+-- @since 1.0.0+coinFromNatural :: Natural -> Coin+coinFromNatural = Coin++-- | Converts the given coin into an integral number.+--+coinToIntegral :: Integral i => Coin -> i+coinToIntegral (Coin i) = Prelude.fromIntegral i++-- | Converts the given coin into a natural number.+--+-- @since 1.0.0+coinToNatural :: Coin -> Natural+coinToNatural = unCoin++add :: Coin -> Coin -> Coin+add (Coin x) (Coin y) = Coin $ x + y++sub :: Coin -> Coin -> Maybe Coin+sub (Coin x) (Coin y) = coinFromIntegral $ toInteger x - toInteger y++mul :: Integral i => Coin -> i -> Maybe Coin+mul (Coin x) y = coinFromIntegral $ toInteger x * toInteger y++div :: Integral i => Coin -> i -> Maybe Coin+div (Coin x) y+    | y <= 0    = Nothing+    | otherwise = coinFromIntegral $ toInteger x `Prelude.div` toInteger y++mod :: Integral i => Coin -> i -> Maybe Coin+mod (Coin x) y+    | y <= 0    = Nothing+    | otherwise = coinFromIntegral $ toInteger x `Prelude.mod` toInteger y++distance :: Coin -> Coin -> Coin+distance (Coin x) (Coin y)+    | x >= y    = Coin $ x - y+    | otherwise = Coin $ y - x++pred :: Coin -> Maybe Coin+pred x = x `sub` one++succ :: Coin -> Coin+succ x = x `add` one++isZero :: Coin -> Bool+isZero = (== zero)++zero :: Coin+zero = Coin 0++one :: Coin+one = Coin 1++newtype Sum a = Sum { getSum :: a }+    deriving stock (Eq, Generic, Ord)+    deriving Show via (Quiet (Sum a))++instance Monoid Coin where+    mempty = zero++instance Semigroup Coin where+    (<>) = add

@@ -0,0 +1,35 @@+{-# OPTIONS_HADDOCK hide #-}++-- |+-- Copyright: © 2018-2020 IOHK+-- License: Apache-2.0+--+-- Provides internal functions relating to verification of invariants.+--+module Internal.Invariant+    ( invariant+    ) where++import Prelude++-- | Checks whether or not an invariant holds, by applying the given predicate+--   to the given value.+--+-- If the invariant does not hold (indicated by the predicate function+-- returning 'False'), throws an error with the specified message.+--+-- >>> invariant "not empty" [1,2,3] (not . null)+-- [1, 2, 3]+--+-- >>> invariant "not empty" [] (not . null)+-- *** Exception: not empty+invariant+    :: String+        -- ^ The message+    -> a+        -- ^ The value to test+    -> (a -> Bool)+        -- ^ The predicate+    -> a+invariant msg a predicate =+    if predicate a then a else error msg

@@ -0,0 +1,38 @@+{-# LANGUAGE LambdaCase #-}++{-# OPTIONS_HADDOCK hide #-}++-- |+-- Copyright: © 2018-2020 IOHK+-- License: Apache-2.0+--+-- Provides internal types and functions relating to rounding of fractional+-- numbers.+--+module Internal.Rounding+    ( RoundingDirection (..)+    , round+    ) where++import Prelude hiding+    ( round )++-- | Indicates a rounding direction to be used when converting from a+--   fractional value to an integral value.+--+-- See 'round'.+--+data RoundingDirection+    = RoundUp+      -- ^ Round up to the nearest integral value.+    | RoundDown+      -- ^ Round down to the nearest integral value.+    deriving (Eq, Show)++-- | Use the given rounding direction to round the given fractional value,+--   producing an integral result.+--+round :: (RealFrac a, Integral b) => RoundingDirection -> a -> b+round = \case+    RoundUp -> ceiling+    RoundDown -> floor

@@ -0,0 +1,399 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE NumericUnderscores #-}+{-# LANGUAGE RankNTypes #-}++{-# OPTIONS_HADDOCK prune #-}++-- |+-- Copyright: © 2018-2020 IOHK+-- License: Apache-2.0+--+-- Provides general functions and types relating to coin selection.+--+-- The 'CoinSelection' type represents a __coin selection__, the basis for a+-- /transaction/ in a UTxO-based blockchain.+--+-- The 'CoinSelectionAlgorithm' type provides a __common interface__ to+-- algorithms that generate coin selections.+--+-- For a guide to __algorithms provided by this library__, see the+-- "Cardano.CoinSelection.Algorithm" module.+--+-- To adjust coin selections in order to __pay for transaction fees__, see+-- the "Cardano.CoinSelection.Fee" module.+--+module Cardano.CoinSelection+    (+      -- * Coin Selections+      CoinSelection (..)+    , sumInputs+    , sumOutputs+    , sumChange++      -- * Coin Selection Algorithms+    , CoinSelectionAlgorithm (..)+    , CoinSelectionParameters (..)+    , CoinSelectionResult (..)+    , CoinSelectionLimit (..)++      -- * Coins+    , Coin+    , coinFromNatural+    , coinToNatural++      -- * Coin Maps+    , CoinMap (..)+    , CoinMapEntry (..)+    , coinMapFromList+    , coinMapToList+    , coinMapValue++      -- * Coin Selection Errors+    , CoinSelectionError (..)+    , InputValueInsufficientError (..)+    , InputCountInsufficientError (..)+    , InputLimitExceededError (..)+    , InputsExhaustedError (..)++      -- # Internal Functions+    , coinMapRandomEntry++    ) where++import Prelude++import Control.Arrow+    ( (&&&) )+import Control.Monad.Trans.Except+    ( ExceptT (..) )+import Crypto.Number.Generate+    ( generateBetween )+import Crypto.Random.Types+    ( MonadRandom )+import Data.Map.Strict+    ( Map )+import Data.Word+    ( Word16 )+import GHC.Generics+    ( Generic )+import Internal.Coin+    ( Coin, coinFromNatural, coinToNatural )+import Numeric.Natural+    ( Natural )+import Quiet+    ( Quiet (Quiet) )++import qualified Data.Foldable as F+import qualified Data.Map.Strict as Map++--------------------------------------------------------------------------------+-- Coin Map+--------------------------------------------------------------------------------++-- | A mapping from unique keys to associated 'Coin' values.+--+-- A 'CoinMap' can be used to represent:+--+--   * a UTxO set, where each key within the map refers to an unspent output+--     from a previous transaction.+--+--   * a set of 'inputs' to a 'CoinSelection', where each input is an entry+--     selected from a UTxO set by a 'CoinSelectionAlgorithm'.+--+--   * a set of 'outputs' for a 'CoinSelection', where each key within the map+--     refers to the address of a payment recipient.+--+-- A 'CoinMap' can be constructed with the 'coinMapFromList' function.+--+-- The total value of a 'CoinMap' is given by the 'coinMapValue' function.+--+-- @since 1.0.0+newtype CoinMap a = CoinMap { unCoinMap :: Map a Coin }+    deriving (Eq, Generic)+    deriving Show via (Quiet (CoinMap a))++instance Foldable CoinMap where+    foldMap f = F.fold . fmap (f . entryKey) . coinMapToList++instance Ord a => Monoid (CoinMap a) where+    mempty = CoinMap mempty++instance Ord a => Semigroup (CoinMap a) where+    CoinMap a <> CoinMap b = CoinMap $ Map.unionWith (<>) a b++-- | An entry for a 'CoinMap'.+--+-- @since 1.0.0+data CoinMapEntry a = CoinMapEntry+    { entryKey+        :: a+        -- ^ The unique key associated with this entry.+    , entryValue+        :: Coin+        -- ^ The coin value associated with this entry.+    } deriving (Eq, Generic, Ord, Show)++-- | Constructs a 'CoinMap' from a list of entries.+--+-- See 'CoinMapEntry'.+--+-- @since 1.0.0+coinMapFromList :: Ord a => [CoinMapEntry a] -> CoinMap a+coinMapFromList = CoinMap+    . Map.fromListWith (<>)+    . fmap (entryKey &&& entryValue)++-- | Converts a 'CoinMap' to a list of entries.+--+-- See 'CoinMapEntry'.+--+-- @since 1.0.0+coinMapToList :: CoinMap a -> [CoinMapEntry a]+coinMapToList = fmap (uncurry CoinMapEntry) . Map.toList . unCoinMap++-- | Calculates the total coin value associated with a 'CoinMap'.+--+-- @since 1.0.0+coinMapValue :: CoinMap a -> Coin+coinMapValue = mconcat . fmap entryValue . coinMapToList++--------------------------------------------------------------------------------+-- Coin Selection+--------------------------------------------------------------------------------++-- | Provides a __common interface__ for coin selection algorithms.+--+-- The function 'selectCoins', when applied to the given+-- 'CoinSelectionParameters' object (with /available inputs/ and /requested/+-- /outputs/), will generate a 'CoinSelectionResult' (with /remaining inputs/+-- and a /coin selection/).+--+-- For implementations provided by this library, see+-- "Cardano.CoinSelection.Algorithm".+--+-- @since 1.0.0+newtype CoinSelectionAlgorithm i o m = CoinSelectionAlgorithm+    { selectCoins+        :: CoinSelectionParameters i o+        -> ExceptT CoinSelectionError m (CoinSelectionResult i o)+    }++-- | The complete set of parameters required for a 'CoinSelectionAlgorithm'.+--+-- The 'inputsAvailable' and 'outputsRequested' fields are both maps of unique+-- keys to associated 'Coin' values, where:+--+--   * Each key-value pair in the 'inputsAvailable' map corresponds to an+--     __unspent output__ from a previous transaction that is /available/+--     /for selection as an input/ by the coin selection algorithm. The /key/+--     is a unique reference to that output, and the /value/ is the amount of+--     unspent value associated with it.+--+--   * Each key-value pair in the 'outputsRequested' map corresponds to a+--     __payment__ whose value is /to be paid for/ by the coin selection+--     algorithm. The /key/ is a unique reference to a payment recipient,+--     and the /value/ is the amount of money to pay to that recipient.+--+-- A coin selection algorithm will select a __subset__ of inputs from+-- 'inputsAvailable' in order to pay for __all__ the outputs in+-- 'outputsRequested', where:+--+--   * Inputs __selected__ by the algorithm are included in the 'inputs'+--     set of the generated 'CoinSelection'.+--+--   * Inputs __not__ selected by the algorithm are included in the+--     'inputsRemaining' set of the 'CoinSelectionResult'.+--+-- The number of inputs that can selected is limited by 'limit'.+--+-- The total value of 'inputsAvailable' must be /greater than or equal to/+-- the total value of 'outputsRequested', as given by the 'coinMapValue'+-- function.+--+-- @since 1.0.0+data CoinSelectionParameters i o = CoinSelectionParameters+    { inputsAvailable :: CoinMap i+        -- ^ The set of inputs available for selection.+    , outputsRequested :: CoinMap o+        -- ^ The set of outputs requested for payment.+    , limit :: CoinSelectionLimit+        -- ^ A limit on the number of inputs that can be selected.+    }+    deriving Generic++-- | Represents the __result__ of running a coin selection algorithm.+--+-- See 'CoinSelectionAlgorithm'.+--+-- @since 1.0.0+data CoinSelectionResult i o = CoinSelectionResult+    { coinSelection :: CoinSelection i o+        -- ^ The generated coin selection.+    , inputsRemaining :: CoinMap i+        -- ^ The set of inputs that were __not__ selected.+    }++-- | A __coin selection__ is the basis for a /transaction/.+--+-- It consists of a selection of 'inputs', 'outputs', and 'change'.+--+-- The 'inputs' and 'outputs' fields are both maps of unique keys to associated+-- 'Coin' values, where:+--+--   * Each key-value pair in the 'inputs' map corresponds to an+--     __unspent output__ from a previous transaction (also known as a UTxO).+--     The /key/ is a unique reference to that output, and the /value/ is the+--     amount of unspent value associated with it.+--+--   * Each key-value pair in the 'outputs' map corresponds to a __payment__.+--     The /key/ is a unique reference to a payment recipient, and the /value/+--     is the amount of money to pay to that recipient.+--+-- The 'change' field is a set of coins to be returned to the originator of the+-- transaction.+--+-- The 'CoinSelectionAlgorithm' type provides a common interface for generating+-- coin selections.+--+-- @since 1.0.0+data CoinSelection i o = CoinSelection+    { inputs :: CoinMap i+      -- ^ The set of inputs.+    , outputs :: CoinMap o+      -- ^ The set of outputs.+    , change :: [Coin]+      -- ^ The set of change.+    }+    deriving (Generic, Show, Eq)++instance (Ord i, Ord o) => Semigroup (CoinSelection i o) where+    a <> b = CoinSelection+        { inputs = inputs a <> inputs b+        , outputs = outputs a <> outputs b+        , change = change a <> change b+        }++instance (Ord i, Ord o) => Monoid (CoinSelection i o) where+    mempty = CoinSelection mempty mempty mempty++-- | Calculate the total sum of all 'inputs' for the given 'CoinSelection'.+--+-- @since 1.0.0+sumInputs :: CoinSelection i o -> Coin+sumInputs = coinMapValue . inputs++-- | Calculate the total sum of all 'outputs' for the given 'CoinSelection'.+--+-- @since 1.0.0+sumOutputs :: CoinSelection i o -> Coin+sumOutputs =  coinMapValue . outputs++-- | Calculate the total sum of all 'change' for the given 'CoinSelection'.+--+-- @since 1.0.0+sumChange :: CoinSelection i o -> Coin+sumChange = mconcat . change++-- | Defines an __inclusive upper bound__ on the /number/ of inputs that+--   a 'CoinSelectionAlgorithm' is allowed to select.+--+-- @since 1.0.0+newtype CoinSelectionLimit = CoinSelectionLimit+    { calculateLimit+        :: Word16 -> Word16+            -- ^ Calculate the maximum number of inputs allowed for a given+            -- number of outputs.+    } deriving Generic++-- | Represents the set of possible failures that can occur when attempting+--   to produce a 'CoinSelection' with a 'CoinSelectionAlgorithm'.+--+-- See 'selectCoins'.+--+-- @since 1.0.0+data CoinSelectionError+    = InputValueInsufficient+        InputValueInsufficientError+    | InputCountInsufficient+        InputCountInsufficientError+    | InputLimitExceeded+        InputLimitExceededError+    | InputsExhausted+        InputsExhaustedError+    deriving (Eq, Show)++-- | Indicates that the total value of 'inputsAvailable' is less than the total+--   value of 'outputsRequested', making it /impossible/ to cover all payments,+--   /regardless/ of which algorithm is chosen.+--+-- @since 1.0.0+data InputValueInsufficientError =+    InputValueInsufficientError+    { inputValueAvailable :: Coin+        -- ^ The total value of 'inputsAvailable'.+    , inputValueRequired :: Coin+        -- ^ The total value of 'outputsRequested'.+    }+    deriving (Eq, Show)++-- | Indicates that the total count of entries in 'inputsAvailable' is /fewer/+--   /than/ required by the algorithm. The number required depends on the+--   particular algorithm implementation.+--+-- @since 1.0.0+data InputCountInsufficientError =+    InputCountInsufficientError+    { inputCountAvailable :: Natural+        -- ^ The number of entries in 'inputsAvailable'.+    , inputCountRequired :: Natural+        -- ^ The number of entries required.+    }+    deriving (Eq, Show)++-- | Indicates that all available entries in 'inputsAvailable' were depleted+--   /before/ all the payments in 'outputsRequested' could be paid for.+--+-- This condition can occur /even if/ the total value of 'inputsAvailable' is+-- greater than or equal to the total value of 'outputsRequested', due to+-- differences in the way that algorithms select inputs.+--+-- @since 1.0.0+data InputsExhaustedError =+    InputsExhaustedError+    deriving (Eq, Show)++-- | Indicates that the coin selection algorithm is unable to cover the total+--   value of 'outputsRequested' without exceeding the maximum number of inputs+--   defined by 'limit'.+--+-- See 'calculateLimit'.+--+-- @since 1.0.0+newtype InputLimitExceededError =+    InputLimitExceededError+    { calculatedInputLimit :: Word16 }+    deriving (Eq, Show)++--------------------------------------------------------------------------------+-- Internal Functions+--------------------------------------------------------------------------------++-- Selects an entry at random from a 'CoinMap', returning both the selected+-- entry and the map with the entry removed.+--+-- If the given map is empty, this function returns 'Nothing'.+--+coinMapRandomEntry+    :: MonadRandom m+    => CoinMap a+    -> m (Maybe (CoinMapEntry a), CoinMap a)+coinMapRandomEntry (CoinMap m)+    | Map.null m =+        return (Nothing, CoinMap m)+    | otherwise = do+        ix <- fromEnum <$> generateBetween 0 (toEnum (Map.size m - 1))+        let entry = uncurry CoinMapEntry $ Map.elemAt ix m+        let remainder = CoinMap $ Map.deleteAt ix m+        return (Just entry, remainder)

@@ -0,0 +1,57 @@+-- |+-- Copyright: © 2018-2020 IOHK+-- License: Apache-2.0+--+-- __Submodules__ of this module provide implementations of+-- __coin selection algorithms__.+--+-- Algorithms can be divided into two categories:+--+--  * <#generalized-algorithms Generalized Algorithms>+--+--        Algorithms that implement the general+--        'Cardano.CoinSelection.CoinSelectionAlgorithm' interface.+--+--  * <#specialized-algorithms Specialized Algorithms>+--+--        Algorithms that provide functionality suited to specialized purposes.+--+-- = Generalized Algorithms #generalized-algorithms#+--+-- The following algorithms implement the general+-- 'Cardano.CoinSelection.CoinSelectionAlgorithm' interface:+--+--  * __"Cardano.CoinSelection.Algorithm.LargestFirst"__+--+--        Provides an implementation of the __Largest-First__ algorithm.+--+--        When selecting inputs from a given set of UTxO entries, this+--        algorithm always selects the /largest/ entries /first/.+--+--   * __"Cardano.CoinSelection.Algorithm.RandomImprove"__+--+--        Provides an implementation of the __Random-Improve__ algorithm.+--+--        When selecting inputs from a given set of UTxO entries, this+--        algorithm always selects entries at /random/.+--+--        Once selections have been made, a second phase attempts to /improve/+--        on each of the existing selections in order to optimize change+--        outputs.+--+-- For __guidance on choosing an algorithm__ that's appropriate for your+-- scenario, please consult the following article:+--+--        <https://iohk.io/blog/self-organisation-in-coin-selection/>+--+-- = Specialized Algorithms #specialized-algorithms#+--+-- The following algorithms provide functionality suited to specialized+-- purposes:+--+--   * __"Cardano.CoinSelection.Algorithm.Migration"__+--+--        Provides an algorithm for migrating all funds from one wallet to+--        another.+--+module Cardano.CoinSelection.Algorithm where

@@ -0,0 +1,280 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}++-- |+-- Copyright: © 2018-2020 IOHK+-- License: Apache-2.0+--+-- This module contains an implementation of the __Largest-First__ coin+-- selection algorithm.+--+module Cardano.CoinSelection.Algorithm.LargestFirst (+    largestFirst+  ) where++import Prelude++import Cardano.CoinSelection+    ( CoinMapEntry (..)+    , CoinSelection (..)+    , CoinSelectionAlgorithm (..)+    , CoinSelectionError (..)+    , CoinSelectionLimit (..)+    , CoinSelectionParameters (..)+    , CoinSelectionResult (..)+    , InputCountInsufficientError (..)+    , InputLimitExceededError (..)+    , InputValueInsufficientError (..)+    , InputsExhaustedError (..)+    , coinMapFromList+    , coinMapToList+    , coinMapValue+    )+import Control.Monad+    ( foldM )+import Control.Monad.Trans.Except+    ( ExceptT (..), throwE )+import Data.Ord+    ( Down (..) )+import Internal.Coin+    ( Coin )++import qualified Data.Foldable as F+import qualified Data.List as L+import qualified Internal.Coin as C++-- | An implementation of the __Largest-First__ coin selection algorithm.+--+-- = Overview+--+-- The __Largest-First__ algorithm processes outputs in /descending order of/+-- /value/, from /largest/ to /smallest/.+--+-- For each output, it repeatedly selects the /largest/ remaining unspent UTxO+-- entry until the value of selected entries is greater than or equal to the+-- value of that output.+--+-- = State Maintained by the Algorithm+--+-- At all stages of processing, the algorithm maintains:+--+--  1.  A __/remaining UTxO list/__+--+--      This is initially equal to the given /initial UTxO set/ parameter,+--      sorted into /descending order of coin value/.+--+--      The /head/ of the list is always the remaining UTxO entry with the+--      /largest coin value/.+--+--      Entries are incrementally removed from the /head/ of the list as the+--      algorithm proceeds, until the list is empty.+--+--  2.  An __/unpaid output list/__+--+--      This is initially equal to the given /output list/ parameter, sorted+--      into /descending order of coin value/.+--+--      The /head/ of the list is always the unpaid output with the+--      /largest coin value/.+--+--      Entries are incrementally removed from the /head/ of the list as the+--      algorithm proceeds, until the list is empty.+--+--  3.  An __/accumulated coin selection/__+--+--      This is initially /empty/.+--+--      Entries are incrementally added as each output is paid for, until the+--      /unpaid output list/ is empty.+--+-- = Cardinality Rules+--+-- The algorithm requires that:+--+--  1.  Each output from the given /output list/ is paid for by /one or more/+--      entries from the /initial UTxO set/.+--+--  2.  Each entry from the /initial UTxO set/ is used to pay for /at most one/+--      output from the given /output list/.+--+--      (A single UTxO entry __cannot__ be used to pay for multiple outputs.)+--+-- = Order of Processing+--+-- The algorithm proceeds according to the following sequence of steps:+--+--  *   /Step 1/+--+--      Remove a single /unpaid output/ from the head of the+--      /unpaid output list/.+--+--  *   /Step 2/+--+--      Repeatedly remove UTxO entries from the head of the+--      /remaining UTxO list/ until the total value of entries removed is+--      /greater than or equal to/ the value of the /removed output/.+--+--  *   /Step 3/+--+--      Use the /removed UTxO entries/ to pay for the /removed output/.+--+--      This is achieved by:+--+--      *  adding the /removed UTxO entries/ to the 'inputs' field of the+--         /accumulated coin selection/.+--      *  adding the /removed output/ to the 'outputs' field of the+--         /accumulated coin selection/.+--+--  *   /Step 4/+--+--      If the /total value/ of the /removed UTxO entries/ is greater than the+--      value of the /removed output/, generate a coin whose value is equal to+--      the exact difference, and add it to the 'change' field of the+--      /accumulated coin selection/.+--+--  *   /Step 5/+--+--      If the /unpaid output list/ is empty, __terminate__ here.+--+--      Otherwise, return to /Step 1/.+--+-- = Termination+--+-- The algorithm terminates __successfully__ if the /remaining UTxO list/ is+-- not depleted before the /unpaid output list/ can be fully depleted (i.e., if+-- all the outputs have been paid for).+--+-- The /accumulated coin selection/ and /remaining UTxO list/ are returned to+-- the caller.+--+-- === Failure Modes+--+-- The algorithm terminates with an __error__ if:+--+--  1.  The /total value/ of the initial UTxO set (the amount of money+--      /available/) is /less than/ the total value of the output list (the+--      amount of money /required/).+--+--      See: __'InputValueInsufficientError'__.+--+--  2.  The /number/ of entries in the initial UTxO set is /smaller than/ the+--      number of requested outputs.+--+--      Due to the nature of the algorithm, /at least one/ UTxO entry is+--      required /for each/ output.+--+--      See: __'InputCountInsufficientError'__.+--+--  3.  Due to the particular /distribution/ of values within the initial UTxO+--      set, the algorithm depletes all entries from the UTxO set /before/ it+--      is able to pay for all requested outputs.+--+--      See: __'InputsExhaustedError'__.+--+--  4.  The /number/ of UTxO entries needed to pay for the requested outputs+--      would /exceed/ the upper limit specified by 'limit'.+--+--      See: __'InputLimitExceededError'__.+--+-- @since 1.0.0+largestFirst+    :: (Ord i, Ord o, Monad m)+    => CoinSelectionAlgorithm i o m+largestFirst = CoinSelectionAlgorithm payForOutputs++payForOutputs+    :: (Ord i, Ord o, Monad m)+    => CoinSelectionParameters i o+    -> ExceptT CoinSelectionError m (CoinSelectionResult i o)+payForOutputs params =+    case foldM payForOutput (utxoDescending, mempty) outputsDescending of+        Just (utxoRemaining, selection) ->+            pure $ CoinSelectionResult selection $ coinMapFromList utxoRemaining+        Nothing ->+            throwE errorCondition+  where+    errorCondition+      | amountAvailable < amountRequested =+          InputValueInsufficient $+              InputValueInsufficientError+                  amountAvailable amountRequested+      | utxoCount < outputCount =+          InputCountInsufficient $+              InputCountInsufficientError+                  utxoCount outputCount+      | utxoCount <= inputCountMax =+          InputsExhausted+              InputsExhaustedError+      | otherwise =+          InputLimitExceeded $+              InputLimitExceededError $+                  fromIntegral inputCountMax+    amountAvailable =+        coinMapValue $ inputsAvailable params+    amountRequested =+        coinMapValue $ outputsRequested params+    inputCountMax = fromIntegral+        $ calculateLimit (limit params)+        $ fromIntegral outputCount+    outputCount =+        fromIntegral $ length $ coinMapToList $ outputsRequested params+    outputsDescending =+        L.sortOn (Down . entryValue) $ coinMapToList $ outputsRequested params+    utxoCount =+        fromIntegral $ L.length $ coinMapToList $ inputsAvailable params+    utxoDescending =+        take (fromIntegral inputCountMax)+            $ L.sortOn (Down . entryValue)+            $ coinMapToList+            $ inputsAvailable params++-- | Attempts to pay for a /single transaction output/ by selecting the+--   /smallest possible/ number of entries from the /head/ of the given+--   UTxO list.+--+-- Returns a /reduced/ list of UTxO entries, and a coin selection that is+-- /updated/ to include the payment.+--+-- If the total value of entries in the given UTxO list is /less than/ the+-- required output amount, this function will return 'Nothing'.+--+payForOutput+    :: forall i o . (Ord i, Ord o)+    => ([CoinMapEntry i], CoinSelection i o)+    -> CoinMapEntry o+    -> Maybe ([CoinMapEntry i], CoinSelection i o)+payForOutput (utxoAvailable, currentSelection) out =+    coverTarget utxoAvailable mempty+  where+    coverTarget+        :: [CoinMapEntry i]+        -> [CoinMapEntry i]+        -> Maybe ([CoinMapEntry i], CoinSelection i o)+    coverTarget utxoRemaining utxoSelected+        | valueSelected >= valueTarget = Just+            -- We've selected enough to cover the target, so stop here.+            ( utxoRemaining+            , currentSelection <> CoinSelection+                { inputs  = coinMapFromList utxoSelected+                , outputs = coinMapFromList [out]+                , change  = filter (> C.zero)+                    (F.toList $ valueSelected `C.sub` valueTarget)+                }+            )+        | otherwise =+            -- We haven't yet selected enough to cover the target, so attempt+            -- to select a little more and then continue.+            case utxoRemaining of+                utxoEntry : utxoRemaining' ->+                    coverTarget utxoRemaining' (utxoEntry : utxoSelected)+                [] ->+                    -- The UTxO has been exhausted, so stop here.+                    Nothing+      where+        valueTarget+            = entryValue out+        valueSelected+            = sumEntries utxoSelected++sumEntries :: [CoinMapEntry a] -> Coin+sumEntries entries = mconcat $ entryValue <$> entries

@@ -0,0 +1,239 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_HADDOCK prune #-}++-- |+-- Copyright: © 2018-2020 IOHK+-- License: Apache-2.0+--+-- This module contains an algorithm for migrating all funds from one wallet+-- to another.+--+-- See 'selectCoins'.+--+module Cardano.CoinSelection.Algorithm.Migration+    (+      -- * Coin Selection for Migration+      selectCoins+    , BatchSize (..)+    , idealBatchSize+    ) where++import Prelude++import Cardano.CoinSelection+    ( CoinMap+    , CoinMapEntry (..)+    , CoinSelection (..)+    , CoinSelectionLimit (..)+    , coinMapFromList+    , coinMapToList+    , sumChange+    , sumInputs+    )+import Cardano.CoinSelection.Fee+    ( DustThreshold (..)+    , Fee (..)+    , FeeBalancingPolicy (..)+    , FeeEstimator (..)+    , FeeOptions (..)+    )+import Control.Monad.Trans.State+    ( State, evalState, get, put )+import Data.List.NonEmpty+    ( NonEmpty ((:|)) )+import Data.Maybe+    ( fromMaybe, mapMaybe )+import Data.Word+    ( Word16 )+import GHC.Generics+    ( Generic )+import Internal.Coin+    ( Coin, coinFromIntegral, coinToIntegral )++import qualified Internal.Coin as C++--------------------------------------------------------------------------------+-- Coin Selection for Migration+--------------------------------------------------------------------------------++-- | Creates a __series__ of coin selections that, when published as+--   transactions, will have the effect of migrating all funds from one+--   wallet to another.+--+-- Since UTxO-based blockchains typically impose limits on the sizes of+-- individual transactions, and since individual UTxO sets can contain+-- /arbitrarily/ many entries, migrating all funds from one wallet to another+-- may require the creation of /several/ transactions.+--+-- This function therefore /partitions/ the given set of inputs into multiple+-- /batches/ of up to __/b/__ inputs, where __/b/__ is specified by the given+-- 'BatchSize' parameter. (See 'idealBatchSize' for an automatic way to+-- calculate a suitable batch size.)+--+-- For each batch of inputs, this function creates a separate 'CoinSelection'+-- with the given 'inputs' /and/ a generated 'change' set, where the 'change'+-- set represents the value to be transferred to the target wallet, carefully+-- adjusted to deduct a fee in accordance with the given 'FeeOptions'+-- parameter. The set of 'outputs' for each coin selection is /purposefully/+-- left empty, as /all/ value is captured in the 'change' set.+--+-- @since 1.0.0+selectCoins+    :: forall i o . (Ord i, Ord o)+    => FeeOptions i o+        -- ^ The fee options.+    -> BatchSize+        -- ^ The maximum number of inputs to include in each selection.+    -> CoinMap i+        -- ^ The UTxO set to migrate.+    -> [CoinSelection i o]+selectCoins options (BatchSize batchSize) utxo =+    evalState migrate (coinMapToList utxo)+  where+    FeeOptions {dustThreshold, feeEstimator, feeBalancingPolicy} = options++    migrate :: State [CoinMapEntry i] [CoinSelection i o]+    migrate = do+        batch <- getNextBatch+        if null batch then+            pure []+        else case adjustForFee (mkCoinSelection batch) of+            Nothing -> pure []+            Just coinSel -> do+                rest <- migrate+                pure (coinSel:rest)++    -- Construct a provisional 'CoinSelection' from the given selected inputs.+    -- Note that the selection may look a bit weird at first sight as it has+    -- no outputs (we are paying everything to ourselves!).+    mkCoinSelection :: [CoinMapEntry i] -> CoinSelection i o+    mkCoinSelection inps = CoinSelection+        { inputs = coinMapFromList inps+        , outputs = mempty+        , change =+            let chgs = mapMaybe (noDust . entryValue) inps+            in if null chgs then [threshold] else chgs+        }+      where+        threshold = unDustThreshold dustThreshold+        noDust :: Coin -> Maybe Coin+        noDust c+            | c < threshold = Nothing+            | otherwise = Just c++    -- | Attempt to balance the coin selection by reducing or increasing the+    -- change values based on the computed fees.+    adjustForFee :: CoinSelection i o -> Maybe (CoinSelection i o)+    adjustForFee !coinSel = case change coinSel of+        -- If there's no change, nothing to adjust+        [] -> Nothing++        -- No difference between required and computed, we're done+        (_ : _) | diff == 0 -> Just coinSel++        -- Otherwise, we have 2 cases:+        --+        -- 1/ diff < 0+        -- We aren't giving enough as fee, so we need to reduce one output.+        --+        -- 2/ diff > 0+        -- We have some surplus so we add it to an arbitrary output+        --+        -- If both cases we can simply modify one output by adding `diff`, the+        -- sign of `diff` making for the right modification.+        -- We then recursively call ourselves for this might reduce the number+        -- of outputs and change the fee.+        (c : cs) -> do+            let coinSel' = coinSel+                    { change = modifyFirst (c :| cs) (applyDiff diff) }+            let costOfSurplus+                    = fromIntegral+                    $ C.coinToNatural+                    $ C.distance+                        (unFee $ estimateFee feeEstimator coinSel')+                        (unFee $ estimateFee feeEstimator coinSel )+            if+                -- Adding the change costs less than not having it, so it's+                -- worth trying.+                | costOfSurplus < actualFee ->+                    adjustForFee coinSel'++                -- Adding the change costs more than not having it, If we don't+                -- require strict balancing, we can leave the selection as-is.+                | feeBalancingPolicy == RequireMinimalFee ->+                    pure coinSel++                -- Adding the change costs more than not having it. So,+                -- depending on our balancing policy, we may stop the balancing+                -- right here, or, if we must balance the selection discard the+                -- whole selection: it can't be balanced with this algorithm.+                --+                -- Note that this last extreme case is reached when using an+                -- unstable fee policy (where values of outputs can influence+                -- the policy) AND, require transactions to be 100% balanced.+                -- This is a silly thing to do.+                | otherwise ->+                    Nothing+      where+        applyDiff :: Integer -> Coin -> Coin+        applyDiff i c+            = fromMaybe C.zero+            $ coinFromIntegral (i + coinToIntegral c)++        diff :: Integer+        diff = actualFee - requiredFee+          where+            requiredFee+                = coinToIntegral $ unFee+                $ estimateFee feeEstimator coinSel++        actualFee :: Integer+        actualFee+            = coinToIntegral (sumInputs coinSel)+            - coinToIntegral (sumChange coinSel)++    -- | Apply the given function to the first coin of the list. If the+    -- operation makes the 'Coin' smaller than the dust threshold, the coin is+    -- discarded.+    modifyFirst :: NonEmpty Coin -> (Coin -> Coin) -> [Coin]+    modifyFirst (c :| cs) op+        | c' <= threshold = cs+        | otherwise = c' : cs+      where+        c' = op c+        threshold = unDustThreshold dustThreshold++    getNextBatch :: State [a] [a]+    getNextBatch = do+        xs <- get+        let (batch, rest) = splitAt (fromIntegral batchSize) xs+        put rest+        pure batch++-- | An upper limit for the number of 'inputs' to include in each coin selection+--   generated by 'selectCoins'.+--+-- @since 1.0.0+newtype BatchSize = BatchSize Word16+    deriving (Eq, Generic, Ord, Show)++-- | Calculate an ideal batch size based on the given coin selection limit.+--+-- @since 1.0.0+idealBatchSize :: CoinSelectionLimit -> BatchSize+idealBatchSize coinselOpts = BatchSize $ fixPoint 1+  where+    fixPoint :: Word16 -> Word16+    fixPoint !n+        | maxN n <= n = n+        | n == maxBound = n+        | otherwise = fixPoint (n + 1)+      where+        maxN :: Word16 -> Word16+        maxN = calculateLimit coinselOpts

@@ -0,0 +1,421 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}++-- |+-- Copyright: © 2018-2020 IOHK+-- License: Apache-2.0+--+-- This module contains an implementation of the __Random-Improve__ coin+-- selection algorithm.+--+module Cardano.CoinSelection.Algorithm.RandomImprove+    ( randomImprove+    ) where++import Prelude++import Cardano.CoinSelection+    ( CoinMap (..)+    , CoinMapEntry (..)+    , CoinSelection (..)+    , CoinSelectionAlgorithm (..)+    , CoinSelectionError (..)+    , CoinSelectionLimit (..)+    , CoinSelectionParameters (..)+    , CoinSelectionResult (..)+    , InputCountInsufficientError (..)+    , InputLimitExceededError (..)+    , InputValueInsufficientError (..)+    , InputsExhaustedError (..)+    , coinMapFromList+    , coinMapRandomEntry+    , coinMapToList+    , coinMapValue+    )+import Control.Monad+    ( foldM )+import Control.Monad.Trans.Class+    ( lift )+import Control.Monad.Trans.Except+    ( ExceptT (..), throwE )+import Control.Monad.Trans.Maybe+    ( MaybeT (..), runMaybeT )+import Crypto.Random.Types+    ( MonadRandom )+import Data.Ord+    ( Down (..) )+import Internal.Coin+    ( Coin )++import qualified Data.List as L+import qualified Internal.Coin as C++-- | An implementation of the __Random-Improve__ coin selection algorithm.+--+-- = Overview+--+-- The __Random-Improve__ coin selection algorithm works in __two phases__, by+-- /first/ selecting UTxO entries /at random/ to pay for each of the given+-- outputs, and /then/ attempting to /improve/ upon each of the selections.+--+-- === Phase 1: Random Selection+--+-- __In this phase, the algorithm randomly selects a minimal set of UTxO__+-- __entries to pay for each of the given outputs.__+--+-- During this phase, the algorithm:+--+--   *  processes outputs in /descending order of coin value/.+--+--   *  maintains a /remaining UTxO set/, initially equal to the given+--      /UTxO set/ parameter.+--+-- For each output of value __/v/__, the algorithm /randomly/ selects entries+-- from the /remaining UTxO set/, until the total value of selected entries is+-- greater than or equal to __/v/__. The selected entries are then associated+-- with that output, and removed from the /remaining UTxO set/.+--+-- This phase ends when every output has been associated with a selection of+-- UTxO entries.+--+-- However, if the remaining UTxO set is completely exhausted before all+-- outputs can be processed, the algorithm terminates with an error.+--+-- === Phase 2: Improvement+--+-- __In this phase, the algorithm attempts to improve upon each of the UTxO__+-- __selections made in the previous phase, by conservatively expanding the__+-- __selection made for each output.__+--+-- During this phase, the algorithm:+--+--   *  processes outputs in /ascending order of coin value/.+--+--   *  continues to maintain the /remaining UTxO set/ produced by the previous+--      phase.+--+--   *  maintains an /accumulated coin selection/, which is initially /empty/.+--+-- For each output of value __/v/__, the algorithm:+--+--  1.  __Calculates a /target range/__ for the total value of inputs used to+--      pay for that output, defined by the triplet:+--+--      (/minimum/, /ideal/, /maximum/) = (/v/, /2v/, /3v/)+--+--  2.  __Attempts to /improve/ upon the /existing UTxO selection/__ for that+--      output, by repeatedly selecting additional entries at random from the+--      /remaining UTxO set/, stopping when the selection can be improved upon+--      no further.+--+--      A selection with value /v1/ is considered to be an /improvement/ over a+--      selection with value /v0/ if __all__ of the following conditions are+--      satisfied:+--+--       * __Condition 1__: we have moved closer to the /ideal/ value:+--+--             abs (/ideal/ − /v1/) < abs (/ideal/ − /v0/)+--+--       * __Condition 2__: we have not exceeded the /maximum/ value:+--+--             /v1/ ≤ /maximum/+--+--       * __Condition 3__: when counting cumulatively across all outputs+--       considered so far, we have not selected more than the /maximum/ number+--       of UTxO entries specified by 'limit'.+--+--  3.  __Creates a /change value/__ for the output, equal to the total value+--      of the /final UTxO selection/ for that output minus the value /v/ of+--      that output.+--+--  4.  __Updates the /accumulated coin selection/__:+--+--       * Adds the /output/ to 'outputs'.+--       * Adds the /improved UTxO selection/ to 'inputs'.+--       * Adds the /change value/ to 'change'.+--+-- This phase ends when every output has been processed, __or__ when the+-- /remaining UTxO set/ has been exhausted, whichever occurs sooner.+--+-- = Termination+--+-- When both phases are complete, the algorithm terminates.+--+-- The /accumulated coin selection/ and /remaining UTxO set/ are returned to+-- the caller.+--+-- === Failure Modes+--+-- The algorithm terminates with an __error__ if:+--+--  1.  The /total value/ of the initial UTxO set (the amount of money+--      /available/) is /less than/ the total value of the output list (the+--      amount of money /required/).+--+--      See: __'InputValueInsufficientError'__.+--+--  2.  The /number/ of entries in the initial UTxO set is /smaller than/ the+--      number of requested outputs.+--+--      Due to the nature of the algorithm, /at least one/ UTxO entry is+--      required /for each/ output.+--+--      See: __'InputCountInsufficientError'__.+--+--  3.  Due to the particular /distribution/ of values within the initial UTxO+--      set, the algorithm depletes all entries from the UTxO set /before/ it+--      is able to pay for all requested outputs.+--+--      See: __'InputsExhaustedError'__.+--+--  4.  The /number/ of UTxO entries needed to pay for the requested outputs+--      would /exceed/ the upper limit specified by 'limit'.+--+--      See: __'InputLimitExceededError'__.+--+-- = Motivating Principles+--+-- There are several motivating principles behind the design of the algorithm.+--+-- === Principle 1: Dust Management+--+-- The probability that random selection will choose dust entries from a UTxO+-- set increases with the proportion of dust in the set.+--+-- Therefore, for a UTxO set with a large amount of dust, there's a high+-- probability that a random subset will include a large amount of dust.+--+-- === Principle 2: Change Management+--+-- Ideally, coin selection algorithms should, over time, create a UTxO set that+-- has /useful/ outputs: outputs that will allow us to process future payments+-- with a minimum number of inputs.+--+-- If for each payment request of value __/v/__ we create a change output of+-- /roughly/ the same value __/v/__, then we will end up with a distribution of+-- change values that matches the typical value distribution of payment+-- requests.+--+-- === Principle 3: Performance Management+--+-- Searching the UTxO set for additional entries to improve our change outputs+-- is /only/ useful if the UTxO set contains entries that are sufficiently+-- small enough. But it is precisely when the UTxO set contains many small+-- entries that it is less likely for a randomly-chosen UTxO entry to push the+-- total above the upper bound.+--+-- @since 1.0.0+randomImprove+    :: (Ord i, Ord o, MonadRandom m)+    => CoinSelectionAlgorithm i o m+randomImprove = CoinSelectionAlgorithm payForOutputs++payForOutputs+    :: (Ord i, Ord o, MonadRandom m)+    => CoinSelectionParameters i o+    -> ExceptT CoinSelectionError m (CoinSelectionResult i o)+payForOutputs params = do+    mRandomSelections <- lift $ runMaybeT $ foldM makeRandomSelection+        (inputCountMax, inputsAvailable params, []) outputsDescending+    case mRandomSelections of+        Just (inputCountRemaining, utxoRemaining, randomSelections) -> do+            (_, finalSelection, utxoRemaining') <- lift $ foldM+                improveSelection+                    (inputCountRemaining, mempty, utxoRemaining)+                    (reverse randomSelections)+            pure $ CoinSelectionResult finalSelection utxoRemaining'+        Nothing ->+            throwE errorCondition+  where+    errorCondition+      | amountAvailable < amountRequested =+          InputValueInsufficient $+              InputValueInsufficientError+                  amountAvailable amountRequested+      | utxoCount < outputCount =+          InputCountInsufficient $+              InputCountInsufficientError+                  utxoCount outputCount+      | utxoCount <= fromIntegral inputCountMax =+          InputsExhausted+              InputsExhaustedError+      | otherwise =+          InputLimitExceeded $+              InputLimitExceededError $+                  fromIntegral inputCountMax+    amountAvailable =+        coinMapValue $ inputsAvailable params+    amountRequested =+        coinMapValue $ outputsRequested params+    inputCountMax =+        fromIntegral $ calculateLimit (limit params) $ fromIntegral outputCount+    outputCount =+        fromIntegral $ length $ coinMapToList $ outputsRequested params+    outputsDescending =+        L.sortOn (Down . entryValue) $ coinMapToList $ outputsRequested params+    utxoCount =+        fromIntegral $ L.length $ coinMapToList $ inputsAvailable params++-- | Randomly select entries from the given UTxO set, until the total value of+--   selected entries is greater than or equal to the given output value.+--+-- Once a random selection has been made that meets the above criterion, this+-- function returns that selection as is, making no attempt to improve upon+-- the selection in any way.+--+makeRandomSelection+    :: forall i o m . MonadRandom m+    => (Integer, CoinMap i, [([CoinMapEntry i], CoinMapEntry o)])+    -> CoinMapEntry o+    -> MaybeT m (Integer, CoinMap i, [([CoinMapEntry i], CoinMapEntry o)])+makeRandomSelection+    (inputCountRemaining, utxoRemaining, existingSelections) txout = do+        (utxoSelected, utxoRemaining') <- coverRandomly ([], utxoRemaining)+        return+            ( inputCountRemaining - fromIntegral (L.length utxoSelected)+            , utxoRemaining'+            , (utxoSelected, txout) : existingSelections+            )+  where+    coverRandomly+        :: ([CoinMapEntry i], CoinMap i)+        -> MaybeT m ([CoinMapEntry i], CoinMap i)+    coverRandomly (selected, remaining)+        | L.length selected > fromIntegral inputCountRemaining =+            MaybeT $ return Nothing+        | sumEntries selected >= targetMin (mkTargetRange txout) =+            MaybeT $ return $ Just (selected, remaining)+        | otherwise =+            utxoPickRandomT remaining >>= \(picked, remaining') ->+                coverRandomly (picked : selected, remaining')++-- | Perform an improvement to random selection on a given output.+improveSelection+    :: forall i o m . (MonadRandom m, Ord i, Ord o)+    => (Integer, CoinSelection i o, CoinMap i)+    -> ([CoinMapEntry i], CoinMapEntry o)+    -> m (Integer, CoinSelection i o, CoinMap i)+improveSelection (maxN0, selection, utxo0) (inps0, txout) = do+    (maxN, inps, utxo) <- improve (maxN0, inps0, utxo0)+    return+        ( maxN+        , selection <> CoinSelection+            { inputs = coinMapFromList inps+            , outputs = coinMapFromList [txout]+            , change = mkChange txout inps+            }+        , utxo+        )+  where+    target = mkTargetRange txout++    improve+        :: (Integer, [CoinMapEntry i], CoinMap i)+        -> m (Integer, [CoinMapEntry i], CoinMap i)+    improve (maxN, inps, utxo)+        | maxN >= 1 && sumEntries inps < targetAim target = do+            runMaybeT (utxoPickRandomT utxo) >>= \case+                Nothing ->+                    return (maxN, inps, utxo)+                Just (io, utxo') | isImprovement io inps -> do+                    let inps' = io : inps+                    let maxN' = maxN - 1+                    improve (maxN', inps', utxo')+                Just _ ->+                    return (maxN, inps, utxo)+        | otherwise =+            return (maxN, inps, utxo)++    isImprovement :: CoinMapEntry i -> [CoinMapEntry i] -> Bool+    isImprovement io selected =+        let+            condA = -- (a) It doesn’t exceed a specified upper limit.+                sumEntries (io : selected) < targetMax target++            condB = -- (b) Addition gets us closer to the ideal change+                distanceA < distanceB+              where+                distanceA = C.distance+                    (targetAim target)+                    (sumEntries (io : selected))+                distanceB = C.distance+                    (targetAim target)+                    (sumEntries selected)++            -- (c) Doesn't exceed maximum number of inputs+            -- Guaranteed by the precondition on 'improve'.+        in+            condA && condB++--------------------------------------------------------------------------------+-- Internals+--------------------------------------------------------------------------------++-- | Represents a target range of /total input values/ for a given output.+--+-- In this context, /total input value/ refers to the total value of a set of+-- inputs selected to pay for a given output.+--+data TargetRange = TargetRange+    { targetMin :: Coin+        -- ^ The minimum value, corresponding to exactly the requested target+        -- amount, and a change amount of zero.+    , targetAim :: Coin+        -- ^ The ideal value, corresponding to exactly twice the requested+        -- target amount, and a change amount equal to the requested amount.+    , targetMax :: Coin+        -- ^ The maximum value, corresponding to exactly three times the+        -- requested amount, and a change amount equal to twice the requested+        -- amount.+    }++-- | Compute the target range of /total input values/ for a given output.+--+-- See 'TargetRange'.+--+mkTargetRange :: CoinMapEntry o -> TargetRange+mkTargetRange (CoinMapEntry _ c) = TargetRange+    { targetMin = c+    , targetAim = c `C.add` c+    , targetMax = c `C.add` c `C.add` c+    }++-- | Re-wrap 'utxoPickRandom' in a 'MaybeT' monad+utxoPickRandomT+    :: MonadRandom m+    => CoinMap i+    -> MaybeT m (CoinMapEntry i, CoinMap i)+utxoPickRandomT =+    MaybeT+        . fmap (\(mi, u) -> (, u) <$> mi)+        . coinMapRandomEntry++-- | Compute change outputs from a target output and a selection of inputs.+--+-- Pre-condition:+--+-- The output must be less than (or equal to) the sum of the inputs.+--+mkChange :: CoinMapEntry o -> [CoinMapEntry i] -> [Coin]+mkChange (CoinMapEntry _ out) inps =+    case difference of+        Nothing ->+            error $ mconcat+                [ "mkChange: "+                , "output must be less than or equal to sum of inputs"+                ]+        Just d | C.isZero d ->+            []+        Just d ->+            [d]+  where+    difference = sumEntries inps `C.sub` out++--------------------------------------------------------------------------------+-- Utilities+--------------------------------------------------------------------------------++sumEntries :: [CoinMapEntry i] -> Coin+sumEntries = mconcat . fmap entryValue

@@ -0,0 +1,713 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_HADDOCK prune #-}++-- |+-- Copyright: © 2018-2020 IOHK+-- License: Apache-2.0+--+-- Provides functionality for __adjusting__ coin selections in order to pay for+-- transaction __fees__.+--+module Cardano.CoinSelection.Fee+    (+      -- * Fundamental Types+      Fee (..)+    , FeeEstimator (..)++      -- * Fee Adjustment+    , adjustForFee+    , FeeOptions (..)+    , FeeBalancingPolicy (..)+    , FeeAdjustmentError (..)++      -- * Dust Processing+    , DustThreshold (..)+    , coalesceDust++      -- # Internal Functions+    , calculateFee+    , distributeFee+    , reduceChangeOutputs+    , splitCoin++    ) where++import Prelude hiding+    ( round )++import Cardano.CoinSelection+    ( CoinMap (..)+    , CoinMapEntry (..)+    , CoinSelection (..)+    , coinMapFromList+    , coinMapRandomEntry+    , sumChange+    , sumInputs+    , sumOutputs+    )+import Control.Monad.Trans.Class+    ( lift )+import Control.Monad.Trans.Except+    ( ExceptT (..), except, throwE )+import Control.Monad.Trans.State+    ( StateT (..), evalStateT )+import Crypto.Random.Types+    ( MonadRandom )+import Data.Function+    ( (&) )+import Data.List.NonEmpty+    ( NonEmpty ((:|)) )+import Data.Maybe+    ( fromMaybe )+import Data.Ord+    ( Down (..), comparing )+import Data.Ratio+    ( (%) )+import GHC.Generics+    ( Generic )+import Internal.Coin+    ( Coin )+import Internal.Invariant+    ( invariant )+import Internal.Rounding+    ( RoundingDirection (..), round )+import Quiet+    ( Quiet (Quiet) )++import qualified Data.Foldable as F+import qualified Data.List.NonEmpty as NE+import qualified Internal.Coin as C++--------------------------------------------------------------------------------+-- Fundamental Types+--------------------------------------------------------------------------------++-- | Represents a non-negative fee to be paid on a transaction.+--+-- @since 1.0.0+newtype Fee = Fee { unFee :: Coin }+    deriving newtype (Monoid, Semigroup)+    deriving stock (Eq, Generic, Ord)+    deriving Show via (Quiet Fee)++-- | Defines the /maximum/ size of a __dust coin__.+--+-- Functions that accept a 'DustThreshold' argument will generally exclude+-- values that are /less than or equal to/ this threshold from the 'change'+-- sets of generated selections, /coalescing/ such coins together into larger+-- coins that /exceed/ the threshold.+--+-- Specifying a dust threshold of __/n/__ causes all coins that are less than+-- or equal to __/n/__ to be treated as dust and coalesced together.+--+-- Specifying a dust threshold of __0__ completely /disables/ dust elimination+-- with the exception of zero-valued coins, which will always be eliminated.+--+-- See 'coalesceDust'.+--+-- @since 1.0.0+newtype DustThreshold = DustThreshold { unDustThreshold :: Coin }+    deriving stock (Eq, Generic, Ord)+    deriving Show via (Quiet DustThreshold)++-- | Provides a function capable of __estimating__ the transaction fee required+--   for a given coin selection, according to the rules of a particular+--   blockchain.+--+-- The fee estimate should be a function of the __current__ memberships of the+-- 'inputs', 'outputs', and 'change' sets.+--+-- Depending on the rules of the blockchain under consideration, the fee+-- estimate may take either (or both) of the following factors into account:+--+--   - the number of entries in each set;+--   - the coin value of each set member.+--+-- A fee estimate may differ from the final fee required for a selection, as+-- fees are generally paid for by /adjusting/ a given selection to make a /new/+-- selection. See 'adjustForFee' for more details of this process.+--+-- @since 1.0.0+newtype FeeEstimator i o = FeeEstimator+    { estimateFee :: CoinSelection i o -> Fee+    } deriving Generic++--------------------------------------------------------------------------------+-- Fee Adjustment+--------------------------------------------------------------------------------++-- | Provides options for fee adjustment.+--+-- @since 1.0.0+data FeeOptions i o = FeeOptions+    { feeEstimator+        :: FeeEstimator i o+        -- ^ Estimate fees based on selected inputs and requested outputs.++    , dustThreshold+        :: DustThreshold+        -- ^ The threshold to use for dust elimination. Specifying a threshold+        -- of zero will disable dust elimination. See 'DustThreshold' for more+        -- details.++    , feeBalancingPolicy+        :: FeeBalancingPolicy+        -- ^ Which fee balancing policy to use.+    } deriving Generic++-- | A choice of fee balancing policies for use when adjusting a coin selection.+--+-- == Background+--+-- A coin selection __'s'__ is said to have a /perfectly-balanced/ fee when it+-- satisfies the following property:+--+-- >>> sumInputs s = sumOutputs s + sumChange s + estimateFee s+--+-- Conversely, a selection is said to have an /unbalanced/ fee when it+-- satisfies the following property:+--+-- >>> sumInputs s > sumOutputs s + sumChange s + estimateFee s+--+-- In other words, if a coin selection has an /unbalanced/ fee, the /effective/+-- fee is greater than the minimum fee /actually required/ by the blockchain.+--+-- == Balanced Fees vs Minimal Fees+--+-- Some blockchains /require /that fees are always /perfectly-balanced/.+--+-- However, for blockchains that allow /unbalanced/ fees, it is sometimes+-- possible to /save money/ by generating a coin selection with an unbalanced+-- fee. This may seem counterintuitive at first, but consider an individual+-- change ouput __/c/__ of value __/v/__. If the /marginal fee/ __/f/__+-- associated with __/c/__ is greater than its value __/v/__, then we will+-- /save money/ by __not__ including __/c/__ within 'change'.+--+-- There are two policy choices available for handling change values with+-- marginal fees greater than their value:+--+--   - For blockchains that __allow__ transactions with /unbalanced/ fees,+--     specifying the 'RequireMinimalFee' policy will allow money to be saved by+--     /excluding/ change outputs that have a marginal fee greater than+--     their value.+--+--   - For blockchains that do __not__ allow transactions with /unbalanced/+--     fees, specifying the 'RequireBalancedFee' policy will always generate+--     selections with fees that are perfectly-balanced, even if the resulting+--     fees are higher than could be achieved by allowing unbalanced fees.+--+data FeeBalancingPolicy+    = RequireBalancedFee+        -- ^ Generate selections with fees that are perfectly balanced, with the+        -- trade-off of allowing slightly higher fees.+    | RequireMinimalFee+        -- ^ Generate selections with the lowest fees possible, with the+        -- trade-off of allowing slightly imbalanced fees.+    deriving (Generic, Show, Eq)++-- | Represents the set of possible failures that can occur when adjusting a+--   'CoinSelection' with the 'adjustForFee' function.+--+data FeeAdjustmentError i o+    = CannotCoverFee Fee+    -- ^ Indicates that the given map of additional inputs was exhausted while+    --   attempting to select extra inputs to cover the required fee.+    --+    -- Records the shortfall (__/f/__ − __/s/__) between the required fee+    -- __/f/__ and the total value __/s/__ of currently-selected inputs.++    | CoinSelectionUnderfunded (CoinSelection i o)+    -- ^ Indicates that the given coin selection is __underfunded__: the total+    -- value of 'inputs' is less than the total value of 'outputs', as+    -- calculated by the 'CoinSelection.coinMapValue' function.+    deriving (Show, Eq)++-- | Adjusts the given 'CoinSelection' in order to pay for a __transaction__+--   __fee__, required in order to publish the selection as a transaction on+--   a blockchain.+--+-- == Background+--+-- Implementations of 'Cardano.CoinSelection.CoinSelectionAlgorithm' generally+-- produce coin selections that are /exactly balanced/, satisfying the+-- following equality:+--+-- >>> sumInputs s = sumOutputs s + sumChange s+--+-- In order to pay for a transaction fee, the above equality must be+-- transformed into an /inequality/:+--+-- >>> sumInputs s > sumOutputs s + sumChange s+--+-- The difference between these two sides represents value to be paid /by the/+-- /originator/ of the transaction, in the form of a fee:+--+-- >>> sumInputs s = sumOutputs s + sumChange s + fee+--+-- == The Adjustment Process+--+-- In order to generate a fee that is acceptable to the network, this function+-- adjusts the 'change' and 'inputs' of the given 'CoinSelection', consulting+-- the 'FeeEstimator' as a guide for how much the current selection would cost+-- to publish as a transaction on the network.+--+-- == Methods of Adjustment+--+-- There are two methods of adjustment possible:+--+--  1. The __'change'__ set can be /reduced/, either by:+--+--      a. completely removing a change value from the set; or by+--+--      b. reducing a change value to a lower value.+--+--  2. The __'inputs'__ set can be /augmented/, by selecting additional inputs+--     from the specified 'CoinMap' argument.+--+-- == Dealing with Dust Values+--+-- If, at any point, a change value is generated that is less than or equal+-- to the 'DustThreshold', this function will eliminate that change value+-- from the 'change' set, redistributing the eliminated value over the remaining+-- change values, ensuring that the total value of all 'change' is preserved.+--+-- See 'coalesceDust' for more details.+--+-- == Termination+--+-- Since adjusting a selection can affect the fee estimate produced by+-- 'estimateFee', the process of adjustment is an /iterative/ process.+--+-- The termination post-condition depends on the choice of+-- 'FeeBalancingPolicy':+--+--   - If 'RequireBalancedFee' is specified, this function terminates+--     only when it has generated a 'CoinSelection' __'s'__ that satisfies the+--     following property:+--+--         >>> sumInputs s = sumOutputs s + sumChange s + estimateFee s+--+--   - If 'RequireMinimalFee' policy is specified, the above /equality/+--     is relaxed to the following /inequality/:+--+--         >>> sumInputs s ≥ sumOutputs s + sumChange s + estimateFee s+--+-- See 'FeeBalancingPolicy' for more details.+--+-- @since 1.0.0+adjustForFee+    :: (Ord i, MonadRandom m)+    => FeeOptions i o+    -> CoinMap i+    -> CoinSelection i o+    -> ExceptT (FeeAdjustmentError i o) m (CoinSelection i o)+adjustForFee unsafeOpt utxo coinSel = do+    let opt = invariant+            "adjustForFee: fee must be non-null" unsafeOpt (not . nullFee)+    senderPaysFee opt utxo coinSel+  where+    nullFee opt = estimateFee (feeEstimator opt) coinSel == Fee C.zero++--------------------------------------------------------------------------------+-- Internal Functions+--------------------------------------------------------------------------------++-- Calculates the current fee associated with a given 'CoinSelection'.+--+-- If the result is less than zero, returns 'Nothing'.+--+calculateFee :: CoinSelection i o -> Maybe Fee+calculateFee s = Fee <$> sumInputs s `C.sub` (sumOutputs s `C.add` sumChange s)++-- The sender pays fee in this scenario, so fees are removed from the change+-- outputs, and new inputs are selected if necessary.+--+senderPaysFee+    :: forall i o m . (Ord i, MonadRandom m)+    => FeeOptions i o+    -> CoinMap i+    -> CoinSelection i o+    -> ExceptT (FeeAdjustmentError i o) m (CoinSelection i o)+senderPaysFee opts utxo sel =+    evalStateT (go sel) utxo+  where+    go+        :: CoinSelection i o+        -> StateT+            (CoinMap i)+            (ExceptT (FeeAdjustmentError i o) m)+            (CoinSelection i o)+    go coinSel@(CoinSelection inps outs chgs) = do+        -- Substract fee from change outputs, proportionally to their value.+        (coinSel', remFee) <- lift $ except $ reduceChangeOutputs opts coinSel++        -- Should the change cover the fee, we're (almost) good. By removing+        -- change outputs, we make them smaller and may reduce the size of the+        -- transaction, and the fee. Thus, we end up paying slightly more than+        -- the upper bound. We could do some binary search and try to+        -- re-distribute excess across changes until fee becomes bigger.+        if remFee == Fee C.zero+        then pure coinSel'+        else do+            -- Otherwise, we need an extra entries from the available utxo to+            -- cover what's left. Note that this entry may increase our change+            -- because we may not consume it entirely. So we will just split+            -- the extra change across all changes possibly increasing the+            -- number of change outputs (if there was none, or if increasing a+            -- change value causes an overflow).+            --+            -- Because selecting a new input increases the fee, we need to+            -- re-run the algorithm with this new elements and using the initial+            -- change plus the extra change brought up by this entry and see if+            -- we can now correctly cover fee.+            inps' <- coverRemainingFee remFee+            let extraChange = splitCoin (sumEntries inps') chgs+            go $ CoinSelection (inps <> coinMapFromList inps') outs extraChange++-- A short and simple version of the 'random' fee policy to cover for the fee+-- in the case where existing set of change is not enough.+--+coverRemainingFee+    :: MonadRandom m+    => Fee+    -> StateT (CoinMap i) (ExceptT (FeeAdjustmentError i o) m) [CoinMapEntry i]+coverRemainingFee (Fee fee) = go [] where+    go acc+        | sumEntries acc >= fee =+            return acc+        | otherwise = do+            -- We ignore the size of the fee, and just pick randomly+            StateT (lift . coinMapRandomEntry) >>= \case+                Just entry ->+                    go (entry : acc)+                Nothing ->+                    lift $ throwE $ CannotCoverFee $ Fee $+                        fee `C.distance` (sumEntries acc)++-- Pays for the given fee by subtracting it from the given list of change+-- outputs, so that each change output is reduced by a portion of the fee+-- that's in proportion to its relative size.+--+-- == Basic Examples+--+-- >>> reduceChangeOutputs (DustThreshold 0) (Fee 4) (Coin <$> [2, 2, 2, 2])+-- [Coin 1, Coin 1, Coin 1, Coin 1]+--+-- >>> reduceChangeOutputs (DustThreshold 0) (Fee 15) (Coin <$> [2, 4, 8, 16])+-- [Coin 1, Coin 2, Coin 4, Coin 8]+--+-- == Handling Dust+--+-- Any dust outputs in the resulting list are coalesced according to the given+-- dust threshold: (See 'coalesceDust'.)+--+-- >>> reduceChangeOutputs (DustThreshold 1) (Fee 4) (Coin <$> [2, 2, 2, 2])+-- [Coin 4]+--+-- == Handling Insufficient Change+--+-- If there's not enough change to pay for the fee, or if there's only just+-- enough to pay for it exactly, this function returns the /empty list/:+--+-- >>> reduceChangeOutputs (DustThreshold 0) (Fee 15) (Coin <$> [10])+-- []+--+-- >>> reduceChangeOutputs (DustThreshold 0) (Fee 15) (Coin <$> [1, 2, 4, 8])+-- []+--+reduceChangeOutputs+    :: FeeOptions i o+    -> CoinSelection i o+    -> Either (FeeAdjustmentError i o) (CoinSelection i o, Fee)+reduceChangeOutputs opts s = do+    -- The original requested fee amount+    let Fee φ_original = estimateFee (feeEstimator opts) s+    -- The initial amount left for fee (i.e. inputs - outputs)+    let mδ_original = sumInputs s `C.sub` (sumOutputs s `C.add` sumChange s)+    case mδ_original of+        -- selection is now balanced, nothing to do.+        Just δ_original | φ_original == δ_original -> do+            pure (s, Fee C.zero)++        -- some fee left to pay, but we've depleted all change outputs+        Just δ_original | φ_original > δ_original && null (change s) -> do+            let remainder = φ_original `C.distance` δ_original+            pure (s, Fee remainder)++        -- some fee left to pay, and we've haven't depleted all change yet+        Just δ_original | φ_original > δ_original && not (null (change s)) -> do+            let remainder = φ_original `C.distance` δ_original+            let chgs' = distributeFee (Fee remainder) (NE.fromList (change s))+                      & fmap payFee+                      & coalesceDust (dustThreshold opts)+            reduceChangeOutputs opts (s { change = chgs' })++        -- The current selection has a higher fee than necessary. This typically+        -- occurs if, after reducing an output to pay for the predicted fee, the+        -- required fee turns out to be less than originally predicted.+        -- The outcome depends on whether or not the node allows transactions+        -- to be unbalanced.+        Just δ_original | δ_original > φ_original -> do+            let extraChg = δ_original `C.distance` φ_original+            let sDangling = s { change = splitCoin extraChg (change s) }+            let Fee φ_dangling = estimateFee (feeEstimator opts) sDangling+            -- We have `δ_dangling = φ_original` by construction of sDangling.+            --+            -- Proof:+            --+            -- δ_dangling = Σi_dangling - (Σo_dangling + Σc_dangling)+            --            = Σi_original - (Σo_original + Σc_original + extraChg)+            --            = Σi_original - (Σo_original + Σc_original) - extraChg+            --            = δ_original - extraChg+            --            = δ_original - (δ_original - φ_original)+            --            = φ_original+            let δ_dangling = φ_original+            case φ_dangling `C.sub` δ_dangling of+                -- we've left too much, but adding a change output would be more+                -- expensive than not having it. Here we have two choices:+                --+                -- a) If the node allows unbalanced transaction, we can stop+                --    here and do nothing. We'll leave slightly more than what's+                --    needed for fees, but having an extra change output isn't+                --    worth it anyway.+                --+                -- b) If we __must__ balance the transaction, then we can choose+                --    to pay the extra cost by adding the change output and+                --    continue trying to balance the transaction (likely, by+                --    selecting another input).+                Just remainder | φ_dangling >= δ_original ->+                    case feeBalancingPolicy opts of+                        RequireMinimalFee ->+                            pure (s, Fee C.zero)+                        RequireBalancedFee ->+                            pure (sDangling, Fee remainder)++                -- If however, adding the dangling change doesn't cost more than+                -- not having it, we might as well add it to get the money and+                -- continue balancing!+                _otherwise ->+                    reduceChangeOutputs opts sDangling++        -- The only way to end-up here is if the user has provided an invalid+        -- selection where outputs are trying to spend more than inputs. This is+        -- simply forbidden.+        _Nothing ->+            Left (CoinSelectionUnderfunded s)++-- Distribute the given fee over the given list of coins, so that each coin+-- is allocated a __fraction__ of the fee in proportion to its relative size.+--+-- == Pre-condition+--+-- Every coin in the given list must be __non-zero__ in value.+--+-- == Examples+--+-- >>> distributeFee (Fee 2) [(Coin 1), (Coin 1)]+-- [(Fee 1, Coin 1), (Fee 1, Coin 1)]+--+-- >>> distributeFee (Fee 4) [(Coin 1), (Coin 1)]+-- [(Fee 2, Coin 1), (Fee 2, Coin 1)]+--+-- >>> distributeFee (Fee 7) [(Coin 1), (Coin 2), (Coin 4)]+-- [(Fee 1, Coin 1), (Fee 2, Coin 2), (Fee 4, Coin 4)]+--+-- >>> distributeFee (Fee 14) [(Coin 1), (Coin 2), (Coin 4)]+-- [(Fee 2, Coin 1), (Fee 4, Coin 2), (Fee 8, Coin 4)]+--+distributeFee :: Fee -> NonEmpty Coin -> NonEmpty (Fee, Coin)+distributeFee (Fee feeTotal) coinsUnsafe =+    NE.zip feesRounded coins+  where+    -- A list of coins that are non-zero in value.+    coins :: NonEmpty Coin+    coins =+        invariant "distributeFee: all coins must be non-zero in value."+        coinsUnsafe (C.zero `F.notElem`)++    -- A list of rounded fee portions, where each fee portion deviates from the+    -- ideal unrounded portion by as small an amount as possible.+    feesRounded :: NonEmpty Fee+    feesRounded+        -- 1. Start with the list of ideal unrounded fee portions for each coin:+        = feesUnrounded+        -- 2. Attach an index to each fee portion, so that we can remember the+        --    original order:+        & NE.zip indices+        -- 3. Sort the fees into descending order of their fractional parts:+        & NE.sortBy (comparing (Down . fractionalPart . snd))+        -- 4. Apply pre-computed roundings to each fee portion:+        --    * portions with the greatest fractional parts are rounded up;+        --    * portions with the smallest fractional parts are rounded down.+        & NE.zipWith (\roundDir (i, f) -> (i, round roundDir f)) feeRoundings+        -- 5. Restore the original order:+        & NE.sortBy (comparing fst)+        -- 6. Strip away the indices:+        & fmap snd+        -- 7. Transform results into fees:+        & fmap (Fee . fromMaybe C.zero . C.coinFromIntegral @Integer)+      where+        indices :: NonEmpty Int+        indices = 0 :| [1 ..]++    -- A list of rounding directions, one per fee portion.+    --+    -- Since the ideal fee portion for each coin is a rational value, we must+    -- therefore round each rational value either /up/ or /down/ to produce a+    -- final integer result.+    --+    -- However, we can't take the simple approach of either rounding /all/ fee+    -- portions down or rounding /all/ fee portions up, as this could cause the+    -- sum of fee portions to either undershoot or overshoot the original fee.+    --+    -- So in order to hit the fee exactly, we must round /some/ of the portions+    -- up, and /some/ of the portions down.+    --+    -- Fortunately, we can calculate exactly how many fee portions must be+    -- rounded up, by first rounding /all/ portions down, and then computing+    -- the /shortfall/ between the sum of the rounded-down portions and the+    -- original fee.+    --+    -- We return a list where all values of 'RoundUp' occur in a contiguous+    -- section at the start of the list, of the following form:+    --+    --     [RoundUp, RoundUp, ..., RoundDown, RoundDown, ...]+    --+    feeRoundings :: NonEmpty RoundingDirection+    feeRoundings =+        applyN feeShortfall (NE.cons RoundUp) (NE.repeat RoundDown)+      where+         -- The part of the total fee that we'd lose if we were to take the+         -- simple approach of rounding all ideal fee portions /down/.+        feeShortfall+            = C.coinToIntegral feeTotal+            - fromIntegral @Integer (F.sum $ round RoundDown <$> feesUnrounded)++    -- A list of ideal unrounded fee portions, with one fee portion per coin.+    --+    -- A coin's ideal fee portion is the rational portion of the total fee that+    -- corresponds to that coin's relative size when compared to other coins.+    feesUnrounded :: NonEmpty Rational+    feesUnrounded = calculateIdealFee <$> coins+      where+        calculateIdealFee c+            = C.coinToIntegral c+            * C.coinToIntegral feeTotal+            % C.coinToIntegral totalCoinValue++    -- The total value of all coins.+    totalCoinValue :: Coin+    totalCoinValue = F.fold coins++-- | From the given list of coins, remove dust coins with a value less than or+--   equal to the given threshold value, redistributing their total value over+--   the coins that remain.+--+-- This function satisfies the following properties:+--+-- >>> sum coins = sum (coalesceDust threshold coins)+-- >>> all (/= Coin 0) (coalesceDust threshold coins)+--+coalesceDust :: DustThreshold -> NonEmpty Coin -> [Coin]+coalesceDust (DustThreshold threshold) coins =+    splitCoin valueToDistribute coinsToKeep+  where+    (coinsToKeep, coinsToRemove) = NE.partition (> threshold) coins+    valueToDistribute = F.fold coinsToRemove++-- Splits up the given coin of value __@v@__, distributing its value over the+-- given coin list of length __@n@__, so that each coin value is increased by+-- an integral amount within unity of __@v/n@__, producing a new list of coin+-- values where the overall total is preserved.+--+-- == Basic Examples+--+-- When it's possible to divide a coin evenly, each coin value is increased by+-- the same integer amount:+--+-- >>> splitCoin (Coin 40) (Coin <$> [1, 1, 1, 1])+-- [Coin 11, Coin 11, Coin 11, Coin 11]+--+-- >>> splitCoin (Coin 40) (Coin <$> [1, 2, 3, 4])+-- [Coin 11, Coin 12, Coin 13, Coin 14]+--+-- == Handling Non-Uniform Increases+--+-- When it's not possible to divide a coin evenly, each integral coin value in+-- the resulting list is always within unity of the ideal unrounded result:+--+-- >>> splitCoin (Coin 2) (Coin <$> [1, 1, 1, 1])+-- [Coin 1, Coin 1, Coin 2, Coin 2]+--+-- >>> splitCoin (Coin 10) (Coin <$> [1, 1, 1, 1])+-- [Coin 3, Coin 3, Coin 4, Coin 4]+--+-- == Handling Empty Lists+--+-- If the given list is empty, this function returns a list with the original+-- given coin as its sole element:+--+-- >>> splitCoin (Coin 10) []+-- [Coin 10]+--+-- == Properties+--+-- The total value is always preserved:+--+-- >>> sum (splitCoin x ys) == x + sum ys+--+splitCoin :: Coin -> [Coin] -> [Coin]+splitCoin coinToSplit coinsToIncrease =+    case (mIncrement, mShortfall) of+        (Just increment, Just shortfall) ->+            zipWith C.add coinsToIncrease increments+          where+            increments = zipWith C.add majorIncrements minorIncrements+            majorIncrements = repeat increment+            minorIncrements = replicate (C.coinToIntegral shortfall) C.one+                <> repeat C.zero+        _ | coinToSplit > C.zero ->+            [coinToSplit]+        _ ->+            []+  where+    mCoinCount = length coinsToIncrease+    mIncrement = coinToSplit `C.div` mCoinCount+    mShortfall = coinToSplit `C.mod` mCoinCount++-- Extract the fractional part of a rational number.+--+-- Examples:+--+-- >>> fractionalPart (3 % 2)+-- 1 % 2+--+-- >>> fractionalPart (11 % 10)+-- 1 % 10+--+fractionalPart :: Rational -> Rational+fractionalPart = snd . properFraction @_ @Integer++-- Apply the same function multiple times to a value.+--+applyN :: Int -> (a -> a) -> a -> a+applyN n f = F.foldr (.) id (replicate n f)++-- Find the sum of a list of entries.+--+sumEntries :: [CoinMapEntry i] -> Coin+sumEntries = F.fold . fmap entryValue++-- | Reduce a coin value by a given fee amount. If fees are too big for+-- a single coin, returns a `Coin 0`.+payFee :: (Fee, Coin) -> Coin+payFee (Fee f, c) = fromMaybe C.zero (c `C.sub` f)

@@ -0,0 +1,247 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeApplications #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Cardano.CoinSelection.Algorithm.LargestFirstSpec+    ( spec+    ) where++import Prelude++import Cardano.CoinSelection+    ( CoinMap (..)+    , CoinMapEntry (..)+    , CoinSelection (..)+    , CoinSelectionAlgorithm (..)+    , CoinSelectionError (..)+    , CoinSelectionLimit (..)+    , CoinSelectionParameters (..)+    , CoinSelectionResult (..)+    , InputCountInsufficientError (..)+    , InputLimitExceededError (..)+    , InputValueInsufficientError (..)+    , InputsExhaustedError (..)+    , coinMapToList+    )+import Cardano.CoinSelection.Algorithm.LargestFirst+    ( largestFirst )+import Cardano.CoinSelectionSpec+    ( CoinSelProp (..)+    , CoinSelectionFixture (..)+    , CoinSelectionTestResult (..)+    , coinSelectionUnitTest+    )+import Cardano.Test.Utilities+    ( Address, TxIn, excluding, unsafeCoin )+import Control.Monad+    ( unless )+import Control.Monad.Trans.Except+    ( runExceptT )+import Data.Either+    ( isRight )+import Data.Functor.Identity+    ( Identity (runIdentity) )+import Test.Hspec+    ( Spec, describe, it, shouldSatisfy )+import Test.QuickCheck+    ( Property, property, (==>) )++import qualified Data.List as L+import qualified Data.Map.Strict as Map+import qualified Data.Set as Set++spec :: Spec+spec = do+    describe "Coin selection: largest-first algorithm: unit tests" $ do++        coinSelectionUnitTest largestFirst ""+            (Right $ CoinSelectionTestResult+                { rsInputs = [17]+                , rsChange = []+                , rsOutputs = [17]+                })+            (CoinSelectionFixture+                { maxNumOfInputs = 100+                , utxoInputs = [10,10,17]+                , txOutputs = [17]+                })++        coinSelectionUnitTest largestFirst ""+            (Right $ CoinSelectionTestResult+                { rsInputs = [17]+                , rsChange = [16]+                , rsOutputs = [1]+                })+            (CoinSelectionFixture+                { maxNumOfInputs = 100+                , utxoInputs = [12,10,17]+                , txOutputs = [1]+                })++        coinSelectionUnitTest largestFirst ""+            (Right $ CoinSelectionTestResult+                { rsInputs = [12, 17]+                , rsChange = [11]+                , rsOutputs = [18]+                })+            (CoinSelectionFixture+                { maxNumOfInputs = 100+                , utxoInputs = [12,10,17]+                , txOutputs = [18]+                })++        coinSelectionUnitTest largestFirst ""+            (Right $ CoinSelectionTestResult+                { rsInputs = [10, 12, 17]+                , rsChange = [9]+                , rsOutputs = [30]+                })+            (CoinSelectionFixture+                { maxNumOfInputs = 100+                , utxoInputs = [12,10,17]+                , txOutputs = [30]+                })++        coinSelectionUnitTest largestFirst ""+            (Right $ CoinSelectionTestResult+                { rsInputs = [6,10,5]+                , rsChange = [5,4]+                , rsOutputs = [11,1]+                })+            (CoinSelectionFixture+                { maxNumOfInputs = 3+                , utxoInputs = [1,2,10,6,5]+                , txOutputs = [11, 1]+                })++        coinSelectionUnitTest largestFirst+            "UTxO balance not sufficient"+            (Left $ InputValueInsufficient $ InputValueInsufficientError+                (unsafeCoin @Int 39) (unsafeCoin @Int 40))+            (CoinSelectionFixture+                { maxNumOfInputs = 100+                , utxoInputs = [12,10,17]+                , txOutputs = [40]+                })++        coinSelectionUnitTest largestFirst+            "UTxO balance not sufficient, and not fragmented enough"+            (Left $ InputValueInsufficient $ InputValueInsufficientError+                (unsafeCoin @Int 39) (unsafeCoin @Int 43))+            (CoinSelectionFixture+                { maxNumOfInputs = 100+                , utxoInputs = [12,10,17]+                , txOutputs = [40,1,1,1]+                })++        coinSelectionUnitTest largestFirst+            "UTxO balance sufficient, but not fragmented enough"+            (Left $ InputCountInsufficient $ InputCountInsufficientError 3 4)+            (CoinSelectionFixture+                { maxNumOfInputs = 100+                , utxoInputs = [12,20,17]+                , txOutputs = [40,1,1,1]+                })++        coinSelectionUnitTest largestFirst+            "UTxO balance sufficient, fragmented enough, but single output \+            \depletes all UTxO entries"+            (Left (InputsExhausted InputsExhaustedError))+            (CoinSelectionFixture+                { maxNumOfInputs = 100+                , utxoInputs = [12,20,17]+                , txOutputs = [40, 1]+                })++        coinSelectionUnitTest largestFirst+            "UTxO balance sufficient, fragmented enough, but single output \+            \depletes all UTxO entries"+            (Left (InputsExhausted InputsExhaustedError))+            (CoinSelectionFixture+                { maxNumOfInputs = 100+                , utxoInputs = [20,20,10,5]+                , txOutputs = [41, 6]+                })++        coinSelectionUnitTest largestFirst+            "UTxO balance sufficient, fragmented enough, but maximum input \+            \count exceeded"+            (Left $ InputLimitExceeded $ InputLimitExceededError 9)+            (CoinSelectionFixture+                { maxNumOfInputs = 9+                , utxoInputs = replicate 100 1+                , txOutputs = replicate 100 1+                })++        coinSelectionUnitTest largestFirst+            "UTxO balance sufficient, fragmented enough, but maximum input \+            \count exceeded"+            (Left $ InputLimitExceeded $ InputLimitExceededError 9)+            (CoinSelectionFixture+                { maxNumOfInputs = 9+                , utxoInputs = replicate 100 1+                , txOutputs = replicate 10 10+                })++        coinSelectionUnitTest largestFirst+            "UTxO balance sufficient, fragmented enough, but maximum input \+            \count exceeded"+            (Left $ InputLimitExceeded $ InputLimitExceededError 2)+            (CoinSelectionFixture+                { maxNumOfInputs = 2+                , utxoInputs = [1,2,10,6,5]+                , txOutputs = [11, 1]+                })++    describe "Coin selection: largest-first algorithm: properties" $ do++        it "forall (UTxO, NonEmpty TxOut), there's at least as many selected \+            \inputs as there are requested outputs"+            (property $ propAtLeast @TxIn @Address)+        it "forall (UTxO, NonEmpty TxOut), for all selected input, there's no \+            \bigger input in the UTxO that is not already in the selected \+            \inputs"+            (property $ propInputDecreasingOrder @TxIn @Address)++--------------------------------------------------------------------------------+-- Properties+--------------------------------------------------------------------------------++propAtLeast+    :: (Ord i, Ord o)+    => CoinSelProp i o+    -> Property+propAtLeast (CoinSelProp utxo txOuts) =+    isRight selection ==>+        let Right (CoinSelectionResult s _) = selection in+        prop s+  where+    prop (CoinSelection inps _ _) =+        length inps `shouldSatisfy` (>= length txOuts)+    selection = runIdentity $ runExceptT $ selectCoins largestFirst+        $ CoinSelectionParameters utxo txOuts selectionLimit+    selectionLimit = CoinSelectionLimit $ const 100++propInputDecreasingOrder+    :: (Ord i, Ord o)+    => CoinSelProp i o+    -> Property+propInputDecreasingOrder (CoinSelProp utxo txOuts) =+    isRight selection ==>+        let Right (CoinSelectionResult s _) = selection in+        prop s+  where+    prop (CoinSelection inps _ _) =+        let+            utxo' = (Map.toList . unCoinMap) $ utxo `excluding`+                Set.fromList (entryKey <$> coinMapToList inps)+        in unless (L.null utxo') $+            (L.minimum (entryValue <$> coinMapToList inps))+            `shouldSatisfy`+            (>= (L.maximum (snd <$> utxo')))+    selection = runIdentity+        $ runExceptT+        $ selectCoins largestFirst+        $ CoinSelectionParameters utxo txOuts selectionLimit+    selectionLimit = CoinSelectionLimit $ const 100

@@ -0,0 +1,339 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}++{-# OPTIONS_GHC -fno-warn-orphans #-}++module Cardano.CoinSelection.Algorithm.MigrationSpec+    ( spec+    ) where++import Prelude++import Cardano.CoinSelection+    ( CoinMap (..)+    , CoinMapEntry (..)+    , CoinSelection (..)+    , coinMapToList+    , coinMapValue+    , sumChange+    , sumInputs+    )+import Cardano.CoinSelection.Algorithm.Migration+    ( BatchSize (..), idealBatchSize, selectCoins )+import Cardano.CoinSelection.Fee+    ( DustThreshold (..)+    , Fee (..)+    , FeeBalancingPolicy (..)+    , FeeEstimator (..)+    , FeeOptions (..)+    )+import Cardano.CoinSelection.FeeSpec+    ( FeeParameters, stableEstimator )+import Cardano.CoinSelectionSpec+    ()+import Cardano.Test.Utilities+    ( Address+    , Hash (..)+    , TxIn (..)+    , unsafeCoin+    , unsafeDustThreshold+    , unsafeFee+    )+import Data.ByteString+    ( ByteString )+import Data.Function+    ( (&) )+import Internal.Coin+    ( Coin, coinToIntegral )+import Numeric.Natural+    ( Natural )+import Test.Hspec+    ( Spec, SpecWith, describe, it, shouldSatisfy )+import Test.QuickCheck+    ( Arbitrary (..)+    , Gen+    , Property+    , arbitrarySizedIntegral+    , choose+    , conjoin+    , counterexample+    , frequency+    , label+    , property+    , scale+    , vectorOf+    , withMaxSuccess+    , (===)+    )+import Test.QuickCheck.Monadic+    ( monadicIO, monitor, pick )++import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as B8+import qualified Data.Map as Map+import qualified Data.Set as Set+import qualified Internal.Coin as C++spec :: Spec+spec = do+    describe "idealBatchSize" $ do+        it "Eventually converge for decreasing functions" $ do+            property $ \coinselOpts -> do+                let batchSize = idealBatchSize coinselOpts+                label (show batchSize) True++    describe "accuracy of selectCoins" $ do+        let testAccuracy :: Double -> SpecWith ()+            testAccuracy r = it title $ withMaxSuccess 1000 $ monadicIO $ do+                let dust = unsafeCoin @Int 100+                utxo <- pick (genUTxO r dust)+                batchSize <- pick genBatchSize+                feeOpts <- pick (genFeeOptions dust)+                let selections = selectCoins feeOpts batchSize utxo+                monitor $ label $ accuracy dust+                    (coinToIntegral $ coinMapValue utxo)+                    (sum $ coinToIntegral . sumInputs <$> selections)+              where+                title :: String+                title = "dust=" <> show (round (100 * r) :: Int) <> "%"++                accuracy :: Coin -> Natural -> Natural -> String+                accuracy dust sup real+                    | a >= 1.0 =+                        "PERFECT  (== 100%)"+                    | a > 0.99 || (sup - real) < coinToIntegral dust =+                        "OKAY     (>   99%)"+                    | otherwise =+                        "MEDIOCRE (<=  99%)"+                  where+                    a = double real / double sup+                    double = fromRational @Double . fromIntegral++        mapM_ testAccuracy [ 0.01 , 0.05 , 0.10 , 0.25 , 0.50 ]++    describe "selectCoins properties" $ do+        it "No coin selection has outputs" $+            property $ withMaxSuccess 10000 $ prop_onlyChangeOutputs+                @(Wrapped TxIn) @Address++        it "Every coin in the selection change >= minimum threshold coin" $+            property $ withMaxSuccess 10000 $ prop_noLessThanThreshold+                @(Wrapped TxIn) @Address++        it "Total input UTxO value >= sum of selection change coins" $+            property $ withMaxSuccess 10000 $ prop_inputsGreaterThanOutputs+                @(Wrapped TxIn) @Address++        it "Every selection input is unique" $+            property $ withMaxSuccess 10000 $ prop_inputsAreUnique+                @(Wrapped TxIn) @Address++        it "Every selection input is a member of the UTxO" $+            property $ withMaxSuccess 10000 $ prop_inputsStillInUTxO+                @(Wrapped TxIn) @Address++        it "Every coin selection is well-balanced" $+            property $ withMaxSuccess 10000 $ prop_wellBalanced+                @(Wrapped TxIn) @Address++    describe "selectCoins regressions" $ do+        it "regression #1" $ do+            let feeOpts = FeeOptions+                    { dustThreshold = unsafeDustThreshold @Int 9+                    , feeEstimator = FeeEstimator $ \s -> unsafeFee @Int+                        $ fromIntegral+                        $ 5 * (length (inputs s) + length (outputs s))+                    , feeBalancingPolicy = RequireBalancedFee+                    }+            let batchSize = BatchSize 1+            let utxo = CoinMap $ Map.fromList+                    [ ( TxIn+                        { txinId = Hash "|\243^\SUBg\242\231\&1\213\203"+                        , txinIx = 2+                        }+                      , unsafeCoin @Int 2+                      )+                    ]+            property $ prop_inputsGreaterThanOutputs+                @TxIn @Address feeOpts batchSize utxo++--------------------------------------------------------------------------------+-- Properties+--------------------------------------------------------------------------------++-- | No coin selection has outputs+prop_onlyChangeOutputs+    :: forall i o . (Ord i, Ord o, Show o)+    => FeeOptions i o+    -> BatchSize+    -> CoinMap i+    -> Property+prop_onlyChangeOutputs feeOpts batchSize utxo = do+    let allOutputs =+            coinMapToList . outputs =<< selectCoins feeOpts batchSize utxo+    property (allOutputs `shouldSatisfy` null)++-- | Every coin in the selection change >= minimum threshold coin+prop_noLessThanThreshold+    :: forall i o . (Ord i, Ord o)+    => FeeOptions i o+    -> BatchSize+    -> CoinMap i+    -> Property+prop_noLessThanThreshold feeOpts batchSize utxo = do+    let allChange = change+            =<< selectCoins feeOpts batchSize utxo+    let undersizedCoins =+            filter (< threshold) allChange+    property (undersizedCoins `shouldSatisfy` null)+  where+    threshold = unDustThreshold $ dustThreshold feeOpts++-- | Total input UTxO value >= sum of selection change coins+prop_inputsGreaterThanOutputs+    :: forall i o . (Ord i, Ord o, Show i, Show o)+    => FeeOptions i o+    -> BatchSize+    -> CoinMap i+    -> Property+prop_inputsGreaterThanOutputs feeOpts batchSize utxo = do+    let selections  = selectCoins feeOpts batchSize utxo+    let totalChange = mconcat (sumChange <$> selections)+    let balanceUTxO = coinMapValue utxo+    property (balanceUTxO >= totalChange)+        & counterexample ("Total change balance: " <> show totalChange)+        & counterexample ("Total UTxO balance: " <> show balanceUTxO)+        & counterexample ("Selections: " <> show selections)++-- | Every selected input is unique, i.e. selected only once+prop_inputsAreUnique+    :: forall i o . (Ord i, Ord o)+    => FeeOptions i o+    -> BatchSize+    -> CoinMap i+    -> Property+prop_inputsAreUnique feeOpts batchSize utxo = do+    let selectionInputList =+            coinMapToList . inputs =<< selectCoins feeOpts batchSize utxo+    let selectionInputSet =+            Set.fromList selectionInputList+    Set.size selectionInputSet === length selectionInputSet++-- | Every selection input is still a member of the UTxO" $+prop_inputsStillInUTxO+    :: forall i o . (Ord i, Ord o)+    => FeeOptions i o+    -> BatchSize+    -> CoinMap i+    -> Property+prop_inputsStillInUTxO feeOpts batchSize utxo = do+    let selectionInputSet = Set.fromList $+            coinMapToList . inputs =<< selectCoins feeOpts batchSize utxo+    let utxoSet = Set.fromList $+            fmap (uncurry CoinMapEntry) $ Map.toList $ unCoinMap utxo+    property (selectionInputSet `Set.isSubsetOf` utxoSet)++-- | Every coin selection is well-balanced (i.e. actual fees are exactly the+-- expected fees)+prop_wellBalanced+    :: forall i o . (Ord i, Ord o, Show i, Show o)+    => FeeParameters i o+    -> BatchSize+    -> CoinMap i+    -> Property+prop_wellBalanced feeParams batchSize utxo = do+    let feeOpts = FeeOptions+            { dustThreshold = DustThreshold mempty+            , feeEstimator = stableEstimator feeParams+            , feeBalancingPolicy = RequireBalancedFee+            }+    let selections = selectCoins feeOpts batchSize utxo+    conjoin+        [ counterexample example (actualFee === expectedFee)+        | s <- selections+        , let actualFee+                = coinToIntegral (sumInputs s)+                - coinToIntegral (sumChange s)+        , let expectedFee+                = coinToIntegral @Integer+                $ unFee $ estimateFee (feeEstimator feeOpts) s+        , let example = unlines+                [ "Coin Selection: " <> show s+                , "Actual fee: " <> show actualFee+                , "Expected fee: " <> show expectedFee+                ]+        ]++--------------------------------------------------------------------------------+-- Arbitrary Instances+--------------------------------------------------------------------------------++-- A wrapper to avoid overlapping instances imported from other modules.+newtype Wrapped a = Wrapped { unwrap :: a }+    deriving (Eq, Ord, Show)++-- TODO: Move similar Arbitrary instances to a shared module for better reuse.+instance Arbitrary (Wrapped TxIn) where+    arbitrary = fmap Wrapped . TxIn+        <$> fmap unwrap arbitrary+        <*> scale (`mod` 3) arbitrary++-- TODO: Move similar Arbitrary instances to a shared module for better reuse.+instance Arbitrary (Wrapped (Hash "Tx")) where+    arbitrary = Wrapped . Hash <$> (BS.pack <$> vectorOf 32 arbitrary)++instance Arbitrary BatchSize where+    arbitrary = BatchSize <$> arbitrarySizedIntegral+    shrink (BatchSize s) = BatchSize <$> shrink s++--------------------------------------------------------------------------------+-- Generators+--------------------------------------------------------------------------------++genBatchSize :: Gen BatchSize+genBatchSize = BatchSize <$> choose (50, 150)++genFeeOptions :: Coin -> Gen (FeeOptions TxIn Address)+genFeeOptions dust = do+    pure $ FeeOptions+        { feeEstimator = FeeEstimator $ \s ->+            let x = fromIntegral @_ @Integer+                    (length (inputs s) + length (outputs s))+            in unsafeFee $+                  (C.coinToIntegral dust `div` 100) * x + C.coinToIntegral dust+        , dustThreshold = DustThreshold dust+        , feeBalancingPolicy = RequireBalancedFee+        }++-- | Generate a given UTxO with a particular percentage of dust+genUTxO :: Double -> Coin -> Gen (CoinMap TxIn)+genUTxO r dust = do+    n <- choose (10, 1000)+    inps <- genTxIn n+    coins <- vectorOf n genCoin+    pure $ CoinMap $ Map.fromList $ zip inps coins+  where+    genTxIn :: Int -> Gen [TxIn]+    genTxIn n = do+        ids <- vectorOf n (Hash <$> genBytes 8)+        ixs <- vectorOf n arbitrary+        pure $ zipWith TxIn ids ixs++    genBytes :: Int -> Gen ByteString+    genBytes n = B8.pack <$> vectorOf n arbitrary++    genCoin :: Gen Coin+    genCoin = unsafeCoin @Int <$> frequency+        [ (round (100*r), choose (1, integralDust))+        , (round (100*(1-r)), choose (integralDust, 1000 * integralDust))+        ]+      where+        integralDust = C.coinToIntegral dust++--------------------------------------------------------------------------------+-- Utility Functions+--------------------------------------------------------------------------------

@@ -0,0 +1,264 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeApplications #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Cardano.CoinSelection.Algorithm.RandomImproveSpec+    ( spec+    ) where++import Prelude++import Cardano.CoinSelection+    ( CoinSelection (..)+    , CoinSelectionAlgorithm (..)+    , CoinSelectionError (..)+    , CoinSelectionLimit (..)+    , CoinSelectionParameters (..)+    , CoinSelectionResult (..)+    , InputCountInsufficientError (..)+    , InputLimitExceededError (..)+    , InputValueInsufficientError (..)+    , InputsExhaustedError (..)+    )+import Cardano.CoinSelection.Algorithm.LargestFirst+    ( largestFirst )+import Cardano.CoinSelection.Algorithm.RandomImprove+    ( randomImprove )+import Cardano.CoinSelectionSpec+    ( CoinSelProp (..)+    , CoinSelectionFixture (..)+    , CoinSelectionTestResult (..)+    , coinSelectionUnitTest+    )+import Cardano.Test.Utilities+    ( Address, TxIn, unsafeCoin )+import Control.Monad.Trans.Except+    ( runExceptT )+import Crypto.Random+    ( SystemDRG, getSystemDRG )+import Crypto.Random.Types+    ( withDRG )+import Data.Either+    ( isLeft, isRight )+import Data.Functor.Identity+    ( Identity (..) )+import Test.Hspec+    ( Spec, before, describe, it, shouldSatisfy )+import Test.QuickCheck+    ( Property, property, (===), (==>) )++import qualified Data.List as L++spec :: Spec+spec = do+    describe "Coin selection : random algorithm unit tests" $ do+        let oneAda = 1000000++        coinSelectionUnitTest randomImprove ""+            (Right $ CoinSelectionTestResult+                { rsInputs = [1,1,1,1]+                , rsChange = [2]+                , rsOutputs = [2]+                })+            (CoinSelectionFixture+                { maxNumOfInputs = 100+                , utxoInputs = [1,1,1,1,1,1]+                , txOutputs = [2]+                })++        coinSelectionUnitTest randomImprove ""+            (Right $ CoinSelectionTestResult+                { rsInputs = [1,1,1,1,1,1]+                , rsChange = [2,1]+                , rsOutputs = [2,1]+                })+            (CoinSelectionFixture+                { maxNumOfInputs = 100+                , utxoInputs = [1,1,1,1,1,1]+                , txOutputs = [2,1]+                })++        coinSelectionUnitTest randomImprove ""+            (Right $ CoinSelectionTestResult+                { rsInputs = [1,1,1,1,1]+                , rsChange = [2]+                , rsOutputs = [2,1]+                })+            (CoinSelectionFixture+                { maxNumOfInputs = 100+                , utxoInputs = [1,1,1,1,1]+                , txOutputs = [2,1]+                })++        coinSelectionUnitTest randomImprove ""+            (Right $ CoinSelectionTestResult+                { rsInputs = [1,1,1,1]+                , rsChange = [1]+                , rsOutputs = [2,1]+                })+            (CoinSelectionFixture+                { maxNumOfInputs = 100+                , utxoInputs = [1,1,1,1]+                , txOutputs = [2,1]+                })++        coinSelectionUnitTest randomImprove ""+            (Right $ CoinSelectionTestResult+                { rsInputs = [5]+                , rsChange = [3]+                , rsOutputs = [2]+                })+            (CoinSelectionFixture+                { maxNumOfInputs = 100+                , utxoInputs = [5,5,5]+                , txOutputs = [2]+                })++        coinSelectionUnitTest randomImprove ""+            (Right $ CoinSelectionTestResult+                { rsInputs = [10,10]+                , rsChange = [8,8]+                , rsOutputs = [2,2]+                }+            )+            (CoinSelectionFixture+                { maxNumOfInputs = 100+                , utxoInputs = [10,10,10]+                , txOutputs = [2,2]+                })++        coinSelectionUnitTest randomImprove "cannot cover aim, but only min"+            (Right $ CoinSelectionTestResult+                { rsInputs = [1,1,1,1]+                , rsChange = [1]+                , rsOutputs = [3]+                })+            (CoinSelectionFixture+                { maxNumOfInputs = 4+                , utxoInputs = [1,1,1,1,1,1]+                , txOutputs = [3]+                })++        coinSelectionUnitTest randomImprove "REG CO-450: no fallback"+            (Right $ CoinSelectionTestResult+                { rsInputs = [oneAda, oneAda, oneAda, oneAda]+                , rsChange = [oneAda, oneAda `div` 2]+                , rsOutputs = [2*oneAda,oneAda `div` 2]+                })+            (CoinSelectionFixture+                { maxNumOfInputs = 4+                , utxoInputs = [oneAda, oneAda, oneAda, oneAda]+                , txOutputs = [2*oneAda, oneAda `div` 2]+                })++        coinSelectionUnitTest randomImprove+            "enough funds, proper fragmentation, inputs depleted"+            (Left (InputsExhausted InputsExhaustedError))+            (CoinSelectionFixture+                { maxNumOfInputs = 100+                , utxoInputs = [10,10,10,10]+                , txOutputs = [38,1]+                })++        coinSelectionUnitTest randomImprove ""+            (Left $ InputLimitExceeded $ InputLimitExceededError 2)+            (CoinSelectionFixture+                { maxNumOfInputs = 2+                , utxoInputs = [1,1,1,1,1,1]+                , txOutputs = [3]+                })++        coinSelectionUnitTest randomImprove "each output needs <maxNumOfInputs"+            (Left $ InputLimitExceeded $ InputLimitExceededError 9)+            (CoinSelectionFixture+                { maxNumOfInputs = 9+                , utxoInputs = replicate 100 1+                , txOutputs = replicate 100 1+                })++        coinSelectionUnitTest randomImprove "each output needs >maxNumInputs"+            (Left $ InputLimitExceeded $ InputLimitExceededError 9)+            (CoinSelectionFixture+                { maxNumOfInputs = 9+                , utxoInputs = replicate 100 1+                , txOutputs = replicate 10 10+                })++        coinSelectionUnitTest randomImprove ""+            (Left $ InputValueInsufficient $ InputValueInsufficientError+                (unsafeCoin @Int 39) (unsafeCoin @Int 40))+            (CoinSelectionFixture+                { maxNumOfInputs = 100+                , utxoInputs = [12,10,17]+                , txOutputs = [40]+                })++        coinSelectionUnitTest randomImprove ""+            (Left $ InputValueInsufficient $ InputValueInsufficientError+                (unsafeCoin @Int 39) (unsafeCoin @Int 43))+            (CoinSelectionFixture+                { maxNumOfInputs = 100+                , utxoInputs = [12,10,17]+                , txOutputs = [40,1,1,1]+                })++        coinSelectionUnitTest randomImprove ""+            (Left $ InputCountInsufficient $ InputCountInsufficientError 3 4)+            (CoinSelectionFixture+                { maxNumOfInputs = 100+                , utxoInputs = [12,20,17]+                , txOutputs = [40,1,1,1]+                })++    before getSystemDRG $+        describe "Coin selection properties : random algorithm" $ do+            it "forall (UTxO, NonEmpty TxOut), running algorithm gives not \+                \less UTxO fragmentation than LargestFirst algorithm"+                (property . propFragmentation @TxIn @Address)+            it "forall (UTxO, NonEmpty TxOut), running algorithm gives the \+                \same errors as LargestFirst algorithm"+                (property . propErrors @TxIn @Address)++--------------------------------------------------------------------------------+-- Properties+--------------------------------------------------------------------------------++propFragmentation+    :: (Ord i, Ord o)+    => SystemDRG+    -> CoinSelProp i o+    -> Property+propFragmentation drg (CoinSelProp utxo txOuts) = do+    isRight selection1 && isRight selection2 ==>+        let Right (CoinSelectionResult s1 _) = selection1 in+        let Right (CoinSelectionResult s2 _) = selection2 in+        prop (s1, s2)+  where+    prop (CoinSelection inps1 _ _, CoinSelection inps2 _ _) =+        L.length inps1 `shouldSatisfy` (>= L.length inps2)+    (selection1,_) = withDRG drg $+        runExceptT $ selectCoins randomImprove params+    selection2 = runIdentity $ runExceptT $+        selectCoins largestFirst params+    selectionLimit = CoinSelectionLimit $ const 100+    params = CoinSelectionParameters txOuts utxo selectionLimit++propErrors+    :: (Ord i, Ord o)+    => SystemDRG+    -> CoinSelProp i o+    -> Property+propErrors drg (CoinSelProp utxo txOuts) = do+    isLeft selection1 && isLeft selection2 ==>+        let (Left s1, Left s2) = (selection1, selection2)+        in prop (s1, s2)+  where+    prop (err1, err2) =+        err1 === err2+    (selection1,_) = withDRG drg $+        runExceptT $ selectCoins randomImprove params+    selection2 = runIdentity $ runExceptT $+        selectCoins largestFirst params+    selectionLimit = CoinSelectionLimit $ const 1+    params = CoinSelectionParameters txOuts utxo selectionLimit

@@ -0,0 +1,1103 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE NumericUnderscores #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}++{-# OPTIONS_GHC -fno-warn-orphans #-}++module Cardano.CoinSelection.FeeSpec+    ( spec++    -- Internals+    , FeeParameters+    , stableEstimator+    , valueDependentEstimator+    ) where++import Prelude hiding+    ( round )++import Cardano.CoinSelection+    ( CoinMap (..)+    , CoinMapEntry (..)+    , CoinSelection (..)+    , CoinSelectionAlgorithm (..)+    , CoinSelectionResult (..)+    , coinMapFromList+    , coinMapToList+    , sumChange+    , sumInputs+    , sumOutputs+    )+import Cardano.CoinSelection.Algorithm.LargestFirst+    ( largestFirst )+import Cardano.CoinSelection.Fee+    ( DustThreshold (..)+    , Fee (..)+    , FeeAdjustmentError (..)+    , FeeBalancingPolicy (..)+    , FeeEstimator (..)+    , FeeOptions (..)+    , adjustForFee+    , coalesceDust+    , distributeFee+    , reduceChangeOutputs+    , splitCoin+    )+import Cardano.Test.Utilities+    ( Address (..)+    , Hash (..)+    , ShowFmt (..)+    , TxIn (..)+    , unsafeCoin+    , unsafeDustThreshold+    , unsafeFee+    )+import Control.Arrow+    ( left )+import Control.Monad+    ( replicateM )+import Control.Monad.IO.Class+    ( liftIO )+import Control.Monad.Trans.Except+    ( runExceptT )+import Crypto.Random+    ( SystemDRG, getSystemDRG )+import Crypto.Random.Types+    ( withDRG )+import Data.Either+    ( isRight )+import Data.Function+    ( (&) )+import Data.Functor.Identity+    ( Identity (runIdentity) )+import Data.List.NonEmpty+    ( NonEmpty (..) )+import Data.Monoid+    ( All (..) )+import Data.Ratio+    ( (%) )+import Fmt+    ( Buildable (..), nameF, tupleF )+import GHC.Generics+    ( Generic )+import Internal.Coin+    ( Coin, coinToIntegral )+import Internal.Rounding+    ( RoundingDirection (..), round )+import Test.Hspec+    ( Spec, SpecWith, before, describe, it, shouldBe, shouldSatisfy )+import Test.QuickCheck+    ( Arbitrary (..)+    , Gen+    , Positive (getPositive)+    , Property+    , arbitraryBoundedIntegral+    , checkCoverage+    , choose+    , counterexample+    , cover+    , coverTable+    , disjoin+    , elements+    , expectFailure+    , generate+    , genericShrink+    , oneof+    , property+    , scale+    , tabulate+    , vectorOf+    , withMaxSuccess+    , (.&&.)+    , (===)+    , (==>)+    )+import Test.QuickCheck.Monadic+    ( monadicIO )++import qualified Cardano.CoinSelection as CS+import qualified Data.ByteString as BS+import qualified Data.Foldable as F+import qualified Data.List as L+import qualified Data.List.NonEmpty as NE+import qualified Data.Map.Strict as Map+import qualified Internal.Coin as C++spec :: Spec+spec = do+    describe "Fee calculation : unit tests" $ do+        -- Change covers fee exactly, single change output+        feeUnitTest (FeeFixture+            { fInps = [20]+            , fOuts = [17]+            , fChngs = [3]+            , fUtxo = []+            , fFee = 3+            , fDust = 0+            }) (Right $ FeeOutput+            { csInps = [20]+            , csOuts = [17]+            , csChngs = []+            })++        -- Total change covers fee, multiple change outputs+        feeUnitTest (FeeFixture+            { fInps = [20,20]+            , fOuts = [16,18]+            , fChngs = [4,2]+            , fUtxo = []+            , fFee = 6+            , fDust = 0+            }) (Right $ FeeOutput+            { csInps = [20,20]+            , csOuts = [16,18]+            , csChngs = []+            })++        -- Fee split evenly across change outputs+        feeUnitTest (FeeFixture+            { fInps = [20,20]+            , fOuts = [18,18]+            , fChngs = [2,2]+            , fUtxo = []+            , fFee = 2+            , fDust = 0+            }) (Right $ FeeOutput+            { csInps = [20,20]+            , csOuts = [18,18]+            , csChngs = [1,1]+            })++        -- Fee split evenly across change outputs+        feeUnitTest (FeeFixture+            { fInps = [20,20]+            , fOuts = [17,18]+            , fChngs = [3,2]+            , fUtxo = []+            , fFee = 2+            , fDust = 0+            }) (Right $ FeeOutput+            { csInps = [20,20]+            , csOuts = [17,18]+            , csChngs = [2,1]+            })++        -- Fee divvied, dust removed (dust = 0)+        feeUnitTest (FeeFixture+            { fInps = [20,20,20]+            , fOuts = [14,18,19]+            , fChngs = [6,2,1]+            , fUtxo = []+            , fFee = 3+            , fDust = 0+            }) (Right $ FeeOutput+            { csInps = [20,20,20]+            , csOuts = [14,18,19]+            , csChngs = [4,1,1]+            })++        -- Fee divvied, dust removed (dust = 1)+        feeUnitTest (FeeFixture+            { fInps = [20,20,20]+            , fOuts = [14,18,19]+            , fChngs = [6,2,1]+            , fUtxo = []+            , fFee = 3+            , fDust = 1+            }) (Right $ FeeOutput+            { csInps = [20,20,20]+            , csOuts = [14,18,19]+            , csChngs = [6]+            })++        -- Cannot cover fee, no extra inputs+        feeUnitTest (FeeFixture+            { fInps = [20]+            , fOuts = [17]+            , fChngs = [3]+            , fUtxo = []+            , fFee = 4+            , fDust = 0+            }) (Left $ CannotCoverFee $ unsafeFee @Int 1)++        -- Cannot cover fee even with an extra (too small) inputs+        feeUnitTest (FeeFixture+            { fInps = [10]+            , fOuts = [7]+            , fChngs = [3]+            , fUtxo = [1]+            , fFee = 5+            , fDust = 0+            }) (Left $ CannotCoverFee $ unsafeFee @Int 1)++        -- Can select extra inputs to exactly cover fee, no change back+        feeUnitTest (FeeFixture+            { fInps = [10]+            , fOuts = [7]+            , fChngs = [3]+            , fUtxo = [1,1]+            , fFee = 5+            , fDust = 0+            }) (Right $ FeeOutput+            { csInps = [10,1,1]+            , csOuts = [7]+            , csChngs = []+            })++        -- Can select extra inputs to cover for fee, and leave a change back+        feeUnitTest (FeeFixture+            { fInps = [10]+            , fOuts = [7]+            , fChngs = [3]+            , fUtxo = [3]+            , fFee = 5+            , fDust = 0+            }) (Right $ FeeOutput+            { csInps = [10,3]+            , csOuts = [7]+            , csChngs = [1]+            })++        -- Multiple change output, can select extra inputs to cover fee, no+        -- change+        feeUnitTest (FeeFixture+            { fInps = [10,10]+            , fOuts = [7,7]+            , fChngs = [3,3]+            , fUtxo = [2,2]+            , fFee = 10+            , fDust = 0+            }) (Right $ FeeOutput+            { csInps = [10,10,2,2]+            , csOuts = [7,7]+            , csChngs = []+            })++        -- Multiple outputs, extra inputs selected, resulting change+        feeUnitTest (FeeFixture+            { fInps = [10,10]+            , fOuts = [7,7]+            , fChngs = [3,3]+            , fUtxo = [3,3]+            , fFee = 10+            , fDust = 0+            }) (Right $ FeeOutput+            { csInps = [10,10,3,3]+            , csOuts = [7,7]+            , csChngs = [1,1]+            })++        -- Multiple change outputs, some bigger than actual Dust+        feeUnitTest (FeeFixture+            { fInps = [20,20]+            , fOuts = [16,18]+            , fChngs = [4,2]+            , fUtxo = []+            , fFee = 6+            , fDust = 2+            }) (Right $ FeeOutput+            { csInps = [20,20]+            , csOuts = [16,18]+            , csChngs = []+            })++        -- Change created when there was no change before+        feeUnitTest (FeeFixture+            { fInps = [1]+            , fOuts = [1]+            , fChngs = []+            , fUtxo = [2]+            , fFee = 1+            , fDust = 0+            }) (Right $ FeeOutput+            { csInps = [1,2]+            , csOuts = [1]+            , csChngs = [1]+            })++        feeUnitTest (FeeFixture+            { fInps = []+            , fOuts = []+            , fChngs = []+            , fUtxo = [3]+            , fFee = 3+            , fDust = 0+            }) (Right $ FeeOutput+            { csInps = [3]+            , csOuts = []+            , csChngs = []+            })++        feeUnitTest (FeeFixture+            { fInps = []+            , fOuts = []+            , fChngs = []+            , fUtxo = [2,2]+            , fFee = 3+            , fDust = 0+            }) (Right $ FeeOutput+            { csInps = [2,2]+            , csOuts = []+            , csChngs = [1]+            })++        feeUnitTest (FeeFixture+            { fInps = []+            , fOuts = []+            , fChngs = []+            , fUtxo = [2,2]+            , fFee = 3+            , fDust = 1+            }) (Right $ FeeOutput+            { csInps = [2,2]+            , csOuts = []+            , csChngs = [1]+            })++    describe "Fee Calculation: Generators" $ do+        it "Arbitrary CoinSelection" $ property $ \(ShowFmt cs) ->+            property $ isValidSelection @TxIn @Address cs++    before getSystemDRG $ describe "Fee Adjustment properties" $ do+        it "Fee adjustment is deterministic when there's no extra inputs"+            (\_ -> property $ propDeterministic @TxIn @Address)+        it "Adjusting for fee (/= 0) reduces the change outputs or increase \+            \inputs"+            (property . propReducedChanges @TxIn @Address)++    describe "distributeFee" $ do+        it "fee portions are all within unity of ideal unrounded portions"+            (checkCoverage propDistributeFeeFair)+        it "fee portions are allocated optimally"+            (checkCoverage propDistributeFeeOptimal)+        it "Σ fst (distributeFee fee outs) == fee"+            (checkCoverage propDistributeFeeSame)+        it "snd (distributeFee fee outs) == outs"+            (checkCoverage propDistributeFeeOuts)+        it "expectFailure: not (any null (fst <$> distributeFee fee outs))"+            (expectFailure propDistributeFeeNoNullFee)++    describe "coalesceDust" $ do+        it "sum coins = sum (coalesceDust threshold coins)"+            (checkCoverage propCoalesceDustPreservesSum)+        it "all (/= Coin 0) (coalesceDust threshold coins)"+            (checkCoverage propCoalesceDustLeavesNoZeroCoins)+        it "leaves at most one dust coin"+            (checkCoverage propCoalesceDustLeavesAtMostOneDustCoin)+        it "length coins >= (coalesceDust threshold coins)"+            (checkCoverage propCoalesceDustNeverLengthensList)++    describe "reduceChangeOutputs" $ do+        it "data coverage is adequate"+            (checkCoverage propReduceChangeOutputsDataCoverage)+        it "the fee balancing algorithm converges for any coin selection"+            ( withMaxSuccess 100_000+            $ propReduceChangeOutputsConverge @TxIn @Address+            )++    describe "splitCoin" $ do+        it "data coverage is adequate"+            (checkCoverage propSplitCoinDataCoverage)+        it "preserves the total sum"+            (checkCoverage propSplitCoinPreservesSum)+        it "results are all within unity of ideal unrounded results"+            (checkCoverage propSplitCoinFair)++--------------------------------------------------------------------------------+-- Fee Adjustment - Properties+--------------------------------------------------------------------------------++-- Check whether a selection is valid+isValidSelection :: CoinSelection i o -> Bool+isValidSelection s =+    sumInputs s >= sumOutputs s `C.add` sumChange s++-- | Data for running fee calculation properties+data FeeProp i o = FeeProp+    { selection :: CoinSelection i o+     -- ^ inputs from wich largestFirst can be calculated+    , availableUtxo :: CoinMap i+     -- ^ additional UTxO from which fee calculation will pick needed coins+    , feeDust :: (Integer, Integer)+     -- ^ constant fee and dust threshold+    } deriving Show++instance (Buildable i, Buildable o) =>+    Buildable (FeeProp i o) where+        build (FeeProp cc utxo opt) = mempty+            <> nameF "selection" (build cc)+            <> nameF "utxo" (build (coinMapToList utxo))+            <> nameF "options" (tupleF opt)++propDeterministic+    :: forall i o . (Ord i, Ord o, Show i, Show o)+    => ShowFmt (FeeProp i o)+    -> Property+propDeterministic (ShowFmt (FeeProp coinSel _ (fee, dust))) =+    monadicIO $ liftIO $ do+        let feeOpt = feeOptions fee dust+        let utxo = mempty+        resultOne <- runExceptT $ adjustForFee feeOpt utxo coinSel+        resultTwo <- runExceptT $ adjustForFee feeOpt utxo coinSel+        resultOne `shouldBe` resultTwo++propReducedChanges+    :: forall i o . (Ord i, Show i, Show o)+    => SystemDRG+    -> ShowFmt (FeeProp i o)+    -> Property+propReducedChanges drg (ShowFmt (FeeProp coinSel utxo (fee, dust))) = do+    isRight coinSel' ==> let Right s = coinSel' in prop s+  where+    prop s = do+        let chgs' = F.fold $ change s+        let chgs = F.fold $ change coinSel+        let inps' = CS.inputs s+        let inps = CS.inputs coinSel+        disjoin+            [ chgs' `shouldSatisfy` (<= chgs)+            , length inps' `shouldSatisfy` (>= length inps)+            ]+    feeOpt = feeOptions fee dust+    coinSel' = left show $ fst $ withDRG drg $ runExceptT $+        adjustForFee feeOpt utxo coinSel++--------------------------------------------------------------------------------+-- distributeFee - Properties+--------------------------------------------------------------------------------++-- | Helper to re-apply the pre-conditions for distributeFee+propDistributeFee+    :: ((Fee, NonEmpty Coin) -> Property)+    -> (Fee, NonEmpty Coin)+    -> Property+propDistributeFee prop (fee, outs) =+    coverTable "properties"+        [ ("fee > 0", 50)+        , ("nOuts=1", 1)+        , ("nOuts=2", 1)+        , ("nOuts=2+", 10)+        ]+        $ tabulate "properties"+            [ if fee > Fee C.zero then "fee > 0" else "fee == 0"+            , "nOuts=" <> case length outs of+                n | n <= 2 -> show n+                _ -> "2+"+            ]+        $ prop (fee, outs)++-- | Verify that fees are distributed fairly across outputs, so that every+--   rounded fee portion is always within unity of the ideal unrounded fee+--   portion.+propDistributeFeeFair+    :: (Fee, NonEmpty Coin)+    -> Property+propDistributeFeeFair (fee, coins) = (.&&.)+    (F.all (uncurry (<=)) (NE.zip fees feeUpperBounds))+    (F.all (uncurry (>=)) (NE.zip fees feeLowerBounds))+  where+    fees = fst <$> distributeFee fee coins++    feeUpperBounds = unsafeFee @Integer . ceiling . computeIdealFee <$> coins+    feeLowerBounds = unsafeFee @Integer . floor   . computeIdealFee <$> coins++    computeIdealFee :: Coin -> Rational+    computeIdealFee c+        = coinToIntegral c+        * coinToIntegral (unFee fee)+        % coinToIntegral (F.fold coins)++-- | Verify that fees are distributed optimally across coins, such that the+-- absolute deviation from the ideal (unrounded) fee distribution is minimal.+propDistributeFeeOptimal+    :: Fee+    -> NonEmpty Coin+    -> Property+propDistributeFeeOptimal fee coins = property $+    computeDeviation (fst <$> distributeFee fee coins)+        `shouldBe` minimumPossibleDeviation+  where+    -- Compute the deviation of a fee portion distribution from the ideal+    -- unrounded fee portion distribution.+    computeDeviation :: NonEmpty Fee -> Rational+    computeDeviation feesRounded = F.sum $+        NE.zipWith zipper+            feesRounded+            idealUnroundedDistribution+      where+        zipper :: Fee -> Rational -> Rational+        zipper (Fee roundedFee) unroundedFee = abs $+            fromIntegral (coinToIntegral @Integer roundedFee) - unroundedFee++    -- The minimum deviation across all possible distributions for the given+    -- fee and set of coins.+    minimumPossibleDeviation :: Rational+    minimumPossibleDeviation =+        F.minimum $ computeDeviation <$> allPossibleDistributions++    -- The set of all possible fee distributions for the given fee and coins.+    allPossibleDistributions :: [NonEmpty Fee]+    allPossibleDistributions = filter isValidDistribution $ NE.zipWith+        (\f roundDir ->+            unsafeFee @Integer $ fromIntegral @Integer $ round roundDir f)+        idealUnroundedDistribution <$> allPossibleRoundings+      where+        -- Indicates whether the given distribution has the correct total fee.+        isValidDistribution :: NonEmpty Fee -> Bool+        isValidDistribution r = F.fold r == fee++        -- All possible ways to round an unrounded fee distribution.+        allPossibleRoundings :: [NonEmpty RoundingDirection]+        allPossibleRoundings = traverse (const [RoundUp, RoundDown]) coins++    -- The ideal unrounded fee distribution.+    idealUnroundedDistribution :: NonEmpty Rational+    idealUnroundedDistribution = computeIdealFee <$> coins+      where+        computeIdealFee :: Coin -> Rational+        computeIdealFee c+            = coinToIntegral c+            * coinToIntegral (unFee fee)+            % coinToIntegral (F.fold coins)++-- | Sum of the fees divvied over each output is the same as the initial total+-- fee.+propDistributeFeeSame+    :: (Fee, NonEmpty Coin)+    -> Property+propDistributeFeeSame = propDistributeFee $ \(fee, outs) ->+    F.fold (fst <$> distributeFee fee outs) === fee++-- | distributeFee doesn't change any of the outputs+propDistributeFeeOuts+    :: (Fee, NonEmpty Coin)+    -> Property+propDistributeFeeOuts = propDistributeFee $ \(fee, outs) ->+    (snd <$> distributeFee fee outs) === outs++-- | distributeFee never generates null fees for a given output.+--+-- This is NOT a property. It is here to illustrate that this can happen in+-- practice, and is known as a possible outcome for the distributeFee function+-- (it is fine for one of the output to be assigned no fee). The only reason+-- this would happen is because there would be less outputs than the fee amount+-- which is probably never going to happen in practice...+propDistributeFeeNoNullFee+    :: (Fee, NonEmpty Coin)+    -> Property+propDistributeFeeNoNullFee (fee, outs) =+    not (null outs) ==> withMaxSuccess 100000 prop+  where+    prop = property $ Fee C.zero `F.notElem` (fst <$> distributeFee fee outs)++--------------------------------------------------------------------------------+-- coalesceDust - Properties+--------------------------------------------------------------------------------++data CoalesceDustData = CoalesceDustData+    { cddThreshold :: DustThreshold+    , cddCoins :: NonEmpty Coin+    } deriving (Eq, Generic, Show)++instance Arbitrary CoalesceDustData where+    arbitrary = do+        coinCount <- genCoinCount+        coins <- (:|) <$> genCoin <*> replicateM coinCount genCoin+        threshold <- DustThreshold <$> oneof+            [ -- Two possibilities:+              genCoin+              -- ^ A completely fresh coin.+            , elements (F.toList coins)+              -- ^ A coin picked from the existing coin set.+            ]+        pure $ CoalesceDustData threshold coins+      where+        genCoin = unsafeCoin @Int <$> oneof [pure 0, choose (1, 100)]+        genCoinCount = choose (0, 10)+    shrink = genericShrink++propCoalesceDustPreservesSum :: CoalesceDustData -> Property+propCoalesceDustPreservesSum (CoalesceDustData threshold coins) =+    property $+    let total = F.fold coins in+    cover 8 (total == C.zero) "sum coins = 0" $+    cover 8 (total /= C.zero) "sum coins ≠ 0" $+    total == F.fold (coalesceDust threshold coins)++propCoalesceDustLeavesNoZeroCoins :: CoalesceDustData -> Property+propCoalesceDustLeavesNoZeroCoins (CoalesceDustData threshold coins) =+    property $+    cover 4 (F.all  (== C.zero) coins) "∀ coin ∈ coins . coin = 0" $+    cover 4 (F.elem    (C.zero) coins) "∃ coin ∈ coins . coin = 0" $+    cover 8 (F.notElem (C.zero) coins) "∀ coin ∈ coins . coin > 0" $+    F.notElem C.zero $ coalesceDust threshold coins++propCoalesceDustLeavesAtMostOneDustCoin :: CoalesceDustData -> Property+propCoalesceDustLeavesAtMostOneDustCoin (CoalesceDustData threshold coins) =+    property $+    let result = coalesceDust threshold coins in+    -- Check that we cover different kinds of extreme threshold conditions:+    cover 2 (F.all (<  threshold') coins) "∀ coin ∈ coins . coin < threshold" $+    cover 2 (F.all (>  threshold') coins) "∀ coin ∈ coins . coin > threshold" $+    cover 2 (F.all (== threshold') coins) "∀ coin ∈ coins . coin = threshold" $+    cover 2 (F.all (/= threshold') coins) "∀ coin ∈ coins . coin ≠ threshold" $+    -- Check that we cover typical threshold conditions:+    let haveMixture = getAll $ mconcat $ All <$>+          [ F.any (<  threshold') coins+          , F.any (== threshold') coins+          , F.any (>  threshold') coins+          ] in+    cover 8 haveMixture "have mixture of coin values in relation to threshold" $+    -- Check that we cover different result lengths:+    cover 8 (null result)        "length result = 0" $+    cover 8 (length result == 1) "length result = 1" $+    cover 8 (length result >= 2) "length result ≥ 2" $+    case result of+        [ ] -> F.fold coins == C.zero+        [x] -> F.fold coins == x+        cxs -> all (> threshold') cxs+  where+    threshold' = unDustThreshold threshold++propCoalesceDustNeverLengthensList :: CoalesceDustData -> Property+propCoalesceDustNeverLengthensList (CoalesceDustData threshold coins) =+    property $ length coins >= length (coalesceDust threshold coins)++--------------------------------------------------------------------------------+-- reduceChangeOutputs - Properties+--------------------------------------------------------------------------------++data ReduceChangeOutputsData = ReduceChangeOutputsData+    { rcodFee :: Fee+    , rcodThreshold :: DustThreshold+    , rcodCoins :: [Coin]+    } deriving (Eq, Generic, Show)++instance Arbitrary ReduceChangeOutputsData where+    arbitrary = do+        coalesceDustData <- arbitrary+        let threshold = cddThreshold coalesceDustData+        let coins = F.toList $ cddCoins coalesceDustData+        let coinSum = sum $ coinToIntegral <$> coins+        fee <- unsafeFee <$> oneof+            [ pure 0+            , choose (1, safePred coinSum)+            , pure coinSum+            , choose (coinSum + 1, coinSum * 2)+            ]+        pure $ ReduceChangeOutputsData fee threshold coins+      where+        safePred :: Integer -> Integer+        safePred x+            | x > 0 = x - 1+            | otherwise = 0+    shrink = genericShrink++propReduceChangeOutputsDataCoverage :: ReduceChangeOutputsData -> Property+propReduceChangeOutputsDataCoverage+    (ReduceChangeOutputsData (Fee fee) _ coins) =+        let coinSum = F.fold coins in+        property+            -- Test coverage of fee amount, relative to sum of coins:+            $ cover 100 (fee >= C.zero)+                "fee >= 0"+            $ cover 8 (fee == C.zero)+                "fee = 0"+            $ cover 8 (length (filter (> C.zero) coins) == 1)+                "one non-empty coin"+            $ cover 8 (length (filter (> C.zero) coins) == 2)+                "two non-empty coins"+            $ cover 8 (length (filter (> C.zero) coins) >= 3)+                "several non-empty coins"+            $ cover 8 (any (> C.zero) coins && C.zero < fee && fee < coinSum)+                "0 < fee < sum coins"+            $ cover 8 (any (> C.zero) coins && fee == coinSum)+                "fee = sum coins"+            $ cover 8 (any (> C.zero) coins && fee > coinSum)+                "fee > sum coins"+            True++propReduceChangeOutputsConverge+    :: (Show i, Show o)+    => CoinSelection i o+    -> FeeOptions i o+    -> Property+propReduceChangeOutputsConverge sel opts = do+    let Right (sel', remainder) = reduceChangeOutputs opts sel+    let fee = estimateFee (feeEstimator opts) sel'+    let prop = case feeBalancingPolicy opts of+            -- If fees are null and we require balanced selections, then the+            -- selection must be exactly balanced.+            RequireBalancedFee | remainder == Fee C.zero ->+                (Fee <$> delta sel') == Just fee++            -- Otherwise, either the change outputs are null, or the delta is+            -- positive because of the dangling output and we'll have to pay for+            -- it.+            RequireBalancedFee ->+                null (change sel') || (delta sel' >= Just C.zero)++            -- If fees are null and we do not require balanced selections, then+            -- the selection must leave __at least__ the fee amount.+            RequireMinimalFee | remainder == Fee C.zero ->+                (Fee <$> delta sel') >= Just fee++            -- Otherwise, the change outputs are necessarily null.+            RequireMinimalFee ->+                null (change sel')+    property prop+        & counterexample (unlines+            [ "new selection:  " <> show sel'+            , "delta (before): " <> show (delta sel)+            , "delta (after):  " <> show (delta sel')+            , "remainder:      " <> show remainder+            ])+  where+    delta s = sumInputs s `C.sub` (sumOutputs s `C.add` sumChange s)++--------------------------------------------------------------------------------+-- splitCoin - Properties+--------------------------------------------------------------------------------++data SplitCoinData = SplitCoinData+    { scdCoinToSplit :: Coin+    , scdCoinsToIncrease :: [Coin]+    } deriving (Eq, Generic, Show)++instance Arbitrary SplitCoinData where+    arbitrary = do+        coinToSplit <- genCoin+        n <- oneof+            [ pure 0+            , pure 1+            , choose (2, 10)+            ]+        coinsToIncrease <- replicateM n genCoin+        pure $ SplitCoinData coinToSplit coinsToIncrease+      where+        genCoin :: Gen Coin+        genCoin = oneof+            [ pure $ unsafeCoin @Integer 0+            , pure $ unsafeCoin @Integer 1+            , unsafeCoin @Int . (+ 1) . getPositive <$> arbitrary+            ]+    shrink = genericShrink++propSplitCoinDataCoverage :: SplitCoinData -> Property+propSplitCoinDataCoverage (SplitCoinData coinToSplit coinsToIncrease) =+    property+        $ cover 8 (null coinsToIncrease)+            "list of coins is empty"+        $ cover 8 (length coinsToIncrease == 1)+            "list of coins is singleton"+        $ cover 8 (length coinsToIncrease > 1)+            "list of coins has multiple entries"+        $ cover 8 (C.zero `elem` coinsToIncrease)+            "list of coins has at least one zero coin"+        $ cover 8 (any (> C.zero) coinsToIncrease)+            "list of coins has at least one non-zero coin"+        $ cover 8 (coinToSplit == C.zero)+            "coin to split is zero"+        $ cover 8 (coinToSplit > C.zero)+            "coin to split is non-zero"+        $ cover 8 (length coinsToIncrease > coinToIntegral coinToSplit)+            "coin to split is smaller than number of coins to increase"+        True++propSplitCoinPreservesSum :: SplitCoinData -> Property+propSplitCoinPreservesSum (SplitCoinData coinToSplit coinsToIncrease) =+    property $ totalBefore `shouldBe` totalAfter+  where+    totalAfter = F.fold (splitCoin coinToSplit coinsToIncrease)+    totalBefore = coinToSplit `C.add` F.fold coinsToIncrease++propSplitCoinFair :: (Coin, NonEmpty Coin) -> Property+propSplitCoinFair (coinToSplit, coinsToIncrease) = (.&&.)+    (F.all (uncurry (<=)) (NE.zip results upperBounds))+    (F.all (uncurry (>=)) (NE.zip results lowerBounds))+  where+    results = NE.fromList $ splitCoin coinToSplit $ NE.toList coinsToIncrease++    upperBounds = unsafeCoin @Integer . ceiling+        . computeIdealResult <$> coinsToIncrease+    lowerBounds = unsafeCoin @Integer . floor+        . computeIdealResult <$> coinsToIncrease++    computeIdealResult :: Coin -> Rational+    computeIdealResult c+        = fromIntegral (coinToIntegral @Integer c)+        + coinToIntegral @Integer coinToSplit+        % fromIntegral (length coinsToIncrease)++--------------------------------------------------------------------------------+-- Fee Adjustment - Unit Tests+--------------------------------------------------------------------------------++feeOptions+    :: Integer+    -> Integer+    -> FeeOptions i o+feeOptions fee dust = FeeOptions+    { feeEstimator = FeeEstimator $+        \_ -> unsafeFee fee+    , dustThreshold =+        unsafeDustThreshold dust+    , feeBalancingPolicy =+        RequireBalancedFee+    }++feeUnitTest+    :: FeeFixture+    -> Either (FeeAdjustmentError TxIn Address) FeeOutput+    -> SpecWith ()+feeUnitTest (FeeFixture inpsF outsF chngsF utxoF feeF dustF) expected =+    it title $ do+        (utxo, sel) <- setup @TxIn @Address+        result <- runExceptT $ do+            (CoinSelection inps outs chngs) <-+                adjustForFee (feeOptions feeF dustF) utxo sel+            return $ FeeOutput+                { csInps = coinToIntegral . entryValue <$> coinMapToList inps+                , csOuts = coinToIntegral . entryValue <$> coinMapToList outs+                , csChngs = coinToIntegral <$> chngs+                }+        fmap sortFeeOutput result `shouldBe` fmap sortFeeOutput expected+  where+    setup+        :: forall i o . (Arbitrary i, Arbitrary o, Ord i, Ord o)+        => IO (CoinMap i, CoinSelection i o)+    setup = do+        utxo <- generate (genInputs $ unsafeCoin <$> utxoF)+        inps <- (fmap (uncurry CoinMapEntry) . Map.toList . unCoinMap) <$>+            generate (genInputs $ unsafeCoin <$> inpsF)+        outs <- generate (genOutputs $ unsafeCoin <$> outsF)+        let chngs = map unsafeCoin chngsF+        pure (utxo, CoinSelection (coinMapFromList inps) outs chngs)++    title :: String+    title = mempty+        <> "CoinSelection (inps=" <> show inpsF+        <> "outs=" <> show outsF+        <> "chngs=" <> show chngsF+        <> "), UTxO=" <> show utxoF+        <> "), fee=" <> show feeF+        <> " --> " <> show expected++-- | A fixture for testing the fee calculation+data FeeFixture = FeeFixture+    { fInps :: [Integer]+        -- ^ Value (in Lovelace) & number of coins in inputs+    , fOuts :: [Integer]+        -- ^ Value (in Lovelace) & number of requested outputs+    , fChngs :: [Integer]+        -- ^ Value (in Lovelace) & number of changes+    , fUtxo :: [Integer]+        -- ^ Value (in Lovelace) & number of available coins in the UTxO+    , fFee :: Integer+        -- ^ Value (in Lovelace) of rigid fee+    , fDust :: Integer+        -- ^ Value (in Lovelace) of dust+    } deriving Show++-- | A fee calculation output+data FeeOutput = FeeOutput+    { csInps :: [Integer]+        -- ^ Value (in Lovelace) & number of available coins in the UTxO+    , csOuts :: [Integer]+        -- ^ Value (in Lovelace) & number of requested outputs+    , csChngs :: [Integer]+        -- ^ Value (in Lovelace) & number of changes+    } deriving (Show, Eq)++sortFeeOutput :: FeeOutput -> FeeOutput+sortFeeOutput (FeeOutput is os cs) =+    FeeOutput (L.sort is) (L.sort os) (L.sort cs)++--------------------------------------------------------------------------------+-- Arbitrary Instances+--------------------------------------------------------------------------------++deriving newtype instance Arbitrary a => Arbitrary (ShowFmt a)++genInputs :: (Arbitrary i, Ord i) => [Coin] -> Gen (CoinMap i)+genInputs coins = do+    let n = length coins+    inps <- vectorOf n arbitrary+    return $ CoinMap $ Map.fromList $ zip inps coins++genOutputs :: (Arbitrary o, Ord o) => [Coin] -> Gen (CoinMap o)+genOutputs coins = do+    let n = length coins+    outs <- vectorOf n arbitrary+    return $ coinMapFromList $ zipWith CoinMapEntry outs coins++genSelection+    :: (Arbitrary i, Ord i, Ord o)+    => CoinMap o+    -> Gen (CoinSelection i o)+genSelection outs = do+    utxo <- vectorOf (length outs * 3) arbitrary >>= genInputs+    let selectionLimit = CS.CoinSelectionLimit $ const 100+    let params = CS.CoinSelectionParameters utxo outs selectionLimit+    case runIdentity $ runExceptT $ selectCoins largestFirst params of+        Left _ -> genSelection outs+        Right (CoinSelectionResult s _) -> return s++instance Arbitrary TxIn where+    shrink _ = []+    arbitrary = TxIn+        <$> arbitrary+        <*> scale (`mod` 3) arbitrary -- No need for a high indexes++instance Arbitrary Coin where+    arbitrary = unsafeCoin @Int <$> choose (1, 100_000)+    shrink = fmap unsafeCoin . filter (> 0) . shrink . coinToIntegral @Int++instance Arbitrary DustThreshold where+    arbitrary = unsafeDustThreshold @Int <$> choose (0, 100)+    shrink = fmap DustThreshold . shrink . unDustThreshold++instance Arbitrary Fee where+    arbitrary = unsafeFee @Int <$> choose (1, 100_000)+    shrink = fmap Fee . shrink . unFee++instance (Arbitrary i, Arbitrary o, Ord i, Ord o) =>+    Arbitrary (FeeProp i o)+  where+    shrink (FeeProp cs utxo opts) =+        case Map.toList $ unCoinMap utxo of+            [] ->+                map (\cs' -> FeeProp cs' utxo opts) (shrink cs)+            us ->+                concatMap (\cs' ->+                    [ FeeProp cs' mempty opts+                    , FeeProp cs' (CoinMap $ Map.fromList (drop 1 us)) opts+                    ]+                ) (shrink cs)+    arbitrary = do+        cs <- arbitrary+        utxo <- choose (0, 50)+            >>= \n -> vectorOf n arbitrary+            >>= genInputs+        fee <- choose (100000, 500000)+        dust <- choose (0, 10000)+        return $ FeeProp cs utxo (fee, dust)++instance Arbitrary (Hash "Tx") where+    shrink _ = []+    arbitrary = do+        bytes <- BS.pack <$> vectorOf 8 arbitraryBoundedIntegral+        pure $ Hash bytes++instance Arbitrary Address where+    shrink _ = []+    arbitrary = do+        bytes <- BS.pack <$> vectorOf 8 arbitraryBoundedIntegral+        pure $ Address bytes++instance (Arbitrary i, Arbitrary o, Ord i, Ord o) =>+    Arbitrary (CoinSelection i o)+  where+    shrink sel = case unCoinSelection sel of+        ([_], [_], []) ->+            []+        (inps, outs, chgs) ->+            let+                inps' = if length inps > 1 then drop 1 inps else inps+                outs' = if length outs > 1 then drop 1 outs else outs+                chgs' = if not (null chgs) then drop 1 chgs else chgs+            in+            filter (\s -> s /= sel && isValidSelection s) $+                mkCoinSelection <$>+                    [ (inps', outs', chgs')+                    , (inps', outs , chgs )+                    , (inps , outs', chgs )+                    , (inps , outs , chgs')+                    ]+      where+        unCoinSelection s =+            (coinMapToList $ inputs s, coinMapToList $ outputs s, change s)+        mkCoinSelection (is, os, cs) =+            CoinSelection (coinMapFromList is) (coinMapFromList os) cs+    arbitrary = do+        outs <- choose (1, 10)+            >>= \n -> vectorOf n arbitrary+            >>= genOutputs+        genSelection outs++data FeeParameters i o = FeeParameters+    { feePerTransaction+        :: Fee+        -- ^ Base fee for a transaction.+    , feePerTransactionEntry+        :: Fee+        -- ^ Incremental fee for each input, output, and change output.+    } deriving (Eq, Generic, Show)++instance Arbitrary (FeeParameters i o) where+    arbitrary = do+        feePerTransaction <- unsafeFee @Int <$> choose (0, 10)+        feePerTransactionEntry <- unsafeFee @Int <$> choose (0, 10)+        pure $ FeeParameters {feePerTransaction, feePerTransactionEntry}+    shrink = genericShrink++-- An estimator that solely depends on the number of inputs and outputs.+stableEstimator :: FeeParameters i o -> FeeEstimator i o+stableEstimator+    FeeParameters {feePerTransaction, feePerTransactionEntry} =+        FeeEstimator $ \s -> Fee $ maybe C.zero+            (C.add (unFee feePerTransaction))+            (C.mul+                (unFee feePerTransactionEntry)+                (length (inputs s) + length (outputs s)))++-- An estimator which depends on the size of inputs and outputs, where the size+-- is a function of their number and their value. The bigger the coins, the+-- bigger the fee.+valueDependentEstimator :: FeeParameters i o -> FeeEstimator i o+valueDependentEstimator+    FeeParameters {feePerTransaction, feePerTransactionEntry} =+        FeeEstimator $ \s -> Fee $ maybe C.zero+            (C.add (unFee feePerTransaction))+            (C.mul+                (unFee feePerTransactionEntry)+                (length (inputs s) + length (outputs s) + size (change s)))+  where+    size :: [Coin] -> Int+    size = sum . fmap sizeOfOne+      where+        sizeOfOne :: Coin -> Int+        sizeOfOne coin+            | coin < C.coinFromNatural 1_000   = 1+            | coin < C.coinFromNatural 10_000  = 2+            | coin < C.coinFromNatural 100_000 = 3+            | otherwise                        = 4++instance Arbitrary (FeeOptions i o) where+    arbitrary = do+        dustThreshold <- unsafeDustThreshold @Int <$> choose (0, 10)+        feeEstimator <- oneof+            [ stableEstimator <$> arbitrary+            , valueDependentEstimator <$> arbitrary+            ]+        feeBalancingPolicy <- elements [RequireBalancedFee, RequireMinimalFee]+        return $ FeeOptions {dustThreshold, feeEstimator, feeBalancingPolicy}++instance Arbitrary a => Arbitrary (NonEmpty a) where+    arbitrary = do+        tailLength <- choose (0, 10)+        (:|) <$> arbitrary <*> replicateM tailLength arbitrary+    shrink = genericShrink++instance Show (FeeOptions i o) where+    show (FeeOptions _ dust policy) = show (dust, policy)

@@ -0,0 +1,257 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeApplications #-}++{-# OPTIONS_GHC -fno-warn-orphans #-}++module Cardano.CoinSelection.TypesSpec+    ( spec+    ) where++import Prelude++import Cardano.CoinSelection+    ( CoinMap (..), coinMapValue )+import Cardano.Test.Utilities+    ( Address (..)+    , Hash (..)+    , ShowFmt (..)+    , TxIn (..)+    , TxOut (..)+    , excluding+    , isSubsetOf+    , restrictedBy+    , restrictedTo+    , unsafeCoin+    , unsafeFromHex+    )+import Data.Set+    ( Set, (\\) )+import Internal.Coin+    ( Coin )+import Test.Hspec+    ( Spec, describe, it )+import Test.QuickCheck+    ( Arbitrary (..)+    , Property+    , checkCoverage+    , choose+    , cover+    , oneof+    , property+    , scale+    , vectorOf+    , (===)+    )++import qualified Data.Map.Strict as Map+import qualified Data.Set as Set+import qualified Internal.Coin as C++spec :: Spec+spec = do++    describe "Lemma 2.1 - Properties of UTxO operations" $ do+        it "2.1.1) ins⊲ u ⊆ u"+            (checkCoverage $ prop_2_1_1 @TxIn)+        it "2.1.2) ins⋪ u ⊆ u"+            (checkCoverage $ prop_2_1_2 @TxIn)+        it "2.1.3) u ⊳ outs ⊆ u"+            (checkCoverage $ prop_2_1_3 @TxIn)+        it "2.1.4) ins⊲ (u ⋃ v) = (ins⊲ u) ⋃ (ins⊲ v)"+            (checkCoverage $ prop_2_1_4 @TxIn)+        it "2.1.5) ins⋪ (u ⋃ v) = (ins⋪ u) ⋃ (ins⋪ v)"+            (checkCoverage $ prop_2_1_5 @TxIn)+        it "2.1.6) (dom u ⋂ ins) ⊲ u = ins⊲ u"+            (checkCoverage $ prop_2_1_6 @TxIn)+        it "2.1.7) (dom u ⋂ ins) ⋪ u = ins⋪ u"+            (checkCoverage $ prop_2_1_7 @TxIn)+        it "2.1.8) (dom u ⋃ ins) ⋪ (u ⋃ v) = (ins ⋃ dom u) ⋪ v"+            (checkCoverage $ prop_2_1_8 @TxIn)+        it "2.1.9) ins⋪ u = (dom u \\ ins)⊲ u"+            (checkCoverage $ prop_2_1_9 @TxIn)++    describe "Lemma 2.6 - Properties of balance" $ do+        it "2.6.1) dom u ⋂ dom v ==> balance (u ⋃ v) = balance u + balance v"+            (checkCoverage $ prop_2_6_1 @TxIn)+        it "2.6.2) balance (ins⋪ u) = balance u - balance (ins⊲ u)"+            (checkCoverage $ prop_2_6_2 @TxIn)++--------------------------------------------------------------------------------+-- Wallet Specification - Lemma 2.1 - Properties of UTxO operations+--------------------------------------------------------------------------------++prop_2_1_1 :: Ord u => (Set u, CoinMap u) -> Property+prop_2_1_1 (ins, u) =+    cover 50 cond "dom u ⋂ ins ≠ ∅" (property prop)+  where+    cond = not $ Set.null $ dom u `Set.intersection` ins+    prop = (u `restrictedBy` ins) `isSubsetOf` u++prop_2_1_2 :: Ord u => (Set u, CoinMap u) -> Property+prop_2_1_2 (ins, u) =+    cover 50 cond "dom u ⋂ ins ≠ ∅" (property prop)+  where+    cond = not $ Set.null $ dom u `Set.intersection` ins+    prop = (u `excluding` ins) `isSubsetOf` u++prop_2_1_3 :: Ord u => (Set Coin, CoinMap u) -> Property+prop_2_1_3 (outs, u) =+    cover 50 cond "u ⋂ outs ≠ ∅" (property prop)+  where+    cond = not $ Set.null $+        Set.fromList (Map.elems (unCoinMap u)) `Set.intersection` outs+    prop = (u `restrictedTo` outs) `isSubsetOf` u++prop_2_1_4 :: (Ord u, Show u) => (Set u, CoinMap u, CoinMap u) -> Property+prop_2_1_4 (ins, u, v) =+    cover 50 cond "(dom u ⋃ dom v) ⋂ ins ≠ ∅" (property prop)+  where+    cond = not $ Set.null $ Set.union (dom u) (dom v) `Set.intersection` ins+    prop =+        ((u <> v) `restrictedBy` ins)+            ===+        (u `restrictedBy` ins) <> (v `restrictedBy` ins)++prop_2_1_5 :: (Ord u, Show u) => (Set u, CoinMap u, CoinMap u) -> Property+prop_2_1_5 (ins, u, v) =+    cover 50 cond "(dom u ⋃ dom v) ⋂ ins ≠ ∅" (property prop)+  where+    cond = not $ Set.null $ Set.union (dom u) (dom v) `Set.intersection` ins+    prop =+        ((u <> v) `excluding` ins)+            ===+        (u `excluding` ins) <> (v `excluding` ins)++prop_2_1_6 :: (Ord u, Show u) => (Set u, CoinMap u) -> Property+prop_2_1_6 (ins, u) =+    cover 50 cond "dom u ⋂ ins ≠ ∅" (property prop)+  where+    cond = not $ Set.null $ dom u `Set.intersection` ins+    prop =+        (u `restrictedBy` (dom u `Set.intersection` ins))+            ===+        (u `restrictedBy` ins)++prop_2_1_7 :: (Ord u, Show u) => (Set u, CoinMap u) -> Property+prop_2_1_7 (ins, u) =+    cover 50 cond "dom u ⋂ ins ≠ ∅" (property prop)+  where+    cond = not $ Set.null $ dom u `Set.intersection` ins+    prop =+        (u `excluding` (dom u `Set.intersection` ins))+            ===+        (u `excluding` ins)++prop_2_1_8 :: (Ord u, Show u) => (Set u, CoinMap u, CoinMap u) -> Property+prop_2_1_8 (ins, u, v) =+    cover 50 cond "dom u ⋂ ins ≠ ∅" (property prop)+  where+    cond = not $ Set.null $ dom u `Set.intersection` ins+    prop =+        ((u <> v) `excluding` (dom u <> ins))+            ===+        v `excluding` (ins <> dom u)++prop_2_1_9 :: (Ord u, Show u) => (Set u, CoinMap u) -> Property+prop_2_1_9 (ins, u) =+    cover 50 cond "dom u ⋂ ins ≠ ∅" (property prop)+  where+    cond = not $ Set.null $ dom u `Set.intersection` ins+    prop = (u `excluding` ins) === u `restrictedBy` (dom u \\ ins)++--------------------------------------------------------------------------------+-- Wallet Specification - Lemma 2.6 - Properties of Balance+--------------------------------------------------------------------------------++prop_2_6_1 :: Ord u => (CoinMap u, CoinMap u) -> Property+prop_2_6_1 (u, v) =+    cover 50 cond "u ≠ ∅ , v ≠ ∅" (property prop)+  where+    -- NOTE:+    -- A precondition (u ⋂ v = ∅ ) is hard to satisfy because our generators+    -- are built in order to not be 'too entropic'. So, we better just create+    -- a v' that has no overlap with u.+    v' = v `excluding` dom u+    cond = not (u `isSubsetOf` mempty || v' `isSubsetOf` mempty)+    prop = coinMapValue (u <> v')+        === coinMapValue u `C.add` coinMapValue v'++prop_2_6_2 :: Ord u => (Set u, CoinMap u) -> Property+prop_2_6_2 (ins, u) =+    cover 50 cond "dom u ⋂ ins ≠ ∅" (property prop)+  where+    cond = not $ Set.null $ dom u `Set.intersection` ins+    prop =+        Just (coinMapValue (u `excluding` ins))+            ===+        coinMapValue u `C.sub`+            coinMapValue (u `restrictedBy` ins)++--------------------------------------------------------------------------------+-- UTxO Utilities+--------------------------------------------------------------------------------++-- | Extracts the domain of a UTxO: the set of references to unspent transaction+--   ouputs.+dom :: CoinMap u -> Set u+dom (CoinMap utxo) = Map.keysSet utxo++--------------------------------------------------------------------------------+-- Arbitrary Instances+--+-- Arbitrary instances define here aren't necessarily reflecting on real-life+-- scenario, but they help test the property above by constructing data+-- structures that don't have much entropy and therefore, allow us to even test+-- something when checking for intersections and set restrictions!+--------------------------------------------------------------------------------++deriving instance Arbitrary a => Arbitrary (ShowFmt a)++instance Arbitrary (Hash "Tx") where+    -- No Shrinking+    arbitrary = oneof+        [ pure $ Hash $ unsafeFromHex+            "0000000000000000000000000000000000000000000000000000000000000001"+        , pure $ Hash $ unsafeFromHex+            "0000000000000000000000000000000000000000000000000000000000000002"+        , pure $ Hash $ unsafeFromHex+            "0000000000000000000000000000000000000000000000000000000000000003"+        ]++instance Arbitrary Address where+    -- No Shrinking+    arbitrary = oneof+        [ pure $ Address "ADDR01"+        , pure $ Address "ADDR02"+        , pure $ Address "ADDR03"+        ]++instance Arbitrary Coin where+    -- No Shrinking+    arbitrary = unsafeCoin @Int <$> choose (0, 3)++instance Arbitrary TxOut where+    -- No Shrinking+    arbitrary = TxOut+        <$> arbitrary+        <*> arbitrary++instance Arbitrary TxIn where+    -- No Shrinking+    arbitrary = TxIn+        <$> arbitrary+        <*> scale (`mod` 3) arbitrary -- No need for a crazy high indexes++instance (Arbitrary u, Ord u) => Arbitrary (CoinMap u) where+    shrink (CoinMap utxo) = CoinMap <$> shrink utxo+    arbitrary = do+        n <- choose (0, 10)+        utxo <- zip+            <$> vectorOf n arbitrary+            <*> vectorOf n arbitrary+        return $ CoinMap $ Map.fromList utxo

@@ -0,0 +1,460 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}++{-# OPTIONS_GHC -fno-warn-orphans #-}++module Cardano.CoinSelectionSpec+    ( spec++    -- * Export used to test various coin selection implementations+    , CoinSelectionFixture (..)+    , CoinSelectionTestResult (..)+    , CoinSelProp (..)+    , coinSelectionUnitTest+    ) where++-- | This module contains shared functionality for coin selection tests.+--+-- Coin selection algorithms share a common interface, and therefore it makes+-- sense for them to also share arbitrary instances and tests.++import Prelude++import Cardano.CoinSelection+    ( CoinMap (..)+    , CoinMapEntry (..)+    , CoinSelection (..)+    , CoinSelectionAlgorithm (..)+    , CoinSelectionError (..)+    , CoinSelectionLimit (..)+    , CoinSelectionParameters (..)+    , CoinSelectionResult (..)+    , coinMapFromList+    , coinMapToList+    , coinMapValue+    , sumChange+    , sumInputs+    , sumOutputs+    )+import Cardano.Test.Utilities+    ( Address (..), Hash (..), ShowFmt (..), TxIn (..), unsafeCoin )+import Control.Arrow+    ( (&&&) )+import Control.Monad.Trans.Except+    ( runExceptT )+import Data.Function+    ( (&) )+import Data.List.NonEmpty+    ( NonEmpty (..) )+import Data.Maybe+    ( catMaybes )+import Data.Set+    ( Set )+import Data.Word+    ( Word16, Word8 )+import Fmt+    ( Buildable (..), blockListF, nameF )+import Internal.Coin+    ( Coin, coinToIntegral )+import Test.Hspec+    ( Spec, SpecWith, describe, it, shouldBe )+import Test.QuickCheck+    ( Arbitrary (..)+    , Confidence (..)+    , Gen+    , NonEmptyList (..)+    , Property+    , arbitraryBoundedIntegral+    , checkCoverage+    , checkCoverageWith+    , choose+    , cover+    , elements+    , generate+    , genericShrink+    , oneof+    , property+    , scale+    , vectorOf+    )+import Test.QuickCheck.Monadic+    ( monadicIO )+import Test.Vector.Shuffle+    ( shuffle )++import qualified Data.ByteString as BS+import qualified Data.List as L+import qualified Data.List.NonEmpty as NE+import qualified Data.Map.Strict as Map+import qualified Data.Set as Set+import qualified Internal.Coin as C+import qualified Test.QuickCheck.Monadic as QC++spec :: Spec+spec = do+    describe "CoinMap properties" $ do+        it "CoinMap coverage is adequate" $+            checkCoverage $ prop_CoinMap_coverage @Int+        it "CoinMapEntry coverage is adequate" $+            checkCoverage $ prop_CoinMapEntry_coverage @Int+        it "coinMapFromList preserves total value for each unique key" $+            checkCoverage $+                prop_coinMapFromList_preservesTotalValueForEachUniqueKey @Int+        it "coinMapFromList preserves total value" $+            checkCoverage $ prop_coinMapFromList_preservesTotalValue @Int+        it "coinMapToList preserves total value" $+            checkCoverage $ prop_coinMapToList_preservesTotalValue @Int+        it "coinMapFromList . coinMapToList = id" $+            checkCoverage $ prop_coinMapToList_coinMapFromList @Int+        it "coinMapToList . coinMapFromList = id (when no keys duplicated)" $+            checkCoverage $ prop_coinMapFromList_coinMapToList @Int+        it "coinMapToList order deterministic" $+            checkCoverageWith lowerConfidence $+                prop_coinMapToList_orderDeterministic @Int++    describe "CoinSelection properties" $ do+        it "monoidal append preserves keys" $+            checkCoverage $ prop_coinSelection_mappendPreservesKeys @Int @Int+        it "monoidal append preserves value" $+            checkCoverage $+                prop_coinSelection_mappendPreservesTotalValue @Int @Int++  where+    lowerConfidence :: Confidence+    lowerConfidence = Confidence (10^(6 :: Integer)) 0.75++--------------------------------------------------------------------------------+-- Properties+--------------------------------------------------------------------------------++prop_CoinMap_coverage+    :: CoinMap u+    -> Property+prop_CoinMap_coverage m = property+    $ cover 10 (null m)+        "coin map is empty"+    $ cover 10 (length m == 1)+        "coin map has one entry"+    $ cover 10 (length m >= 2)+        "coin map has multiple entries"+    $ cover 10 (1 == length (Set.fromList $ entryValue <$> coinMapToList m))+        "coin map has one unique value"+    $ cover 10 (1 < length (Set.fromList $ entryValue <$> coinMapToList m))+        "coin map has several unique values"+    True++prop_CoinMapEntry_coverage :: forall u . Ord u => [CoinMapEntry u] -> Property+prop_CoinMapEntry_coverage entries = property+    $ cover 2 (null entries)+        "coin map entry list is empty"+    $ cover 2 (length entries == 1)+        "coin map entry list has one entry"+    $ cover 2 (length entries == 2)+        "coin map entry list has two entries"+    $ cover 2 (length entries >= 3)+        "coin map entry list has multiple entries"+    $ cover 2 (not (null entries) && length uniqueKeys == 1)+        "coin map entry list has one unique key"+    $ cover 2 (not (null entries) && length uniqueKeys == 2)+        "coin map entry list has two unique keys"+    $ cover 2 (not (null entries) && length uniqueKeys >= 3)+        "coin map entry list has multiple unique keys"+    $ cover 2 (not (null entries) && null duplicateKeys)+        "coin map entry list has no duplicate keys"+    $ cover 2 (not (null entries) && length duplicateKeys == 1)+        "coin map entry list has one duplicate key"+    $ cover 2 (not (null entries) && length duplicateKeys == 2)+        "coin map entry list has two duplicate keys"+    $ cover 2 (not (null entries) && length duplicateKeys >= 3)+        "coin map entry list has multiple duplicate keys"+    True+  where+    uniqueKeys :: Set u+    uniqueKeys = entries+        & fmap entryKey+        & Set.fromList+    duplicateKeys :: Set u+    duplicateKeys = entries+        & fmap (entryKey &&& const (1 :: Int))+        & Map.fromListWith (+)+        & Map.filter (> 1)+        & Map.keysSet++prop_coinMapFromList_preservesTotalValueForEachUniqueKey+    :: (Ord u, Show u)+    => [CoinMapEntry u]+    -> Property+prop_coinMapFromList_preservesTotalValueForEachUniqueKey entries = property $+    mkEntryMap entries+        `shouldBe`+        mkEntryMap (coinMapToList (coinMapFromList entries))+  where+    mkEntryMap+        = Map.fromListWith C.add+        . fmap (entryKey &&& entryValue)++prop_coinMapFromList_preservesTotalValue+    :: Ord u+    => [CoinMapEntry u]+    -> Property+prop_coinMapFromList_preservesTotalValue entries = property $+    mconcat (entryValue <$> entries)+        `shouldBe` coinMapValue (coinMapFromList entries)++prop_coinMapToList_preservesTotalValue+    :: CoinMap u+    -> Property+prop_coinMapToList_preservesTotalValue m = property $+    mconcat (entryValue <$> coinMapToList m)+        `shouldBe` coinMapValue m++prop_coinMapToList_coinMapFromList+    :: (Ord u, Show u)+    => CoinMap u+    -> Property+prop_coinMapToList_coinMapFromList m = property $+    coinMapFromList (coinMapToList m)+        `shouldBe` m++prop_coinMapFromList_coinMapToList+    :: (Ord u, Show u)+    => [CoinMapEntry u]+    -> Property+prop_coinMapFromList_coinMapToList entries+    | duplicateKeyCount == 0 =+        property $ x `shouldBe` y+    | otherwise =+        property $ length x > length y+  where+    x = L.sort entries+    y = L.sort $ coinMapToList $ coinMapFromList entries++    duplicateKeyCount :: Int+    duplicateKeyCount = entries+        & fmap (entryKey &&& const (1 :: Int))+        & Map.fromListWith (+)+        & Map.filter (> 1)+        & Map.keysSet+        & length++prop_coinMapToList_orderDeterministic+    :: Ord u => CoinMap u -> Property+prop_coinMapToList_orderDeterministic u = monadicIO $ QC.run $ do+    let list0 = coinMapToList u+    list1 <- shuffle list0+    return $+        cover 10 (list0 /= list1) "shuffled" $+        list0 == coinMapToList (coinMapFromList list1)++prop_coinSelection_mappendPreservesKeys+    :: (Ord i, Ord o, Show i, Show o)+    => CoinSelection i o+    -> CoinSelection i o+    -> Property+prop_coinSelection_mappendPreservesKeys s1 s2 = property $ do+    Map.keysSet (unCoinMap $ inputs $ s1 <> s2)+        `shouldBe`+        Map.keysSet (unCoinMap $ inputs s1)+        `Set.union`+        Map.keysSet (unCoinMap $ inputs s2)+    Map.keysSet (unCoinMap $ outputs $ s1 <> s2)+        `shouldBe`+        Map.keysSet (unCoinMap $ outputs s1)+        `Set.union`+        Map.keysSet (unCoinMap $ outputs s2)++prop_coinSelection_mappendPreservesTotalValue+    :: (Ord i, Ord o)+    => CoinSelection i o+    -> CoinSelection i o+    -> Property+prop_coinSelection_mappendPreservesTotalValue s1 s2 = property $ do+    sumInputs  s1 <> sumInputs  s2 `shouldBe` sumInputs  (s1 <> s2)+    sumOutputs s1 <> sumOutputs s2 `shouldBe` sumOutputs (s1 <> s2)+    sumChange  s1 <> sumChange  s2 `shouldBe` sumChange  (s1 <> s2)+    change     s1 <> change     s2 `shouldBe` change     (s1 <> s2)++--------------------------------------------------------------------------------+-- Coin Selection - Unit Tests+--------------------------------------------------------------------------------++-- | Data for running+data CoinSelProp i o = CoinSelProp+    { csUtxO :: CoinMap i+        -- ^ Available UTxO for the selection+    , csOuts :: CoinMap o+        -- ^ Requested outputs for the payment+    } deriving Show++instance (Buildable i, Buildable o) => Buildable (CoinSelProp i o) where+    build (CoinSelProp utxo outs) = mempty+        <> nameF "utxo" (blockListF $ coinMapToList utxo)+        <> nameF "outs" (blockListF $ coinMapToList outs)++-- | A fixture for testing the coin selection+data CoinSelectionFixture i o = CoinSelectionFixture+    { maxNumOfInputs :: Word16+        -- ^ Maximum number of inputs that can be selected+    , utxoInputs :: [Integer]+        -- ^ Value (in Lovelace) & number of available coins in the UTxO+    , txOutputs :: [Integer]+        -- ^ Value (in Lovelace) & number of requested outputs+    }++-- | Testing-friendly format for 'CoinSelection' results of unit tests.+data CoinSelectionTestResult = CoinSelectionTestResult+    { rsInputs :: [Integer]+    , rsChange :: [Integer]+    , rsOutputs :: [Integer]+    } deriving (Eq, Show)++sortCoinSelectionTestResult+    :: CoinSelectionTestResult -> CoinSelectionTestResult+sortCoinSelectionTestResult (CoinSelectionTestResult is cs os) =+    CoinSelectionTestResult (L.sort is) (L.sort cs) (L.sort os)++-- | Generate a 'UTxO' and 'TxOut' matching the given 'Fixture', and perform+-- the given coin selection on it.+coinSelectionUnitTest+    :: CoinSelectionAlgorithm TxIn Address IO+    -> String+    -> Either CoinSelectionError CoinSelectionTestResult+    -> CoinSelectionFixture TxIn Address+    -> SpecWith ()+coinSelectionUnitTest alg lbl expected (CoinSelectionFixture n utxoF outsF) =+    it title $ do+        (utxo,txOuts) <- setup+        result <- runExceptT $ do+            CoinSelectionResult (CoinSelection inps outs chngs) _ <-+                selectCoins alg $+                    CoinSelectionParameters utxo txOuts selectionLimit+            return $ CoinSelectionTestResult+                { rsInputs = coinToIntegral . entryValue <$> coinMapToList inps+                , rsChange = coinToIntegral <$> chngs+                , rsOutputs = coinToIntegral . entryValue <$> coinMapToList outs+                }+        fmap sortCoinSelectionTestResult result+            `shouldBe` fmap sortCoinSelectionTestResult expected+  where+    selectionLimit = CoinSelectionLimit $ const n++    title :: String+    title = mempty+        <> if null lbl then "" else lbl <> ":\n\t"+        <> "max=" <> show n+        <> ", UTxO=" <> show utxoF+        <> ", Output=" <> show outsF+        <> " --> " <> show (rsInputs <$> expected)++    setup :: IO (CoinMap TxIn, CoinMap Address)+    setup = do+        utxo <- generate (genUTxO utxoF)+        outs <- generate (genOutputs outsF)+        pure (utxo, outs)++--------------------------------------------------------------------------------+-- Arbitrary Instances+--------------------------------------------------------------------------------++deriving instance Arbitrary a => Arbitrary (ShowFmt a)++instance (Arbitrary i, Arbitrary o, Ord i, Ord o) =>+    Arbitrary (CoinSelection i o)+  where+    arbitrary = CoinSelection+        <$> arbitrary+        <*> arbitrary+        <*> arbitrary+    shrink = genericShrink++instance Arbitrary (CoinSelectionLimit) where+    arbitrary = do+        -- NOTE Functions have to be decreasing functions+        fn <- elements+            [ (maxBound -)+            , \x ->+                if x > maxBound `div` 2+                    then maxBound+                    else maxBound - (2 * x)+            , const 42+            ]+        pure $ CoinSelectionLimit fn++instance Show (CoinSelectionLimit) where+    show _ = "CoinSelectionLimit"++instance Arbitrary a => Arbitrary (NonEmpty a) where+    shrink xs = catMaybes (NE.nonEmpty <$> shrink (NE.toList xs))+    arbitrary = do+        n <- choose (1, 10)+        NE.fromList <$> vectorOf n arbitrary++instance (Arbitrary i, Arbitrary o, Ord i, Ord o) =>+    Arbitrary (CoinSelProp i o)+  where+    shrink (CoinSelProp utxo outs) = uncurry CoinSelProp <$> zip+        (shrink utxo)+        (coinMapFromList <$> filter (not . null) (shrink (coinMapToList outs)))+    arbitrary = CoinSelProp+        <$> (coinMapFromList . getNonEmpty <$> arbitrary)+        <*> (coinMapFromList . getNonEmpty <$> arbitrary)++instance Arbitrary Address where+    shrink _ = []+    arbitrary = do+        bytes <- BS.pack <$> vectorOf 8 arbitraryBoundedIntegral+        pure $ Address bytes++instance Arbitrary Coin where+    -- No Shrinking+    arbitrary = unsafeCoin @Int <$> choose (1, 100000)++instance Arbitrary TxIn where+    -- No Shrinking+    arbitrary = TxIn+        <$> arbitrary+        <*> scale (`mod` 3) arbitrary -- No need for a high indexes++instance Arbitrary (Hash "Tx") where+    -- No Shrinking+    arbitrary = do+        wds <- vectorOf 10 arbitrary :: Gen [Word8]+        let bs = BS.pack wds+        pure $ Hash bs++instance Arbitrary a => Arbitrary (CoinMapEntry a) where+    -- No Shrinking+    arbitrary = CoinMapEntry+        <$> arbitrary+        <*> arbitrary++instance (Arbitrary a, Ord a) => Arbitrary (CoinMap a) where+    shrink (CoinMap m) = CoinMap <$> shrink m+    arbitrary = do+        n <- oneof+            [ pure 0+            , pure 1+            , choose (2, 100)+            ]+        entries <- zip+            <$> vectorOf n arbitrary+            <*> vectorOf n arbitrary+        return $ CoinMap $ Map.fromList entries++genUTxO :: [Integer] -> Gen (CoinMap TxIn)+genUTxO coins = do+    let n = length coins+    inps <- vectorOf n arbitrary+    return $ CoinMap $ Map.fromList $ zip inps (unsafeCoin <$> coins)++genOutputs :: [Integer] -> Gen (CoinMap Address)+genOutputs coins = do+    let n = length coins+    outs <- vectorOf n arbitrary+    return $ coinMapFromList $ zipWith CoinMapEntry outs (map unsafeCoin coins)

@@ -0,0 +1,264 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE NumericUnderscores #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}++{-# OPTIONS_GHC -fno-warn-orphans #-}++-- | Utility functions, types, and type class instances used purely for testing.+--+-- Copyright: © 2018-2020 IOHK+-- License: Apache-2.0+--+module Cardano.Test.Utilities+    (+    -- * Addresses+      Address (..)++    -- * Hashes+    , Hash (..)++    -- * Formatting+    , ShowFmt (..)++    -- * Transactions+    , TxIn (..)+    , TxOut (..)++    -- * UTxO Operations+    , excluding+    , isSubsetOf+    , restrictedBy+    , restrictedTo++    -- * Unsafe Operations+    , unsafeCoin+    , unsafeDustThreshold+    , unsafeFee+    , unsafeFromHex++    ) where++import Prelude++import Cardano.CoinSelection+    ( CoinMap (..), CoinMapEntry (..), CoinSelection (..), coinMapToList )+import Cardano.CoinSelection.Fee+    ( DustThreshold (..), Fee (..) )+import Control.DeepSeq+    ( NFData (..) )+import Data.ByteArray+    ( ByteArrayAccess )+import Data.ByteArray.Encoding+    ( Base (Base16), convertFromBase, convertToBase )+import Data.ByteString+    ( ByteString )+import Data.Maybe+    ( fromMaybe )+import Data.Set+    ( Set )+import Data.Word+    ( Word32 )+import Fmt+    ( Buildable (..)+    , blockListF+    , fmt+    , listF+    , nameF+    , ordinalF+    , prefixF+    , suffixF+    )+import GHC.Generics+    ( Generic )+import GHC.Stack+    ( HasCallStack )+import GHC.TypeLits+    ( Symbol )+import Internal.Coin+    ( Coin, coinFromIntegral )+import Numeric.Natural+    ( Natural )+import Quiet+    ( Quiet (Quiet) )++import qualified Data.Map.Strict as Map+import qualified Data.Set as Set+import qualified Data.Text.Encoding as T+import qualified Internal.Coin as C++--------------------------------------------------------------------------------+-- Addresses+--------------------------------------------------------------------------------++newtype Address = Address+    { unAddress :: ByteString }+    deriving stock (Eq, Generic, Ord)+    deriving Show via (Quiet Address)++instance NFData Address++instance Buildable Address where+    build addr = mempty+        <> prefixF 8 addrF+        <> "..."+        <> suffixF 8 addrF+      where+        addrF = build (toText addr)+        toText = T.decodeUtf8+            . convertToBase Base16+            . unAddress++--------------------------------------------------------------------------------+-- Unsafe Operations+--------------------------------------------------------------------------------++unsafeCoin :: (Integral i, Show i) => i -> Coin+unsafeCoin i = fromMaybe die $ coinFromIntegral i+  where+    die = error $ mconcat+        [ "Test suite attempted to create a coin with negative value: "+        , show i+        ]++unsafeDustThreshold :: (Integral i, Show i) => i -> DustThreshold+unsafeDustThreshold i = DustThreshold $ fromMaybe die $ coinFromIntegral i+  where+    die = error $ mconcat+        [ "Test suite attempted to create a dust theshold with negative value: "+        , show i+        ]++unsafeFee :: (Integral i, Show i) => i -> Fee+unsafeFee i = Fee $ fromMaybe die $ coinFromIntegral i+  where+    die = error $ mconcat+        [ "Test suite attempted to create a fee with negative value: "+        , show i+        ]++-- | Decode an hex-encoded 'ByteString' into raw bytes, or fail.+unsafeFromHex :: HasCallStack => ByteString -> ByteString+unsafeFromHex =+    either (error . show) id . convertFromBase @ByteString @ByteString Base16++--------------------------------------------------------------------------------+-- Hashes+--------------------------------------------------------------------------------++newtype Hash (tag :: Symbol) = Hash { getHash :: ByteString }+    deriving stock (Eq, Generic, Ord)+    deriving newtype (ByteArrayAccess)+    deriving Show via (Quiet (Hash tag))++instance NFData (Hash tag)++instance Buildable (Hash tag) where+    build h = mempty+        <> prefixF 8 builder+      where+        builder = build . toText $ h+        toText = T.decodeUtf8 . convertToBase Base16 . getHash++--------------------------------------------------------------------------------+-- Formatting+--------------------------------------------------------------------------------++-- | A polymorphic wrapper type with a custom 'Show' instance to display data+--   through 'Buildable' instances.+newtype ShowFmt a = ShowFmt { unShowFmt :: a }+    deriving (Generic, Eq, Ord)++instance NFData a => NFData (ShowFmt a)++instance Buildable a => Show (ShowFmt a) where+    show (ShowFmt a) = fmt (build a)++--------------------------------------------------------------------------------+-- Transactions+--------------------------------------------------------------------------------++data TxIn = TxIn+    { txinId+        :: !(Hash "Tx")+    , txinIx+        :: !Word32+    } deriving (Show, Generic, Eq, Ord)++instance NFData TxIn++instance Buildable TxIn where+    build txin = mempty+        <> ordinalF (txinIx txin + 1)+        <> " "+        <> build (txinId txin)++data TxOut = TxOut+    { txoutAddress+        :: !Address+    , txoutCoin+        :: !Coin+    } deriving (Show, Generic, Eq, Ord)++instance Buildable TxOut where+    build txout = mempty+        <> build (txoutCoin txout)+        <> " @ "+        <> prefixF 8 addrF+        <> "..."+        <> suffixF 8 addrF+      where+        addrF = build $ txoutAddress txout++--------------------------------------------------------------------------------+-- UTxO Operations+--------------------------------------------------------------------------------++-- | ins⋪ u+excluding :: Ord u => CoinMap u -> Set u -> CoinMap u+excluding (CoinMap utxo) =+    CoinMap . Map.withoutKeys utxo++-- | a ⊆ b+isSubsetOf :: Ord u => CoinMap u -> CoinMap u -> Bool+isSubsetOf (CoinMap a) (CoinMap b) =+    a `Map.isSubmapOf` b++-- | ins⊲ u+restrictedBy :: Ord u => CoinMap u -> Set u -> CoinMap u+restrictedBy (CoinMap utxo) =+    CoinMap . Map.restrictKeys utxo++-- | u ⊳ outs+restrictedTo :: CoinMap u -> Set Coin -> CoinMap u+restrictedTo (CoinMap utxo) outs =+    CoinMap $ Map.filter (`Set.member` outs) utxo++--------------------------------------------------------------------------------+-- Buildable Instances+--------------------------------------------------------------------------------++instance Buildable Coin where+    build = build . fromIntegral @Natural @Integer . C.coinToIntegral++instance Buildable a => Buildable (CoinMapEntry a) where+    build a = mempty+        <> build (entryKey a)+        <> ":"+        <> build (entryValue a)++instance (Buildable i, Buildable o) => Buildable (CoinSelection i o) where+    build s = mempty+        <> nameF "inputs"+            (blockListF $ coinMapToList $ inputs s)+        <> nameF "outputs"+            (blockListF $ coinMapToList $ outputs s)+        <> nameF "change"+            (listF $ change s)

@@ -0,0 +1,164 @@+{-# LANGUAGE TypeApplications #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Internal.CoinSpec+    ( spec+    ) where++import Prelude++import Data.Maybe+    ( catMaybes, fromMaybe )+import Internal.Coin+    ( Coin )+import Test.Hspec+    ( Spec, describe, it, shouldBe, shouldSatisfy )+import Test.QuickCheck+    ( Arbitrary (..)+    , NonNegative (..)+    , Property+    , checkCoverage+    , cover+    , oneof+    , property+    )++import qualified Internal.Coin as C++spec :: Spec+spec = do++    describe "Coin properties" $ do+        it "Only construction of non-negative values is possible." $+            checkCoverage prop_construction+        it "Coverage of generated values is acceptable." $+            checkCoverage prop_generation+        it "Addition" $+            checkCoverage prop_add+        it "Multiplication" $+            checkCoverage prop_mul+        it "Subtraction" $+            checkCoverage prop_sub+        it "Division" $+            checkCoverage prop_div+        it "Modulus" $+            checkCoverage prop_mod+        it "Distance" $+            checkCoverage prop_distance++prop_construction+    :: Integer+    -> Property+prop_construction i = property+    $ cover 10 (i < 0)+        "input is negative"+    $ cover 10 (i > 0)+        "input is positive"+    $ cover 2 (i == 0)+        "input is zero"+    $ if i < 0+        then C.coinFromIntegral i `shouldBe` Nothing+        else (C.coinToIntegral <$> C.coinFromIntegral i) `shouldBe` Just i++prop_generation+    :: Coin+    -> Property+prop_generation n = property+    $ cover 2 (n == C.zero)+        "value is zero"+    $ cover 2 (n == C.one)+        "value is one"+    $ cover 10 (n > C.one)+        "value is more than one"+    True++prop_add :: Coin -> Coin -> Property+prop_add x y = property $+    C.coinToIntegral @Integer (x `C.add` y)+        `shouldBe`+        (C.coinToIntegral x + C.coinToIntegral y)++prop_mul :: Coin -> Integer -> Property+prop_mul x y = property+    $ cover 2 (y == 0)+        "scaling factor is zero"+    $ cover 8 (y < 0)+        "scaling factor is negative"+    $ cover 8 (y > 0)+        "scaling factor is positive"+    $ case (x `C.mul` y) of+        Nothing ->+            y `shouldSatisfy` (< 0)+        Just r ->+            (C.coinToIntegral x * y) `shouldBe` C.coinToIntegral @Integer r++prop_sub :: Coin -> Coin -> Property+prop_sub x y = property+    $ cover 4 (x == y)+        "values are equal"+    $ cover 8 (x < y)+        "x < y"+    $ cover 8 (x > y)+        "x > y"+    $ case x `C.sub` y of+        Nothing ->+            x `shouldSatisfy` (< y)+        Just r ->+            C.coinToIntegral x - C.coinToIntegral y+                `shouldBe` C.coinToIntegral @Integer r++prop_div :: Coin -> Integer -> Property+prop_div x y = property+    $ cover 2 (y == 0)+        "denominator is zero"+    $ cover 8 (y < 0)+        "denominator is negative"+    $ cover 8 (y > 0)+        "denominator is positive"+    $ case (x `C.div` y) of+        Nothing ->+            y `shouldSatisfy` (<= 0)+        Just r ->+            (C.coinToIntegral x `div` y)+                `shouldBe` C.coinToIntegral @Integer r++prop_mod :: Coin -> Integer -> Property+prop_mod x y = property+    $ cover 2 (y == 0)+        "denominator is zero"+    $ cover 8 (y < 0)+        "denominator is negative"+    $ cover 8 (y > 0)+        "denominator is positive"+    $ case (x `C.mod` y) of+        Nothing ->+            y `shouldSatisfy` (<= 0)+        Just r ->+            (C.coinToIntegral x `mod` y)+                `shouldBe` C.coinToIntegral @Integer r++prop_distance :: Coin -> Coin -> Property+prop_distance x y = property+    $ cover 4 (x == y)+        "values are equal"+    $ cover 8 (x < y)+        "x < y"+    $ cover 8 (x > y)+        "x > y"+    $ C.coinToIntegral @Integer (x `C.distance` y)+        `shouldBe`+        abs (C.coinToIntegral x - C.coinToIntegral y)++instance Arbitrary Coin where+    arbitrary = oneof+        [ pure C.zero+        , pure C.one+        , somethingElse+        ]+      where+        somethingElse =+            fromMaybe C.zero+            . C.coinFromIntegral @Integer+            . getNonNegative <$> arbitrary+    shrink n = catMaybes+        $ C.coinFromIntegral @Integer <$> shrink (C.coinToIntegral @Integer n)

@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}

@@ -0,0 +1,106 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeApplications #-}++module Test.Vector.Shuffle+    ( -- * Simple+      shuffle+    , shuffleNonEmpty++      -- * Advanced+    , mkSeed+    , shuffleWith+    , shuffleNonEmptyWith+    ) where++import Prelude++import Control.Monad+    ( forM_ )+import Control.Monad.Trans.Class+    ( lift )+import Control.Monad.Trans.State.Strict+    ( evalStateT, state )+import Crypto.Hash+    ( hash )+import Crypto.Hash.Algorithms+    ( MD5 )+import Data.List.NonEmpty+    ( NonEmpty (..) )+import Data.Maybe+    ( fromMaybe )+import Data.Text+    ( Text )+import Data.Vector.Mutable+    ( IOVector )+import Data.Word+    ( Word8 )+import System.Random+    ( RandomGen, StdGen, mkStdGen, newStdGen, randomR )++import qualified Data.ByteArray as BA+import qualified Data.ByteString as BS+import qualified Data.List.NonEmpty as NE+import qualified Data.Text.Encoding as T+import qualified Data.Vector as V+import qualified Data.Vector.Mutable as MV++-- | Generate a random generator seed from a text string+mkSeed :: Text -> StdGen+mkSeed = mkStdGen . toInt . quickHash . T.encodeUtf16LE+  where+    quickHash = BA.convert . hash @_ @MD5+    toInt = snd . BS.foldl' exponentiation (0,0)+      where+        exponentiation :: (Int, Int) -> Word8 -> (Int, Int)+        exponentiation (e, n) i = (e+1, n + fromIntegral i*2^e)++-- | Shuffles a list of elements.+--+-- >>> shuffle (outputs coinSel)+-- [...]+shuffle :: [a] -> IO [a]+shuffle xs = newStdGen >>= flip shuffleWith xs++-- | Like 'shuffle', but from a given seed. 'shuffle' will use a randomly+-- generate seed using 'newStdGen' from @System.Random@.+--+-- __Properties:__+--+-- - @shuffleWith g es == shuffleWith g es@+-- - @∃Δ> 1. g ≠g', length es > Δ⇒ shuffleWith g es ≠shuffleWith g' es@+shuffleWith :: RandomGen g => g -> [a] -> IO [a]+shuffleWith seed = modifyInPlace $ \v -> flip evalStateT seed $ do+    let (lo, hi) = (0, MV.length v - 1)+    forM_ [lo .. hi] $ \i -> do+      j <- fromInteger <$> state (randomR (fromIntegral lo, fromIntegral hi))+      lift $ swapElems v i j+  where+    swapElems :: IOVector a -> Int -> Int -> IO ()+    swapElems v i j = do+        x <- MV.read v i+        y <- MV.read v j+        MV.write v i y+        MV.write v j x++    modifyInPlace :: forall a. (IOVector a -> IO ()) -> [a] -> IO [a]+    modifyInPlace f xs = do+        v' <- V.thaw $ V.fromList xs+        f v'+        V.toList <$> V.freeze v'++-- | Shuffles a /non-empty/ list of elements.+--+-- See 'shuffle'.+--+shuffleNonEmpty :: NonEmpty a -> IO (NonEmpty a)+shuffleNonEmpty xs = newStdGen >>= flip shuffleNonEmptyWith xs++-- | Shuffles a /non-empty/ list of elements with the given random generator.+--+-- See 'shuffleWith'.+--+shuffleNonEmptyWith :: RandomGen g => g -> NonEmpty a -> IO (NonEmpty a)+shuffleNonEmptyWith g =+    fmap (fromMaybe raiseError . NE.nonEmpty) . shuffleWith g . NE.toList+  where+    raiseError = error "shuffleNonEmptyWith encountered an empty list."

@@ -0,0 +1,161 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Test.Vector.ShuffleSpec+    ( spec+    ) where++import Prelude++import Data.List.NonEmpty+    ( NonEmpty (..) )+import Test.Hspec+    ( Spec, describe, it )+import Test.QuickCheck+    ( Arbitrary (..)+    , Confidence (..)+    , NonEmptyList (..)+    , Positive (..)+    , PrintableString (..)+    , Property+    , Testable+    , arbitrary+    , checkCoverageWith+    , cover+    , genericShrink+    , label+    , vectorOf+    , (==>)+    )+import Test.QuickCheck.Monadic+    ( assert, monadicIO, monitor, pick, run )+import Test.Vector.Shuffle+    ( mkSeed, shuffle, shuffleNonEmpty, shuffleWith )++import qualified Data.List as L+import qualified Data.List.NonEmpty as NE+import qualified Data.Text as T++spec :: Spec+spec = do+    describe "shuffle" $ do+        it "every list can be shuffled, ultimately" $+            check prop_shuffleCanShuffle+        it "shuffle is non-deterministic" $+            check prop_shuffleNotDeterministic+        it "sort (shuffle xs) == sort xs" $+            check prop_shufflePreserveElements++    describe "shuffleNonEmpty" $ do+        it "every non-empty list can be shuffled, ultimately" $+            check prop_shuffleNonEmptyCanShuffle+        it "shuffleNonEmpty is non-deterministic" $+            check prop_shuffleNonEmptyNotDeterministic+        it "sort (shuffleNonEmpty xs) == sort xs" $+            check prop_shuffleNonEmptyPreserveElements++    describe "shuffleWith / mkSeed" $ do+        it "shuffling with the same seed is deterministic" $+            check prop_shuffleWithDeterministic+        it "different seed means different shuffles" $+            check prop_shuffleDifferentSeed++  where+    check :: forall p. Testable p => p -> Property+    check = checkCoverageWith lowerConfidence++    lowerConfidence :: Confidence+    lowerConfidence = Confidence (10^(6 :: Integer)) 0.75++--------------------------------------------------------------------------------+-- Properties+--------------------------------------------------------------------------------++prop_shuffleCanShuffle+    :: NonEmptyList Int+    -> Property+prop_shuffleCanShuffle (NonEmpty xs) = monadicIO $ run $ do+    xs' <- shuffle xs+    return $ cover 90 (xs /= xs') "shuffled" ()++prop_shuffleNonEmptyCanShuffle+    :: NonEmpty Int+    -> Property+prop_shuffleNonEmptyCanShuffle xs = monadicIO $ run $ do+    xs' <- shuffleNonEmpty xs+    return $ cover 90 (xs /= xs') "shuffled" ()++prop_shuffleNotDeterministic+    :: NonEmptyList Int+    -> Property+prop_shuffleNotDeterministic (NonEmpty xs) = monadicIO $ run $ do+    xs1 <- shuffle xs+    xs2 <- shuffle xs+    return $ cover 90 (xs1 /= xs2) "not deterministic" ()++prop_shuffleNonEmptyNotDeterministic+    :: NonEmpty Int+    -> Property+prop_shuffleNonEmptyNotDeterministic xs = monadicIO $ run $ do+    xs1 <- shuffleNonEmpty xs+    xs2 <- shuffleNonEmpty xs+    return $ cover 90 (xs1 /= xs2) "not deterministic" ()++prop_shufflePreserveElements+    :: [Int]+    -> Property+prop_shufflePreserveElements xs = monadicIO $ run $ do+    xs' <- shuffle xs+    return $ cover 90 (not $ null xs) "non-empty" (L.sort xs == L.sort xs')++prop_shuffleNonEmptyPreserveElements+    :: NonEmpty Int+    -> Property+prop_shuffleNonEmptyPreserveElements xs = monadicIO $ run $ do+    xs' <- shuffleNonEmpty xs+    return $ cover 90 (not $ null xs) "non-empty" (NE.sort xs == NE.sort xs')++-- ∀(g :: RandomGen).+-- ∀(es :: [a]).+--+-- shuffleWith g es == shuffleWith g es+prop_shuffleWithDeterministic+    :: PrintableString+    -> NonEmptyList Int+    -> Property+prop_shuffleWithDeterministic (PrintableString seed) (NonEmpty xs) =+    monadicIO $ do+        ys0 <- run $ shuffleWith (mkSeed $ T.pack seed) xs+        ys1 <- run $ shuffleWith (mkSeed $ T.pack seed) xs+        monitor $ cover 90 (length xs > 1) "non singleton"+        assert (ys0 == ys1)++-- ∀(x0 : Text, x1 : Text). g0 = mkSeed x0, g1 = mkSeed x1+-- ∃(Δ: Int).+-- ∀(es :: [a]).+--+-- g0 ≠g1, length es > Δ⇒ shuffleWith g0 es ≠shuffleWith g1 es+prop_shuffleDifferentSeed+    :: (PrintableString, PrintableString)+    -> Positive Int+    -> Property+prop_shuffleDifferentSeed (x0, x1) (Positive len) = do+    x0 /= x1 ==> monadicIO $ do+        let g0 = mkSeed $ T.pack $ getPrintableString x0+        let g1 = mkSeed $ T.pack $ getPrintableString x1+        es <- pick $ vectorOf len (arbitrary @Int)+        ys0 <- run $ shuffleWith g0 es+        ys1 <- run $ shuffleWith g1 es+        monitor $ label (prettyLen es)+        monitor $ cover 90 (ys0 /= ys1) "different"+  where+    prettyLen :: [a] -> String+    prettyLen xs = case length xs of+        n | n <= 1 -> "singleton"+        n | n <= 10 -> "small list"+        _ -> "big list"++instance Arbitrary a => Arbitrary (NonEmpty a) where+    arbitrary = (:|) <$> arbitrary <*> arbitrary+    shrink = genericShrink