From 7eb1844c903dedac0824974fbdabab9b7d16ee70 Mon Sep 17 00:00:00 2001 From: Pablo Lamela Date: Fri, 5 Apr 2019 12:25:44 +0100 Subject: [PATCH] Add CouponBondGuaranteed example to embedded editor --- meadow-client/src/StaticData.purs | 2 + meadow/app/PSGenerator.hs | 3 +- meadow/contracts/CouponBondGuaranteed.hs | 70 ++++++++++++++++++++++++ meadow/src/Meadow/Contracts.hs | 3 + 4 files changed, 77 insertions(+), 1 deletion(-) create mode 100644 meadow/contracts/CouponBondGuaranteed.hs diff --git a/meadow-client/src/StaticData.purs b/meadow-client/src/StaticData.purs index 557d671ec62..d61db19cc69 100644 --- a/meadow-client/src/StaticData.purs +++ b/meadow-client/src/StaticData.purs @@ -20,6 +20,7 @@ import Marlowe.Contracts import Meadow.Contracts ( escrow , zeroCouponBond + , couponBondGuaranteed ) as E import Data.Map as Map @@ -35,6 +36,7 @@ demoFiles :: Map Label Contents demoFiles = Map.fromFoldable [ "Escrow" /\ E.escrow , "ZeroCouponBond" /\ E.zeroCouponBond + , "CouponBondGuaranteed" /\ E.couponBondGuaranteed ] marloweContracts :: diff --git a/meadow/app/PSGenerator.hs b/meadow/app/PSGenerator.hs index 62e5c7a5dd1..33305090013 100644 --- a/meadow/app/PSGenerator.hs +++ b/meadow/app/PSGenerator.hs @@ -38,7 +38,7 @@ import Language.PureScript.Bridge (BridgePart, Language psTypeParameters, typeModule, typeName, writePSTypes, (^==)) import Language.PureScript.Bridge.PSTypes (psArray, psInt) import Language.PureScript.Bridge.TypeParameters (A) -import Meadow.Contracts (escrow, zeroCouponBond) +import Meadow.Contracts (escrow, zeroCouponBond, couponBondGuaranteed) import Servant ((:<|>)) import Servant.PureScript (HasBridge, Settings, apiModuleName, defaultBridge, defaultSettings, languageBridge, writeAPIModuleWithSettings, @@ -138,6 +138,7 @@ writeUsecases outputDir = do multilineString "gitHead" (CBS.pack gitHead) <> multilineString "escrow" escrow <> multilineString "zeroCouponBond" zeroCouponBond + <> multilineString "couponBondGuaranteed" couponBondGuaranteed usecasesModule = psModule "Meadow.Contracts" usecases createDirectoryIfMissing True (outputDir "Meadow") BS.writeFile (outputDir "Meadow" "Contracts.purs") usecasesModule diff --git a/meadow/contracts/CouponBondGuaranteed.hs b/meadow/contracts/CouponBondGuaranteed.hs new file mode 100644 index 00000000000..8347364093c --- /dev/null +++ b/meadow/contracts/CouponBondGuaranteed.hs @@ -0,0 +1,70 @@ +module CouponBondGuaranteed where + +import Marlowe +import Data.List (genericLength) + +{-# ANN module "HLint: ignore" #-} + +main :: IO () +main = putStrLn $ prettyPrint contract + +------------------------------------- +-- Write your code below this line -- +------------------------------------- + +-- Escrow example using embedding + +contract :: Contract +contract = couponBondGuaranteed 1 2 3 1000 0.08 50 100 450 30240 + +couponBondGuaranteed :: Integer -> Integer -> Integer -> Integer -> Double + -> Timeout -> Timeout -> Timeout -> Timeout -> Contract +couponBondGuaranteed creatorID counterpartyID guarantor notionalPrincipal + nominalInterestRate initialExchangeDate slotCycle + maturityDate gracePeriod = + -- counterpartyID commits a bond face value before initialExchangeDate + Commit 1 0 counterpartyID (Constant notionalPrincipal) initialExchangeDate maturityDate + -- guarantor commits a 'guarantee' before initialExchangeDate + (Commit 2 1 guarantor (Constant totalPayment) initialExchangeDate (maturityDate + gracePeriod) + (Both + -- creatorID can receive the payment from counterpartyID + (Pay 4 1 creatorID (Committed 0) maturityDate Null Null) + -- schedule payments + (Both payments finalPayment) + ) + -- if no guarantee committed we abort contract and allow to redeem the counterpartyID's commit + (Pay 3 0 counterpartyID (Committed 0) maturityDate Null Null) + ) + Null + where + cycles = takeWhile (\i -> + let paymentDate = initialExchangeDate + i * slotCycle + in paymentDate < maturityDate + ) [1..] + + -- calculate payment schedule + paymentDates = map (\i -> initialExchangeDate + i * slotCycle) cycles + + coupon = round $ fromIntegral notionalPrincipal * nominalInterestRate + + -- calculate total amount of payments to be ensured by guarantor + totalPayment = notionalPrincipal + coupon * genericLength cycles + + -- generate Commit/Pay for each scheduled payment + payment amount (ident, paymentDate) = + -- creatorID commits a coupon payment + Commit baseActionId ident creatorID (Constant amount) paymentDate (maturityDate + gracePeriod) + (When FalseObs paymentDate Null + -- counterpartyID can claim the coupon after payment date + (Pay (baseActionId + 1) ident counterpartyID (Committed ident) (maturityDate + gracePeriod) Null Null)) + -- in case creatorID did not commit on time the guarantor pays the coupon + (Pay (baseActionId + 2) (ident + 1) counterpartyID (Constant amount) (maturityDate + gracePeriod) Null Null) + where baseActionId = (5 + ((ident `div` 2) - 1) * 3) + + -- generate coupon payments for given schedule + payments = foldr1 Both $ map (payment coupon) idsAndDates + -- generate IdentCC/IdentPay identifiers for each payment date + where idsAndDates = zip (map (2*) [1..]) paymentDates + + finalPayment = payment notionalPrincipal (2 * (1 + genericLength paymentDates), maturityDate) + diff --git a/meadow/src/Meadow/Contracts.hs b/meadow/src/Meadow/Contracts.hs index 321cb0f3b6d..29a4bf3ae7a 100644 --- a/meadow/src/Meadow/Contracts.hs +++ b/meadow/src/Meadow/Contracts.hs @@ -11,3 +11,6 @@ escrow = $(makeRelativeToProject "contracts/Escrow.hs" >>= embedFile) zeroCouponBond :: ByteString zeroCouponBond = $(makeRelativeToProject "contracts/ZeroCouponBond.hs" >>= embedFile) +couponBondGuaranteed :: ByteString +couponBondGuaranteed = $(makeRelativeToProject "contracts/CouponBondGuaranteed.hs" >>= embedFile) +