Add CouponBondGuaranteed example to embedded editor

IntersectMBO · Apr 5, 2019 · 7eb1844 · 7eb1844
1 parent 71756ad
commit 7eb1844
Show file tree

Hide file tree

Showing 4 changed files with 77 additions and 1 deletion.
diff --git 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
@@ -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
@@ -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
@@ -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)
+