Make the Largest-First algorithm pay for outputs collectively.

src/library/Cardano/CoinSelection.hs

@@ -233,7 +233,7 @@ data CoinSelectionResult i o = CoinSelectionResult
         -- ^ The generated coin selection.
     , inputsRemaining :: CoinMap i
         -- ^ The set of inputs that were __not__ selected.
-    }
+    } deriving (Eq, Show)
 
 -- | A __coin selection__ is the basis for a /transaction/.
 --

src/library/Cardano/CoinSelection/Algorithm/LargestFirst.hs

@@ -1,4 +1,6 @@
+{-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
 
 -- |
@@ -15,137 +17,51 @@ module Cardano.CoinSelection.Algorithm.LargestFirst (
 import Prelude
 
 import Cardano.CoinSelection
-    ( CoinMapEntry (..)
+    ( CoinMap (..)
+    , 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.Function
+    ( (&) )
 import Data.Ord
     ( Down (..) )
-import Internal.Coin
-    ( Coin )
+import Data.Word
+    ( Word16 )
 
 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 coin selection algorithm considers available inputs in
+-- /descending/ order of value, from /largest/ to /smallest/.
 --
--- The __Largest-First__ algorithm processes outputs in /descending order of/
--- /value/, from /largest/ to /smallest/.
+-- When applied to a set of requested outputs, the algorithm repeatedly selects
+-- entries from the available inputs set until the total value of selected
+-- entries is greater than or equal to the total value of requested outputs.
 --
--- 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.
+-- === Change Values
 --
--- = State Maintained by the Algorithm
+-- If the total value of selected inputs is /greater than/ the total value of
+-- all requested outputs, the 'change' set of the resulting selection will
+-- contain /a single coin/ with the excess value.
 --
--- 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.
+-- If the total value of selected inputs is /exactly equal to/ the total value
+-- of all requested outputs, the 'change' set of the resulting selection will
+-- be /empty/.
 --
 -- === Failure Modes
 --
@@ -178,103 +94,67 @@ import qualified Internal.Coin as C
 --
 -- @since 1.0.0
 largestFirst
-    :: (Ord i, Ord o, Monad m)
+    :: (Ord i, Monad m)
     => CoinSelectionAlgorithm i o m
 largestFirst = CoinSelectionAlgorithm payForOutputs
 
 payForOutputs
-    :: (Ord i, Ord o, Monad m)
+    :: forall i o m . (Ord i, 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
+payForOutputs params
+    | amountAvailable < amountRequired =
+        throwE
+            $ InputValueInsufficient
+            $ InputValueInsufficientError amountAvailable amountRequired
+    | length inputsSelected > inputCountMax =
+        throwE
+            $ InputLimitExceeded
+            $ InputLimitExceededError
+            $ fromIntegral inputCountMax
+    | otherwise =
+        pure CoinSelectionResult {coinSelection, inputsRemaining}
   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 =
+    amountRequired =
         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
+    coinSelection = CoinSelection
+        { inputs =
+            inputsSelected
+        , outputs =
+            outputsRequested params
+        , change = filter (> C.zero)
+            $ F.toList
+            $ coinMapValue inputsSelected `C.sub` amountRequired
+        }
+    inputsAvailableDescending :: [CoinMapEntry i]
+    inputsAvailableDescending = inputsAvailable params
+        & coinMapToList
+        & L.sortOn (Down . entryValue)
+    inputCountMax :: Int
+    inputCountMax = outputsRequested params
+        & coinMapToList
+        & length
+        & fromIntegral @Int @Word16
+        & calculateLimit (limit params)
+        & fromIntegral @Word16 @Int
+    inputsSelected :: CoinMap i
+    inputsSelected = inputsAvailableDescending
+        & fmap entryValue
+        & scanl1 (<>)
+        & takeUntil (>= amountRequired)
+        & zip inputsAvailableDescending
+        & fmap fst
+        & coinMapFromList
+    inputsRemaining :: CoinMap i
+    inputsRemaining = inputsAvailableDescending
+        & drop (length inputsSelected)
+        & coinMapFromList
 
--- | 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
+--------------------------------------------------------------------------------
+-- Utilities
+--------------------------------------------------------------------------------
 
-sumEntries :: [CoinMapEntry a] -> Coin
-sumEntries entries = mconcat $ entryValue <$> entries
+takeUntil :: (a -> Bool) -> [a] -> [a]
+takeUntil p = foldr (\x ys -> x : if p x then [] else ys) []