draft

cardano-dex-contracts-onchain/ErgoDex/Contracts/Proxy/LqMining/Simple/Deposit.hs

@@ -0,0 +1,27 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module ErgoDex.Contracts.Proxy.LqMining.Simple.Deposit where
+
+import qualified PlutusTx
+import PlutusLedgerApi.V1.Crypto (PubKeyHash)
+import PlutusLedgerApi.V1.Value
+
+data DepositConfig = DepositConfig
+    { expectedNumEpochs  :: Integer
+    , bundleKeyCS        :: CurrencySymbol
+    , redeemerPkh        :: PubKeyHash
+    , vlqAC              :: AssetClass
+    , tmpAC              :: AssetClass
+    } deriving stock (Show)
+
+PlutusTx.makeIsDataIndexed ''DepositConfig [('DepositConfig, 0)]
+
+data DepositRedeemer = DepositRedeemer
+    { poolInIdx      :: Integer
+    , depositInIdx   :: Integer
+    , redeemerOutIdx :: Integer
+    , bundleOutIdx   :: Integer
+    } deriving stock (Show)
+
+PlutusTx.makeIsDataIndexed ''DepositRedeemer [('DepositRedeemer, 0)]

cardano-dex-contracts-onchain/ErgoDex/Contracts/Proxy/LqMining/Simple/LMPool.hs

@@ -0,0 +1,30 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module ErgoDex.Contracts.Proxy.LqMining.Simple.LMPool where
+
+import qualified PlutusTx
+import PlutusLedgerApi.V1.Value
+
+data LMPoolConfig = LMPoolConfig
+    { epochLen      :: Integer
+    , epochNum      :: Integer
+    , programStart  :: Integer
+    , programBudget :: Integer
+    , execBudget    :: Integer
+    , epoch         :: Integer
+    , poolNft       :: AssetClass
+    , poolX         :: AssetClass
+    , poolLQ        :: AssetClass
+    , poolVLQ       :: AssetClass
+    , poolTMP       :: AssetClass
+    } deriving stock (Show)
+
+PlutusTx.makeIsDataIndexed ''LMPoolConfig [('LMPoolConfig, 0)]
+
+data LMPoolRedeemer = LMPoolRedeemer
+    { poolInIdx   :: Integer
+    , poolOutIdx  :: Integer
+    } deriving stock (Show)
+
+PlutusTx.makeIsDataIndexed ''LMPoolRedeemer [('LMPoolRedeemer, 0)]

cardano-dex-contracts-onchain/ErgoDex/Contracts/Proxy/LqMining/Simple/Redeem.hs

@@ -0,0 +1,23 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module ErgoDex.Contracts.Proxy.LqMining.Simple.Redeem where
+
+import PlutusLedgerApi.V1.Value
+import PlutusLedgerApi.V1.Crypto (PubKeyHash)
+
+import qualified PlutusTx
+
+data RedeemConfig = RedeemConfig
+    { expectedLQAC     :: AssetClass
+    , expectedLQAmount :: Integer
+    , rewardPkh        :: PubKeyHash
+    } deriving stock (Show)
+
+PlutusTx.makeIsDataIndexed ''RedeemConfig [('RedeemConfig, 0)]
+
+data RedeemRedeemerConfig = RedeemRedeemerConfig
+    { rewardOutIdx :: Integer 
+    } deriving stock (Show)
+
+PlutusTx.makeIsDataIndexed ''RedeemRedeemerConfig [('RedeemRedeemerConfig, 0)]

cardano-dex-contracts-onchain/ErgoDex/Contracts/Proxy/LqMining/Simple/StakingBundle.hs

@@ -0,0 +1,30 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module ErgoDex.Contracts.Proxy.LqMining.Simple.StakingBundle where
+
+import PlutusLedgerApi.V1.Value
+import PlutusLedgerApi.V1.Crypto (PubKeyHash)
+
+import qualified PlutusTx
+
+data StakingBundleConfig = StakingBundleConfig
+    { bundleAC    :: AssetClass
+    , poolAC      :: AssetClass
+    , bundleLQAC  :: AssetClass
+    , bundleVLQAC :: AssetClass
+    , bundleTMPAC :: AssetClass
+    , redeemerPkh :: PubKeyHash
+    } deriving stock (Show)
+
+PlutusTx.makeIsDataIndexed ''StakingBundleConfig [('StakingBundleConfig, 0)]
+
+data StakingBundleRedeemer = StakingBundleRedeemer
+    { poolInIdx    :: Integer
+    , permitIdx    :: Integer
+    , selfInIdx    :: Integer
+    , redeemerOutIx :: Integer
+    , successorOutIndex :: Integer
+    } deriving stock (Show)
+
+PlutusTx.makeIsDataIndexed ''StakingBundleRedeemer [('StakingBundleRedeemer, 0)]

cardano-dex-contracts-onchain/ErgoDex/PContracts/LqMining/Simple/PDeposit.hs

@@ -0,0 +1,152 @@
+{-# LANGUAGE UndecidableInstances #-}
+
+module ErgoDex.PContracts.LqMining.Simple.PDeposit where
+
+import qualified GHC.Generics  as GHC
+
+import Plutarch
+import Plutarch.Api.V2              (POutputDatum(POutputDatum), PPubKeyHash, PDatum(PDatum), PTokenName(..), PCurrencySymbol(..))
+import Plutarch.Api.V2.Contexts     (PScriptContext, PScriptPurpose (PSpending))
+import Plutarch.DataRepr
+import Plutarch.Lift
+import Plutarch.Prelude
+import Plutarch.Extra.TermCont
+
+import PExtra.API                   (PAssetClass, assetClassValueOf, ptryFromData, assetClass, tletUnwrap)
+import PExtra.Monadic               (tlet, tletField, tmatch)
+
+import ErgoDex.PContracts.PApi      (containsSignature, getRewardValueByPkh', maxLqCap)
+
+import qualified ErgoDex.Contracts.Proxy.LqMining.Simple.Deposit   as D
+import qualified ErgoDex.PContracts.LqMining.Simple.PStakingBundle as SB
+import qualified ErgoDex.PContracts.LqMining.Simple.PLMPool        as LMPool
+
+newtype DepositConfig (s :: S)
+    = DepositConfig
+        ( Term
+            s
+            ( PDataRecord
+                '[ "expectedNumEpochs" ':= PInteger
+                 , "bundleKeyCS" ':= PCurrencySymbol
+                 , "redeemerPkh" ':= PPubKeyHash
+                 , "vlqAC" ':= PAssetClass
+                 , "tmpAC" ':= PAssetClass
+                 ]
+            )
+        )
+    deriving stock (GHC.Generic)
+    deriving
+        (PIsData, PDataFields, PlutusType)
+
+instance DerivePlutusType DepositConfig where type DPTStrat _ = PlutusTypeData
+
+instance PUnsafeLiftDecl DepositConfig where type PLifted DepositConfig = D.DepositConfig
+deriving via (DerivePConstantViaData D.DepositConfig DepositConfig) instance (PConstantDecl D.DepositConfig)
+
+newtype DepositRedeemer (s :: S)
+    = DepositRedeemer
+        ( Term
+            s
+            ( PDataRecord
+                '[ "poolInIdx"      ':= PInteger
+                 , "depositInIdx"   ':= PInteger
+                 , "redeemerOutIdx" ':= PInteger
+                 , "bundleOutIdx"   ':= PInteger
+                 ]
+            )
+        )
+    deriving stock (GHC.Generic)
+    deriving
+        (PIsData, PDataFields, PlutusType)
+
+instance DerivePlutusType DepositRedeemer where type DPTStrat _ = PlutusTypeData
+
+instance PUnsafeLiftDecl DepositRedeemer where type PLifted DepositRedeemer = D.DepositRedeemer
+deriving via (DerivePConstantViaData D.DepositRedeemer DepositRedeemer) instance (PConstantDecl D.DepositRedeemer)
+
+depositValidatorT :: ClosedTerm (DepositConfig :--> DepositRedeemer :--> PScriptContext :--> PBool)
+depositValidatorT = plam $ \conf' redeemer' ctx' -> unTermCont $ do
+    ctx      <- pletFieldsC @'["txInfo", "purpose"] ctx'
+    conf     <- pletFieldsC @'["expectedNumEpochs", "bundleKeyCS", "redeemerPkh", "vlqAC", "tmpAC"] conf'
+    redeemer <- pletFieldsC @'["poolInIdx", "depositInIdx", "redeemerOutIdx", "bundleOutIdx"] redeemer'
+
+    txInfo  <- pletFieldsC @'["inputs", "outputs", "signatories"] $ getField @"txInfo" ctx
+    inputs  <- tletUnwrap $ getField @"inputs"  txInfo
+    outputs <- tletUnwrap $ getField @"outputs" txInfo
+    let
+        poolInIx       = getField @"poolInIdx"      redeemer
+        depositInIdx   = getField @"depositInIdx"   redeemer
+        redeemerOutIdx = getField @"redeemerOutIdx" redeemer
+        bundleOutIdx   = getField @"bundleOutIdx"   redeemer
+
+        expectedNumEpochs = getField @"expectedNumEpochs" conf
+
+        redeemerPkh   = getField @"redeemerPkh" conf
+        vlqAC         = getField @"vlqAC"       conf
+        bundleKeyCS   = getField @"bundleKeyCS" conf
+        tmpAC         = getField @"tmpAC"       conf
+
+        sigs = pfromData $ getField @"signatories" txInfo
+
+        signedByRedeemPkh = containsSignature # sigs # redeemerPkh
+
+    selfIn'   <- tlet $ pelemAt # depositInIdx # inputs
+    selfIn    <- pletFieldsC @'["outRef", "resolved"] selfIn'
+    selfValue <-
+        let self = getField @"resolved" selfIn
+         in tletField @"value" self
+
+    PSpending selfRef' <- tmatch (pfromData $ getField @"purpose" ctx)
+
+    let 
+        selfIdentity =
+            let selfRef   = pfromData $ pfield @"_0" # selfRef'
+                selfInRef = pfromData $ getField @"outRef" selfIn
+             in selfRef #== selfInRef
+
+    poolIn'    <- tlet $ pelemAt # poolInIx # inputs
+    poolOutRef <- tletUnwrap $ pfield @"outRef" # poolIn'
+    let
+        poolId     = pfield @"id" # poolOutRef
+        lqTnBytes  = pcon $ PTokenName $ pfield @"_0" # poolId
+
+    redeemerOut'  <- tlet $ pelemAt # redeemerOutIdx # outputs
+    let 
+        redeemerValue = getRewardValueByPkh' # redeemerOut' # redeemerPkh
+
+        lqAc = assetClass # bundleKeyCS # lqTnBytes
+
+        redeemerLqValue = assetClassValueOf # redeemerValue # lqAc
+        correctLqValue  = redeemerLqValue #== maxLqCap
+
+    bundleOut'  <- tlet $ pelemAt # bundleOutIdx # outputs
+    bundleOut   <- pletFieldsC @'["value", "datum"] bundleOut'
+    let 
+        bundleValue = getField @"value" bundleOut
+        datumOD'    = getField @"datum" bundleOut
+
+    POutputDatum bundleOD' <- pmatchC datumOD'
+
+    bundleOD <- tletField @"outputDatum" bundleOD'
+
+    PDatum bundleDatum'' <- pmatchC bundleOD
+
+    bundleDatum' <- tlet $ ptryFromData @(SB.StakingBundleConfig) $ bundleDatum''
+    bundleDatum  <- pletFieldsC @'["bundleLQAC", "redeemerPkh"] bundleDatum'
+    let
+        bundleLQAC = getField @"bundleLQAC" bundleDatum
+
+        redeemerPkhBundle = getField @"redeemerPkh" bundleDatum
+
+        vlqIn  = assetClassValueOf # selfValue   # vlqAC
+        vlqOut = assetClassValueOf # bundleValue # vlqAC
+        tmpOut = assetClassValueOf # bundleValue # tmpAC
+
+        validVLQQty = vlqIn #== vlqOut
+        validTMPQty = (vlqIn * expectedNumEpochs) #== tmpOut
+
+        validBundleRedeemer = redeemerPkh #== redeemerPkhBundle
+
+        validBundleAC = bundleLQAC #== lqAc
+
+    pure $ signedByRedeemPkh #|| (selfIdentity #&& validVLQQty #&& validTMPQty #&& validBundleRedeemer #&& correctLqValue #&& validBundleAC)