From ead575b7c5b6380c60ac5cf4105fa9be499c1851 Mon Sep 17 00:00:00 2001 From: AOranov Date: Thu, 21 Mar 2024 19:24:55 +0300 Subject: [PATCH 1/2] Redeem & Swap for random weights and fees fixes. --- .../WhalePoolsDex/PContracts/PBalancePool.hs | 71 +- plutarch-validators/test/Eval.hs | 5 +- .../test/Gen/BalancePoolGen.hs | 81 +- plutarch-validators/test/Tests/BalancePool.hs | 726 +++++++++++++++--- 4 files changed, 736 insertions(+), 147 deletions(-) diff --git a/plutarch-validators/WhalePoolsDex/PContracts/PBalancePool.hs b/plutarch-validators/WhalePoolsDex/PContracts/PBalancePool.hs index d8389dd..08c6cad 100644 --- a/plutarch-validators/WhalePoolsDex/PContracts/PBalancePool.hs +++ b/plutarch-validators/WhalePoolsDex/PContracts/PBalancePool.hs @@ -186,7 +186,7 @@ verifyGEquality :: :--> PInteger :--> PBool ) -verifyGEquality = plam $ \leftSideMultiplicator rightSideRaw prevTokenBalance tokenG tokenWeight -> +verifyGEquality = plam $ \leftSideMultiplicator rightSideRaw prevTokenBalance tokenG tokenWeight -> unTermCont $ do let tokenBalanceIntLength = pIntLength # prevTokenBalance @@ -201,10 +201,14 @@ verifyGEquality = plam $ \leftSideMultiplicator rightSideRaw prevTokenBalance to gEDiff = leftSide - rightSide validGEquality = pif ( gEDiff #<= 0 ) - ( (-1) #<= gEDiff ) - ( gEDiff #<= (1) ) + ( (-2) #<= gEDiff ) + ( gEDiff #<= (2) ) - in validGEquality + ptraceC $ "gEDiff" + ptraceC $ pshow $ gEDiff + ptraceC $ "validGEquality" + ptraceC $ pshow $ validGEquality + pure validGEquality verifyTExpEquality :: ClosedTerm @@ -310,9 +314,12 @@ validSwap = plam $ \prevState' newState' prevPoolConfig newPoolConfig newGX newT prevInvariantLength = pIntLength # prevInvariant newInvarianRounded = roundTo # (newGX #* newGY) # prevInvariantLength - + invariantRoundingDiff = newInvarianRounded - prevInvariant -- Verify that new value of invariant equals to previous - newInvariantIsCorrect = prevInvariant #== newInvarianRounded + newInvariantIsCorrect = pif + ( invariantRoundingDiff #<= 0 ) + ( (-1) #<= invariantRoundingDiff ) + ( invariantRoundingDiff #<= (1) ) correctTokensUpdate = pif @@ -343,6 +350,15 @@ validSwap = plam $ \prevState' newState' prevPoolConfig newPoolConfig newGX newT #$ pdcons @"invariant" @PInteger # pdata prevInvariant # pdnil) + + ptraceC $ "prevInvariant" + ptraceC $ pshow $ prevInvariant + ptraceC $ "newInvarianRounded" + ptraceC $ pshow $ newInvarianRounded + ptraceC $ "correctTokensUpdate" + ptraceC $ pshow $ correctTokensUpdate + ptraceC $ "correctTreasuryUpdate" + ptraceC $ pshow $ correctTreasuryUpdate pure $ ( newInvariantIsCorrect #&& correctTokensUpdate @@ -371,26 +387,45 @@ correctLpTokenDelta :: :--> PInteger :--> PBool ) -correctLpTokenDelta = plam $ \lpIssued lpDelta tokenDelta tokenBalance tokenWeight tokenG tokenT -> +correctLpTokenDelta = plam $ \lpIssued lpDelta tokenDelta tokenBalance tokenWeight tokenG tokenT -> unTermCont $ do let tokenBalanceIntLength = pIntLength # tokenBalance leftPart = roundTo # ((pabs #tokenDelta) * lpIssued) # tokenBalanceIntLength rightPart = roundTo # (tokenBalance * (pabs # lpDelta)) # tokenBalanceIntLength - leftRightPartDiff = leftPart - rightPart + calcTokenDelta = (pdiv # (lpDelta #* tokenBalance) # lpIssued) + + tokensDiff = calcTokenDelta - tokenDelta + + correctTokenError = pif + ( tokensDiff #<= 0 ) + ( (-1) #<= tokensDiff ) + ( tokensDiff #<= (1) ) + + correctTokenIn = correctTokenError #&& (calcTokenDelta #<= tokenDelta) - correctTokenIn = pif - ( leftRightPartDiff #<= 0 ) - ( (-1) #<= leftRightPartDiff ) - ( leftRightPartDiff #<= (1) ) - correctTokenValue = pif ( (pmod # pDen # tokenWeight) #== 0 ) ( verifyGEquality # 1 # (tokenBalance + tokenDelta) # tokenBalance # tokenG # tokenWeight ) ( verifyTExpEquality # tokenT # (tokenBalance + tokenDelta) ) - - in correctTokenIn #&& correctTokenValue + ptraceC $ "leftPart" + ptraceC $ pshow leftPart + ptraceC $ "rightPart" + ptraceC $ pshow rightPart + ptraceC $ "tokenBalance" + ptraceC $ pshow tokenBalance + ptraceC $ "tokenDelta" + ptraceC $ pshow tokenDelta + ptraceC $ "calcTokenDelta" + ptraceC $ pshow calcTokenDelta + ptraceC $ "correctTokenValue" + ptraceC $ pshow correctTokenValue + ptraceC $ "lpIssued" + ptraceC $ pshow lpIssued + ptraceC $ "lpDelta" + ptraceC $ pshow lpDelta + pure $ correctTokenIn #&& correctTokenValue validDepositRedeemAllTokens :: ClosedTerm @@ -456,6 +491,12 @@ validDepositRedeemAllTokens = plam $ \prevState' newState' prevPoolConfig newPoo #$ pdcons @"invariant" @PInteger # pdata newInvariant # pdnil) + ptraceC $ "xDepositRedeemIsValid" + ptraceC $ pshow xDepositRedeemIsValid + ptraceC $ "yDepositRedeemIsValid" + ptraceC $ pshow yDepositRedeemIsValid + ptraceC $ "newPoolConfig #== newExpectedConfig" + ptraceC $ pshow (newPoolConfig #== newExpectedConfig) pure $ ( xDepositRedeemIsValid #&& yDepositRedeemIsValid diff --git a/plutarch-validators/test/Eval.hs b/plutarch-validators/test/Eval.hs index d04ed8f..3a5ec55 100644 --- a/plutarch-validators/test/Eval.hs +++ b/plutarch-validators/test/Eval.hs @@ -14,13 +14,14 @@ import PlutusTx (Data) import Debug.Trace evalConfig :: Config -evalConfig = Config NoTracing +evalConfig = Config DoTracing evalWithArgs :: ClosedTerm a -> [Data] -> Either Text (ExBudget, [Text], Program DeBruijn DefaultUni DefaultFun ()) evalWithArgs x args = do cmp <- compile evalConfig x - --traceM $ "Compiled:" + traceM $ "Compiled:" let (escr, budg, trc) = evalScriptHuge $ applyArguments cmp args + traceM $ "Trace:" ++ (show trc) scr <- left (pack . show) escr pure (budg, trc, unScript scr) diff --git a/plutarch-validators/test/Gen/BalancePoolGen.hs b/plutarch-validators/test/Gen/BalancePoolGen.hs index ccec6bd..ac5185b 100644 --- a/plutarch-validators/test/Gen/BalancePoolGen.hs +++ b/plutarch-validators/test/Gen/BalancePoolGen.hs @@ -87,6 +87,7 @@ instance ToTxInfo BalancePool where } feeDen = 100000 +precisionAdditionalDec = 10 daoMintingPurpose :: BalancePool -> ScriptPurpose daoMintingPurpose BalancePool{..} = Rewarding $ List.head (daoPolicy config) @@ -136,20 +137,21 @@ genBalancePool adminsPkhs threshold lpFeeIsEditable = do stakeHash <- genPkh - -- todo: error on big values such as 10000000000000000 - (xQty :: Integer) <- integral (Range.constant 10000000000 10000000000000000) + -- todo: error on big values such as 10000000000000000 -- (yQty :: Int) <- integral (Range.constant 10000000000 10000000000000000) - -- todo: doesn't work for non 2/8 pools - -- (xWeight :: Integer) <- integral (Range.constant 1 5) - + (xWeight :: Integer) <- integral (Range.constant 1 5) + (xQty :: Integer) <- integral (Range.constant 1000000000 1000000000000) poolFee <- integral (Range.constant 80000 feeDen) - trFee <- integral (Range.constant 0 1000) + trFee <- integral (Range.constant 1 1000) + -- let trFee = 683 + -- let poolFee = 86472 + -- let xWeight = 5 + -- let yWeight = 5 + -- let xQty = 303457031315 treasuryAddress <- genValidatorHash let - --xQty = 1325954420705621 - xWeight = 2 yWeight = 10 - xWeight yQty = xQty * yWeight @@ -161,7 +163,7 @@ genBalancePool adminsPkhs threshold lpFeeIsEditable = do yPartLength = toInteger $ RIO.length . show $ xQty xValueLength = toInteger $ RIO.length . show $ yQty - maxPrecision = (if (yPartLength > xValueLength) then yPartLength else xValueLength) + maxPrecision = (if (yPartLength > xValueLength) then yPartLength else xValueLength) + precisionAdditionalDec -- invariant = (xQtyFloat**(xWeightFloat / 10)) * (yQtyFloat**(yWeightFloat / 10)) invariantT = ((BigDecimal xQty 0) ** (fromRational $ (fromIntegral xWeight) / 10)) * ( (BigDecimal yQty 0) ** (fromRational $ (fromIntegral yWeight) / 10)) @@ -192,7 +194,12 @@ genBalancePool adminsPkhs threshold lpFeeIsEditable = do } poolValue = mkValues ((\(ac, qty) -> mkValue ac (fromIntegral qty)) `RIO.map` [(x, xQty), (y, yQty), (nft, nftQty), (lq, lqQty)]) mempty - + traceM $ T.pack $ (("x: ") ++ (show xQty)) + traceM $ T.pack $ (("y: ") ++ (show yQty)) + traceM $ T.pack $ (("xWeight: ") ++ (show xWeight)) + traceM $ T.pack $ (("yWeight: ") ++ (show yWeight)) + traceM $ T.pack $ (("poolFee: ") ++ (show poolFee)) + traceM $ T.pack $ (("trFee: ") ++ (show trFee)) pure $ BalancePool poolConfig stakeHash poolValue --- Test utils --- @@ -204,11 +211,7 @@ calculateGandTSwap baseAssetBalance baseAssetWeight quoteAssetBalance quoteAsset yPartLength = toInteger $ RIO.length . show $ quoteAssetBalance xValueLength = toInteger $ RIO.length . show $ (baseAssetBalance + baseIn) - maxPrecisionByToken = (if (yPartLength > xValueLength) then yPartLength else xValueLength) - - maxPrecision = (if (yPartLength > xValueLength) then yPartLength else xValueLength) + 15 - - xValuePrecise = 10 ^ xValueLength + maxPrecision = (if (yPartLength > xValueLength) then yPartLength else xValueLength) + precisionAdditionalDec invariantLength = toInteger $ RIO.length . show $ prevInvariant @@ -232,7 +235,7 @@ calculateGandTSwap baseAssetBalance baseAssetWeight quoteAssetBalance quoteAsset -- test invDivision = invariantFloat / xInInvariantWithDegree - invDivisionInReverseDegree = nthRoot (invDivision ** 10) (fromInteger quoteAssetWeghit) (DOWN, (Just . toInteger $ 10)) + invDivisionInReverseDegree = nthRoot (invDivision ** 10) (fromInteger quoteAssetWeghit) (DOWN, (Just . toInteger $ 0)) -- denum = 10 ^ (yPartLength - xValueLength) invDivisionInReverseDegreeBigDecimalRounded = takeNBigDecimal invDivisionInReverseDegree (yPartLength) @@ -244,6 +247,16 @@ calculateGandTSwap baseAssetBalance baseAssetWeight quoteAssetBalance quoteAsset gY = takeNBigDecimal gYDouble (maxPrecision) -- ((getValue gYDouble)) tY = takeNBigDecimal tGDouble (maxPrecision) -- ((getValue tGDouble)) + traceM $ T.pack $ (("baseAssetWeight: ") ++ (show baseAssetWeight)) + traceM $ T.pack $ (("maxPrecision: ") ++ (show maxPrecision)) + traceM $ T.pack $ (("gX: ") ++ (show gX)) + traceM $ T.pack $ (("tX: ") ++ (show tX)) + traceM $ T.pack $ (("gY: ") ++ (show gY)) + traceM $ T.pack $ (("tY: ") ++ (show tY)) + traceM $ T.pack $ (("yToSwap: ") ++ (show yToSwap)) + traceM $ T.pack $ (("xInInvariantWithDegree: ") ++ (show xInInvariantWithDegree)) + traceM $ T.pack $ (("invDivisionInReverseDegree: ") ++ (show invDivisionInReverseDegree)) + @@ -268,9 +281,7 @@ calculateGandTDeposit baseAssetBalance baseAssetWeight quoteAssetBalance quoteAs yPartLength = toInteger $ RIO.length . show $ quoteAssetBalance xValueLength = toInteger $ RIO.length . show $ (xValueFloat + xToDeposit) - maxPrecisionByToken = (if (yPartLength > xValueLength) then yPartLength else xValueLength) - - maxPrecision = (if (yPartLength > xValueLength) then yPartLength else xValueLength) + 5 + maxPrecision = (if (yPartLength > xValueLength) then yPartLength else xValueLength) xValueFloat = (fromIntegral baseAssetBalance) :: BigDecimal invariantFloat = fromIntegral prevInvariant :: BigDecimal @@ -302,15 +313,16 @@ calculateGandTDeposit baseAssetBalance baseAssetWeight quoteAssetBalance quoteAs pure (gX, tX, gY, tY, getDecimalNum xToDeposit, getDecimalNum yToDeposit, getDecimalNum lqIssuedDec) calculateGandTRedeem :: MonadGen m => Integer -> Integer -> Integer -> Integer -> Integer -> Integer -> Integer -> Integer -> Integer -> m (Integer, Integer, Integer, Integer, Integer, Integer) -calculateGandTRedeem baseAssetBalance baseAssetWeight quoteAssetBalance quoteAssetWeghit lqRedeemI lqSupply lpFee treasuryFee prevInvariant = do +calculateGandTRedeem baseAssetBalance baseAssetWeight quoteAssetBalance quoteAssetWeghit lqRedeem lqSupply lpFee treasuryFee prevInvariant = do let - lqLength = toInteger $ RIO.length . show $ lqSupply - yPartLength = toInteger $ RIO.length . show $ quoteAssetBalance - xValueLength = toInteger $ RIO.length . show $ baseAssetBalance + lqRedeemDec = (fromIntegral lqRedeem) :: BigDecimal + xToRedeem = roundBD ((lqRedeemDec * xValueFloat) / lqSupplyDouble) (DOWN, (Just . toInteger $ 0)) + yToRedeem = roundBD ((lqRedeemDec * yValueFloat) / lqSupplyDouble) (DOWN, (Just . toInteger $ 0)) - maxPrecisionByToken = (if (yPartLength > xValueLength) then yPartLength else xValueLength) + yPartLength = toInteger $ RIO.length . show $ quoteAssetBalance + xValueLength = toInteger $ RIO.length . show $ (xValueFloat - xToRedeem) - maxPrecision = (if (yPartLength > xValueLength) then yPartLength else xValueLength) + 10 + maxPrecision = (if (yPartLength > xValueLength) then yPartLength else xValueLength) xValueFloat = (fromIntegral baseAssetBalance) :: BigDecimal invariantFloat = fromIntegral prevInvariant :: BigDecimal @@ -320,12 +332,9 @@ calculateGandTRedeem baseAssetBalance baseAssetWeight quoteAssetBalance quoteAss treasuryFeeNum = (fromIntegral treasuryFee) :: BigDecimal lpFeeNum = (fromIntegral lpFee) :: BigDecimal lqSupplyDouble = (fromIntegral lqSupply) :: BigDecimal - lqRedeemDouble = (fromIntegral lqRedeemI) :: BigDecimal - - xToRedeem = roundBD ((lqRedeemDouble * xValueFloat) / lqSupplyDouble) (UP, (Just . toInteger $ 0)) - yToRedeem = roundBD ((lqRedeemDouble * yValueFloat) / lqSupplyDouble) (UP, (Just . toInteger $ 0)) - + -- no decimals after point xInInvariantBigDecimal = xValueFloat - xToRedeem + -- xInInvariantBigDecimal in degree `(xWieght / 10)` xInInvariantWithDegree = (xInInvariantBigDecimal ** (fromRational $ ((fromIntegral baseAssetWeight) / 10))) -- g xInInvariantWith1Degree = (xInInvariantBigDecimal) ** (fromRational $ (1 / 10)) -- t @@ -338,7 +347,7 @@ calculateGandTRedeem baseAssetBalance baseAssetWeight quoteAssetBalance quoteAss tGDoubleTest = nthRoot gBaseRounded 10 (DOWN, (Just . toInteger $ maxPrecision)) tGDouble = nthRoot gBaseRounded 10 (DOWN, (Just . toInteger $ maxPrecision)) - + gY = takeNBigDecimal gYDouble (maxPrecision) tY = takeNBigDecimal tGDouble (maxPrecision) @@ -364,9 +373,9 @@ correctSwap = (yCS, yTN) = unAssetClass (poolY config) xValue = valueOf value xCS xTN yValue = valueOf value yCS yTN - - xToSwap <- integral (Range.constant 10000 10000000) - + -- let xToSwap = 285041264117 + xToSwap <- integral (Range.constant 100 xValue) + traceM $ T.pack $ (("xToSwap: ") ++ (show xToSwap)) (gX, tX, gY, tY, yToSwap) <- calculateGandTSwap xValue (weightX config) yValue (weightY config) (xToSwap) (poolFeeNum config) (treasuryFee config) (invariant config) let -- going to withdraw all pool x and y value @@ -585,9 +594,9 @@ correctRedeem = yValue = valueOf value yCS yTN lqValue = valueOf value lqCS lqTN lqIssued = 0x7fffffffffffffff - lqValue - + -- let lqToRedeem = 85989149586251 lqToRedeem <- integral (Range.constant 1 ((lqIssued `div` 2) - 1)) - + traceM $ T.pack $ (("lqToRedeem: ") ++ (show lqToRedeem)) (gX, tX, gY, tY, xToRedeem, yToRedeem) <- calculateGandTRedeem xValue (weightX config) yValue (weightY config) (lqToRedeem) lqIssued (poolFeeNum config) (treasuryFee config) (invariant config) let diff --git a/plutarch-validators/test/Tests/BalancePool.hs b/plutarch-validators/test/Tests/BalancePool.hs index 922d8ee..ac5185b 100644 --- a/plutarch-validators/test/Tests/BalancePool.hs +++ b/plutarch-validators/test/Tests/BalancePool.hs @@ -1,118 +1,656 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE ScopedTypeVariables #-} -module Tests.BalancePool where +module Gen.BalancePoolGen where -import qualified WhalePoolsDex.PContracts.PBalancePool as PPool -import qualified WhalePoolsDex.Contracts.BalancePool as Pool -import WhalePoolsDex.Contracts.Proxy.FeeSwitch -import WhalePoolsDex.PValidators -import WhalePoolsDex.PConstants -import Data.Either +import Test.Tasty -import Eval -import Hedgehog +import Plutarch.Prelude +import Plutarch +import Plutarch.Api.V2.Contexts (PScriptContext) +import Plutarch.Prelude import Numeric +import Data.BigDecimal +import Data.BigFloating +import Data.Ratio + +import RIO hiding (Data(..)) +import Hedgehog +import Hedgehog.Internal.Property +import Hedgehog.Gen as Gen +import Hedgehog.Range as Range import HaskellWorks.Hedgehog.Gen hiding (MonadGen) -import Gen.Utils hiding (Pool(..), TestAction(..), constructCase) -import PlutusLedgerApi.V2 -import Plutarch.Api.V2 as PV2 -import WhalePoolsDex.PConstants +import Data.Text as T + +import WhalePoolsDex.PContracts.PFeeSwitch + +import qualified PlutusLedgerApi.V1.Interval as Interval +import PlutusLedgerApi.V1.Value hiding (getValue) +import qualified PlutusLedgerApi.V1.Value as Value hiding (getValue) +import qualified Data.ByteString.Base16 as Hex +import qualified Data.Text.Encoding as E +import qualified Data.List as List +import qualified Data.ByteString as BS +import PlutusLedgerApi.V2 hiding (getValue) +import PlutusLedgerApi.V1.Address +import Plutarch.Api.V2 (scriptHash) +import PlutusLedgerApi.V1.Credential +import PlutusTx.Builtins.Internal import WhalePoolsDex.PMintingValidators +import qualified PlutusLedgerApi.V1 as Plutus +import Gen.Models (mkAdaValue, mkValues, mkValue, genAssetClass, genPkh, genCSRandom, genSCRandom, genTxId, genTxOutRef, genValidatorHash, mkContext) +import Gen.DepositGen (unsafeFromEither, mkByteString) +import Gen.Utils hiding (Pool(..), TestAction(..), TestGroup(..)) -import Test.Tasty -import Test.Tasty.HUnit -import Test.Tasty.Hedgehog as HH - -import Gen.Models -import Gen.DepositGen -import Gen.BalancePoolGen -import Gen.SwapGen -import Gen.RedeemGen -import Gen.DestroyGen -import Hedgehog.Range as Range -import Debug.Trace -import Data.Text as T (pack, unpack, splitOn) - -balancePool = testGroup "BalancePool" - ((genTests `map` [redeemAllTests])) - -genTests BalancePoolTestGroup{..} = - let - failedCases = (constructCase Failed) `map` invalidActions - successCases = constructCase Success validAction - - --incorrectThreshold = treasholdCase contractAction $ constructIncorrectSignatureThresholdCase validAction - in testGroup name ((testCases contractAction ([successCases] ++ failedCases))) -- ++ [incorrectThreshold]) - -testCases action cases = - (\(name, propertyName, poolUpdater, testResult) -> - HH.testPropertyNamed name propertyName (actionWithValidSignersQty 2 poolUpdater action testResult) - ) `map` cases - -treasholdCase action (name, propertyName, poolUpdater, testResult) = - HH.testPropertyNamed name propertyName (actionWithValidSignersQty 1 poolUpdater action testResult) - --- Test groups -- - -swapTests = BalancePoolTestGroup - { name = "Swap tests" - , contractAction = Pool.Swap - , validAction = correctSwap - , invalidActions = - [ incorrectSwapGT - , incorrectSwapPoolFinalXValue - , incorrectSwapPoolFinalYValue - , incorrectSwapTrFeeValue - ] - } +import WhalePoolsDex.Contracts.BalancePool -depositAllTests = BalancePoolTestGroup - { name = "Deposit tests" - , contractAction = Pool.Deposit - , validAction = correctDeposit - , invalidActions = [incorrectDepositLqOut] +data BalancePoolActionResult = BalancePoolActionResult + { newPool :: BalancePool + , additionalOutputs :: [TxOut] + , g :: [Integer] + , t :: [Integer] + } deriving Show + +data BalancePoolTestAction m = BalancePoolTestAction + { name :: String + , action :: (BalancePool -> m BalancePoolActionResult) } -redeemAllTests = BalancePoolTestGroup - { name = "Redeem tests" - , contractAction = Pool.Redeem - , validAction = correctRedeem - , invalidActions = [incorrectRedeemLQFinalValue] +data BalancePoolTestGroup action = BalancePoolTestGroup + { name :: String + , contractAction :: action + , validAction :: BalancePoolTestAction Gen + , invalidActions :: [BalancePoolTestAction Gen] } ------------------ +constructCase testResult BalancePoolTestAction{..} = + let + testName :: TestName = + case testResult of + Success -> "Correct " ++ name ++ " change" + Failed -> "Attempt to " ++ name ++ " failed" + propertyName = PropertyName name + in (testName, propertyName, action, testResult) + +instance ToTxInfo BalancePool where + toTxInInfo pool = do + ref <- genTxOutRef + let txOut = toTxOut pool + pure $ TxInInfo + { txInInfoOutRef = ref + , txInInfoResolved = txOut + } + +feeDen = 100000 +precisionAdditionalDec = 10 + +daoMintingPurpose :: BalancePool -> ScriptPurpose +daoMintingPurpose BalancePool{..} = Rewarding $ List.head (daoPolicy config) + +daoValidator :: BalancePool -> [PubKeyHash] -> Integer -> Bool -> ClosedTerm (PData :--> PScriptContext :--> POpaque) +daoValidator BalancePool{..} admins threshold lpFeeIsEditable = + wrapMintingValidator (daoMultisigPolicyValidatorT (pconstant (poolNft config)) (pconstant admins) (pconstant threshold) (pconstant lpFeeIsEditable)) + +createTxInfo :: MonadGen m => BalancePool -> BalancePoolActionResult -> [PubKeyHash] -> m TxInfo +createTxInfo prevPool@BalancePool{..} BalancePoolActionResult{..} adminPkhs = do + poolTxIn <- toTxInInfo prevPool + let + daoCS = List.head (daoPolicy config) + + pure $ TxInfo + { txInfoInputs = [poolTxIn] + , txInfoReferenceInputs = [] + , txInfoOutputs = [toTxOut newPool] ++ additionalOutputs + , txInfoFee = mempty + , txInfoMint = mempty + , txInfoDCert = mempty + , txInfoWdrl = fromList [(daoCS, 0)] + , txInfoValidRange = Interval.always + , txInfoSignatories = adminPkhs + , txInfoRedeemers = fromList [] + , txInfoData = fromList [] + , txInfoId = "b0" + } + + +takeNBigDecimal :: BigDecimal -> Integer -> Integer +takeNBigDecimal toCut n = + let + inString = T.unpack (T.take (fromInteger n) (T.pack . show $ (Data.BigDecimal.getValue toCut))) + in (read inString) :: Integer + +getDecimalNum :: BigDecimal -> Integer +getDecimalNum toCut = + let + currentScale = getScale toCut + inString = T.unpack (T.dropEnd (fromInteger currentScale) (T.pack . show $ (Data.BigDecimal.getValue toCut))) + in (read inString) :: Integer + +genBalancePool :: MonadGen f => [PubKeyHash] -> Integer -> Bool -> f BalancePool +genBalancePool adminsPkhs threshold lpFeeIsEditable = do + (x, y, lq, nft) <- tuple4 genAssetClass + + stakeHash <- genPkh + + -- todo: error on big values such as 10000000000000000 + -- (yQty :: Int) <- integral (Range.constant 10000000000 10000000000000000) + + (xWeight :: Integer) <- integral (Range.constant 1 5) + (xQty :: Integer) <- integral (Range.constant 1000000000 1000000000000) + poolFee <- integral (Range.constant 80000 feeDen) + trFee <- integral (Range.constant 1 1000) + -- let trFee = 683 + -- let poolFee = 86472 + -- let xWeight = 5 + -- let yWeight = 5 + -- let xQty = 303457031315 + + treasuryAddress <- genValidatorHash + let + yWeight = 10 - xWeight + + yQty = xQty * yWeight + nftQty = 1 + + xQtyFloat = (fromIntegral xQty) :: Double + yQtyFloat = (fromIntegral yQty) :: Double + + yPartLength = toInteger $ RIO.length . show $ xQty + xValueLength = toInteger $ RIO.length . show $ yQty + + maxPrecision = (if (yPartLength > xValueLength) then yPartLength else xValueLength) + precisionAdditionalDec + + -- invariant = (xQtyFloat**(xWeightFloat / 10)) * (yQtyFloat**(yWeightFloat / 10)) + invariantT = ((BigDecimal xQty 0) ** (fromRational $ (fromIntegral xWeight) / 10)) * ( (BigDecimal yQty 0) ** (fromRational $ (fromIntegral yWeight) / 10)) + invariant = getDecimalNum invariantT + + lqQty = 0x7fffffffffffffff - invariant + + daoContract = + StakingHash . ScriptCredential . ValidatorHash . getScriptHash . scriptHash $ (unMintingPolicyScript (daoMintPolicyValidator nft adminsPkhs threshold lpFeeIsEditable)) + + leftSide = (BigDecimal invariant 0) / ((BigDecimal xQty 0) ** (fromRational $ (fromIntegral xWeight) / 10)) + + let + poolConfig = BalancePoolConfig + { poolNft = nft + , poolX = x + , weightX = xWeight + , poolY = y + , weightY = yWeight + , poolLq = lq + , poolFeeNum = poolFee + , treasuryFee = trFee + , treasuryX = 0 + , treasuryY = 0 + , daoPolicy = [daoContract] + , treasuryAddress = treasuryAddress + , invariant = invariant + } + + poolValue = mkValues ((\(ac, qty) -> mkValue ac (fromIntegral qty)) `RIO.map` [(x, xQty), (y, yQty), (nft, nftQty), (lq, lqQty)]) mempty + traceM $ T.pack $ (("x: ") ++ (show xQty)) + traceM $ T.pack $ (("y: ") ++ (show yQty)) + traceM $ T.pack $ (("xWeight: ") ++ (show xWeight)) + traceM $ T.pack $ (("yWeight: ") ++ (show yWeight)) + traceM $ T.pack $ (("poolFee: ") ++ (show poolFee)) + traceM $ T.pack $ (("trFee: ") ++ (show trFee)) + pure $ BalancePool poolConfig stakeHash poolValue + +--- Test utils --- + +-- BaseAssetBalance -> BaseAssetWeight -> QuoteAssetBalance -> QuoteAssetWeghit -> BaseIn -> lpFee -> treasuryFee -> (gBase, tBase, gQuote, tQuote, quoteOut) +calculateGandTSwap :: MonadGen m => Integer -> Integer -> Integer -> Integer -> Integer -> Integer -> Integer -> Integer -> m (Integer, Integer, Integer, Integer, Integer) +calculateGandTSwap baseAssetBalance baseAssetWeight quoteAssetBalance quoteAssetWeghit baseIn lpFee treasuryFee prevInvariant = do + let + yPartLength = toInteger $ RIO.length . show $ quoteAssetBalance + xValueLength = toInteger $ RIO.length . show $ (baseAssetBalance + baseIn) + + maxPrecision = (if (yPartLength > xValueLength) then yPartLength else xValueLength) + precisionAdditionalDec + + invariantLength = toInteger $ RIO.length . show $ prevInvariant + + xValueFloat = (fromIntegral baseAssetBalance) :: BigDecimal + invariantFloat = (BigDecimal prevInvariant 0) :: BigDecimal + xWeightFloat = (fromIntegral baseAssetWeight) :: BigDecimal + yValueFloat = (fromIntegral quoteAssetBalance) :: BigDecimal + yWeightFloat = (fromIntegral quoteAssetWeghit) :: BigDecimal + treasuryFeeNum = (fromIntegral treasuryFee) :: Double + lpFeeNum = (fromIntegral lpFee) :: Double + + additionalPart = (BigDecimal (fromIntegral baseIn) 0) * (fromRational $ (fromIntegral (lpFee - treasuryFee)) / fromIntegral feeDen) -- xInInvariant = fromIntegral $ baseAssetBalance + round ((fromIntegral baseIn) * ((lpFeeNum - treasuryFeeNum) / fromIntegral feeDen)) + -- no decimals after point + xInInvariantBigDecimal = xValueFloat + additionalPart + -- xInInvariantBigDecimal in degree `(xWieght / 10)` + xInInvariantWithDegree = (xInInvariantBigDecimal ** (fromRational $ ((fromIntegral baseAssetWeight) / 10))) -- g + xInInvariantWith1Degree = (xInInvariantBigDecimal) ** (fromRational $ (1 / 10)) -- t + + gX = ((takeNBigDecimal xInInvariantWithDegree (maxPrecision)) :: Integer) + tX = ((takeNBigDecimal xInInvariantWith1Degree (maxPrecision)) :: Integer) + + -- test + invDivision = invariantFloat / xInInvariantWithDegree + invDivisionInReverseDegree = nthRoot (invDivision ** 10) (fromInteger quoteAssetWeghit) (DOWN, (Just . toInteger $ 0)) + -- denum = 10 ^ (yPartLength - xValueLength) + + invDivisionInReverseDegreeBigDecimalRounded = takeNBigDecimal invDivisionInReverseDegree (yPartLength) + + yToSwap = quoteAssetBalance - invDivisionInReverseDegreeBigDecimalRounded + + gYDouble = ((BigDecimal (quoteAssetBalance - yToSwap) 0) ** (fromRational $ (fromIntegral quoteAssetWeghit) / 10)) :: BigDecimal -- g + tGDouble = (((BigDecimal (quoteAssetBalance - yToSwap) 0) ** (fromRational $ (1 / 10)))) :: BigDecimal -- g + + gY = takeNBigDecimal gYDouble (maxPrecision) -- ((getValue gYDouble)) + tY = takeNBigDecimal tGDouble (maxPrecision) -- ((getValue tGDouble)) + traceM $ T.pack $ (("baseAssetWeight: ") ++ (show baseAssetWeight)) + traceM $ T.pack $ (("maxPrecision: ") ++ (show maxPrecision)) + traceM $ T.pack $ (("gX: ") ++ (show gX)) + traceM $ T.pack $ (("tX: ") ++ (show tX)) + traceM $ T.pack $ (("gY: ") ++ (show gY)) + traceM $ T.pack $ (("tY: ") ++ (show tY)) + traceM $ T.pack $ (("yToSwap: ") ++ (show yToSwap)) + traceM $ T.pack $ (("xInInvariantWithDegree: ") ++ (show xInInvariantWithDegree)) + traceM $ T.pack $ (("invDivisionInReverseDegree: ") ++ (show invDivisionInReverseDegree)) + + + + + -------- Max test --------- + + + let + spotPriceWithoutFee = (((BigDecimal baseAssetBalance 0)) / ((BigDecimal baseAssetWeight 0))) / (((BigDecimal quoteAssetBalance 0)) / ((BigDecimal quoteAssetWeghit 0))) :: BigDecimal + spotPriceWithFee = spotPriceWithoutFee * (fromRational $ (fromIntegral (lpFee - treasuryFee) / fromIntegral (feeDen))) + + pure (gX, tX, gY, tY, yToSwap) + +-- BaseAssetBalance -> BaseAssetWeight -> QuoteAssetBalance -> QuoteAssetWeghit -> BaseIn -> lqSupply -> lpFee -> treasuryFee -> (gBase, tBase, gQuote, tQuote, quoteToDeposit, lqOut) +calculateGandTDeposit :: MonadGen m => Integer -> Integer -> Integer -> Integer -> Integer -> Integer -> Integer -> Integer -> Integer -> m (Integer, Integer, Integer, Integer, Integer, Integer, Integer) +calculateGandTDeposit baseAssetBalance baseAssetWeight quoteAssetBalance quoteAssetWeghit lqIssued lqSupply lpFee treasuryFee prevInvariant = do + let + lqIssuedDec = (fromIntegral lqIssued) :: BigDecimal + xToDeposit = roundBD ((lqIssuedDec * xValueFloat) / lqSupplyDouble) (UP, (Just . toInteger $ 0)) + yToDeposit = roundBD ((lqIssuedDec * yValueFloat) / lqSupplyDouble) (UP, (Just . toInteger $ 0)) + + -- yToDeposit = (((lqSupplyDouble + lqIssued) / lqSupplyDouble) - 1) * yValueFloat + yPartLength = toInteger $ RIO.length . show $ quoteAssetBalance + xValueLength = toInteger $ RIO.length . show $ (xValueFloat + xToDeposit) + + maxPrecision = (if (yPartLength > xValueLength) then yPartLength else xValueLength) + + xValueFloat = (fromIntegral baseAssetBalance) :: BigDecimal + invariantFloat = fromIntegral prevInvariant :: BigDecimal + xWeightFloat = (fromIntegral baseAssetWeight) :: BigDecimal + yValueFloat = (fromIntegral quoteAssetBalance) :: BigDecimal + yWeightFloat = (fromIntegral quoteAssetWeghit) :: BigDecimal + treasuryFeeNum = (fromIntegral treasuryFee) :: BigDecimal + lpFeeNum = (fromIntegral lpFee) :: BigDecimal + lqSupplyDouble = (fromIntegral lqSupply) :: BigDecimal + -- no decimals after point + xInInvariantBigDecimal = xValueFloat + xToDeposit + -- xInInvariantBigDecimal in degree `(xWieght / 10)` + xInInvariantWithDegree = (xInInvariantBigDecimal ** (fromRational $ ((fromIntegral baseAssetWeight) / 10))) -- g + xInInvariantWith1Degree = (xInInvariantBigDecimal) ** (fromRational $ (1 / 10)) -- t + + gX = ((takeNBigDecimal xInInvariantWithDegree (maxPrecision)) :: Integer) + tX = ((takeNBigDecimal xInInvariantWith1Degree (maxPrecision)) :: Integer) + + gBase = yValueFloat + yToDeposit + gBaseRounded = BigDecimal (getDecimalNum (yValueFloat + yToDeposit)) 0 + gYDouble = nthRoot (gBaseRounded ** yWeightFloat) 10 (UP, (Just . toInteger $ maxPrecision)) :: BigDecimal -- g + + tGDoubleTest = nthRoot gBaseRounded 10 (DOWN, (Just . toInteger $ maxPrecision)) + tGDouble = nthRoot gBaseRounded 10 (DOWN, (Just . toInteger $ maxPrecision)) + + gY = takeNBigDecimal gYDouble (maxPrecision) + tY = takeNBigDecimal tGDouble (maxPrecision) + + pure (gX, tX, gY, tY, getDecimalNum xToDeposit, getDecimalNum yToDeposit, getDecimalNum lqIssuedDec) + +calculateGandTRedeem :: MonadGen m => Integer -> Integer -> Integer -> Integer -> Integer -> Integer -> Integer -> Integer -> Integer -> m (Integer, Integer, Integer, Integer, Integer, Integer) +calculateGandTRedeem baseAssetBalance baseAssetWeight quoteAssetBalance quoteAssetWeghit lqRedeem lqSupply lpFee treasuryFee prevInvariant = do + let + lqRedeemDec = (fromIntegral lqRedeem) :: BigDecimal + xToRedeem = roundBD ((lqRedeemDec * xValueFloat) / lqSupplyDouble) (DOWN, (Just . toInteger $ 0)) + yToRedeem = roundBD ((lqRedeemDec * yValueFloat) / lqSupplyDouble) (DOWN, (Just . toInteger $ 0)) + + yPartLength = toInteger $ RIO.length . show $ quoteAssetBalance + xValueLength = toInteger $ RIO.length . show $ (xValueFloat - xToRedeem) + + maxPrecision = (if (yPartLength > xValueLength) then yPartLength else xValueLength) -cutFloatD :: Double -> Int -> Integer -cutFloatD toCut maxInt = let + xValueFloat = (fromIntegral baseAssetBalance) :: BigDecimal + invariantFloat = fromIntegral prevInvariant :: BigDecimal + xWeightFloat = (fromIntegral baseAssetWeight) :: BigDecimal + yValueFloat = (fromIntegral quoteAssetBalance) :: BigDecimal + yWeightFloat = (fromIntegral quoteAssetWeghit) :: BigDecimal + treasuryFeeNum = (fromIntegral treasuryFee) :: BigDecimal + lpFeeNum = (fromIntegral lpFee) :: BigDecimal + lqSupplyDouble = (fromIntegral lqSupply) :: BigDecimal + -- no decimals after point + xInInvariantBigDecimal = xValueFloat - xToRedeem + -- xInInvariantBigDecimal in degree `(xWieght / 10)` + xInInvariantWithDegree = (xInInvariantBigDecimal ** (fromRational $ ((fromIntegral baseAssetWeight) / 10))) -- g + xInInvariantWith1Degree = (xInInvariantBigDecimal) ** (fromRational $ (1 / 10)) -- t + + gX = ((takeNBigDecimal xInInvariantWithDegree (maxPrecision)) :: Integer) + tX = ((takeNBigDecimal xInInvariantWith1Degree (maxPrecision)) :: Integer) + + gBase = yValueFloat - yToRedeem + gBaseRounded = BigDecimal (getDecimalNum (yValueFloat - yToRedeem)) 0 + gYDouble = nthRoot (gBaseRounded ** yWeightFloat) 10 (UP, (Just . toInteger $ maxPrecision)) :: BigDecimal -- g + + tGDoubleTest = nthRoot gBaseRounded 10 (DOWN, (Just . toInteger $ maxPrecision)) + tGDouble = nthRoot gBaseRounded 10 (DOWN, (Just . toInteger $ maxPrecision)) + + gY = takeNBigDecimal gYDouble (maxPrecision) + tY = takeNBigDecimal tGDouble (maxPrecision) + + pure (gX, tX, gY, tY, getDecimalNum xToRedeem, getDecimalNum yToRedeem) + +--- Test cases --- + +cutFloat :: Double -> Int -> Integer +cutFloat toCut maxInt = let strValue = T.pack $ showFFloat (Just maxInt) toCut "" - splitted = T.splitOn "." strValue + splitted = splitOn "." strValue in read $ T.unpack . Prelude.head $ splitted -actionWithValidSignersQty :: Int -> (BalancePool -> Gen BalancePoolActionResult) -> Pool.BalancePoolAction -> TestResult -> Property -actionWithValidSignersQty sigsQty poolUpdater action testResultShouldBe = withTests 10 $ property $ do +-- Swap cases start -- + +correctSwap :: MonadGen m => BalancePoolTestAction m +correctSwap = let - threshold = 2 + testAction prevPool@BalancePool{..} = do + + let + (xCS, xTN) = unAssetClass (poolX config) + (yCS, yTN) = unAssetClass (poolY config) + xValue = valueOf value xCS xTN + yValue = valueOf value yCS yTN + -- let xToSwap = 285041264117 + xToSwap <- integral (Range.constant 100 xValue) + traceM $ T.pack $ (("xToSwap: ") ++ (show xToSwap)) + (gX, tX, gY, tY, yToSwap) <- calculateGandTSwap xValue (weightX config) yValue (weightY config) (xToSwap) (poolFeeNum config) (treasuryFee config) (invariant config) + let + -- going to withdraw all pool x and y value + tFee = treasuryFee config + + newPoolConfig = config + { treasuryX = (tFee * xToSwap) `div` feeDen + , treasuryY = 0 + } + + newPool = prevPool + { config = newPoolConfig + , value = value <> (assetClassValue (poolX config) (xToSwap)) <> (assetClassValue (poolY config) (negate yToSwap)) + } - (pkh1, pkh2, pkh3) <- forAll $ tuple3 genPkh - prevPool <- forAll $ genBalancePool [pkh1, pkh2, pkh3] threshold True - updateResult <- forAll $ poolUpdater prevPool - txInInfo <- forAll $ createTxInfo prevPool updateResult (take sigsQty [pkh1, pkh2, pkh3]) + pure $ BalancePoolActionResult newPool [] [gX, gY] [tX, tY] + in BalancePoolTestAction "Correct swap" testAction + +incorrectSwapGT :: MonadGen m => BalancePoolTestAction m +incorrectSwapGT = let - purpose = mkPurpose (txInInfoOutRef . head . txInfoInputs $ txInInfo) + testAction prevPool@BalancePool{..} = do + + let + (xCS, xTN) = unAssetClass (poolX config) + (yCS, yTN) = unAssetClass (poolY config) + xValue = valueOf value xCS xTN + yValue = valueOf value yCS yTN + + xToSwap <- integral (Range.constant 1 ((xValue `div` 2) - 1)) + (gX, tX, gY, tY, yToSwap) <- calculateGandTSwap xValue (weightX config) yValue (weightY config) (xToSwap + 1000) (poolFeeNum config) (treasuryFee config) (invariant config) + let + newPool = prevPool + { value = value <> (assetClassValue (poolX config) (xToSwap)) <> (assetClassValue (poolY config) (negate yToSwap)) + } + + pure $ BalancePoolActionResult newPool [] [gX, gY] [tX, tY] + in BalancePoolTestAction "Incorrect swap GT" testAction + +incorrectSwapPoolFinalXValue :: MonadGen m => BalancePoolTestAction m +incorrectSwapPoolFinalXValue = let - datum = toData $ (config prevPool) + testAction prevPool@BalancePool{..} = do + let + (xCS, xTN) = unAssetClass (poolX config) + (yCS, yTN) = unAssetClass (poolY config) + xValue = valueOf value xCS xTN + yValue = valueOf value yCS yTN + tFee = treasuryFee config + + xToSwap <- integral (Range.constant 1 ((xValue `div` 2) - 1)) + incorrectXSwapValue <- integral (Range.constant 1 ((xValue `div` 2) - 1)) + (gX, tX, gY, tY, yToSwap) <- calculateGandTSwap xValue (weightX config) yValue (weightY config) (xToSwap) (poolFeeNum config) (treasuryFee config) (invariant config) + let + tFee = treasuryFee config + + newPoolConfig = config + { treasuryX = (tFee * xToSwap) `div` feeDen + , treasuryY = 0 + } + + newPool = prevPool + { value = value <> (assetClassValue (poolX config) (incorrectXSwapValue)) <> (assetClassValue (poolY config) (negate yToSwap)) + } + + pure $ BalancePoolActionResult newPool [] [gX, gY] [tX, tY] + in BalancePoolTestAction "Incorrect pool x final value" testAction + +incorrectSwapPoolFinalYValue :: MonadGen m => BalancePoolTestAction m +incorrectSwapPoolFinalYValue = let - context = toData $ mkContext txInInfo purpose - redeemer = toData $ Pool.BalancePoolRedeemer action 0 (g updateResult) (t updateResult) + testAction prevPool@BalancePool{..} = do - correctResult = - case testResultShouldBe of - Success -> Right() - Failed -> Left() - - result = eraseBoth $ evalWithArgs (wrapValidator PPool.balancePoolValidatorT) [datum, redeemer, context] + let + (xCS, xTN) = unAssetClass (poolX config) + (yCS, yTN) = unAssetClass (poolY config) + xValue = valueOf value xCS xTN + yValue = valueOf value yCS yTN + + xToSwap <- integral (Range.constant 1 ((xValue `div` 2) - 1)) + incorrectYFinalValue <- integral (Range.constant 1 (yValue - 1)) + (gX, tX, gY, tY, yToSwap) <- calculateGandTSwap xValue (weightX config) yValue (weightY config) (xToSwap) (poolFeeNum config) (treasuryFee config) (invariant config) + + let + -- going to withdraw all pool x and y value + tFee = treasuryFee config + + newPoolConfig = config + { treasuryX = (tFee * xToSwap) `div` feeDen + , treasuryY = 0 + } + + newPool = prevPool + { value = value <> (assetClassValue (poolX config) (xToSwap)) <> (assetClassValue (poolY config) (negate incorrectYFinalValue)) + } + + pure $ BalancePoolActionResult newPool [] [gX, gY] [tX, tY] + in BalancePoolTestAction "Incorrect pool y final value" testAction + +incorrectSwapTrFeeValue :: MonadGen m => BalancePoolTestAction m +incorrectSwapTrFeeValue = + let + testAction prevPool@BalancePool{..} = do + + let + (xCS, xTN) = unAssetClass (poolX config) + (yCS, yTN) = unAssetClass (poolY config) + xValue = valueOf value xCS xTN + yValue = valueOf value yCS yTN + + xToSwap <- integral (Range.constant 1 ((xValue `div` 2) - 1)) + (gX, tX, gY, tY, yToSwap) <- calculateGandTSwap xValue (weightX config) yValue (weightY config) (xToSwap) (poolFeeNum config) (treasuryFee config) (invariant config) + let + treasuryFee_ = treasuryFee config + newPoolConfig = config + { treasuryX = (treasuryFee_ * (xToSwap)) `div` feeDen - 1 + } + newPool = prevPool + { config = newPoolConfig + , value = value <> (assetClassValue (poolX config) (xToSwap)) <> (assetClassValue (poolY config) (negate yToSwap)) + } + + pure $ BalancePoolActionResult newPool [] [gX, gY] [tX, tY] + in BalancePoolTestAction "Incorrect pool treasury X final value" testAction + +-- Swap cases end -- + +-- Deposit all cases start -- + +correctDeposit :: MonadGen m => BalancePoolTestAction m +correctDeposit = + let + testAction prevPool@BalancePool{..} = do + + let + (xCS, xTN) = unAssetClass (poolX config) + (yCS, yTN) = unAssetClass (poolY config) + (lqCS, lqTN) = unAssetClass (poolLq config) + xValue = valueOf value xCS xTN + yValue = valueOf value yCS yTN + lqValue = valueOf value lqCS lqTN + lqSupply = 0x7fffffffffffffff - lqValue + + lqIssued <- integral (Range.constant 1 ((lqValue `div` 2) - 1)) + + (gX, tX, gY, tY, xToDeposit, yToDeposit, lqIssued) <- calculateGandTDeposit xValue (weightX config) yValue (weightY config) (lqIssued) lqSupply (poolFeeNum config) (treasuryFee config) (invariant config) + + let + -- lqIssued = 0x7fffffffffffffff - (round lqValue) + + newInvariant = gX * gY + + -- going to withdraw all pool x and y value + newPoolConfig = config + { invariant = newInvariant + } + + newPool = prevPool + { config = newPoolConfig + , value = value <> (assetClassValue (poolX config) (xToDeposit)) <> (assetClassValue (poolY config) (yToDeposit)) <> (assetClassValue (poolLq config) (negate lqIssued)) + } + + pure $ BalancePoolActionResult newPool [] [gX, gY] [tX, tY] + in BalancePoolTestAction "Correct deposit all tokens" testAction + +incorrectDepositLqOut :: MonadGen m => BalancePoolTestAction m +incorrectDepositLqOut = + let + testAction prevPool@BalancePool{..} = do + + let + (xCS, xTN) = unAssetClass (poolX config) + (yCS, yTN) = unAssetClass (poolY config) + (lqCS, lqTN) = unAssetClass (poolLq config) + xValue = valueOf value xCS xTN + yValue = valueOf value yCS yTN + lqValue = valueOf value lqCS lqTN + lqSupply = 0x7fffffffffffffff - lqValue + + lqIssued <- integral (Range.constant 1 ((lqValue `div` 2) - 1)) + + (gX, tX, gY, tY, xToDeposit, yToDeposit, lqIssued) <- calculateGandTDeposit xValue (weightX config) yValue (weightY config) (lqIssued) lqSupply (poolFeeNum config) (treasuryFee config) (invariant config) + + let + -- lqIssued = 0x7fffffffffffffff - (round lqValue) + + newInvariant = gX * gY + + -- going to withdraw all pool x and y value + newPoolConfig = config + { invariant = newInvariant + } + + newPool = prevPool + { config = newPoolConfig + , value = value <> (assetClassValue (poolX config) (xToDeposit)) <> (assetClassValue (poolY config) (yToDeposit)) <> (assetClassValue (poolLq config) (negate (lqIssued + 1000))) + } + + pure $ BalancePoolActionResult newPool [] [gX, gY] [tX, tY] + in BalancePoolTestAction "Incorrect deposit all tokens. Incorrect lq out" testAction + +-- Deposit all cases end -- + +-- Redeem all cases start -- + +correctRedeem :: MonadGen m => BalancePoolTestAction m +correctRedeem = + let + testAction prevPool@BalancePool{..} = do + + let + (xCS, xTN) = unAssetClass (poolX config) + (yCS, yTN) = unAssetClass (poolY config) + (lqCS, lqTN) = unAssetClass (poolLq config) + xValue = valueOf value xCS xTN + yValue = valueOf value yCS yTN + lqValue = valueOf value lqCS lqTN + lqIssued = 0x7fffffffffffffff - lqValue + -- let lqToRedeem = 85989149586251 + lqToRedeem <- integral (Range.constant 1 ((lqIssued `div` 2) - 1)) + traceM $ T.pack $ (("lqToRedeem: ") ++ (show lqToRedeem)) + (gX, tX, gY, tY, xToRedeem, yToRedeem) <- calculateGandTRedeem xValue (weightX config) yValue (weightY config) (lqToRedeem) lqIssued (poolFeeNum config) (treasuryFee config) (invariant config) + + let + -- lqIssued = 0x7fffffffffffffff - (round lqValue) + + newInvariant = gX * gY + + -- going to withdraw all pool x and y value + newPoolConfig = config + { invariant = newInvariant + } + + newPool = prevPool + { config = newPoolConfig + , value = value <> (assetClassValue (poolX config) (negate xToRedeem)) <> (assetClassValue (poolY config) (negate yToRedeem)) <> (assetClassValue (poolLq config) (lqToRedeem)) + } + + pure $ BalancePoolActionResult newPool [] [gX, gY] [tX, tY] + in BalancePoolTestAction "Correct redeem all tokens" testAction + +incorrectRedeemLQFinalValue :: MonadGen m => BalancePoolTestAction m +incorrectRedeemLQFinalValue = + let + testAction prevPool@BalancePool{..} = do + + let + (xCS, xTN) = unAssetClass (poolX config) + (yCS, yTN) = unAssetClass (poolY config) + (lqCS, lqTN) = unAssetClass (poolLq config) + xValue = valueOf value xCS xTN + yValue = valueOf value yCS yTN + lqValue = valueOf value lqCS lqTN + lqIssued = 0x7fffffffffffffff - lqValue + + lqToRedeem <- integral (Range.constant 1000 ((lqIssued `div` 2) - 1)) + + (gX, tX, gY, tY, xToRedeem, yToRedeem) <- calculateGandTRedeem xValue (weightX config) yValue (weightY config) (lqToRedeem) lqIssued (poolFeeNum config) (treasuryFee config) (invariant config) + + let + -- lqIssued = 0x7fffffffffffffff - (round lqValue) + + newInvariant = gX * gY + + -- going to withdraw all pool x and y value + newPoolConfig = config + { invariant = newInvariant + } + + newPool = prevPool + { config = newPoolConfig + , value = value <> (assetClassValue (poolX config) (negate xToRedeem)) <> (assetClassValue (poolY config) (negate yToRedeem)) <> (assetClassValue (poolLq config) (lqToRedeem - 100)) + } + + pure $ BalancePoolActionResult newPool [] [gX, gY] [tX, tY] + in BalancePoolTestAction "InCorrect redeem all tokens. Incorrect final lq value" testAction - result === correctResult \ No newline at end of file +-- Redeem all cases end -- \ No newline at end of file From 99e17c7966b686ac92a0817ec1d9468575f6e05b Mon Sep 17 00:00:00 2001 From: AOranov Date: Thu, 21 Mar 2024 19:37:31 +0300 Subject: [PATCH 2/2] Fixes and looped test example fixed. --- .../WhalePoolsDex/PContracts/PBalancePool.hs | 46 +- .../WhalePoolsDex/PMintingValidators.hs | 2 +- .../WhalePoolsDex/PValidators.hs | 2 +- plutarch-validators/test/Eval.hs | 4 +- .../test/Gen/BalancePoolGen.hs | 33 +- plutarch-validators/test/Tests/BalancePool.hs | 726 +++--------------- 6 files changed, 107 insertions(+), 706 deletions(-) diff --git a/plutarch-validators/WhalePoolsDex/PContracts/PBalancePool.hs b/plutarch-validators/WhalePoolsDex/PContracts/PBalancePool.hs index 08c6cad..566273f 100644 --- a/plutarch-validators/WhalePoolsDex/PContracts/PBalancePool.hs +++ b/plutarch-validators/WhalePoolsDex/PContracts/PBalancePool.hs @@ -186,9 +186,9 @@ verifyGEquality :: :--> PInteger :--> PBool ) -verifyGEquality = plam $ \leftSideMultiplicator rightSideRaw prevTokenBalance tokenG tokenWeight -> unTermCont $ do +verifyGEquality = plam $ \leftSideMultiplicator rightSideRaw prevTokenBalance tokenG tokenWeight -> let - tokenBalanceIntLength = pIntLength # prevTokenBalance + tokenBalanceIntLength = pIntLength # rightSideRaw degree = pdiv # pDen # tokenWeight @@ -201,14 +201,10 @@ verifyGEquality = plam $ \leftSideMultiplicator rightSideRaw prevTokenBalance to gEDiff = leftSide - rightSide validGEquality = pif ( gEDiff #<= 0 ) - ( (-2) #<= gEDiff ) - ( gEDiff #<= (2) ) + ( (-1) #<= gEDiff ) + ( gEDiff #<= (1) ) - ptraceC $ "gEDiff" - ptraceC $ pshow $ gEDiff - ptraceC $ "validGEquality" - ptraceC $ pshow $ validGEquality - pure validGEquality + in validGEquality verifyTExpEquality :: ClosedTerm @@ -350,15 +346,6 @@ validSwap = plam $ \prevState' newState' prevPoolConfig newPoolConfig newGX newT #$ pdcons @"invariant" @PInteger # pdata prevInvariant # pdnil) - - ptraceC $ "prevInvariant" - ptraceC $ pshow $ prevInvariant - ptraceC $ "newInvarianRounded" - ptraceC $ pshow $ newInvarianRounded - ptraceC $ "correctTokensUpdate" - ptraceC $ pshow $ correctTokensUpdate - ptraceC $ "correctTreasuryUpdate" - ptraceC $ pshow $ correctTreasuryUpdate pure $ ( newInvariantIsCorrect #&& correctTokensUpdate @@ -409,22 +396,7 @@ correctLpTokenDelta = plam $ \lpIssued lpDelta tokenDelta tokenBalance tokenWeig ( (pmod # pDen # tokenWeight) #== 0 ) ( verifyGEquality # 1 # (tokenBalance + tokenDelta) # tokenBalance # tokenG # tokenWeight ) ( verifyTExpEquality # tokenT # (tokenBalance + tokenDelta) ) - ptraceC $ "leftPart" - ptraceC $ pshow leftPart - ptraceC $ "rightPart" - ptraceC $ pshow rightPart - ptraceC $ "tokenBalance" - ptraceC $ pshow tokenBalance - ptraceC $ "tokenDelta" - ptraceC $ pshow tokenDelta - ptraceC $ "calcTokenDelta" - ptraceC $ pshow calcTokenDelta - ptraceC $ "correctTokenValue" - ptraceC $ pshow correctTokenValue - ptraceC $ "lpIssued" - ptraceC $ pshow lpIssued - ptraceC $ "lpDelta" - ptraceC $ pshow lpDelta + pure $ correctTokenIn #&& correctTokenValue validDepositRedeemAllTokens :: @@ -491,12 +463,6 @@ validDepositRedeemAllTokens = plam $ \prevState' newState' prevPoolConfig newPoo #$ pdcons @"invariant" @PInteger # pdata newInvariant # pdnil) - ptraceC $ "xDepositRedeemIsValid" - ptraceC $ pshow xDepositRedeemIsValid - ptraceC $ "yDepositRedeemIsValid" - ptraceC $ pshow yDepositRedeemIsValid - ptraceC $ "newPoolConfig #== newExpectedConfig" - ptraceC $ pshow (newPoolConfig #== newExpectedConfig) pure $ ( xDepositRedeemIsValid #&& yDepositRedeemIsValid diff --git a/plutarch-validators/WhalePoolsDex/PMintingValidators.hs b/plutarch-validators/WhalePoolsDex/PMintingValidators.hs index 4824509..277961f 100644 --- a/plutarch-validators/WhalePoolsDex/PMintingValidators.hs +++ b/plutarch-validators/WhalePoolsDex/PMintingValidators.hs @@ -21,7 +21,7 @@ import PlutusLedgerApi.V1.Crypto (PubKeyHash) import PlutusLedgerApi.V1.Contexts cfgForMintingValidator :: Config -cfgForMintingValidator = Config DoTracing +cfgForMintingValidator = Config NoTracing wrapMintingValidator :: PIsData rdmr => diff --git a/plutarch-validators/WhalePoolsDex/PValidators.hs b/plutarch-validators/WhalePoolsDex/PValidators.hs index 2f3253a..2e6d1d8 100644 --- a/plutarch-validators/WhalePoolsDex/PValidators.hs +++ b/plutarch-validators/WhalePoolsDex/PValidators.hs @@ -26,7 +26,7 @@ import Plutarch.Unsafe (punsafeCoerce) import Plutarch.Internal cfgForValidator :: Config -cfgForValidator = Config DoTracing +cfgForValidator = Config NoTracing wrapValidator :: (PIsData dt, PIsData rdmr) => diff --git a/plutarch-validators/test/Eval.hs b/plutarch-validators/test/Eval.hs index 3a5ec55..a044b93 100644 --- a/plutarch-validators/test/Eval.hs +++ b/plutarch-validators/test/Eval.hs @@ -14,14 +14,12 @@ import PlutusTx (Data) import Debug.Trace evalConfig :: Config -evalConfig = Config DoTracing +evalConfig = Config NoTracing evalWithArgs :: ClosedTerm a -> [Data] -> Either Text (ExBudget, [Text], Program DeBruijn DefaultUni DefaultFun ()) evalWithArgs x args = do cmp <- compile evalConfig x - traceM $ "Compiled:" let (escr, budg, trc) = evalScriptHuge $ applyArguments cmp args - traceM $ "Trace:" ++ (show trc) scr <- left (pack . show) escr pure (budg, trc, unScript scr) diff --git a/plutarch-validators/test/Gen/BalancePoolGen.hs b/plutarch-validators/test/Gen/BalancePoolGen.hs index ac5185b..47fedf9 100644 --- a/plutarch-validators/test/Gen/BalancePoolGen.hs +++ b/plutarch-validators/test/Gen/BalancePoolGen.hs @@ -137,8 +137,8 @@ genBalancePool adminsPkhs threshold lpFeeIsEditable = do stakeHash <- genPkh - -- todo: error on big values such as 10000000000000000 - -- (yQty :: Int) <- integral (Range.constant 10000000000 10000000000000000) + -- todo: error on big values such as 10 000 000 000 000 000 + (yQty :: Int) <- integral (Range.constant 10000000000 10000000000000000) (xWeight :: Integer) <- integral (Range.constant 1 5) (xQty :: Integer) <- integral (Range.constant 1000000000 1000000000000) @@ -194,12 +194,6 @@ genBalancePool adminsPkhs threshold lpFeeIsEditable = do } poolValue = mkValues ((\(ac, qty) -> mkValue ac (fromIntegral qty)) `RIO.map` [(x, xQty), (y, yQty), (nft, nftQty), (lq, lqQty)]) mempty - traceM $ T.pack $ (("x: ") ++ (show xQty)) - traceM $ T.pack $ (("y: ") ++ (show yQty)) - traceM $ T.pack $ (("xWeight: ") ++ (show xWeight)) - traceM $ T.pack $ (("yWeight: ") ++ (show yWeight)) - traceM $ T.pack $ (("poolFee: ") ++ (show poolFee)) - traceM $ T.pack $ (("trFee: ") ++ (show trFee)) pure $ BalancePool poolConfig stakeHash poolValue --- Test utils --- @@ -247,25 +241,9 @@ calculateGandTSwap baseAssetBalance baseAssetWeight quoteAssetBalance quoteAsset gY = takeNBigDecimal gYDouble (maxPrecision) -- ((getValue gYDouble)) tY = takeNBigDecimal tGDouble (maxPrecision) -- ((getValue tGDouble)) - traceM $ T.pack $ (("baseAssetWeight: ") ++ (show baseAssetWeight)) - traceM $ T.pack $ (("maxPrecision: ") ++ (show maxPrecision)) - traceM $ T.pack $ (("gX: ") ++ (show gX)) - traceM $ T.pack $ (("tX: ") ++ (show tX)) - traceM $ T.pack $ (("gY: ") ++ (show gY)) - traceM $ T.pack $ (("tY: ") ++ (show tY)) - traceM $ T.pack $ (("yToSwap: ") ++ (show yToSwap)) - traceM $ T.pack $ (("xInInvariantWithDegree: ") ++ (show xInInvariantWithDegree)) - traceM $ T.pack $ (("invDivisionInReverseDegree: ") ++ (show invDivisionInReverseDegree)) - - - - -------- Max test --------- - - - let - spotPriceWithoutFee = (((BigDecimal baseAssetBalance 0)) / ((BigDecimal baseAssetWeight 0))) / (((BigDecimal quoteAssetBalance 0)) / ((BigDecimal quoteAssetWeghit 0))) :: BigDecimal - spotPriceWithFee = spotPriceWithoutFee * (fromRational $ (fromIntegral (lpFee - treasuryFee) / fromIntegral (feeDen))) + spotPriceWithoutFee = (((BigDecimal baseAssetBalance 0)) / ((BigDecimal baseAssetWeight 0))) / (((BigDecimal quoteAssetBalance 0)) / ((BigDecimal quoteAssetWeghit 0))) :: BigDecimal + spotPriceWithFee = spotPriceWithoutFee * (fromRational $ (fromIntegral (lpFee - treasuryFee) / fromIntegral (feeDen))) pure (gX, tX, gY, tY, yToSwap) @@ -373,9 +351,7 @@ correctSwap = (yCS, yTN) = unAssetClass (poolY config) xValue = valueOf value xCS xTN yValue = valueOf value yCS yTN - -- let xToSwap = 285041264117 xToSwap <- integral (Range.constant 100 xValue) - traceM $ T.pack $ (("xToSwap: ") ++ (show xToSwap)) (gX, tX, gY, tY, yToSwap) <- calculateGandTSwap xValue (weightX config) yValue (weightY config) (xToSwap) (poolFeeNum config) (treasuryFee config) (invariant config) let -- going to withdraw all pool x and y value @@ -596,7 +572,6 @@ correctRedeem = lqIssued = 0x7fffffffffffffff - lqValue -- let lqToRedeem = 85989149586251 lqToRedeem <- integral (Range.constant 1 ((lqIssued `div` 2) - 1)) - traceM $ T.pack $ (("lqToRedeem: ") ++ (show lqToRedeem)) (gX, tX, gY, tY, xToRedeem, yToRedeem) <- calculateGandTRedeem xValue (weightX config) yValue (weightY config) (lqToRedeem) lqIssued (poolFeeNum config) (treasuryFee config) (invariant config) let diff --git a/plutarch-validators/test/Tests/BalancePool.hs b/plutarch-validators/test/Tests/BalancePool.hs index ac5185b..086d4ad 100644 --- a/plutarch-validators/test/Tests/BalancePool.hs +++ b/plutarch-validators/test/Tests/BalancePool.hs @@ -1,656 +1,118 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} -module Gen.BalancePoolGen where +module Tests.BalancePool where -import Test.Tasty - -import Plutarch.Prelude -import Plutarch -import Plutarch.Api.V2.Contexts (PScriptContext) -import Plutarch.Prelude -import Numeric -import Data.BigDecimal -import Data.BigFloating -import Data.Ratio +import qualified WhalePoolsDex.PContracts.PBalancePool as PPool +import qualified WhalePoolsDex.Contracts.BalancePool as Pool +import WhalePoolsDex.Contracts.Proxy.FeeSwitch +import WhalePoolsDex.PValidators +import WhalePoolsDex.PConstants +import Data.Either -import RIO hiding (Data(..)) +import Eval import Hedgehog -import Hedgehog.Internal.Property -import Hedgehog.Gen as Gen -import Hedgehog.Range as Range +import Numeric import HaskellWorks.Hedgehog.Gen hiding (MonadGen) +import Gen.Utils hiding (Pool(..), TestAction(..), constructCase) -import Data.Text as T - -import WhalePoolsDex.PContracts.PFeeSwitch - -import qualified PlutusLedgerApi.V1.Interval as Interval -import PlutusLedgerApi.V1.Value hiding (getValue) -import qualified PlutusLedgerApi.V1.Value as Value hiding (getValue) -import qualified Data.ByteString.Base16 as Hex -import qualified Data.Text.Encoding as E -import qualified Data.List as List -import qualified Data.ByteString as BS -import PlutusLedgerApi.V2 hiding (getValue) -import PlutusLedgerApi.V1.Address -import Plutarch.Api.V2 (scriptHash) -import PlutusLedgerApi.V1.Credential -import PlutusTx.Builtins.Internal +import PlutusLedgerApi.V2 +import Plutarch.Api.V2 as PV2 +import WhalePoolsDex.PConstants import WhalePoolsDex.PMintingValidators -import qualified PlutusLedgerApi.V1 as Plutus -import Gen.Models (mkAdaValue, mkValues, mkValue, genAssetClass, genPkh, genCSRandom, genSCRandom, genTxId, genTxOutRef, genValidatorHash, mkContext) -import Gen.DepositGen (unsafeFromEither, mkByteString) -import Gen.Utils hiding (Pool(..), TestAction(..), TestGroup(..)) - -import WhalePoolsDex.Contracts.BalancePool -data BalancePoolActionResult = BalancePoolActionResult - { newPool :: BalancePool - , additionalOutputs :: [TxOut] - , g :: [Integer] - , t :: [Integer] - } deriving Show - -data BalancePoolTestAction m = BalancePoolTestAction - { name :: String - , action :: (BalancePool -> m BalancePoolActionResult) +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.Hedgehog as HH + +import Gen.Models +import Gen.DepositGen +import Gen.BalancePoolGen +import Gen.SwapGen +import Gen.RedeemGen +import Gen.DestroyGen +import Hedgehog.Range as Range +import Debug.Trace +import Data.Text as T (pack, unpack, splitOn) + +balancePool = testGroup "BalancePool" + ((genTests `map` [swapTests, depositAllTests, redeemAllTests])) + +genTests BalancePoolTestGroup{..} = + let + failedCases = (constructCase Failed) `map` invalidActions + successCases = constructCase Success validAction + + --incorrectThreshold = treasholdCase contractAction $ constructIncorrectSignatureThresholdCase validAction + in testGroup name ((testCases contractAction ([successCases] ++ failedCases))) -- ++ [incorrectThreshold]) + +testCases action cases = + (\(name, propertyName, poolUpdater, testResult) -> + HH.testPropertyNamed name propertyName (actionWithValidSignersQty 2 poolUpdater action testResult) + ) `map` cases + +treasholdCase action (name, propertyName, poolUpdater, testResult) = + HH.testPropertyNamed name propertyName (actionWithValidSignersQty 1 poolUpdater action testResult) + +-- Test groups -- + +swapTests = BalancePoolTestGroup + { name = "Swap tests" + , contractAction = Pool.Swap + , validAction = correctSwap + , invalidActions = + [ incorrectSwapGT + , incorrectSwapPoolFinalXValue + , incorrectSwapPoolFinalYValue + , incorrectSwapTrFeeValue + ] } -data BalancePoolTestGroup action = BalancePoolTestGroup - { name :: String - , contractAction :: action - , validAction :: BalancePoolTestAction Gen - , invalidActions :: [BalancePoolTestAction Gen] +depositAllTests = BalancePoolTestGroup + { name = "Deposit tests" + , contractAction = Pool.Deposit + , validAction = correctDeposit + , invalidActions = [incorrectDepositLqOut] } -constructCase testResult BalancePoolTestAction{..} = - let - testName :: TestName = - case testResult of - Success -> "Correct " ++ name ++ " change" - Failed -> "Attempt to " ++ name ++ " failed" - propertyName = PropertyName name - in (testName, propertyName, action, testResult) - -instance ToTxInfo BalancePool where - toTxInInfo pool = do - ref <- genTxOutRef - let txOut = toTxOut pool - pure $ TxInInfo - { txInInfoOutRef = ref - , txInInfoResolved = txOut - } - -feeDen = 100000 -precisionAdditionalDec = 10 - -daoMintingPurpose :: BalancePool -> ScriptPurpose -daoMintingPurpose BalancePool{..} = Rewarding $ List.head (daoPolicy config) - -daoValidator :: BalancePool -> [PubKeyHash] -> Integer -> Bool -> ClosedTerm (PData :--> PScriptContext :--> POpaque) -daoValidator BalancePool{..} admins threshold lpFeeIsEditable = - wrapMintingValidator (daoMultisigPolicyValidatorT (pconstant (poolNft config)) (pconstant admins) (pconstant threshold) (pconstant lpFeeIsEditable)) - -createTxInfo :: MonadGen m => BalancePool -> BalancePoolActionResult -> [PubKeyHash] -> m TxInfo -createTxInfo prevPool@BalancePool{..} BalancePoolActionResult{..} adminPkhs = do - poolTxIn <- toTxInInfo prevPool - let - daoCS = List.head (daoPolicy config) - - pure $ TxInfo - { txInfoInputs = [poolTxIn] - , txInfoReferenceInputs = [] - , txInfoOutputs = [toTxOut newPool] ++ additionalOutputs - , txInfoFee = mempty - , txInfoMint = mempty - , txInfoDCert = mempty - , txInfoWdrl = fromList [(daoCS, 0)] - , txInfoValidRange = Interval.always - , txInfoSignatories = adminPkhs - , txInfoRedeemers = fromList [] - , txInfoData = fromList [] - , txInfoId = "b0" - } - - -takeNBigDecimal :: BigDecimal -> Integer -> Integer -takeNBigDecimal toCut n = - let - inString = T.unpack (T.take (fromInteger n) (T.pack . show $ (Data.BigDecimal.getValue toCut))) - in (read inString) :: Integer - -getDecimalNum :: BigDecimal -> Integer -getDecimalNum toCut = - let - currentScale = getScale toCut - inString = T.unpack (T.dropEnd (fromInteger currentScale) (T.pack . show $ (Data.BigDecimal.getValue toCut))) - in (read inString) :: Integer - -genBalancePool :: MonadGen f => [PubKeyHash] -> Integer -> Bool -> f BalancePool -genBalancePool adminsPkhs threshold lpFeeIsEditable = do - (x, y, lq, nft) <- tuple4 genAssetClass - - stakeHash <- genPkh - - -- todo: error on big values such as 10000000000000000 - -- (yQty :: Int) <- integral (Range.constant 10000000000 10000000000000000) - - (xWeight :: Integer) <- integral (Range.constant 1 5) - (xQty :: Integer) <- integral (Range.constant 1000000000 1000000000000) - poolFee <- integral (Range.constant 80000 feeDen) - trFee <- integral (Range.constant 1 1000) - -- let trFee = 683 - -- let poolFee = 86472 - -- let xWeight = 5 - -- let yWeight = 5 - -- let xQty = 303457031315 - - treasuryAddress <- genValidatorHash - let - yWeight = 10 - xWeight - - yQty = xQty * yWeight - nftQty = 1 - - xQtyFloat = (fromIntegral xQty) :: Double - yQtyFloat = (fromIntegral yQty) :: Double - - yPartLength = toInteger $ RIO.length . show $ xQty - xValueLength = toInteger $ RIO.length . show $ yQty - - maxPrecision = (if (yPartLength > xValueLength) then yPartLength else xValueLength) + precisionAdditionalDec - - -- invariant = (xQtyFloat**(xWeightFloat / 10)) * (yQtyFloat**(yWeightFloat / 10)) - invariantT = ((BigDecimal xQty 0) ** (fromRational $ (fromIntegral xWeight) / 10)) * ( (BigDecimal yQty 0) ** (fromRational $ (fromIntegral yWeight) / 10)) - invariant = getDecimalNum invariantT - - lqQty = 0x7fffffffffffffff - invariant - - daoContract = - StakingHash . ScriptCredential . ValidatorHash . getScriptHash . scriptHash $ (unMintingPolicyScript (daoMintPolicyValidator nft adminsPkhs threshold lpFeeIsEditable)) - - leftSide = (BigDecimal invariant 0) / ((BigDecimal xQty 0) ** (fromRational $ (fromIntegral xWeight) / 10)) - - let - poolConfig = BalancePoolConfig - { poolNft = nft - , poolX = x - , weightX = xWeight - , poolY = y - , weightY = yWeight - , poolLq = lq - , poolFeeNum = poolFee - , treasuryFee = trFee - , treasuryX = 0 - , treasuryY = 0 - , daoPolicy = [daoContract] - , treasuryAddress = treasuryAddress - , invariant = invariant - } - - poolValue = mkValues ((\(ac, qty) -> mkValue ac (fromIntegral qty)) `RIO.map` [(x, xQty), (y, yQty), (nft, nftQty), (lq, lqQty)]) mempty - traceM $ T.pack $ (("x: ") ++ (show xQty)) - traceM $ T.pack $ (("y: ") ++ (show yQty)) - traceM $ T.pack $ (("xWeight: ") ++ (show xWeight)) - traceM $ T.pack $ (("yWeight: ") ++ (show yWeight)) - traceM $ T.pack $ (("poolFee: ") ++ (show poolFee)) - traceM $ T.pack $ (("trFee: ") ++ (show trFee)) - pure $ BalancePool poolConfig stakeHash poolValue - ---- Test utils --- - --- BaseAssetBalance -> BaseAssetWeight -> QuoteAssetBalance -> QuoteAssetWeghit -> BaseIn -> lpFee -> treasuryFee -> (gBase, tBase, gQuote, tQuote, quoteOut) -calculateGandTSwap :: MonadGen m => Integer -> Integer -> Integer -> Integer -> Integer -> Integer -> Integer -> Integer -> m (Integer, Integer, Integer, Integer, Integer) -calculateGandTSwap baseAssetBalance baseAssetWeight quoteAssetBalance quoteAssetWeghit baseIn lpFee treasuryFee prevInvariant = do - let - yPartLength = toInteger $ RIO.length . show $ quoteAssetBalance - xValueLength = toInteger $ RIO.length . show $ (baseAssetBalance + baseIn) - - maxPrecision = (if (yPartLength > xValueLength) then yPartLength else xValueLength) + precisionAdditionalDec - - invariantLength = toInteger $ RIO.length . show $ prevInvariant - - xValueFloat = (fromIntegral baseAssetBalance) :: BigDecimal - invariantFloat = (BigDecimal prevInvariant 0) :: BigDecimal - xWeightFloat = (fromIntegral baseAssetWeight) :: BigDecimal - yValueFloat = (fromIntegral quoteAssetBalance) :: BigDecimal - yWeightFloat = (fromIntegral quoteAssetWeghit) :: BigDecimal - treasuryFeeNum = (fromIntegral treasuryFee) :: Double - lpFeeNum = (fromIntegral lpFee) :: Double - - additionalPart = (BigDecimal (fromIntegral baseIn) 0) * (fromRational $ (fromIntegral (lpFee - treasuryFee)) / fromIntegral feeDen) -- xInInvariant = fromIntegral $ baseAssetBalance + round ((fromIntegral baseIn) * ((lpFeeNum - treasuryFeeNum) / fromIntegral feeDen)) - -- no decimals after point - xInInvariantBigDecimal = xValueFloat + additionalPart - -- xInInvariantBigDecimal in degree `(xWieght / 10)` - xInInvariantWithDegree = (xInInvariantBigDecimal ** (fromRational $ ((fromIntegral baseAssetWeight) / 10))) -- g - xInInvariantWith1Degree = (xInInvariantBigDecimal) ** (fromRational $ (1 / 10)) -- t - - gX = ((takeNBigDecimal xInInvariantWithDegree (maxPrecision)) :: Integer) - tX = ((takeNBigDecimal xInInvariantWith1Degree (maxPrecision)) :: Integer) - - -- test - invDivision = invariantFloat / xInInvariantWithDegree - invDivisionInReverseDegree = nthRoot (invDivision ** 10) (fromInteger quoteAssetWeghit) (DOWN, (Just . toInteger $ 0)) - -- denum = 10 ^ (yPartLength - xValueLength) - - invDivisionInReverseDegreeBigDecimalRounded = takeNBigDecimal invDivisionInReverseDegree (yPartLength) - - yToSwap = quoteAssetBalance - invDivisionInReverseDegreeBigDecimalRounded - - gYDouble = ((BigDecimal (quoteAssetBalance - yToSwap) 0) ** (fromRational $ (fromIntegral quoteAssetWeghit) / 10)) :: BigDecimal -- g - tGDouble = (((BigDecimal (quoteAssetBalance - yToSwap) 0) ** (fromRational $ (1 / 10)))) :: BigDecimal -- g - - gY = takeNBigDecimal gYDouble (maxPrecision) -- ((getValue gYDouble)) - tY = takeNBigDecimal tGDouble (maxPrecision) -- ((getValue tGDouble)) - traceM $ T.pack $ (("baseAssetWeight: ") ++ (show baseAssetWeight)) - traceM $ T.pack $ (("maxPrecision: ") ++ (show maxPrecision)) - traceM $ T.pack $ (("gX: ") ++ (show gX)) - traceM $ T.pack $ (("tX: ") ++ (show tX)) - traceM $ T.pack $ (("gY: ") ++ (show gY)) - traceM $ T.pack $ (("tY: ") ++ (show tY)) - traceM $ T.pack $ (("yToSwap: ") ++ (show yToSwap)) - traceM $ T.pack $ (("xInInvariantWithDegree: ") ++ (show xInInvariantWithDegree)) - traceM $ T.pack $ (("invDivisionInReverseDegree: ") ++ (show invDivisionInReverseDegree)) - - - - - -------- Max test --------- - - - let - spotPriceWithoutFee = (((BigDecimal baseAssetBalance 0)) / ((BigDecimal baseAssetWeight 0))) / (((BigDecimal quoteAssetBalance 0)) / ((BigDecimal quoteAssetWeghit 0))) :: BigDecimal - spotPriceWithFee = spotPriceWithoutFee * (fromRational $ (fromIntegral (lpFee - treasuryFee) / fromIntegral (feeDen))) - - pure (gX, tX, gY, tY, yToSwap) - --- BaseAssetBalance -> BaseAssetWeight -> QuoteAssetBalance -> QuoteAssetWeghit -> BaseIn -> lqSupply -> lpFee -> treasuryFee -> (gBase, tBase, gQuote, tQuote, quoteToDeposit, lqOut) -calculateGandTDeposit :: MonadGen m => Integer -> Integer -> Integer -> Integer -> Integer -> Integer -> Integer -> Integer -> Integer -> m (Integer, Integer, Integer, Integer, Integer, Integer, Integer) -calculateGandTDeposit baseAssetBalance baseAssetWeight quoteAssetBalance quoteAssetWeghit lqIssued lqSupply lpFee treasuryFee prevInvariant = do - let - lqIssuedDec = (fromIntegral lqIssued) :: BigDecimal - xToDeposit = roundBD ((lqIssuedDec * xValueFloat) / lqSupplyDouble) (UP, (Just . toInteger $ 0)) - yToDeposit = roundBD ((lqIssuedDec * yValueFloat) / lqSupplyDouble) (UP, (Just . toInteger $ 0)) - - -- yToDeposit = (((lqSupplyDouble + lqIssued) / lqSupplyDouble) - 1) * yValueFloat - yPartLength = toInteger $ RIO.length . show $ quoteAssetBalance - xValueLength = toInteger $ RIO.length . show $ (xValueFloat + xToDeposit) - - maxPrecision = (if (yPartLength > xValueLength) then yPartLength else xValueLength) - - xValueFloat = (fromIntegral baseAssetBalance) :: BigDecimal - invariantFloat = fromIntegral prevInvariant :: BigDecimal - xWeightFloat = (fromIntegral baseAssetWeight) :: BigDecimal - yValueFloat = (fromIntegral quoteAssetBalance) :: BigDecimal - yWeightFloat = (fromIntegral quoteAssetWeghit) :: BigDecimal - treasuryFeeNum = (fromIntegral treasuryFee) :: BigDecimal - lpFeeNum = (fromIntegral lpFee) :: BigDecimal - lqSupplyDouble = (fromIntegral lqSupply) :: BigDecimal - -- no decimals after point - xInInvariantBigDecimal = xValueFloat + xToDeposit - -- xInInvariantBigDecimal in degree `(xWieght / 10)` - xInInvariantWithDegree = (xInInvariantBigDecimal ** (fromRational $ ((fromIntegral baseAssetWeight) / 10))) -- g - xInInvariantWith1Degree = (xInInvariantBigDecimal) ** (fromRational $ (1 / 10)) -- t - - gX = ((takeNBigDecimal xInInvariantWithDegree (maxPrecision)) :: Integer) - tX = ((takeNBigDecimal xInInvariantWith1Degree (maxPrecision)) :: Integer) - - gBase = yValueFloat + yToDeposit - gBaseRounded = BigDecimal (getDecimalNum (yValueFloat + yToDeposit)) 0 - gYDouble = nthRoot (gBaseRounded ** yWeightFloat) 10 (UP, (Just . toInteger $ maxPrecision)) :: BigDecimal -- g - - tGDoubleTest = nthRoot gBaseRounded 10 (DOWN, (Just . toInteger $ maxPrecision)) - tGDouble = nthRoot gBaseRounded 10 (DOWN, (Just . toInteger $ maxPrecision)) - - gY = takeNBigDecimal gYDouble (maxPrecision) - tY = takeNBigDecimal tGDouble (maxPrecision) - - pure (gX, tX, gY, tY, getDecimalNum xToDeposit, getDecimalNum yToDeposit, getDecimalNum lqIssuedDec) - -calculateGandTRedeem :: MonadGen m => Integer -> Integer -> Integer -> Integer -> Integer -> Integer -> Integer -> Integer -> Integer -> m (Integer, Integer, Integer, Integer, Integer, Integer) -calculateGandTRedeem baseAssetBalance baseAssetWeight quoteAssetBalance quoteAssetWeghit lqRedeem lqSupply lpFee treasuryFee prevInvariant = do - let - lqRedeemDec = (fromIntegral lqRedeem) :: BigDecimal - xToRedeem = roundBD ((lqRedeemDec * xValueFloat) / lqSupplyDouble) (DOWN, (Just . toInteger $ 0)) - yToRedeem = roundBD ((lqRedeemDec * yValueFloat) / lqSupplyDouble) (DOWN, (Just . toInteger $ 0)) - - yPartLength = toInteger $ RIO.length . show $ quoteAssetBalance - xValueLength = toInteger $ RIO.length . show $ (xValueFloat - xToRedeem) - - maxPrecision = (if (yPartLength > xValueLength) then yPartLength else xValueLength) - - xValueFloat = (fromIntegral baseAssetBalance) :: BigDecimal - invariantFloat = fromIntegral prevInvariant :: BigDecimal - xWeightFloat = (fromIntegral baseAssetWeight) :: BigDecimal - yValueFloat = (fromIntegral quoteAssetBalance) :: BigDecimal - yWeightFloat = (fromIntegral quoteAssetWeghit) :: BigDecimal - treasuryFeeNum = (fromIntegral treasuryFee) :: BigDecimal - lpFeeNum = (fromIntegral lpFee) :: BigDecimal - lqSupplyDouble = (fromIntegral lqSupply) :: BigDecimal - -- no decimals after point - xInInvariantBigDecimal = xValueFloat - xToRedeem - -- xInInvariantBigDecimal in degree `(xWieght / 10)` - xInInvariantWithDegree = (xInInvariantBigDecimal ** (fromRational $ ((fromIntegral baseAssetWeight) / 10))) -- g - xInInvariantWith1Degree = (xInInvariantBigDecimal) ** (fromRational $ (1 / 10)) -- t - - gX = ((takeNBigDecimal xInInvariantWithDegree (maxPrecision)) :: Integer) - tX = ((takeNBigDecimal xInInvariantWith1Degree (maxPrecision)) :: Integer) - - gBase = yValueFloat - yToRedeem - gBaseRounded = BigDecimal (getDecimalNum (yValueFloat - yToRedeem)) 0 - gYDouble = nthRoot (gBaseRounded ** yWeightFloat) 10 (UP, (Just . toInteger $ maxPrecision)) :: BigDecimal -- g - - tGDoubleTest = nthRoot gBaseRounded 10 (DOWN, (Just . toInteger $ maxPrecision)) - tGDouble = nthRoot gBaseRounded 10 (DOWN, (Just . toInteger $ maxPrecision)) - - gY = takeNBigDecimal gYDouble (maxPrecision) - tY = takeNBigDecimal tGDouble (maxPrecision) - - pure (gX, tX, gY, tY, getDecimalNum xToRedeem, getDecimalNum yToRedeem) +redeemAllTests = BalancePoolTestGroup + { name = "Redeem tests" + , contractAction = Pool.Redeem + , validAction = correctRedeem + , invalidActions = [incorrectRedeemLQFinalValue] + } ---- Test cases --- +----------------- -cutFloat :: Double -> Int -> Integer -cutFloat toCut maxInt = let +cutFloatD :: Double -> Int -> Integer +cutFloatD toCut maxInt = let strValue = T.pack $ showFFloat (Just maxInt) toCut "" - splitted = splitOn "." strValue + splitted = T.splitOn "." strValue in read $ T.unpack . Prelude.head $ splitted --- Swap cases start -- - -correctSwap :: MonadGen m => BalancePoolTestAction m -correctSwap = +actionWithValidSignersQty :: Int -> (BalancePool -> Gen BalancePoolActionResult) -> Pool.BalancePoolAction -> TestResult -> Property +actionWithValidSignersQty sigsQty poolUpdater action testResultShouldBe = withShrinks 1 $ withTests 10 $ property $ do let - testAction prevPool@BalancePool{..} = do - - let - (xCS, xTN) = unAssetClass (poolX config) - (yCS, yTN) = unAssetClass (poolY config) - xValue = valueOf value xCS xTN - yValue = valueOf value yCS yTN - -- let xToSwap = 285041264117 - xToSwap <- integral (Range.constant 100 xValue) - traceM $ T.pack $ (("xToSwap: ") ++ (show xToSwap)) - (gX, tX, gY, tY, yToSwap) <- calculateGandTSwap xValue (weightX config) yValue (weightY config) (xToSwap) (poolFeeNum config) (treasuryFee config) (invariant config) - let - -- going to withdraw all pool x and y value - tFee = treasuryFee config - - newPoolConfig = config - { treasuryX = (tFee * xToSwap) `div` feeDen - , treasuryY = 0 - } - - newPool = prevPool - { config = newPoolConfig - , value = value <> (assetClassValue (poolX config) (xToSwap)) <> (assetClassValue (poolY config) (negate yToSwap)) - } + threshold = 2 - pure $ BalancePoolActionResult newPool [] [gX, gY] [tX, tY] - in BalancePoolTestAction "Correct swap" testAction - -incorrectSwapGT :: MonadGen m => BalancePoolTestAction m -incorrectSwapGT = + (pkh1, pkh2, pkh3) <- forAll $ tuple3 genPkh + prevPool <- forAll $ genBalancePool [pkh1, pkh2, pkh3] threshold True + updateResult <- forAll $ poolUpdater prevPool + txInInfo <- forAll $ createTxInfo prevPool updateResult (take sigsQty [pkh1, pkh2, pkh3]) let - testAction prevPool@BalancePool{..} = do - - let - (xCS, xTN) = unAssetClass (poolX config) - (yCS, yTN) = unAssetClass (poolY config) - xValue = valueOf value xCS xTN - yValue = valueOf value yCS yTN - - xToSwap <- integral (Range.constant 1 ((xValue `div` 2) - 1)) - (gX, tX, gY, tY, yToSwap) <- calculateGandTSwap xValue (weightX config) yValue (weightY config) (xToSwap + 1000) (poolFeeNum config) (treasuryFee config) (invariant config) - let - newPool = prevPool - { value = value <> (assetClassValue (poolX config) (xToSwap)) <> (assetClassValue (poolY config) (negate yToSwap)) - } - - pure $ BalancePoolActionResult newPool [] [gX, gY] [tX, tY] - in BalancePoolTestAction "Incorrect swap GT" testAction - -incorrectSwapPoolFinalXValue :: MonadGen m => BalancePoolTestAction m -incorrectSwapPoolFinalXValue = + purpose = mkPurpose (txInInfoOutRef . head . txInfoInputs $ txInInfo) let - testAction prevPool@BalancePool{..} = do - let - (xCS, xTN) = unAssetClass (poolX config) - (yCS, yTN) = unAssetClass (poolY config) - xValue = valueOf value xCS xTN - yValue = valueOf value yCS yTN - tFee = treasuryFee config - - xToSwap <- integral (Range.constant 1 ((xValue `div` 2) - 1)) - incorrectXSwapValue <- integral (Range.constant 1 ((xValue `div` 2) - 1)) - (gX, tX, gY, tY, yToSwap) <- calculateGandTSwap xValue (weightX config) yValue (weightY config) (xToSwap) (poolFeeNum config) (treasuryFee config) (invariant config) - let - tFee = treasuryFee config - - newPoolConfig = config - { treasuryX = (tFee * xToSwap) `div` feeDen - , treasuryY = 0 - } - - newPool = prevPool - { value = value <> (assetClassValue (poolX config) (incorrectXSwapValue)) <> (assetClassValue (poolY config) (negate yToSwap)) - } - - pure $ BalancePoolActionResult newPool [] [gX, gY] [tX, tY] - in BalancePoolTestAction "Incorrect pool x final value" testAction - -incorrectSwapPoolFinalYValue :: MonadGen m => BalancePoolTestAction m -incorrectSwapPoolFinalYValue = - let - testAction prevPool@BalancePool{..} = do - - let - (xCS, xTN) = unAssetClass (poolX config) - (yCS, yTN) = unAssetClass (poolY config) - xValue = valueOf value xCS xTN - yValue = valueOf value yCS yTN - - xToSwap <- integral (Range.constant 1 ((xValue `div` 2) - 1)) - incorrectYFinalValue <- integral (Range.constant 1 (yValue - 1)) - (gX, tX, gY, tY, yToSwap) <- calculateGandTSwap xValue (weightX config) yValue (weightY config) (xToSwap) (poolFeeNum config) (treasuryFee config) (invariant config) - - let - -- going to withdraw all pool x and y value - tFee = treasuryFee config - - newPoolConfig = config - { treasuryX = (tFee * xToSwap) `div` feeDen - , treasuryY = 0 - } - - newPool = prevPool - { value = value <> (assetClassValue (poolX config) (xToSwap)) <> (assetClassValue (poolY config) (negate incorrectYFinalValue)) - } - - pure $ BalancePoolActionResult newPool [] [gX, gY] [tX, tY] - in BalancePoolTestAction "Incorrect pool y final value" testAction - -incorrectSwapTrFeeValue :: MonadGen m => BalancePoolTestAction m -incorrectSwapTrFeeValue = + datum = toData $ (config prevPool) let - testAction prevPool@BalancePool{..} = do - - let - (xCS, xTN) = unAssetClass (poolX config) - (yCS, yTN) = unAssetClass (poolY config) - xValue = valueOf value xCS xTN - yValue = valueOf value yCS yTN - - xToSwap <- integral (Range.constant 1 ((xValue `div` 2) - 1)) - (gX, tX, gY, tY, yToSwap) <- calculateGandTSwap xValue (weightX config) yValue (weightY config) (xToSwap) (poolFeeNum config) (treasuryFee config) (invariant config) - let - treasuryFee_ = treasuryFee config - newPoolConfig = config - { treasuryX = (treasuryFee_ * (xToSwap)) `div` feeDen - 1 - } - newPool = prevPool - { config = newPoolConfig - , value = value <> (assetClassValue (poolX config) (xToSwap)) <> (assetClassValue (poolY config) (negate yToSwap)) - } - - pure $ BalancePoolActionResult newPool [] [gX, gY] [tX, tY] - in BalancePoolTestAction "Incorrect pool treasury X final value" testAction - --- Swap cases end -- - --- Deposit all cases start -- - -correctDeposit :: MonadGen m => BalancePoolTestAction m -correctDeposit = - let - testAction prevPool@BalancePool{..} = do - - let - (xCS, xTN) = unAssetClass (poolX config) - (yCS, yTN) = unAssetClass (poolY config) - (lqCS, lqTN) = unAssetClass (poolLq config) - xValue = valueOf value xCS xTN - yValue = valueOf value yCS yTN - lqValue = valueOf value lqCS lqTN - lqSupply = 0x7fffffffffffffff - lqValue - - lqIssued <- integral (Range.constant 1 ((lqValue `div` 2) - 1)) + context = toData $ mkContext txInInfo purpose + redeemer = toData $ Pool.BalancePoolRedeemer action 0 (g updateResult) (t updateResult) - (gX, tX, gY, tY, xToDeposit, yToDeposit, lqIssued) <- calculateGandTDeposit xValue (weightX config) yValue (weightY config) (lqIssued) lqSupply (poolFeeNum config) (treasuryFee config) (invariant config) - - let - -- lqIssued = 0x7fffffffffffffff - (round lqValue) - - newInvariant = gX * gY - - -- going to withdraw all pool x and y value - newPoolConfig = config - { invariant = newInvariant - } - - newPool = prevPool - { config = newPoolConfig - , value = value <> (assetClassValue (poolX config) (xToDeposit)) <> (assetClassValue (poolY config) (yToDeposit)) <> (assetClassValue (poolLq config) (negate lqIssued)) - } - - pure $ BalancePoolActionResult newPool [] [gX, gY] [tX, tY] - in BalancePoolTestAction "Correct deposit all tokens" testAction - -incorrectDepositLqOut :: MonadGen m => BalancePoolTestAction m -incorrectDepositLqOut = - let - testAction prevPool@BalancePool{..} = do - - let - (xCS, xTN) = unAssetClass (poolX config) - (yCS, yTN) = unAssetClass (poolY config) - (lqCS, lqTN) = unAssetClass (poolLq config) - xValue = valueOf value xCS xTN - yValue = valueOf value yCS yTN - lqValue = valueOf value lqCS lqTN - lqSupply = 0x7fffffffffffffff - lqValue - - lqIssued <- integral (Range.constant 1 ((lqValue `div` 2) - 1)) - - (gX, tX, gY, tY, xToDeposit, yToDeposit, lqIssued) <- calculateGandTDeposit xValue (weightX config) yValue (weightY config) (lqIssued) lqSupply (poolFeeNum config) (treasuryFee config) (invariant config) - - let - -- lqIssued = 0x7fffffffffffffff - (round lqValue) - - newInvariant = gX * gY - - -- going to withdraw all pool x and y value - newPoolConfig = config - { invariant = newInvariant - } - - newPool = prevPool - { config = newPoolConfig - , value = value <> (assetClassValue (poolX config) (xToDeposit)) <> (assetClassValue (poolY config) (yToDeposit)) <> (assetClassValue (poolLq config) (negate (lqIssued + 1000))) - } - - pure $ BalancePoolActionResult newPool [] [gX, gY] [tX, tY] - in BalancePoolTestAction "Incorrect deposit all tokens. Incorrect lq out" testAction - --- Deposit all cases end -- - --- Redeem all cases start -- - -correctRedeem :: MonadGen m => BalancePoolTestAction m -correctRedeem = - let - testAction prevPool@BalancePool{..} = do - - let - (xCS, xTN) = unAssetClass (poolX config) - (yCS, yTN) = unAssetClass (poolY config) - (lqCS, lqTN) = unAssetClass (poolLq config) - xValue = valueOf value xCS xTN - yValue = valueOf value yCS yTN - lqValue = valueOf value lqCS lqTN - lqIssued = 0x7fffffffffffffff - lqValue - -- let lqToRedeem = 85989149586251 - lqToRedeem <- integral (Range.constant 1 ((lqIssued `div` 2) - 1)) - traceM $ T.pack $ (("lqToRedeem: ") ++ (show lqToRedeem)) - (gX, tX, gY, tY, xToRedeem, yToRedeem) <- calculateGandTRedeem xValue (weightX config) yValue (weightY config) (lqToRedeem) lqIssued (poolFeeNum config) (treasuryFee config) (invariant config) - - let - -- lqIssued = 0x7fffffffffffffff - (round lqValue) - - newInvariant = gX * gY - - -- going to withdraw all pool x and y value - newPoolConfig = config - { invariant = newInvariant - } - - newPool = prevPool - { config = newPoolConfig - , value = value <> (assetClassValue (poolX config) (negate xToRedeem)) <> (assetClassValue (poolY config) (negate yToRedeem)) <> (assetClassValue (poolLq config) (lqToRedeem)) - } - - pure $ BalancePoolActionResult newPool [] [gX, gY] [tX, tY] - in BalancePoolTestAction "Correct redeem all tokens" testAction - -incorrectRedeemLQFinalValue :: MonadGen m => BalancePoolTestAction m -incorrectRedeemLQFinalValue = - let - testAction prevPool@BalancePool{..} = do - - let - (xCS, xTN) = unAssetClass (poolX config) - (yCS, yTN) = unAssetClass (poolY config) - (lqCS, lqTN) = unAssetClass (poolLq config) - xValue = valueOf value xCS xTN - yValue = valueOf value yCS yTN - lqValue = valueOf value lqCS lqTN - lqIssued = 0x7fffffffffffffff - lqValue - - lqToRedeem <- integral (Range.constant 1000 ((lqIssued `div` 2) - 1)) - - (gX, tX, gY, tY, xToRedeem, yToRedeem) <- calculateGandTRedeem xValue (weightX config) yValue (weightY config) (lqToRedeem) lqIssued (poolFeeNum config) (treasuryFee config) (invariant config) - - let - -- lqIssued = 0x7fffffffffffffff - (round lqValue) - - newInvariant = gX * gY - - -- going to withdraw all pool x and y value - newPoolConfig = config - { invariant = newInvariant - } - - newPool = prevPool - { config = newPoolConfig - , value = value <> (assetClassValue (poolX config) (negate xToRedeem)) <> (assetClassValue (poolY config) (negate yToRedeem)) <> (assetClassValue (poolLq config) (lqToRedeem - 100)) - } - - pure $ BalancePoolActionResult newPool [] [gX, gY] [tX, tY] - in BalancePoolTestAction "InCorrect redeem all tokens. Incorrect final lq value" testAction + correctResult = + case testResultShouldBe of + Success -> Right() + Failed -> Left() + + result = eraseBoth $ evalWithArgs (wrapValidator PPool.balancePoolValidatorT) [datum, redeemer, context] --- Redeem all cases end -- \ No newline at end of file + result === correctResult \ No newline at end of file