diff --git a/use-case-2/common/src/Common/Plutus/Contracts/Uniswap/Estimates.hs b/use-case-2/common/src/Common/Plutus/Contracts/Uniswap/Estimates.hs index 9bf92a0a3..2ae315e19 100644 --- a/use-case-2/common/src/Common/Plutus/Contracts/Uniswap/Estimates.hs +++ b/use-case-2/common/src/Common/Plutus/Contracts/Uniswap/Estimates.hs @@ -6,16 +6,20 @@ - This modules is full of functions used to provide estimates for swaps, liquidity redemption, etc. -} +{-# LANGUAGE DerivingStrategies #-} + module Common.Plutus.Contracts.Uniswap.Estimates where +import Data.Ratio + traceIfFalse :: String -> Bool -> Bool traceIfFalse _ a = if a then True else False -checkSwap - :: Integer -- Amount A - -> Integer -- Amount B - -> Integer -- Amount A - -> Integer -- Amount B +checkSwap + :: Integer -- Amount A + -> Integer -- Amount B + -> Integer -- Amount A + -> Integer -- Amount B -> Bool checkSwap oldA oldB newA newB = traceIfFalse "expected positive oldA" (oldA > 0) && @@ -74,3 +78,59 @@ calculateRemoval inA inB liquidity diff = (g inA, g inB) g :: Integer -> Integer g x = x - div (x * diff) liquidity +-- | Integer square-root representation, discarding imaginary integers. +data Sqrt + -- | The number was negative, so we don't even attempt to compute it; + -- just note that the result would be imaginary. + = Imaginary + -- | An exact integer result. The 'rsqrt' of 4 is 'Exactly 2'. + | Exactly Integer + -- | The Integer component (i.e. the floor) of a non-integral result. The + -- 'rsqrt 2' is 'Approximately 1'. + | Approximately Integer + deriving stock (Show, Eq) + +{-# INLINABLE rsqrt #-} +-- | Calculates the sqrt of a ratio of integers. As x / 0 is undefined, +-- calling this function with `d=0` results in an error. +rsqrt :: Rational -> Sqrt +rsqrt r + | n * d < 0 = Imaginary + | n == 0 = Exactly 0 + | n == d = Exactly 1 + | n < d = Approximately 0 + | n < 0 = rsqrt $ negate n % negate d + | otherwise = go 1 $ 1 + div n d + where + n = numerator r + d = denominator r + go :: Integer -> Integer -> Sqrt + go l u + | l * l * d == n = Exactly l + | u == (l + 1) = Approximately l + | otherwise = + let + m = div (l + u) 2 + in + if m * m * d <= n then go m u + else go l m + +calculateAdditionalLiquidity + :: Integer -- Liquidity Pool Balance for first coin of token pool + -> Integer -- Liquidity Pool Balance for second coin of token pool + -> Integer -- Liquidity Pool Balance + -> Integer -- Amount of first coin being added to token pool + -> Integer -- Amount of second coin being added to token pool + -> Integer -- Amount of Liquidity to be recieved +calculateAdditionalLiquidity oldA oldB liquidity delA delB = + case rsqrt ratio of + Imaginary -> (-1) -- TODO: Throw error here + Exactly x -> x - liquidity + Approximately x -> x - liquidity + where + ratio = (liquidity * liquidity * newProd) % oldProd + + oldProd, newProd :: Integer + oldProd = oldA * oldB + newProd = (oldA + delA) * (oldB + delB) + diff --git a/use-case-2/frontend/src/Frontend.hs b/use-case-2/frontend/src/Frontend.hs index d12ebf094..0bfb5a31e 100644 --- a/use-case-2/frontend/src/Frontend.hs +++ b/use-case-2/frontend/src/Frontend.hs @@ -605,6 +605,35 @@ poolDashboard wid = Workflow $ do let newObservableStateTag = incomingWebSocketData ^.. key "tag" . _String failureMessageTag = incomingWebSocketData ^.. key "contents" . key "Left" . _String newObservableStateTag == ["NewObservableState"] && failureMessageTag /= [""] + poolsEvent = flip ffilter (_webSocket_recv ws) $ \(mIncomingWebSocketData :: Maybe Aeson.Value) -> case mIncomingWebSocketData of + Nothing -> False + Just incomingWebSocketData -> do + let observableStateTag = incomingWebSocketData ^.. key "tag" . _String + poolsTag = incomingWebSocketData ^.. key "contents" . key "Right" . key "tag" . _String + observableStateTag == ["NewObservableState"] && poolsTag == ["Pools"] + -- use pool map to calculate and display tokens to be redeemed when removing liquidity + dynPoolMap <- holdDyn Map.empty $ ffor poolsEvent $ \mIncomingPoolsWebSocketData -> do + let poolDetails = case mIncomingPoolsWebSocketData of + Nothing -> V.empty + Just poolsWebSocketData -> poolsWebSocketData ^. key "contents" . key "Right" . key "contents" . _Array + parseLiquidityTokensToMap poolDetails + let ffor4 a b c d f = liftA3 f a b c <*> d + poolSelectionAmounts = ffor4 selectionA amountA selectionB amountB $ \a b c d -> ((a,b),(c,d)) + liquidityEstimate = ffor2 dynPoolMap poolSelectionAmounts $ \poolMap ((selA,amtA) ,(selB, amtB)) -> do + let (liquidityPoolAmount, ((_, coinAPoolAmount), (_, coinBPoolAmount))) = fromMaybe (1,(("",1),("",1))) + $ headMay + $ Map.elems + $ flip Map.filter poolMap + $ \(_, ((nameA,_),(nameB,_))) -> nameA == (_pooledToken_name selA) && nameB == (_pooledToken_name selB) + stakeAmountA :: Integer = fromMaybe 0 $ readMay $ T.unpack amtA + stakeAmountB :: Integer = fromMaybe 0 $ readMay $ T.unpack amtB + calculateAdditionalLiquidity coinAPoolAmount coinBPoolAmount liquidityPoolAmount stakeAmountA stakeAmountB + display liquidityEstimate + divClass "p-3 mt-2" $ widgetHold_ blank $ ffor (updated liquidityEstimate) $ \liqEst -> + elClass "p" "text-info" $ text + $ "Staking this amount to the pool will yield " + <> (T.pack $ show liqEst) + <> " Liquidity Tokens" -- this event will cause the success message to disappear when it occurs vanishEvent <- delay 7 observableStateSuccessEvent -- show success message based on new observable state