Commit
This commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.
split some code to avoid schizofrenia
- Loading branch information
Showing
5 changed files
with
115 additions
and
60 deletions.
There are no files selected for viewing
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -0,0 +1,53 @@ | ||
| {-# LANGUAGE DataKinds #-} | ||
| {-# LANGUAGE DeriveAnyClass #-} | ||
| {-# LANGUAGE DeriveGeneric #-} | ||
| {-# LANGUAGE DerivingStrategies #-} | ||
| {-# LANGUAGE FlexibleContexts #-} | ||
| {-# LANGUAGE GeneralizedNewtypeDeriving #-} | ||
| {-# LANGUAGE MultiParamTypeClasses #-} | ||
| {-# LANGUAGE NoImplicitPrelude #-} | ||
| {-# LANGUAGE OverloadedStrings #-} | ||
| {-# LANGUAGE RecordWildCards #-} | ||
| {-# LANGUAGE TemplateHaskell #-} | ||
| {-# LANGUAGE TypeFamilies #-} | ||
| {-# LANGUAGE TypeOperators #-} | ||
| {-# options_ghc -Wno-redundant-constraints #-} | ||
| {-# options_ghc -fno-strictness #-} | ||
| {-# options_ghc -fno-specialise #-} | ||
|
|
||
| {-# LANGUAGE ScopedTypeVariables #-} | ||
| {-# LANGUAGE StandaloneDeriving #-} | ||
| module Plutus.Contracts.Data | ||
| where | ||
|
|
||
| import Ledger | ||
| import Ledger.Value (AssetClass (..), assetClass, assetClassValue, assetClassValueOf) | ||
| import Playground.Contract (FromJSON, Generic, ToJSON, ToSchema) | ||
| import qualified PlutusTx | ||
| import PlutusTx.Prelude hiding (Semigroup (..), unless) | ||
| import qualified Prelude as Haskell | ||
| import Text.Printf (PrintfArg) | ||
|
|
||
| -- uniswapTokenName and poolStateTokenName share the same minting policy | ||
| -- | A handy alias to put things in the language of "Coins" instead of | ||
| -- "AssetClass". | ||
| type Coin = AssetClass | ||
|
|
||
| -- Note: An orphan instance here because of the alias above. | ||
| deriving anyclass instance ToSchema AssetClass | ||
|
|
||
| -- 2 token liquidity Pool | ||
| -- Order does not matter A/B == B/A pool | ||
| data LiquidityPool = LiquidityPool | ||
| { lpCoinA :: Coin | ||
| , lpCoinB :: Coin | ||
| } | ||
| deriving (Show, Generic, ToJSON, FromJSON, ToSchema) | ||
|
|
||
| PlutusTx.unstableMakeIsData ''LiquidityPool | ||
| PlutusTx.makeLift ''LiquidityPool | ||
|
|
||
| instance Eq LiquidityPool where | ||
| {-# INLINABLE (==) #-} | ||
| x == y = (lpCoinA x == lpCoinA y && lpCoinB x == lpCoinB y) || | ||
| (lpCoinA x == lpCoinB y && lpCoinB x == lpCoinA y) |
53 changes: 53 additions & 0 deletions
53
AltLabs/dex-token-swap/src/Plutus/Contracts/LiquidityPool.hs
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -0,0 +1,53 @@ | ||
| {-# LANGUAGE NoImplicitPrelude #-} | ||
| {-# LANGUAGE OverloadedStrings #-} | ||
| {-# LANGUAGE RecordWildCards #-} | ||
|
|
||
| module Plutus.Contracts.LiquidityPool | ||
| ( calculateAdditionalLiquidity | ||
| , calculateInitialLiquidity | ||
| , calculateRemoval | ||
| -- , checkSwap | ||
| -- , lpTicker | ||
| , LiquidityPool | ||
| ) where | ||
|
|
||
| import Ledger.Value (TokenName (..), unAssetClass, unCurrencySymbol) | ||
| import Plutus.Contracts.Data | ||
| import PlutusTx.Prelude | ||
| import PlutusTx.Sqrt | ||
|
|
||
|
|
||
| {-# INLINABLE calculateInitialLiquidity #-} | ||
| calculateInitialLiquidity :: Integer -> Integer -> Integer | ||
| calculateInitialLiquidity outA outB = case isqrt (outA * outB) of | ||
| Exact l | ||
| | l > 0 -> l | ||
| Irrational l | ||
| | l > 0 -> l + 1 | ||
| _ -> traceError "insufficient liquidity" | ||
|
|
||
| -- helper for if you have an existing Pool, and someone adds liquidity to it | ||
| -- eg. A (n) tokens, B (n) tokens | ||
| -- someone adds (n) A or B, computes how many | ||
| -- liquidity tokens the person should receive | ||
| {-# INLINABLE calculateAdditionalLiquidity #-} | ||
| calculateAdditionalLiquidity :: Integer -> Integer -> Integer -> Integer -> Integer -> Integer | ||
| calculateAdditionalLiquidity oldA oldB liquidity delA delB = | ||
| case rsqrt ((liquidity * liquidity * newProd) % oldProd) of | ||
| Imaginary -> traceError "insufficient liquidity" | ||
| Exact x -> x - liquidity | ||
| Irrational x -> x - liquidity | ||
| where | ||
| oldProd, newProd :: Integer | ||
| oldProd = oldA * oldB | ||
| newProd = (oldA + delA) * (oldB + delB) | ||
|
|
||
| -- same as above just opposite | ||
| {-# INLINABLE calculateRemoval #-} | ||
| calculateRemoval :: Integer -> Integer -> Integer -> Integer -> (Integer, Integer) | ||
| calculateRemoval inA inB liquidity diff = (f inA, f inB) | ||
| where | ||
| f :: Integer -> Integer | ||
| f x = x - divide (x * diff) liquidity | ||
|
|
||
|
|
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters