Skip to content

Commit c01f1cd

Browse files
IAmPara0xIAmPara0x
committed
improve greedy coin selection
1 parent 388f9c7 commit c01f1cd

File tree

7 files changed

+158
-117
lines changed

7 files changed

+158
-117
lines changed

‎.envrc‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -1 +1,2 @@
1+
nix-user-chroot ~/.nix zsh -l
12
use flake

‎examples/debug/app/Main.hs‎

Lines changed: 0 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -9,4 +9,3 @@ import Prelude
99
main :: IO ()
1010
main = do
1111
TestRun.testnetRun
12-

‎examples/debug/src/SomeDebugContract.hs‎

Lines changed: 3 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -1,26 +1,26 @@
11
{-# LANGUAGE TemplateHaskell #-}
2-
module SomeDebugContract where
32

3+
module SomeDebugContract where
44

55
import Data.Aeson.Extras (encodeByteString)
66
import Data.Map (size)
77
import Data.Map qualified as M
88
import Data.Text (Text)
99
import Data.Void (Void)
1010
import Debug.Trace (traceM)
11-
import Ledger qualified
1211
import Ledger (Address (Address), PaymentPubKeyHash (PaymentPubKeyHash), getCardanoTxId)
12+
import Ledger qualified
1313
import Ledger.Constraints qualified as Constraints
1414
import Ledger.Scripts qualified as Scripts
1515
import Ledger.Tx (CardanoTx)
1616
import Ledger.Value qualified as Value
17-
import Plutus.Contract qualified as Contract
1817
import Plutus.Contract (
1918
Contract,
2019
Endpoint,
2120
submitTx,
2221
submitTxConstraintsWith,
2322
)
23+
import Plutus.Contract qualified as Contract
2424
import Plutus.PAB.Effects.Contract.Builtin (EmptySchema)
2525
import Plutus.V1.Ledger.Ada (adaValueOf)
2626
import Plutus.V1.Ledger.Api (Credential (PubKeyCredential))
@@ -65,7 +65,6 @@ payToHardcodedPKH = do
6565
traceM $ "UTxOs Size AFTER: " <> Hask.show (size utxosAfter)
6666
traceM $ "UTxOs AFTER: " <> ppShow utxosAfter
6767

68-
6968
curSymbol :: Value.CurrencySymbol
7069
curSymbol = Ledger.scriptCurrencySymbol mintingPolicy
7170

@@ -83,7 +82,6 @@ mintContract tn = do
8382
(PaymentPubKeyHash ownPkh) = ownPPkh
8483
ownAddr = Address (PubKeyCredential ownPkh) Nothing
8584

86-
8785
tx <- submitTxConstraintsWith @Void lookups constraints
8886

8987
Contract.awaitTxConfirmed (getCardanoTxId tx)

‎examples/debug/src/TestRun.hs‎

Lines changed: 1 addition & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -7,8 +7,8 @@ import Cardano.Api.Shelley (ProtocolParameters)
77
import Control.Concurrent.STM (newTVarIO, readTVarIO)
88
import Control.Monad (void)
99
import Data.Aeson (decodeFileStrict)
10-
import Data.Text (Text)
1110
import Data.String (fromString)
11+
import Data.Text (Text)
1212

1313
import Data.Text qualified as Text
1414
import Data.UUID.V4 qualified as UUID
@@ -48,7 +48,6 @@ testnetRun = do
4848

4949
let netMagic' = read netMagic
5050

51-
5251
cEnv <- mkContractEnv netMagic' bpiDir
5352

5453
putStrLn "Running contract"

‎src/BotPlutusInterface/Balance.hs‎

Lines changed: 61 additions & 73 deletions
Original file line numberDiff line numberDiff line change
@@ -9,14 +9,14 @@ module BotPlutusInterface.Balance (
99
) where
1010

1111
import BotPlutusInterface.CardanoCLI qualified as CardanoCLI
12+
import BotPlutusInterface.CoinSelection (selectTxIns)
1213
import BotPlutusInterface.Effects (
1314
PABEffect,
1415
createDirectoryIfMissingCLI,
1516
getInMemCollateral,
1617
posixTimeRangeToContainedSlotRange,
1718
printBpiLog,
1819
)
19-
import BotPlutusInterface.CoinSelection (selectTxIn)
2020
import BotPlutusInterface.Files (DummyPrivKey, unDummyPrivateKey)
2121
import BotPlutusInterface.Files qualified as Files
2222
import BotPlutusInterface.Types (CollateralUtxo, LogLevel (Debug), PABConfig, collateralTxOutRef, collateralValue)
@@ -29,13 +29,11 @@ import Control.Monad.Trans.Either (EitherT, hoistEither, newEitherT, runEitherT)
2929
import Control.Monad.Trans.Except (throwE)
3030
import Data.Bifunctor (bimap)
3131
import Data.Coerce (coerce)
32-
import Data.Either.Combinators (rightToMaybe)
3332
import Data.Kind (Type)
3433
import Data.List (uncons, (\\))
3534
import Data.Map (Map)
3635
import Data.Map qualified as Map
3736
import Data.Maybe (fromMaybe, mapMaybe)
38-
import Data.Set (Set)
3937
import Data.Set qualified as Set
4038
import Data.Text (Text)
4139
import Data.Text qualified as Text
@@ -64,7 +62,6 @@ import Ledger.Tx qualified as Tx
6462
import Ledger.Value (Value)
6563
import Ledger.Value qualified as Value
6664
import Plutus.V1.Ledger.Api (
67-
Credential (PubKeyCredential, ScriptCredential),
6865
CurrencySymbol (..),
6966
TokenName (..),
7067
)
@@ -178,15 +175,16 @@ balanceTxIO' pabConf ownPkh unbalancedTx balanceTxType =
178175
-- Get the updated change, add it to the tx
179176
let finalAdaChange = getAdaChange utxoIndex balancedTxWithChange
180177
fullyBalancedTx = addAdaChange changeAddr finalAdaChange balancedTxWithChange collateralTxOut
181-
txInfoLog = printBpiLog @w Debug
182-
$ "UnbalancedTx TxInputs: "
183-
<+> pretty (length $ txInputs preBalancedTx)
184-
<+> "UnbalancedTx TxOutputs: "
185-
<+> pretty (length $ txOutputs preBalancedTx)
186-
<+> "TxInputs: "
187-
<+> pretty (length $ txInputs fullyBalancedTx)
188-
<+> "TxOutputs: "
189-
<+> pretty (length $ txOutputs fullyBalancedTx)
178+
txInfoLog =
179+
printBpiLog @w Debug $
180+
"UnbalancedTx TxInputs: "
181+
<+> pretty (length $ txInputs preBalancedTx)
182+
<+> "UnbalancedTx TxOutputs: "
183+
<+> pretty (length $ txOutputs preBalancedTx)
184+
<+> "TxInputs: "
185+
<+> pretty (length $ txInputs fullyBalancedTx)
186+
<+> "TxOutputs: "
187+
<+> pretty (length $ txOutputs fullyBalancedTx)
190188

191189
lift txInfoLog
192190

@@ -220,14 +218,13 @@ balanceTxIO' pabConf ownPkh unbalancedTx balanceTxType =
220218

221219
nonBudgettedFees <- newEitherT $ CardanoCLI.calculateMinFee @w pabConf txWithoutFees
222220

223-
let fees = nonBudgettedFees + getBudgetPrice (getExecutionUnitPrices pabConf) exBudget
221+
let fees = nonBudgettedFees + getBudgetPrice (getExecutionUnitPrices pabConf) exBudget
224222

225223
lift $ printBpiLog @w Debug $ "Fees:" <+> pretty fees
226224

227225
-- Rebalance the initial tx with the above fees
228226
balancedTx <- hoistEither $ balanceTxStep minUtxos utxoIndex changeAddr $ tx `withFee` fees
229227

230-
231228
if balancedTx == tx
232229
then pure (balancedTx, minUtxos)
233230
else balanceTxLoop utxoIndex privKeys minUtxos balancedTx
@@ -321,61 +318,55 @@ getAdaChange utxos = lovelaceValue . getChange utxos
321318
getNonAdaChange :: Map TxOutRef TxOut -> Tx -> Value
322319
getNonAdaChange utxos = Ledger.noAdaValue . getChange utxos
323320

324-
-- | Getting the necessary utxos to cover the fees for the transaction
325-
collectTxIns :: Set TxIn -> Map TxOutRef TxOut -> Value -> Either Text (Set TxIn)
326-
collectTxIns originalTxIns utxos value = do
327-
updatedInputs <- selectTxInStep originalTxIns utxos value
328-
if isSufficient updatedInputs
329-
then pure updatedInputs
330-
else Left $
331-
Text.unlines
332-
[ "Insufficient tx inputs, needed: "
333-
, showText (Value.flattenValue value)
334-
, "got:"
335-
, showText (Value.flattenValue (txInsValue updatedInputs))
336-
]
337-
where
321+
{- | Getting the necessary utxos to cover the fees for the transaction
322+
collectTxIns :: Set TxIn -> Map TxOutRef TxOut -> Value -> Either Text (Set TxIn)
323+
collectTxIns originalTxIns utxos value = do
324+
updatedInputs <- selectTxInStep originalTxIns utxos value
325+
if isSufficient updatedInputs
326+
then pure updatedInputs
327+
else Left $
328+
Text.unlines
329+
[ "Insufficient tx inputs, needed: "
330+
, showText (Value.flattenValue value)
331+
, "got:"
332+
, showText (Value.flattenValue (txInsValue updatedInputs))
333+
]
334+
where
335+
336+
selectTxInStep ins utxoIndex outValue = do
337+
let txInRefs :: [TxOutRef]
338+
txInRefs = map txInRef $ Set.toList originalTxIns
339+
340+
diffUtxos :: [(TxOutRef, TxOut)]
341+
diffUtxos = Map.toList $ Map.filterWithKey (\k _ -> k `notElem` txInRefs) utxoIndex
342+
343+
case null diffUtxos of
344+
True -> return ins
345+
False -> do
346+
newIns <- selectTxIn ins utxoIndex outValue
347+
348+
if isSufficient newIns
349+
then return newIns
350+
else selectTxInStep newIns utxoIndex outValue
351+
-}
338352

339-
selectTxInStep ins utxoIndex outValue = do
340-
let txInRefs :: [TxOutRef]
341-
txInRefs = map txInRef $ Set.toList originalTxIns
342-
343-
diffUtxos :: [(TxOutRef, TxOut)]
344-
diffUtxos = Map.toList $ Map.filterWithKey (\k _ -> k `notElem` txInRefs) utxoIndex
345-
346-
case null diffUtxos of
347-
True -> return ins
348-
False -> do
349-
newIns <- selectTxIn ins utxoIndex outValue
350-
351-
if isSufficient newIns
352-
then return newIns
353-
else selectTxInStep newIns utxoIndex outValue
354-
355-
-- updatedInputs =
356-
-- foldl
357-
-- ( \acc txIn ->
358-
-- if isSufficient acc
359-
-- then acc
360-
-- else Set.insert txIn acc
361-
-- )
362-
-- originalTxIns
363-
-- $ mapMaybe (rightToMaybe . txOutToTxIn) $ Map.toList utxos
364-
365-
isSufficient :: Set TxIn -> Bool
366-
isSufficient txIns' =
367-
not (Set.null txIns') && txInsValue txIns' `Value.geq` value
368-
369-
txInsValue :: Set TxIn -> Value
370-
txInsValue txIns' =
371-
mconcat $ map Tx.txOutValue $ mapMaybe ((`Map.lookup` utxos) . Tx.txInRef) $ Set.toList txIns'
372-
373-
-- Converting a chain index transaction output to a transaction input type
374-
txOutToTxIn :: (TxOutRef, TxOut) -> Either Text TxIn
375-
txOutToTxIn (txOutRef, txOut) =
376-
case addressCredential (txOutAddress txOut) of
377-
PubKeyCredential _ -> Right $ Tx.pubKeyTxIn txOutRef
378-
ScriptCredential _ -> Left "Cannot covert a script output to TxIn"
353+
-- updatedInputs =
354+
-- foldl
355+
-- ( \acc txIn ->
356+
-- if isSufficient acc
357+
-- then acc
358+
-- else Set.insert txIn acc
359+
-- )
360+
-- originalTxIns
361+
-- $ mapMaybe (rightToMaybe . txOutToTxIn) $ Map.toList utxos
362+
363+
-- isSufficient :: Set TxIn -> Bool
364+
-- isSufficient txIns' =
365+
-- not (Set.null txIns') && txInsValue txIns' `Value.geq` value
366+
--
367+
-- txInsValue :: Set TxIn -> Value
368+
-- txInsValue txIns' =
369+
-- mconcat $ map Tx.txOutValue $ mapMaybe ((`Map.lookup` utxos) . Tx.txInRef) $ Set.toList txIns'
379370

380371
-- | Add min lovelaces to each tx output
381372
addLovelaces :: [(TxOut, Integer)] -> Tx -> Tx
@@ -403,7 +394,7 @@ balanceTxIns utxos tx = do
403394
[ txFee tx
404395
, nonMintedValue
405396
]
406-
txIns <- collectTxIns (txInputs tx) utxos minSpending
397+
txIns <- selectTxIns (txInputs tx) utxos minSpending
407398
pure $ tx {txInputs = txIns <> txInputs tx}
408399

409400
-- | Set collateral or fail in case it's required but not available
@@ -519,9 +510,6 @@ modifyFirst ::
519510
modifyFirst _ m [] = m Nothing `consJust` []
520511
modifyFirst p m (x : xs) = if p x then m (Just x) `consJust` xs else x : modifyFirst p m xs
521512

522-
showText :: forall (a :: Type). Show a => a -> Text
523-
showText = Text.pack . show
524-
525513
minus :: Value -> Value -> Value
526514
minus x y =
527515
let negativeValues = map (\(c, t, a) -> (c, t, - a)) $ Value.flattenValue y

0 commit comments

Comments
 (0)