WIP

lib/core/cardano-wallet-core.cabal

@@ -178,6 +178,7 @@ library
       Cardano.Wallet.Primitive.AddressDiscovery.Sequential
       Cardano.Wallet.Primitive.AddressDiscovery.Shared
       Cardano.Wallet.Primitive.SyncProgress
+      Cardano.Wallet.Primitive.CoinSelection.Collateral
       Cardano.Wallet.Primitive.CoinSelection.MA.RoundRobin
       Cardano.Wallet.Primitive.Delegation.UTxO
       Cardano.Wallet.Primitive.Migration
@@ -297,6 +298,7 @@ test-suite unit
     , regex-pcre-builtin
     , OddWord
     , ouroboros-consensus
+    , overloaded
     , QuickCheck
     , quickcheck-classes
     , quickcheck-state-machine >= 0.6.0
@@ -366,6 +368,7 @@ test-suite unit
       Cardano.Wallet.Primitive.AddressDiscovery.SharedSpec
       Cardano.Wallet.Primitive.Delegation.StateSpec
       Cardano.Wallet.Primitive.AddressDiscoverySpec
+      Cardano.Wallet.Primitive.CoinSelection.CollateralSpec
       Cardano.Wallet.Primitive.CoinSelection.MA.RoundRobinSpec
       Cardano.Wallet.Primitive.MigrationSpec
       Cardano.Wallet.Primitive.Migration.PlanningSpec

lib/core/src/Cardano/Wallet/Primitive/CoinSelection/Collateral.hs

@@ -0,0 +1,131 @@
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Cardano.Wallet.Primitive.CoinSelection.Collateral where
+
+import Cardano.Wallet.Primitive.Types.Coin
+    ( Coin )
+import Data.Function
+    ( (&) )
+import Data.Map.Strict
+    ( Map )
+import Data.Maybe
+    ( listToMaybe, mapMaybe )
+import Data.Ord
+    ( Down (..) )
+
+import Prelude
+
+import qualified Data.Foldable as F
+import qualified Data.List as L
+import qualified Data.Map.Strict as Map
+
+--------------------------------------------------------------------------------
+-- Types
+--------------------------------------------------------------------------------
+
+data SelectCollateralParams inputId = SelectCollateralParams
+    { coinsAvailable
+        :: Map inputId Coin
+    , minimumCollateralAmount
+        :: Coin
+    , maximumCollateralEntryCount
+        :: Int
+    , maximumSearchSpaceSize
+        :: Maybe Int
+    }
+    deriving (Eq, Show)
+
+data SelectCollateralResult inputId = SelectCollateralResult
+    { coinsSelected :: Map inputId Coin
+    , coinsLeftover :: Map inputId Coin
+    }
+    deriving (Eq, Show)
+
+-- Note: the largest combination should never be valid.
+--
+data SelectCollateralError inputId = SelectCollateralError
+    { minimumCollateralAmount
+        :: Coin
+    , largestCombinationAvailable
+        :: Map inputId Coin
+    }
+    deriving (Eq, Show)
+
+--------------------------------------------------------------------------------
+-- Selecting collateral
+--------------------------------------------------------------------------------
+
+selectCollateral
+    :: forall inputId. Ord inputId
+    => SelectCollateralParams inputId
+    -> Either
+        (SelectCollateralError inputId)
+        (SelectCollateralResult inputId)
+selectCollateral params =
+    case smallestValidCombinationMaybe of
+        Just smallestValidCombination ->
+            Right SelectCollateralResult
+                { coinsSelected = smallestValidCombination
+                , coinsLeftover = coinsAvailable
+                    `Map.withoutKeys` Map.keysSet smallestValidCombination
+                }
+        Nothing ->
+            Left SelectCollateralError
+                { minimumCollateralAmount
+                , largestCombinationAvailable
+                }
+  where
+    smallestValidCombinationMaybe :: Maybe (Map inputId Coin)
+    smallestValidCombinationMaybe
+        = listToMaybe
+        $ L.sortOn F.fold validCombinations
+      where
+        validCombinations :: [Map inputId Coin]
+        validCombinations = mapMaybe smallestValidCombinationForSize
+            [1 .. maximumCollateralEntryCount]
+
+    smallestValidCombinationForSize :: Int -> Maybe (Map inputId Coin)
+    smallestValidCombinationForSize size = coinsAvailable
+        & Map.toList
+        & subsequencesOfSize size
+        & fmap (\ics -> (ics, F.foldMap snd ics))
+        & L.sortOn snd
+        & L.dropWhile ((< minimumCollateralAmount) . snd)
+        & listToMaybe
+        & fmap (Map.fromList . fst)
+
+    largestCombinationAvailable :: Map inputId Coin
+    largestCombinationAvailable = coinsAvailable
+        & Map.toList
+        & L.sortOn (Down . snd)
+        & L.take maximumCollateralEntryCount
+        & Map.fromList
+
+    SelectCollateralParams
+        { coinsAvailable
+        , minimumCollateralAmount
+        , maximumCollateralEntryCount
+        } = params
+
+--------------------------------------------------------------------------------
+-- Utility functions
+--------------------------------------------------------------------------------
+
+subsequencesOfSize :: Int -> [a] -> [[a]]
+subsequencesOfSize n xs
+    | n > length xs =
+        []
+    | otherwise =
+        subsequencesBySize xs !! n
+  where
+    subsequencesBySize [] = [[[]]]
+    subsequencesBySize (x : xs) =
+        zipWith
+            (++)
+            ([] : map (map (x :)) next)
+            (next ++ [[]])
+      where
+        next = subsequencesBySize xs

lib/core/test/unit/Cardano/Wallet/Primitive/CoinSelection/CollateralSpec.hs

@@ -0,0 +1,122 @@
+{-# OPTIONS -fplugin=Overloaded -fplugin-opt=Overloaded:Numerals #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedLists #-}
+
+module Cardano.Wallet.Primitive.CoinSelection.CollateralSpec where
+
+import Prelude
+
+import Cardano.Wallet.Primitive.CoinSelection.Collateral
+    ( SelectCollateralParams (..)
+    , SelectCollateralResult (..)
+    , selectCollateral
+    )
+import Cardano.Wallet.Primitive.Types.Coin
+    ( Coin (..) )
+import Data.Either
+    ( isLeft, isRight )
+import Data.Map.Strict
+    ( Map )
+import Data.Word
+    ( Word64 )
+import Test.Hspec
+    ( Spec )
+import Test.QuickCheck
+    ( Gen
+    , Property
+    , checkCoverage
+    , choose
+    , conjoin
+    , cover
+    , forAll
+    , label
+    , property
+    , scale
+    , sized
+    , shuffle
+    , (===)
+    )
+
+import qualified Data.Bits as Bits
+import qualified Data.Foldable as F
+import qualified Data.Map.Strict as Map
+
+spec :: Spec
+spec = undefined
+
+-- TODO: Make a property that always fails (we don't allow the selection of
+-- enough coins).
+--
+-- Think a bit more carefully about the different conditions we want to test.
+-- * Enough coins available, but limited
+-- * Enough coins available, and not limited
+-- * Not enough coins available.
+--
+prop_selectCollateral_singleBitCoins :: Property
+prop_selectCollateral_singleBitCoins =
+    forAll genSingleBitCoinMap $ \(SingleBit coinsAvailable) ->
+    forAll genCoin $ \minimumCollateralAmount ->
+    let requiredCoinCount = Bits.popCount (unCoin minimumCollateralAmount) in
+    let params = SelectCollateralParams
+            { coinsAvailable
+            , minimumCollateralAmount
+            , maximumCollateralEntryCount = requiredCoinCount
+            , maximumSearchSpaceSize = Nothing
+            } in
+    let maybeResult = selectCollateral params in
+    checkCoverage $
+    cover 0.1 (isLeft maybeResult)
+        "Failure" $
+    cover 0.1 (isRight maybeResult)
+        "Success" $
+    cover 10.0 (requiredCoinCount == 1)
+        "Required coin count: 1" $
+    cover 10.0 (requiredCoinCount == 2)
+        "Required coin count: 2" $
+    cover 10.0 (requiredCoinCount == 3)
+        "Required coin count: 3" $
+    cover 10.0 (requiredCoinCount == 4)
+        "Required coin count: 4" $
+    label ("Required coin count: " <> show requiredCoinCount) $
+    case maybeResult of
+        Left _ ->
+            -- TODO: What does this mean?
+            property True
+        Right result -> conjoin
+            [ Map.size (coinsSelected result) === requiredCoinCount
+            , F.fold (coinsSelected result) === minimumCollateralAmount
+            ]
+
+test :: SelectCollateralParams TestInputIdChar
+test = SelectCollateralParams
+    { coinsAvailable = [A ▶ 1, B ▶ 18446744073709551615]
+    , minimumCollateralAmount = 0
+    , maximumCollateralEntryCount = 0
+    , maximumSearchSpaceSize = Nothing
+    }
+
+(▶) :: a -> b -> (a, b)
+(▶) = (,)
+
+data TestInputIdChar
+    = A | B | C | D | E | F | G | H | I | J | K | L | M
+    | N | O | P | Q | R | S | T | U | V | W | X | Y | Z
+    deriving (Enum, Eq, Ord, Show)
+
+type TestCoinMap = Map TestInputIdChar Coin
+
+newtype SingleBit a = SingleBit { unSingleBit :: a }
+    deriving (Eq, Show)
+
+genCoin :: Gen Coin
+genCoin = sized $ \size -> do
+    Coin . fromIntegral <$> choose (1, max 1 size)
+
+genSingleBitCoinMap :: Gen (SingleBit TestCoinMap)
+genSingleBitCoinMap = sized $ \size ->
+    SingleBit . Map.fromList . flip zip powersOfTwo
+        <$> shuffle (take size [A ..])
+  where
+    powersOfTwo = Coin . ((2 :: Word64) ^) <$> [0 :: Word64 .. ]