From cb45b7887b6a852b44f64dd62b351693d5572de3 Mon Sep 17 00:00:00 2001 From: Bromel777 Date: Wed, 3 Apr 2024 08:57:02 +0200 Subject: [PATCH 1/5] Balance pool. Optimizations, redundant logic removed, validDelta bug fix --- plutarch-validators/PExtra/Integer.hs | 53 +++ .../WhalePoolsDex/Contracts/BalancePool.hs | 2 + .../WhalePoolsDex/PContracts/PBalancePool.hs | 344 +++++++++++------- .../WhalePoolsDex/PContracts/PPoolBFee.hs | 1 - plutarch-validators/test/Eval.hs | 4 +- .../test/Gen/BalancePoolGen.hs | 186 ++++++---- plutarch-validators/test/Gen/DepositGen.hs | 6 + plutarch-validators/test/Spec.hs | 3 + plutarch-validators/test/Tests/BalancePool.hs | 8 +- 9 files changed, 393 insertions(+), 214 deletions(-) diff --git a/plutarch-validators/PExtra/Integer.hs b/plutarch-validators/PExtra/Integer.hs index 98ec580..b2ef8c1 100644 --- a/plutarch-validators/PExtra/Integer.hs +++ b/plutarch-validators/PExtra/Integer.hs @@ -2,6 +2,7 @@ module PExtra.Integer ( podd, peven, ppow, + ppow10 ) where import Plutarch.Prelude @@ -32,5 +33,57 @@ pexp' = phoistAcyclic $ 1 $ pif (podd # n) a 1 * (psquare #$ self # a # (pdiv # n # 2)) +ppow10 :: Term s (PInteger :--> PInteger :--> PInteger) +ppow10 = phoistAcyclic $ + plam $ \a n -> + pif + (n #< 0) + perror + (pexp10' # a # n) + +pexp10' :: Term s (PInteger :--> PInteger :--> PInteger) +pexp10' = phoistAcyclic $ + pfix #$ plam $ \self a n -> + pif + (n #< 12) + (pexp10constant' # a # n) + $ pif (podd # n) a 1 * (psquare #$ self # a # (pdiv # n # 2)) + +-- max degree is 11 +pexp10constant' :: Term s (PInteger :--> PInteger :--> PInteger) +pexp10constant' = phoistAcyclic $ + pfix #$ plam $ \self a n -> + pif + ( n #== 11 ) + (pconstant 100000000000) + ( pif (n #== 10) + (pconstant 10000000000) + ( pif (n #== 9) + (pconstant 1000000000) + ( pif (n #== 8) + (pconstant 100000000) + ( pif (n #== 7) + (pconstant 10000000) + ( pif (n #== 6) + (pconstant 1000000) + ( pif (n #== 5) + (pconstant 100000) + ( pif (n #== 4) + (pconstant 10000) + ( pif (n #== 3) + (pconstant 1000) + ( pif (n #== 2) + (pconstant 100) + $ pif (n #== 1) (pconstant 10) (pconstant 1) + ) + ) + ) + ) + ) + ) + ) + ) + ) + psquare :: Term s (PInteger :--> PInteger) psquare = phoistAcyclic $ plam $ \x' -> plet x' $ \x -> x * x diff --git a/plutarch-validators/WhalePoolsDex/Contracts/BalancePool.hs b/plutarch-validators/WhalePoolsDex/Contracts/BalancePool.hs index bc9a430..a805911 100644 --- a/plutarch-validators/WhalePoolsDex/Contracts/BalancePool.hs +++ b/plutarch-validators/WhalePoolsDex/Contracts/BalancePool.hs @@ -28,6 +28,7 @@ data BalancePoolConfig = BalancePoolConfig , daoPolicy :: [StakingCredential] , treasuryAddress :: ValidatorHash , invariant :: Integer + , invariantLength :: Integer } deriving stock (Show) @@ -64,6 +65,7 @@ data BalancePoolRedeemer = BalancePoolRedeemer , selfIx :: Integer , g :: [Integer] , t :: [Integer] + , lList :: [Integer] } deriving (Show) diff --git a/plutarch-validators/WhalePoolsDex/PContracts/PBalancePool.hs b/plutarch-validators/WhalePoolsDex/PContracts/PBalancePool.hs index 36f7f35..1c0e999 100644 --- a/plutarch-validators/WhalePoolsDex/PContracts/PBalancePool.hs +++ b/plutarch-validators/WhalePoolsDex/PContracts/PBalancePool.hs @@ -2,7 +2,7 @@ module WhalePoolsDex.PContracts.PBalancePool where -import qualified GHC.Generics as GHC +import qualified GHC.Generics as GHC hiding (log) import Generics.SOP (Generic, I (I)) import Plutarch @@ -18,7 +18,7 @@ import Plutarch.Internal.PlutusType (PInner, PlutusType, pcon', pmatch') import Plutarch.TryFrom (PTryFrom (PTryFromExcess, ptryFrom')) import Plutarch.Api.V1.Scripts (PValidatorHash) import Plutarch.Rational -import Plutarch.Num ((#*), pabs) +import Plutarch.Num ((#*), (#+), (#-), pabs, pnegate) import Plutarch.Extra.Maybe as Maybe import Plutarch.Api.V1.AssocMap import Plutarch.Positive @@ -53,6 +53,7 @@ newtype BalancePoolConfig (s :: S) , "DAOPolicy" ':= PBuiltinList (PAsData PStakingCredential) , "treasuryAddress" ':= PValidatorHash , "invariant" ':= PInteger + , "invariantLength" ':= PInteger ] ) ) @@ -121,6 +122,8 @@ newtype BalancePoolRedeemer (s :: S) , "g" ':= PBuiltinList (PAsData PInteger) -- for swap, deposit / redeem (All assets) contains: tX, tY , "t" ':= PBuiltinList (PAsData PInteger) + -- info about internals lengths + , "lengths" ':= PBuiltinList (PAsData PInteger) ] ) ) @@ -133,7 +136,7 @@ instance DerivePlutusType BalancePoolRedeemer where type DPTStrat _ = PlutusType -- Balance pool related constants -- pDen :: Term s PInteger -pDen = pconstant 10 +pDen = pconstant 5 ------------------------------------ @@ -143,77 +146,92 @@ parseDatum = plam $ \newDatum -> unTermCont $ do tletUnwrap $ ptryFromData @(BalancePoolConfig) $ poolDatum pIntLength :: ClosedTerm (PInteger :--> PInteger) -pIntLength = plam $ \integerToProcess -> pIntLengthInternal # integerToProcess # 1 # 1 +pIntLength = plam $ \integerToProcess -> pIntLengthInternal # integerToProcess # 1 -pIntLengthInternal :: Term s (PInteger :--> PInteger :--> PInteger :--> PInteger) +pIntLengthInternal :: Term s (PInteger :--> PInteger :--> PInteger) pIntLengthInternal = phoistAcyclic $ - pfix #$ plam $ \self integerToProcess acc10 accLength -> + pfix #$ plam $ \self integerToProcess accLength -> + plet (pdiv # integerToProcess # (pconstant 10)) $ \divided -> pif - (integerToProcess #<= acc10) - (accLength - 1) - (self # integerToProcess # (acc10 * 10) # (accLength + 1)) - -roundTo :: ClosedTerm (PInteger :--> PInteger :--> PInteger) -roundTo = plam $ \origValue roundIdx -> - let - roundingDenum = ptryPositive # (ppow # 10 # ((pIntLength # origValue) - roundIdx)) - rational = (pcon $ PRational origValue roundingDenum) - in pround # rational + (divided #== (pconstant 0)) + (accLength #- (pconstant 1)) + (self # divided # (accLength #+ (pconstant 1))) + +checkLength :: Term s (PInteger :--> PInteger :--> PInteger) +checkLength = phoistAcyclic $ plam $ \origValue apLength -> + plet (ppow10 # (pconstant 10) # apLength) $ \upperBound -> + plet (pdiv # upperBound # (pconstant 10)) $ \lowerBound -> unTermCont $ do + pure (pif (lowerBound #<= origValue #&& origValue #< upperBound) + (apLength) + (perror)) + +roundToTest :: Term s (PInteger :--> PInteger :--> PInteger :--> PInteger) +roundToTest = phoistAcyclic $ plam $ \origValue roundIdx lengthTest -> unTermCont $ do + checkedLength <- tlet $ checkLength # origValue # lengthTest + denum <- tlet $ (ppow10 # (pconstant 10) # (checkedLength - roundIdx)) + roundingDenum <- tlet $ ptryPositive # denum + rational <- tlet $ (pcon $ PRational origValue roundingDenum) + pure $ pround # rational verifyGTValues :: - ClosedTerm + Term s ( PInteger :--> PInteger :--> PInteger :--> PInteger + :--> PInteger + :--> PInteger + :--> PInteger :--> PBool ) -verifyGTValues = plam $ \tokenBalance tokenWeight tokenG tokenT -> - let - tokenPrecision = pIntLength # tokenBalance - finalLeftValue = roundTo # tokenG # tokenPrecision - finalRightValue = roundTo # (ppow # tokenT # tokenWeight) # tokenPrecision - in finalLeftValue #== finalRightValue +verifyGTValues = plam $ \tokenBalance tokenBalanceLength tokenWeight tokenG tokenT tokenGLength tokenTPowWeightLength -> + plet (checkLength # tokenBalance # tokenBalanceLength) $ \_ -> + (roundToTest # tokenG # tokenBalanceLength # tokenGLength) #== (roundToTest # (ppow # tokenT # tokenWeight) # tokenBalanceLength # tokenTPowWeightLength) verifyGEquality :: - ClosedTerm + Term s ( PInteger :--> PInteger :--> PInteger :--> PInteger + :--> PInteger + :--> PInteger :--> PBool ) -verifyGEquality = plam $ \leftSideMultiplicator rightSideRaw tokenG tokenWeight -> +verifyGEquality = phoistAcyclic $ plam $ \leftSideMultiplicator rightSideRaw tokenG tokenWeight leftSideLength rightSideLength -> unTermCont $ do + degree <- tlet $ (pdiv # pDen # tokenWeight) + leftSideRaw <- tlet $ (ppow # tokenG # degree) #* leftSideMultiplicator + leftSide <- tlet $ roundToTest # leftSideRaw # rightSideLength # leftSideLength + gEDiff <- tlet $ leftSide - rightSideRaw let - tokenBalanceIntLength = pIntLength # rightSideRaw - - degree = pdiv # pDen # tokenWeight - - -- tokenG = rightSideNum ^ (tokenWeight / pDen) - -- leftSideRaw = tokenG ^ (pDen / tokenWeight) => leftSide == (rightSide +-1) - leftSideRaw = (ppow # tokenG # degree) * leftSideMultiplicator - leftSide = roundTo # leftSideRaw # tokenBalanceIntLength - rightSide = roundTo # rightSideRaw # tokenBalanceIntLength - - gEDiff = leftSide - rightSide validGEquality = pif - ( gEDiff #<= 0 ) - ( (-1) #<= gEDiff ) - ( gEDiff #<= (1) ) - in validGEquality + ( gEDiff #<= (pconstant 0) ) + ( (pconstant (-1)) #<= gEDiff ) + ( gEDiff #<= (pconstant 1) ) + + pure validGEquality verifyTExpEquality :: - ClosedTerm + Term s ( PInteger :--> PInteger + :--> PInteger + :--> PInteger :--> PBool ) -verifyTExpEquality = plam $ \tokenT rightSide -> - let - rightLength = pIntLength # rightSide - leftRounded = roundTo # (ppow # tokenT # 10) # rightLength - in leftRounded #== rightSide +verifyTExpEquality = phoistAcyclic $ + plam $ \tokenT rightSide rightSideLength tokenTPowLength -> unTermCont $ do + leftSideRounded <- tlet $ (roundToTest # (ppow # tokenT # pDen) # rightSideLength # tokenTPowLength) + delta <- tlet (leftSideRounded - rightSide) + tlet (checkLength # rightSide # rightSideLength) + let + validDelta = pif + ( delta #<= (pconstant 0) ) + ( (pconstant (-1)) #<= delta ) + ( delta #<= (pconstant 1) ) + + pure $ validDelta validGTAndTokenDeltaWithFees :: ClosedTerm @@ -223,39 +241,59 @@ validGTAndTokenDeltaWithFees :: :--> PInteger :--> PInteger :--> PInteger + :--> PInteger + :--> PInteger + :--> PInteger + :--> PInteger + :--> PInteger + :--> PInteger :--> PBool ) -validGTAndTokenDeltaWithFees = plam $ \prevTokenBalance tokenWeight tokenDelta tokenG tokenT fees -> - let - correctGandT = verifyGTValues # (prevTokenBalance + tokenDelta) # tokenWeight # tokenG # tokenT +validGTAndTokenDeltaWithFees = phoistAcyclic $ + -- leftSideMultiplicator = feeDen + -- leftSide = (ppow # tokenG # degree) #* leftSideMultiplicator + -- rightSide = (prevTokenBalance #* feeDen + tokenDelta #* fees) + plam $ \prevTokenBalance newTokenBalanceLength tokenWeight tokenDelta tokenG tokenGLength tokenT tokenTPowLength tokenTPowWeightLength leftSideLength rightSideLength fees -> + let + correctGandT = verifyGTValues # (prevTokenBalance #+ tokenDelta) # newTokenBalanceLength # tokenWeight # tokenG # tokenT # tokenGLength # tokenTPowWeightLength - correctTokenValue = pif - ( (pmod # pDen # tokenWeight) #== 0 ) - ( verifyGEquality # feeDen # (prevTokenBalance * feeDen + tokenDelta * fees) # tokenG # tokenWeight ) --( leftSide #== rightSide ) - ( verifyTExpEquality # tokenT # (prevTokenBalance * feeDen + tokenDelta * fees) ) + correctTokenValue = pif + ( (pmod # pDen # tokenWeight) #== (pconstant 0) ) + ( verifyGEquality # feeDen # (prevTokenBalance #* feeDen + tokenDelta #* fees) # tokenG # tokenWeight # leftSideLength # rightSideLength ) --( leftSide #== rightSide ) + ( verifyTExpEquality # tokenT # (prevTokenBalance #* feeDen + tokenDelta #* fees) # rightSideLength # tokenTPowLength ) - in correctGandT #&& correctTokenValue + in correctGandT #&& correctTokenValue -- Common task is validate G against T and new token value validGTAndTokenDeltaWithoutFees :: - ClosedTerm + Term s ( PInteger :--> PInteger :--> PInteger :--> PInteger :--> PInteger + :--> PInteger + :--> PInteger + :--> PInteger + :--> PInteger + :--> PInteger + :--> PInteger :--> PBool ) -validGTAndTokenDeltaWithoutFees = plam $ \prevTokenBalance tokenWeight tokenDelta tokenG tokenT -> - let - correctGandT = verifyGTValues # prevTokenBalance # tokenWeight # tokenG # tokenT +validGTAndTokenDeltaWithoutFees = phoistAcyclic $ + -- leftSideMultiplicator = (pconstant 1) + -- leftSide = (ppow # tokenG # degree) #* leftSideMultiplicator + -- rightSide = (prevTokenBalance + tokenDelta) + plam $ \prevTokenBalance prevTokenBalanceLength tokenWeight tokenDelta tokenG tokenGLength tokenT tokenTPowLength tokenTPowWeightLength leftSideLength rightSideLength -> + let + correctGandT = verifyGTValues # (prevTokenBalance + tokenDelta) # prevTokenBalanceLength # tokenWeight # tokenG # tokenT # tokenGLength # tokenTPowWeightLength - correctTokenValue = pif - ( (pmod # pDen # tokenWeight) #== 0 ) - ( verifyGEquality # 1 # (prevTokenBalance + tokenDelta) # tokenG # tokenWeight ) - ( verifyTExpEquality # tokenT # (prevTokenBalance + tokenDelta) ) + correctTokenValue = pif + ( (pmod # pDen # tokenWeight) #== (pconstant 0) ) + ( verifyGEquality # (pconstant 1) # (prevTokenBalance + tokenDelta) # tokenG # tokenWeight # leftSideLength # rightSideLength ) + ( verifyTExpEquality # tokenT # (prevTokenBalance + tokenDelta) # rightSideLength # tokenTPowLength ) - in correctGandT #&& correctTokenValue + in (correctGandT #&& correctTokenValue) validSwap :: ClosedTerm @@ -267,12 +305,25 @@ validSwap :: :--> PInteger :--> PInteger :--> PInteger + :--> PInteger + :--> PInteger + :--> PInteger + :--> PInteger + :--> PInteger + :--> PInteger + :--> PInteger + :--> PInteger + :--> PInteger + :--> PInteger + :--> PInteger + :--> PInteger + :--> PInteger :--> PBool ) -validSwap = plam $ \prevState' newState' prevPoolConfig newPoolConfig newGX newTx newGY newTy -> unTermCont $ do +validSwap = plam $ \prevState' newState' prevPoolConfig newPoolConfig newGX newTx newGY newTy gXgYLength newXBalanceLength newGXLength newTxPowLength newTxPowWeightLength leftSideLengthX rightSideLengthX newYBalanceLength newGYLength newTyPowLength newTyPowWeightLength leftSideLengthY rightSideLengthY -> unTermCont $ do prevState <- pletFieldsC @'["reservesX", "reservesY", "liquidity"] prevState' newState <- pletFieldsC @'["reservesX", "reservesY", "liquidity"] newState' - prevConfig <- pletFieldsC @'["poolNft", "poolX", "weightX", "poolY", "weightY", "poolLq", "feeNum", "treasuryFee", "treasuryX", "treasuryY", "DAOPolicy", "treasuryAddress", "invariant"] prevPoolConfig + prevConfig <- pletFieldsC @'["poolNft", "poolX", "weightX", "poolY", "weightY", "poolLq", "feeNum", "treasuryFee", "treasuryX", "treasuryY", "DAOPolicy", "treasuryAddress", "invariant", "invariantLength"] prevPoolConfig newConfig <- pletFieldsC @'["treasuryX", "treasuryY"] newPoolConfig let prevPoolNft = getField @"poolNft" prevConfig @@ -288,6 +339,7 @@ validSwap = plam $ \prevState' newState' prevPoolConfig newPoolConfig newGX newT prevDAOPolicy = getField @"DAOPolicy" prevConfig prevTreasuryAddress = getField @"treasuryAddress" prevConfig prevInvariant = getField @"invariant" prevConfig + invariantLength = getField @"invariantLength" prevConfig newTreasuryX = getField @"treasuryX" newConfig newTreasuryY = getField @"treasuryY" newConfig @@ -301,24 +353,41 @@ validSwap = plam $ \prevState' newState' prevPoolConfig newPoolConfig newGX newT newY = pfromData $ getField @"reservesY" newState newLq = pfromData $ getField @"liquidity" newState - dx = newX - prevX - dy = newY - prevY - dlq = newLq - prevLq + dx <- tlet $ newX - prevX + dy <- tlet $ newY - prevY + dlq <- tlet $ newLq - prevLq + + newInvarianRounded <- tlet $ roundToTest # (newGX #* newGY) # invariantLength # gXgYLength + invariantRoundingDiff <- tlet $ newInvarianRounded - prevInvariant - prevInvariantLength = pIntLength # prevInvariant - newInvarianRounded = roundTo # (newGX #* newGY) # prevInvariantLength - invariantRoundingDiff = newInvarianRounded - prevInvariant + let -- Verify that new value of invariant equals to previous newInvariantIsCorrect = pif - ( invariantRoundingDiff #<= 0 ) - ( (-1) #<= invariantRoundingDiff ) - ( invariantRoundingDiff #<= (1) ) + ( invariantRoundingDiff #<= (pconstant 0) ) + ( (pconstant (-1)) #<= invariantRoundingDiff ) + ( invariantRoundingDiff #<= (pconstant 1) ) + + -- g,t related to tokens with fees + + -- leftSideMultiplicator = feeDen + -- leftSide = (ppow # tokenG # degree) #* leftSideMultiplicator + -- rightSide = (prevTokenBalance #* feeDen + tokenDelta #* fees) + + -- without fees + -- leftSideMultiplicator = (pconstant 1) + -- leftSide = (ppow # tokenG # degree) #* leftSideMultiplicator + -- rightSide = (prevTokenBalance + tokenDelta) correctTokensUpdate = pif ( zero #< dx ) - ( (validGTAndTokenDeltaWithFees # prevX # weightX # dx # newGX # newTx # (feeNum - treasuryFee)) #&& (validGTAndTokenDeltaWithoutFees # prevY # weightY # dy # newGY # newTy) ) - ( (validGTAndTokenDeltaWithoutFees # prevX # weightX # dx # newGX # newTx) #&& (validGTAndTokenDeltaWithFees # prevY # weightY # dy # newGY # newTy # (feeNum - treasuryFee)) ) + ( + (validGTAndTokenDeltaWithFees # prevX # newXBalanceLength # weightX # dx # newGX # newGXLength # newTx # newTxPowLength # newTxPowWeightLength # leftSideLengthX # rightSideLengthX # (feeNum - treasuryFee)) + #&& (validGTAndTokenDeltaWithoutFees # prevY # newYBalanceLength # weightY # dy # newGY # newGYLength # newTy # newTyPowLength # newTyPowWeightLength # leftSideLengthY # rightSideLengthY) + ) + ( (validGTAndTokenDeltaWithoutFees # prevX # newXBalanceLength # weightX # dx # newGX # newGXLength # newTx # newTxPowLength # newTxPowWeightLength # leftSideLengthX # rightSideLengthX) + #&& (validGTAndTokenDeltaWithFees # prevY # newYBalanceLength # weightY # dy # newGY # newGYLength # newTy # newTyPowLength # newTyPowWeightLength # leftSideLengthY # rightSideLengthY # (feeNum - treasuryFee)) + ) correctTreasuryUpdate = pif @@ -341,6 +410,7 @@ validSwap = plam $ \prevState' newState' prevPoolConfig newPoolConfig newGX newT #$ pdcons @"DAOPolicy" @(PBuiltinList (PAsData PStakingCredential)) # pdata prevDAOPolicy #$ pdcons @"treasuryAddress" @PValidatorHash # pdata prevTreasuryAddress #$ pdcons @"invariant" @PInteger # pdata prevInvariant + #$ pdcons @"invariantLength" @PInteger # pdata invariantLength # pdnil) pure $ @@ -366,47 +436,34 @@ correctLpTokenDelta :: :--> PInteger :--> PInteger :--> PInteger - :--> PInteger - :--> PInteger - :--> PInteger :--> PBool ) -correctLpTokenDelta = plam $ \lpIssued lpDelta tokenDelta tokenBalance tokenWeight tokenG tokenT -> - let - calcTokenDelta = (pdiv # (lpDelta #* tokenBalance) # lpIssued) - - tokensDiff = calcTokenDelta - tokenDelta - +correctLpTokenDelta = plam $ \lpIssued lpDelta tokenDelta tokenBalance -> unTermCont $ do + calcTokenDelta <- tlet (pdiv # (lpDelta #* tokenBalance) # lpIssued) + tokensDiff <- tlet (calcTokenDelta - tokenDelta) + let correctTokenError = pif - ( tokensDiff #<= 0 ) - ( (-1) #<= tokensDiff ) - ( tokensDiff #<= (1) ) + ( tokensDiff #<= (pconstant 0) ) + ( (pconstant (-1)) #<= tokensDiff ) + ( tokensDiff #<= (pconstant 1) ) correctTokenIn = correctTokenError #&& (calcTokenDelta #<= tokenDelta) - correctTokenValue = pif - ( (pmod # pDen # tokenWeight) #== 0 ) - ( verifyGEquality # 1 # (tokenBalance + tokenDelta) # tokenG # tokenWeight ) - ( verifyTExpEquality # tokenT # (tokenBalance + tokenDelta) ) - - in correctTokenIn #&& correctTokenValue + pure $ correctTokenIn validDepositRedeemAllTokens :: ClosedTerm ( BalancePoolState :--> BalancePoolState :--> BalancePoolConfig - :--> BalancePoolConfig - :--> PInteger - :--> PInteger - :--> PInteger - :--> PInteger + :--> BalancePoolConfig :--> PBool ) -validDepositRedeemAllTokens = plam $ \prevState' newState' prevPoolConfig newPoolConfig newGX newTx newGY newTy -> unTermCont $ do +validDepositRedeemAllTokens = plam $ \prevState' newState' prevPoolConfig newPoolConfig -> unTermCont $ do prevState <- pletFieldsC @'["reservesX", "reservesY", "liquidity"] prevState' newState <- pletFieldsC @'["reservesX", "reservesY", "liquidity"] newState' - prevConfig <- pletFieldsC @'["poolNft", "poolX", "weightX", "poolY", "weightY", "poolLq", "feeNum", "treasuryFee", "treasuryX", "treasuryY", "DAOPolicy", "treasuryAddress", "invariant"] prevPoolConfig + prevConfig <- pletFieldsC @'["poolNft", "poolX", "weightX", "poolY", "weightY", "poolLq", "feeNum", "treasuryFee", "treasuryX", "treasuryY", "DAOPolicy", "treasuryAddress", "invariant", "invariantLength"] prevPoolConfig + newConfig <- pletFieldsC @'["invariant", "invariantLength"] newPoolConfig let prevPoolNft = getField @"poolNft" prevConfig prevPoolX = getField @"poolX" prevConfig @@ -420,7 +477,11 @@ validDepositRedeemAllTokens = plam $ \prevState' newState' prevPoolConfig newPoo prevTreasuryY = getField @"treasuryY" prevConfig prevDAOPolicy = getField @"DAOPolicy" prevConfig prevTreasuryAddress = getField @"treasuryAddress" prevConfig + prevInvariant = getField @"invariant" prevConfig + newInvariant = getField @"invariant" newConfig + newInvariantLength = getField @"invariantLength" newConfig + prevX = pfromData $ getField @"reservesX" prevState prevY = pfromData $ getField @"reservesY" prevState prevLq = pfromData $ getField @"liquidity" prevState @@ -429,15 +490,25 @@ validDepositRedeemAllTokens = plam $ \prevState' newState' prevPoolConfig newPoo newY = pfromData $ getField @"reservesY" newState newLq = pfromData $ getField @"liquidity" newState - dx = newX - prevX - dy = newY - prevY - dlq = newLq - prevLq + dx <- tlet $ newX - prevX + dy <- tlet $ newY - prevY + dlq <- tlet $ newLq - prevLq + + let + newCalculatedInvariant = pdiv # ((prevX + dx) #* prevInvariant) # prevX + + invariantroundUpIsNecessary = 0 #< (pmod # ((prevX + dx) #* prevInvariant) # prevX) - xDepositRedeemIsValid = correctLpTokenDelta # prevLq # dlq # dx # prevX # weightX # newGX # newTx - yDepositRedeemIsValid = correctLpTokenDelta # prevLq # dlq # dy # prevY # weightY # newGY # newTy + normalizedInvariant = + pif (invariantroundUpIsNecessary) + (newCalculatedInvariant #+ 1) + (newCalculatedInvariant) + + xDepositRedeemIsValid = correctLpTokenDelta # prevLq # dlq # dx # prevX + yDepositRedeemIsValid = correctLpTokenDelta # prevLq # dlq # dy # prevY + + tlet (checkLength # newInvariant # newInvariantLength) - newInvariant = newGX * newGY - newExpectedConfig <- tcon $ (BalancePoolConfig $ pdcons @"poolNft" @PAssetClass # pdata prevPoolNft @@ -453,35 +524,16 @@ validDepositRedeemAllTokens = plam $ \prevState' newState' prevPoolConfig newPoo #$ pdcons @"DAOPolicy" @(PBuiltinList (PAsData PStakingCredential)) # pdata prevDAOPolicy #$ pdcons @"treasuryAddress" @PValidatorHash # pdata prevTreasuryAddress #$ pdcons @"invariant" @PInteger # pdata newInvariant + #$ pdcons @"invariantLength" @PInteger # pdata newInvariantLength # pdnil) pure $ - ( xDepositRedeemIsValid + ( normalizedInvariant #== newInvariant + #&& xDepositRedeemIsValid #&& yDepositRedeemIsValid #&& newPoolConfig #== newExpectedConfig ) -correctLpTokenRedeem :: - ClosedTerm - ( PInteger - :--> PInteger - :--> PInteger - :--> PInteger - :--> PInteger - :--> PInteger - :--> PInteger - :--> PBool - ) -correctLpTokenRedeem = plam $ \lpIssued lpRedeemed tokenOut tokenBalance tokenWeight tokenG tokenT -> - let - correctTokenOut = (1 - (pdiv # (lpIssued - lpRedeemed) # lpIssued)) #* tokenBalance - correctTokenDelta = - pif - ( (pmod # pDen # tokenWeight) #== 0 ) - ( tokenOut #== tokenBalance - (ppow # tokenG # (pdiv # pDen # tokenWeight)) ) - ( tokenOut #== tokenBalance - (ppow # tokenT # tokenWeight) ) - in tokenOut #== correctTokenOut #&& correctTokenDelta - readPoolState :: Term s (BalancePoolConfig :--> PTxOut :--> BalancePoolState) readPoolState = phoistAcyclic $ plam $ \conf' out -> unTermCont $ do @@ -510,7 +562,7 @@ readPoolState = phoistAcyclic $ balancePoolValidatorT :: ClosedTerm (BalancePoolConfig :--> BalancePoolRedeemer :--> PScriptContext :--> PBool) balancePoolValidatorT = plam $ \conf redeemer' ctx' -> unTermCont $ do - redeemer <- pletFieldsC @'["action", "selfIx", "g", "t", "maxDen"] redeemer' + redeemer <- pletFieldsC @'["action", "selfIx", "g", "t", "lengths"] redeemer' let selfIx = getField @"selfIx" redeemer action = getField @"action" redeemer @@ -518,6 +570,8 @@ balancePoolValidatorT = plam $ \conf redeemer' ctx' -> unTermCont $ do gList = getField @"g" redeemer tList = getField @"t" redeemer + lList = getField @"lengths" redeemer + ctx <- pletFieldsC @'["txInfo", "purpose"] ctx' let txinfo' = getField @"txInfo" ctx @@ -563,21 +617,33 @@ balancePoolValidatorT = plam $ \conf redeemer' ctx' -> unTermCont $ do noMoreTokens = selfValueLength #== succesorValueLength - newConfig = parseDatum # succD + newConfig = parseDatum # succD pure $ selfIdentity #&& (pmatch action $ \case Swap -> unTermCont $ do + gx <- tletUnwrap $ phead # gList gy <- tletUnwrap $ pelemAt # (pconstant 1) # gList tx <- tletUnwrap $ phead # tList ty <- tletUnwrap $ pelemAt # (pconstant 1) # tList - pure $ noMoreTokens #&& scriptPreserved #&& (validSwap # s0 # s1 # conf # newConfig # gx # tx # gy # ty) + + -- Parsing length list + gXgYLength <- tletUnwrap $ phead # lList + newXBalanceLength <- tletUnwrap $ pelemAt # (pconstant 1) # lList + newGXLength <- tletUnwrap $ pelemAt # (pconstant 2) # lList + newTxPowLength <- tletUnwrap $ pelemAt # (pconstant 3) # lList + newTxPowWeightLength <- tletUnwrap $ pelemAt # (pconstant 4) # lList + leftSideLengthX <- tletUnwrap $ pelemAt # (pconstant 5) # lList + rightSideLengthX <- tletUnwrap $ pelemAt # (pconstant 6) # lList + newYBalanceLength <- tletUnwrap $ pelemAt # (pconstant 7) # lList + newGYLength <- tletUnwrap $ pelemAt # (pconstant 8) # lList + newTyPowLength <- tletUnwrap $ pelemAt # (pconstant 9) # lList + newTyPowWeightLength <- tletUnwrap $ pelemAt # (pconstant 10) # lList + leftSideLengthY <- tletUnwrap $ pelemAt # (pconstant 11) # lList + rightSideLengthY <- tletUnwrap $ pelemAt # (pconstant 12) # lList + + pure $ noMoreTokens #&& scriptPreserved #&& (validSwap # s0 # s1 # conf # newConfig # gx # tx # gy # ty # gXgYLength # newXBalanceLength # newGXLength # newTxPowLength # newTxPowWeightLength # leftSideLengthX # rightSideLengthX # newYBalanceLength # newGYLength # newTyPowLength # newTyPowWeightLength # leftSideLengthY # rightSideLengthY) DAOAction -> validDAOAction # conf # txinfo' - _ -> unTermCont $ do - gx <- tletUnwrap $ phead # gList - gy <- tletUnwrap $ pelemAt # (pconstant 1) # gList - tx <- tletUnwrap $ phead # tList - ty <- tletUnwrap $ pelemAt # (pconstant 1) # tList - pure $ noMoreTokens #&& scriptPreserved #&& (validDepositRedeemAllTokens # s0 # s1 # conf # newConfig # gx # tx # gy # ty) + _ -> noMoreTokens #&& scriptPreserved #&& (validDepositRedeemAllTokens # s0 # s1 # conf # newConfig) ) \ No newline at end of file diff --git a/plutarch-validators/WhalePoolsDex/PContracts/PPoolBFee.hs b/plutarch-validators/WhalePoolsDex/PContracts/PPoolBFee.hs index 1e09d1f..de51396 100644 --- a/plutarch-validators/WhalePoolsDex/PContracts/PPoolBFee.hs +++ b/plutarch-validators/WhalePoolsDex/PContracts/PPoolBFee.hs @@ -265,7 +265,6 @@ poolBFeeValidatorT = plam $ \conf redeemer' ctx' -> unTermCont $ do (zero #< dx) (-dy * (rx0 * feeDen' + dxf) #<= ry0 * dxf) (-dx * (ry0 * feeDen' + dyf) #<= rx0 * dyf) - ptraceC $ pshow validSwap pure $ noMoreTokens #&& swapAllowed #&& scriptPreserved #&& dlq #== 0 #&& validSwap #&& validTreasury -- liquidity left intact and swap is performed properly DAOAction -> validDAOAction # conf # txinfo' _ -> unTermCont $ do diff --git a/plutarch-validators/test/Eval.hs b/plutarch-validators/test/Eval.hs index 06af911..cea2a9a 100644 --- a/plutarch-validators/test/Eval.hs +++ b/plutarch-validators/test/Eval.hs @@ -4,7 +4,7 @@ module Eval where import Plutarch.Prelude import PExtra.API import Data.Text (Text, pack) -import Plutarch.Evaluate (evalScript, EvalError, evalTerm, evalScriptHuge) +import Plutarch.Evaluate (evalScript, EvalError, evalTerm) import Plutarch (ClosedTerm, compile, Config(..), TracingMode (..)) import PlutusLedgerApi.V1 (Data, ExBudget) import PlutusLedgerApi.V1.Scripts (Script (unScript), applyArguments) @@ -19,7 +19,7 @@ evalConfig = Config NoTracing evalWithArgs :: ClosedTerm a -> [Data] -> Either Text (ExBudget, [Text], Program DeBruijn DefaultUni DefaultFun ()) evalWithArgs x args = do cmp <- compile evalConfig x - let (escr, budg, trc) = evalScriptHuge $ applyArguments cmp args + let (escr, budg, trc) = evalScript $ applyArguments cmp args 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 ba22ba3..ec48b80 100644 --- a/plutarch-validators/test/Gen/BalancePoolGen.hs +++ b/plutarch-validators/test/Gen/BalancePoolGen.hs @@ -54,6 +54,7 @@ data BalancePoolActionResult = BalancePoolActionResult , additionalOutputs :: [TxOut] , g :: [Integer] , t :: [Integer] + , lList :: [Integer] } deriving Show data BalancePoolTestAction m = BalancePoolTestAction @@ -138,18 +139,16 @@ genBalancePool adminsPkhs threshold lpFeeIsEditable = do stakeHash <- genPkh -- todo: error on big values such as 10 000 000 000 000 000 - (yQty :: Int) <- integral (Range.constant 10000000000 10000000000000000) + (yQty :: Integer) <- integral (Range.constant 10000000000 10000000000000000) - (xWeight :: Integer) <- integral (Range.constant 1 5) + (xWeight :: Integer) <- integral (Range.constant 1 4) (xQty :: Integer) <- integral (Range.constant 1000000000 1000000000000) poolFee <- integral (Range.constant 80000 feeDen) trFee <- integral (Range.constant 1 1000) treasuryAddress <- genValidatorHash let - yWeight = 10 - xWeight - - yQty = xQty * yWeight - nftQty = 1 + yWeight = 5 - xWeight + nftQty = 1 xQtyFloat = (fromIntegral xQty) :: Double yQtyFloat = (fromIntegral yQty) :: Double @@ -159,7 +158,7 @@ genBalancePool adminsPkhs threshold lpFeeIsEditable = do maxPrecision = (if (yPartLength > xValueLength) then yPartLength else xValueLength) + precisionAdditionalDec - invariantT = ((BigDecimal xQty 0) ** (fromRational $ (fromIntegral xWeight) / 10)) * ( (BigDecimal yQty 0) ** (fromRational $ (fromIntegral yWeight) / 10)) + invariantT = ((BigDecimal xQty 0) ** (fromRational $ (fromIntegral xWeight) / 5)) * ( (BigDecimal yQty 0) ** (fromRational $ (fromIntegral yWeight) / 5)) invariant = getDecimalNum invariantT lqQty = 0x7fffffffffffffff - invariant @@ -167,7 +166,7 @@ genBalancePool adminsPkhs threshold lpFeeIsEditable = do daoContract = StakingHash . ScriptCredential . ValidatorHash . getScriptHash . scriptHash $ (unMintingPolicyScript (daoMintPolicyValidator nft adminsPkhs threshold lpFeeIsEditable)) - leftSide = (BigDecimal invariant 0) / ((BigDecimal xQty 0) ** (fromRational $ (fromIntegral xWeight) / 10)) + leftSide = (BigDecimal invariant 0) / ((BigDecimal xQty 0) ** (fromRational $ (fromIntegral xWeight) / 5)) let poolConfig = BalancePoolConfig @@ -184,16 +183,18 @@ genBalancePool adminsPkhs threshold lpFeeIsEditable = do , daoPolicy = [daoContract] , treasuryAddress = treasuryAddress , invariant = invariant + , invariantLength = toInteger . T.length . T.pack $ show invariant } poolValue = mkValues ((\(ac, qty) -> mkValue ac (fromIntegral qty)) `RIO.map` [(x, xQty), (y, yQty), (nft, nftQty), (lq, lqQty)]) mempty + 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 +calculateGandTSwap :: MonadGen m => Integer -> Integer -> Integer -> Integer -> Integer -> Integer -> Integer -> Integer -> Integer -> Integer -> m (Integer, Integer, Integer, Integer, Integer, [Integer]) +calculateGandTSwap baseAssetBalance baseAssetWeight baseTreasury quoteAssetBalance quoteAssetWeghit quoteTreasury baseIn lpFee treasuryFee prevInvariant = do let yPartLength = toInteger $ RIO.length . show $ quoteAssetBalance xValueLength = toInteger $ RIO.length . show $ (baseAssetBalance + baseIn) @@ -202,7 +203,7 @@ calculateGandTSwap baseAssetBalance baseAssetWeight quoteAssetBalance quoteAsset invariantLength = toInteger $ RIO.length . show $ prevInvariant - xValueFloat = (fromIntegral baseAssetBalance) :: BigDecimal + xValueFloat = (fromIntegral (baseAssetBalance - baseTreasury)) :: BigDecimal invariantFloat = (BigDecimal prevInvariant 0) :: BigDecimal xWeightFloat = (fromIntegral baseAssetWeight) :: BigDecimal yValueFloat = (fromIntegral quoteAssetBalance) :: BigDecimal @@ -214,46 +215,52 @@ calculateGandTSwap baseAssetBalance baseAssetWeight quoteAssetBalance quoteAsset -- 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 + xInInvariantWithDegree = (xInInvariantBigDecimal ** (fromRational $ ((fromIntegral baseAssetWeight) / 5))) -- g + xInInvariantWith1Degree = (xInInvariantBigDecimal) ** (fromRational $ (1 / 5)) -- 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)) + test = xInInvariantWithDegree * invDivision + invDivisionInReverseDegree = nthRoot (invDivision ** 5) (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 + gYDouble = ((BigDecimal (quoteAssetBalance - yToSwap) 0) ** (fromRational $ (fromIntegral quoteAssetWeghit) / 5)) :: BigDecimal -- g + tGDouble = (((BigDecimal (quoteAssetBalance - yToSwap) 0) ** (fromRational $ (1 / 5)))) :: BigDecimal -- g - gY = takeNBigDecimal gYDouble (maxPrecision) -- ((getValue gYDouble)) - tY = takeNBigDecimal tGDouble (maxPrecision) -- ((getValue tGDouble)) + gY = takeNBigDecimal gYDouble (maxPrecision) + tY = takeNBigDecimal tGDouble (maxPrecision) 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) + gXgYLength = toInteger $ T.length . T.pack $ show (gX * gY) + newXBalanceLength = toInteger $ T.length . T.pack $ show (baseAssetBalance + baseIn) + newGXLength = toInteger $ T.length . T.pack $ show gX + newTxPowLength = toInteger $ T.length . T.pack $ show (tX ^ 5) + newTxPowWeightLength = toInteger $ T.length . T.pack $ show (tX ^ baseAssetWeight) + leftSideLengthX = toInteger $ T.length . T.pack $ show ((gX ^ 5) * 100000) -- degree = 5 + rightSideLengthX = toInteger $ T.length . T.pack $ show ((baseAssetBalance * feeDen + baseIn * ((lpFee - treasuryFee)))) + newYBalanceLength = toInteger $ T.length . T.pack $ show (quoteAssetBalance - yToSwap) + newGYLength = toInteger $ T.length . T.pack $ show gY + newTyPowLength = toInteger $ T.length . T.pack $ show (tY ^ 5) + newTyPowWeightLength = toInteger $ T.length . T.pack $ show (tY ^ quoteAssetWeghit) + leftSideLengthY = if (quoteAssetWeghit == 1) then (toInteger $ T.length . T.pack $ show ((gY ^ 5) * 1)) else (toInteger $ T.length . T.pack $ show ((gY ^ 5) * baseAssetWeight)) + rightSideLengthY = toInteger $ T.length . T.pack $ show (quoteAssetBalance - yToSwap) + + pure (gX, tX, gY, tY, yToSwap, [gXgYLength, newXBalanceLength, newGXLength, newTxPowLength, newTxPowWeightLength, leftSideLengthX, rightSideLengthX, newYBalanceLength, newGYLength, newTyPowLength, newTyPowWeightLength, leftSideLengthY, rightSideLengthY]) -- 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 :: MonadGen m => Integer -> Integer -> Integer -> Integer -> Integer -> Integer -> Integer -> Integer -> Integer -> m (Integer, Integer, Integer, Integer, Integer, Integer, Integer, [Integer], Integer) calculateGandTDeposit baseAssetBalance baseAssetWeight quoteAssetBalance quoteAssetWeghit lqIssued lqSupply lpFee treasuryFee prevInvariant = do let + lqSupplyDouble = (fromIntegral lqSupply) :: BigDecimal 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 @@ -261,29 +268,67 @@ calculateGandTDeposit baseAssetBalance baseAssetWeight quoteAssetBalance quoteAs yWeightFloat = (fromIntegral quoteAssetWeghit) :: BigDecimal treasuryFeeNum = (fromIntegral treasuryFee) :: BigDecimal lpFeeNum = (fromIntegral lpFee) :: BigDecimal - lqSupplyDouble = (fromIntegral lqSupply) :: BigDecimal + xToDeposit = roundBD ((lqIssuedDec * xValueFloat) / lqSupplyDouble) (DOWN, (Just . toInteger $ 0)) + yToDeposit = roundBD ((lqIssuedDec * yValueFloat) / lqSupplyDouble) (DOWN, (Just . toInteger $ 0)) + + yPartLength = toInteger $ RIO.length . show $ (quoteAssetBalance + (getDecimalNum yToDeposit)) + xValueLength = toInteger $ RIO.length . show $ (baseAssetBalance + (getDecimalNum xToDeposit)) + + maxPrecision = (if (yPartLength > xValueLength) then yPartLength else xValueLength) + precisionAdditionalDec -- 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 + xInInvariantWithDegree = (xInInvariantBigDecimal ** (fromRational $ ((fromIntegral baseAssetWeight) / 5))) -- g + xInInvariantWith1Degree = (xInInvariantBigDecimal) ** (fromRational $ (1 / 5)) -- 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 + gYDouble = nthRoot (gBaseRounded ** yWeightFloat) 5 (UP, (Just . toInteger $ maxPrecision)) :: BigDecimal -- g - tGDoubleTest = nthRoot gBaseRounded 10 (DOWN, (Just . toInteger $ maxPrecision)) - tGDouble = nthRoot gBaseRounded 10 (DOWN, (Just . toInteger $ maxPrecision)) + tGDoubleTest = nthRoot gBaseRounded 5 (DOWN, (Just . toInteger $ maxPrecision)) + tGDouble = nthRoot gBaseRounded 5 (DOWN, (Just . toInteger $ maxPrecision)) gY = takeNBigDecimal gYDouble (maxPrecision) tY = takeNBigDecimal tGDouble (maxPrecision) - pure (gX, tX, gY, tY, getDecimalNum xToDeposit, getDecimalNum yToDeposit, getDecimalNum lqIssuedDec) + xToAdd = getDecimalNum xToDeposit + yToAdd = getDecimalNum yToDeposit -calculateGandTRedeem :: MonadGen m => Integer -> Integer -> Integer -> Integer -> Integer -> Integer -> Integer -> Integer -> Integer -> m (Integer, Integer, Integer, Integer, Integer, Integer) + gXgYLength = toInteger $ T.length . T.pack $ show (gX * gY) + newXBalanceLength = toInteger $ T.length . T.pack $ show (baseAssetBalance + xToAdd) + newGXLength = toInteger $ T.length . T.pack $ show gX + newTxPowLength = toInteger $ T.length . T.pack $ show (tX ^ 5) + newTxPowWeightLength = toInteger $ T.length . T.pack $ show (tX ^ baseAssetWeight) + leftSideLengthX = if (quoteAssetWeghit == 1) then (toInteger $ T.length . T.pack $ show ((gX ^ 5) * 1)) else (toInteger $ T.length . T.pack $ show ((gX ^ 5) * 1)) + rightSideLengthX = toInteger $ T.length . T.pack $ show (baseAssetBalance + xToAdd) + newYBalanceLength = toInteger $ T.length . T.pack $ show (quoteAssetBalance + yToAdd) + newGYLength = toInteger $ T.length . T.pack $ show gY + newTyPowLength = toInteger $ T.length . T.pack $ show (tY ^ 5) + newTyPowWeightLength = toInteger $ T.length . T.pack $ show (tY ^ quoteAssetWeghit) + leftSideLengthY = if (quoteAssetWeghit == 1) then (toInteger $ T.length . T.pack $ show ((gY ^ 5) * 1)) else (toInteger $ T.length . T.pack $ show ((gY ^ 5) * 1)) + rightSideLengthY = toInteger $ T.length . T.pack $ show (quoteAssetBalance + yToAdd) + + invariantT = ((BigDecimal (baseAssetBalance + xToAdd) 0) ** (fromRational $ (fromIntegral baseAssetWeight) / 5)) * ( (BigDecimal (quoteAssetBalance + yToAdd) 0) ** (fromRational $ (fromIntegral quoteAssetWeghit) / 5)) + invariant = getDecimalNum invariantT + + newBalance = BigDecimal (baseAssetBalance + xToAdd) 0 + prevBalance = BigDecimal baseAssetBalance 0 + prevInvarianBD = BigDecimal prevInvariant 0 + + newInvariant = ((baseAssetBalance + xToAdd) * prevInvariant) `div` baseAssetBalance + + additional = if ((((baseAssetBalance + xToAdd) * prevInvariant) `mod` baseAssetBalance) == 0) then 0 else 1 + + normalizedNeInvariant = newInvariant + additional + + normalizedNeInvariantLength = toInteger $ T.length . T.pack $ show normalizedNeInvariant + + pure (gX, tX, gY, tY, getDecimalNum xToDeposit, getDecimalNum yToDeposit, getDecimalNum lqIssuedDec, [normalizedNeInvariantLength, newXBalanceLength, newGXLength, newTxPowLength, newTxPowWeightLength, leftSideLengthX, rightSideLengthX, newYBalanceLength, newGYLength, newTyPowLength, newTyPowWeightLength, leftSideLengthY, rightSideLengthY], normalizedNeInvariant) + +calculateGandTRedeem :: MonadGen m => Integer -> Integer -> Integer -> Integer -> Integer -> Integer -> Integer -> Integer -> Integer -> m (Integer, Integer, Integer, Integer, Integer, Integer, Integer, Integer) calculateGandTRedeem baseAssetBalance baseAssetWeight quoteAssetBalance quoteAssetWeghit lqRedeem lqSupply lpFee treasuryFee prevInvariant = do let lqRedeemDec = (fromIntegral lqRedeem) :: BigDecimal @@ -292,6 +337,7 @@ calculateGandTRedeem baseAssetBalance baseAssetWeight quoteAssetBalance quoteAss yPartLength = toInteger $ RIO.length . show $ quoteAssetBalance xValueLength = toInteger $ RIO.length . show $ (xValueFloat - xToRedeem) + xToRedeemDN = getDecimalNum xToRedeem maxPrecision = (if (yPartLength > xValueLength) then yPartLength else xValueLength) @@ -322,7 +368,15 @@ calculateGandTRedeem baseAssetBalance baseAssetWeight quoteAssetBalance quoteAss gY = takeNBigDecimal gYDouble (maxPrecision) tY = takeNBigDecimal tGDouble (maxPrecision) - pure (gX, tX, gY, tY, getDecimalNum xToRedeem, getDecimalNum yToRedeem) + newInvariant = ((baseAssetBalance - xToRedeemDN) * prevInvariant) `div` baseAssetBalance + + additional = if ((((baseAssetBalance - xToRedeemDN) * prevInvariant) `mod` baseAssetBalance) == 0) then 0 else 1 + + normalizedNeInvariant = newInvariant + additional + + normalizedNeInvariantLength = toInteger $ T.length . T.pack $ show normalizedNeInvariant + + pure (gX, tX, gY, tY, getDecimalNum xToRedeem, getDecimalNum yToRedeem, normalizedNeInvariant, normalizedNeInvariantLength) --- Test cases --- @@ -345,7 +399,7 @@ correctSwap = xValue = valueOf value xCS xTN yValue = valueOf value yCS yTN xToSwap <- integral (Range.constant 100 xValue) - (gX, tX, gY, tY, yToSwap) <- calculateGandTSwap xValue (weightX config) yValue (weightY config) (xToSwap) (poolFeeNum config) (treasuryFee config) (invariant config) + (gX, tX, gY, tY, yToSwap, llist) <- calculateGandTSwap xValue (weightX config) (treasuryX config) yValue (weightY config) (treasuryY config) (xToSwap) (poolFeeNum config) (treasuryFee config) (invariant config) let -- going to withdraw all pool x and y value tFee = treasuryFee config @@ -360,7 +414,7 @@ correctSwap = , value = value <> (assetClassValue (poolX config) (xToSwap)) <> (assetClassValue (poolY config) (negate yToSwap)) } - pure $ BalancePoolActionResult newPool [] [gX, gY] [tX, tY] + pure $ BalancePoolActionResult newPool [] [gX, gY] [tX, tY] llist in BalancePoolTestAction "Correct swap" testAction incorrectSwapGT :: MonadGen m => BalancePoolTestAction m @@ -375,13 +429,13 @@ incorrectSwapGT = 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) + (gX, tX, gY, tY, yToSwap, llist) <- calculateGandTSwap xValue (weightX config) (treasuryX config) yValue (weightY config) (treasuryY 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] + pure $ BalancePoolActionResult newPool [] [gX, gY] [tX, tY] [] in BalancePoolTestAction "Incorrect swap GT" testAction incorrectSwapPoolFinalXValue :: MonadGen m => BalancePoolTestAction m @@ -397,7 +451,7 @@ incorrectSwapPoolFinalXValue = 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) + (gX, tX, gY, tY, yToSwap, llist) <- calculateGandTSwap xValue (weightX config) (treasuryX config) yValue (weightY config) (treasuryY config) (xToSwap) (poolFeeNum config) (treasuryFee config) (invariant config) let tFee = treasuryFee config @@ -410,7 +464,7 @@ incorrectSwapPoolFinalXValue = { value = value <> (assetClassValue (poolX config) (incorrectXSwapValue)) <> (assetClassValue (poolY config) (negate yToSwap)) } - pure $ BalancePoolActionResult newPool [] [gX, gY] [tX, tY] + pure $ BalancePoolActionResult newPool [] [gX, gY] [tX, tY] [] in BalancePoolTestAction "Incorrect pool x final value" testAction incorrectSwapPoolFinalYValue :: MonadGen m => BalancePoolTestAction m @@ -426,7 +480,7 @@ incorrectSwapPoolFinalYValue = 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) + (gX, tX, gY, tY, yToSwap, llist) <- calculateGandTSwap xValue (weightX config) (treasuryX config) yValue (weightY config) (treasuryY config) (xToSwap) (poolFeeNum config) (treasuryFee config) (invariant config) let -- going to withdraw all pool x and y value @@ -441,7 +495,7 @@ incorrectSwapPoolFinalYValue = { value = value <> (assetClassValue (poolX config) (xToSwap)) <> (assetClassValue (poolY config) (negate incorrectYFinalValue)) } - pure $ BalancePoolActionResult newPool [] [gX, gY] [tX, tY] + pure $ BalancePoolActionResult newPool [] [gX, gY] [tX, tY] [] in BalancePoolTestAction "Incorrect pool y final value" testAction incorrectSwapTrFeeValue :: MonadGen m => BalancePoolTestAction m @@ -456,7 +510,7 @@ incorrectSwapTrFeeValue = 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) + (gX, tX, gY, tY, yToSwap, llist) <- calculateGandTSwap xValue (weightX config) (treasuryX config) yValue (weightY config) (treasuryY config) (xToSwap) (poolFeeNum config) (treasuryFee config) (invariant config) let treasuryFee_ = treasuryFee config newPoolConfig = config @@ -467,7 +521,7 @@ incorrectSwapTrFeeValue = , value = value <> (assetClassValue (poolX config) (xToSwap)) <> (assetClassValue (poolY config) (negate yToSwap)) } - pure $ BalancePoolActionResult newPool [] [gX, gY] [tX, tY] + pure $ BalancePoolActionResult newPool [] [gX, gY] [tX, tY] [] in BalancePoolTestAction "Incorrect pool treasury X final value" testAction -- Swap cases end -- @@ -490,16 +544,13 @@ correctDeposit = 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) + (gX, tX, gY, tY, xToDeposit, yToDeposit, lqIssued, llist, newInvariant) <- 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 + { invariant = newInvariant + , invariantLength = Prelude.head llist } newPool = prevPool @@ -507,7 +558,7 @@ correctDeposit = , value = value <> (assetClassValue (poolX config) (xToDeposit)) <> (assetClassValue (poolY config) (yToDeposit)) <> (assetClassValue (poolLq config) (negate lqIssued)) } - pure $ BalancePoolActionResult newPool [] [gX, gY] [tX, tY] + pure $ BalancePoolActionResult newPool [] [gX, gY] [tX, tY] llist in BalancePoolTestAction "Correct deposit all tokens" testAction incorrectDepositLqOut :: MonadGen m => BalancePoolTestAction m @@ -526,11 +577,9 @@ incorrectDepositLqOut = 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) + (gX, tX, gY, tY, xToDeposit, yToDeposit, lqIssued, llist, newInvariant) <- 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 @@ -543,7 +592,7 @@ incorrectDepositLqOut = , value = value <> (assetClassValue (poolX config) (xToDeposit)) <> (assetClassValue (poolY config) (yToDeposit)) <> (assetClassValue (poolLq config) (negate (lqIssued + 1000))) } - pure $ BalancePoolActionResult newPool [] [gX, gY] [tX, tY] + pure $ BalancePoolActionResult newPool [] [gX, gY] [tX, tY] llist in BalancePoolTestAction "Incorrect deposit all tokens. Incorrect lq out" testAction -- Deposit all cases end -- @@ -563,18 +612,15 @@ 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)) - (gX, tX, gY, tY, xToRedeem, yToRedeem) <- calculateGandTRedeem xValue (weightX config) yValue (weightY config) (lqToRedeem) lqIssued (poolFeeNum config) (treasuryFee config) (invariant config) + (gX, tX, gY, tY, xToRedeem, yToRedeem, newInvariant, newInvariantLength) <- 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 + , invariantLength = newInvariantLength } newPool = prevPool @@ -582,7 +628,7 @@ correctRedeem = , value = value <> (assetClassValue (poolX config) (negate xToRedeem)) <> (assetClassValue (poolY config) (negate yToRedeem)) <> (assetClassValue (poolLq config) (lqToRedeem)) } - pure $ BalancePoolActionResult newPool [] [gX, gY] [tX, tY] + pure $ BalancePoolActionResult newPool [] [gX, gY] [tX, tY] [] in BalancePoolTestAction "Correct redeem all tokens" testAction incorrectRedeemLQFinalValue :: MonadGen m => BalancePoolTestAction m @@ -601,11 +647,9 @@ incorrectRedeemLQFinalValue = 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) + (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 @@ -618,7 +662,7 @@ incorrectRedeemLQFinalValue = , value = value <> (assetClassValue (poolX config) (negate xToRedeem)) <> (assetClassValue (poolY config) (negate yToRedeem)) <> (assetClassValue (poolLq config) (lqToRedeem - 100)) } - pure $ BalancePoolActionResult newPool [] [gX, gY] [tX, tY] + pure $ BalancePoolActionResult newPool [] [gX, gY] [tX, tY] [] in BalancePoolTestAction "InCorrect redeem all tokens. Incorrect final lq value" testAction -- Redeem all cases end -- \ No newline at end of file diff --git a/plutarch-validators/test/Gen/DepositGen.hs b/plutarch-validators/test/Gen/DepositGen.hs index 9e80744..5ca6404 100644 --- a/plutarch-validators/test/Gen/DepositGen.hs +++ b/plutarch-validators/test/Gen/DepositGen.hs @@ -87,4 +87,10 @@ genTxOut :: OutputDatum -> AssetClass -> Integer -> Integer -> PubKeyHash -> TxO genTxOut od lq lqQty adaQty pkh = let value = mkValues [mkValue lq lqQty, mkAdaValue adaQty] mempty + in mkTxOut' od value pkh + +genTxOutWithCharge :: OutputDatum -> AssetClass -> Integer -> AssetClass -> Integer -> Integer -> PubKeyHash -> TxOut +genTxOutWithCharge od chrageTokenAC chrageTokenqty lq lqQty adaQty pkh = + let + value = mkValues [mkValue chrageTokenAC chrageTokenqty, mkValue lq lqQty, mkAdaValue adaQty] mempty in mkTxOut' od value pkh \ No newline at end of file diff --git a/plutarch-validators/test/Spec.hs b/plutarch-validators/test/Spec.hs index 8e491db..9570d77 100644 --- a/plutarch-validators/test/Spec.hs +++ b/plutarch-validators/test/Spec.hs @@ -19,6 +19,9 @@ import Test.Tasty.HUnit import WhalePoolsDex.PValidators import PlutusLedgerApi.V2 as PV2 import Plutarch.Api.V2 +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LBS +import Codec.Serialise (serialise, deserialise) main :: IO () main = do diff --git a/plutarch-validators/test/Tests/BalancePool.hs b/plutarch-validators/test/Tests/BalancePool.hs index fe1f467..39672ff 100644 --- a/plutarch-validators/test/Tests/BalancePool.hs +++ b/plutarch-validators/test/Tests/BalancePool.hs @@ -39,6 +39,12 @@ import Data.Text as T (pack, unpack, splitOn) balancePool = testGroup "BalancePool" ((genTests `map` [swapTests, depositAllTests, redeemAllTests])) +validPoolHash :: Property +validPoolHash = withTests 1 $ property $ do + let + actualPoolValidatorHash = PV2.validatorHash poolValidator + actualPoolValidatorHash === poolValidatorHash + genTests BalancePoolTestGroup{..} = let failedCases = (constructCase Failed) `map` invalidActions @@ -104,7 +110,7 @@ actionWithValidSignersQty sigsQty poolUpdater action testResultShouldBe = withSh datum = toData $ (config prevPool) let context = toData $ mkContext txInInfo purpose - redeemer = toData $ Pool.BalancePoolRedeemer action 0 (g updateResult) (t updateResult) + redeemer = toData $ Pool.BalancePoolRedeemer action 0 (g updateResult) (t updateResult) (lList updateResult) correctResult = case testResultShouldBe of From 91eeefc465ff1c09d8c45c6733020d0f9fce87cf Mon Sep 17 00:00:00 2001 From: Bromel777 Date: Wed, 17 Apr 2024 22:42:03 +0200 Subject: [PATCH 2/5] update balanceFeeSwitch --- .../PContracts/PFeeSwitchBalancePool.hs | 23 +++++++++++-------- 1 file changed, 13 insertions(+), 10 deletions(-) diff --git a/plutarch-validators/WhalePoolsDex/PContracts/PFeeSwitchBalancePool.hs b/plutarch-validators/WhalePoolsDex/PContracts/PFeeSwitchBalancePool.hs index be271f0..26e0cfb 100644 --- a/plutarch-validators/WhalePoolsDex/PContracts/PFeeSwitchBalancePool.hs +++ b/plutarch-validators/WhalePoolsDex/PContracts/PFeeSwitchBalancePool.hs @@ -83,7 +83,7 @@ instance PlutusType DAOAction where ) -- All SwitchFee actions shouldn't modify main poolConfig elements: poolNft, poolX, poolY, poolLq, lqBound, feeNum -validateCommonFields :: PMemberFields BalancePoolConfig '["poolNft", "poolX", "poolY", "poolLq", "weightX", "weightY", "invariant"] s as => HRec as -> HRec as -> Term s PBool +validateCommonFields :: PMemberFields BalancePoolConfig '["poolNft", "poolX", "poolY", "poolLq", "weightX", "weightY", "invariant", "invariantLength"] s as => HRec as -> HRec as -> Term s PBool validateCommonFields prevConfig newConfig = let prevPoolNft = getField @"poolNft" prevConfig @@ -93,6 +93,7 @@ validateCommonFields prevConfig newConfig = prevWeightY = getField @"weightY" prevConfig prevPoolLq = getField @"poolLq" prevConfig prevInvariant = getField @"invariant" prevConfig + prevInvariantLength = getField @"invariantLength" prevConfig newPoolNft = getField @"poolNft" newConfig newPoolX = getField @"poolX" newConfig @@ -101,15 +102,17 @@ validateCommonFields prevConfig newConfig = newWeightY = getField @"weightY" newConfig newPoolLq = getField @"poolLq" newConfig newInvariant = getField @"invariant" newConfig + newInvariantLength = getField @"invariantLength" newConfig commonFieldsValid = - prevPoolNft #== newPoolNft #&& - prevPoolX #== newPoolX #&& - prevWeightX #== newWeightX #&& - prevPoolY #== newPoolY #&& - prevWeightY #== newWeightY #&& - prevPoolLq #== newPoolLq #&& - prevInvariant #== newInvariant + prevPoolNft #== newPoolNft #&& + prevPoolX #== newPoolX #&& + prevWeightX #== newWeightX #&& + prevPoolY #== newPoolY #&& + prevWeightY #== newWeightY #&& + prevPoolLq #== newPoolLq #&& + prevInvariant #== newInvariant #&& + prevInvariantLength #== newInvariantLength in commonFieldsValid @@ -217,8 +220,8 @@ daoMultisigPolicyValidatorT poolNft daoPkhs threshold lpFeeIsEditable = plam $ \ poolInputAddr <- tletField @"address" poolInputResolved poolOutputAddr <- tletField @"address" successor - prevConf <- pletFieldsC @'["poolNft", "poolX", "weightX", "poolY", "weightY", "poolLq", "feeNum", "treasuryFee", "treasuryX", "treasuryY", "DAOPolicy", "treasuryAddress", "invariant"] poolInputDatum - newConf <- pletFieldsC @'["poolNft", "poolX", "weightX", "poolY", "weightY", "poolLq", "feeNum", "treasuryFee", "treasuryX", "treasuryY", "DAOPolicy", "treasuryAddress", "invariant"] poolOutputDatum + prevConf <- pletFieldsC @'["poolNft", "poolX", "weightX", "poolY", "weightY", "poolLq", "feeNum", "treasuryFee", "treasuryX", "treasuryY", "DAOPolicy", "treasuryAddress", "invariant", "invariantLength"] poolInputDatum + newConf <- pletFieldsC @'["poolNft", "poolX", "weightX", "poolY", "weightY", "poolLq", "feeNum", "treasuryFee", "treasuryX", "treasuryY", "DAOPolicy", "treasuryAddress", "invariant", "invariantLength"] poolOutputDatum let validSignaturesQty = pfoldl # plam (\acc pkh -> pif (containsSignature # signatories # pkh) (acc + 1) acc) # 0 # daoPkhs From 6fdef3498275932c7295d72a7913415c2da5f9f3 Mon Sep 17 00:00:00 2001 From: Bromel777 Date: Thu, 18 Apr 2024 12:18:44 +0200 Subject: [PATCH 3/5] remove redundant variable in ppow10 --- plutarch-validators/PExtra/Integer.hs | 18 +++++++++--------- .../WhalePoolsDex/PContracts/PBalancePool.hs | 4 ++-- 2 files changed, 11 insertions(+), 11 deletions(-) diff --git a/plutarch-validators/PExtra/Integer.hs b/plutarch-validators/PExtra/Integer.hs index b2ef8c1..4300c72 100644 --- a/plutarch-validators/PExtra/Integer.hs +++ b/plutarch-validators/PExtra/Integer.hs @@ -33,26 +33,26 @@ pexp' = phoistAcyclic $ 1 $ pif (podd # n) a 1 * (psquare #$ self # a # (pdiv # n # 2)) -ppow10 :: Term s (PInteger :--> PInteger :--> PInteger) +ppow10 :: Term s (PInteger :--> PInteger) ppow10 = phoistAcyclic $ - plam $ \a n -> + plam $ \n -> pif (n #< 0) perror - (pexp10' # a # n) + (pexp10' # n) -pexp10' :: Term s (PInteger :--> PInteger :--> PInteger) +pexp10' :: Term s (PInteger :--> PInteger) pexp10' = phoistAcyclic $ - pfix #$ plam $ \self a n -> + pfix #$ plam $ \self n -> pif (n #< 12) - (pexp10constant' # a # n) - $ pif (podd # n) a 1 * (psquare #$ self # a # (pdiv # n # 2)) + (pexp10constant' # n) + $ pif (podd # n) (pconstant 10) 1 * (psquare #$ self # (pdiv # n # 2)) -- max degree is 11 -pexp10constant' :: Term s (PInteger :--> PInteger :--> PInteger) +pexp10constant' :: Term s (PInteger :--> PInteger) pexp10constant' = phoistAcyclic $ - pfix #$ plam $ \self a n -> + plam $ \n -> pif ( n #== 11 ) (pconstant 100000000000) diff --git a/plutarch-validators/WhalePoolsDex/PContracts/PBalancePool.hs b/plutarch-validators/WhalePoolsDex/PContracts/PBalancePool.hs index 1c0e999..974cb08 100644 --- a/plutarch-validators/WhalePoolsDex/PContracts/PBalancePool.hs +++ b/plutarch-validators/WhalePoolsDex/PContracts/PBalancePool.hs @@ -160,7 +160,7 @@ pIntLengthInternal = checkLength :: Term s (PInteger :--> PInteger :--> PInteger) checkLength = phoistAcyclic $ plam $ \origValue apLength -> - plet (ppow10 # (pconstant 10) # apLength) $ \upperBound -> + plet (ppow10 # apLength) $ \upperBound -> plet (pdiv # upperBound # (pconstant 10)) $ \lowerBound -> unTermCont $ do pure (pif (lowerBound #<= origValue #&& origValue #< upperBound) (apLength) @@ -169,7 +169,7 @@ checkLength = phoistAcyclic $ plam $ \origValue apLength -> roundToTest :: Term s (PInteger :--> PInteger :--> PInteger :--> PInteger) roundToTest = phoistAcyclic $ plam $ \origValue roundIdx lengthTest -> unTermCont $ do checkedLength <- tlet $ checkLength # origValue # lengthTest - denum <- tlet $ (ppow10 # (pconstant 10) # (checkedLength - roundIdx)) + denum <- tlet $ (ppow10 # (checkedLength - roundIdx)) roundingDenum <- tlet $ ptryPositive # denum rational <- tlet $ (pcon $ PRational origValue roundingDenum) pure $ pround # rational From e53539efcb2d5a671271e4e8c5f86227222cfb31 Mon Sep 17 00:00:00 2001 From: Bromel777 Date: Mon, 22 Apr 2024 21:14:37 +0200 Subject: [PATCH 4/5] Fix incorrect flow in deposit, redeem contracts --- .../WhalePoolsDex/PContracts/PDeposit.hs | 154 ++++++++--------- .../PContracts/PDepositBalance.hs | 154 ++++++++--------- .../WhalePoolsDex/PContracts/PRedeem.hs | 159 +++++++++--------- .../PContracts/PRedeemBalance.hs | 159 +++++++++--------- 4 files changed, 314 insertions(+), 312 deletions(-) diff --git a/plutarch-validators/WhalePoolsDex/PContracts/PDeposit.hs b/plutarch-validators/WhalePoolsDex/PContracts/PDeposit.hs index 920d38a..dc4b20b 100644 --- a/plutarch-validators/WhalePoolsDex/PContracts/PDeposit.hs +++ b/plutarch-validators/WhalePoolsDex/PContracts/PDeposit.hs @@ -57,92 +57,92 @@ depositValidatorT :: ClosedTerm (DepositConfig :--> OrderRedeemer :--> PScriptCo depositValidatorT = plam $ \conf' redeemer' ctx' -> unTermCont $ do ctx <- pletFieldsC @'["txInfo", "purpose"] ctx' conf <- pletFieldsC @'["x", "y", "lq", "poolNft", "exFee", "rewardPkh", "stakePkh", "collateralAda"] conf' + redeemer <- pletFieldsC @'["poolInIx", "orderInIx", "rewardOutIx", "action"] redeemer' let collateralAda = getField @"collateralAda" conf rewardPkh = getField @"rewardPkh" conf - stakePkh = getField @"stakePkh" conf - exFee = getField @"exFee" conf - - x = getField @"x" conf - y = getField @"y" conf - lq = getField @"lq" conf - - txInfo' = getField @"txInfo" ctx + txInfo' = getField @"txInfo" ctx + action = getField @"action" redeemer txInfo <- pletFieldsC @'["inputs", "outputs", "signatories"] txInfo' - inputs <- tletUnwrap $ getField @"inputs" txInfo - outputs <- tletUnwrap $ getField @"outputs" txInfo - - redeemer <- pletFieldsC @'["poolInIx", "orderInIx", "rewardOutIx", "action"] redeemer' - let - poolInIx = getField @"poolInIx" redeemer - orderInIx = getField @"orderInIx" redeemer - rewardOutIx = getField @"rewardOutIx" redeemer - action = getField @"action" redeemer - - rewardOut <- tlet $ pelemAt # rewardOutIx # outputs - rewardValue <- tlet $ getRewardValue' # rewardOut # rewardPkh # stakePkh - - poolIn' <- tlet $ pelemAt # poolInIx # inputs - poolIn <- pletFieldsC @'["outRef", "resolved"] poolIn' - let pool = getField @"resolved" poolIn - - poolValue <- tletField @"value" pool - let poolIdentity = -- operation is performed with the pool selected by the user - let requiredNft = pfromData $ getField @"poolNft" conf - nftAmount = assetClassValueOf # poolValue # requiredNft - in nftAmount #== 1 - poolInputDatum <- tlet $ extractPoolConfig # pool - poolConf <- pletFieldsC @'["treasuryX", "treasuryY"] poolInputDatum - let - treasuryX = getField @"treasuryX" poolConf - treasuryY = getField @"treasuryY" poolConf - - selfIn' <- tlet $ pelemAt # orderInIx # inputs - selfIn <- pletFieldsC @'["outRef", "resolved"] selfIn' - selfValue <- - let self = pfromData $ getField @"resolved" selfIn - in tletField @"value" self - - PSpending selfRef' <- pmatchC $ getField @"purpose" ctx - let - selfIdentity = - let selfRef = pfield @"_0" # selfRef' - selfInRef = getField @"outRef" selfIn - in selfRef #== selfInRef -- check that orderInIx points to the actual order - - strictInputs = -- ensure double satisfaction attack is not possible - let inputsLength = plength # inputs - in inputsLength #== 2 - - liquidity <- - let lqNegative = assetClassValueOf # poolValue # lq - in tlet $ maxLqCap - lqNegative - - reservesX <- tlet $ (assetClassValueOf # poolValue # x) - treasuryX - reservesY <- tlet $ (assetClassValueOf # poolValue # y) - treasuryY - - minRewardByX <- tlet $ minAssetReward # selfValue # x # reservesX # liquidity # exFee # collateralAda - minRewardByY <- tlet $ minAssetReward # selfValue # y # reservesY # liquidity # exFee # collateralAda - let validChange = -- pair excess is returned to user - pif - (minRewardByX #== minRewardByY) - (pcon PTrue) - ( pif - (minRewardByX #< minRewardByY) - (validChange' # rewardValue # y # minRewardByY # minRewardByX # reservesY # liquidity) - (validChange' # rewardValue # x # minRewardByX # minRewardByY # reservesX # liquidity) - ) - minReward = pmin # minRewardByX # minRewardByY - validReward = -- calculated minimal output of LQ tokens is satisfied - let actualReward = assetClassValueOf # rewardValue # lq - in minReward #<= actualReward - pure $ pmatch action $ \case - Apply -> poolIdentity #&& selfIdentity #&& strictInputs #&& validChange #&& validReward + Apply -> unTermCont $ do + inputs <- tletUnwrap $ getField @"inputs" txInfo + outputs <- tletUnwrap $ getField @"outputs" txInfo + let + poolInIx = getField @"poolInIx" redeemer + orderInIx = getField @"orderInIx" redeemer + rewardOutIx = getField @"rewardOutIx" redeemer + + stakePkh = getField @"stakePkh" conf + exFee = getField @"exFee" conf + + x = getField @"x" conf + y = getField @"y" conf + lq = getField @"lq" conf + + rewardOut <- tlet $ pelemAt # rewardOutIx # outputs + rewardValue <- tlet $ getRewardValue' # rewardOut # rewardPkh # stakePkh + + poolIn' <- tlet $ pelemAt # poolInIx # inputs + poolIn <- pletFieldsC @'["outRef", "resolved"] poolIn' + let pool = getField @"resolved" poolIn + + poolValue <- tletField @"value" pool + let poolIdentity = -- operation is performed with the pool selected by the user + let requiredNft = pfromData $ getField @"poolNft" conf + nftAmount = assetClassValueOf # poolValue # requiredNft + in nftAmount #== 1 + + poolInputDatum <- tlet $ extractPoolConfig # pool + poolConf <- pletFieldsC @'["treasuryX", "treasuryY"] poolInputDatum + let + treasuryX = getField @"treasuryX" poolConf + treasuryY = getField @"treasuryY" poolConf + + selfIn' <- tlet $ pelemAt # orderInIx # inputs + selfIn <- pletFieldsC @'["outRef", "resolved"] selfIn' + selfValue <- + let self = pfromData $ getField @"resolved" selfIn + in tletField @"value" self + + PSpending selfRef' <- pmatchC $ getField @"purpose" ctx + let + selfIdentity = + let selfRef = pfield @"_0" # selfRef' + selfInRef = getField @"outRef" selfIn + in selfRef #== selfInRef -- check that orderInIx points to the actual order + + strictInputs = -- ensure double satisfaction attack is not possible + let inputsLength = plength # inputs + in inputsLength #== 2 + + liquidity <- + let lqNegative = assetClassValueOf # poolValue # lq + in tlet $ maxLqCap - lqNegative + + reservesX <- tlet $ (assetClassValueOf # poolValue # x) - treasuryX + reservesY <- tlet $ (assetClassValueOf # poolValue # y) - treasuryY + + minRewardByX <- tlet $ minAssetReward # selfValue # x # reservesX # liquidity # exFee # collateralAda + minRewardByY <- tlet $ minAssetReward # selfValue # y # reservesY # liquidity # exFee # collateralAda + let validChange = -- pair excess is returned to user + pif + (minRewardByX #== minRewardByY) + (pcon PTrue) + ( pif + (minRewardByX #< minRewardByY) + (validChange' # rewardValue # y # minRewardByY # minRewardByX # reservesY # liquidity) + (validChange' # rewardValue # x # minRewardByX # minRewardByY # reservesX # liquidity) + ) + minReward = pmin # minRewardByX # minRewardByY + validReward = -- calculated minimal output of LQ tokens is satisfied + let actualReward = assetClassValueOf # rewardValue # lq + in minReward #<= actualReward + pure $ poolIdentity #&& selfIdentity #&& strictInputs #&& validChange #&& validReward Refund -> let sigs = pfromData $ getField @"signatories" txInfo in containsSignature # sigs # rewardPkh -- user signed the refund diff --git a/plutarch-validators/WhalePoolsDex/PContracts/PDepositBalance.hs b/plutarch-validators/WhalePoolsDex/PContracts/PDepositBalance.hs index 4551e44..6174c07 100644 --- a/plutarch-validators/WhalePoolsDex/PContracts/PDepositBalance.hs +++ b/plutarch-validators/WhalePoolsDex/PContracts/PDepositBalance.hs @@ -57,92 +57,92 @@ depositValidatorT :: ClosedTerm (DepositBalanceConfig :--> OrderRedeemer :--> PS depositValidatorT = plam $ \conf' redeemer' ctx' -> unTermCont $ do ctx <- pletFieldsC @'["txInfo", "purpose"] ctx' conf <- pletFieldsC @'["x", "y", "lq", "poolNft", "exFee", "rewardPkh", "stakePkh", "collateralAda"] conf' + redeemer <- pletFieldsC @'["poolInIx", "orderInIx", "rewardOutIx", "action"] redeemer' let collateralAda = getField @"collateralAda" conf rewardPkh = getField @"rewardPkh" conf - stakePkh = getField @"stakePkh" conf - exFee = getField @"exFee" conf - - x = getField @"x" conf - y = getField @"y" conf - lq = getField @"lq" conf - - txInfo' = getField @"txInfo" ctx + txInfo' = getField @"txInfo" ctx + action = getField @"action" redeemer txInfo <- pletFieldsC @'["inputs", "outputs", "signatories"] txInfo' - inputs <- tletUnwrap $ getField @"inputs" txInfo - outputs <- tletUnwrap $ getField @"outputs" txInfo - - redeemer <- pletFieldsC @'["poolInIx", "orderInIx", "rewardOutIx", "action"] redeemer' - let - poolInIx = getField @"poolInIx" redeemer - orderInIx = getField @"orderInIx" redeemer - rewardOutIx = getField @"rewardOutIx" redeemer - action = getField @"action" redeemer - - rewardOut <- tlet $ pelemAt # rewardOutIx # outputs - rewardValue <- tlet $ getRewardValue' # rewardOut # rewardPkh # stakePkh - - poolIn' <- tlet $ pelemAt # poolInIx # inputs - poolIn <- pletFieldsC @'["outRef", "resolved"] poolIn' - let pool = getField @"resolved" poolIn - - poolValue <- tletField @"value" pool - let poolIdentity = -- operation is performed with the pool selected by the user - let requiredNft = pfromData $ getField @"poolNft" conf - nftAmount = assetClassValueOf # poolValue # requiredNft - in nftAmount #== 1 - poolInputDatum <- tlet $ extractBalancePoolConfig # pool - poolConf <- pletFieldsC @'["treasuryX", "treasuryY"] poolInputDatum - let - treasuryX = getField @"treasuryX" poolConf - treasuryY = getField @"treasuryY" poolConf - - selfIn' <- tlet $ pelemAt # orderInIx # inputs - selfIn <- pletFieldsC @'["outRef", "resolved"] selfIn' - selfValue <- - let self = pfromData $ getField @"resolved" selfIn - in tletField @"value" self - - PSpending selfRef' <- pmatchC $ getField @"purpose" ctx - let - selfIdentity = - let selfRef = pfield @"_0" # selfRef' - selfInRef = getField @"outRef" selfIn - in selfRef #== selfInRef -- check that orderInIx points to the actual order - - strictInputs = -- ensure double satisfaction attack is not possible - let inputsLength = plength # inputs - in inputsLength #== 2 - - liquidity <- - let lqNegative = assetClassValueOf # poolValue # lq - in tlet $ maxLqCap - lqNegative - - reservesX <- tlet $ (assetClassValueOf # poolValue # x) - treasuryX - reservesY <- tlet $ (assetClassValueOf # poolValue # y) - treasuryY - - minRewardByX <- tlet $ minAssetReward # selfValue # x # reservesX # liquidity # exFee # collateralAda - minRewardByY <- tlet $ minAssetReward # selfValue # y # reservesY # liquidity # exFee # collateralAda - let validChange = -- pair excess is returned to user - pif - (minRewardByX #== minRewardByY) - (pcon PTrue) - ( pif - (minRewardByX #< minRewardByY) - (validChange' # rewardValue # y # minRewardByY # minRewardByX # reservesY # liquidity) - (validChange' # rewardValue # x # minRewardByX # minRewardByY # reservesX # liquidity) - ) - minReward = pmin # minRewardByX # minRewardByY - validReward = -- calculated minimal output of LQ tokens is satisfied - let actualReward = assetClassValueOf # rewardValue # lq - in minReward #<= actualReward - pure $ pmatch action $ \case - Apply -> poolIdentity #&& selfIdentity #&& strictInputs #&& validChange #&& validReward + Apply -> unTermCont $ do + inputs <- tletUnwrap $ getField @"inputs" txInfo + outputs <- tletUnwrap $ getField @"outputs" txInfo + let + poolInIx = getField @"poolInIx" redeemer + orderInIx = getField @"orderInIx" redeemer + rewardOutIx = getField @"rewardOutIx" redeemer + + stakePkh = getField @"stakePkh" conf + exFee = getField @"exFee" conf + + x = getField @"x" conf + y = getField @"y" conf + lq = getField @"lq" conf + + rewardOut <- tlet $ pelemAt # rewardOutIx # outputs + rewardValue <- tlet $ getRewardValue' # rewardOut # rewardPkh # stakePkh + + poolIn' <- tlet $ pelemAt # poolInIx # inputs + poolIn <- pletFieldsC @'["outRef", "resolved"] poolIn' + let pool = getField @"resolved" poolIn + + poolValue <- tletField @"value" pool + let poolIdentity = -- operation is performed with the pool selected by the user + let requiredNft = pfromData $ getField @"poolNft" conf + nftAmount = assetClassValueOf # poolValue # requiredNft + in nftAmount #== 1 + + poolInputDatum <- tlet $ extractBalancePoolConfig # pool + poolConf <- pletFieldsC @'["treasuryX", "treasuryY"] poolInputDatum + let + treasuryX = getField @"treasuryX" poolConf + treasuryY = getField @"treasuryY" poolConf + + selfIn' <- tlet $ pelemAt # orderInIx # inputs + selfIn <- pletFieldsC @'["outRef", "resolved"] selfIn' + selfValue <- + let self = pfromData $ getField @"resolved" selfIn + in tletField @"value" self + + PSpending selfRef' <- pmatchC $ getField @"purpose" ctx + let + selfIdentity = + let selfRef = pfield @"_0" # selfRef' + selfInRef = getField @"outRef" selfIn + in selfRef #== selfInRef -- check that orderInIx points to the actual order + + strictInputs = -- ensure double satisfaction attack is not possible + let inputsLength = plength # inputs + in inputsLength #== 2 + + liquidity <- + let lqNegative = assetClassValueOf # poolValue # lq + in tlet $ maxLqCap - lqNegative + + reservesX <- tlet $ (assetClassValueOf # poolValue # x) - treasuryX + reservesY <- tlet $ (assetClassValueOf # poolValue # y) - treasuryY + + minRewardByX <- tlet $ minAssetReward # selfValue # x # reservesX # liquidity # exFee # collateralAda + minRewardByY <- tlet $ minAssetReward # selfValue # y # reservesY # liquidity # exFee # collateralAda + let validChange = -- pair excess is returned to user + pif + (minRewardByX #== minRewardByY) + (pcon PTrue) + ( pif + (minRewardByX #< minRewardByY) + (validChange' # rewardValue # y # minRewardByY # minRewardByX # reservesY # liquidity) + (validChange' # rewardValue # x # minRewardByX # minRewardByY # reservesX # liquidity) + ) + minReward = pmin # minRewardByX # minRewardByY + validReward = -- calculated minimal output of LQ tokens is satisfied + let actualReward = assetClassValueOf # rewardValue # lq + in minReward #<= actualReward + pure $ poolIdentity #&& selfIdentity #&& strictInputs #&& validChange #&& validReward Refund -> let sigs = pfromData $ getField @"signatories" txInfo in containsSignature # sigs # rewardPkh -- user signed the refund diff --git a/plutarch-validators/WhalePoolsDex/PContracts/PRedeem.hs b/plutarch-validators/WhalePoolsDex/PContracts/PRedeem.hs index 3a4fe49..a4436fb 100644 --- a/plutarch-validators/WhalePoolsDex/PContracts/PRedeem.hs +++ b/plutarch-validators/WhalePoolsDex/PContracts/PRedeem.hs @@ -52,93 +52,94 @@ deriving via (DerivePConstantViaData R.RedeemConfig RedeemConfig) instance (PCon redeemValidatorT :: ClosedTerm (RedeemConfig :--> OrderRedeemer :--> PScriptContext :--> PBool) redeemValidatorT = plam $ \conf' redeemer' ctx' -> unTermCont $ do - ctx <- pletFieldsC @'["txInfo", "purpose"] ctx' - conf <- pletFieldsC @'["x", "y", "lq", "poolNft", "exFee", "rewardPkh", "stakePkh"] conf' + ctx <- pletFieldsC @'["txInfo", "purpose"] ctx' + conf <- pletFieldsC @'["x", "y", "lq", "poolNft", "exFee", "rewardPkh", "stakePkh"] conf' + redeemer <- pletFieldsC @'["poolInIx", "orderInIx", "rewardOutIx", "action"] redeemer' let rewardPkh = getField @"rewardPkh" conf - stakePkh = getField @"stakePkh" conf - - x = getField @"x" conf - y = getField @"y" conf - lq = getField @"lq" conf - - exFee = getField @"exFee" conf txInfo' = getField @"txInfo" ctx txInfo <- pletFieldsC @'["inputs", "outputs", "signatories"] txInfo' - inputs <- tletUnwrap $ getField @"inputs" txInfo - outputs <- tletUnwrap $ getField @"outputs" txInfo - - redeemer <- pletFieldsC @'["poolInIx", "orderInIx", "rewardOutIx", "action"] redeemer' - let - poolInIx = getField @"poolInIx" redeemer - orderInIx = getField @"orderInIx" redeemer - rewardOutIx = getField @"rewardOutIx" redeemer - - rewardOut <- tlet $ pelemAt # rewardOutIx # outputs - rewardValue <- tlet $ getRewardValue' # rewardOut # rewardPkh # stakePkh - - poolIn' <- tlet $ pelemAt # poolInIx # inputs - poolIn <- pletFieldsC @'["outRef", "resolved"] poolIn' - let - pool = getField @"resolved" poolIn - poolValue = pfield @"value" # pool - poolIdentity = -- operation is performed with the pool selected by the user - let - requiredNft = pfromData $ getField @"poolNft" conf - nftAmount = assetClassValueOf # poolValue # requiredNft - in nftAmount #== 1 - - poolInputDatum <- tlet $ extractPoolConfig # pool - poolConf <- pletFieldsC @'["treasuryX", "treasuryY"] poolInputDatum - let - treasuryX = getField @"treasuryX" poolConf - treasuryY = getField @"treasuryY" poolConf - - selfIn' <- tlet $ pelemAt # orderInIx # inputs - selfIn <- pletFieldsC @'["outRef", "resolved"] selfIn' - let selfValue = pfield @"value" # (getField @"resolved" selfIn) - - PSpending selfRef' <- tmatch (pfromData $ getField @"purpose" ctx) - let - selfIdentity = - let - selfRef = pfromData $ pfield @"_0" # selfRef' - selfInRef = pfromData $ getField @"outRef" selfIn - in selfRef #== selfInRef - - collateralAda <- -- we reserve a small amount of ADA to put it into user output later - let inAda = plovelaceValueOf # selfValue - in tlet $ inAda - exFee - - let strictInputs = -- ensure double satisfaction attack is not possible - let inputsLength = plength # inputs - in inputsLength #== 2 - - liquidity <- - let lqNegative = assetClassValueOf # poolValue # lq - in tlet $ maxLqCap - lqNegative - - outs <- tlet $ calcOutput # rewardValue # x # y # collateralAda - inLq <- tlet $ assetClassValueOf # selfValue # lq - - let - outAda = plovelaceValueOf # rewardValue - - minReturnX = calcMinReturn # liquidity # inLq # poolValue # x # treasuryX - minReturnY = calcMinReturn # liquidity # inLq # poolValue # y # treasuryY - - outX = pfromData $ pfield @"_0" # outs - outY = pfromData $ pfield @"_1" # outs - opAda = pfromData $ pfield @"_2" # outs - - fairShare = minReturnX #<= outX #&& minReturnY #<= outY -- output shares are proportional to the total LQ and LQ returned by the user - fairFee = opAda + collateralAda #<= outAda -- output ADA (if present) plus collateral ADA is returned in full to the user - action <- tletUnwrap $ getField @"action" redeemer pure $ pmatch action $ \case - Apply -> poolIdentity #&& selfIdentity #&& strictInputs #&& fairShare #&& fairFee + Apply -> unTermCont $ do + inputs <- tletUnwrap $ getField @"inputs" txInfo + outputs <- tletUnwrap $ getField @"outputs" txInfo + let + poolInIx = getField @"poolInIx" redeemer + orderInIx = getField @"orderInIx" redeemer + rewardOutIx = getField @"rewardOutIx" redeemer + + stakePkh = getField @"stakePkh" conf + + x = getField @"x" conf + y = getField @"y" conf + lq = getField @"lq" conf + + exFee = getField @"exFee" conf + + rewardOut <- tlet $ pelemAt # rewardOutIx # outputs + rewardValue <- tlet $ getRewardValue' # rewardOut # rewardPkh # stakePkh + + poolIn' <- tlet $ pelemAt # poolInIx # inputs + poolIn <- pletFieldsC @'["outRef", "resolved"] poolIn' + let + pool = getField @"resolved" poolIn + poolValue = pfield @"value" # pool + poolIdentity = -- operation is performed with the pool selected by the user + let + requiredNft = pfromData $ getField @"poolNft" conf + nftAmount = assetClassValueOf # poolValue # requiredNft + in nftAmount #== 1 + + poolInputDatum <- tlet $ extractPoolConfig # pool + poolConf <- pletFieldsC @'["treasuryX", "treasuryY"] poolInputDatum + let + treasuryX = getField @"treasuryX" poolConf + treasuryY = getField @"treasuryY" poolConf + + selfIn' <- tlet $ pelemAt # orderInIx # inputs + selfIn <- pletFieldsC @'["outRef", "resolved"] selfIn' + let selfValue = pfield @"value" # (getField @"resolved" selfIn) + + PSpending selfRef' <- tmatch (pfromData $ getField @"purpose" ctx) + let + selfIdentity = + let + selfRef = pfromData $ pfield @"_0" # selfRef' + selfInRef = pfromData $ getField @"outRef" selfIn + in selfRef #== selfInRef + + collateralAda <- -- we reserve a small amount of ADA to put it into user output later + let inAda = plovelaceValueOf # selfValue + in tlet $ inAda - exFee + + let strictInputs = -- ensure double satisfaction attack is not possible + let inputsLength = plength # inputs + in inputsLength #== 2 + + liquidity <- + let lqNegative = assetClassValueOf # poolValue # lq + in tlet $ maxLqCap - lqNegative + + outs <- tlet $ calcOutput # rewardValue # x # y # collateralAda + inLq <- tlet $ assetClassValueOf # selfValue # lq + + let + outAda = plovelaceValueOf # rewardValue + + minReturnX = calcMinReturn # liquidity # inLq # poolValue # x # treasuryX + minReturnY = calcMinReturn # liquidity # inLq # poolValue # y # treasuryY + + outX = pfromData $ pfield @"_0" # outs + outY = pfromData $ pfield @"_1" # outs + opAda = pfromData $ pfield @"_2" # outs + + fairShare = minReturnX #<= outX #&& minReturnY #<= outY -- output shares are proportional to the total LQ and LQ returned by the user + fairFee = opAda + collateralAda #<= outAda -- output ADA (if present) plus collateral ADA is returned in full to the user + + pure $ poolIdentity #&& selfIdentity #&& strictInputs #&& fairShare #&& fairFee Refund -> let sigs = pfromData $ getField @"signatories" txInfo in containsSignature # sigs # rewardPkh -- user signed the refund diff --git a/plutarch-validators/WhalePoolsDex/PContracts/PRedeemBalance.hs b/plutarch-validators/WhalePoolsDex/PContracts/PRedeemBalance.hs index d9e7086..89fa0d8 100644 --- a/plutarch-validators/WhalePoolsDex/PContracts/PRedeemBalance.hs +++ b/plutarch-validators/WhalePoolsDex/PContracts/PRedeemBalance.hs @@ -52,93 +52,94 @@ deriving via (DerivePConstantViaData R.RedeemBalanceConfig RedeemBalanceConfig) redeemBalanceValidatorT :: ClosedTerm (RedeemBalanceConfig :--> OrderRedeemer :--> PScriptContext :--> PBool) redeemBalanceValidatorT = plam $ \conf' redeemer' ctx' -> unTermCont $ do - ctx <- pletFieldsC @'["txInfo", "purpose"] ctx' - conf <- pletFieldsC @'["x", "y", "lq", "poolNft", "exFee", "rewardPkh", "stakePkh"] conf' + ctx <- pletFieldsC @'["txInfo", "purpose"] ctx' + conf <- pletFieldsC @'["x", "y", "lq", "poolNft", "exFee", "rewardPkh", "stakePkh"] conf' + redeemer <- pletFieldsC @'["poolInIx", "orderInIx", "rewardOutIx", "action"] redeemer' let rewardPkh = getField @"rewardPkh" conf - stakePkh = getField @"stakePkh" conf - - x = getField @"x" conf - y = getField @"y" conf - lq = getField @"lq" conf - - exFee = getField @"exFee" conf txInfo' = getField @"txInfo" ctx txInfo <- pletFieldsC @'["inputs", "outputs", "signatories"] txInfo' - inputs <- tletUnwrap $ getField @"inputs" txInfo - outputs <- tletUnwrap $ getField @"outputs" txInfo - - redeemer <- pletFieldsC @'["poolInIx", "orderInIx", "rewardOutIx", "action"] redeemer' - let - poolInIx = getField @"poolInIx" redeemer - orderInIx = getField @"orderInIx" redeemer - rewardOutIx = getField @"rewardOutIx" redeemer - - rewardOut <- tlet $ pelemAt # rewardOutIx # outputs - rewardValue <- tlet $ getRewardValue' # rewardOut # rewardPkh # stakePkh - - poolIn' <- tlet $ pelemAt # poolInIx # inputs - poolIn <- pletFieldsC @'["outRef", "resolved"] poolIn' - let - pool = getField @"resolved" poolIn - poolValue = pfield @"value" # pool - poolIdentity = -- operation is performed with the pool selected by the user - let - requiredNft = pfromData $ getField @"poolNft" conf - nftAmount = assetClassValueOf # poolValue # requiredNft - in nftAmount #== 1 - - poolInputDatum <- tlet $ extractBalancePoolConfig # pool - poolConf <- pletFieldsC @'["treasuryX", "treasuryY"] poolInputDatum - let - treasuryX = getField @"treasuryX" poolConf - treasuryY = getField @"treasuryY" poolConf - - selfIn' <- tlet $ pelemAt # orderInIx # inputs - selfIn <- pletFieldsC @'["outRef", "resolved"] selfIn' - let selfValue = pfield @"value" # (getField @"resolved" selfIn) - - PSpending selfRef' <- tmatch (pfromData $ getField @"purpose" ctx) - let - selfIdentity = - let - selfRef = pfromData $ pfield @"_0" # selfRef' - selfInRef = pfromData $ getField @"outRef" selfIn - in selfRef #== selfInRef - - collateralAda <- -- we reserve a small amount of ADA to put it into user output later - let inAda = plovelaceValueOf # selfValue - in tlet $ inAda - exFee - - let strictInputs = -- ensure double satisfaction attack is not possible - let inputsLength = plength # inputs - in inputsLength #== 2 - - liquidity <- - let lqNegative = assetClassValueOf # poolValue # lq - in tlet $ maxLqCap - lqNegative - - outs <- tlet $ calcOutput # rewardValue # x # y # collateralAda - inLq <- tlet $ assetClassValueOf # selfValue # lq - - let - outAda = plovelaceValueOf # rewardValue - - minReturnX = calcMinReturn # liquidity # inLq # poolValue # x # treasuryX - minReturnY = calcMinReturn # liquidity # inLq # poolValue # y # treasuryY - - outX = pfromData $ pfield @"_0" # outs - outY = pfromData $ pfield @"_1" # outs - opAda = pfromData $ pfield @"_2" # outs - - fairShare = minReturnX #<= outX #&& minReturnY #<= outY -- output shares are proportional to the total LQ and LQ returned by the user - fairFee = opAda + collateralAda #<= outAda -- output ADA (if present) plus collateral ADA is returned in full to the user - action <- tletUnwrap $ getField @"action" redeemer pure $ pmatch action $ \case - Apply -> poolIdentity #&& selfIdentity #&& strictInputs #&& fairShare #&& fairFee + Apply -> unTermCont $ do + inputs <- tletUnwrap $ getField @"inputs" txInfo + outputs <- tletUnwrap $ getField @"outputs" txInfo + let + poolInIx = getField @"poolInIx" redeemer + orderInIx = getField @"orderInIx" redeemer + rewardOutIx = getField @"rewardOutIx" redeemer + + stakePkh = getField @"stakePkh" conf + + x = getField @"x" conf + y = getField @"y" conf + lq = getField @"lq" conf + + exFee = getField @"exFee" conf + + rewardOut <- tlet $ pelemAt # rewardOutIx # outputs + rewardValue <- tlet $ getRewardValue' # rewardOut # rewardPkh # stakePkh + + poolIn' <- tlet $ pelemAt # poolInIx # inputs + poolIn <- pletFieldsC @'["outRef", "resolved"] poolIn' + let + pool = getField @"resolved" poolIn + poolValue = pfield @"value" # pool + poolIdentity = -- operation is performed with the pool selected by the user + let + requiredNft = pfromData $ getField @"poolNft" conf + nftAmount = assetClassValueOf # poolValue # requiredNft + in nftAmount #== 1 + + poolInputDatum <- tlet $ extractBalancePoolConfig # pool + poolConf <- pletFieldsC @'["treasuryX", "treasuryY"] poolInputDatum + let + treasuryX = getField @"treasuryX" poolConf + treasuryY = getField @"treasuryY" poolConf + + selfIn' <- tlet $ pelemAt # orderInIx # inputs + selfIn <- pletFieldsC @'["outRef", "resolved"] selfIn' + let selfValue = pfield @"value" # (getField @"resolved" selfIn) + + PSpending selfRef' <- tmatch (pfromData $ getField @"purpose" ctx) + let + selfIdentity = + let + selfRef = pfromData $ pfield @"_0" # selfRef' + selfInRef = pfromData $ getField @"outRef" selfIn + in selfRef #== selfInRef + + collateralAda <- -- we reserve a small amount of ADA to put it into user output later + let inAda = plovelaceValueOf # selfValue + in tlet $ inAda - exFee + + let strictInputs = -- ensure double satisfaction attack is not possible + let inputsLength = plength # inputs + in inputsLength #== 2 + + liquidity <- + let lqNegative = assetClassValueOf # poolValue # lq + in tlet $ maxLqCap - lqNegative + + outs <- tlet $ calcOutput # rewardValue # x # y # collateralAda + inLq <- tlet $ assetClassValueOf # selfValue # lq + + let + outAda = plovelaceValueOf # rewardValue + + minReturnX = calcMinReturn # liquidity # inLq # poolValue # x # treasuryX + minReturnY = calcMinReturn # liquidity # inLq # poolValue # y # treasuryY + + outX = pfromData $ pfield @"_0" # outs + outY = pfromData $ pfield @"_1" # outs + opAda = pfromData $ pfield @"_2" # outs + + fairShare = minReturnX #<= outX #&& minReturnY #<= outY -- output shares are proportional to the total LQ and LQ returned by the user + fairFee = opAda + collateralAda #<= outAda -- output ADA (if present) plus collateral ADA is returned in full to the user + + pure $ poolIdentity #&& selfIdentity #&& strictInputs #&& fairShare #&& fairFee Refund -> let sigs = pfromData $ getField @"signatories" txInfo in containsSignature # sigs # rewardPkh -- user signed the refund From 4fadd8ff4b1b4f5765d65e9022586be8d7304018 Mon Sep 17 00:00:00 2001 From: Bromel777 <33941049+Bromel777@users.noreply.github.com> Date: Sun, 2 Jun 2024 17:01:25 +0300 Subject: [PATCH 5/5] Balance pool. New approach (#43) * New approach for balance pools * remove invariant * fix balance contract --- .../WhalePoolsDex/Contracts/BalancePool.hs | 7 - .../WhalePoolsDex/PContracts/PBalancePool.hs | 307 ++--------------- .../PContracts/PFeeSwitchBalancePool.hs | 20 +- plutarch-validators/test/Eval.hs | 1 + .../test/Gen/BalancePoolGen.hs | 308 +++++++++--------- plutarch-validators/test/Spec.hs | 54 +-- plutarch-validators/test/Tests/BalancePool.hs | 16 +- 7 files changed, 229 insertions(+), 484 deletions(-) diff --git a/plutarch-validators/WhalePoolsDex/Contracts/BalancePool.hs b/plutarch-validators/WhalePoolsDex/Contracts/BalancePool.hs index a805911..329d029 100644 --- a/plutarch-validators/WhalePoolsDex/Contracts/BalancePool.hs +++ b/plutarch-validators/WhalePoolsDex/Contracts/BalancePool.hs @@ -17,9 +17,7 @@ import PlutusLedgerApi.V1.Credential data BalancePoolConfig = BalancePoolConfig { poolNft :: AssetClass , poolX :: AssetClass - , weightX :: Integer , poolY :: AssetClass - , weightY :: Integer , poolLq :: AssetClass , poolFeeNum :: Integer , treasuryFee :: Integer @@ -27,8 +25,6 @@ data BalancePoolConfig = BalancePoolConfig , treasuryY :: Integer , daoPolicy :: [StakingCredential] , treasuryAddress :: ValidatorHash - , invariant :: Integer - , invariantLength :: Integer } deriving stock (Show) @@ -63,9 +59,6 @@ instance PlutusTx.ToData BalancePoolAction where data BalancePoolRedeemer = BalancePoolRedeemer { action :: BalancePoolAction , selfIx :: Integer - , g :: [Integer] - , t :: [Integer] - , lList :: [Integer] } deriving (Show) diff --git a/plutarch-validators/WhalePoolsDex/PContracts/PBalancePool.hs b/plutarch-validators/WhalePoolsDex/PContracts/PBalancePool.hs index 974cb08..b173f3a 100644 --- a/plutarch-validators/WhalePoolsDex/PContracts/PBalancePool.hs +++ b/plutarch-validators/WhalePoolsDex/PContracts/PBalancePool.hs @@ -42,9 +42,7 @@ newtype BalancePoolConfig (s :: S) ( PDataRecord '[ "poolNft" ':= PAssetClass , "poolX" ':= PAssetClass - , "weightX" ':= PInteger , "poolY" ':= PAssetClass - , "weightY" ':= PInteger , "poolLq" ':= PAssetClass , "feeNum" ':= PInteger , "treasuryFee" ':= PInteger @@ -52,8 +50,6 @@ newtype BalancePoolConfig (s :: S) , "treasuryY" ':= PInteger , "DAOPolicy" ':= PBuiltinList (PAsData PStakingCredential) , "treasuryAddress" ':= PValidatorHash - , "invariant" ':= PInteger - , "invariantLength" ':= PInteger ] ) ) @@ -118,12 +114,6 @@ newtype BalancePoolRedeemer (s :: S) ( PDataRecord '[ "action" ':= BalancePoolAction , "selfIx" ':= PInteger - -- for swap, deposit / redeem (All assets) contains: gX, gY - , "g" ':= PBuiltinList (PAsData PInteger) - -- for swap, deposit / redeem (All assets) contains: tX, tY - , "t" ':= PBuiltinList (PAsData PInteger) - -- info about internals lengths - , "lengths" ':= PBuiltinList (PAsData PInteger) ] ) ) @@ -144,193 +134,24 @@ parseDatum :: ClosedTerm (PDatum :--> BalancePoolConfig) parseDatum = plam $ \newDatum -> unTermCont $ do PDatum poolDatum <- pmatchC newDatum tletUnwrap $ ptryFromData @(BalancePoolConfig) $ poolDatum - -pIntLength :: ClosedTerm (PInteger :--> PInteger) -pIntLength = plam $ \integerToProcess -> pIntLengthInternal # integerToProcess # 1 - -pIntLengthInternal :: Term s (PInteger :--> PInteger :--> PInteger) -pIntLengthInternal = - phoistAcyclic $ - pfix #$ plam $ \self integerToProcess accLength -> - plet (pdiv # integerToProcess # (pconstant 10)) $ \divided -> - pif - (divided #== (pconstant 0)) - (accLength #- (pconstant 1)) - (self # divided # (accLength #+ (pconstant 1))) - -checkLength :: Term s (PInteger :--> PInteger :--> PInteger) -checkLength = phoistAcyclic $ plam $ \origValue apLength -> - plet (ppow10 # apLength) $ \upperBound -> - plet (pdiv # upperBound # (pconstant 10)) $ \lowerBound -> unTermCont $ do - pure (pif (lowerBound #<= origValue #&& origValue #< upperBound) - (apLength) - (perror)) - -roundToTest :: Term s (PInteger :--> PInteger :--> PInteger :--> PInteger) -roundToTest = phoistAcyclic $ plam $ \origValue roundIdx lengthTest -> unTermCont $ do - checkedLength <- tlet $ checkLength # origValue # lengthTest - denum <- tlet $ (ppow10 # (checkedLength - roundIdx)) - roundingDenum <- tlet $ ptryPositive # denum - rational <- tlet $ (pcon $ PRational origValue roundingDenum) - pure $ pround # rational - -verifyGTValues :: - Term s - ( PInteger - :--> PInteger - :--> PInteger - :--> PInteger - :--> PInteger - :--> PInteger - :--> PInteger - :--> PBool - ) -verifyGTValues = plam $ \tokenBalance tokenBalanceLength tokenWeight tokenG tokenT tokenGLength tokenTPowWeightLength -> - plet (checkLength # tokenBalance # tokenBalanceLength) $ \_ -> - (roundToTest # tokenG # tokenBalanceLength # tokenGLength) #== (roundToTest # (ppow # tokenT # tokenWeight) # tokenBalanceLength # tokenTPowWeightLength) - -verifyGEquality :: - Term s - ( PInteger - :--> PInteger - :--> PInteger - :--> PInteger - :--> PInteger - :--> PInteger - :--> PBool - ) -verifyGEquality = phoistAcyclic $ plam $ \leftSideMultiplicator rightSideRaw tokenG tokenWeight leftSideLength rightSideLength -> unTermCont $ do - degree <- tlet $ (pdiv # pDen # tokenWeight) - leftSideRaw <- tlet $ (ppow # tokenG # degree) #* leftSideMultiplicator - leftSide <- tlet $ roundToTest # leftSideRaw # rightSideLength # leftSideLength - gEDiff <- tlet $ leftSide - rightSideRaw - let - validGEquality = pif - ( gEDiff #<= (pconstant 0) ) - ( (pconstant (-1)) #<= gEDiff ) - ( gEDiff #<= (pconstant 1) ) - - pure validGEquality - -verifyTExpEquality :: - Term s - ( PInteger - :--> PInteger - :--> PInteger - :--> PInteger - :--> PBool - ) -verifyTExpEquality = phoistAcyclic $ - plam $ \tokenT rightSide rightSideLength tokenTPowLength -> unTermCont $ do - leftSideRounded <- tlet $ (roundToTest # (ppow # tokenT # pDen) # rightSideLength # tokenTPowLength) - delta <- tlet (leftSideRounded - rightSide) - tlet (checkLength # rightSide # rightSideLength) - let - validDelta = pif - ( delta #<= (pconstant 0) ) - ( (pconstant (-1)) #<= delta ) - ( delta #<= (pconstant 1) ) - - pure $ validDelta - -validGTAndTokenDeltaWithFees :: - ClosedTerm - ( PInteger - :--> PInteger - :--> PInteger - :--> PInteger - :--> PInteger - :--> PInteger - :--> PInteger - :--> PInteger - :--> PInteger - :--> PInteger - :--> PInteger - :--> PInteger - :--> PBool - ) -validGTAndTokenDeltaWithFees = phoistAcyclic $ - -- leftSideMultiplicator = feeDen - -- leftSide = (ppow # tokenG # degree) #* leftSideMultiplicator - -- rightSide = (prevTokenBalance #* feeDen + tokenDelta #* fees) - plam $ \prevTokenBalance newTokenBalanceLength tokenWeight tokenDelta tokenG tokenGLength tokenT tokenTPowLength tokenTPowWeightLength leftSideLength rightSideLength fees -> - let - correctGandT = verifyGTValues # (prevTokenBalance #+ tokenDelta) # newTokenBalanceLength # tokenWeight # tokenG # tokenT # tokenGLength # tokenTPowWeightLength - - correctTokenValue = pif - ( (pmod # pDen # tokenWeight) #== (pconstant 0) ) - ( verifyGEquality # feeDen # (prevTokenBalance #* feeDen + tokenDelta #* fees) # tokenG # tokenWeight # leftSideLength # rightSideLength ) --( leftSide #== rightSide ) - ( verifyTExpEquality # tokenT # (prevTokenBalance #* feeDen + tokenDelta #* fees) # rightSideLength # tokenTPowLength ) - - in correctGandT #&& correctTokenValue - --- Common task is validate G against T and new token value -validGTAndTokenDeltaWithoutFees :: - Term s - ( PInteger - :--> PInteger - :--> PInteger - :--> PInteger - :--> PInteger - :--> PInteger - :--> PInteger - :--> PInteger - :--> PInteger - :--> PInteger - :--> PInteger - :--> PBool - ) -validGTAndTokenDeltaWithoutFees = phoistAcyclic $ - -- leftSideMultiplicator = (pconstant 1) - -- leftSide = (ppow # tokenG # degree) #* leftSideMultiplicator - -- rightSide = (prevTokenBalance + tokenDelta) - plam $ \prevTokenBalance prevTokenBalanceLength tokenWeight tokenDelta tokenG tokenGLength tokenT tokenTPowLength tokenTPowWeightLength leftSideLength rightSideLength -> - let - correctGandT = verifyGTValues # (prevTokenBalance + tokenDelta) # prevTokenBalanceLength # tokenWeight # tokenG # tokenT # tokenGLength # tokenTPowWeightLength - - correctTokenValue = pif - ( (pmod # pDen # tokenWeight) #== (pconstant 0) ) - ( verifyGEquality # (pconstant 1) # (prevTokenBalance + tokenDelta) # tokenG # tokenWeight # leftSideLength # rightSideLength ) - ( verifyTExpEquality # tokenT # (prevTokenBalance + tokenDelta) # rightSideLength # tokenTPowLength ) - - in (correctGandT #&& correctTokenValue) - + validSwap :: ClosedTerm ( BalancePoolState :--> BalancePoolState :--> BalancePoolConfig - :--> BalancePoolConfig - :--> PInteger - :--> PInteger - :--> PInteger - :--> PInteger - :--> PInteger - :--> PInteger - :--> PInteger - :--> PInteger - :--> PInteger - :--> PInteger - :--> PInteger - :--> PInteger - :--> PInteger - :--> PInteger - :--> PInteger - :--> PInteger - :--> PInteger + :--> BalancePoolConfig :--> PBool ) -validSwap = plam $ \prevState' newState' prevPoolConfig newPoolConfig newGX newTx newGY newTy gXgYLength newXBalanceLength newGXLength newTxPowLength newTxPowWeightLength leftSideLengthX rightSideLengthX newYBalanceLength newGYLength newTyPowLength newTyPowWeightLength leftSideLengthY rightSideLengthY -> unTermCont $ do +validSwap = plam $ \prevState' newState' prevPoolConfig newPoolConfig -> unTermCont $ do prevState <- pletFieldsC @'["reservesX", "reservesY", "liquidity"] prevState' newState <- pletFieldsC @'["reservesX", "reservesY", "liquidity"] newState' - prevConfig <- pletFieldsC @'["poolNft", "poolX", "weightX", "poolY", "weightY", "poolLq", "feeNum", "treasuryFee", "treasuryX", "treasuryY", "DAOPolicy", "treasuryAddress", "invariant", "invariantLength"] prevPoolConfig + prevConfig <- pletFieldsC @'["poolNft", "poolX", "poolY", "poolLq", "feeNum", "treasuryFee", "treasuryX", "treasuryY", "DAOPolicy", "treasuryAddress"] prevPoolConfig newConfig <- pletFieldsC @'["treasuryX", "treasuryY"] newPoolConfig let prevPoolNft = getField @"poolNft" prevConfig prevPoolX = getField @"poolX" prevConfig - weightX = getField @"weightX" prevConfig prevPoolY = getField @"poolY" prevConfig - weightY = getField @"weightY" prevConfig prevPoolLq = getField @"poolLq" prevConfig feeNum = getField @"feeNum" prevConfig treasuryFee = getField @"treasuryFee" prevConfig @@ -338,8 +159,6 @@ validSwap = plam $ \prevState' newState' prevPoolConfig newPoolConfig newGX newT prevTreasuryY = getField @"treasuryY" prevConfig prevDAOPolicy = getField @"DAOPolicy" prevConfig prevTreasuryAddress = getField @"treasuryAddress" prevConfig - prevInvariant = getField @"invariant" prevConfig - invariantLength = getField @"invariantLength" prevConfig newTreasuryX = getField @"treasuryX" newConfig newTreasuryY = getField @"treasuryY" newConfig @@ -357,51 +176,44 @@ validSwap = plam $ \prevState' newState' prevPoolConfig newPoolConfig newGX newT dy <- tlet $ newY - prevY dlq <- tlet $ newLq - prevLq - newInvarianRounded <- tlet $ roundToTest # (newGX #* newGY) # invariantLength # gXgYLength - invariantRoundingDiff <- tlet $ newInvarianRounded - prevInvariant - let - -- Verify that new value of invariant equals to previous - newInvariantIsCorrect = pif - ( invariantRoundingDiff #<= (pconstant 0) ) - ( (pconstant (-1)) #<= invariantRoundingDiff ) - ( invariantRoundingDiff #<= (pconstant 1) ) - - -- g,t related to tokens with fees + fullFeeNum = feeNum - treasuryFee - -- leftSideMultiplicator = feeDen - -- leftSide = (ppow # tokenG # degree) #* leftSideMultiplicator - -- rightSide = (prevTokenBalance #* feeDen + tokenDelta #* fees) + currentInvariant = prevX * (prevY * prevY * prevY * prevY) - -- without fees - -- leftSideMultiplicator = (pconstant 1) - -- leftSide = (ppow # tokenG # degree) #* leftSideMultiplicator - -- rightSide = (prevTokenBalance + tokenDelta) + newXPart = + pif + (zero #< dx) + (prevX + (pdiv # (dx * fullFeeNum) # feeDen)) + (prevX + dx) - correctTokensUpdate = + newYPart = pif - ( zero #< dx ) - ( - (validGTAndTokenDeltaWithFees # prevX # newXBalanceLength # weightX # dx # newGX # newGXLength # newTx # newTxPowLength # newTxPowWeightLength # leftSideLengthX # rightSideLengthX # (feeNum - treasuryFee)) - #&& (validGTAndTokenDeltaWithoutFees # prevY # newYBalanceLength # weightY # dy # newGY # newGYLength # newTy # newTyPowLength # newTyPowWeightLength # leftSideLengthY # rightSideLengthY) - ) - ( (validGTAndTokenDeltaWithoutFees # prevX # newXBalanceLength # weightX # dx # newGX # newGXLength # newTx # newTxPowLength # newTxPowWeightLength # leftSideLengthX # rightSideLengthX) - #&& (validGTAndTokenDeltaWithFees # prevY # newYBalanceLength # weightY # dy # newGY # newGYLength # newTy # newTyPowLength # newTyPowWeightLength # leftSideLengthY # rightSideLengthY # (feeNum - treasuryFee)) - ) + (zero #< dx) + (prevY + dy) + (prevY + pdiv # (dy * fullFeeNum) # feeDen) + + newInvariant = newXPart * (newYPart * newYPart * newYPart * newYPart) correctTreasuryUpdate = pif - ( zero #< dx ) - ( ((feeDen * prevTreasuryX + (dx * treasuryFee)) #<= ((newTreasuryX + 1) * feeDen)) #&& (prevTreasuryY #== newTreasuryY) ) - ( ((feeDen * prevTreasuryY + (dy * treasuryFee)) #<= ((newTreasuryY + 1) * feeDen)) #&& (prevTreasuryX #== newTreasuryX) ) + (zero #< dx) + (newTreasuryX #== (prevTreasuryX + (pdiv # (dx * treasuryFee) # feeDen))) + (newTreasuryY #== (prevTreasuryY + (pdiv # (dy * treasuryFee) # feeDen))) + + anotherTokenTreasuryCorrect = + pif + (zero #< dx) + (prevTreasuryY #== newTreasuryY) + (prevTreasuryX #== newTreasuryX) + + correctInv <- tlet $ currentInvariant #<= newInvariant newExpectedConfig <- tcon $ (BalancePoolConfig $ pdcons @"poolNft" @PAssetClass # pdata prevPoolNft #$ pdcons @"poolX" @PAssetClass # pdata prevPoolX - #$ pdcons @"weightX" @PInteger # pdata weightX #$ pdcons @"poolY" @PAssetClass # pdata prevPoolY - #$ pdcons @"weightY" @PInteger # pdata weightY #$ pdcons @"poolLq" @PAssetClass # pdata prevPoolLq #$ pdcons @"feeNum" @PInteger # pdata feeNum #$ pdcons @"treasuryFee" @PInteger # pdata treasuryFee @@ -409,14 +221,12 @@ validSwap = plam $ \prevState' newState' prevPoolConfig newPoolConfig newGX newT #$ pdcons @"treasuryY" @PInteger # pdata newTreasuryY #$ pdcons @"DAOPolicy" @(PBuiltinList (PAsData PStakingCredential)) # pdata prevDAOPolicy #$ pdcons @"treasuryAddress" @PValidatorHash # pdata prevTreasuryAddress - #$ pdcons @"invariant" @PInteger # pdata prevInvariant - #$ pdcons @"invariantLength" @PInteger # pdata invariantLength # pdnil) pure $ - ( newInvariantIsCorrect - #&& correctTokensUpdate + ( correctInv #&& correctTreasuryUpdate + #&& anotherTokenTreasuryCorrect #&& (newPoolConfig #== newExpectedConfig) #&& (dlq #== zero) ) @@ -462,14 +272,11 @@ validDepositRedeemAllTokens :: validDepositRedeemAllTokens = plam $ \prevState' newState' prevPoolConfig newPoolConfig -> unTermCont $ do prevState <- pletFieldsC @'["reservesX", "reservesY", "liquidity"] prevState' newState <- pletFieldsC @'["reservesX", "reservesY", "liquidity"] newState' - prevConfig <- pletFieldsC @'["poolNft", "poolX", "weightX", "poolY", "weightY", "poolLq", "feeNum", "treasuryFee", "treasuryX", "treasuryY", "DAOPolicy", "treasuryAddress", "invariant", "invariantLength"] prevPoolConfig - newConfig <- pletFieldsC @'["invariant", "invariantLength"] newPoolConfig + prevConfig <- pletFieldsC @'["poolNft", "poolX", "poolY", "poolLq", "feeNum", "treasuryFee", "treasuryX", "treasuryY", "DAOPolicy", "treasuryAddress"] prevPoolConfig let prevPoolNft = getField @"poolNft" prevConfig prevPoolX = getField @"poolX" prevConfig - weightX = getField @"weightX" prevConfig prevPoolY = getField @"poolY" prevConfig - weightY = getField @"weightY" prevConfig prevPoolLq = getField @"poolLq" prevConfig feeNum = getField @"feeNum" prevConfig treasuryFee = getField @"treasuryFee" prevConfig @@ -477,10 +284,6 @@ validDepositRedeemAllTokens = plam $ \prevState' newState' prevPoolConfig newPoo prevTreasuryY = getField @"treasuryY" prevConfig prevDAOPolicy = getField @"DAOPolicy" prevConfig prevTreasuryAddress = getField @"treasuryAddress" prevConfig - prevInvariant = getField @"invariant" prevConfig - - newInvariant = getField @"invariant" newConfig - newInvariantLength = getField @"invariantLength" newConfig prevX = pfromData $ getField @"reservesX" prevState prevY = pfromData $ getField @"reservesY" prevState @@ -495,27 +298,14 @@ validDepositRedeemAllTokens = plam $ \prevState' newState' prevPoolConfig newPoo dlq <- tlet $ newLq - prevLq let - newCalculatedInvariant = pdiv # ((prevX + dx) #* prevInvariant) # prevX - - invariantroundUpIsNecessary = 0 #< (pmod # ((prevX + dx) #* prevInvariant) # prevX) - - normalizedInvariant = - pif (invariantroundUpIsNecessary) - (newCalculatedInvariant #+ 1) - (newCalculatedInvariant) - xDepositRedeemIsValid = correctLpTokenDelta # prevLq # dlq # dx # prevX yDepositRedeemIsValid = correctLpTokenDelta # prevLq # dlq # dy # prevY - tlet (checkLength # newInvariant # newInvariantLength) - newExpectedConfig <- tcon $ (BalancePoolConfig $ pdcons @"poolNft" @PAssetClass # pdata prevPoolNft #$ pdcons @"poolX" @PAssetClass # pdata prevPoolX - #$ pdcons @"weightX" @PInteger # pdata weightX #$ pdcons @"poolY" @PAssetClass # pdata prevPoolY - #$ pdcons @"weightY" @PInteger # pdata weightY #$ pdcons @"poolLq" @PAssetClass # pdata prevPoolLq #$ pdcons @"feeNum" @PInteger # pdata feeNum #$ pdcons @"treasuryFee" @PInteger # pdata treasuryFee @@ -523,13 +313,10 @@ validDepositRedeemAllTokens = plam $ \prevState' newState' prevPoolConfig newPoo #$ pdcons @"treasuryY" @PInteger # pdata prevTreasuryY #$ pdcons @"DAOPolicy" @(PBuiltinList (PAsData PStakingCredential)) # pdata prevDAOPolicy #$ pdcons @"treasuryAddress" @PValidatorHash # pdata prevTreasuryAddress - #$ pdcons @"invariant" @PInteger # pdata newInvariant - #$ pdcons @"invariantLength" @PInteger # pdata newInvariantLength # pdnil) pure $ - ( normalizedInvariant #== newInvariant - #&& xDepositRedeemIsValid + ( xDepositRedeemIsValid #&& yDepositRedeemIsValid #&& newPoolConfig #== newExpectedConfig ) @@ -562,16 +349,11 @@ readPoolState = phoistAcyclic $ balancePoolValidatorT :: ClosedTerm (BalancePoolConfig :--> BalancePoolRedeemer :--> PScriptContext :--> PBool) balancePoolValidatorT = plam $ \conf redeemer' ctx' -> unTermCont $ do - redeemer <- pletFieldsC @'["action", "selfIx", "g", "t", "lengths"] redeemer' + redeemer <- pletFieldsC @'["action", "selfIx"] redeemer' let selfIx = getField @"selfIx" redeemer action = getField @"action" redeemer - gList = getField @"g" redeemer - tList = getField @"t" redeemer - - lList = getField @"lengths" redeemer - ctx <- pletFieldsC @'["txInfo", "purpose"] ctx' let txinfo' = getField @"txInfo" ctx @@ -622,28 +404,7 @@ balancePoolValidatorT = plam $ \conf redeemer' ctx' -> unTermCont $ do pure $ selfIdentity #&& (pmatch action $ \case Swap -> unTermCont $ do - - gx <- tletUnwrap $ phead # gList - gy <- tletUnwrap $ pelemAt # (pconstant 1) # gList - tx <- tletUnwrap $ phead # tList - ty <- tletUnwrap $ pelemAt # (pconstant 1) # tList - - -- Parsing length list - gXgYLength <- tletUnwrap $ phead # lList - newXBalanceLength <- tletUnwrap $ pelemAt # (pconstant 1) # lList - newGXLength <- tletUnwrap $ pelemAt # (pconstant 2) # lList - newTxPowLength <- tletUnwrap $ pelemAt # (pconstant 3) # lList - newTxPowWeightLength <- tletUnwrap $ pelemAt # (pconstant 4) # lList - leftSideLengthX <- tletUnwrap $ pelemAt # (pconstant 5) # lList - rightSideLengthX <- tletUnwrap $ pelemAt # (pconstant 6) # lList - newYBalanceLength <- tletUnwrap $ pelemAt # (pconstant 7) # lList - newGYLength <- tletUnwrap $ pelemAt # (pconstant 8) # lList - newTyPowLength <- tletUnwrap $ pelemAt # (pconstant 9) # lList - newTyPowWeightLength <- tletUnwrap $ pelemAt # (pconstant 10) # lList - leftSideLengthY <- tletUnwrap $ pelemAt # (pconstant 11) # lList - rightSideLengthY <- tletUnwrap $ pelemAt # (pconstant 12) # lList - - pure $ noMoreTokens #&& scriptPreserved #&& (validSwap # s0 # s1 # conf # newConfig # gx # tx # gy # ty # gXgYLength # newXBalanceLength # newGXLength # newTxPowLength # newTxPowWeightLength # leftSideLengthX # rightSideLengthX # newYBalanceLength # newGYLength # newTyPowLength # newTyPowWeightLength # leftSideLengthY # rightSideLengthY) + pure $ noMoreTokens #&& scriptPreserved #&& (validSwap # s0 # s1 # conf # newConfig) DAOAction -> validDAOAction # conf # txinfo' _ -> noMoreTokens #&& scriptPreserved #&& (validDepositRedeemAllTokens # s0 # s1 # conf # newConfig) ) \ No newline at end of file diff --git a/plutarch-validators/WhalePoolsDex/PContracts/PFeeSwitchBalancePool.hs b/plutarch-validators/WhalePoolsDex/PContracts/PFeeSwitchBalancePool.hs index 26e0cfb..a673545 100644 --- a/plutarch-validators/WhalePoolsDex/PContracts/PFeeSwitchBalancePool.hs +++ b/plutarch-validators/WhalePoolsDex/PContracts/PFeeSwitchBalancePool.hs @@ -83,36 +83,24 @@ instance PlutusType DAOAction where ) -- All SwitchFee actions shouldn't modify main poolConfig elements: poolNft, poolX, poolY, poolLq, lqBound, feeNum -validateCommonFields :: PMemberFields BalancePoolConfig '["poolNft", "poolX", "poolY", "poolLq", "weightX", "weightY", "invariant", "invariantLength"] s as => HRec as -> HRec as -> Term s PBool +validateCommonFields :: PMemberFields BalancePoolConfig '["poolNft", "poolX", "poolY", "poolLq"] s as => HRec as -> HRec as -> Term s PBool validateCommonFields prevConfig newConfig = let prevPoolNft = getField @"poolNft" prevConfig prevPoolX = getField @"poolX" prevConfig - prevWeightX = getField @"weightX" prevConfig prevPoolY = getField @"poolY" prevConfig - prevWeightY = getField @"weightY" prevConfig prevPoolLq = getField @"poolLq" prevConfig - prevInvariant = getField @"invariant" prevConfig - prevInvariantLength = getField @"invariantLength" prevConfig newPoolNft = getField @"poolNft" newConfig newPoolX = getField @"poolX" newConfig - newWeightX = getField @"weightX" newConfig newPoolY = getField @"poolY" newConfig - newWeightY = getField @"weightY" newConfig newPoolLq = getField @"poolLq" newConfig - newInvariant = getField @"invariant" newConfig - newInvariantLength = getField @"invariantLength" newConfig commonFieldsValid = prevPoolNft #== newPoolNft #&& prevPoolX #== newPoolX #&& - prevWeightX #== newWeightX #&& prevPoolY #== newPoolY #&& - prevWeightY #== newWeightY #&& - prevPoolLq #== newPoolLq #&& - prevInvariant #== newInvariant #&& - prevInvariantLength #== newInvariantLength + prevPoolLq #== newPoolLq in commonFieldsValid @@ -220,8 +208,8 @@ daoMultisigPolicyValidatorT poolNft daoPkhs threshold lpFeeIsEditable = plam $ \ poolInputAddr <- tletField @"address" poolInputResolved poolOutputAddr <- tletField @"address" successor - prevConf <- pletFieldsC @'["poolNft", "poolX", "weightX", "poolY", "weightY", "poolLq", "feeNum", "treasuryFee", "treasuryX", "treasuryY", "DAOPolicy", "treasuryAddress", "invariant", "invariantLength"] poolInputDatum - newConf <- pletFieldsC @'["poolNft", "poolX", "weightX", "poolY", "weightY", "poolLq", "feeNum", "treasuryFee", "treasuryX", "treasuryY", "DAOPolicy", "treasuryAddress", "invariant", "invariantLength"] poolOutputDatum + prevConf <- pletFieldsC @'["poolNft", "poolX", "poolY", "poolLq", "feeNum", "treasuryFee", "treasuryX", "treasuryY", "DAOPolicy", "treasuryAddress"] poolInputDatum + newConf <- pletFieldsC @'["poolNft", "poolX", "poolY", "poolLq", "feeNum", "treasuryFee", "treasuryX", "treasuryY", "DAOPolicy", "treasuryAddress"] poolOutputDatum let validSignaturesQty = pfoldl # plam (\acc pkh -> pif (containsSignature # signatories # pkh) (acc + 1) acc) # 0 # daoPkhs diff --git a/plutarch-validators/test/Eval.hs b/plutarch-validators/test/Eval.hs index cea2a9a..3c85de7 100644 --- a/plutarch-validators/test/Eval.hs +++ b/plutarch-validators/test/Eval.hs @@ -20,6 +20,7 @@ evalWithArgs :: ClosedTerm a -> [Data] -> Either Text (ExBudget, [Text], Program evalWithArgs x args = do cmp <- compile evalConfig x let (escr, budg, trc) = evalScript $ applyArguments cmp args + traceM $ 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 ec48b80..0f5004c 100644 --- a/plutarch-validators/test/Gen/BalancePoolGen.hs +++ b/plutarch-validators/test/Gen/BalancePoolGen.hs @@ -46,15 +46,13 @@ 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 System.IO import WhalePoolsDex.Contracts.BalancePool data BalancePoolActionResult = BalancePoolActionResult { newPool :: BalancePool , additionalOutputs :: [TxOut] - , g :: [Integer] - , t :: [Integer] - , lList :: [Integer] } deriving Show data BalancePoolTestAction m = BalancePoolTestAction @@ -88,7 +86,7 @@ instance ToTxInfo BalancePool where } feeDen = 100000 -precisionAdditionalDec = 10 +precisionAdditionalDec = 15 daoMintingPurpose :: BalancePool -> ScriptPurpose daoMintingPurpose BalancePool{..} = Rewarding $ List.head (daoPolicy config) @@ -97,7 +95,7 @@ daoValidator :: BalancePool -> [PubKeyHash] -> Integer -> Bool -> ClosedTerm (PD 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 :: (MonadGen m) => BalancePool -> BalancePoolActionResult -> [PubKeyHash] -> m TxInfo createTxInfo prevPool@BalancePool{..} BalancePoolActionResult{..} adminPkhs = do poolTxIn <- toTxInInfo prevPool let @@ -139,14 +137,21 @@ genBalancePool adminsPkhs threshold lpFeeIsEditable = do stakeHash <- genPkh -- todo: error on big values such as 10 000 000 000 000 000 - (yQty :: Integer) <- integral (Range.constant 10000000000 10000000000000000) + -- (yQty :: Integer) <- integral (Range.constant 10000000000 10000000000000000) - (xWeight :: Integer) <- integral (Range.constant 1 4) - (xQty :: Integer) <- integral (Range.constant 1000000000 1000000000000) - poolFee <- integral (Range.constant 80000 feeDen) - trFee <- integral (Range.constant 1 1000) + -- (xWeight :: Integer) <- integral (Range.constant 1 4) + -- (xQty :: Integer) <- integral (Range.constant 1000000000 1000000000000) + -- poolFee <- integral (Range.constant 80000 feeDen) + -- trFee <- integral (Range.constant 1 1000) treasuryAddress <- genValidatorHash let + (yQty :: Integer) = 38156462205 + + (xWeight :: Integer) = 1 + (xQty :: Integer) = 1220000000 + poolFee = 95000 + trFee = 500 + yWeight = 5 - xWeight nftQty = 1 @@ -158,8 +163,8 @@ genBalancePool adminsPkhs threshold lpFeeIsEditable = do maxPrecision = (if (yPartLength > xValueLength) then yPartLength else xValueLength) + precisionAdditionalDec - invariantT = ((BigDecimal xQty 0) ** (fromRational $ (fromIntegral xWeight) / 5)) * ( (BigDecimal yQty 0) ** (fromRational $ (fromIntegral yWeight) / 5)) - invariant = getDecimalNum invariantT + invariantT = ((BigDecimal xQty 0) ** (fromRational $ (fromIntegral xWeight))) * ((BigDecimal yQty 0) ** (fromRational $ (fromIntegral yWeight))) + invariant = getDecimalNum (nthRoot invariantT 5 (DOWN, (Just . toInteger $ 30))) lqQty = 0x7fffffffffffffff - invariant @@ -172,18 +177,14 @@ genBalancePool adminsPkhs threshold lpFeeIsEditable = do poolConfig = BalancePoolConfig { poolNft = nft , poolX = x - , weightX = xWeight , poolY = y - , weightY = yWeight , poolLq = lq , poolFeeNum = poolFee , treasuryFee = trFee - , treasuryX = 0 + , treasuryX = 1100000 , treasuryY = 0 , daoPolicy = [daoContract] , treasuryAddress = treasuryAddress - , invariant = invariant - , invariantLength = toInteger . T.length . T.pack $ show invariant } poolValue = mkValues ((\(ac, qty) -> mkValue ac (fromIntegral qty)) `RIO.map` [(x, xQty), (y, yQty), (nft, nftQty), (lq, lqQty)]) mempty @@ -193,81 +194,112 @@ genBalancePool adminsPkhs threshold lpFeeIsEditable = do --- 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 -> Integer -> Integer -> m (Integer, Integer, Integer, Integer, Integer, [Integer]) -calculateGandTSwap baseAssetBalance baseAssetWeight baseTreasury quoteAssetBalance quoteAssetWeghit quoteTreasury baseIn lpFee treasuryFee prevInvariant = do +calculateY :: MonadGen m => Integer -> Integer -> Integer -> Integer -> Integer -> Integer -> Integer -> Integer -> Integer -> m Integer +calculateY baseAssetBalance baseAssetWeight baseTreasury quoteAssetBalance quoteAssetWeight quoteTreasury baseIn lpFee treasuryFee = do + let + prevX = BigDecimal (baseAssetBalance - baseTreasury) 0 + prevY = BigDecimal (quoteAssetBalance - quoteTreasury) 0 + + invariantFloat = (prevX ** (fromIntegral baseAssetWeight)) * (prevY ** (fromIntegral quoteAssetWeight)) +-- 84224881596217145943141940500000000000000000000 + traceM $ "prevX" + traceM $ T.pack . show $ prevX + traceM $ "baseAssetWeight" + traceM $ T.pack . show $ baseAssetWeight + traceM $ "prevY" + traceM $ T.pack . show $ prevY + traceM $ "quoteAssetWeight" + traceM $ T.pack . show $ quoteAssetWeight + traceM $ "invariantFloat" + traceM $ T.pack . show $ invariantFloat + let yPartLength = toInteger $ RIO.length . show $ quoteAssetBalance - xValueLength = toInteger $ RIO.length . show $ (baseAssetBalance + baseIn) + additionalPart = (BigDecimal (fromIntegral baseIn) 0) * (fromRational $ (fromIntegral (lpFee - treasuryFee)) / fromIntegral feeDen) + xValueFloat = BigDecimal (baseAssetBalance - baseTreasury) 0 + xInInvariantBigDecimal = xValueFloat + additionalPart + xInInvariantWithDegree = (xInInvariantBigDecimal ** ((fromIntegral baseAssetWeight))) - maxPrecision = (if (yPartLength > xValueLength) then yPartLength else xValueLength) + precisionAdditionalDec + invDivision = invariantFloat / xInInvariantWithDegree + invDivisionInReverseDegree = nthRoot (invDivision) (fromInteger quoteAssetWeight) (UP, (Just . toInteger $ 30)) + invDivisionInReverseDegreeBigDecimalRounded = takeNBigDecimal invDivisionInReverseDegree (yPartLength) + yToSwap = quoteAssetBalance - quoteTreasury - invDivisionInReverseDegreeBigDecimalRounded - invariantLength = toInteger $ RIO.length . show $ prevInvariant + (correctY, attempts) <- internalCheck (getDecimalNum xInInvariantBigDecimal) baseAssetWeight (quoteAssetBalance - quoteTreasury) quoteAssetWeight (getDecimalNum invariantFloat) yToSwap 1 - xValueFloat = (fromIntegral (baseAssetBalance - baseTreasury)) :: 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 + pure correctY - 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) / 5))) -- g - xInInvariantWith1Degree = (xInInvariantBigDecimal) ** (fromRational $ (1 / 5)) -- t - gX = ((takeNBigDecimal xInInvariantWithDegree (maxPrecision)) :: Integer) - tX = ((takeNBigDecimal xInInvariantWith1Degree (maxPrecision)) :: Integer) +calculateX :: MonadGen m => Integer -> Integer -> Integer -> Integer -> Integer -> Integer -> Integer -> Integer -> Integer -> m Integer +calculateX baseAssetBalance baseAssetWeight baseTreasury quoteAssetBalance quoteAssetWeight quoteTreasury quoteIn lpFee treasuryFee = do + let + prevX = BigDecimal (baseAssetBalance - baseTreasury) 0 + prevY = BigDecimal (quoteAssetBalance - quoteTreasury) 0 + + invariantFloat = (prevX ** (fromIntegral baseAssetWeight)) * (prevY ** (fromIntegral quoteAssetWeight)) +-- 84224881596217145943141940500000000000000000000 + traceM $ "prevX" + traceM $ T.pack . show $ prevX + traceM $ "baseAssetWeight" + traceM $ T.pack . show $ baseAssetWeight + traceM $ "prevY" + traceM $ T.pack . show $ prevY + traceM $ "quoteAssetWeight" + traceM $ T.pack . show $ quoteAssetWeight + traceM $ "invariantFloat" + traceM $ T.pack . show $ invariantFloat - invDivision = invariantFloat / xInInvariantWithDegree - test = xInInvariantWithDegree * invDivision - invDivisionInReverseDegree = nthRoot (invDivision ** 5) (fromInteger quoteAssetWeghit) (DOWN, (Just . toInteger $ 0)) - -- denum = 10 ^ (yPartLength - xValueLength) - - invDivisionInReverseDegreeBigDecimalRounded = takeNBigDecimal invDivisionInReverseDegree (yPartLength) + let + xPartLength = toInteger $ RIO.length . show $ baseAssetBalance + additionalPart = (BigDecimal (fromIntegral quoteIn) 0) * (fromRational $ (fromIntegral (lpFee - treasuryFee)) / fromIntegral feeDen) + yValueFloat = BigDecimal (quoteAssetBalance - quoteTreasury) 0 + yInInvariantBigDecimal = yValueFloat + additionalPart + yInInvariantWithDegree = (yInInvariantBigDecimal ** ((fromIntegral quoteAssetWeight))) - yToSwap = quoteAssetBalance - invDivisionInReverseDegreeBigDecimalRounded + invDivision = invariantFloat / yInInvariantWithDegree + invDivisionInReverseDegree = nthRoot (invDivision) (fromInteger baseAssetWeight) (UP, (Just . toInteger $ 30)) + invDivisionInReverseDegreeBigDecimalRounded = takeNBigDecimal invDivisionInReverseDegree (xPartLength) + xToSwap = baseAssetBalance - baseTreasury - invDivisionInReverseDegreeBigDecimalRounded - gYDouble = ((BigDecimal (quoteAssetBalance - yToSwap) 0) ** (fromRational $ (fromIntegral quoteAssetWeghit) / 5)) :: BigDecimal -- g - tGDouble = (((BigDecimal (quoteAssetBalance - yToSwap) 0) ** (fromRational $ (1 / 5)))) :: BigDecimal -- g + (correctX, attempts) <- internalCheckX (baseAssetBalance - baseTreasury) baseAssetWeight (getDecimalNum yInInvariantBigDecimal) quoteAssetWeight (getDecimalNum invariantFloat) xToSwap 1 - gY = takeNBigDecimal gYDouble (maxPrecision) - tY = takeNBigDecimal tGDouble (maxPrecision) + pure correctX - spotPriceWithoutFee = (((BigDecimal baseAssetBalance 0)) / ((BigDecimal baseAssetWeight 0))) / (((BigDecimal quoteAssetBalance 0)) / ((BigDecimal quoteAssetWeghit 0))) :: BigDecimal - spotPriceWithFee = spotPriceWithoutFee * (fromRational $ (fromIntegral (lpFee - treasuryFee) / fromIntegral (feeDen))) - - gXgYLength = toInteger $ T.length . T.pack $ show (gX * gY) - newXBalanceLength = toInteger $ T.length . T.pack $ show (baseAssetBalance + baseIn) - newGXLength = toInteger $ T.length . T.pack $ show gX - newTxPowLength = toInteger $ T.length . T.pack $ show (tX ^ 5) - newTxPowWeightLength = toInteger $ T.length . T.pack $ show (tX ^ baseAssetWeight) - leftSideLengthX = toInteger $ T.length . T.pack $ show ((gX ^ 5) * 100000) -- degree = 5 - rightSideLengthX = toInteger $ T.length . T.pack $ show ((baseAssetBalance * feeDen + baseIn * ((lpFee - treasuryFee)))) - newYBalanceLength = toInteger $ T.length . T.pack $ show (quoteAssetBalance - yToSwap) - newGYLength = toInteger $ T.length . T.pack $ show gY - newTyPowLength = toInteger $ T.length . T.pack $ show (tY ^ 5) - newTyPowWeightLength = toInteger $ T.length . T.pack $ show (tY ^ quoteAssetWeghit) - leftSideLengthY = if (quoteAssetWeghit == 1) then (toInteger $ T.length . T.pack $ show ((gY ^ 5) * 1)) else (toInteger $ T.length . T.pack $ show ((gY ^ 5) * baseAssetWeight)) - rightSideLengthY = toInteger $ T.length . T.pack $ show (quoteAssetBalance - yToSwap) - - pure (gX, tX, gY, tY, yToSwap, [gXgYLength, newXBalanceLength, newGXLength, newTxPowLength, newTxPowWeightLength, leftSideLengthX, rightSideLengthX, newYBalanceLength, newGYLength, newTyPowLength, newTyPowWeightLength, leftSideLengthY, rightSideLengthY]) +internalCheck :: Monad m => Integer -> Integer -> Integer -> Integer -> Integer -> Integer -> Integer -> m (Integer, Integer) +internalCheck baseAssetBalance baseAssetWeight quoteAssetBalance quoteAssetWeight prevInvariant quoteToSwap startAcc = do + let + newInvariant = getDecimalNum $ (((BigDecimal baseAssetBalance 0)) ** (fromRational $ (fromIntegral baseAssetWeight))) * ((BigDecimal (quoteAssetBalance - quoteToSwap) 0) ** (fromRational $ (fromIntegral quoteAssetWeight))) + if (newInvariant >= prevInvariant) + then pure $ (quoteToSwap, startAcc) + else internalCheck baseAssetBalance baseAssetWeight quoteAssetBalance quoteAssetWeight prevInvariant (quoteToSwap - 1) (startAcc + 1) + +internalCheckX :: Monad m => Integer -> Integer -> Integer -> Integer -> Integer -> Integer -> Integer -> m (Integer, Integer) +internalCheckX baseAssetBalance baseAssetWeight quoteAssetBalance quoteAssetWeight prevInvariant baseToSwap startAcc = do + let + newInvariant = getDecimalNum $ (((BigDecimal (baseAssetBalance - baseToSwap) 0)) ** (fromRational $ (fromIntegral baseAssetWeight))) * (((BigDecimal quoteAssetBalance) 0) ** (fromRational $ (fromIntegral quoteAssetWeight))) + traceM "newInvariant in check" + traceM $ T.pack . show $ newInvariant + traceM "prevInvariant" + traceM $ T.pack . show $ prevInvariant + if (newInvariant >= prevInvariant) + then pure $ (baseToSwap, startAcc) + else internalCheck baseAssetBalance baseAssetWeight quoteAssetBalance quoteAssetWeight prevInvariant (baseToSwap - 1) (startAcc + 1) -- 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, [Integer], Integer) -calculateGandTDeposit baseAssetBalance baseAssetWeight quoteAssetBalance quoteAssetWeghit lqIssued lqSupply lpFee treasuryFee prevInvariant = do +calculateGandTDeposit :: MonadGen m => Integer -> Integer -> Integer -> Integer -> Integer -> Integer -> Integer -> Integer -> Integer -> Integer -> m (Integer, Integer, Integer, Integer) +calculateGandTDeposit baseAssetBalance baseTreasury baseAssetWeight quoteAssetBalance quoteTreasury quoteAssetWeghit lqIssued lqSupply lpFee treasuryFee = do let + prevX = BigDecimal (baseAssetBalance - baseTreasury) 0 + prevY = BigDecimal (quoteAssetBalance - quoteTreasury) 0 + + invariantFloat = (prevX ** (fromIntegral baseAssetWeight)) * (prevY ** (fromIntegral quoteAssetWeghit)) + prevInvariant = getDecimalNum invariantFloat + lqSupplyDouble = (fromIntegral lqSupply) :: BigDecimal lqIssuedDec = (fromIntegral lqIssued) :: BigDecimal 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 xToDeposit = roundBD ((lqIssuedDec * xValueFloat) / lqSupplyDouble) (DOWN, (Just . toInteger $ 0)) yToDeposit = roundBD ((lqIssuedDec * yValueFloat) / lqSupplyDouble) (DOWN, (Just . toInteger $ 0)) @@ -281,36 +313,12 @@ calculateGandTDeposit baseAssetBalance baseAssetWeight quoteAssetBalance quoteAs xInInvariantWithDegree = (xInInvariantBigDecimal ** (fromRational $ ((fromIntegral baseAssetWeight) / 5))) -- g xInInvariantWith1Degree = (xInInvariantBigDecimal) ** (fromRational $ (1 / 5)) -- t - gX = ((takeNBigDecimal xInInvariantWithDegree (maxPrecision)) :: Integer) - tX = ((takeNBigDecimal xInInvariantWith1Degree (maxPrecision)) :: Integer) - gBase = yValueFloat + yToDeposit gBaseRounded = BigDecimal (getDecimalNum (yValueFloat + yToDeposit)) 0 - gYDouble = nthRoot (gBaseRounded ** yWeightFloat) 5 (UP, (Just . toInteger $ maxPrecision)) :: BigDecimal -- g - - tGDoubleTest = nthRoot gBaseRounded 5 (DOWN, (Just . toInteger $ maxPrecision)) - tGDouble = nthRoot gBaseRounded 5 (DOWN, (Just . toInteger $ maxPrecision)) - gY = takeNBigDecimal gYDouble (maxPrecision) - tY = takeNBigDecimal tGDouble (maxPrecision) - xToAdd = getDecimalNum xToDeposit yToAdd = getDecimalNum yToDeposit - gXgYLength = toInteger $ T.length . T.pack $ show (gX * gY) - newXBalanceLength = toInteger $ T.length . T.pack $ show (baseAssetBalance + xToAdd) - newGXLength = toInteger $ T.length . T.pack $ show gX - newTxPowLength = toInteger $ T.length . T.pack $ show (tX ^ 5) - newTxPowWeightLength = toInteger $ T.length . T.pack $ show (tX ^ baseAssetWeight) - leftSideLengthX = if (quoteAssetWeghit == 1) then (toInteger $ T.length . T.pack $ show ((gX ^ 5) * 1)) else (toInteger $ T.length . T.pack $ show ((gX ^ 5) * 1)) - rightSideLengthX = toInteger $ T.length . T.pack $ show (baseAssetBalance + xToAdd) - newYBalanceLength = toInteger $ T.length . T.pack $ show (quoteAssetBalance + yToAdd) - newGYLength = toInteger $ T.length . T.pack $ show gY - newTyPowLength = toInteger $ T.length . T.pack $ show (tY ^ 5) - newTyPowWeightLength = toInteger $ T.length . T.pack $ show (tY ^ quoteAssetWeghit) - leftSideLengthY = if (quoteAssetWeghit == 1) then (toInteger $ T.length . T.pack $ show ((gY ^ 5) * 1)) else (toInteger $ T.length . T.pack $ show ((gY ^ 5) * 1)) - rightSideLengthY = toInteger $ T.length . T.pack $ show (quoteAssetBalance + yToAdd) - invariantT = ((BigDecimal (baseAssetBalance + xToAdd) 0) ** (fromRational $ (fromIntegral baseAssetWeight) / 5)) * ( (BigDecimal (quoteAssetBalance + yToAdd) 0) ** (fromRational $ (fromIntegral quoteAssetWeghit) / 5)) invariant = getDecimalNum invariantT @@ -326,11 +334,18 @@ calculateGandTDeposit baseAssetBalance baseAssetWeight quoteAssetBalance quoteAs normalizedNeInvariantLength = toInteger $ T.length . T.pack $ show normalizedNeInvariant - pure (gX, tX, gY, tY, getDecimalNum xToDeposit, getDecimalNum yToDeposit, getDecimalNum lqIssuedDec, [normalizedNeInvariantLength, newXBalanceLength, newGXLength, newTxPowLength, newTxPowWeightLength, leftSideLengthX, rightSideLengthX, newYBalanceLength, newGYLength, newTyPowLength, newTyPowWeightLength, leftSideLengthY, rightSideLengthY], normalizedNeInvariant) + pure (getDecimalNum xToDeposit, getDecimalNum yToDeposit, getDecimalNum lqIssuedDec, normalizedNeInvariant) -calculateGandTRedeem :: MonadGen m => Integer -> Integer -> Integer -> Integer -> Integer -> Integer -> Integer -> Integer -> Integer -> m (Integer, Integer, Integer, Integer, Integer, Integer, Integer, Integer) -calculateGandTRedeem baseAssetBalance baseAssetWeight quoteAssetBalance quoteAssetWeghit lqRedeem lqSupply lpFee treasuryFee prevInvariant = do +calculateGandTRedeem :: MonadGen m => Integer -> Integer -> Integer -> Integer -> Integer -> Integer -> Integer -> Integer -> Integer -> Integer -> m (Integer, Integer) +calculateGandTRedeem baseAssetBalance baseTreasury baseAssetWeight quoteAssetBalance quoteTreasury quoteAssetWeghit lqRedeem lqSupply lpFee treasuryFee = do let + + prevX = BigDecimal (baseAssetBalance - baseTreasury) 0 + prevY = BigDecimal (quoteAssetBalance - quoteTreasury) 0 + + invariantFloat = (prevX ** (fromIntegral baseAssetWeight)) * (prevY ** (fromIntegral quoteAssetWeghit)) + prevInvariant = getDecimalNum invariantFloat + lqRedeemDec = (fromIntegral lqRedeem) :: BigDecimal xToRedeem = roundBD ((lqRedeemDec * xValueFloat) / lqSupplyDouble) (DOWN, (Just . toInteger $ 0)) yToRedeem = roundBD ((lqRedeemDec * yValueFloat) / lqSupplyDouble) (DOWN, (Just . toInteger $ 0)) @@ -342,7 +357,6 @@ calculateGandTRedeem baseAssetBalance baseAssetWeight quoteAssetBalance quoteAss 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 @@ -376,7 +390,7 @@ calculateGandTRedeem baseAssetBalance baseAssetWeight quoteAssetBalance quoteAss normalizedNeInvariantLength = toInteger $ T.length . T.pack $ show normalizedNeInvariant - pure (gX, tX, gY, tY, getDecimalNum xToRedeem, getDecimalNum yToRedeem, normalizedNeInvariant, normalizedNeInvariantLength) + pure (getDecimalNum xToRedeem, getDecimalNum yToRedeem) --- Test cases --- @@ -398,23 +412,27 @@ correctSwap = (yCS, yTN) = unAssetClass (poolY config) xValue = valueOf value xCS xTN yValue = valueOf value yCS yTN - xToSwap <- integral (Range.constant 100 xValue) - (gX, tX, gY, tY, yToSwap, llist) <- calculateGandTSwap xValue (weightX config) (treasuryX config) yValue (weightY config) (treasuryY config) (xToSwap) (poolFeeNum config) (treasuryFee config) (invariant config) + yToSwap = 70000000 + + -- xToSwap <- integral (Range.constant 100 xValue) + xToSwap <- calculateX xValue 1 (treasuryX config) yValue 4 (treasuryY config) (yToSwap) (poolFeeNum config) (treasuryFee config) let -- going to withdraw all pool x and y value tFee = treasuryFee config + traceM $ T.pack $ "xToSwap: " ++ show xToSwap + let newPoolConfig = config - { treasuryX = (tFee * xToSwap) `div` feeDen - , treasuryY = 0 + { treasuryX = (treasuryX config) + , treasuryY = (treasuryY config) + ((tFee * yToSwap) `div` feeDen) } - + let newPool = prevPool { config = newPoolConfig - , value = value <> (assetClassValue (poolX config) (xToSwap)) <> (assetClassValue (poolY config) (negate yToSwap)) + , value = value <> (assetClassValue (poolX config) (negate xToSwap)) <> (assetClassValue (poolY config) (yToSwap)) } - - pure $ BalancePoolActionResult newPool [] [gX, gY] [tX, tY] llist + traceM $ T.pack $ "newValue: " ++ show (value <> (assetClassValue (poolX config) (xToSwap)) <> (assetClassValue (poolY config) (negate yToSwap))) + pure $ BalancePoolActionResult newPool [] in BalancePoolTestAction "Correct swap" testAction incorrectSwapGT :: MonadGen m => BalancePoolTestAction m @@ -429,13 +447,13 @@ incorrectSwapGT = yValue = valueOf value yCS yTN xToSwap <- integral (Range.constant 1 ((xValue `div` 2) - 1)) - (gX, tX, gY, tY, yToSwap, llist) <- calculateGandTSwap xValue (weightX config) (treasuryX config) yValue (weightY config) (treasuryY config) (xToSwap + 1000) (poolFeeNum config) (treasuryFee config) (invariant config) + yToSwap <- calculateY xValue 1 (treasuryX config) yValue 4 (treasuryY config) (xToSwap + 1000) (poolFeeNum config) (treasuryFee config) let newPool = prevPool { value = value <> (assetClassValue (poolX config) (xToSwap)) <> (assetClassValue (poolY config) (negate yToSwap)) } - pure $ BalancePoolActionResult newPool [] [gX, gY] [tX, tY] [] + pure $ BalancePoolActionResult newPool [] in BalancePoolTestAction "Incorrect swap GT" testAction incorrectSwapPoolFinalXValue :: MonadGen m => BalancePoolTestAction m @@ -451,7 +469,7 @@ incorrectSwapPoolFinalXValue = xToSwap <- integral (Range.constant 1 ((xValue `div` 2) - 1)) incorrectXSwapValue <- integral (Range.constant 1 ((xValue `div` 2) - 1)) - (gX, tX, gY, tY, yToSwap, llist) <- calculateGandTSwap xValue (weightX config) (treasuryX config) yValue (weightY config) (treasuryY config) (xToSwap) (poolFeeNum config) (treasuryFee config) (invariant config) + yToSwap <- calculateY xValue 1 (treasuryX config) yValue 4 (treasuryY config) (xToSwap) (poolFeeNum config) (treasuryFee config) let tFee = treasuryFee config @@ -464,7 +482,7 @@ incorrectSwapPoolFinalXValue = { value = value <> (assetClassValue (poolX config) (incorrectXSwapValue)) <> (assetClassValue (poolY config) (negate yToSwap)) } - pure $ BalancePoolActionResult newPool [] [gX, gY] [tX, tY] [] + pure $ BalancePoolActionResult newPool [] in BalancePoolTestAction "Incorrect pool x final value" testAction incorrectSwapPoolFinalYValue :: MonadGen m => BalancePoolTestAction m @@ -480,7 +498,7 @@ incorrectSwapPoolFinalYValue = xToSwap <- integral (Range.constant 1 ((xValue `div` 2) - 1)) incorrectYFinalValue <- integral (Range.constant 1 (yValue - 1)) - (gX, tX, gY, tY, yToSwap, llist) <- calculateGandTSwap xValue (weightX config) (treasuryX config) yValue (weightY config) (treasuryY config) (xToSwap) (poolFeeNum config) (treasuryFee config) (invariant config) + yToSwap <- calculateY xValue 1 (treasuryX config) yValue 4 (treasuryY config) (xToSwap) (poolFeeNum config) (treasuryFee config) let -- going to withdraw all pool x and y value @@ -495,7 +513,7 @@ incorrectSwapPoolFinalYValue = { value = value <> (assetClassValue (poolX config) (xToSwap)) <> (assetClassValue (poolY config) (negate incorrectYFinalValue)) } - pure $ BalancePoolActionResult newPool [] [gX, gY] [tX, tY] [] + pure $ BalancePoolActionResult newPool [] in BalancePoolTestAction "Incorrect pool y final value" testAction incorrectSwapTrFeeValue :: MonadGen m => BalancePoolTestAction m @@ -510,7 +528,7 @@ incorrectSwapTrFeeValue = yValue = valueOf value yCS yTN xToSwap <- integral (Range.constant 1 ((xValue `div` 2) - 1)) - (gX, tX, gY, tY, yToSwap, llist) <- calculateGandTSwap xValue (weightX config) (treasuryX config) yValue (weightY config) (treasuryY config) (xToSwap) (poolFeeNum config) (treasuryFee config) (invariant config) + yToSwap <- calculateY xValue 1 (treasuryX config) yValue 4 (treasuryY config) (xToSwap) (poolFeeNum config) (treasuryFee config) let treasuryFee_ = treasuryFee config newPoolConfig = config @@ -521,7 +539,7 @@ incorrectSwapTrFeeValue = , value = value <> (assetClassValue (poolX config) (xToSwap)) <> (assetClassValue (poolY config) (negate yToSwap)) } - pure $ BalancePoolActionResult newPool [] [gX, gY] [tX, tY] [] + pure $ BalancePoolActionResult newPool [] in BalancePoolTestAction "Incorrect pool treasury X final value" testAction -- Swap cases end -- @@ -544,21 +562,16 @@ correctDeposit = lqIssued <- integral (Range.constant 1 ((lqValue `div` 2) - 1)) - (gX, tX, gY, tY, xToDeposit, yToDeposit, lqIssued, llist, newInvariant) <- calculateGandTDeposit xValue (weightX config) yValue (weightY config) (lqIssued) lqSupply (poolFeeNum config) (treasuryFee config) (invariant config) + (xToDeposit, yToDeposit, lqIssued, _) <- calculateGandTDeposit xValue (treasuryX config) 1 yValue (treasuryY config) 4 (lqIssued) lqSupply (poolFeeNum config) (treasuryFee config) let - -- going to withdraw all pool x and y value - newPoolConfig = config - { invariant = newInvariant - , invariantLength = Prelude.head llist - } - + newInvariant = getDecimalNum ((((BigDecimal (xValue + xToDeposit) 0)) ** (fromRational $ (fromIntegral 1))) * ((BigDecimal (yValue + yToDeposit) 0) ** (fromRational $ (fromIntegral 4)))) + newPool = prevPool - { config = newPoolConfig - , value = value <> (assetClassValue (poolX config) (xToDeposit)) <> (assetClassValue (poolY config) (yToDeposit)) <> (assetClassValue (poolLq config) (negate lqIssued)) + { value = value <> (assetClassValue (poolX config) (xToDeposit)) <> (assetClassValue (poolY config) (yToDeposit)) <> (assetClassValue (poolLq config) (negate lqIssued)) } - pure $ BalancePoolActionResult newPool [] [gX, gY] [tX, tY] llist + pure $ BalancePoolActionResult newPool [] in BalancePoolTestAction "Correct deposit all tokens" testAction incorrectDepositLqOut :: MonadGen m => BalancePoolTestAction m @@ -577,22 +590,14 @@ incorrectDepositLqOut = lqIssued <- integral (Range.constant 1 ((lqValue `div` 2) - 1)) - (gX, tX, gY, tY, xToDeposit, yToDeposit, lqIssued, llist, newInvariant) <- calculateGandTDeposit xValue (weightX config) yValue (weightY config) (lqIssued) lqSupply (poolFeeNum config) (treasuryFee config) (invariant config) + (xToDeposit, yToDeposit, lqIssued, _) <- calculateGandTDeposit xValue (treasuryX config) 1 yValue (treasuryY config) 4 (lqIssued) lqSupply (poolFeeNum config) (treasuryFee config) let - 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))) + { value = value <> (assetClassValue (poolX config) (xToDeposit)) <> (assetClassValue (poolY config) (yToDeposit)) <> (assetClassValue (poolLq config) (negate (lqIssued + 1000))) } - pure $ BalancePoolActionResult newPool [] [gX, gY] [tX, tY] llist + pure $ BalancePoolActionResult newPool [] in BalancePoolTestAction "Incorrect deposit all tokens. Incorrect lq out" testAction -- Deposit all cases end -- @@ -614,21 +619,14 @@ correctRedeem = lqIssued = 0x7fffffffffffffff - lqValue lqToRedeem <- integral (Range.constant 1 ((lqIssued `div` 2) - 1)) - (gX, tX, gY, tY, xToRedeem, yToRedeem, newInvariant, newInvariantLength) <- calculateGandTRedeem xValue (weightX config) yValue (weightY config) (lqToRedeem) lqIssued (poolFeeNum config) (treasuryFee config) (invariant config) + (xToRedeem, yToRedeem) <- calculateGandTRedeem xValue (treasuryX config) 1 yValue (treasuryY config) 4 (lqToRedeem) lqIssued (poolFeeNum config) (treasuryFee config) let - -- going to withdraw all pool x and y value - newPoolConfig = config - { invariant = newInvariant - , invariantLength = newInvariantLength - } - newPool = prevPool - { config = newPoolConfig - , value = value <> (assetClassValue (poolX config) (negate xToRedeem)) <> (assetClassValue (poolY config) (negate yToRedeem)) <> (assetClassValue (poolLq config) (lqToRedeem)) + { value = value <> (assetClassValue (poolX config) (negate xToRedeem)) <> (assetClassValue (poolY config) (negate yToRedeem)) <> (assetClassValue (poolLq config) (lqToRedeem)) } - pure $ BalancePoolActionResult newPool [] [gX, gY] [tX, tY] [] + pure $ BalancePoolActionResult newPool [] in BalancePoolTestAction "Correct redeem all tokens" testAction incorrectRedeemLQFinalValue :: MonadGen m => BalancePoolTestAction m @@ -647,22 +645,14 @@ incorrectRedeemLQFinalValue = 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) + (xToRedeem, yToRedeem) <- calculateGandTRedeem xValue (treasuryX config) 1 yValue (treasuryY config) 4 (lqToRedeem) lqIssued (poolFeeNum config) (treasuryFee config) let - 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)) + { value = value <> (assetClassValue (poolX config) (negate xToRedeem)) <> (assetClassValue (poolY config) (negate yToRedeem)) <> (assetClassValue (poolLq config) (lqToRedeem - 100)) } - pure $ BalancePoolActionResult newPool [] [gX, gY] [tX, tY] [] + pure $ BalancePoolActionResult newPool [] in BalancePoolTestAction "InCorrect redeem all tokens. Incorrect final lq value" testAction -- Redeem all cases end -- \ No newline at end of file diff --git a/plutarch-validators/test/Spec.hs b/plutarch-validators/test/Spec.hs index 9570d77..e699015 100644 --- a/plutarch-validators/test/Spec.hs +++ b/plutarch-validators/test/Spec.hs @@ -22,31 +22,41 @@ import Plutarch.Api.V2 import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LBS import Codec.Serialise (serialise, deserialise) +import Debug.Trace main :: IO () main = do - defaultMain tests + let + shortBSRedeem = validatorHash redeemBalanceValidator + shortBSDeposit = validatorHash depositBalanceValidator + traceM $ show shortBSRedeem + traceM $ show shortBSDeposit + -- BS.writeFile ("/home/bromel/projects/whalepools-core/plutarch-validators/redeem.uplc") shortBSRedeem + -- BS.writeFile ("/home/bromel/projects/whalepools-core/plutarch-validators/deposit.uplc") shortBSDeposit + pure () tests = testGroup "Contracts" - [ feeSwitch - , feeSwitchBFee - , balancePool - , checkPValueLength - , checkPool - , checkPoolRedeemer - , checkPoolBFee - , checkPoolBFeeRedeemer - , checkRedeem - , checkRedeemIdentity - , checkRedeemIsFair - , checkRedeemRedeemer - , checkDeposit - , checkDepositChange - , checkDepositRedeemer - , checkDepositIdentity - , checkDepositLq - , checkDepositTokenReward - , checkSwap - , checkSwapRedeemer - , checkSwapIdentity + [ + -- feeSwitch + -- , feeSwitchBFee + -- , + balancePool + -- , checkPValueLength + -- , checkPool + -- , checkPoolRedeemer + -- , checkPoolBFee + -- , checkPoolBFeeRedeemer + -- , checkRedeem + -- , checkRedeemIdentity + -- , checkRedeemIsFair + -- , checkRedeemRedeemer + -- , checkDeposit + -- , checkDepositChange + -- , checkDepositRedeemer + -- , checkDepositIdentity + -- , checkDepositLq + -- , checkDepositTokenReward + -- , checkSwap + -- , checkSwapRedeemer + -- , checkSwapIdentity ] \ No newline at end of file diff --git a/plutarch-validators/test/Tests/BalancePool.hs b/plutarch-validators/test/Tests/BalancePool.hs index 39672ff..3fcdd3f 100644 --- a/plutarch-validators/test/Tests/BalancePool.hs +++ b/plutarch-validators/test/Tests/BalancePool.hs @@ -25,6 +25,7 @@ import WhalePoolsDex.PMintingValidators import Test.Tasty import Test.Tasty.HUnit import Test.Tasty.Hedgehog as HH +import Hedgehog.Internal.Property import Gen.Models import Gen.DepositGen @@ -37,7 +38,7 @@ import Debug.Trace import Data.Text as T (pack, unpack, splitOn) balancePool = testGroup "BalancePool" - ((genTests `map` [swapTests, depositAllTests, redeemAllTests])) + ((genTests `map` [swapTests])) validPoolHash :: Property validPoolHash = withTests 1 $ property $ do @@ -66,10 +67,11 @@ swapTests = BalancePoolTestGroup , contractAction = Pool.Swap , validAction = correctSwap , invalidActions = - [ incorrectSwapGT - , incorrectSwapPoolFinalXValue - , incorrectSwapPoolFinalYValue - , incorrectSwapTrFeeValue + [ + -- incorrectSwapGT + -- , incorrectSwapPoolFinalXValue + -- , incorrectSwapPoolFinalYValue + -- , incorrectSwapTrFeeValue ] } @@ -96,7 +98,7 @@ cutFloatD toCut maxInt = let in read $ T.unpack . Prelude.head $ splitted actionWithValidSignersQty :: Int -> (BalancePool -> Gen BalancePoolActionResult) -> Pool.BalancePoolAction -> TestResult -> Property -actionWithValidSignersQty sigsQty poolUpdater action testResultShouldBe = withShrinks 1 $ withTests 10 $ property $ do +actionWithValidSignersQty sigsQty poolUpdater action testResultShouldBe = withShrinks 1 $ withTests 1 $ property $ do let threshold = 2 @@ -110,7 +112,7 @@ actionWithValidSignersQty sigsQty poolUpdater action testResultShouldBe = withSh datum = toData $ (config prevPool) let context = toData $ mkContext txInInfo purpose - redeemer = toData $ Pool.BalancePoolRedeemer action 0 (g updateResult) (t updateResult) (lList updateResult) + redeemer = toData $ Pool.BalancePoolRedeemer action 0 correctResult = case testResultShouldBe of