Merge pull request #523 from input-output-hk/KtorZ/522/coin-selection…

…-options

Fix coin selection max number of inputs not diminishing as expected

lib/core/src/Cardano/Wallet/Primitive/CoinSelection/Random.hs

@@ -112,30 +112,27 @@ random
     -> ExceptT ErrCoinSelection m (CoinSelection, UTxO)
 random opt outs utxo = do
     let descending = NE.toList . NE.sortBy (flip $ comparing coin)
-    randomMaybe <- lift $ runMaybeT $ foldM
-        (makeSelection opt)
-        (utxo, [])
-        (descending outs)
+    randomMaybe <- lift $ runMaybeT $
+        foldM makeSelection (opt, utxo, []) (descending outs)
     case randomMaybe of
-        Just (utxo', res) -> do
-            lift $ foldM
-                (improveTxOut opt)
-                (mempty, utxo')
-                (reverse res)
+        Just (opt', utxo', res) -> do
+            (_, sel, remUtxo) <- lift $
+                foldM improveTxOut (opt', mempty, utxo') (reverse res)
+            return (sel, remUtxo)
         Nothing ->
             largestFirst opt outs utxo
 
 -- | Perform a random selection on a given output, without improvement.
 makeSelection
     :: forall m. MonadRandom m
-    => CoinSelectionOptions
-    -> (UTxO, [([(TxIn, TxOut)], TxOut)])
+    => (CoinSelectionOptions, UTxO, [([(TxIn, TxOut)], TxOut)])
     -> TxOut
-    -> MaybeT m (UTxO, [([(TxIn, TxOut)], TxOut)])
-makeSelection (CoinSelectionOptions maxNumInputs) (utxo0, selection) txout = do
+    -> MaybeT m (CoinSelectionOptions, UTxO, [([(TxIn, TxOut)], TxOut)])
+makeSelection (CoinSelectionOptions maxNumInputs, utxo0, selection) txout = do
     (inps, utxo1) <- coverRandomly ([], utxo0)
     return
-        ( utxo1
+        ( CoinSelectionOptions (maxNumInputs - fromIntegral (L.length inps))
+        , utxo1
         , (inps, txout) : selection
         )
   where
@@ -151,18 +148,17 @@ makeSelection (CoinSelectionOptions maxNumInputs) (utxo0, selection) txout = do
         | otherwise = do
             pickRandomT utxo >>= \(io, utxo') -> coverRandomly (io:inps, utxo')
 
-
 -- | Perform an improvement to random selection on a given output.
 improveTxOut
     :: forall m. MonadRandom m
-    => CoinSelectionOptions
-    -> (CoinSelection, UTxO)
+    => (CoinSelectionOptions, CoinSelection, UTxO)
     -> ([(TxIn, TxOut)], TxOut)
-    -> m (CoinSelection, UTxO)
-improveTxOut (CoinSelectionOptions maxNumInputs) (selection, utxo0) (inps0, txout) = do
-    (inps, utxo) <- improve (inps0, utxo0)
+    -> m (CoinSelectionOptions, CoinSelection, UTxO)
+improveTxOut (opt0, selection, utxo0) (inps0, txout) = do
+    (opt, inps, utxo) <- improve (opt0, inps0, utxo0)
     return
-        ( selection <> CoinSelection
+        ( opt
+        , selection <> CoinSelection
             { inputs = inps
             , outputs = [txout]
             , change = mkChange txout inps
@@ -174,19 +170,21 @@ improveTxOut (CoinSelectionOptions maxNumInputs) (selection, utxo0) (inps0, txou
 
     improve
         :: forall m. MonadRandom m
-        => ([(TxIn, TxOut)], UTxO)
-        -> m ([(TxIn, TxOut)], UTxO)
-    improve (inps, utxo) =
-        runMaybeT (pickRandomT utxo) >>= \case
-        Nothing ->
-            return (inps, utxo)
-        Just (io, utxo') | isImprovement io inps -> do
-            let inps' = io : inps
-            if balance' inps' >= targetAim target
-                then return (inps', utxo')
-                else improve (inps', utxo')
-        Just _ ->
-            return (inps, utxo)
+        => (CoinSelectionOptions, [(TxIn, TxOut)], UTxO)
+        -> m (CoinSelectionOptions, [(TxIn, TxOut)], UTxO)
+    improve (opt@(CoinSelectionOptions maxN), inps, utxo)
+        | maxN >= 1 && balance' inps < targetAim target = do
+            runMaybeT (pickRandomT utxo) >>= \case
+                Nothing ->
+                    return (opt, inps, utxo)
+                Just (io, utxo') | isImprovement io inps -> do
+                    let inps' = io : inps
+                    let opt' = CoinSelectionOptions (maxN - 1)
+                    improve (opt', inps', utxo')
+                Just _ ->
+                    return (opt, inps, utxo)
+        | otherwise =
+            return (opt, inps, utxo)
 
     isImprovement :: (TxIn, TxOut) -> [(TxIn, TxOut)] -> Bool
     isImprovement io selected =
@@ -199,11 +197,10 @@ improveTxOut (CoinSelectionOptions maxNumInputs) (selection, utxo0) (inps0, txou
                 <
                 distance (targetAim target) (balance' selected)
 
-            condC = -- (c) Doesn't exceed maximum number of inputs
-                length (io : selected) <= fromIntegral maxNumInputs
+            -- (c) Doesn't exceed maximum number of inputs
+            -- Guaranteed by the precondition on 'improve'.
         in
-            condA && condB && condC
-
+            condA && condB
 
 {-------------------------------------------------------------------------------
                                  Internals

lib/core/test/unit/Cardano/Wallet/Primitive/CoinSelection/LargestFirstSpec.hs

@@ -153,6 +153,22 @@ spec = do
                 , txOutputs = 41 :| [6]
                 }
 
+        coinSelectionUnitTest largestFirst "each output needs <maxNumOfInputs"
+            (Left $ ErrMaximumInputsReached 9)
+            (CoinSelectionFixture
+                { maxNumOfInputs = 9
+                , utxoInputs = replicate 100 1
+                , txOutputs = NE.fromList (replicate 100 1)
+                })
+
+        coinSelectionUnitTest largestFirst "each output needs >maxNumInputs"
+            (Left $ ErrMaximumInputsReached 9)
+            (CoinSelectionFixture
+                { maxNumOfInputs = 9
+                , utxoInputs = replicate 100 1
+                , txOutputs = NE.fromList (replicate 10 10)
+                })
+
         coinSelectionUnitTest
             largestFirst
             "enough coins but, strict maximumNumberOfInputs"

lib/core/test/unit/Cardano/Wallet/Primitive/CoinSelection/RandomSpec.hs

@@ -38,12 +38,11 @@ import Test.QuickCheck
     ( Property, property, (===), (==>) )
 
 import qualified Data.List as L
-
+import qualified Data.List.NonEmpty as NE
 
 spec :: Spec
 spec = do
     describe "Coin selection : random algorithm unit tests" $ do
-
         let oneAda = 1000000
 
         coinSelectionUnitTest random ""
@@ -151,12 +150,29 @@ spec = do
                 , txOutputs = 38 :| [1]
                 })
 
-        coinSelectionUnitTest random "" (Left $ ErrMaximumInputsReached 2) $
-            CoinSelectionFixture
-            { maxNumOfInputs = 2
-            , utxoInputs = [1,1,1,1,1,1]
-            , txOutputs = 3 :| []
-            }
+        coinSelectionUnitTest random ""
+            (Left $ ErrMaximumInputsReached 2)
+            (CoinSelectionFixture
+                { maxNumOfInputs = 2
+                , utxoInputs = [1,1,1,1,1,1]
+                , txOutputs = 3 :| []
+                })
+
+        coinSelectionUnitTest random "each output needs <maxNumOfInputs"
+            (Left $ ErrMaximumInputsReached 9)
+            (CoinSelectionFixture
+                { maxNumOfInputs = 9
+                , utxoInputs = replicate 100 1
+                , txOutputs = NE.fromList (replicate 100 1)
+                })
+
+        coinSelectionUnitTest random "each output needs >maxNumInputs"
+            (Left $ ErrMaximumInputsReached 9)
+            (CoinSelectionFixture
+                { maxNumOfInputs = 9
+                , utxoInputs = replicate 100 1
+                , txOutputs = NE.fromList (replicate 10 10)
+                })
 
         coinSelectionUnitTest random "" (Left $ ErrNotEnoughMoney 39 40) $
             CoinSelectionFixture