take withdrawals into account, one level earlier, during the coin sel…

…ection

Still to be done:

- Make sure it's correctly done in the largest-first algorithm
- Add some test scenario that show the influence of the withdrawal

lib/core/src/Cardano/Wallet.hs

@@ -1178,15 +1178,15 @@ selectCoinsForPaymentFromUTxO
     -> NonEmpty TxOut
     -> Quantity "lovelace" Word64
     -> ExceptT (ErrSelectForPayment e) IO CoinSelection
-selectCoinsForPaymentFromUTxO ctx utxo txp recipients (Quantity withdrawal) = do
+selectCoinsForPaymentFromUTxO ctx utxo txp recipients withdrawal = do
     lift . traceWith tr $ MsgPaymentCoinSelectionStart utxo txp recipients
     (sel, utxo') <- withExceptT ErrSelectForPaymentCoinSelection $ do
         let opts = coinSelOpts tl (txp ^. #getTxMaxSize)
-        CoinSelection.random opts recipients utxo
+        CoinSelection.random opts recipients withdrawal utxo
     lift . traceWith tr $ MsgPaymentCoinSelection sel
     let feePolicy = feeOpts tl Nothing (txp ^. #getFeePolicy)
     withExceptT ErrSelectForPaymentFee $ do
-        balancedSel <- adjustForFee feePolicy utxo' (sel { withdrawal })
+        balancedSel <- adjustForFee feePolicy utxo' sel
         lift . traceWith tr $ MsgPaymentCoinSelectionAdjusted balancedSel
         pure balancedSel
   where

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

@@ -1,3 +1,4 @@
+{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE RankNTypes #-}
 
 
@@ -31,6 +32,10 @@ import Data.List.NonEmpty
     ( NonEmpty (..) )
 import Data.Ord
     ( Down (..) )
+import Data.Quantity
+    ( Quantity (..) )
+import Data.Word
+    ( Word64 )
 
 import qualified Data.List as L
 import qualified Data.List.NonEmpty as NE
@@ -42,9 +47,10 @@ largestFirst
     :: forall m e. Monad m
     => CoinSelectionOptions e
     -> NonEmpty TxOut
+    -> Quantity "lovelace" Word64
     -> UTxO
     -> ExceptT (ErrCoinSelection e) m (CoinSelection, UTxO)
-largestFirst opt outs utxo = do
+largestFirst opt outs _withdrawals utxo = do
     let descending = L.sortOn (Down . coin) . NE.toList
     let nOuts = fromIntegral $ NE.length outs
     let maxN = fromIntegral $ maximumNumberOfInputs opt (fromIntegral nOuts)

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

@@ -1,3 +1,4 @@
+{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE TupleSections #-}
@@ -48,6 +49,10 @@ import Data.List.NonEmpty
     ( NonEmpty (..) )
 import Data.Ord
     ( comparing )
+import Data.Quantity
+    ( Quantity (..) )
+import Data.Ratio
+    ( Ratio, denominator, numerator, (%) )
 import Data.Word
     ( Word64 )
 
@@ -112,46 +117,64 @@ random
     :: forall m e. MonadRandom m
     => CoinSelectionOptions e
     -> NonEmpty TxOut
+    -> Quantity "lovelace" Word64
     -> UTxO
     -> ExceptT (ErrCoinSelection e) m (CoinSelection, UTxO)
-random opt outs utxo = do
+random opt outs (Quantity totalWithdraw) utxo = do
     let descending = NE.toList . NE.sortBy (flip $ comparing coin)
     let nOuts = fromIntegral $ NE.length outs
     let maxN = fromIntegral $ maximumNumberOfInputs opt nOuts
+    let totalOut = sum (getCoin . coin <$> outs)
     randomMaybe <- lift $ runMaybeT $
-        foldM makeSelection (maxN, utxo, []) (descending outs)
+        foldM
+            (\acc out ->
+                let
+                    withdraw = totalWithdraw
+                        `proportionallyTo` (getCoin (coin out) % totalOut)
+                in
+                    makeSelection (Quantity withdraw) acc out
+            )
+            (maxN, utxo, [])
+            (descending outs)
     case randomMaybe of
         Just (maxN', utxo', res) -> do
             (_, sel, remUtxo) <- lift $
                 foldM improveTxOut (maxN', mempty, utxo') (reverse res)
-            guard sel $> (sel, remUtxo)
+            -- NOTE re-assigning total withdrawal to cope with potential
+            -- rounding issues.
+            guard sel $> (sel { withdrawal = totalWithdraw }, remUtxo)
         Nothing ->
-            largestFirst opt outs utxo
+            largestFirst opt outs (Quantity totalWithdraw) utxo
   where
     guard = except . left ErrInvalidSelection . validate opt
 
 -- | Perform a random selection on a given output, without improvement.
 makeSelection
     :: forall m. MonadRandom m
-    => (Word64, UTxO, [([(TxIn, TxOut)], TxOut)])
+    => Quantity "lovelace" Word64
+    -> (Word64, UTxO, [(Quantity "lovelace" Word64, [(TxIn, TxOut)], TxOut)])
     -> TxOut
-    -> MaybeT m (Word64, UTxO, [([(TxIn, TxOut)], TxOut)])
-makeSelection (maxNumInputs, utxo0, selection) txout = do
+    -> MaybeT m
+        ( Word64 -- Number of remaining inputs that can be selected
+        , UTxO -- New UTxO
+        , [(Quantity "lovelace" Word64, [(TxIn, TxOut)], TxOut)] -- Ongoing selection
+        )
+makeSelection withdraw (maxNumInputs, utxo0, selection) txout = do
     (inps, utxo1) <- coverRandomly ([], utxo0)
     return
         ( maxNumInputs - fromIntegral (L.length inps)
         , utxo1
-        , (inps, txout) : selection
+        , (withdraw, inps, txout) : selection
         )
   where
     coverRandomly
         :: forall m. MonadRandom m
         => ([(TxIn, TxOut)], UTxO)
         -> MaybeT m ([(TxIn, TxOut)], UTxO)
     coverRandomly (inps, utxo)
-        | L.length inps > (fromIntegral maxNumInputs) =
+        | L.length inps > fromIntegral maxNumInputs =
             MaybeT $ return Nothing
-        | balance' inps >= targetMin (mkTargetRange txout) =
+        | totalBalance withdraw inps >= targetMin (mkTargetRange txout) =
             MaybeT $ return $ Just (inps, utxo)
         | otherwise = do
             pickRandomT utxo >>= \(io, utxo') -> coverRandomly (io:inps, utxo')
@@ -160,16 +183,17 @@ makeSelection (maxNumInputs, utxo0, selection) txout = do
 improveTxOut
     :: forall m. MonadRandom m
     => (Word64, CoinSelection, UTxO)
-    -> ([(TxIn, TxOut)], TxOut)
+    -> (Quantity "lovelace" Word64, [(TxIn, TxOut)], TxOut)
     -> m (Word64, CoinSelection, UTxO)
-improveTxOut (maxN0, selection, utxo0) (inps0, txout) = do
+improveTxOut (maxN0, selection, utxo0) (withdraw, inps0, txout) = do
     (maxN, inps, utxo) <- improve (maxN0, inps0, utxo0)
     return
         ( maxN
         , selection <> mempty
             { inputs = inps
             , outputs = [txout]
             , change = mkChange txout inps
+            , withdrawal = getQuantity withdraw
             }
         , utxo
         )
@@ -181,7 +205,7 @@ improveTxOut (maxN0, selection, utxo0) (inps0, txout) = do
         => (Word64, [(TxIn, TxOut)], UTxO)
         -> m (Word64, [(TxIn, TxOut)], UTxO)
     improve (maxN, inps, utxo)
-        | maxN >= 1 && balance' inps < targetAim target = do
+        | maxN >= 1 && totalBalance withdraw inps < targetAim target = do
             runMaybeT (pickRandomT utxo) >>= \case
                 Nothing ->
                     return (maxN, inps, utxo)
@@ -198,12 +222,12 @@ improveTxOut (maxN0, selection, utxo0) (inps0, txout) = do
     isImprovement io selected =
         let
             condA = -- (a) It doesn’t exceed a specified upper limit.
-                balance' (io : selected) < targetMax target
+                totalBalance withdraw (io : selected) < targetMax target
 
             condB = -- (b) Addition gets us closer to the ideal change
-                distance (targetAim target) (balance' (io : selected))
+                distance (targetAim target) (totalBalance withdraw (io : selected))
                 <
-                distance (targetAim target) (balance' selected)
+                distance (targetAim target) (totalBalance withdraw selected)
 
             -- (c) Doesn't exceed maximum number of inputs
             -- Guaranteed by the precondition on 'improve'.
@@ -214,6 +238,13 @@ improveTxOut (maxN0, selection, utxo0) (inps0, txout) = do
                                  Internals
 -------------------------------------------------------------------------------}
 
+-- | Total UTxO balance + withdrawal. The withdrawal only counts towards the
+-- balance if there's at least one input.
+totalBalance :: Quantity "lovelace" Word64 -> [(TxIn, TxOut)] -> Word64
+totalBalance (Quantity withdraw) inps
+    | null inps = 0
+    | otherwise = balance' inps + withdraw
+
 -- | Re-wrap 'pickRandom' in a 'MaybeT' monad
 pickRandomT :: MonadRandom m => UTxO -> MaybeT m ((TxIn, TxOut), UTxO)
 pickRandomT =
@@ -247,3 +278,18 @@ mkChange (TxOut _ (Coin out)) inps =
                 []
             c ->
                 [ Coin c ]
+
+-- | Compute the fraction of the first input to match the given ratio, rounded
+-- down.
+--
+-- >>> 10 `proportionallyTo` 1%1
+-- 10
+--
+-- >>> 10 `proportionallyTo` 1%2
+-- 5
+--
+-- >>> 10 `proportionallyTo` 1%3
+-- 3
+proportionallyTo :: Integral a => a -> Ratio a -> a
+proportionallyTo n r = fromIntegral $
+    toInteger n * toInteger (numerator r) `div` toInteger (denominator r)

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

@@ -33,6 +33,8 @@ import Data.Functor.Identity
     ( Identity (runIdentity) )
 import Data.List.NonEmpty
     ( NonEmpty (..) )
+import Data.Quantity
+    ( Quantity (..) )
 import Test.Hspec
     ( Spec, describe, it, shouldSatisfy )
 import Test.QuickCheck
@@ -57,6 +59,7 @@ spec = do
                 , validateSelection = noValidation
                 , utxoInputs = [10,10,17]
                 , txOutputs = 17 :| []
+                , totalWithdrawal = 0
                 })
 
         coinSelectionUnitTest largestFirst ""
@@ -70,6 +73,7 @@ spec = do
                 , validateSelection = noValidation
                 , utxoInputs = [12,10,17]
                 , txOutputs = 1 :| []
+                , totalWithdrawal = 0
                 })
 
         coinSelectionUnitTest largestFirst ""
@@ -83,6 +87,7 @@ spec = do
                 , validateSelection = noValidation
                 , utxoInputs = [12,10,17]
                 , txOutputs = 18 :| []
+                , totalWithdrawal = 0
                 })
 
         coinSelectionUnitTest largestFirst ""
@@ -96,6 +101,7 @@ spec = do
                 , validateSelection = noValidation
                 , utxoInputs = [12,10,17]
                 , txOutputs = 30 :| []
+                , totalWithdrawal = 0
                 })
 
         coinSelectionUnitTest largestFirst ""
@@ -109,6 +115,7 @@ spec = do
                 , validateSelection = noValidation
                 , utxoInputs = [1,2,10,6,5]
                 , txOutputs = 11 :| [1]
+                , totalWithdrawal = 0
                 })
 
         coinSelectionUnitTest largestFirst "not enough coins"
@@ -118,6 +125,7 @@ spec = do
                 , validateSelection = noValidation
                 , utxoInputs = [12,10,17]
                 , txOutputs = 40 :| []
+                , totalWithdrawal = 0
                 })
 
         coinSelectionUnitTest largestFirst "not enough coin & not fragmented enough"
@@ -127,6 +135,7 @@ spec = do
                 , validateSelection = noValidation
                 , utxoInputs = [12,10,17]
                 , txOutputs = 40 :| [1,1,1]
+                , totalWithdrawal = 0
                 })
 
         coinSelectionUnitTest largestFirst "enough coins, but not fragmented enough"
@@ -136,6 +145,7 @@ spec = do
                 , validateSelection = noValidation
                 , utxoInputs = [12,20,17]
                 , txOutputs = 40 :| [1,1,1]
+                , totalWithdrawal = 0
                 })
 
         coinSelectionUnitTest largestFirst
@@ -146,6 +156,7 @@ spec = do
                 , validateSelection = noValidation
                 , utxoInputs = [12,20,17]
                 , txOutputs = 40 :| [1]
+                , totalWithdrawal = 0
                 })
 
         coinSelectionUnitTest
@@ -157,6 +168,7 @@ spec = do
                 , validateSelection = noValidation
                 , utxoInputs = [20,20,10,5]
                 , txOutputs = 41 :| [6]
+                , totalWithdrawal = 0
                 })
 
         coinSelectionUnitTest largestFirst "each output needs <maxNumOfInputs"
@@ -166,6 +178,7 @@ spec = do
                 , validateSelection = noValidation
                 , utxoInputs = replicate 100 1
                 , txOutputs = NE.fromList (replicate 100 1)
+                , totalWithdrawal = 0
                 })
 
         coinSelectionUnitTest largestFirst "each output needs >maxNumInputs"
@@ -175,6 +188,7 @@ spec = do
                 , validateSelection = noValidation
                 , utxoInputs = replicate 100 1
                 , txOutputs = NE.fromList (replicate 10 10)
+                , totalWithdrawal = 0
                 })
 
         coinSelectionUnitTest largestFirst
@@ -185,6 +199,7 @@ spec = do
                 , validateSelection = noValidation
                 , utxoInputs = [1,2,10,6,5]
                 , txOutputs = 11 :| [1]
+                , totalWithdrawal = 0
                 })
 
         coinSelectionUnitTest largestFirst "custom validation"
@@ -194,6 +209,7 @@ spec = do
                 , validateSelection = alwaysFail
                 , utxoInputs = [1,1]
                 , txOutputs = 2 :| []
+                , totalWithdrawal = 0
                 })
 
     describe "Coin selection properties : LargestFirst algorithm" $ do
@@ -216,8 +232,9 @@ propDeterministic
     -> Property
 propDeterministic (CoinSelProp utxo txOuts) = do
     let opts = CoinSelectionOptions (const 100) noValidation
-    let resultOne = runIdentity $ runExceptT $ largestFirst opts txOuts utxo
-    let resultTwo = runIdentity $ runExceptT $ largestFirst opts txOuts utxo
+    let withdraw = Quantity 0
+    let resultOne = runIdentity $ runExceptT $ largestFirst opts txOuts withdraw utxo
+    let resultTwo = runIdentity $ runExceptT $ largestFirst opts txOuts withdraw utxo
     resultOne === resultTwo
 
 propAtLeast
@@ -228,8 +245,9 @@ propAtLeast (CoinSelProp utxo txOuts) =
   where
     prop cs =
         L.length (inputs cs) `shouldSatisfy` (>= NE.length txOuts)
-    selection = runIdentity $ runExceptT $
-        largestFirst (CoinSelectionOptions (const 100) noValidation) txOuts utxo
+    selection = runIdentity $ runExceptT $ do
+        let opts = CoinSelectionOptions (const 100) noValidation
+        largestFirst opts txOuts (Quantity 0) utxo
 
 propInputDecreasingOrder
     :: CoinSelProp
@@ -246,5 +264,6 @@ propInputDecreasingOrder (CoinSelProp utxo txOuts) =
             `shouldSatisfy`
             (>= (getExtremumValue L.maximum utxo'))
     getExtremumValue f = f . map (getCoin . coin . snd)
-    selection = runIdentity $ runExceptT $
-        largestFirst (CoinSelectionOptions (const 100) noValidation) txOuts utxo
+    selection = runIdentity $ runExceptT $ do
+        let opts = CoinSelectionOptions (const 100) noValidation
+        largestFirst opts txOuts (Quantity 0) utxo