Add function to minimize the fee excess for a particular output.

lib/core/src/Cardano/Wallet/Primitive/Migration/Selection.hs

@@ -75,6 +75,9 @@ module Cardano.Wallet.Primitive.Migration.Selection
     , ReclaimAdaResult (..)
     , reclaimAda
 
+    -- * Minimizing fee excess
+    , minimizeFeeExcess
+
     ) where
 
 import Prelude
@@ -608,6 +611,7 @@ initialize params rewardWithdrawal inputs = do
                 pure (Coin.distance cf mf)
             _ ->
                 Left SelectionAdaInsufficient
+    -- TODO: call minimizeFee here
     pure reducedSelection {size, feeExcess}
 
 --------------------------------------------------------------------------------
@@ -627,6 +631,30 @@ finalize selection = selection
         (outputs selection)
     }
 
+-- TODO: Call this from reclaimAda
+--minimizeFee :: SelectionParameters s -> Selection i s -> Selection i s
+--minimizeFee params selection = undefined
+
+-- Repeatedly increase the ada quantity of the output with the largest ada
+    -- quantity while the fee excess does not go below zero. We can actually
+    -- move on to the next output if we fail to go to zero with the first
+    -- output.
+
+    -- The post-condition of this function is that the feeExcess really cannot
+    -- be reduced further.
+    --
+    -- Try breaking it up into a function that minimizes for a single output.
+    -- Work through outputs from left to right.
+    --
+    -- For each output, we first try adding the whole excess, then half the
+    -- excess, then 1/4, then 1/8, and so on. Basically, perform binary search
+    -- to find the largest excess that can be added, before giving up.
+    --
+    -- The remainder (what could not be added) should be returned, so it can
+    -- be tried with the next output.
+    --
+    -- We have to be careful not to exceed the maximum size.
+
 --------------------------------------------------------------------------------
 -- Extending a selection
 --------------------------------------------------------------------------------
@@ -974,6 +1002,36 @@ reclaimAda params totalAdaToReclaim bundles =
         𝛿cost' = 𝛿cost <> costReductionForThisOutput
         𝛿size' = 𝛿size <> sizeReductionForThisOutput
 
+minimizeFeeExcess
+    :: SelectionParameters s
+    -> (Coin, TokenBundle)
+    -- ^ Fee excess and output bundle.
+    -> (Coin, TokenBundle)
+    -- ^ Fee excess and output bundle after minimization.
+minimizeFeeExcess params =
+    findFixedPoint reduceFeeExcess
+  where
+    reduceFeeExcess :: (Coin, TokenBundle) -> (Coin, TokenBundle)
+    reduceFeeExcess (feeExcess, outputBundle) =
+        (feeExcessFinal, TokenBundle.setCoin outputBundle outputCoinFinal)
+      where
+        outputCoin = view #coin outputBundle
+        outputCoinMaxCostIncrease = Coin.distance
+            (costOfOutputCoin params outputCoin)
+            (costOfOutputCoin params $ outputCoin <> feeExcess)
+        outputCoinFinal = Coin
+            $ unCoin outputCoin
+            + unCoin feeExcess
+            - unCoin outputCoinMaxCostIncrease
+        outputCoinFinalCostIncrease = Coin.distance
+            (costOfOutputCoin params outputCoin)
+            (costOfOutputCoin params outputCoinFinal)
+        outputCoinFinalIncrease = Coin.distance outputCoin outputCoinFinal
+        feeExcessFinal = Coin
+            $ unCoin feeExcess
+            - unCoin outputCoinFinalIncrease
+            - unCoin outputCoinFinalCostIncrease
+
 --------------------------------------------------------------------------------
 -- Miscellaneous types and functions
 --------------------------------------------------------------------------------
@@ -1025,6 +1083,11 @@ newtype NegativeCoin = NegativeCoin
     }
     deriving (Eq, Show)
 
+findFixedPoint :: Eq a => (a -> a) -> a -> a
+findFixedPoint f = findInner
+  where
+    findInner a = let fa = f a in if a == fa then a else findInner fa
+
 guardE :: Bool -> e -> Either e ()
 guardE condition e = if condition then Right () else Left e
 

lib/core/test/unit/Cardano/Wallet/Primitive/Migration/SelectionSpec.hs

@@ -26,6 +26,7 @@ import Cardano.Wallet.Primitive.Migration.Selection
     , ReclaimAdaResult (..)
     , excessAdaForOutput
     , reclaimAda
+    , minimizeFeeExcess
     , Size (..)
     , Selection (..)
     , SelectionError (..)
@@ -39,6 +40,7 @@ import Cardano.Wallet.Primitive.Migration.Selection
     , addBundleToExistingOutput
     , checkInvariant
     , coalesceOutputs
+    , costOfOutputCoin
     , initialize
     , outputSizeWithinLimit
     , outputOrdering
@@ -138,6 +140,11 @@ spec = describe "Cardano.Wallet.Primitive.Migration.SelectionSpec" $
         it "prop_reclaimAda" $
             property prop_reclaimAda
 
+    parallel $ describe "Minimizing fee excesses" $ do
+
+        it "prop_minimizeFeeExcess" $
+            property prop_minimizeFeeExcess
+
 --------------------------------------------------------------------------------
 -- Initializing a selection
 --------------------------------------------------------------------------------
@@ -506,6 +513,104 @@ prop_reclaimAda mockArgs =
 
     resultIsFailure = isNothing
 
+--------------------------------------------------------------------------------
+-- Minimizing fee excesses
+--------------------------------------------------------------------------------
+
+data MockMinimizeFeeExcessArguments = MockMinimizeFeeExcessArguments
+    { mockSelectionParameters :: MockSelectionParameters
+    , mockFeeExcessToMinimize :: Coin
+    , mockOutput :: TokenBundle
+    }
+    deriving (Eq, Show)
+
+genMockMinimizeFeeExcessArguments :: Gen MockMinimizeFeeExcessArguments
+genMockMinimizeFeeExcessArguments = do
+    mockSelectionParameters <- genMockSelectionParameters
+    mockOutput <- genTokenBundle mockSelectionParameters
+    mockFeeExcessToMinimize <- genCoin
+    pure MockMinimizeFeeExcessArguments
+        { mockSelectionParameters
+        , mockFeeExcessToMinimize
+        , mockOutput
+        }
+
+instance Arbitrary MockMinimizeFeeExcessArguments where
+    arbitrary = genMockMinimizeFeeExcessArguments
+
+conjoinMap :: [(String, Bool)] -> Property
+conjoinMap = conjoin . fmap (\(d, t) -> counterexample d t)
+
+prop_minimizeFeeExcess :: Blind MockMinimizeFeeExcessArguments -> Property
+prop_minimizeFeeExcess mockArgs =
+    counterexample counterexampleText $
+    conjoinMap
+        [ ("feeExcessAfter >  feeExcessBefore"
+          , feeExcessAfter <= feeExcessBefore)
+        , ("outputCoinAfter <  outputCoinBefore"
+          , outputCoinAfter >= outputCoinBefore)
+        , ("outputCoinCostAfter <  outputCoinCostBefore"
+          , outputCoinCostAfter >= outputCoinCostBefore)
+        , ("outputCoinIncrease <> outputCostIncrease <> feeExcessAfter /= feeExcessBefore"
+          , outputCoinIncrease <> outputCostIncrease <> feeExcessAfter == feeExcessBefore)
+        , ("feeExcessAfter > Coin 0 && costOfIncreasingFinalOutputCoinByOne < feeExcessAfter"
+          , if feeExcessAfter > Coin 0
+            then costOfIncreasingFinalOutputCoinByOne >= feeExcessAfter
+            else True)
+        ]
+  where
+    Blind MockMinimizeFeeExcessArguments
+        { mockSelectionParameters
+        , mockFeeExcessToMinimize
+        , mockOutput
+        } = mockArgs
+
+    params = unMockSelectionParameters mockSelectionParameters
+    (feeExcessAfter, outputBundleAfter) =
+        minimizeFeeExcess params (mockFeeExcessToMinimize, mockOutput)
+
+    feeExcessBefore =
+        mockFeeExcessToMinimize
+    outputCoinBefore =
+        view #coin mockOutput
+    outputCoinAfter =
+        view #coin outputBundleAfter
+    outputCoinIncrease =
+        Coin.distance outputCoinBefore outputCoinAfter
+    outputCoinCostBefore =
+        costOfOutputCoin params outputCoinBefore
+    outputCoinCostAfter =
+        costOfOutputCoin params outputCoinAfter
+    outputCostIncrease =
+        Coin.distance outputCoinCostBefore outputCoinCostAfter
+    outputMinimumAdaQuantity =
+        minimumAdaQuantityForOutput params (view #tokens mockOutput)
+    costOfIncreasingFinalOutputCoinByOne =
+        Coin.distance
+            (costOfOutputCoin params outputCoinAfter)
+            (costOfOutputCoin params (outputCoinAfter <> Coin 1))
+
+    counterexampleText = counterexampleMap
+        [ ( "feeExcessBefore"
+          , show feeExcessBefore )
+        , ( "feeExcessAfter"
+          , show feeExcessAfter )
+        , ( "outputMinimumAdaQuantity"
+          , show outputMinimumAdaQuantity )
+        , ( "outputCoinBefore"
+          , show outputCoinBefore )
+        , ( "outputCoinAfter"
+          , show outputCoinAfter )
+        , ( "outputCoinCostBefore"
+          , show outputCoinCostBefore )
+        , ( "outputCoinCostAfter"
+          , show outputCoinCostAfter )
+        , ( "outputCostIncrease"
+          , show outputCostIncrease )
+        , ( "costOfIncreasingFinalOutputCoinByOne"
+          , show costOfIncreasingFinalOutputCoinByOne )
+        ]
+
 --------------------------------------------------------------------------------
 -- Mock results
 --------------------------------------------------------------------------------