{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}

-- |
-- Copyright: © 2018-2024 Intersect MBO
-- 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 :: forall i o (m :: * -> *).
(Ord i, Ord o, MonadRandom m) =>
CoinSelectionAlgorithm i o m
randomImprove = (CoinSelectionParameters i o
 -> ExceptT CoinSelectionError m (CoinSelectionResult i o))
-> CoinSelectionAlgorithm i o m
forall i o (m :: * -> *).
(CoinSelectionParameters i o
 -> ExceptT CoinSelectionError m (CoinSelectionResult i o))
-> CoinSelectionAlgorithm i o m
CoinSelectionAlgorithm CoinSelectionParameters i o
-> ExceptT CoinSelectionError m (CoinSelectionResult i o)
forall i o (m :: * -> *).
(Ord i, Ord o, MonadRandom m) =>
CoinSelectionParameters i o
-> ExceptT CoinSelectionError m (CoinSelectionResult i o)
payForOutputs

payForOutputs
    :: (Ord i, Ord o, MonadRandom m)
    => CoinSelectionParameters i o
    -> ExceptT CoinSelectionError m (CoinSelectionResult i o)
payForOutputs :: forall i o (m :: * -> *).
(Ord i, Ord o, MonadRandom m) =>
CoinSelectionParameters i o
-> ExceptT CoinSelectionError m (CoinSelectionResult i o)
payForOutputs CoinSelectionParameters i o
params = do
    Maybe (Integer, CoinMap i, [([CoinMapEntry i], CoinMapEntry o)])
mRandomSelections <- m (Maybe
     (Integer, CoinMap i, [([CoinMapEntry i], CoinMapEntry o)]))
-> ExceptT
     CoinSelectionError
     m
     (Maybe (Integer, CoinMap i, [([CoinMapEntry i], CoinMapEntry o)]))
forall (m :: * -> *) a.
Monad m =>
m a -> ExceptT CoinSelectionError m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Maybe
      (Integer, CoinMap i, [([CoinMapEntry i], CoinMapEntry o)]))
 -> ExceptT
      CoinSelectionError
      m
      (Maybe (Integer, CoinMap i, [([CoinMapEntry i], CoinMapEntry o)])))
-> m (Maybe
        (Integer, CoinMap i, [([CoinMapEntry i], CoinMapEntry o)]))
-> ExceptT
     CoinSelectionError
     m
     (Maybe (Integer, CoinMap i, [([CoinMapEntry i], CoinMapEntry o)]))
forall a b. (a -> b) -> a -> b
$ MaybeT m (Integer, CoinMap i, [([CoinMapEntry i], CoinMapEntry o)])
-> m (Maybe
        (Integer, CoinMap i, [([CoinMapEntry i], CoinMapEntry o)]))
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT
   m (Integer, CoinMap i, [([CoinMapEntry i], CoinMapEntry o)])
 -> m (Maybe
         (Integer, CoinMap i, [([CoinMapEntry i], CoinMapEntry o)])))
-> MaybeT
     m (Integer, CoinMap i, [([CoinMapEntry i], CoinMapEntry o)])
-> m (Maybe
        (Integer, CoinMap i, [([CoinMapEntry i], CoinMapEntry o)]))
forall a b. (a -> b) -> a -> b
$ ((Integer, CoinMap i, [([CoinMapEntry i], CoinMapEntry o)])
 -> CoinMapEntry o
 -> MaybeT
      m (Integer, CoinMap i, [([CoinMapEntry i], CoinMapEntry o)]))
-> (Integer, CoinMap i, [([CoinMapEntry i], CoinMapEntry o)])
-> [CoinMapEntry o]
-> MaybeT
     m (Integer, CoinMap i, [([CoinMapEntry i], CoinMapEntry o)])
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (Integer, CoinMap i, [([CoinMapEntry i], CoinMapEntry o)])
-> CoinMapEntry o
-> MaybeT
     m (Integer, CoinMap i, [([CoinMapEntry i], CoinMapEntry o)])
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
        (Integer
inputCountMax, CoinSelectionParameters i o -> CoinMap i
forall i o. CoinSelectionParameters i o -> CoinMap i
inputsAvailable CoinSelectionParameters i o
params, []) [CoinMapEntry o]
outputsDescending
    case Maybe (Integer, CoinMap i, [([CoinMapEntry i], CoinMapEntry o)])
mRandomSelections of
        Just (Integer
inputCountRemaining, CoinMap i
utxoRemaining, [([CoinMapEntry i], CoinMapEntry o)]
randomSelections) -> do
            (Integer
_, CoinSelection i o
finalSelection, CoinMap i
utxoRemaining') <- m (Integer, CoinSelection i o, CoinMap i)
-> ExceptT
     CoinSelectionError m (Integer, CoinSelection i o, CoinMap i)
forall (m :: * -> *) a.
Monad m =>
m a -> ExceptT CoinSelectionError m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Integer, CoinSelection i o, CoinMap i)
 -> ExceptT
      CoinSelectionError m (Integer, CoinSelection i o, CoinMap i))
-> m (Integer, CoinSelection i o, CoinMap i)
-> ExceptT
     CoinSelectionError m (Integer, CoinSelection i o, CoinMap i)
forall a b. (a -> b) -> a -> b
$ ((Integer, CoinSelection i o, CoinMap i)
 -> ([CoinMapEntry i], CoinMapEntry o)
 -> m (Integer, CoinSelection i o, CoinMap i))
-> (Integer, CoinSelection i o, CoinMap i)
-> [([CoinMapEntry i], CoinMapEntry o)]
-> m (Integer, CoinSelection i o, CoinMap i)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM
                (Integer, CoinSelection i o, CoinMap i)
-> ([CoinMapEntry i], CoinMapEntry o)
-> m (Integer, CoinSelection i o, CoinMap i)
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
                    (Integer
inputCountRemaining, CoinSelection i o
forall a. Monoid a => a
mempty, CoinMap i
utxoRemaining)
                    ([([CoinMapEntry i], CoinMapEntry o)]
-> [([CoinMapEntry i], CoinMapEntry o)]
forall a. [a] -> [a]
reverse [([CoinMapEntry i], CoinMapEntry o)]
randomSelections)
            CoinSelectionResult i o
-> ExceptT CoinSelectionError m (CoinSelectionResult i o)
forall a. a -> ExceptT CoinSelectionError m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CoinSelectionResult i o
 -> ExceptT CoinSelectionError m (CoinSelectionResult i o))
-> CoinSelectionResult i o
-> ExceptT CoinSelectionError m (CoinSelectionResult i o)
forall a b. (a -> b) -> a -> b
$ CoinSelection i o -> CoinMap i -> CoinSelectionResult i o
forall i o.
CoinSelection i o -> CoinMap i -> CoinSelectionResult i o
CoinSelectionResult CoinSelection i o
finalSelection CoinMap i
utxoRemaining'
        Maybe (Integer, CoinMap i, [([CoinMapEntry i], CoinMapEntry o)])
Nothing ->
            CoinSelectionError
-> ExceptT CoinSelectionError m (CoinSelectionResult i o)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE CoinSelectionError
errorCondition
  where
    errorCondition :: CoinSelectionError
errorCondition
      | Coin
amountAvailable Coin -> Coin -> Bool
forall a. Ord a => a -> a -> Bool
< Coin
amountRequested =
          InputValueInsufficientError -> CoinSelectionError
InputValueInsufficient (InputValueInsufficientError -> CoinSelectionError)
-> InputValueInsufficientError -> CoinSelectionError
forall a b. (a -> b) -> a -> b
$
              Coin -> Coin -> InputValueInsufficientError
InputValueInsufficientError
                  Coin
amountAvailable Coin
amountRequested
      | Natural
utxoCount Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
< Natural
outputCount =
          InputCountInsufficientError -> CoinSelectionError
InputCountInsufficient (InputCountInsufficientError -> CoinSelectionError)
-> InputCountInsufficientError -> CoinSelectionError
forall a b. (a -> b) -> a -> b
$
              Natural -> Natural -> InputCountInsufficientError
InputCountInsufficientError
                  Natural
utxoCount Natural
outputCount
      | Natural
utxoCount Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
inputCountMax =
          InputsExhaustedError -> CoinSelectionError
InputsExhausted
              InputsExhaustedError
InputsExhaustedError
      | Bool
otherwise =
          InputLimitExceededError -> CoinSelectionError
InputLimitExceeded (InputLimitExceededError -> CoinSelectionError)
-> InputLimitExceededError -> CoinSelectionError
forall a b. (a -> b) -> a -> b
$
              Word16 -> InputLimitExceededError
InputLimitExceededError (Word16 -> InputLimitExceededError)
-> Word16 -> InputLimitExceededError
forall a b. (a -> b) -> a -> b
$
                  Integer -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
inputCountMax
    amountAvailable :: Coin
amountAvailable =
        CoinMap i -> Coin
forall a. CoinMap a -> Coin
coinMapValue (CoinMap i -> Coin) -> CoinMap i -> Coin
forall a b. (a -> b) -> a -> b
$ CoinSelectionParameters i o -> CoinMap i
forall i o. CoinSelectionParameters i o -> CoinMap i
inputsAvailable CoinSelectionParameters i o
params
    amountRequested :: Coin
amountRequested =
        CoinMap o -> Coin
forall a. CoinMap a -> Coin
coinMapValue (CoinMap o -> Coin) -> CoinMap o -> Coin
forall a b. (a -> b) -> a -> b
$ CoinSelectionParameters i o -> CoinMap o
forall i o. CoinSelectionParameters i o -> CoinMap o
outputsRequested CoinSelectionParameters i o
params
    inputCountMax :: Integer
inputCountMax =
        Word16 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16 -> Integer) -> Word16 -> Integer
forall a b. (a -> b) -> a -> b
$ CoinSelectionLimit -> Word16 -> Word16
calculateLimit (CoinSelectionParameters i o -> CoinSelectionLimit
forall i o. CoinSelectionParameters i o -> CoinSelectionLimit
limit CoinSelectionParameters i o
params) (Word16 -> Word16) -> Word16 -> Word16
forall a b. (a -> b) -> a -> b
$ Natural -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
outputCount
    outputCount :: Natural
outputCount =
        Int -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Natural) -> Int -> Natural
forall a b. (a -> b) -> a -> b
$ [CoinMapEntry o] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([CoinMapEntry o] -> Int) -> [CoinMapEntry o] -> Int
forall a b. (a -> b) -> a -> b
$ CoinMap o -> [CoinMapEntry o]
forall a. CoinMap a -> [CoinMapEntry a]
coinMapToList (CoinMap o -> [CoinMapEntry o]) -> CoinMap o -> [CoinMapEntry o]
forall a b. (a -> b) -> a -> b
$ CoinSelectionParameters i o -> CoinMap o
forall i o. CoinSelectionParameters i o -> CoinMap o
outputsRequested CoinSelectionParameters i o
params
    outputsDescending :: [CoinMapEntry o]
outputsDescending =
        (CoinMapEntry o -> Down Coin)
-> [CoinMapEntry o] -> [CoinMapEntry o]
forall b a. Ord b => (a -> b) -> [a] -> [a]
L.sortOn (Coin -> Down Coin
forall a. a -> Down a
Down (Coin -> Down Coin)
-> (CoinMapEntry o -> Coin) -> CoinMapEntry o -> Down Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoinMapEntry o -> Coin
forall a. CoinMapEntry a -> Coin
entryValue) ([CoinMapEntry o] -> [CoinMapEntry o])
-> [CoinMapEntry o] -> [CoinMapEntry o]
forall a b. (a -> b) -> a -> b
$ CoinMap o -> [CoinMapEntry o]
forall a. CoinMap a -> [CoinMapEntry a]
coinMapToList (CoinMap o -> [CoinMapEntry o]) -> CoinMap o -> [CoinMapEntry o]
forall a b. (a -> b) -> a -> b
$ CoinSelectionParameters i o -> CoinMap o
forall i o. CoinSelectionParameters i o -> CoinMap o
outputsRequested CoinSelectionParameters i o
params
    utxoCount :: Natural
utxoCount =
        Int -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Natural) -> Int -> Natural
forall a b. (a -> b) -> a -> b
$ [CoinMapEntry i] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
L.length ([CoinMapEntry i] -> Int) -> [CoinMapEntry i] -> Int
forall a b. (a -> b) -> a -> b
$ CoinMap i -> [CoinMapEntry i]
forall a. CoinMap a -> [CoinMapEntry a]
coinMapToList (CoinMap i -> [CoinMapEntry i]) -> CoinMap i -> [CoinMapEntry i]
forall a b. (a -> b) -> a -> b
$ CoinSelectionParameters i o -> CoinMap i
forall i o. CoinSelectionParameters i o -> CoinMap i
inputsAvailable CoinSelectionParameters i o
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 :: 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
    (Integer
inputCountRemaining, CoinMap i
utxoRemaining, [([CoinMapEntry i], CoinMapEntry o)]
existingSelections) CoinMapEntry o
txout = do
        ([CoinMapEntry i]
utxoSelected, CoinMap i
utxoRemaining') <- ([CoinMapEntry i], CoinMap i)
-> MaybeT m ([CoinMapEntry i], CoinMap i)
coverRandomly ([], CoinMap i
utxoRemaining)
        (Integer, CoinMap i, [([CoinMapEntry i], CoinMapEntry o)])
-> MaybeT
     m (Integer, CoinMap i, [([CoinMapEntry i], CoinMapEntry o)])
forall a. a -> MaybeT m a
forall (m :: * -> *) a. Monad m => a -> m a
return
            ( Integer
inputCountRemaining Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([CoinMapEntry i] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
L.length [CoinMapEntry i]
utxoSelected)
            , CoinMap i
utxoRemaining'
            , ([CoinMapEntry i]
utxoSelected, CoinMapEntry o
txout) ([CoinMapEntry i], CoinMapEntry o)
-> [([CoinMapEntry i], CoinMapEntry o)]
-> [([CoinMapEntry i], CoinMapEntry o)]
forall a. a -> [a] -> [a]
: [([CoinMapEntry i], CoinMapEntry o)]
existingSelections
            )
  where
    coverRandomly
        :: ([CoinMapEntry i], CoinMap i)
        -> MaybeT m ([CoinMapEntry i], CoinMap i)
    coverRandomly :: ([CoinMapEntry i], CoinMap i)
-> MaybeT m ([CoinMapEntry i], CoinMap i)
coverRandomly ([CoinMapEntry i]
selected, CoinMap i
remaining)
        | [CoinMapEntry i] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
L.length [CoinMapEntry i]
selected Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
inputCountRemaining =
            m (Maybe ([CoinMapEntry i], CoinMap i))
-> MaybeT m ([CoinMapEntry i], CoinMap i)
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (m (Maybe ([CoinMapEntry i], CoinMap i))
 -> MaybeT m ([CoinMapEntry i], CoinMap i))
-> m (Maybe ([CoinMapEntry i], CoinMap i))
-> MaybeT m ([CoinMapEntry i], CoinMap i)
forall a b. (a -> b) -> a -> b
$ Maybe ([CoinMapEntry i], CoinMap i)
-> m (Maybe ([CoinMapEntry i], CoinMap i))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ([CoinMapEntry i], CoinMap i)
forall a. Maybe a
Nothing
        | [CoinMapEntry i] -> Coin
forall i. [CoinMapEntry i] -> Coin
sumEntries [CoinMapEntry i]
selected Coin -> Coin -> Bool
forall a. Ord a => a -> a -> Bool
>= TargetRange -> Coin
targetMin (CoinMapEntry o -> TargetRange
forall o. CoinMapEntry o -> TargetRange
mkTargetRange CoinMapEntry o
txout) =
            m (Maybe ([CoinMapEntry i], CoinMap i))
-> MaybeT m ([CoinMapEntry i], CoinMap i)
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (m (Maybe ([CoinMapEntry i], CoinMap i))
 -> MaybeT m ([CoinMapEntry i], CoinMap i))
-> m (Maybe ([CoinMapEntry i], CoinMap i))
-> MaybeT m ([CoinMapEntry i], CoinMap i)
forall a b. (a -> b) -> a -> b
$ Maybe ([CoinMapEntry i], CoinMap i)
-> m (Maybe ([CoinMapEntry i], CoinMap i))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ([CoinMapEntry i], CoinMap i)
 -> m (Maybe ([CoinMapEntry i], CoinMap i)))
-> Maybe ([CoinMapEntry i], CoinMap i)
-> m (Maybe ([CoinMapEntry i], CoinMap i))
forall a b. (a -> b) -> a -> b
$ ([CoinMapEntry i], CoinMap i)
-> Maybe ([CoinMapEntry i], CoinMap i)
forall a. a -> Maybe a
Just ([CoinMapEntry i]
selected, CoinMap i
remaining)
        | Bool
otherwise =
            m (Maybe (CoinMapEntry i, CoinMap i))
-> MaybeT m (CoinMapEntry i, CoinMap i)
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (CoinMap i -> m (Maybe (CoinMapEntry i, CoinMap i))
forall (m :: * -> *) a.
MonadRandom m =>
CoinMap a -> m (Maybe (CoinMapEntry a, CoinMap a))
coinMapRandomEntry CoinMap i
remaining) MaybeT m (CoinMapEntry i, CoinMap i)
-> ((CoinMapEntry i, CoinMap i)
    -> MaybeT m ([CoinMapEntry i], CoinMap i))
-> MaybeT m ([CoinMapEntry i], CoinMap i)
forall a b. MaybeT m a -> (a -> MaybeT m b) -> MaybeT m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(CoinMapEntry i
picked, CoinMap i
remaining') ->
                ([CoinMapEntry i], CoinMap i)
-> MaybeT m ([CoinMapEntry i], CoinMap i)
coverRandomly (CoinMapEntry i
picked CoinMapEntry i -> [CoinMapEntry i] -> [CoinMapEntry i]
forall a. a -> [a] -> [a]
: [CoinMapEntry i]
selected, CoinMap i
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 :: 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 (Integer
maxN0, CoinSelection i o
selection, CoinMap i
utxo0) ([CoinMapEntry i]
inps0, CoinMapEntry o
txout) = do
    (Integer
maxN, [CoinMapEntry i]
inps, CoinMap i
utxo) <- (Integer, [CoinMapEntry i], CoinMap i)
-> m (Integer, [CoinMapEntry i], CoinMap i)
improve (Integer
maxN0, [CoinMapEntry i]
inps0, CoinMap i
utxo0)
    (Integer, CoinSelection i o, CoinMap i)
-> m (Integer, CoinSelection i o, CoinMap i)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return
        ( Integer
maxN
        , CoinSelection i o
selection CoinSelection i o -> CoinSelection i o -> CoinSelection i o
forall a. Semigroup a => a -> a -> a
<> CoinSelection
            { inputs :: CoinMap i
inputs = [CoinMapEntry i] -> CoinMap i
forall a. Ord a => [CoinMapEntry a] -> CoinMap a
coinMapFromList [CoinMapEntry i]
inps
            , outputs :: CoinMap o
outputs = [CoinMapEntry o] -> CoinMap o
forall a. Ord a => [CoinMapEntry a] -> CoinMap a
coinMapFromList [CoinMapEntry o
txout]
            , change :: [Coin]
change = CoinMapEntry o -> [CoinMapEntry i] -> [Coin]
forall o i. CoinMapEntry o -> [CoinMapEntry i] -> [Coin]
mkChange CoinMapEntry o
txout [CoinMapEntry i]
inps
            }
        , CoinMap i
utxo
        )
  where
    target :: TargetRange
target = CoinMapEntry o -> TargetRange
forall o. CoinMapEntry o -> TargetRange
mkTargetRange CoinMapEntry o
txout

    improve
        :: (Integer, [CoinMapEntry i], CoinMap i)
        -> m (Integer, [CoinMapEntry i], CoinMap i)
    improve :: (Integer, [CoinMapEntry i], CoinMap i)
-> m (Integer, [CoinMapEntry i], CoinMap i)
improve (Integer
maxN, [CoinMapEntry i]
inps, CoinMap i
utxo)
        | Integer
maxN Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
1 Bool -> Bool -> Bool
&& [CoinMapEntry i] -> Coin
forall i. [CoinMapEntry i] -> Coin
sumEntries [CoinMapEntry i]
inps Coin -> Coin -> Bool
forall a. Ord a => a -> a -> Bool
< TargetRange -> Coin
targetAim TargetRange
target = do
            CoinMap i -> m (Maybe (CoinMapEntry i, CoinMap i))
forall (m :: * -> *) a.
MonadRandom m =>
CoinMap a -> m (Maybe (CoinMapEntry a, CoinMap a))
coinMapRandomEntry CoinMap i
utxo m (Maybe (CoinMapEntry i, CoinMap i))
-> (Maybe (CoinMapEntry i, CoinMap i)
    -> m (Integer, [CoinMapEntry i], CoinMap i))
-> m (Integer, [CoinMapEntry i], CoinMap i)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                Maybe (CoinMapEntry i, CoinMap i)
Nothing ->
                    (Integer, [CoinMapEntry i], CoinMap i)
-> m (Integer, [CoinMapEntry i], CoinMap i)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer
maxN, [CoinMapEntry i]
inps, CoinMap i
utxo)
                Just (CoinMapEntry i
io, CoinMap i
utxo') | CoinMapEntry i -> [CoinMapEntry i] -> Bool
isImprovement CoinMapEntry i
io [CoinMapEntry i]
inps -> do
                    let inps' :: [CoinMapEntry i]
inps' = CoinMapEntry i
io CoinMapEntry i -> [CoinMapEntry i] -> [CoinMapEntry i]
forall a. a -> [a] -> [a]
: [CoinMapEntry i]
inps
                    let maxN' :: Integer
maxN' = Integer
maxN Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1
                    (Integer, [CoinMapEntry i], CoinMap i)
-> m (Integer, [CoinMapEntry i], CoinMap i)
improve (Integer
maxN', [CoinMapEntry i]
inps', CoinMap i
utxo')
                Just (CoinMapEntry i, CoinMap i)
_ ->
                    (Integer, [CoinMapEntry i], CoinMap i)
-> m (Integer, [CoinMapEntry i], CoinMap i)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer
maxN, [CoinMapEntry i]
inps, CoinMap i
utxo)
        | Bool
otherwise =
            (Integer, [CoinMapEntry i], CoinMap i)
-> m (Integer, [CoinMapEntry i], CoinMap i)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer
maxN, [CoinMapEntry i]
inps, CoinMap i
utxo)

    isImprovement :: CoinMapEntry i -> [CoinMapEntry i] -> Bool
    isImprovement :: CoinMapEntry i -> [CoinMapEntry i] -> Bool
isImprovement CoinMapEntry i
io [CoinMapEntry i]
selected =
        let
            condA :: Bool
condA = -- (a) It doesn’t exceed a specified upper limit.
                [CoinMapEntry i] -> Coin
forall i. [CoinMapEntry i] -> Coin
sumEntries (CoinMapEntry i
io CoinMapEntry i -> [CoinMapEntry i] -> [CoinMapEntry i]
forall a. a -> [a] -> [a]
: [CoinMapEntry i]
selected) Coin -> Coin -> Bool
forall a. Ord a => a -> a -> Bool
< TargetRange -> Coin
targetMax TargetRange
target

            condB :: Bool
condB = -- (b) Addition gets us closer to the ideal change
                Coin
distanceA Coin -> Coin -> Bool
forall a. Ord a => a -> a -> Bool
< Coin
distanceB
              where
                distanceA :: Coin
distanceA = Coin -> Coin -> Coin
C.distance
                    (TargetRange -> Coin
targetAim TargetRange
target)
                    ([CoinMapEntry i] -> Coin
forall i. [CoinMapEntry i] -> Coin
sumEntries (CoinMapEntry i
io CoinMapEntry i -> [CoinMapEntry i] -> [CoinMapEntry i]
forall a. a -> [a] -> [a]
: [CoinMapEntry i]
selected))
                distanceB :: Coin
distanceB = Coin -> Coin -> Coin
C.distance
                    (TargetRange -> Coin
targetAim TargetRange
target)
                    ([CoinMapEntry i] -> Coin
forall i. [CoinMapEntry i] -> Coin
sumEntries [CoinMapEntry i]
selected)

            -- (c) Doesn't exceed maximum number of inputs
            -- Guaranteed by the precondition on 'improve'.
        in
            Bool
condA Bool -> Bool -> Bool
&& Bool
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
    { TargetRange -> Coin
targetMin :: Coin
        -- ^ The minimum value, corresponding to exactly the requested target
        -- amount, and a change amount of zero.
    , TargetRange -> Coin
targetAim :: Coin
        -- ^ The ideal value, corresponding to exactly twice the requested
        -- target amount, and a change amount equal to the requested amount.
    , TargetRange -> Coin
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 :: forall o. CoinMapEntry o -> TargetRange
mkTargetRange (CoinMapEntry o
_ Coin
c) = TargetRange
    { targetMin :: Coin
targetMin = Coin
c
    , targetAim :: Coin
targetAim = Coin
c Coin -> Coin -> Coin
`C.add` Coin
c
    , targetMax :: Coin
targetMax = Coin
c Coin -> Coin -> Coin
`C.add` Coin
c Coin -> Coin -> Coin
`C.add` Coin
c
    }

-- | 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 :: forall o i. CoinMapEntry o -> [CoinMapEntry i] -> [Coin]
mkChange (CoinMapEntry o
_ Coin
out) [CoinMapEntry i]
inps =
    case Maybe Coin
difference of
        Maybe Coin
Nothing ->
            [Char] -> [Coin]
forall a. HasCallStack => [Char] -> a
error ([Char] -> [Coin]) -> [Char] -> [Coin]
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
forall a. Monoid a => [a] -> a
mconcat
                [ [Char]
"mkChange: "
                , [Char]
"output must be less than or equal to sum of inputs"
                ]
        Just Coin
d | Coin -> Bool
C.isZero Coin
d ->
            []
        Just Coin
d ->
            [Coin
d]
  where
    difference :: Maybe Coin
difference = [CoinMapEntry i] -> Coin
forall i. [CoinMapEntry i] -> Coin
sumEntries [CoinMapEntry i]
inps Coin -> Coin -> Maybe Coin
`C.sub` Coin
out

--------------------------------------------------------------------------------
-- Utilities
--------------------------------------------------------------------------------

sumEntries :: [CoinMapEntry i] -> Coin
sumEntries :: forall i. [CoinMapEntry i] -> Coin
sumEntries = [Coin] -> Coin
forall a. Monoid a => [a] -> a
mconcat ([Coin] -> Coin)
-> ([CoinMapEntry i] -> [Coin]) -> [CoinMapEntry i] -> Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CoinMapEntry i -> Coin) -> [CoinMapEntry i] -> [Coin]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CoinMapEntry i -> Coin
forall a. CoinMapEntry a -> Coin
entryValue