{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards   #-}
{-# OPTIONS_GHC -g -fplugin-opt PlutusTx.Plugin:coverage-all #-}

module Plutus.Contracts.Uniswap.Pool
  ( calculateAdditionalLiquidity
  , calculateInitialLiquidity
  , calculateRemoval
  , checkSwap
  , lpTicker
  ) where

import Plutus.Contracts.Uniswap.Types
import Plutus.Script.Utils.Value (TokenName (..), unAssetClass, unCurrencySymbol)
import PlutusTx.Prelude hiding (ratio)
import PlutusTx.Sqrt

{-# INLINABLE calculateInitialLiquidity #-}
-- | The initial liquidity is 'ceil( sqrt(x*y) )' where 'x' is the amount of
-- 'Coin A' and y the amount of 'Coin B'.  See Eq. 13 of the Uniswap v2 paper.
calculateInitialLiquidity :: Amount A -> Amount B -> Amount Liquidity
calculateInitialLiquidity :: Amount A -> Amount B -> Amount Liquidity
calculateInitialLiquidity Amount A
outA Amount B
outB = Integer -> Amount Liquidity
forall a. Integer -> Amount a
Amount (Integer -> Amount Liquidity) -> Integer -> Amount Liquidity
forall a b. (a -> b) -> a -> b
$ case Integer -> Sqrt
isqrt (Amount A -> Integer
forall a. Amount a -> Integer
unAmount Amount A
outA Integer -> Integer -> Integer
forall a. MultiplicativeSemigroup a => a -> a -> a
* Amount B -> Integer
forall a. Amount a -> Integer
unAmount Amount B
outB) of
    Exactly Integer
l
        | Integer
l Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
0 -> Integer
l
    Approximately Integer
l
        | Integer
l Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
0 -> Integer
l Integer -> Integer -> Integer
forall a. AdditiveSemigroup a => a -> a -> a
+ Integer
1
    Sqrt
_           -> BuiltinString -> Integer
forall a. BuiltinString -> a
traceError BuiltinString
"insufficient liquidity"

{-# INLINABLE calculateAdditionalLiquidity #-}
calculateAdditionalLiquidity :: Amount A -> Amount B -> Amount Liquidity -> Amount A -> Amount B -> Amount Liquidity
calculateAdditionalLiquidity :: Amount A
-> Amount B
-> Amount Liquidity
-> Amount A
-> Amount B
-> Amount Liquidity
calculateAdditionalLiquidity Amount A
oldA' Amount B
oldB' Amount Liquidity
liquidity Amount A
delA' Amount B
delB' =
  case Rational -> Sqrt
rsqrt Rational
ratio of
    Sqrt
Imaginary       -> BuiltinString -> Amount Liquidity
forall a. BuiltinString -> a
traceError BuiltinString
"insufficient liquidity"
    Exactly Integer
x       -> Integer -> Amount Liquidity
forall a. Integer -> Amount a
Amount Integer
x Amount Liquidity -> Amount Liquidity -> Amount Liquidity
forall a. AdditiveGroup a => a -> a -> a
- Amount Liquidity
liquidity
    Approximately Integer
x -> Integer -> Amount Liquidity
forall a. Integer -> Amount a
Amount Integer
x Amount Liquidity -> Amount Liquidity -> Amount Liquidity
forall a. AdditiveGroup a => a -> a -> a
- Amount Liquidity
liquidity
  where
    ratio :: Rational
ratio = Integer -> Integer -> Rational
unsafeRatio (Amount Liquidity -> Integer
forall a. Amount a -> Integer
unAmount (Amount Liquidity
liquidity Amount Liquidity -> Amount Liquidity -> Amount Liquidity
forall a. MultiplicativeSemigroup a => a -> a -> a
* Amount Liquidity
liquidity Amount Liquidity -> Amount Liquidity -> Amount Liquidity
forall a. MultiplicativeSemigroup a => a -> a -> a
* Amount Liquidity
newProd)) (Amount Liquidity -> Integer
forall a. Amount a -> Integer
unAmount Amount Liquidity
oldProd)

    -- Unwrap, as we're combining terms
    oldA :: Integer
oldA = Amount A -> Integer
forall a. Amount a -> Integer
unAmount Amount A
oldA'
    oldB :: Integer
oldB = Amount B -> Integer
forall a. Amount a -> Integer
unAmount Amount B
oldB'
    delA :: Integer
delA = Amount A -> Integer
forall a. Amount a -> Integer
unAmount Amount A
delA'
    delB :: Integer
delB = Amount B -> Integer
forall a. Amount a -> Integer
unAmount Amount B
delB'

    oldProd, newProd :: Amount Liquidity
    oldProd :: Amount Liquidity
oldProd = Integer -> Amount Liquidity
forall a. Integer -> Amount a
Amount (Integer -> Amount Liquidity) -> Integer -> Amount Liquidity
forall a b. (a -> b) -> a -> b
$ Integer
oldA Integer -> Integer -> Integer
forall a. MultiplicativeSemigroup a => a -> a -> a
* Integer
oldB
    newProd :: Amount Liquidity
newProd = Integer -> Amount Liquidity
forall a. Integer -> Amount a
Amount (Integer -> Amount Liquidity) -> Integer -> Amount Liquidity
forall a b. (a -> b) -> a -> b
$ (Integer
oldA Integer -> Integer -> Integer
forall a. AdditiveSemigroup a => a -> a -> a
+ Integer
delA) Integer -> Integer -> Integer
forall a. MultiplicativeSemigroup a => a -> a -> a
* (Integer
oldB Integer -> Integer -> Integer
forall a. AdditiveSemigroup a => a -> a -> a
+ Integer
delB)

{-# INLINABLE calculateRemoval #-}
-- | See Definition 3 of <https://github.com/runtimeverification/verified-smart-contracts/blob/c40c98d6ae35148b76742aaaa29e6eaa405b2f93/uniswap/x-y-k.pdf>.
calculateRemoval :: Amount A -> Amount B -> Amount Liquidity -> Amount Liquidity -> (Amount A, Amount B)
calculateRemoval :: Amount A
-> Amount B
-> Amount Liquidity
-> Amount Liquidity
-> (Amount A, Amount B)
calculateRemoval Amount A
inA Amount B
inB Amount Liquidity
liquidity' Amount Liquidity
diff' = (Amount A -> Amount A
forall a. Amount a -> Amount a
f Amount A
inA, Amount B -> Amount B
forall a. Amount a -> Amount a
f Amount B
inB)
  where
    f :: Amount a -> Amount a
    f :: Amount a -> Amount a
f = Integer -> Amount a
forall a. Integer -> Amount a
Amount (Integer -> Amount a)
-> (Amount a -> Integer) -> Amount a -> Amount a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Integer
g (Integer -> Integer)
-> (Amount a -> Integer) -> Amount a -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Amount a -> Integer
forall a. Amount a -> Integer
unAmount

    diff :: Integer
diff      = Amount Liquidity -> Integer
forall a. Amount a -> Integer
unAmount Amount Liquidity
diff'
    liquidity :: Integer
liquidity = Amount Liquidity -> Integer
forall a. Amount a -> Integer
unAmount Amount Liquidity
liquidity'

    g :: Integer -> Integer
    g :: Integer -> Integer
g Integer
x = Integer
x Integer -> Integer -> Integer
forall a. AdditiveGroup a => a -> a -> a
- Integer -> Integer -> Integer
divide (Integer
x Integer -> Integer -> Integer
forall a. MultiplicativeSemigroup a => a -> a -> a
* Integer
diff) Integer
liquidity

{-# INLINABLE checkSwap #-}
-- | A swap is valid if the fee is computed correctly, and we're swapping some
-- positive amount of A for B.  See: <https://uniswap.org/whitepaper.pdf> Eq (11) (Page 7.)
checkSwap :: Amount A -> Amount B -> Amount A -> Amount B -> Bool
checkSwap :: Amount A -> Amount B -> Amount A -> Amount B -> Bool
checkSwap Amount A
oldA' Amount B
oldB' Amount A
newA' Amount B
newB' =
    BuiltinString -> Bool -> Bool
traceIfFalse BuiltinString
"expected positive oldA" (Integer
oldA Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
0) Bool -> Bool -> Bool
&&
    BuiltinString -> Bool -> Bool
traceIfFalse BuiltinString
"expected positive oldB" (Integer
oldB Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
0) Bool -> Bool -> Bool
&&
    BuiltinString -> Bool -> Bool
traceIfFalse BuiltinString
"expected positive-newA" (Integer
newA Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
0) Bool -> Bool -> Bool
&&
    BuiltinString -> Bool -> Bool
traceIfFalse BuiltinString
"expected positive-newB" (Integer
newB Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
0) Bool -> Bool -> Bool
&&
    BuiltinString -> Bool -> Bool
traceIfFalse BuiltinString
"expected product to increase"
        ((((Integer
newA Integer -> Integer -> Integer
forall a. MultiplicativeSemigroup a => a -> a -> a
* Integer
feeDen) Integer -> Integer -> Integer
forall a. AdditiveGroup a => a -> a -> a
- (Integer
inA Integer -> Integer -> Integer
forall a. MultiplicativeSemigroup a => a -> a -> a
* Integer
feeNum)) Integer -> Integer -> Integer
forall a. MultiplicativeSemigroup a => a -> a -> a
* ((Integer
newB Integer -> Integer -> Integer
forall a. MultiplicativeSemigroup a => a -> a -> a
* Integer
feeDen) Integer -> Integer -> Integer
forall a. AdditiveGroup a => a -> a -> a
- (Integer
inB Integer -> Integer -> Integer
forall a. MultiplicativeSemigroup a => a -> a -> a
* Integer
feeNum)))
         Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= (Integer
feeDen Integer -> Integer -> Integer
forall a. MultiplicativeSemigroup a => a -> a -> a
* Integer
feeDen Integer -> Integer -> Integer
forall a. MultiplicativeSemigroup a => a -> a -> a
* Integer
oldA Integer -> Integer -> Integer
forall a. MultiplicativeSemigroup a => a -> a -> a
* Integer
oldB))
  where
    -- Unwrap; because we are mixing terms.
    oldA :: Integer
oldA = Amount A -> Integer
forall a. Amount a -> Integer
unAmount Amount A
oldA'
    oldB :: Integer
oldB = Amount B -> Integer
forall a. Amount a -> Integer
unAmount Amount B
oldB'
    newA :: Integer
newA = Amount A -> Integer
forall a. Amount a -> Integer
unAmount Amount A
newA'
    newB :: Integer
newB = Amount B -> Integer
forall a. Amount a -> Integer
unAmount Amount B
newB'

    inA :: Integer
inA = Integer -> Integer -> Integer
forall a. Ord a => a -> a -> a
max Integer
0 (Integer -> Integer) -> Integer -> Integer
forall a b. (a -> b) -> a -> b
$ Integer
newA Integer -> Integer -> Integer
forall a. AdditiveGroup a => a -> a -> a
- Integer
oldA
    inB :: Integer
inB = Integer -> Integer -> Integer
forall a. Ord a => a -> a -> a
max Integer
0 (Integer -> Integer) -> Integer -> Integer
forall a b. (a -> b) -> a -> b
$ Integer
newB Integer -> Integer -> Integer
forall a. AdditiveGroup a => a -> a -> a
- Integer
oldB
    -- The uniswap fee is 0.3%; here it is multiplied by 1000, so that the
    -- on-chain code deals only in integers.
    -- See: <https://uniswap.org/whitepaper.pdf> Eq (11) (Page 7.)
    feeNum, feeDen :: Integer
    feeNum :: Integer
feeNum = Integer
3
    feeDen :: Integer
feeDen = Integer
1000

{-# INLINABLE lpTicker #-}
-- | Generate a unique token name for this particular pool; based on the
-- tokens it exchanges. This should be such that looking for a pool exchanging
-- any two tokens always yields a unique name.
lpTicker :: LiquidityPool -> TokenName
lpTicker :: LiquidityPool -> TokenName
lpTicker LiquidityPool{Coin A
Coin B
lpCoinB :: LiquidityPool -> Coin B
lpCoinA :: LiquidityPool -> Coin A
lpCoinB :: Coin B
lpCoinA :: Coin A
..}  = BuiltinByteString -> TokenName
TokenName BuiltinByteString
hash
    where
      cA :: (CurrencySymbol, TokenName)
cA@(CurrencySymbol
csA, TokenName
tokA) = AssetClass -> (CurrencySymbol, TokenName)
unAssetClass (Coin A -> AssetClass
forall a. Coin a -> AssetClass
unCoin Coin A
lpCoinA)
      cB :: (CurrencySymbol, TokenName)
cB@(CurrencySymbol
csB, TokenName
tokB) = AssetClass -> (CurrencySymbol, TokenName)
unAssetClass (Coin B -> AssetClass
forall a. Coin a -> AssetClass
unCoin Coin B
lpCoinB)
      ((CurrencySymbol
x1, TokenName
y1), (CurrencySymbol
x2, TokenName
y2))
        | (CurrencySymbol, TokenName)
cA (CurrencySymbol, TokenName) -> (CurrencySymbol, TokenName) -> Bool
forall a. Ord a => a -> a -> Bool
< (CurrencySymbol, TokenName)
cB   = ((CurrencySymbol
csA, TokenName
tokA), (CurrencySymbol
csB, TokenName
tokB))
        | Bool
otherwise = ((CurrencySymbol
csB, TokenName
tokB), (CurrencySymbol
csA, TokenName
tokA))
      h1 :: BuiltinByteString
h1   = BuiltinByteString -> BuiltinByteString
sha2_256 (BuiltinByteString -> BuiltinByteString)
-> BuiltinByteString -> BuiltinByteString
forall a b. (a -> b) -> a -> b
$ TokenName -> BuiltinByteString
unTokenName TokenName
y1
      h2 :: BuiltinByteString
h2   = BuiltinByteString -> BuiltinByteString
sha2_256 (BuiltinByteString -> BuiltinByteString)
-> BuiltinByteString -> BuiltinByteString
forall a b. (a -> b) -> a -> b
$ TokenName -> BuiltinByteString
unTokenName TokenName
y2
      h3 :: BuiltinByteString
h3   = BuiltinByteString -> BuiltinByteString
sha2_256 (BuiltinByteString -> BuiltinByteString)
-> BuiltinByteString -> BuiltinByteString
forall a b. (a -> b) -> a -> b
$ CurrencySymbol -> BuiltinByteString
unCurrencySymbol CurrencySymbol
x1
      h4 :: BuiltinByteString
h4   = BuiltinByteString -> BuiltinByteString
sha2_256 (BuiltinByteString -> BuiltinByteString)
-> BuiltinByteString -> BuiltinByteString
forall a b. (a -> b) -> a -> b
$ CurrencySymbol -> BuiltinByteString
unCurrencySymbol CurrencySymbol
x2
      hash :: BuiltinByteString
hash = BuiltinByteString -> BuiltinByteString
sha2_256 (BuiltinByteString -> BuiltinByteString)
-> BuiltinByteString -> BuiltinByteString
forall a b. (a -> b) -> a -> b
$ BuiltinByteString
h1 BuiltinByteString -> BuiltinByteString -> BuiltinByteString
forall a. Semigroup a => a -> a -> a
<> BuiltinByteString
h2 BuiltinByteString -> BuiltinByteString -> BuiltinByteString
forall a. Semigroup a => a -> a -> a
<> BuiltinByteString
h3 BuiltinByteString -> BuiltinByteString -> BuiltinByteString
forall a. Semigroup a => a -> a -> a
<> BuiltinByteString
h4