{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
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
largestFirst
:: (Ord i, Monad m)
=> CoinSelectionAlgorithm i o m
largestFirst = CoinSelectionAlgorithm payForOutputs
payForOutputs
:: forall i o m . (Ord i, Monad m)
=> CoinSelectionParameters i o
-> ExceptT CoinSelectionError m (CoinSelectionResult i o)
payForOutputs params
| amountAvailable < amountRequired =
throwE
$ InputValueInsufficient
$ InputValueInsufficientError amountAvailable amountRequired
| length inputsSelected > inputCountMax =
throwE
$ InputLimitExceeded
$ InputLimitExceededError
$ fromIntegral inputCountMax
| otherwise =
pure CoinSelectionResult {coinSelection, inputsRemaining}
where
amountAvailable =
coinMapValue $ inputsAvailable params
amountRequired =
coinMapValue $ outputsRequested 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
takeUntil :: (a -> Bool) -> [a] -> [a]
takeUntil p = foldr (\x ys -> x : if p x then [] else ys) []