{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}

-- |
-- Copyright: © 2018-2024 Intersect MBO
-- License: Apache-2.0
--
-- This module contains an implementation of the __Largest-First__ coin
-- selection algorithm.
--
module Cardano.CoinSelection.Algorithm.LargestFirst (
    largestFirst
  ) where

import Prelude

import Cardano.CoinSelection
    ( CoinMap (..)
    , CoinMapEntry (..)
    , CoinSelection (..)
    , CoinSelectionAlgorithm (..)
    , CoinSelectionError (..)
    , CoinSelectionLimit (..)
    , CoinSelectionParameters (..)
    , CoinSelectionResult (..)
    , InputLimitExceededError (..)
    , InputValueInsufficientError (..)
    , coinMapFromList
    , coinMapToList
    , coinMapValue
    )
import Control.Monad.Trans.Except ( ExceptT (..), throwE )
import Data.Function ( (&) )
import Data.Ord ( Down (..) )
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.
--
-- The Largest-First coin selection algorithm considers available inputs 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.
--
-- === Change Values
--
-- 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.
--
-- 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
--
-- The algorithm terminates with an __error__ if:
--
--  1.  The /total value/ of 'inputsAvailable' (the amount of money
--      /available/) is /less than/ the total value of 'outputsRequested' (the
--      amount of money /required/).
--
--      See: __'InputValueInsufficientError'__.
--
--  2.  It is not possible to cover the total value of 'outputsRequested'
--      without selecting a number of inputs from 'inputsAvailable' that
--      would exceed the maximum defined by 'limit'.
--
--      See: __'InputLimitExceededError'__.
--
-- @since 1.0.0
largestFirst
    :: (Ord i, Monad m)
    => CoinSelectionAlgorithm i o m
largestFirst :: forall i (m :: * -> *) o.
(Ord i, Monad m) =>
CoinSelectionAlgorithm i o m
largestFirst = (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, Monad m) =>
CoinSelectionParameters i o
-> ExceptT CoinSelectionError m (CoinSelectionResult i o)
payForOutputs

payForOutputs
    :: forall i o m . (Ord i, Monad m)
    => CoinSelectionParameters i o
    -> ExceptT CoinSelectionError m (CoinSelectionResult i o)
payForOutputs :: forall i o (m :: * -> *).
(Ord i, Monad m) =>
CoinSelectionParameters i o
-> ExceptT CoinSelectionError m (CoinSelectionResult i o)
payForOutputs CoinSelectionParameters i o
params
    | Coin
amountAvailable Coin -> Coin -> Bool
forall a. Ord a => a -> a -> Bool
< Coin
amountRequired =
        CoinSelectionError
-> ExceptT CoinSelectionError m (CoinSelectionResult i o)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE
            (CoinSelectionError
 -> ExceptT CoinSelectionError m (CoinSelectionResult i o))
-> CoinSelectionError
-> ExceptT CoinSelectionError m (CoinSelectionResult i o)
forall a b. (a -> b) -> a -> b
$ InputValueInsufficientError -> CoinSelectionError
InputValueInsufficient
            (InputValueInsufficientError -> CoinSelectionError)
-> InputValueInsufficientError -> CoinSelectionError
forall a b. (a -> b) -> a -> b
$ Coin -> Coin -> InputValueInsufficientError
InputValueInsufficientError Coin
amountAvailable Coin
amountRequired
    | CoinMap i -> Int
forall a. CoinMap a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length CoinMap i
inputsSelected Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
inputCountMax =
        CoinSelectionError
-> ExceptT CoinSelectionError m (CoinSelectionResult i o)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE
            (CoinSelectionError
 -> ExceptT CoinSelectionError m (CoinSelectionResult i o))
-> CoinSelectionError
-> ExceptT CoinSelectionError m (CoinSelectionResult i o)
forall a b. (a -> b) -> a -> b
$ 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
$ Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
inputCountMax
    | Bool
otherwise =
        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 {CoinSelection i o
coinSelection :: CoinSelection i o
coinSelection :: CoinSelection i o
coinSelection, CoinMap i
inputsRemaining :: CoinMap i
inputsRemaining :: CoinMap i
inputsRemaining}
  where
    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
    amountRequired :: Coin
amountRequired =
        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
    coinSelection :: CoinSelection i o
coinSelection = CoinSelection
        { inputs :: CoinMap i
inputs =
            CoinMap i
inputsSelected
        , outputs :: CoinMap o
outputs =
            CoinSelectionParameters i o -> CoinMap o
forall i o. CoinSelectionParameters i o -> CoinMap o
outputsRequested CoinSelectionParameters i o
params
        , change :: [Coin]
change = (Coin -> Bool) -> [Coin] -> [Coin]
forall a. (a -> Bool) -> [a] -> [a]
filter (Coin -> Coin -> Bool
forall a. Ord a => a -> a -> Bool
> Coin
C.zero)
            ([Coin] -> [Coin]) -> [Coin] -> [Coin]
forall a b. (a -> b) -> a -> b
$ Maybe Coin -> [Coin]
forall a. Maybe a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList
            (Maybe Coin -> [Coin]) -> Maybe Coin -> [Coin]
forall a b. (a -> b) -> a -> b
$ CoinMap i -> Coin
forall a. CoinMap a -> Coin
coinMapValue CoinMap i
inputsSelected Coin -> Coin -> Maybe Coin
`C.sub` Coin
amountRequired
        }
    inputsAvailableDescending :: [CoinMapEntry i]
    inputsAvailableDescending :: [CoinMapEntry i]
inputsAvailableDescending = CoinSelectionParameters i o -> CoinMap i
forall i o. CoinSelectionParameters i o -> CoinMap i
inputsAvailable CoinSelectionParameters i o
params
        CoinMap i -> (CoinMap i -> [CoinMapEntry i]) -> [CoinMapEntry i]
forall a b. a -> (a -> b) -> b
& CoinMap i -> [CoinMapEntry i]
forall a. CoinMap a -> [CoinMapEntry a]
coinMapToList
        [CoinMapEntry i]
-> ([CoinMapEntry i] -> [CoinMapEntry i]) -> [CoinMapEntry i]
forall a b. a -> (a -> b) -> b
& (CoinMapEntry i -> Down Coin)
-> [CoinMapEntry i] -> [CoinMapEntry i]
forall b a. Ord b => (a -> b) -> [a] -> [a]
L.sortOn (Coin -> Down Coin
forall a. a -> Down a
Down (Coin -> Down Coin)
-> (CoinMapEntry i -> Coin) -> CoinMapEntry i -> Down Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoinMapEntry i -> Coin
forall a. CoinMapEntry a -> Coin
entryValue)
    inputCountMax :: Int
    inputCountMax :: Int
inputCountMax = CoinSelectionParameters i o -> CoinMap o
forall i o. CoinSelectionParameters i o -> CoinMap o
outputsRequested CoinSelectionParameters i o
params
        CoinMap o -> (CoinMap o -> [CoinMapEntry o]) -> [CoinMapEntry o]
forall a b. a -> (a -> b) -> b
& CoinMap o -> [CoinMapEntry o]
forall a. CoinMap a -> [CoinMapEntry a]
coinMapToList
        [CoinMapEntry o] -> ([CoinMapEntry o] -> Int) -> Int
forall a b. a -> (a -> b) -> b
& [CoinMapEntry o] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length
        Int -> (Int -> Word16) -> Word16
forall a b. a -> (a -> b) -> b
& forall a b. (Integral a, Num b) => a -> b
fromIntegral @Int @Word16
        Word16 -> (Word16 -> Word16) -> Word16
forall a b. a -> (a -> b) -> b
& CoinSelectionLimit -> Word16 -> Word16
calculateLimit (CoinSelectionParameters i o -> CoinSelectionLimit
forall i o. CoinSelectionParameters i o -> CoinSelectionLimit
limit CoinSelectionParameters i o
params)
        Word16 -> (Word16 -> Int) -> Int
forall a b. a -> (a -> b) -> b
& forall a b. (Integral a, Num b) => a -> b
fromIntegral @Word16 @Int
    inputsSelected :: CoinMap i
    inputsSelected :: CoinMap i
inputsSelected = [CoinMapEntry i]
inputsAvailableDescending
        [CoinMapEntry i] -> ([CoinMapEntry i] -> [Coin]) -> [Coin]
forall a b. a -> (a -> b) -> b
& (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
        [Coin] -> ([Coin] -> [Coin]) -> [Coin]
forall a b. a -> (a -> b) -> b
& (Coin -> Coin -> Coin) -> [Coin] -> [Coin]
forall a. (a -> a -> a) -> [a] -> [a]
scanl1 Coin -> Coin -> Coin
forall a. Semigroup a => a -> a -> a
(<>)
        [Coin] -> ([Coin] -> [Coin]) -> [Coin]
forall a b. a -> (a -> b) -> b
& (Coin -> Bool) -> [Coin] -> [Coin]
forall a. (a -> Bool) -> [a] -> [a]
takeUntil (Coin -> Coin -> Bool
forall a. Ord a => a -> a -> Bool
>= Coin
amountRequired)
        [Coin]
-> ([Coin] -> [(CoinMapEntry i, Coin)]) -> [(CoinMapEntry i, Coin)]
forall a b. a -> (a -> b) -> b
& [CoinMapEntry i] -> [Coin] -> [(CoinMapEntry i, Coin)]
forall a b. [a] -> [b] -> [(a, b)]
zip [CoinMapEntry i]
inputsAvailableDescending
        [(CoinMapEntry i, Coin)]
-> ([(CoinMapEntry i, Coin)] -> [CoinMapEntry i])
-> [CoinMapEntry i]
forall a b. a -> (a -> b) -> b
& ((CoinMapEntry i, Coin) -> CoinMapEntry i)
-> [(CoinMapEntry i, Coin)] -> [CoinMapEntry i]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (CoinMapEntry i, Coin) -> CoinMapEntry i
forall a b. (a, b) -> a
fst
        [CoinMapEntry i] -> ([CoinMapEntry i] -> CoinMap i) -> CoinMap i
forall a b. a -> (a -> b) -> b
& [CoinMapEntry i] -> CoinMap i
forall a. Ord a => [CoinMapEntry a] -> CoinMap a
coinMapFromList
    inputsRemaining :: CoinMap i
    inputsRemaining :: CoinMap i
inputsRemaining = [CoinMapEntry i]
inputsAvailableDescending
        [CoinMapEntry i]
-> ([CoinMapEntry i] -> [CoinMapEntry i]) -> [CoinMapEntry i]
forall a b. a -> (a -> b) -> b
& Int -> [CoinMapEntry i] -> [CoinMapEntry i]
forall a. Int -> [a] -> [a]
drop (CoinMap i -> Int
forall a. CoinMap a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length CoinMap i
inputsSelected)
        [CoinMapEntry i] -> ([CoinMapEntry i] -> CoinMap i) -> CoinMap i
forall a b. a -> (a -> b) -> b
& [CoinMapEntry i] -> CoinMap i
forall a. Ord a => [CoinMapEntry a] -> CoinMap a
coinMapFromList

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

takeUntil :: (a -> Bool) -> [a] -> [a]
takeUntil :: forall a. (a -> Bool) -> [a] -> [a]
takeUntil a -> Bool
p = (a -> [a] -> [a]) -> [a] -> [a] -> [a]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\a
x [a]
ys -> a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: if a -> Bool
p a
x then [] else [a]
ys) []