From f36af8231d8625974cda1a81784633a274f2b824 Mon Sep 17 00:00:00 2001 From: Yves Hauser Date: Mon, 30 Aug 2021 14:24:16 +0200 Subject: [PATCH 01/28] scp-2708 - Actus ANN test cases --- marlowe-actus/marlowe-actus.cabal | 2 + .../src/Language/Marlowe/ACTUS/Analysis.hs | 37 +++++++--- .../ACTUS/Definitions/ContractTerms.hs | 23 ++++++ .../Model/APPLICABILITY/Applicability.hs | 2 + .../ACTUS/Model/INIT/StateInitialization.hs | 13 ++-- .../Model/INIT/StateInitializationModel.hs | 50 +++++++++++++ .../Marlowe/ACTUS/Model/POF/Payoff.hs | 15 +++- .../Marlowe/ACTUS/Model/POF/PayoffModel.hs | 2 +- .../ACTUS/Model/SCHED/ContractSchedule.hs | 53 ++++++++++---- .../Model/SCHED/ContractScheduleModel.hs | 7 ++ .../ACTUS/Model/STF/StateTransition.hs | 51 ++++++++++--- .../ACTUS/Model/STF/StateTransitionModel.hs | 68 +++++++++++++++++- .../ACTUS/Model/Utility/ANN/Annuity.hs | 27 +++++++ .../ACTUS/Model/Utility/ANN/Maturity.hs | 71 +++++++++++++++++++ .../ACTUS/Model/Utility/ScheduleGenerator.hs | 4 +- .../src/Language/Marlowe/ACTUS/QCGenerator.hs | 2 + marlowe-actus/test/Spec.hs | 10 ++- marlowe-actus/test/Spec/Marlowe/Actus.hs | 4 +- marlowe-actus/test/Spec/Marlowe/Util.hs | 1 + 19 files changed, 398 insertions(+), 44 deletions(-) create mode 100644 marlowe-actus/src/Language/Marlowe/ACTUS/Model/Utility/ANN/Annuity.hs create mode 100644 marlowe-actus/src/Language/Marlowe/ACTUS/Model/Utility/ANN/Maturity.hs diff --git a/marlowe-actus/marlowe-actus.cabal b/marlowe-actus/marlowe-actus.cabal index dea81aca13e..a7ffe0b8bb5 100644 --- a/marlowe-actus/marlowe-actus.cabal +++ b/marlowe-actus/marlowe-actus.cabal @@ -73,6 +73,8 @@ library Language.Marlowe.ACTUS.Model.INIT.StateInitializationFs Language.Marlowe.ACTUS.Model.APPLICABILITY.Applicability Language.Marlowe.ACTUS.Model.APPLICABILITY.ApplicabilityModel + Language.Marlowe.ACTUS.Model.Utility.ANN.Annuity + Language.Marlowe.ACTUS.Model.Utility.ANN.Maturity Language.Marlowe.ACTUS.Model.Utility.DateShift Language.Marlowe.ACTUS.Model.Utility.ScheduleGenerator Language.Marlowe.ACTUS.Model.Utility.YearFraction diff --git a/marlowe-actus/src/Language/Marlowe/ACTUS/Analysis.hs b/marlowe-actus/src/Language/Marlowe/ACTUS/Analysis.hs index e1c14f85ae5..b2ca67a76b9 100644 --- a/marlowe-actus/src/Language/Marlowe/ACTUS/Analysis.hs +++ b/marlowe-actus/src/Language/Marlowe/ACTUS/Analysis.hs @@ -1,10 +1,11 @@ {-# LANGUAGE RecordWildCards #-} module Language.Marlowe.ACTUS.Analysis(sampleCashflows, genProjectedCashflows, genZeroRiskAssertions) where +import Control.Applicative import qualified Data.List as L (dropWhile, filter, find, groupBy, scanl, tail, zip) import qualified Data.Map as M (empty, fromList, lookup) -import Data.Maybe (fromJust, fromMaybe, isJust) +import Data.Maybe (fromJust, fromMaybe, isJust, isNothing) import Data.Sort (sortOn) import Data.Time (Day) @@ -20,17 +21,19 @@ import Language.Marlowe.ACTUS.Model.INIT.StateInitialization (inititia import Language.Marlowe.ACTUS.Model.POF.Payoff (payoff) import Language.Marlowe.ACTUS.Model.SCHED.ContractSchedule (schedule) import Language.Marlowe.ACTUS.Model.STF.StateTransition (stateTransition) +import Language.Marlowe.ACTUS.Model.Utility.ANN.Maturity (maturity) import Language.Marlowe.ACTUS.Ops (ActusNum (..), YearFractionOps (_y)) import Prelude hiding (Fractional, Num, (*), (+), (-), (/)) + genProjectedCashflows :: DataObserved -> ContractTerms -> [CashFlow] genProjectedCashflows dataObserved = sampleCashflows dataObserved postProcessSchedule :: ContractTerms -> [(EventType, ShiftedDay)] -> [(EventType, ShiftedDay)] postProcessSchedule ct = let trim = L.dropWhile (\(_, d) -> calculationDay d < ct_SD ct) - prioritised = [IED, FP, PR, PD, PRF, PY, PP, IP, IPCI, CE, RRF, RR, DV, PRD, MR, TD, SC, IPCB, MD, XD, STD, AD] + prioritised = [IED, FP, PR, PD, PY, PP, IP, IPCI, CE, RRF, RR, PRF, DV, PRD, MR, TD, SC, IPCB, MD, XD, STD, AD] priority :: (EventType, ShiftedDay) -> Integer priority (event, _) = fromJust $ M.lookup event $ M.fromList (zip prioritised [1..]) simillarity (_, l) (_, r) = calculationDay l == calculationDay r @@ -42,7 +45,7 @@ postProcessSchedule ct = sampleCashflows :: DataObserved -> ContractTerms -> [CashFlow] sampleCashflows dataObserved terms = let - eventTypes = [IED, MD, RR, RRF, IP, PR, IPCB, IPCI, PRD, TD, SC] + eventTypes = [IED, MD, RR, RRF, IP, PR, PRF, IPCB, IPCI, PRD, TD, SC] analysisDate = ct_SD terms preserveDate e d = (e, d) @@ -101,25 +104,39 @@ filterEvents terms@ContractTerms{ contractType = contractType } events = L.filter (\(_, (ShiftedDay{ calculationDay = calculationDay })) -> calculationDay <= fromJust (ct_TD terms)) events else events + ANN -> + if isJust (ct_TD terms) then + L.filter (\(_, (ShiftedDay{ calculationDay = calculationDay })) -> calculationDay <= fromJust (ct_TD terms)) events + else + events filterStates :: ContractTerms -> [(ContractState, EventType, ShiftedDay)] -> [(ContractState, EventType, ShiftedDay)] -filterStates terms@ContractTerms{ contractType = contractType } states = +filterStates ct@ContractTerms{..} states = case contractType of PAM -> - if isJust (ct_PRD terms) then - L.filter (\(_, _, (ShiftedDay{ calculationDay = calculationDay })) -> calculationDay >= fromJust (ct_PRD terms)) states + if isJust ct_PRD then + L.filter (\(_, _, (ShiftedDay{ calculationDay = calculationDay })) -> calculationDay >= fromJust ct_PRD) states else states LAM -> - if isJust (ct_PRD terms) then - L.filter (\(_, eventType, (ShiftedDay{ calculationDay = calculationDay })) -> eventType == PRD || calculationDay > fromJust (ct_PRD terms)) states + if isJust ct_PRD then + L.filter (\(_, eventType, (ShiftedDay{ calculationDay = calculationDay })) -> eventType == PRD || calculationDay > fromJust ct_PRD) states else states NAM -> - if isJust (ct_PRD terms) then - L.filter (\(_, eventType, (ShiftedDay{ calculationDay = calculationDay })) -> eventType == PRD || calculationDay > fromJust (ct_PRD terms)) states + if isJust ct_PRD then + L.filter (\(_, eventType, (ShiftedDay{ calculationDay = calculationDay })) -> eventType == PRD || calculationDay > fromJust ct_PRD) states else states + ANN -> + let states' = if isJust ct_PRD then + L.filter (\(_, eventType, (ShiftedDay{ calculationDay = calculationDay })) -> eventType == PRD || calculationDay > fromJust ct_PRD) states + else states + in + let m = ct_MD <|> ct_AD <|> maturity ct + f (_, PR, ShiftedDay{..}) = isNothing m || Just calculationDay <= m + f (_, _, _) = True + in L.filter f states' genZeroRiskAssertions :: ContractTerms -> Assertion -> Contract -> Contract genZeroRiskAssertions terms@ContractTerms{..} NpvAssertionAgainstZeroRiskBond{..} continue = diff --git a/marlowe-actus/src/Language/Marlowe/ACTUS/Definitions/ContractTerms.hs b/marlowe-actus/src/Language/Marlowe/ACTUS/Definitions/ContractTerms.hs index 0072eef2063..d2756a25445 100644 --- a/marlowe-actus/src/Language/Marlowe/ACTUS/Definitions/ContractTerms.hs +++ b/marlowe-actus/src/Language/Marlowe/ACTUS/Definitions/ContractTerms.hs @@ -13,6 +13,7 @@ import GHC.Generics (Generic) data CT = PAM -- principal at maturity | LAM -- linear amortizer | NAM -- negative amortizer + | ANN -- annuity deriving stock (Show, Read, Eq, Generic) deriving anyclass (FromJSON, ToJSON) -- ContractRole @@ -216,6 +217,7 @@ data ContractTerms = ContractTerms , ct_NT :: Maybe Double -- Notional Principal , ct_PDIED :: Maybe Double -- Premium Discount At IED , ct_MD :: Maybe Day -- Maturity Date + , ct_AD :: Maybe Day -- Amortization Date , ct_PRANX :: Maybe Day -- Cycle Anchor Date Of Principal Redemption , ct_PRCL :: Maybe Cycle -- Cycle Of Principal Redemption , ct_PRNXT :: Maybe Double -- Next Principal Redemption Payment @@ -372,6 +374,27 @@ setDefaultContractTermValues ct@ContractTerms{..} = , ct_RRLC = Just $ fromMaybe infinity ct_RRLC , ct_RRLF = Just $ fromMaybe (-infinity) ct_RRLF + , ct_IPCBA = Just $ fromMaybe 0.0 ct_IPCBA + } + + ANN -> + ct { + ct_FEAC = Just $ fromMaybe 0.0 ct_FEAC + , ct_FER = Just $ fromMaybe 0.0 ct_FER + + , ct_IPAC = Just $ fromMaybe 0.0 ct_IPAC + , ct_IPNR = Just $ fromMaybe 0.0 ct_IPNR + + , ct_PDIED = Just $ fromMaybe 0.0 ct_PDIED + , ct_PPRD = Just $ fromMaybe 0.0 ct_PPRD + , ct_PTD = Just $ fromMaybe 0.0 ct_PTD + , ct_SCCDD = Just $ fromMaybe 0.0 ct_SCCDD + + , ct_RRPF = Just $ fromMaybe (-infinity) ct_RRPF + , ct_RRPC = Just $ fromMaybe infinity ct_RRPC + , ct_RRLC = Just $ fromMaybe infinity ct_RRLC + , ct_RRLF = Just $ fromMaybe (-infinity) ct_RRLF + , ct_IPCBA = Just $ fromMaybe 0.0 ct_IPCBA } in diff --git a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/APPLICABILITY/Applicability.hs b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/APPLICABILITY/Applicability.hs index c38adf02656..b1a9112ea14 100644 --- a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/APPLICABILITY/Applicability.hs +++ b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/APPLICABILITY/Applicability.hs @@ -92,3 +92,5 @@ validateTerms t = _NN ct_PRNXT t "periodic payment amount" <* _NN_I_1 [isJust $ ct_SCEF t, isJust $ ct_SCIED t, isJust $ ct_SCCDD t] t ["scaling effect", "scaling index at status date", "scaling index at contract deal date"] <* _X_I_1 [isJust $ ct_PYRT t, isJust $ ct_PYTP t] [isJust $ ct_PPEF t] t ["penalty rate", "penalty type"] ["prepayment effect"] + ANN -> + Success t diff --git a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/INIT/StateInitialization.hs b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/INIT/StateInitialization.hs index 54e6e8be457..2a0d520150a 100644 --- a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/INIT/StateInitialization.hs +++ b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/INIT/StateInitialization.hs @@ -1,15 +1,16 @@ {-# LANGUAGE RecordWildCards #-} module Language.Marlowe.ACTUS.Model.INIT.StateInitialization where -import Data.Maybe (fromMaybe) +import Data.Maybe (fromJust, fromMaybe, maybeToList) import Language.Marlowe.ACTUS.Definitions.BusinessEvents (EventType (FP, IP, PR)) import Language.Marlowe.ACTUS.Definitions.ContractState (ContractState) -import Language.Marlowe.ACTUS.Definitions.ContractTerms (CT (LAM, NAM, PAM), ContractTerms (..)) +import Language.Marlowe.ACTUS.Definitions.ContractTerms (CT (..), ContractTerms (..)) import Language.Marlowe.ACTUS.Definitions.Schedule (ShiftedDay (calculationDay)) -import Language.Marlowe.ACTUS.Model.INIT.StateInitializationModel (_INIT_LAM, _INIT_NAM, _INIT_PAM) +import Language.Marlowe.ACTUS.Model.INIT.StateInitializationModel (_INIT_ANN, _INIT_LAM, _INIT_NAM, _INIT_PAM) import Language.Marlowe.ACTUS.Model.SCHED.ContractSchedule (schedule) +import Language.Marlowe.ACTUS.Model.Utility.ANN.Maturity (maturity) import Language.Marlowe.ACTUS.Model.Utility.ScheduleGenerator (inf, sup) - +import Language.Marlowe.ACTUS.Ops (YearFractionOps (_y)) inititializeState :: ContractTerms -> ContractState inititializeState terms@ContractTerms {..} = @@ -27,3 +28,7 @@ inititializeState terms@ContractTerms {..} = PAM -> _INIT_PAM t0 tminus tfp_minus tfp_plus terms LAM -> _INIT_LAM t0 tminus tpr_minus tfp_minus tfp_plus terms NAM -> _INIT_NAM t0 tminus tpr_minus tfp_minus tfp_plus terms + ANN -> let prDates = maybe [] (map calculationDay) prSchedule ++ maybeToList (maturity terms) + ti = zipWith (\tn tm -> _y (fromJust ct_DCC) tn tm ct_MD) prDates (tail prDates) + in _INIT_ANN t0 tminus tpr_minus tfp_minus tfp_plus ti terms + diff --git a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/INIT/StateInitializationModel.hs b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/INIT/StateInitializationModel.hs index 1665c34c142..fb935cb1beb 100644 --- a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/INIT/StateInitializationModel.hs +++ b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/INIT/StateInitializationModel.hs @@ -11,12 +11,15 @@ import Language.Marlowe.ACTUS.Definitions.ContractTerms (CR, Con SCEF (SE_0N0, SE_0NM, SE_I00, SE_I0M, SE_IN0, SE_INM), ScheduleConfig (..), n) import Language.Marlowe.ACTUS.Definitions.Schedule (ShiftedDay (..), ShiftedSchedule) +import Language.Marlowe.ACTUS.Model.Utility.ANN.Annuity (annuity) import Language.Marlowe.ACTUS.Model.Utility.ContractRoleSign (contractRoleSign) import Language.Marlowe.ACTUS.Model.Utility.ScheduleGenerator (applyEOMC, generateRecurrentScheduleWithCorrections, minusCycle, plusCycle) import Language.Marlowe.ACTUS.Model.Utility.YearFraction (yearFraction) +{-# ANN module "HLint: ignore Use camelCase" #-} + _S :: Day -> Cycle -> Day -> ScheduleConfig -> ShiftedSchedule _S = generateRecurrentScheduleWithCorrections @@ -203,3 +206,50 @@ _INIT_NAM t0 tminus _ tfp_minus tfp_plus -- All is same as PAM except PRNXT and TMD, IPCB same as LAM in pam_init { prnxt = prnxt, ipcb = ipcb, tmd = tmd } + +_INIT_ANN :: Day -> Day -> Day -> Day -> Day -> [Double] -> ContractTerms -> ContractStatePoly Double Day +_INIT_ANN t0 tminus tpr_minus tfp_minus tfp_plus ti + terms@ContractTerms{..} = + let + _IED = fromJust ct_IED + _DCC = fromJust ct_DCC + + -- TMD + maybeTMinus + | isJust ct_PRANX && (fromJust ct_PRANX >= t0) = ct_PRANX + | (_IED `plusCycle` fromJust ct_PRCL) >= t0 = Just $ _IED `plusCycle` fromJust ct_PRCL + | otherwise = Just tpr_minus + + pam_init = _INIT_PAM t0 tminus tfp_minus tfp_plus terms + + -- PRNXT + nt + | _IED > t0 = 0.0 + | otherwise = r ct_CNTRL * fromJust ct_NT + ipnr + | _IED > t0 = 0.0 + | otherwise = fromMaybe 0.0 ct_IPNR + ipac + | isNothing ct_IPNR = 0.0 + | isJust ct_IPAC = fromJust ct_IPAC + | otherwise = y _DCC tminus t0 ct_MD * nt * ipnr + + prnxt + -- | isJust ct_PRNXT = r ct_CNTRL * fromJust ct_PRNXT + | isJust ct_PRNXT = fromJust ct_PRNXT + | otherwise = let scale = fromJust ct_NT + ipac + frac = annuity ipnr ti + in frac * scale + + tmd + | isJust ct_MD = fromJust ct_MD + | otherwise = fromJust maybeTMinus `plusCycle` (fromJust ct_PRCL) { n = ceiling(fromJust ct_NT / (prnxt - fromJust ct_NT * y _DCC tminus (tminus `plusCycle` fromJust ct_PRCL) ct_MD * fromJust ct_IPNR))} + + -- IPCB + ipcb + | t0 < _IED = 0.0 + | fromJust ct_IPCB == IPCB_NT = r ct_CNTRL * fromJust ct_NT + | otherwise = r ct_CNTRL * fromJust ct_IPCBA + -- All is same as PAM except PRNXT and TMD, IPCB same as LAM + in pam_init { prnxt = prnxt, ipcb = ipcb, tmd = tmd } + diff --git a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/POF/Payoff.hs b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/POF/Payoff.hs index 3f171ed9d3d..5c2cb351bea 100644 --- a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/POF/Payoff.hs +++ b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/POF/Payoff.hs @@ -6,7 +6,7 @@ import Data.Maybe (fromJust) import Data.Time (Day) import Language.Marlowe.ACTUS.Definitions.BusinessEvents (EventType (..), RiskFactors (..)) import Language.Marlowe.ACTUS.Definitions.ContractState (ContractState, ContractStatePoly (..)) -import Language.Marlowe.ACTUS.Definitions.ContractTerms (CT (LAM, NAM, PAM), ContractTerms (..)) +import Language.Marlowe.ACTUS.Definitions.ContractTerms (CT (..), ContractTerms (..)) import Language.Marlowe.ACTUS.Model.POF.PayoffModel import Language.Marlowe.ACTUS.Ops (YearFractionOps (_y)) @@ -52,3 +52,16 @@ payoff ev RiskFactors{..} ContractTerms{..} ContractStatePoly {..} t = TD -> _POF_TD_NAM o_rf_CURS ct_CNTRL (fromJust ct_PTD) ipac ipnr ipcb y_sd_t IP -> _POF_IP_NAM o_rf_CURS isc ipac ipnr ipcb y_sd_t _ -> 0.0 + ANN -> + case ev of + IED -> _POF_IED_PAM o_rf_CURS ct_CNTRL (fromJust ct_NT) (fromJust ct_PDIED) + PR -> _POF_PR_NAM o_rf_CURS ct_CNTRL nsc prnxt ipac y_sd_t ipnr ipcb nt + MD -> _POF_MD_PAM o_rf_CURS nsc nt isc ipac feac + PP -> _POF_PP_PAM o_rf_CURS pp_payoff + PY -> _POF_PY_PAM (fromJust ct_PYTP) o_rf_CURS o_rf_RRMO (fromJust ct_PYRT) ct_cPYRT ct_CNTRL nt ipnr y_sd_t + FP -> _POF_FP_PAM (fromJust ct_FEB) (fromJust ct_FER) o_rf_CURS ct_CNTRL nt feac y_sd_t + PRD -> _POF_PRD_LAM o_rf_CURS ct_CNTRL (fromJust ct_PPRD) ipac ipnr ipcb y_sd_t + TD -> _POF_TD_LAM o_rf_CURS ct_CNTRL (fromJust ct_PTD) ipac ipnr ipcb y_sd_t + IP -> _POF_IP_LAM o_rf_CURS isc ipac ipnr ipcb y_sd_t + _ -> 0.0 + diff --git a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/POF/PayoffModel.hs b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/POF/PayoffModel.hs index 6131236a439..429e3fc6f28 100644 --- a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/POF/PayoffModel.hs +++ b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/POF/PayoffModel.hs @@ -75,7 +75,7 @@ _POF_IED_NAM = _POF_IED_PAM _POF_PR_NAM :: (RoleSignOps a, ActusNum a, ActusOps a) => a -> CR -> a -> a -> a -> a -> a -> a -> a -> a _POF_PR_NAM o_rf_CURS _CNTRL nsc prnxt ipac y_sd_t ipnr ipcb nt = let ra = prnxt - _r _CNTRL * (ipac + y_sd_t * ipnr * ipcb) - r = ra - (_max _zero (ra - (_abs nt))) + r = ra - _max _zero (ra - _abs nt) in o_rf_CURS * _r _CNTRL * nsc * r _POF_MD_NAM :: ActusNum a => a -> a -> a -> a -> a -> a -> a diff --git a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/SCHED/ContractSchedule.hs b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/SCHED/ContractSchedule.hs index 50c3453ac8c..848e39b01d7 100644 --- a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/SCHED/ContractSchedule.hs +++ b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/SCHED/ContractSchedule.hs @@ -2,15 +2,17 @@ module Language.Marlowe.ACTUS.Model.SCHED.ContractSchedule where -import Data.Maybe (fromJust, fromMaybe) -import Language.Marlowe.ACTUS.Definitions.BusinessEvents (EventType (FP, IED, IP, IPCB, IPCI, MD, PP, PR, PRD, PY, RR, RRF, SC, TD)) +import Control.Applicative (Alternative ((<|>))) +import Data.Maybe (fromJust, fromMaybe, isJust) +import Language.Marlowe.ACTUS.Definitions.BusinessEvents (EventType (..)) import Language.Marlowe.ACTUS.Definitions.ContractState (ContractStatePoly (tmd)) -import Language.Marlowe.ACTUS.Definitions.ContractTerms (CT (LAM, NAM, PAM), ContractTerms (..)) +import Language.Marlowe.ACTUS.Definitions.ContractTerms (CT (..), ContractTerms (..), n) import Language.Marlowe.ACTUS.Definitions.Schedule (ShiftedDay (calculationDay)) import Language.Marlowe.ACTUS.Model.INIT.StateInitializationModel (_INIT_LAM, _INIT_NAM) import Language.Marlowe.ACTUS.Model.SCHED.ContractScheduleModel -import Language.Marlowe.ACTUS.Model.Utility.ScheduleGenerator (inf, sup) - +import Language.Marlowe.ACTUS.Model.Utility.ANN.Maturity (maturity) +import Language.Marlowe.ACTUS.Model.Utility.ScheduleGenerator (inf, plusCycle, sup) +import Language.Marlowe.ACTUS.Model.Utility.YearFraction (yearFraction) schedule :: EventType -> ContractTerms -> Maybe [ShiftedDay] schedule ev @@ -53,12 +55,12 @@ schedule ev -- Also cannot call initializeState directly without cyclical imports t0 = ct_SD fpSchedule = schedule FP ct - tfp_minus = fromMaybe t0 $ calculationDay <$> ((\sc -> sup sc t0) =<< fpSchedule) - tfp_plus = fromMaybe t0 $ calculationDay <$> ((\sc -> inf sc t0) =<< fpSchedule) + tfp_minus = maybe t0 calculationDay ((\sc -> sup sc t0) =<< fpSchedule) + tfp_plus = maybe t0 calculationDay ((\sc -> inf sc t0) =<< fpSchedule) ipSchedule = schedule IP ct - tminus = fromMaybe t0 $ calculationDay <$> ((\sc -> sup sc t0) =<< ipSchedule) + tminus = maybe t0 calculationDay ((\sc -> sup sc t0) =<< ipSchedule) prSchedule = schedule PR ct - tpr_minus = fromMaybe t0 $ calculationDay <$> ((\sc -> sup sc t0) =<< prSchedule) + tpr_minus = maybe t0 calculationDay ((\sc -> sup sc t0) =<< prSchedule) _tmd = tmd $ _INIT_LAM ct_SD tminus tpr_minus tfp_minus tfp_plus ct in case ev of IED -> _SCHED_IED_LAM scfg ct_IED' @@ -82,12 +84,12 @@ schedule ev let t0 = ct_SD fpSchedule = schedule FP ct - tfp_minus = fromMaybe t0 $ calculationDay <$> ((\sc -> sup sc t0) =<< fpSchedule) - tfp_plus = fromMaybe t0 $ calculationDay <$> ((\sc -> inf sc t0) =<< fpSchedule) + tfp_minus = maybe t0 calculationDay ((\sc -> sup sc t0) =<< fpSchedule) + tfp_plus = maybe t0 calculationDay ((\sc -> inf sc t0) =<< fpSchedule) ipSchedule = schedule IP ct - tminus = fromMaybe t0 $ calculationDay <$> ((\sc -> sup sc t0) =<< ipSchedule) + tminus = maybe t0 calculationDay ((\sc -> sup sc t0) =<< ipSchedule) prSchedule = schedule PR ct - tpr_minus = fromMaybe t0 $ calculationDay <$> ((\sc -> sup sc t0) =<< prSchedule) + tpr_minus = maybe t0 calculationDay ((\sc -> sup sc t0) =<< prSchedule) _tmd = tmd $ _INIT_NAM ct_SD tminus tpr_minus tfp_minus tfp_plus ct in case ev of IED -> _SCHED_IED_NAM scfg ct_IED' @@ -105,3 +107,28 @@ schedule ev RRF -> _SCHED_RRF_NAM scfg ct_IED' ct_RRANX ct_RRCL ct_RRNXT _tmd ct_SD SC -> _SCHED_SC_NAM scfg ct_IED' ct_SCEF' ct_SCANX ct_SCCL _tmd _ -> Nothing + + ANN -> + let mat = maturity ct + _tmd = ct_AD <|> mat + + in case ev of + IED -> _SCHED_IED_PAM scfg ct_IED' + PR -> _tmd >>= _SCHED_PR_LAM scfg ct_PRCL ct_IED' ct_PRANX + MD -> ct_MD <|> _tmd >>= _SCHED_MD_PAM scfg + PP -> _tmd >>= _SCHED_PP_PAM scfg ct_PPEF' ct_OPCL ct_IED' ct_OPANX + PY -> _tmd >>= _SCHED_PY_PAM scfg ct_PYTP' ct_PPEF' ct_OPCL ct_IED' ct_OPANX + FP -> _tmd >>= _SCHED_FP_PAM scfg ct_FER' ct_FECL ct_IED' ct_FEANX + PRD -> _SCHED_PRD_PAM scfg ct_PRD + TD -> _SCHED_TD_PAM scfg ct_TD + IP -> ct_MD <|> _tmd >>= _SCHED_IP_NAM scfg ct_IED' ct_PRCL ct_PRANX ct_IPCED ct_IPANX ct_IPCL + IPCI -> _tmd >>= \t -> _SCHED_IPCI_PAM scfg ct_IED' ct_IPANX ct_IPCL ct_IPCED t ct_IPNR + IPCB -> _tmd >>= _SCHED_IPCB_LAM scfg ct_IED' ct_IPCB ct_IPCBCL ct_IPCBANX + RR -> _tmd >>= _SCHED_RR_PAM scfg ct_IED' ct_SD ct_RRANX ct_RRCL ct_RRNXT + RRF -> _tmd >>= \t -> _SCHED_RRF_PAM scfg ct_IED' ct_RRANX ct_RRCL ct_RRNXT t ct_SD + SC -> _tmd >>= _SCHED_SC_PAM scfg ct_IED' ct_SCEF' ct_SCANX ct_SCCL + PRF -> let prf = _SCHED_PRF_ANN ct_PRANX ct_PRNXT ct_IED + rr = _tmd >>= _SCHED_RR_PAM scfg ct_IED' ct_SD ct_RRANX ct_RRCL ct_RRNXT + rrf = _tmd >>= \t -> _SCHED_RRF_PAM scfg ct_IED' ct_RRANX ct_RRCL ct_RRNXT t ct_SD + in Just $ fromMaybe [] prf ++ fromMaybe [] rr ++ fromMaybe [] rrf + _ -> Nothing diff --git a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/SCHED/ContractScheduleModel.hs b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/SCHED/ContractScheduleModel.hs index 320f367afd9..504fa2a9eb2 100644 --- a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/SCHED/ContractScheduleModel.hs +++ b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/SCHED/ContractScheduleModel.hs @@ -6,6 +6,7 @@ module Language.Marlowe.ACTUS.Model.SCHED.ContractScheduleModel where import Data.List as L (find, nub) import Data.Maybe (fromJust, fromMaybe, isJust, isNothing) import Data.Time (Day) +import Data.Time.Calendar (addDays) import Language.Marlowe.ACTUS.Definitions.ContractTerms (Cycle (..), IPCB (IPCB_NTL), PPEF (..), PYTP (..), SCEF (..), ScheduleConfig) import Language.Marlowe.ACTUS.Definitions.Schedule (ShiftedDay (..), ShiftedSchedule) @@ -253,3 +254,9 @@ _SCHED_RR_NAM = _SCHED_RR_PAM _SCHED_RRF_NAM = _SCHED_RRF_PAM _SCHED_SC_NAM = _SCHED_SC_PAM + +_SCHED_PRF_ANN :: Maybe Day -> Maybe Double -> Maybe Day -> Maybe ShiftedSchedule +_SCHED_PRF_ANN _PRANX _PRNXT _IED = + let result | isJust _PRANX && isNothing _PRNXT && _PRANX > _IED = let previousDay = addDays (-1) $ fromJust _PRANX in Just [ShiftedDay previousDay previousDay] + | otherwise = Nothing + in result diff --git a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/STF/StateTransition.hs b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/STF/StateTransition.hs index 6fea7b33f74..bd8359a9ded 100644 --- a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/STF/StateTransition.hs +++ b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/STF/StateTransition.hs @@ -2,24 +2,20 @@ module Language.Marlowe.ACTUS.Model.STF.StateTransition where +import Data.Maybe (fromJust, fromMaybe, maybeToList) import Data.Time (Day) import Language.Marlowe.ACTUS.Definitions.BusinessEvents (EventType (..), RiskFactors (..)) -import Language.Marlowe.ACTUS.Definitions.ContractState (ContractState, - ContractStatePoly (ContractStatePoly, feac, ipac, ipcb, ipnr, isc, nsc, nt, prf, prnxt, sd, tmd)) - -import Data.Maybe (fromJust, fromMaybe) -import Language.Marlowe.ACTUS.Definitions.ContractTerms (CT (LAM, NAM, PAM), ContractTerms (..), - ScheduleConfig) +import Language.Marlowe.ACTUS.Definitions.ContractState (ContractState, ContractStatePoly (..)) +import Language.Marlowe.ACTUS.Definitions.ContractTerms (CT (..), ContractTerms (..), ScheduleConfig) import Language.Marlowe.ACTUS.Definitions.Schedule (ShiftedDay (calculationDay)) import Language.Marlowe.ACTUS.Model.SCHED.ContractSchedule (schedule) import Language.Marlowe.ACTUS.Model.STF.StateTransitionModel +import Language.Marlowe.ACTUS.Model.Utility.ANN.Maturity (maturity) +import Language.Marlowe.ACTUS.Model.Utility.DateShift import Language.Marlowe.ACTUS.Model.Utility.ScheduleGenerator (inf, sup) import Language.Marlowe.ACTUS.Ops (YearFractionOps (_y)) -import Language.Marlowe.ACTUS.Model.Utility.DateShift - - shift :: ScheduleConfig -> Day -> ShiftedDay shift = applyBDCWithCfg @@ -39,12 +35,23 @@ stateTransition ev RiskFactors{..} terms@ContractTerms{..} st@ContractStatePoly{ ct_SCCDD' = fromJust ct_SCCDD fpSchedule = schedule FP terms + prSchedule = schedule PR terms + tfp_minus = fromMaybe t $ calculationDay <$> ((\sc -> sup sc t) =<< fpSchedule) tfp_plus = fromMaybe t $ calculationDay <$> ((\sc -> inf sc t) =<< fpSchedule) + + tpr_minus = fromMaybe t $ calculationDay <$> ((\sc -> sup sc t) =<< prSchedule) + tpr_plus = fromMaybe t $ calculationDay <$> ((\sc -> inf sc t) =<< prSchedule) + y_sd_t = _y ct_DCC' sd t ct_MD y_tfpminus_t = _y ct_DCC' tfp_minus t ct_MD y_tfpminus_tfpplus = _y ct_DCC' tfp_minus tfp_plus ct_MD y_ipanx_t = _y ct_DCC' (fromJust ct_IPANX) t ct_MD + + y_tprminus_t = _y ct_DCC' tpr_minus t ct_MD + y_tprminus_tprplus = _y ct_DCC' tpr_minus tpr_plus ct_MD + + y_t = _y ct_DCC' t tpr_plus ct_MD in case contractType of PAM -> case ev of @@ -101,3 +108,29 @@ stateTransition ev RiskFactors{..} terms@ContractTerms{..} st@ContractStatePoly{ SC -> _STF_SC_NAM st t y_sd_t y_tfpminus_t y_tfpminus_tfpplus ct_FEB ct_FER' ct_CNTRL ct_SCEF' o_rf_SCMO ct_SCIED' CE -> _STF_AD_NAM st t y_sd_t _ -> st + ANN -> + let prDates = maybe [] (map calculationDay) prSchedule ++ maybeToList (maturity terms) + prDatesAfterSd = filter (\d -> d > sd) prDates + ti = zipWith (\tn tm -> _y (fromJust ct_DCC) tn tm ct_MD) prDatesAfterSd (tail prDatesAfterSd) + in + case ev of + AD -> _STF_AD_PAM st t y_sd_t + IED -> _STF_IED_LAM st t y_ipanx_t ct_IPNR ct_IPANX ct_CNTRL ct_IPAC (fromJust ct_NT) ct_IPCB ct_IPCBA + PR -> _STF_PR_NAM st t pp_payoff y_sd_t y_tfpminus_t y_tfpminus_tfpplus ct_FEB ct_FER' ct_CNTRL ct_IPCB + MD -> _STF_MD_LAM st t + PP -> _STF_PP_LAM st t pp_payoff y_sd_t y_tfpminus_t y_tfpminus_tfpplus ct_FEB ct_FER' ct_CNTRL ct_IPCB + PY -> _STF_PY_LAM st t y_sd_t y_tfpminus_t y_tfpminus_tfpplus ct_FEB ct_FER' ct_CNTRL + FP -> _STF_FP_LAM st t y_sd_t + PRD -> _STF_PRD_LAM st t y_sd_t y_tfpminus_t y_tfpminus_tfpplus ct_FEB ct_FER' ct_CNTRL + TD -> _STF_TD_PAM st t + IP -> _STF_IP_PAM st t y_sd_t y_tfpminus_t y_tfpminus_tfpplus ct_FEB ct_FER' ct_CNTRL + IPCI -> _STF_IPCI_LAM st t y_sd_t y_tfpminus_t y_tfpminus_tfpplus ct_FEB ct_FER' ct_CNTRL ct_IPCB + IPCB -> _STF_IPCB_LAM st t y_sd_t y_tfpminus_t y_tfpminus_tfpplus ct_FEB ct_FER' ct_CNTRL + RR -> _STF_RR_ANN st t y_sd_t y_tfpminus_t y_tfpminus_tfpplus ct_FEB ct_FER' ct_CNTRL ct_RRLF' ct_RRLC' ct_RRPC' ct_RRPF' ct_RRMLT' ct_RRSP' o_rf_RRMO ti + RRF -> _STF_RRF_ANN st t y_sd_t y_tfpminus_t y_tfpminus_tfpplus ct_FEB ct_FER' ct_CNTRL (fromJust ct_RRNXT) ti + SC -> _STF_SC_LAM st t y_sd_t y_tfpminus_t y_tfpminus_tfpplus ct_FEB ct_FER' ct_CNTRL ct_SCEF' o_rf_SCMO ct_SCIED' + CE -> _STF_AD_PAM st t y_sd_t + PRF -> _STF_PRF_ANN st t y_sd_t y_tfpminus_t y_tfpminus_tfpplus y_tprminus_t y_tprminus_tprplus ct_FEB ct_FER' ct_CNTRL ct_RRNXT y_t ti + _ -> st + + diff --git a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/STF/StateTransitionModel.hs b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/STF/StateTransitionModel.hs index 9ef0843e373..a7abe6a1657 100644 --- a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/STF/StateTransitionModel.hs +++ b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/STF/StateTransitionModel.hs @@ -6,11 +6,11 @@ import Data.Maybe (fromJust, fro import Language.Marlowe.ACTUS.Definitions.ContractState (ContractStatePoly (ContractStatePoly, feac, ipac, ipcb, ipnr, isc, nsc, nt, prf, prnxt, sd, tmd)) import Language.Marlowe.ACTUS.Definitions.ContractTerms (CR, FEB (FEB_N), IPCB (..), SCEF (SE_00M, SE_0N0, SE_0NM, SE_I00)) +import Language.Marlowe.ACTUS.Model.Utility.ANN.Annuity (annuity) import Language.Marlowe.ACTUS.Ops (ActusNum (..), ActusOps (..), DateOps (_lt), RoleSignOps (_r)) import Prelude hiding (Fractional, Num, (*), (+), (-), (/)) - -- Principal at Maturity _STF_AD_PAM :: ActusNum a => ContractStatePoly a b -> b -> a -> ContractStatePoly a b _STF_AD_PAM st@ContractStatePoly{..} t y_sd_t = st { @@ -339,3 +339,69 @@ _STF_SC_NAM = _STF_SC_LAM _STF_CE_NAM :: ActusNum a => ContractStatePoly a b -> b -> a -> ContractStatePoly a b _STF_CE_NAM = _STF_AD_PAM + +-- Annuity (ANN) + +_STF_RR_ANN :: (ActusOps a, RoleSignOps a, ActusNum a) => ContractStatePoly a b -> b -> a -> a -> a -> Maybe FEB -> a -> CR -> a -> a -> a -> a -> a -> a -> a -> [a] -> ContractStatePoly a b +_STF_RR_ANN st@ContractStatePoly{..} t y_sd_t y_tfpminus_t y_tfpminus_tfpplus _FEB _FER _CNTRL _RRLF _RRLC _RRPC _RRPF _RRMLT _RRSP o_rf_RRMO ti = + let ipac' = ipac + y_sd_t * ipnr * ipcb + + feac' = case _FEB of + Just FEB_N -> feac + y_sd_t * nt * _FER + _ -> y_tfpminus_t / y_tfpminus_tfpplus * _r _CNTRL * _FER + + delta_r = _min (_max (o_rf_RRMO * _RRMLT + _RRSP - ipnr) _RRPF) _RRPC + + ipnr' = _min (_max (ipnr + delta_r) _RRLF) _RRLC + + prnxt' = annuity ipnr' ti + + in st + { ipac = ipac', + feac = feac', + ipnr = ipnr', + prnxt = prnxt', + sd = t + } + +_STF_RRF_ANN :: (ActusOps a, RoleSignOps a, ActusNum a) => ContractStatePoly a b -> b -> a -> a -> a -> Maybe FEB -> a -> CR -> a -> [a] -> ContractStatePoly a b +_STF_RRF_ANN st@ContractStatePoly{..} t y_sd_t y_tfpminus_t y_tfpminus_tfpplus _FEB _FER _CNTRL _RRNXT ti = + let ipac' = ipac + y_sd_t * ipnr * ipcb + + feac' = case _FEB of + Just FEB_N -> feac + y_sd_t * nt * _FER + _ -> y_tfpminus_t / y_tfpminus_tfpplus * _r _CNTRL * _FER + + + ipnr' = _RRNXT + + prnxt' = annuity ipnr' ti + + in st + { ipac = ipac', + feac = feac', + ipnr = ipnr', + prnxt = prnxt', + sd = t + } + +_STF_PRF_ANN :: (ActusOps a, RoleSignOps a, ActusNum a) => ContractStatePoly a b -> b -> a-> a-> a -> a -> a -> Maybe FEB -> a -> CR -> Maybe a -> a -> [a] -> ContractStatePoly a b +_STF_PRF_ANN st@ContractStatePoly{..} t y_sd_t y_tfpminus_t y_tfpminus_tfpplus _ _ _FEB _FER _CNTRL _RRNXT y_t ti = + let accruedInterest = ipac + y_sd_t * ipnr * ipcb + + feeAccrued = case _FEB of + Just FEB_N -> feac + y_sd_t * nt * _FER + _ -> y_tfpminus_t / y_tfpminus_tfpplus * _r _CNTRL * _FER + + scale = nt + accruedInterest + y_t*ipnr*nt + frac = annuity ipnr ti + + nextPrincipalRedemptionPayment = _r _CNTRL * frac * scale + statusDate = t + + in st + { ipac = accruedInterest, + feac = feeAccrued, + prnxt = nextPrincipalRedemptionPayment, + sd = statusDate + } diff --git a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/Utility/ANN/Annuity.hs b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/Utility/ANN/Annuity.hs new file mode 100644 index 00000000000..4661db28f0b --- /dev/null +++ b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/Utility/ANN/Annuity.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE RecordWildCards #-} +module Language.Marlowe.ACTUS.Model.Utility.ANN.Annuity + (annuity) +where + +import Data.List (foldl', tails) +import Language.Marlowe.ACTUS.Ops (ActusNum (..), ActusOps (..)) +import Prelude hiding (Fractional, Num, (*), (+), (-), (/)) + +-- |annuity amount function (A), as described in section 3.8 in the +-- ACTUS reference v1.1 +annuity :: (ActusOps a, ActusNum a) => + a -- ^ actual interest rate + -> [a] -- ^ ti + -> a +annuity r ti = numerator / denominator + + where + numerator = _product $ map ((+_one).(*r)) ti + denominator = _sum (map _product $ tails $ map ((+_one).(*r)) ti) + + -- note that _product [] == 1 + _product :: (ActusNum a, ActusOps a) => [a] -> a + _product = foldl' (*) _one + + _sum :: (ActusNum a, ActusOps a) => [a] -> a + _sum = foldl' (+) _zero diff --git a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/Utility/ANN/Maturity.hs b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/Utility/ANN/Maturity.hs new file mode 100644 index 00000000000..4298d3e65d6 --- /dev/null +++ b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/Utility/ANN/Maturity.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE RecordWildCards #-} +module Language.Marlowe.ACTUS.Model.Utility.ANN.Maturity + (maturity) +where + +import Data.Ord (Down (..)) +import Data.Sort (sortOn) +import Data.Time (Day) +import Language.Marlowe.ACTUS.Definitions.ContractTerms (ContractTerms (..), Cycle (n), DCC, + ScheduleConfig) +import Language.Marlowe.ACTUS.Definitions.Schedule (ShiftedDay (ShiftedDay, calculationDay, paymentDay), + ShiftedSchedule) +import Language.Marlowe.ACTUS.Model.Utility.DateShift (applyBDCWithCfg) +import Language.Marlowe.ACTUS.Model.Utility.ScheduleGenerator (generateRecurrentScheduleWithCorrections, + plusCycle) +import Language.Marlowe.ACTUS.Ops (YearFractionOps (_y)) + +maturity :: ContractTerms -> Maybe Day +maturity ContractTerms{..} = + maturity' + ct_SD + ct_SD + scfg + ct_DCC + ct_AD + ct_MD + ct_IED + ct_PRANX + ct_PRCL + ct_PRNXT + ct_IPNR + ct_NT + +maturity' :: Day -- t0 + -> Day -- status date + -> ScheduleConfig -- schedule config + -> Maybe DCC -- day count convention + -> Maybe Day -- amorization date + -> Maybe Day -- maturity date + -> Maybe Day -- initial exchange date + -> Maybe Day -- cycle anchor date of principal redemption + -> Maybe Cycle -- cycle of principal redemption + -> Maybe Double -- next principal redemption payment + -> Maybe Double -- nominal interest rate + -> Maybe Double -- notional principal + -> Maybe Day -- maturity +maturity' t0 sd scfg (Just dcc) Nothing Nothing (Just ied) (Just pranx) (Just prcl) (Just prnxt) (Just ipnr) (Just nt) = + let tplus = ied `plusCycle` prcl + + lastEvent + | pranx >= t0 = pranx + | tplus >= t0 = tplus + | otherwise = + let previousEvents = _S sd prcl pranx scfg + in calculationDay . head . sortOn (Down . calculationDay) . filter (\ShiftedDay {..} -> calculationDay > t0) $ previousEvents + + timeFromLastEventPlusOneCycle = _y dcc lastEvent (lastEvent `plusCycle` prcl) Nothing + + redemptionPerCycle = prnxt - timeFromLastEventPlusOneCycle * ipnr * nt + + remainingPeriods = (ceiling (nt / redemptionPerCycle) - 1) :: Integer + + in Just . calculationDay . applyBDCWithCfg scfg $ lastEvent `plusCycle` prcl {n = remainingPeriods} + + where + _S :: Day -> Cycle -> Day -> ScheduleConfig -> ShiftedSchedule + _S = generateRecurrentScheduleWithCorrections + +maturity' _ _ _ _ ad@(Just _) _ _ _ _ _ _ _ = ad +maturity' _ _ _ _ Nothing md@(Just _) _ _ _ _ _ _ = md +maturity' _ _ _ _ _ _ _ _ _ _ _ _ = Nothing diff --git a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/Utility/ScheduleGenerator.hs b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/Utility/ScheduleGenerator.hs index fb09c3e22b4..f30117fbb35 100644 --- a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/Utility/ScheduleGenerator.hs +++ b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/Utility/ScheduleGenerator.hs @@ -36,11 +36,11 @@ minimumMaybe xs = Just $ minimum xs inf :: [ShiftedDay] -> Day -> Maybe ShiftedDay inf set threshold = - minimumMaybe [t | t <- set, calculationDay t >= threshold] + minimumMaybe [t | t <- set, calculationDay t > threshold] sup :: [ShiftedDay] -> Day -> Maybe ShiftedDay sup set threshold = - maximumMaybe [t | t <- set, calculationDay t <= threshold] + maximumMaybe [t | t <- set, calculationDay t < threshold] remove :: ShiftedDay -> [ShiftedDay] -> [ShiftedDay] remove d = filter (\t -> calculationDay t /= calculationDay d) diff --git a/marlowe-actus/src/Language/Marlowe/ACTUS/QCGenerator.hs b/marlowe-actus/src/Language/Marlowe/ACTUS/QCGenerator.hs index 48e6343b461..38a9df70164 100644 --- a/marlowe-actus/src/Language/Marlowe/ACTUS/QCGenerator.hs +++ b/marlowe-actus/src/Language/Marlowe/ACTUS/QCGenerator.hs @@ -100,6 +100,7 @@ contractTermsGen = do nextPrincipalRedemption <- mightbe largeamount purchaseDate <- mightbe date maturityDate <- mightbe date + amortizationDate <- mightbe date terminationDate <- mightbe date priceAtTerminationDate <- mightbe smallamount priceAtPurchaseDate <- mightbe smallamount @@ -137,6 +138,7 @@ contractTermsGen = do , ct_IED = Just ied , ct_SD = sd , ct_MD = maturityDate + , ct_AD = amortizationDate , ct_TD = terminationDate , ct_PRNXT = nextPrincipalRedemption , ct_PRD = purchaseDate diff --git a/marlowe-actus/test/Spec.hs b/marlowe-actus/test/Spec.hs index 3447e953896..5f304a6e93b 100644 --- a/marlowe-actus/test/Spec.hs +++ b/marlowe-actus/test/Spec.hs @@ -16,13 +16,19 @@ main = do pamTests <- testCasesFromFile ["pam25"] $ p ++ "actus-tests-pam.json" -- pam25: dates include hours, minutes, second lamTests <- testCasesFromFile ["lam18"] $ p ++ "actus-tests-lam.json" -- lam18: dates include hours, minutes, second - -- namTests <- testCasesFromFile [] $ p ++ "actus-tests-nam.json" + namTests <- testCasesFromFile [] $ p ++ "actus-tests-nam.json" + annTests <- testCasesFromFile [ + "ann09" -- ann09: currently unsupported, see also actus-core AnnuityTest.java + , "ann19" -- ann19: dates include hours, minutes, second + , "ann26" -- ann26: dates include hours, minutes, second + ] $ p ++ "actus-tests-ann.json" defaultMain $ testGroup "ACTUS Contracts" [ Spec.Marlowe.Actus.tests "PAM" pamTests , Spec.Marlowe.Actus.tests "LAM" lamTests - -- , Spec.Marlowe.Actus.tests "NAM" namTests + , Spec.Marlowe.Actus.tests "NAM" namTests + , Spec.Marlowe.Actus.tests "ANN" annTests ] testCasesFromFile :: [String] -> FilePath -> IO [TestCase] diff --git a/marlowe-actus/test/Spec/Marlowe/Actus.hs b/marlowe-actus/test/Spec/Marlowe/Actus.hs index bc285f46af6..ba5dfb5720b 100644 --- a/marlowe-actus/test/Spec/Marlowe/Actus.hs +++ b/marlowe-actus/test/Spec/Marlowe/Actus.hs @@ -7,6 +7,7 @@ where import Language.Marlowe.ACTUS.Analysis (genProjectedCashflows) import Language.Marlowe.ACTUS.Definitions.ContractTerms hiding (Assertion) +import Language.Marlowe.ACTUS.Definitions.Schedule import Spec.Marlowe.Util import Test.Tasty import Test.Tasty.HUnit @@ -20,4 +21,5 @@ runTest tc@TestCase{..} = contract = setDefaultContractTermValues testcase observed = parseObservedValues dataObserved cashFlows = genProjectedCashflows observed contract - in assertTestResults cashFlows results identifier + cashFlowsTo = maybe cashFlows (\d -> filter (\cf -> cashCalculationDay cf <= d) cashFlows) (parseDate to) + in assertTestResults cashFlowsTo results identifier diff --git a/marlowe-actus/test/Spec/Marlowe/Util.hs b/marlowe-actus/test/Spec/Marlowe/Util.hs index 718dd98aa2d..a49f4f31152 100644 --- a/marlowe-actus/test/Spec/Marlowe/Util.hs +++ b/marlowe-actus/test/Spec/Marlowe/Util.hs @@ -128,6 +128,7 @@ testToContractTerms TestCase{terms = terms} = , ct_NT = readMaybe $ Map.lookup "notionalPrincipal" terms' :: Maybe Double , ct_PDIED = readMaybe $ Map.lookup "premiumDiscountAtIED" terms' :: Maybe Double , ct_MD = parseMaybeDate $ Map.lookup "maturityDate" terms' + , ct_AD = parseMaybeDate $ Map.lookup "amortizationDate" terms' , ct_PRANX = parseMaybeDate $ Map.lookup "cycleAnchorDateOfPrincipalRedemption" terms' , ct_PRCL = parseMaybeCycle $ Map.lookup "cycleOfPrincipalRedemption" terms' , ct_PRNXT = readMaybe $ Map.lookup "nextPrincipalRedemptionPayment" terms' :: Maybe Double From ae17ca4908aced6ed3ee936c09251d8afb628180 Mon Sep 17 00:00:00 2001 From: Yves Hauser Date: Mon, 30 Aug 2021 14:56:39 +0200 Subject: [PATCH 02/28] scp 2709 - hlint suggestions --- .../src/Language/Marlowe/ACTUS/Analysis.hs | 71 +++---- .../ACTUS/Definitions/ContractTerms.hs | 175 +++++------------- .../Language/Marlowe/ACTUS/MarloweCompat.hs | 2 +- .../Model/APPLICABILITY/Applicability.hs | 8 +- .../ACTUS/Model/INIT/StateInitialization.hs | 14 +- .../ACTUS/Model/INIT/StateInitializationFs.hs | 9 +- .../Model/INIT/StateInitializationModel.hs | 43 +++-- .../Marlowe/ACTUS/Model/POF/PayoffModel.hs | 2 +- .../ACTUS/Model/SCHED/ContractSchedule.hs | 7 +- .../Model/SCHED/ContractScheduleModel.hs | 13 +- .../ACTUS/Model/STF/StateTransition.hs | 8 +- .../ACTUS/Model/STF/StateTransitionFs.hs | 14 +- .../ACTUS/Model/STF/StateTransitionModel.hs | 16 +- .../ACTUS/Model/Utility/ANN/Annuity.hs | 2 +- .../ACTUS/Model/Utility/ScheduleGenerator.hs | 4 +- .../ACTUS/Model/Utility/YearFraction.hs | 2 +- .../src/Language/Marlowe/ACTUS/Ops.hs | 4 +- .../src/Language/Marlowe/ACTUS/QCGenerator.hs | 2 +- marlowe-actus/test/Spec/Marlowe/Util.hs | 2 +- 19 files changed, 162 insertions(+), 236 deletions(-) diff --git a/marlowe-actus/src/Language/Marlowe/ACTUS/Analysis.hs b/marlowe-actus/src/Language/Marlowe/ACTUS/Analysis.hs index b2ca67a76b9..916c80cffdb 100644 --- a/marlowe-actus/src/Language/Marlowe/ACTUS/Analysis.hs +++ b/marlowe-actus/src/Language/Marlowe/ACTUS/Analysis.hs @@ -1,4 +1,5 @@ {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} module Language.Marlowe.ACTUS.Analysis(sampleCashflows, genProjectedCashflows, genZeroRiskAssertions) where import Control.Applicative @@ -28,48 +29,48 @@ import Prelude hiding (F genProjectedCashflows :: DataObserved -> ContractTerms -> [CashFlow] -genProjectedCashflows dataObserved = sampleCashflows dataObserved +genProjectedCashflows = sampleCashflows postProcessSchedule :: ContractTerms -> [(EventType, ShiftedDay)] -> [(EventType, ShiftedDay)] postProcessSchedule ct = let trim = L.dropWhile (\(_, d) -> calculationDay d < ct_SD ct) prioritised = [IED, FP, PR, PD, PY, PP, IP, IPCI, CE, RRF, RR, PRF, DV, PRD, MR, TD, SC, IPCB, MD, XD, STD, AD] + priority :: (EventType, ShiftedDay) -> Integer priority (event, _) = fromJust $ M.lookup event $ M.fromList (zip prioritised [1..]) - simillarity (_, l) (_, r) = calculationDay l == calculationDay r - regroup = L.groupBy simillarity + + similarity (_, l) (_, r) = calculationDay l == calculationDay r + regroup = L.groupBy similarity + overwrite = map (sortOn priority) . regroup in concat . (overwrite . trim) sampleCashflows :: DataObserved -> ContractTerms -> [CashFlow] -sampleCashflows dataObserved terms = +sampleCashflows dataObserved ct@ContractTerms{..} = let - eventTypes = [IED, MD, RR, RRF, IP, PR, PRF, IPCB, IPCI, PRD, TD, SC] - analysisDate = ct_SD terms + -- schedule + scheduleEvent e = maybe [] (fmap (e,)) (schedule e ct) - preserveDate e d = (e, d) - getSchedule e = fromMaybe [] $ schedule e terms - scheduleEvent e = preserveDate e <$> getSchedule e - events = sortOn (paymentDay . snd) $ concatMap scheduleEvent eventTypes - events' = postProcessSchedule terms events + -- events + eventTypes = [IED, MD, RR, RRF, IP, PR, PRF, IPCB, IPCI, PRD, TD, SC] - events'' = filterEvents terms events' + events = sortOn (paymentDay . snd) $ concatMap scheduleEvent eventTypes + events' = postProcessSchedule ct events + events'' = filterEvents ct events' + -- states applyStateTransition (st, ev, date) (ev', date') = - (stateTransition ev ((getRiskFactors dataObserved ev (calculationDay date) terms)) terms st (calculationDay date), ev', date') - calculatePayoff (st, ev, date) = - payoff ev ((getRiskFactors dataObserved ev (calculationDay date) terms)) terms st (calculationDay date) + (stateTransition ev (getRiskFactors dataObserved ev (calculationDay date) ct) ct st (calculationDay date), ev', date') - initialState = - ( inititializeState terms - , AD - , ShiftedDay analysisDate analysisDate - ) - states = L.tail $ L.scanl applyStateTransition initialState events'' + initialState = (inititializeState ct ,AD ,ShiftedDay ct_SD ct_SD) - states' = filterStates terms states + states = L.tail $ L.scanl applyStateTransition initialState events'' + states' = filterStates ct states + -- payoff + calculatePayoff (st, ev, date) = + payoff ev (getRiskFactors dataObserved ev (calculationDay date) ct) ct st (calculationDay date) payoffs = calculatePayoff <$> states' genCashflow ((_, ev, d), pff) = CashFlow @@ -91,22 +92,22 @@ filterEvents terms@ContractTerms{ contractType = contractType } events = case contractType of PAM -> if isJust (ct_TD terms) then - L.filter (\(_, (ShiftedDay{ calculationDay = calculationDay })) -> calculationDay <= fromJust (ct_TD terms)) events + L.filter (\(_, ShiftedDay{..}) -> calculationDay <= fromJust (ct_TD terms)) events else events LAM -> if isJust (ct_TD terms) then - L.filter (\(_, (ShiftedDay{ calculationDay = calculationDay })) -> calculationDay <= fromJust (ct_TD terms)) events + L.filter (\(_, ShiftedDay{..}) -> calculationDay <= fromJust (ct_TD terms)) events else events NAM -> if isJust (ct_TD terms) then - L.filter (\(_, (ShiftedDay{ calculationDay = calculationDay })) -> calculationDay <= fromJust (ct_TD terms)) events + L.filter (\(_, ShiftedDay{..}) -> calculationDay <= fromJust (ct_TD terms)) events else events ANN -> if isJust (ct_TD terms) then - L.filter (\(_, (ShiftedDay{ calculationDay = calculationDay })) -> calculationDay <= fromJust (ct_TD terms)) events + L.filter (\(_, ShiftedDay{..}) -> calculationDay <= fromJust (ct_TD terms)) events else events @@ -115,22 +116,22 @@ filterStates ct@ContractTerms{..} states = case contractType of PAM -> if isJust ct_PRD then - L.filter (\(_, _, (ShiftedDay{ calculationDay = calculationDay })) -> calculationDay >= fromJust ct_PRD) states + L.filter (\(_, _, ShiftedDay{..}) -> calculationDay >= fromJust ct_PRD) states else states LAM -> if isJust ct_PRD then - L.filter (\(_, eventType, (ShiftedDay{ calculationDay = calculationDay })) -> eventType == PRD || calculationDay > fromJust ct_PRD) states + L.filter (\(_, eventType, ShiftedDay{..}) -> eventType == PRD || calculationDay > fromJust ct_PRD) states else states NAM -> if isJust ct_PRD then - L.filter (\(_, eventType, (ShiftedDay{ calculationDay = calculationDay })) -> eventType == PRD || calculationDay > fromJust ct_PRD) states + L.filter (\(_, eventType, ShiftedDay{..}) -> eventType == PRD || calculationDay > fromJust ct_PRD) states else states ANN -> let states' = if isJust ct_PRD then - L.filter (\(_, eventType, (ShiftedDay{ calculationDay = calculationDay })) -> eventType == PRD || calculationDay > fromJust ct_PRD) states + L.filter (\(_, eventType, ShiftedDay{..}) -> eventType == PRD || calculationDay > fromJust ct_PRD) states else states in let m = ct_MD <|> ct_AD <|> maturity ct @@ -141,18 +142,18 @@ filterStates ct@ContractTerms{..} states = genZeroRiskAssertions :: ContractTerms -> Assertion -> Contract -> Contract genZeroRiskAssertions terms@ContractTerms{..} NpvAssertionAgainstZeroRiskBond{..} continue = let - cfs = genProjectedCashflows (M.empty) terms + cfs = genProjectedCashflows M.empty terms dateToYearFraction :: Day -> Double dateToYearFraction dt = _y (fromJust ct_DCC) ct_SD dt ct_MD - dateToDiscountFactor dt = (1 - zeroRiskInterest) ** (dateToYearFraction dt) + dateToDiscountFactor dt = (1 - zeroRiskInterest) ** dateToYearFraction dt - accumulateAndDiscount :: (Value Observation) -> (CashFlow, Integer) -> (Value Observation) + accumulateAndDiscount :: Value Observation -> (CashFlow, Integer) -> Value Observation accumulateAndDiscount acc (cf, t) = let discountFactor = dateToDiscountFactor $ cashCalculationDay cf - sign x = if (amount cf < 0.0) then (NegValue x) else x - in (constnt discountFactor) * (sign $ useval "payoff" t) + acc + sign x = if amount cf < 0.0 then NegValue x else x + in constnt discountFactor * (sign $ useval "payoff" t) + acc npv = foldl accumulateAndDiscount (constnt 0) (zip cfs [1..]) in Assert (ValueLT (constnt expectedNpv) npv) continue diff --git a/marlowe-actus/src/Language/Marlowe/ACTUS/Definitions/ContractTerms.hs b/marlowe-actus/src/Language/Marlowe/ACTUS/Definitions/ContractTerms.hs index d2756a25445..eeae525b8b7 100644 --- a/marlowe-actus/src/Language/Marlowe/ACTUS/Definitions/ContractTerms.hs +++ b/marlowe-actus/src/Language/Marlowe/ACTUS/Definitions/ContractTerms.hs @@ -282,133 +282,58 @@ defaultRRMLT = 1.0 infinity :: Double infinity = 1/0 :: Double +applyDefault :: a -> Maybe a -> Maybe a +applyDefault v = Just . fromMaybe v + setDefaultContractTermValues :: ContractTerms -> ContractTerms setDefaultContractTermValues ct@ContractTerms{..} = - let - ScheduleConfig{..} = scfg - - eomc' = Just $ fromMaybe EOMC_SD eomc - - bdc' = Just $ fromMaybe BDC_NULL bdc - - calendar' = Just $ fromMaybe CLDR_NC calendar - - ct_PRF' = Just $ fromMaybe PRF_PF ct_PRF - - ct_IPCB' = Just $ fromMaybe IPCB_NT ct_IPCB - - ct_SCIP' = Just $ fromMaybe defaultSCIP ct_SCIP - - ct_PDIED' = Just $ fromMaybe defaultPDIED ct_PDIED - - ct_SCNT' = Just $ fromMaybe defaultSCNT ct_SCNT - - ct_SCEF' = Just $ fromMaybe SE_000 ct_SCEF - - ct_PYRT' = Just $ fromMaybe defaultPYRT ct_PYRT - - ct_PYTP' = Just $ fromMaybe PYTP_O ct_PYTP - - ct_PPEF' = Just $ fromMaybe PPEF_N ct_PPEF - - ct_RRSP' = Just $ fromMaybe defaultRRSP ct_RRSP - - ct_RRMLT' = Just $ fromMaybe defaultRRMLT ct_RRMLT - - ct' = - case contractType of - PAM -> - ct { - ct_FEAC = Just $ fromMaybe 0.0 ct_FEAC - , ct_FER = Just $ fromMaybe 0.0 ct_FER - - , ct_IPAC = Just $ fromMaybe 0.0 ct_IPAC - , ct_IPNR = Just $ fromMaybe 0.0 ct_IPNR - - , ct_PPRD = Just $ fromMaybe 0.0 ct_PPRD - , ct_PTD = Just $ fromMaybe 0.0 ct_PTD - , ct_SCCDD = Just $ fromMaybe 0.0 ct_SCCDD - - , ct_RRPF = Just $ fromMaybe (-infinity) ct_RRPF - , ct_RRPC = Just $ fromMaybe infinity ct_RRPC - , ct_RRLC = Just $ fromMaybe infinity ct_RRLC - , ct_RRLF = Just $ fromMaybe (-infinity) ct_RRLF - } - - LAM -> - ct { - ct_FEAC = Just $ fromMaybe 0.0 ct_FEAC - , ct_FER = Just $ fromMaybe 0.0 ct_FER - - , ct_IPAC = Just $ fromMaybe 0.0 ct_IPAC - , ct_IPNR = Just $ fromMaybe 0.0 ct_IPNR - - , ct_PDIED = Just $ fromMaybe 0.0 ct_PDIED - , ct_PPRD = Just $ fromMaybe 0.0 ct_PPRD - , ct_PTD = Just $ fromMaybe 0.0 ct_PTD - , ct_SCCDD = Just $ fromMaybe 0.0 ct_SCCDD - - , ct_RRPF = Just $ fromMaybe (-infinity) ct_RRPF - , ct_RRPC = Just $ fromMaybe infinity ct_RRPC - , ct_RRLC = Just $ fromMaybe infinity ct_RRLC - , ct_RRLF = Just $ fromMaybe (-infinity) ct_RRLF - - , ct_IPCBA = Just $ fromMaybe 0.0 ct_IPCBA - } - - NAM -> - ct { - ct_FEAC = Just $ fromMaybe 0.0 ct_FEAC - , ct_FER = Just $ fromMaybe 0.0 ct_FER - - , ct_IPAC = Just $ fromMaybe 0.0 ct_IPAC - , ct_IPNR = Just $ fromMaybe 0.0 ct_IPNR - - , ct_PDIED = Just $ fromMaybe 0.0 ct_PDIED - , ct_PPRD = Just $ fromMaybe 0.0 ct_PPRD - , ct_PTD = Just $ fromMaybe 0.0 ct_PTD - , ct_SCCDD = Just $ fromMaybe 0.0 ct_SCCDD - - , ct_RRPF = Just $ fromMaybe (-infinity) ct_RRPF - , ct_RRPC = Just $ fromMaybe infinity ct_RRPC - , ct_RRLC = Just $ fromMaybe infinity ct_RRLC - , ct_RRLF = Just $ fromMaybe (-infinity) ct_RRLF - - , ct_IPCBA = Just $ fromMaybe 0.0 ct_IPCBA - } - - ANN -> - ct { - ct_FEAC = Just $ fromMaybe 0.0 ct_FEAC - , ct_FER = Just $ fromMaybe 0.0 ct_FER - - , ct_IPAC = Just $ fromMaybe 0.0 ct_IPAC - , ct_IPNR = Just $ fromMaybe 0.0 ct_IPNR - - , ct_PDIED = Just $ fromMaybe 0.0 ct_PDIED - , ct_PPRD = Just $ fromMaybe 0.0 ct_PPRD - , ct_PTD = Just $ fromMaybe 0.0 ct_PTD - , ct_SCCDD = Just $ fromMaybe 0.0 ct_SCCDD - - , ct_RRPF = Just $ fromMaybe (-infinity) ct_RRPF - , ct_RRPC = Just $ fromMaybe infinity ct_RRPC - , ct_RRLC = Just $ fromMaybe infinity ct_RRLC - , ct_RRLF = Just $ fromMaybe (-infinity) ct_RRLF - - , ct_IPCBA = Just $ fromMaybe 0.0 ct_IPCBA - } + let ScheduleConfig{..} = scfg + eomc' = applyDefault EOMC_SD eomc + bdc' = applyDefault BDC_NULL bdc + calendar' = applyDefault CLDR_NC calendar + _PRF = applyDefault PRF_PF ct_PRF + _IPCB = applyDefault IPCB_NT ct_IPCB + _PDIED = applyDefault defaultPDIED ct_PDIED + _SCEF = applyDefault SE_000 ct_SCEF + _PYRT = applyDefault defaultPYRT ct_PYRT + _PYTP = applyDefault PYTP_O ct_PYTP + _PPEF = applyDefault PPEF_N ct_PPEF + _RRSP = applyDefault defaultRRSP ct_RRSP + _RRMLT = applyDefault defaultRRMLT ct_RRMLT + _FEAC = applyDefault 0.0 ct_FEAC + _FER = applyDefault 0.0 ct_FER + _IPAC = applyDefault 0.0 ct_IPAC + _IPNR = applyDefault 0.0 ct_IPNR + _PPRD = applyDefault 0.0 ct_PPRD + _PTD = applyDefault 0.0 ct_PTD + _SCCDD = applyDefault 0.0 ct_SCCDD + _RRPF = applyDefault (-infinity) ct_RRPF + _RRPC = applyDefault infinity ct_RRPC + _RRLC = applyDefault infinity ct_RRLC + _RRLF = applyDefault (-infinity) ct_RRLF + _IPCBA = applyDefault 0.0 ct_IPCBA in - ct' { + ct { scfg = scfg { eomc = eomc', bdc = bdc', calendar = calendar' } - , ct_PRF = ct_PRF' - , ct_IPCB = ct_IPCB' - , ct_SCIP = ct_SCIP' - , ct_PDIED = ct_PDIED' - , ct_SCNT = ct_SCNT' - , ct_SCEF = ct_SCEF' - , ct_PYRT = ct_PYRT' - , ct_PYTP = ct_PYTP' - , ct_PPEF = ct_PPEF' - , ct_RRSP = ct_RRSP' - , ct_RRMLT = ct_RRMLT' + , ct_PRF = _PRF + , ct_IPCB = _IPCB + , ct_PDIED = _PDIED + , ct_SCEF = _SCEF + , ct_PYRT = _PYRT + , ct_PYTP = _PYTP + , ct_PPEF = _PPEF + , ct_RRSP = _RRSP + , ct_RRMLT = _RRMLT + , ct_FEAC = _FEAC + , ct_FER = _FER + , ct_IPAC = _IPAC + , ct_IPNR = _IPNR + , ct_PPRD = _PPRD + , ct_PTD = _PTD + , ct_SCCDD = _SCCDD + , ct_RRPF = _RRPF + , ct_RRPC = _RRPC + , ct_RRLC = _RRLC + , ct_RRLF = _RRLF + , ct_IPCBA = _IPCBA } diff --git a/marlowe-actus/src/Language/Marlowe/ACTUS/MarloweCompat.hs b/marlowe-actus/src/Language/Marlowe/ACTUS/MarloweCompat.hs index 9b8f9c5abe1..c08cac14a24 100644 --- a/marlowe-actus/src/Language/Marlowe/ACTUS/MarloweCompat.hs +++ b/marlowe-actus/src/Language/Marlowe/ACTUS/MarloweCompat.hs @@ -91,7 +91,7 @@ cardanoEpochStart = 100 dayToSlotNumber :: Day -> Integer dayToSlotNumber d = let (MkSystemTime secs _) = utcToSystemTime (UTCTime d 0) - in (fromIntegral secs) - cardanoEpochStart + in fromIntegral secs - cardanoEpochStart marloweDate :: Day -> Value Observation marloweDate = Constant . fromInteger . dayToSlotNumber diff --git a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/APPLICABILITY/Applicability.hs b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/APPLICABILITY/Applicability.hs index b1a9112ea14..bfbb433e728 100644 --- a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/APPLICABILITY/Applicability.hs +++ b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/APPLICABILITY/Applicability.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RecordWildCards #-} + module Language.Marlowe.ACTUS.Model.APPLICABILITY.Applicability where import Data.Maybe (isJust) @@ -12,7 +12,7 @@ validateTerms :: ContractTerms -> Validation [TermValidationError] ContractTerms validateTerms t = case contractType t of PAM -> - pure t <* + t <$ _NN ct_IED t "initial exchange date" <* _NN ct_DCC t "day count convention" <* _X (calendar . scfg) t "calendar" <* @@ -37,7 +37,7 @@ validateTerms t = _NN_I_1 [isJust $ ct_SCEF t, isJust $ ct_SCIED t, isJust $ ct_SCCDD t] t ["scaling effect", "scaling index at status date", "scaling index at contract deal date"] <* _X_I_1 [isJust $ ct_PYRT t, isJust $ ct_PYTP t] [isJust $ ct_PPEF t] t ["penalty rate", "penalty type"] ["prepayment effect"] LAM -> - pure t <* + t <$ _NN ct_IED t "initial exchange date" <* _NN ct_DCC t "day count convention" <* _X (calendar . scfg) t "calendar" <* @@ -64,7 +64,7 @@ validateTerms t = _NN_I_1 [isJust $ ct_SCEF t, isJust $ ct_SCIED t, isJust $ ct_SCCDD t] t ["scaling effect", "scaling index at status date", "scaling index at contract deal date"] <* _X_I_1 [isJust $ ct_PYRT t, isJust $ ct_PYTP t] [isJust $ ct_PPEF t] t ["penalty rate", "penalty type"] ["prepayment effect"] NAM -> - pure t <* + t <$ _NN ct_IED t "initial exchange date" <* _NN ct_DCC t "day count convention" <* _X (calendar . scfg) t "calendar" <* diff --git a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/INIT/StateInitialization.hs b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/INIT/StateInitialization.hs index 2a0d520150a..dc1866cc7d1 100644 --- a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/INIT/StateInitialization.hs +++ b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/INIT/StateInitialization.hs @@ -1,7 +1,7 @@ {-# LANGUAGE RecordWildCards #-} module Language.Marlowe.ACTUS.Model.INIT.StateInitialization where -import Data.Maybe (fromJust, fromMaybe, maybeToList) +import Data.Maybe (fromJust, maybeToList) import Language.Marlowe.ACTUS.Definitions.BusinessEvents (EventType (FP, IP, PR)) import Language.Marlowe.ACTUS.Definitions.ContractState (ContractState) import Language.Marlowe.ACTUS.Definitions.ContractTerms (CT (..), ContractTerms (..)) @@ -17,13 +17,15 @@ inititializeState terms@ContractTerms {..} = let t0 = ct_SD -- PAM fpSchedule = schedule FP terms - tfp_minus = fromMaybe t0 $ calculationDay <$> ((\sc -> sup sc t0) =<< fpSchedule) - tfp_plus = fromMaybe t0 $ calculationDay <$> ((\sc -> inf sc t0) =<< fpSchedule) + tfp_minus = maybe t0 calculationDay ((\sc -> sup sc t0) =<< fpSchedule) + tfp_plus = maybe t0 calculationDay ((\sc -> inf sc t0) =<< fpSchedule) ipSchedule = schedule IP terms - tminus = fromMaybe t0 $ calculationDay <$> ((\sc -> sup sc t0) =<< ipSchedule) - -- LAM, NAM + tminus = maybe t0 calculationDay ((\sc -> sup sc t0) =<< ipSchedule) + + -- LAM, NAM, ANN prSchedule = schedule PR terms - tpr_minus = fromMaybe t0 $ calculationDay <$> ((\sc -> sup sc t0) =<< prSchedule) + tpr_minus = maybe t0 calculationDay ((\sc -> sup sc t0) =<< prSchedule) + in case contractType of PAM -> _INIT_PAM t0 tminus tfp_minus tfp_plus terms LAM -> _INIT_LAM t0 tminus tpr_minus tfp_minus tfp_plus terms diff --git a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/INIT/StateInitializationFs.hs b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/INIT/StateInitializationFs.hs index 2688a4bc56c..ea9cb8d9b27 100644 --- a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/INIT/StateInitializationFs.hs +++ b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/INIT/StateInitializationFs.hs @@ -1,7 +1,6 @@ {-# LANGUAGE RecordWildCards #-} module Language.Marlowe.ACTUS.Model.INIT.StateInitializationFs where -import Data.Maybe (fromMaybe) import Language.Marlowe import Language.Marlowe.ACTUS.Definitions.BusinessEvents (EventType (FP, IP, PR)) import Language.Marlowe.ACTUS.Definitions.ContractTerms (CT (LAM, NAM, PAM), ContractTerms (..)) @@ -16,13 +15,13 @@ inititializeStateFs terms@ContractTerms {..} continue = let t0 = ct_SD -- PAM fpSchedule = schedule FP terms - tfp_minus = fromMaybe t0 $ calculationDay <$> ((\sc -> sup sc t0) =<< fpSchedule) - tfp_plus = fromMaybe t0 $ calculationDay <$> ((\sc -> inf sc t0) =<< fpSchedule) + tfp_minus = maybe t0 calculationDay ((\sc -> sup sc t0) =<< fpSchedule) + tfp_plus = maybe t0 calculationDay ((\sc -> inf sc t0) =<< fpSchedule) ipSchedule = schedule IP terms - tminus = fromMaybe t0 $ calculationDay <$> ((\sc -> sup sc t0) =<< ipSchedule) + tminus = maybe t0 calculationDay ((\sc -> sup sc t0) =<< ipSchedule) -- LAM, NAM prSchedule = schedule PR terms - tpr_minus = fromMaybe t0 $ calculationDay <$> ((\sc -> sup sc t0) =<< prSchedule) + tpr_minus = maybe t0 calculationDay ((\sc -> sup sc t0) =<< prSchedule) initialState = case contractType of PAM -> _INIT_PAM t0 tminus tfp_minus tfp_plus terms LAM -> _INIT_LAM t0 tminus tpr_minus tfp_minus tfp_plus terms diff --git a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/INIT/StateInitializationModel.hs b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/INIT/StateInitializationModel.hs index fb935cb1beb..af726e032c6 100644 --- a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/INIT/StateInitializationModel.hs +++ b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/INIT/StateInitializationModel.hs @@ -67,7 +67,7 @@ _INIT_PAM t0 tminus tfp_minus tfp_plus ipac | isNothing ct_IPNR = 0.0 | isJust ct_IPAC = r ct_CNTRL * fromJust ct_IPAC - | otherwise = (y _DCC tminus t0 ct_MD) * nt * ipnr + | otherwise = y _DCC tminus t0 ct_MD * nt * ipnr feac | isNothing ct_FER = 0.0 | isJust ct_FEAC = fromJust ct_FEAC @@ -112,16 +112,16 @@ _INIT_LAM t0 tminus _ tfp_minus tfp_plus if isJust ct_PRANX && fromJust ct_PRANX < ct_SD then let previousEvents = (\s -> _S s (fromJust ct_PRCL) ct_SD scfg ) <$> ct_PRANX - previousEvents' = L.filter(\ShiftedDay{ calculationDay = calculationDay } -> calculationDay > (minusCycle ct_SD (fromJust ct_IPCL))) (fromMaybe [] previousEvents) + previousEvents' = L.filter(\ShiftedDay{ calculationDay = calculationDay } -> calculationDay > minusCycle ct_SD (fromJust ct_IPCL)) (fromMaybe [] previousEvents) previousEvents'' = L.filter(\ShiftedDay{ calculationDay = calculationDay } -> calculationDay == ct_SD) previousEvents' ShiftedDay{ calculationDay = lastEventCalcDay } = L.head previousEvents'' in - (lastEventCalcDay, (fromJust ct_NT) / (fromJust ct_PRNXT)) + (lastEventCalcDay, fromJust ct_NT / fromJust ct_PRNXT) else -- TODO: check applicability for PRANX - (fromJust ct_PRANX, (fromJust ct_NT) / (fromJust ct_PRNXT) - 1) + (fromJust ct_PRANX, fromJust ct_NT / fromJust ct_PRNXT - 1) c@Cycle{ n = n } = fromJust ct_PRCL - maturity = plusCycle lastEvent c { n = n * (round remainingPeriods) :: Integer} + maturity = plusCycle lastEvent c { n = n * round remainingPeriods :: Integer} in applyEOMC lastEvent c (fromJust (eomc scfg)) maturity @@ -140,7 +140,7 @@ _INIT_LAM t0 tminus _ tfp_minus tfp_plus -} -- Java implementation - | otherwise = (fromJust ct_NT) / (fromIntegral (length $ fromJust ((\s -> _S s (fromJust ct_PRCL){ includeEndDay = True } tmd scfg ) <$> ct_PRANX))) + | otherwise = fromJust ct_NT / fromIntegral (length $ fromJust ((\s -> _S s (fromJust ct_PRCL){ includeEndDay = True } tmd scfg ) <$> ct_PRANX)) -- IPCB ipcb | t0 < _IED' = 0.0 @@ -169,22 +169,21 @@ _INIT_NAM t0 tminus _ tfp_minus tfp_plus | isJust ct_MD = fromJust ct_MD | otherwise = let - lastEvent = - if isJust ct_PRANX && (fromJust ct_PRANX) >= ct_SD then - fromJust ct_PRANX - else - if _IED `plusCycle` (fromJust ct_PRCL) >= ct_SD then - _IED `plusCycle` (fromJust ct_PRCL) - else - let previousEvents = (\s -> _S s (fromJust ct_PRCL) ct_SD scfg ) <$> ct_PRANX - previousEvents' = L.filter(\ShiftedDay{ calculationDay = calculationDay } -> calculationDay >= ct_SD ) (fromMaybe [] previousEvents) - previousEvents'' = L.filter(\ShiftedDay{ calculationDay = calculationDay } -> calculationDay == ct_SD) previousEvents' - ShiftedDay{ calculationDay = lastEventCalcDay } = L.head previousEvents'' - in - lastEventCalcDay - yLastEventPlusPRCL = (y _DCC lastEvent (lastEvent `plusCycle` (fromJust ct_PRCL)) ct_MD) - redemptionPerCycle = _PRNXT - (yLastEventPlusPRCL * (fromJust ct_IPNR) * (fromJust ct_NT)) - remainingPeriods = (ceiling ((fromJust ct_NT) / redemptionPerCycle)) - 1 + lastEvent + | isJust ct_PRANX && fromJust ct_PRANX >= ct_SD = + fromJust ct_PRANX + | _IED `plusCycle` fromJust ct_PRCL >= ct_SD = + _IED `plusCycle` fromJust ct_PRCL + | otherwise = + let previousEvents = (\s -> _S s (fromJust ct_PRCL) ct_SD scfg ) <$> ct_PRANX + previousEvents' = L.filter(\ShiftedDay{ calculationDay = calculationDay } -> calculationDay >= ct_SD ) (fromMaybe [] previousEvents) + previousEvents'' = L.filter(\ShiftedDay{ calculationDay = calculationDay } -> calculationDay == ct_SD) previousEvents' + ShiftedDay{ calculationDay = lastEventCalcDay } = L.head previousEvents'' + in + lastEventCalcDay + yLastEventPlusPRCL = y _DCC lastEvent (lastEvent `plusCycle` fromJust ct_PRCL) ct_MD + redemptionPerCycle = _PRNXT - (yLastEventPlusPRCL * fromJust ct_IPNR * fromJust ct_NT) + remainingPeriods = ceiling (fromJust ct_NT / redemptionPerCycle) - 1 c@Cycle{ n = n } = fromJust ct_PRCL maturity = plusCycle lastEvent c { n = n * remainingPeriods} in diff --git a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/POF/PayoffModel.hs b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/POF/PayoffModel.hs index 429e3fc6f28..12a243c2994 100644 --- a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/POF/PayoffModel.hs +++ b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/POF/PayoffModel.hs @@ -43,7 +43,7 @@ _POF_IED_LAM = _POF_IED_PAM _POF_PR_LAM :: (ActusNum a, RoleSignOps a, ActusOps a) => a -> CR -> a -> a -> a -> a _POF_PR_LAM o_rf_CURS _CNTRL nt nsc prnxt = - let redemption = prnxt - _r _CNTRL * (_max _zero ((_abs prnxt) - (_abs nt))) + let redemption = prnxt - _r _CNTRL * _max _zero (_abs prnxt - _abs nt) in o_rf_CURS * _r _CNTRL * nsc * redemption _POF_MD_LAM :: ActusNum a => a -> a -> a -> a -> a -> a -> a diff --git a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/SCHED/ContractSchedule.hs b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/SCHED/ContractSchedule.hs index 848e39b01d7..16af28445c0 100644 --- a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/SCHED/ContractSchedule.hs +++ b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/SCHED/ContractSchedule.hs @@ -3,16 +3,15 @@ module Language.Marlowe.ACTUS.Model.SCHED.ContractSchedule where import Control.Applicative (Alternative ((<|>))) -import Data.Maybe (fromJust, fromMaybe, isJust) +import Data.Maybe (fromJust, fromMaybe) import Language.Marlowe.ACTUS.Definitions.BusinessEvents (EventType (..)) import Language.Marlowe.ACTUS.Definitions.ContractState (ContractStatePoly (tmd)) -import Language.Marlowe.ACTUS.Definitions.ContractTerms (CT (..), ContractTerms (..), n) +import Language.Marlowe.ACTUS.Definitions.ContractTerms (CT (..), ContractTerms (..)) import Language.Marlowe.ACTUS.Definitions.Schedule (ShiftedDay (calculationDay)) import Language.Marlowe.ACTUS.Model.INIT.StateInitializationModel (_INIT_LAM, _INIT_NAM) import Language.Marlowe.ACTUS.Model.SCHED.ContractScheduleModel import Language.Marlowe.ACTUS.Model.Utility.ANN.Maturity (maturity) -import Language.Marlowe.ACTUS.Model.Utility.ScheduleGenerator (inf, plusCycle, sup) -import Language.Marlowe.ACTUS.Model.Utility.YearFraction (yearFraction) +import Language.Marlowe.ACTUS.Model.Utility.ScheduleGenerator (inf, sup) schedule :: EventType -> ContractTerms -> Maybe [ShiftedDay] schedule ev diff --git a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/SCHED/ContractScheduleModel.hs b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/SCHED/ContractScheduleModel.hs index 504fa2a9eb2..f670e850f47 100644 --- a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/SCHED/ContractScheduleModel.hs +++ b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/SCHED/ContractScheduleModel.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE RecordWildCards #-} {-# OPTIONS_GHC -fno-warn-missing-signatures #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} @@ -107,7 +108,7 @@ _SCHED_RRF_PAM scfg _IED _RRANX _RRCL _RRNXT _MD _SD = | otherwise = tt in if isJust _RRNXT then - fmap (\d -> [d]) (L.find (\(ShiftedDay{ calculationDay = calculationDay }) -> calculationDay > _SD) (fromMaybe [] result)) + fmap (:[]) (L.find (\ShiftedDay{..} -> calculationDay > _SD) (fromMaybe [] result)) else Nothing @@ -165,7 +166,7 @@ _SCHED_IPCB_LAM scfg _IED _IPCB _IPCBCL _IPCBANX _MD = | isNothing _IPCBANX = Just $ _IED `plusCycle` fromJust _IPCBCL | otherwise = _IPCBANX - result | (fromJust _IPCB) /= IPCB_NTL = Nothing -- This means that IPCB != 'NTL', since there is no cycle + result | fromJust _IPCB /= IPCB_NTL = Nothing -- This means that IPCB != 'NTL', since there is no cycle | otherwise = (\s -> _S s (fromJust _IPCBCL){ includeEndDay = False } _MD scfg) <$> maybeS in result @@ -214,9 +215,9 @@ _SCHED_IP_NAM scfg _IED _PRCL _PRANX _IPCED _IPANX _IPCL _MD = v = (\s -> _S s (fromJust _PRCL) _MD scfg) <$> maybeS - result = Just $ nub ((fromMaybe [] u) ++ (fromMaybe [] v)) + result = Just $ nub (fromMaybe [] u ++ fromMaybe [] v) - result' | isJust result && isJust _IPCED = Just $ filter (\ss -> (calculationDay ss) > fromJust _IPCED) $ fromJust result + result' | isJust result && isJust _IPCED = Just $ filter (\ss -> calculationDay ss > fromJust _IPCED) $ fromJust result | otherwise = result in result' @@ -239,9 +240,9 @@ _SCHED_IPCI_NAM scfg _IED _PRCL _PRANX _IPCED _IPANX _IPCL _MD = v = (\s -> _S s (fromJust _PRCL) _MD scfg) <$> maybeS - result = Just $ nub ((fromMaybe [] u) ++ (fromMaybe [] v)) + result = Just $ nub (fromMaybe [] u ++ fromMaybe [] v) - result' | isJust result && isJust _IPCED = Just $ filter (\ss -> (calculationDay ss) <= fromJust _IPCED) $ fromJust result + result' | isJust result && isJust _IPCED = Just $ filter (\ss -> calculationDay ss <= fromJust _IPCED) $ fromJust result | otherwise = Nothing in result' diff --git a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/STF/StateTransition.hs b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/STF/StateTransition.hs index bd8359a9ded..36f6ab98d0d 100644 --- a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/STF/StateTransition.hs +++ b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/STF/StateTransition.hs @@ -37,11 +37,11 @@ stateTransition ev RiskFactors{..} terms@ContractTerms{..} st@ContractStatePoly{ fpSchedule = schedule FP terms prSchedule = schedule PR terms - tfp_minus = fromMaybe t $ calculationDay <$> ((\sc -> sup sc t) =<< fpSchedule) - tfp_plus = fromMaybe t $ calculationDay <$> ((\sc -> inf sc t) =<< fpSchedule) + tfp_minus = maybe t calculationDay ((\sc -> sup sc t) =<< fpSchedule) + tfp_plus = maybe t calculationDay ((\sc -> inf sc t) =<< fpSchedule) - tpr_minus = fromMaybe t $ calculationDay <$> ((\sc -> sup sc t) =<< prSchedule) - tpr_plus = fromMaybe t $ calculationDay <$> ((\sc -> inf sc t) =<< prSchedule) + tpr_minus = maybe t calculationDay ((\sc -> sup sc t) =<< prSchedule) + tpr_plus = maybe t calculationDay ((\sc -> inf sc t) =<< prSchedule) y_sd_t = _y ct_DCC' sd t ct_MD y_tfpminus_t = _y ct_DCC' tfp_minus t ct_MD diff --git a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/STF/StateTransitionFs.hs b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/STF/StateTransitionFs.hs index 9bd228f0642..e643e2612c4 100644 --- a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/STF/StateTransitionFs.hs +++ b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/STF/StateTransitionFs.hs @@ -27,7 +27,7 @@ stateTransitionFs ev terms@ContractTerms{..} t prevDate curDate continue = __IPNR = constnt <$> ct_IPNR __IPAC = constnt <$> ct_IPAC __NT = constnt (fromJust ct_NT) - __FEB = enum (ct_FEB) + __FEB = enum ct_FEB __FER = constnt (fromJust ct_FER) __IPCB = enum <$> ct_IPCB __IPCBA = constnt <$> ct_IPCBA @@ -46,10 +46,10 @@ stateTransitionFs ev terms@ContractTerms{..} t prevDate curDate continue = __pp_payoff = useval "pp_payoff" t -- dates: - time = marloweDate $ curDate + time = marloweDate curDate fpSchedule = schedule FP terms - tfp_minus = fromMaybe curDate $ calculationDay <$> ((\sc -> sup sc curDate) =<< fpSchedule) - tfp_plus = fromMaybe curDate $ calculationDay <$> ((\sc -> inf sc curDate) =<< fpSchedule) + tfp_minus = maybe curDate calculationDay ((\sc -> sup sc curDate) =<< fpSchedule) + tfp_plus = maybe curDate calculationDay ((\sc -> inf sc curDate) =<< fpSchedule) y_tfpminus_t = constnt $ _y (fromJust ct_DCC) tfp_minus curDate ct_MD y_tfpminus_tfpplus = constnt $ _y (fromJust ct_DCC) tfp_minus tfp_plus ct_MD y_ipanx_t = constnt $ _y (fromJust ct_DCC) (fromJust ct_IPANX) curDate ct_MD @@ -58,9 +58,9 @@ stateTransitionFs ev terms@ContractTerms{..} t prevDate curDate continue = addComment cont = case ev of IED -> letval "IED" t (constnt 0) cont MD -> letval "MD" t (constnt 0) cont - IP -> letval ("IP:" ++ (show curDate) ++ (show prevDate)) t (constnt 0) cont - RR -> letval ("RR:" ++ (show curDate)) t (constnt 0) cont - FP -> letval ("FP:" ++ (show curDate)) t (constnt 0) cont + IP -> letval ("IP:" ++ show curDate ++ show prevDate) t (constnt 0) cont + RR -> letval ("RR:" ++ show curDate) t (constnt 0) cont + FP -> letval ("FP:" ++ show curDate) t (constnt 0) cont _ -> cont in case contractType of PAM -> diff --git a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/STF/StateTransitionModel.hs b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/STF/StateTransitionModel.hs index a7abe6a1657..741c96f443a 100644 --- a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/STF/StateTransitionModel.hs +++ b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/STF/StateTransitionModel.hs @@ -50,7 +50,7 @@ _STF_PY_PAM st@ContractStatePoly{..} t y_sd_t y_tfpminus_t y_tfpminus_tfpplus _F feac' = case _FEB of Just FEB_N -> feac + y_sd_t * nt * _FER - _ -> (_max _zero (y_tfpminus_t / y_tfpminus_tfpplus)) * _r _CNTRL * _FER + _ -> _max _zero (y_tfpminus_t / y_tfpminus_tfpplus) * _r _CNTRL * _FER in st {ipac = ipac', feac = feac', sd = t} @@ -102,7 +102,7 @@ _STF_RR_PAM st@ContractStatePoly{..} t y_sd_t y_tfpminus_t y_tfpminus_tfpplus _F delta_r = _min (_max (o_rf_RRMO * _RRMLT + _RRSP - ipnr) _RRPF) _RRPC - ipnr' = (_min (_max (ipnr + delta_r) _RRLF) _RRLC) + ipnr' = _min (_max (ipnr + delta_r) _RRLF) _RRLC in st' {ipac = ipac', feac = feac', ipnr = ipnr', sd = t} _STF_RRF_PAM :: (ActusOps a, RoleSignOps a, ActusNum a) => ContractStatePoly a b -> b -> a -> a -> a -> Maybe FEB -> a -> CR -> Maybe a -> ContractStatePoly a b @@ -143,8 +143,8 @@ _STF_IED_LAM st t y_ipanx_t _IPNR _IPANX _CNTRL _IPAC _NT _IPCB _IPCBA = nt' = _r _CNTRL * _NT ipnr' = fromJust _IPNR - ipcb' | (fromJust _IPCB) == IPCB_NT = nt' - | otherwise = _r _CNTRL * (fromJust _IPCBA) + ipcb' | fromJust _IPCB == IPCB_NT = nt' + | otherwise = _r _CNTRL * fromJust _IPCBA ipac' | isJust _IPAC = _r _CNTRL * fromJust _IPAC {- @@ -158,14 +158,14 @@ _STF_IED_LAM st t y_ipanx_t _IPNR _IPANX _CNTRL _IPAC _NT _IPCB _IPCBA = _STF_PR_LAM :: (ActusNum a, ActusOps a, RoleSignOps a) => ContractStatePoly a b -> b -> a -> a -> a -> Maybe FEB -> a -> CR -> Maybe IPCB -> ContractStatePoly a b _STF_PR_LAM st@ContractStatePoly{..} t y_sd_t _ _ _FEB _FER _CNTRL _IPCB = let - nt' = nt - _r _CNTRL * (prnxt - _r _CNTRL * (_max _zero ((_abs prnxt) - (_abs nt)))) + nt' = nt - _r _CNTRL * (prnxt - _r _CNTRL * _max _zero (_abs prnxt - _abs nt)) -- feac' = case _FEB of -- Just FEB_N -> feac + y_sd_t * nt * _FER -- _ -> (_max _zero (y_tfpminus_t / y_tfpminus_tfpplus)) * _r _CNTRL * _FER feac' = feac + y_sd_t * nt * _FER - ipcb' = case (fromJust _IPCB) of + ipcb' = case fromJust _IPCB of IPCB_NTL -> ipcb _ -> nt' @@ -288,11 +288,11 @@ _STF_PR_NAM st@ContractStatePoly{..} t _ y_sd_t y_tfpminus_t y_tfpminus_tfpplus let st'@ContractStatePoly{ ipac = ipac' } = _STF_PR_LAM st t y_sd_t y_tfpminus_t y_tfpminus_tfpplus _FEB _FER _CNTRL _IPCB ra = prnxt - _r _CNTRL * ipac' - r = ra - (_max _zero (ra - (_abs nt))) + r = ra - _max _zero (ra - _abs nt) nt' = nt - _r _CNTRL * r -- ACTUS implementation - ipcb' = case (fromJust _IPCB) of + ipcb' = case fromJust _IPCB of IPCB_NT -> nt' _ -> ipcb diff --git a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/Utility/ANN/Annuity.hs b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/Utility/ANN/Annuity.hs index 4661db28f0b..3c5523d868e 100644 --- a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/Utility/ANN/Annuity.hs +++ b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/Utility/ANN/Annuity.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RecordWildCards #-} + module Language.Marlowe.ACTUS.Model.Utility.ANN.Annuity (annuity) where diff --git a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/Utility/ScheduleGenerator.hs b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/Utility/ScheduleGenerator.hs index f30117fbb35..99e8175aa8d 100644 --- a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/Utility/ScheduleGenerator.hs +++ b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/Utility/ScheduleGenerator.hs @@ -90,10 +90,10 @@ generateRecurrentSchedule Cycle {..} anchorDate endDate = generateRecurrentScheduleWithCorrections :: Day -> Cycle -> Day -> ScheduleConfig -> ShiftedSchedule generateRecurrentScheduleWithCorrections anchorDate cycle endDate ScheduleConfig {..} = generateRecurrentSchedule cycle anchorDate endDate & - ((correction cycle anchorDate endDate) >>> + (correction cycle anchorDate endDate >>> (fmap $ applyEOMC anchorDate cycle (fromJust eomc)) >>> (fmap $ applyBDC (fromJust bdc) (fromJust calendar)) >>> - (addEndDay (includeEndDay cycle) endDate)) + addEndDay (includeEndDay cycle) endDate) plusCycle :: Day -> Cycle -> Day plusCycle date cycle = shiftDate date (n cycle) (p cycle) diff --git a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/Utility/YearFraction.hs b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/Utility/YearFraction.hs index f7b1ee56994..519f3ffdcf2 100644 --- a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/Utility/YearFraction.hs +++ b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/Utility/YearFraction.hs @@ -23,7 +23,7 @@ yearFraction DCC_A_AISDA startDay endDay _ secondFractionDays = fromIntegral (diffDays endDay d2YearLastDay) in (firstFractionDays / d1YearFraction) - + (secondFractionDays / d2YearFraction) + (fromIntegral d2Year) - (fromIntegral d1Year) - 1 + + (secondFractionDays / d2YearFraction) + fromIntegral d2Year - fromIntegral d1Year - 1 | otherwise = 0.0 diff --git a/marlowe-actus/src/Language/Marlowe/ACTUS/Ops.hs b/marlowe-actus/src/Language/Marlowe/ACTUS/Ops.hs index 0a30d3a9afe..17e95c457aa 100644 --- a/marlowe-actus/src/Language/Marlowe/ACTUS/Ops.hs +++ b/marlowe-actus/src/Language/Marlowe/ACTUS/Ops.hs @@ -81,7 +81,7 @@ instance ActusNum (Value Observation) where (+) = AddValue (-) = SubValue a * b = Scale (1 % marloweFixedPoint) $ MulValue a b - (Constant 0) / (Constant 0) = (Constant 0) -- by convention in finance + (Constant 0) / (Constant 0) = Constant 0 -- by convention in finance (Constant x) / (Constant y) = Scale (marloweFixedPoint % 1) $ Constant $ div x y - x / (Constant y) = Scale (marloweFixedPoint % y) $ x + x / (Constant y) = Scale (marloweFixedPoint % y) x _ / _ = undefined --division not supported in Marlowe yet diff --git a/marlowe-actus/src/Language/Marlowe/ACTUS/QCGenerator.hs b/marlowe-actus/src/Language/Marlowe/ACTUS/QCGenerator.hs index 38a9df70164..da4c22c5f5f 100644 --- a/marlowe-actus/src/Language/Marlowe/ACTUS/QCGenerator.hs +++ b/marlowe-actus/src/Language/Marlowe/ACTUS/QCGenerator.hs @@ -215,7 +215,7 @@ riskAtTGen = RiskFactors <$> percentage <*> percentage <*> percentage <*> smalla riskFactorsGen :: ContractTerms -> Gen (M.Map Day RiskFactors) riskFactorsGen ct = do - let days = cashCalculationDay <$> genProjectedCashflows (M.empty) ct + let days = cashCalculationDay <$> genProjectedCashflows M.empty ct rf <- vectorOf (L.length days) riskAtTGen return $ M.fromList $ L.zip days rf diff --git a/marlowe-actus/test/Spec/Marlowe/Util.hs b/marlowe-actus/test/Spec/Marlowe/Util.hs index a49f4f31152..deb5b94c05a 100644 --- a/marlowe-actus/test/Spec/Marlowe/Util.hs +++ b/marlowe-actus/test/Spec/Marlowe/Util.hs @@ -3,7 +3,7 @@ {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} + {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} From 12837aa052baa50cd1de580c579722090ca52a44 Mon Sep 17 00:00:00 2001 From: Yves Hauser Date: Mon, 30 Aug 2021 15:25:09 +0200 Subject: [PATCH 03/28] scp-2708 - Removed ACTUS function aliases --- .../Marlowe/ACTUS/Model/POF/Payoff.hs | 26 +++---- .../Marlowe/ACTUS/Model/POF/PayoffFs.hs | 26 +++---- .../Marlowe/ACTUS/Model/POF/PayoffModel.hs | 39 ---------- .../ACTUS/Model/SCHED/ContractSchedule.hs | 46 ++++++------ .../Model/SCHED/ContractScheduleModel.hs | 72 ++----------------- .../ACTUS/Model/STF/StateTransition.hs | 39 +++++----- .../ACTUS/Model/STF/StateTransitionFs.hs | 38 +++++----- .../ACTUS/Model/STF/StateTransitionModel.hs | 59 +-------------- 8 files changed, 97 insertions(+), 248 deletions(-) diff --git a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/POF/Payoff.hs b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/POF/Payoff.hs index 5c2cb351bea..3bb1b4d3a04 100644 --- a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/POF/Payoff.hs +++ b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/POF/Payoff.hs @@ -30,27 +30,27 @@ payoff ev RiskFactors{..} ContractTerms{..} ContractStatePoly {..} t = _ -> 0.0 LAM -> case ev of - IED -> _POF_IED_LAM o_rf_CURS ct_CNTRL (fromJust ct_NT) (fromJust ct_PDIED) + IED -> _POF_IED_PAM o_rf_CURS ct_CNTRL (fromJust ct_NT) (fromJust ct_PDIED) PR -> _POF_PR_LAM o_rf_CURS ct_CNTRL nt nsc prnxt - MD -> _POF_MD_LAM o_rf_CURS nsc nt isc ipac feac - PP -> _POF_PP_LAM o_rf_CURS pp_payoff - PY -> _POF_PY_LAM (fromJust ct_PYTP) o_rf_CURS o_rf_RRMO (fromJust ct_PYRT) ct_cPYRT ct_CNTRL nt ipnr y_sd_t - FP -> _POF_FP_LAM (fromJust ct_FEB) (fromJust ct_FER) o_rf_CURS ct_CNTRL nt feac y_sd_t + MD -> _POF_MD_PAM o_rf_CURS nsc nt isc ipac feac + PP -> _POF_PP_PAM o_rf_CURS pp_payoff + PY -> _POF_PY_PAM (fromJust ct_PYTP) o_rf_CURS o_rf_RRMO (fromJust ct_PYRT) ct_cPYRT ct_CNTRL nt ipnr y_sd_t + FP -> _POF_FP_PAM (fromJust ct_FEB) (fromJust ct_FER) o_rf_CURS ct_CNTRL nt feac y_sd_t PRD -> _POF_PRD_LAM o_rf_CURS ct_CNTRL (fromJust ct_PPRD) ipac ipnr ipcb y_sd_t TD -> _POF_TD_LAM o_rf_CURS ct_CNTRL (fromJust ct_PTD) ipac ipnr ipcb y_sd_t IP -> _POF_IP_LAM o_rf_CURS isc ipac ipnr ipcb y_sd_t _ -> 0.0 NAM -> case ev of - IED -> _POF_IED_NAM o_rf_CURS ct_CNTRL (fromJust ct_NT) (fromJust ct_PDIED) + IED -> _POF_IED_PAM o_rf_CURS ct_CNTRL (fromJust ct_NT) (fromJust ct_PDIED) PR -> _POF_PR_NAM o_rf_CURS ct_CNTRL nsc prnxt ipac y_sd_t ipnr ipcb nt - MD -> _POF_MD_NAM o_rf_CURS nsc nt isc ipac feac - PP -> _POF_PP_NAM o_rf_CURS pp_payoff - PY -> _POF_PY_NAM (fromJust ct_PYTP) o_rf_CURS o_rf_RRMO (fromJust ct_PYRT) ct_cPYRT ct_CNTRL nt ipnr y_sd_t - FP -> _POF_FP_NAM (fromJust ct_FEB) (fromJust ct_FER) o_rf_CURS ct_CNTRL nt feac y_sd_t - PRD -> _POF_PRD_NAM o_rf_CURS ct_CNTRL (fromJust ct_PPRD) ipac ipnr ipcb y_sd_t - TD -> _POF_TD_NAM o_rf_CURS ct_CNTRL (fromJust ct_PTD) ipac ipnr ipcb y_sd_t - IP -> _POF_IP_NAM o_rf_CURS isc ipac ipnr ipcb y_sd_t + MD -> _POF_MD_PAM o_rf_CURS nsc nt isc ipac feac + PP -> _POF_PP_PAM o_rf_CURS pp_payoff + PY -> _POF_PY_PAM (fromJust ct_PYTP) o_rf_CURS o_rf_RRMO (fromJust ct_PYRT) ct_cPYRT ct_CNTRL nt ipnr y_sd_t + FP -> _POF_FP_PAM (fromJust ct_FEB) (fromJust ct_FER) o_rf_CURS ct_CNTRL nt feac y_sd_t + PRD -> _POF_PRD_LAM o_rf_CURS ct_CNTRL (fromJust ct_PPRD) ipac ipnr ipcb y_sd_t + TD -> _POF_TD_LAM o_rf_CURS ct_CNTRL (fromJust ct_PTD) ipac ipnr ipcb y_sd_t + IP -> _POF_IP_LAM o_rf_CURS isc ipac ipnr ipcb y_sd_t _ -> 0.0 ANN -> case ev of diff --git a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/POF/PayoffFs.hs b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/POF/PayoffFs.hs index c1eb849a047..5d31052183c 100644 --- a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/POF/PayoffFs.hs +++ b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/POF/PayoffFs.hs @@ -50,25 +50,25 @@ payoffFs ev ContractTerms{..} t t_minus prevDate curDate = IP -> Just $ _POF_IP_PAM __o_rf_CURS __isc __ipac __ipnr __nt y_sd_t _ -> Nothing LAM -> case ev of - IED -> Just $ _POF_IED_LAM __o_rf_CURS ct_CNTRL __NT __PDIED + IED -> Just $ _POF_IED_PAM __o_rf_CURS ct_CNTRL __NT __PDIED PR -> Just $ _POF_PR_LAM __o_rf_CURS ct_CNTRL __nt __nsc __prnxt - MD -> Just $ _POF_MD_LAM __o_rf_CURS __nsc __nt __isc __ipac __feac - PP -> Just $ _POF_PP_LAM __o_rf_CURS __pp_payoff - PY -> Just $ _POF_PY_LAM __PYTP __o_rf_CURS __o_rf_RRMO __PYRT __cPYRT ct_CNTRL __nt __ipnr y_sd_t - FP -> Just $ _POF_FP_LAM __FEB __FER __o_rf_CURS ct_CNTRL __nt __feac y_sd_t + MD -> Just $ _POF_MD_PAM __o_rf_CURS __nsc __nt __isc __ipac __feac + PP -> Just $ _POF_PP_PAM __o_rf_CURS __pp_payoff + PY -> Just $ _POF_PY_PAM __PYTP __o_rf_CURS __o_rf_RRMO __PYRT __cPYRT ct_CNTRL __nt __ipnr y_sd_t + FP -> Just $ _POF_FP_PAM __FEB __FER __o_rf_CURS ct_CNTRL __nt __feac y_sd_t PRD -> Just $ _POF_PRD_LAM __o_rf_CURS ct_CNTRL __PPRD __ipac __ipnr __ipcb y_sd_t TD -> Just $ _POF_TD_LAM __o_rf_CURS ct_CNTRL __PTD __ipac __ipnr __ipcb y_sd_t IP -> Just $ _POF_IP_LAM __o_rf_CURS __isc __ipac __ipnr __ipcb y_sd_t _ -> Nothing NAM -> case ev of - IED -> Just $ _POF_IED_NAM __o_rf_CURS ct_CNTRL __NT __PDIED + IED -> Just $ _POF_IED_PAM __o_rf_CURS ct_CNTRL __NT __PDIED PR -> Just $ _POF_PR_NAM __o_rf_CURS ct_CNTRL __nsc __prnxt __ipac y_sd_t __ipnr __ipcb __nt - MD -> Just $ _POF_MD_NAM __o_rf_CURS __nsc __nt __isc __ipac __feac - PP -> Just $ _POF_PP_NAM __o_rf_CURS __pp_payoff - PY -> Just $ _POF_PY_NAM __PYTP __o_rf_CURS __o_rf_RRMO __PYRT __cPYRT ct_CNTRL __nt __ipnr y_sd_t - FP -> Just $ _POF_FP_NAM __FEB __FER __o_rf_CURS ct_CNTRL __nt __feac y_sd_t - PRD -> Just $ _POF_PRD_NAM __o_rf_CURS ct_CNTRL __PPRD __ipac __ipnr __ipcb y_sd_t - TD -> Just $ _POF_TD_NAM __o_rf_CURS ct_CNTRL __PTD __ipac __ipnr __ipcb y_sd_t - IP -> Just $ _POF_IP_NAM __o_rf_CURS __isc __ipac __ipnr __ipcb y_sd_t + MD -> Just $ _POF_MD_PAM __o_rf_CURS __nsc __nt __isc __ipac __feac + PP -> Just $ _POF_PP_PAM __o_rf_CURS __pp_payoff + PY -> Just $ _POF_PY_PAM __PYTP __o_rf_CURS __o_rf_RRMO __PYRT __cPYRT ct_CNTRL __nt __ipnr y_sd_t + FP -> Just $ _POF_FP_PAM __FEB __FER __o_rf_CURS ct_CNTRL __nt __feac y_sd_t + PRD -> Just $ _POF_PRD_LAM __o_rf_CURS ct_CNTRL __PPRD __ipac __ipnr __ipcb y_sd_t + TD -> Just $ _POF_TD_LAM __o_rf_CURS ct_CNTRL __PTD __ipac __ipnr __ipcb y_sd_t + IP -> Just $ _POF_IP_LAM __o_rf_CURS __isc __ipac __ipnr __ipcb y_sd_t _ -> Nothing in (\x -> x / (constnt $ fromIntegral marloweFixedPoint)) <$> pof diff --git a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/POF/PayoffModel.hs b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/POF/PayoffModel.hs index 12a243c2994..081a7149b42 100644 --- a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/POF/PayoffModel.hs +++ b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/POF/PayoffModel.hs @@ -38,26 +38,11 @@ _POF_IP_PAM o_rf_CURS isc ipac ipnr nt y_sd_t = o_rf_CURS * isc * (ipac + y_sd_t -- Linear Amortizer (LAM) -_POF_IED_LAM :: (ActusNum a, ActusOps a, RoleSignOps a) => a -> CR -> a -> a -> a -_POF_IED_LAM = _POF_IED_PAM - _POF_PR_LAM :: (ActusNum a, RoleSignOps a, ActusOps a) => a -> CR -> a -> a -> a -> a _POF_PR_LAM o_rf_CURS _CNTRL nt nsc prnxt = let redemption = prnxt - _r _CNTRL * _max _zero (_abs prnxt - _abs nt) in o_rf_CURS * _r _CNTRL * nsc * redemption -_POF_MD_LAM :: ActusNum a => a -> a -> a -> a -> a -> a -> a -_POF_MD_LAM = _POF_MD_PAM - -_POF_PP_LAM :: ActusNum a => a -> a -> a -_POF_PP_LAM = _POF_PP_PAM - -_POF_PY_LAM :: (ActusOps a, ActusNum a, RoleSignOps a) => PYTP -> a -> a -> a -> a -> CR -> a -> a -> a -> a -_POF_PY_LAM = _POF_PY_PAM - -_POF_FP_LAM :: (RoleSignOps a, ActusNum a) => FEB -> a -> a -> CR -> a -> a -> a -> a -_POF_FP_LAM = _POF_FP_PAM - _POF_PRD_LAM :: (ActusNum a, ActusOps a, RoleSignOps a) => a -> CR -> a -> a -> a -> a -> a -> a _POF_PRD_LAM o_rf_CURS _CNTRL _PPRD ipac ipnr ipcb y_sd_t = _zero - o_rf_CURS * _r _CNTRL * (_PPRD + ipac + y_sd_t * ipnr * ipcb) @@ -69,32 +54,8 @@ _POF_IP_LAM o_rf_CURS isc ipac ipnr ipcb y_sd_t = o_rf_CURS * isc * (ipac + y_sd -- Negative Amortizer (NAM) -_POF_IED_NAM :: (ActusNum a, ActusOps a, RoleSignOps a) => a -> CR -> a -> a -> a -_POF_IED_NAM = _POF_IED_PAM - _POF_PR_NAM :: (RoleSignOps a, ActusNum a, ActusOps a) => a -> CR -> a -> a -> a -> a -> a -> a -> a -> a _POF_PR_NAM o_rf_CURS _CNTRL nsc prnxt ipac y_sd_t ipnr ipcb nt = let ra = prnxt - _r _CNTRL * (ipac + y_sd_t * ipnr * ipcb) r = ra - _max _zero (ra - _abs nt) in o_rf_CURS * _r _CNTRL * nsc * r - -_POF_MD_NAM :: ActusNum a => a -> a -> a -> a -> a -> a -> a -_POF_MD_NAM = _POF_MD_PAM - -_POF_PP_NAM :: ActusNum a => a -> a -> a -_POF_PP_NAM = _POF_PP_PAM - -_POF_PY_NAM :: (ActusOps a, ActusNum a, RoleSignOps a) => PYTP -> a -> a -> a -> a -> CR -> a -> a -> a -> a -_POF_PY_NAM = _POF_PY_PAM - -_POF_FP_NAM :: (RoleSignOps a, ActusNum a) => FEB -> a -> a -> CR -> a -> a -> a -> a -_POF_FP_NAM = _POF_FP_PAM - -_POF_PRD_NAM :: (ActusNum a, ActusOps a, RoleSignOps a) => a -> CR -> a -> a -> a -> a -> a -> a -_POF_PRD_NAM = _POF_PRD_LAM - -_POF_TD_NAM :: (ActusNum a, RoleSignOps a) => a -> CR -> a -> a -> a -> a -> a -> a -_POF_TD_NAM = _POF_TD_LAM - -_POF_IP_NAM :: ActusNum a => a -> a -> a -> a -> a -> a -> a -_POF_IP_NAM = _POF_IP_LAM diff --git a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/SCHED/ContractSchedule.hs b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/SCHED/ContractSchedule.hs index 16af28445c0..9515cd4c719 100644 --- a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/SCHED/ContractSchedule.hs +++ b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/SCHED/ContractSchedule.hs @@ -62,20 +62,20 @@ schedule ev tpr_minus = maybe t0 calculationDay ((\sc -> sup sc t0) =<< prSchedule) _tmd = tmd $ _INIT_LAM ct_SD tminus tpr_minus tfp_minus tfp_plus ct in case ev of - IED -> _SCHED_IED_LAM scfg ct_IED' + IED -> _SCHED_IED_PAM scfg ct_IED' PR -> _SCHED_PR_LAM scfg ct_PRCL ct_IED' ct_PRANX _tmd MD -> _SCHED_MD_LAM scfg _tmd - PP -> _SCHED_PP_LAM scfg ct_PPEF' ct_OPCL ct_IED' ct_OPANX _tmd - PY -> _SCHED_PY_LAM scfg ct_PYTP' ct_PPEF' ct_OPCL ct_IED' ct_OPANX _tmd - FP -> _SCHED_FP_LAM scfg ct_FER' ct_FECL ct_IED' ct_FEANX _tmd - PRD -> _SCHED_PRD_LAM scfg ct_PRD - TD -> _SCHED_TD_LAM scfg ct_TD - IP -> _SCHED_IP_LAM scfg ct_IPNR ct_IED' ct_IPANX ct_IPCL ct_IPCED _tmd - IPCI -> _SCHED_IPCI_LAM scfg ct_IED' ct_IPANX ct_IPCL ct_IPCED _tmd ct_IPNR + PP -> _SCHED_PP_PAM scfg ct_PPEF' ct_OPCL ct_IED' ct_OPANX _tmd + PY -> _SCHED_PY_PAM scfg ct_PYTP' ct_PPEF' ct_OPCL ct_IED' ct_OPANX _tmd + FP -> _SCHED_FP_PAM scfg ct_FER' ct_FECL ct_IED' ct_FEANX _tmd + PRD -> _SCHED_PRD_PAM scfg ct_PRD + TD -> _SCHED_TD_PAM scfg ct_TD + IP -> _SCHED_IP_PAM scfg ct_IPNR ct_IED' ct_IPANX ct_IPCL ct_IPCED _tmd + IPCI -> _SCHED_IPCI_PAM scfg ct_IED' ct_IPANX ct_IPCL ct_IPCED _tmd ct_IPNR IPCB -> _SCHED_IPCB_LAM scfg ct_IED' ct_IPCB ct_IPCBCL ct_IPCBANX _tmd - RR -> _SCHED_RR_LAM scfg ct_IED' ct_SD ct_RRANX ct_RRCL ct_RRNXT _tmd - RRF -> _SCHED_RRF_LAM scfg ct_IED' ct_RRANX ct_RRCL ct_RRNXT _tmd ct_SD - SC -> _SCHED_SC_LAM scfg ct_IED' ct_SCEF' ct_SCANX ct_SCCL _tmd + RR -> _SCHED_RR_PAM scfg ct_IED' ct_SD ct_RRANX ct_RRCL ct_RRNXT _tmd + RRF -> _SCHED_RRF_PAM scfg ct_IED' ct_RRANX ct_RRCL ct_RRNXT _tmd ct_SD + SC -> _SCHED_SC_PAM scfg ct_IED' ct_SCEF' ct_SCANX ct_SCCL _tmd _ -> Nothing NAM -> -- Same as LAM - need to calculate Tmd0 @@ -91,20 +91,20 @@ schedule ev tpr_minus = maybe t0 calculationDay ((\sc -> sup sc t0) =<< prSchedule) _tmd = tmd $ _INIT_NAM ct_SD tminus tpr_minus tfp_minus tfp_plus ct in case ev of - IED -> _SCHED_IED_NAM scfg ct_IED' - PR -> _SCHED_PR_NAM scfg ct_PRCL ct_IED' ct_PRANX _tmd - MD -> _SCHED_MD_NAM scfg _tmd - PP -> _SCHED_PP_NAM scfg ct_PPEF' ct_OPCL ct_IED' ct_OPANX _tmd - PY -> _SCHED_PY_NAM scfg ct_PYTP' ct_PPEF' ct_OPCL ct_IED' ct_OPANX _tmd - FP -> _SCHED_FP_NAM scfg ct_FER' ct_FECL ct_IED' ct_FEANX _tmd - PRD -> _SCHED_PRD_NAM scfg ct_PRD - TD -> _SCHED_TD_NAM scfg ct_TD + IED -> _SCHED_IED_PAM scfg ct_IED' + PR -> _SCHED_PR_LAM scfg ct_PRCL ct_IED' ct_PRANX _tmd + MD -> _SCHED_MD_PAM scfg _tmd + PP -> _SCHED_PP_PAM scfg ct_PPEF' ct_OPCL ct_IED' ct_OPANX _tmd + PY -> _SCHED_PY_PAM scfg ct_PYTP' ct_PPEF' ct_OPCL ct_IED' ct_OPANX _tmd + FP -> _SCHED_FP_PAM scfg ct_FER' ct_FECL ct_IED' ct_FEANX _tmd + PRD -> _SCHED_PRD_PAM scfg ct_PRD + TD -> _SCHED_TD_PAM scfg ct_TD IP -> _SCHED_IP_NAM scfg ct_IED' ct_PRCL ct_PRANX ct_IPCED ct_IPANX ct_IPCL _tmd IPCI -> _SCHED_IPCI_NAM scfg ct_IED' ct_PRCL ct_PRANX ct_IPCED ct_IPANX ct_IPCL _tmd - IPCB -> _SCHED_IPCB_NAM scfg ct_IED' ct_IPCB ct_IPCBCL ct_IPCBANX _tmd - RR -> _SCHED_RR_NAM scfg ct_IED' ct_SD ct_RRANX ct_RRCL ct_RRNXT _tmd - RRF -> _SCHED_RRF_NAM scfg ct_IED' ct_RRANX ct_RRCL ct_RRNXT _tmd ct_SD - SC -> _SCHED_SC_NAM scfg ct_IED' ct_SCEF' ct_SCANX ct_SCCL _tmd + IPCB -> _SCHED_IPCB_LAM scfg ct_IED' ct_IPCB ct_IPCBCL ct_IPCBANX _tmd + RR -> _SCHED_RR_PAM scfg ct_IED' ct_SD ct_RRANX ct_RRCL ct_RRNXT _tmd + RRF -> _SCHED_RRF_PAM scfg ct_IED' ct_RRANX ct_RRCL ct_RRNXT _tmd ct_SD + SC -> _SCHED_SC_PAM scfg ct_IED' ct_SCEF' ct_SCANX ct_SCCL _tmd _ -> Nothing ANN -> diff --git a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/SCHED/ContractScheduleModel.hs b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/SCHED/ContractScheduleModel.hs index f670e850f47..f4c295daa30 100644 --- a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/SCHED/ContractScheduleModel.hs +++ b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/SCHED/ContractScheduleModel.hs @@ -1,7 +1,4 @@ {-# LANGUAGE RecordWildCards #-} -{-# OPTIONS_GHC -fno-warn-missing-signatures #-} -{-# OPTIONS_GHC -fno-warn-name-shadowing #-} - module Language.Marlowe.ACTUS.Model.SCHED.ContractScheduleModel where import Data.List as L (find, nub) @@ -14,13 +11,14 @@ import Language.Marlowe.ACTUS.Definitions.Schedule (Shifted import Language.Marlowe.ACTUS.Model.Utility.DateShift (applyBDCWithCfg) import Language.Marlowe.ACTUS.Model.Utility.ScheduleGenerator (generateRecurrentScheduleWithCorrections, inf, minusCycle, plusCycle, remove) --- Principal at Maturity _S :: Day -> Cycle -> Day -> ScheduleConfig -> ShiftedSchedule _S = generateRecurrentScheduleWithCorrections shift :: ScheduleConfig -> Day -> ShiftedDay shift = applyBDCWithCfg +-- Principal at Maturity (PAM) + _SCHED_IED_PAM :: ScheduleConfig -> Day -> Maybe [ShiftedDay] _SCHED_IED_PAM scfg _IED = Just [shift scfg _IED] @@ -98,6 +96,7 @@ _SCHED_RR_PAM scfg _IED _SD _RRANX _RRCL _RRNXT _MD = in result -- ACTUS techspec implementation +_SCHED_RRF_PAM :: ScheduleConfig -> Day -> Maybe Day -> Maybe Cycle -> Maybe a -> Day -> Day -> Maybe [ShiftedDay] _SCHED_RRF_PAM scfg _IED _RRANX _RRCL _RRNXT _MD _SD = let maybeS | isNothing _RRANX = Just $ _IED `plusCycle` fromJust _RRCL | otherwise = _RRANX @@ -124,9 +123,7 @@ _SCHED_SC_PAM scfg _IED _SCEF _SCANX _SCCL _MD = | otherwise = tt in result --- - Linear Amortizer - -- -_SCHED_IED_LAM :: ScheduleConfig -> Day -> Maybe [ShiftedDay] -_SCHED_IED_LAM = _SCHED_IED_PAM +-- Linear Amortizer (LAM) _SCHED_PR_LAM :: ScheduleConfig -> Maybe Cycle -> Day -> Maybe Day -> Day -> Maybe ShiftedSchedule _SCHED_PR_LAM scfg _PRCL _IED _PRANX _MD = @@ -138,28 +135,6 @@ _SCHED_PR_LAM scfg _PRCL _IED _PRANX _MD = _SCHED_MD_LAM :: ScheduleConfig -> Day -> Maybe [ShiftedDay] _SCHED_MD_LAM scfg tmd = Just [shift scfg tmd] -_SCHED_PP_LAM :: ScheduleConfig -> PPEF -> Maybe Cycle -> Day -> Maybe Day -> Day -> Maybe ShiftedSchedule -_SCHED_PP_LAM = _SCHED_PP_PAM - -_SCHED_PY_LAM :: ScheduleConfig -> PYTP -> PPEF -> Maybe Cycle -> Day -> Maybe Day -> Day -> Maybe ShiftedSchedule -_SCHED_PY_LAM = _SCHED_PY_PAM - --- To avoid constraint error, we can't fixpoint this -_SCHED_FP_LAM :: (Eq a, Fractional a) => ScheduleConfig -> a -> Maybe Cycle -> Day -> Maybe Day -> Day -> Maybe ShiftedSchedule -_SCHED_FP_LAM = _SCHED_FP_PAM - -_SCHED_PRD_LAM :: ScheduleConfig -> Maybe Day -> Maybe [ShiftedDay] -_SCHED_PRD_LAM = _SCHED_PRD_PAM - -_SCHED_TD_LAM :: ScheduleConfig -> Maybe Day -> Maybe [ShiftedDay] -_SCHED_TD_LAM = _SCHED_TD_PAM - -_SCHED_IP_LAM :: ScheduleConfig -> Maybe a -> Day -> Maybe Day -> Maybe Cycle -> Maybe Day -> Day -> Maybe [ShiftedDay] -_SCHED_IP_LAM = _SCHED_IP_PAM - -_SCHED_IPCI_LAM :: ScheduleConfig -> Day -> Maybe Day -> Maybe Cycle -> Maybe Day -> Day -> Maybe a -> Maybe [ShiftedDay] -_SCHED_IPCI_LAM = _SCHED_IPCI_PAM - _SCHED_IPCB_LAM :: ScheduleConfig -> Day -> Maybe IPCB -> Maybe Cycle -> Maybe Day -> Day -> Maybe ShiftedSchedule _SCHED_IPCB_LAM scfg _IED _IPCB _IPCBCL _IPCBANX _MD = let maybeS | isNothing _IPCBANX && isNothing _IPCBCL = Nothing @@ -170,33 +145,7 @@ _SCHED_IPCB_LAM scfg _IED _IPCB _IPCBCL _IPCBANX _MD = | otherwise = (\s -> _S s (fromJust _IPCBCL){ includeEndDay = False } _MD scfg) <$> maybeS in result -_SCHED_RR_LAM :: ScheduleConfig -> Day -> Day -> Maybe Day -> Maybe Cycle -> Maybe a -> Day -> Maybe [ShiftedDay] -_SCHED_RR_LAM = _SCHED_RR_PAM - ---_SCHED_RRF_LAM :: ScheduleConfig -> Day -> Maybe Day -> Maybe Cycle -> Day -> Maybe ShiftedSchedule -_SCHED_RRF_LAM = _SCHED_RRF_PAM - -_SCHED_SC_LAM :: ScheduleConfig -> Day -> SCEF -> Maybe Day -> Maybe Cycle -> Day -> Maybe ShiftedSchedule -_SCHED_SC_LAM = _SCHED_SC_PAM - --- Negative Amortizer -_SCHED_IED_NAM = _SCHED_IED_PAM - -_SCHED_PR_NAM = _SCHED_PR_LAM - -_SCHED_MD_NAM = _SCHED_MD_PAM - -_SCHED_PP_NAM = _SCHED_PP_PAM - -_SCHED_PY_NAM = _SCHED_PY_PAM - -_SCHED_FP_NAM :: (Eq a, Fractional a) => ScheduleConfig -> a -> Maybe Cycle -> Day -> Maybe Day -> Day -> Maybe ShiftedSchedule -_SCHED_FP_NAM = _SCHED_FP_PAM - -_SCHED_PRD_NAM = _SCHED_PRD_PAM - -_SCHED_TD_NAM :: ScheduleConfig -> Maybe Day -> Maybe [ShiftedDay] -_SCHED_TD_NAM = _SCHED_TD_PAM +-- Negative Amortizer (NAM) _SCHED_IP_NAM :: ScheduleConfig -> Day -> Maybe Cycle -> Maybe Day -> Maybe Day -> Maybe Day -> Maybe Cycle -> Day -> Maybe [ShiftedDay] _SCHED_IP_NAM scfg _IED _PRCL _PRANX _IPCED _IPANX _IPCL _MD = @@ -222,7 +171,7 @@ _SCHED_IP_NAM scfg _IED _PRCL _PRANX _IPCED _IPANX _IPCL _MD = in result' - +_SCHED_IPCI_NAM :: ScheduleConfig -> Day -> Maybe Cycle -> Maybe Day -> Maybe Day -> Maybe Day -> Maybe Cycle -> Day -> Maybe [ShiftedDay] _SCHED_IPCI_NAM scfg _IED _PRCL _PRANX _IPCED _IPANX _IPCL _MD = let maybeS | isNothing _PRANX = Just $ _IED `plusCycle` fromJust _PRCL | otherwise = _PRANX @@ -247,14 +196,7 @@ _SCHED_IPCI_NAM scfg _IED _PRCL _PRANX _IPCED _IPANX _IPCL _MD = in result' - -_SCHED_IPCB_NAM = _SCHED_IPCB_LAM - -_SCHED_RR_NAM = _SCHED_RR_PAM - -_SCHED_RRF_NAM = _SCHED_RRF_PAM - -_SCHED_SC_NAM = _SCHED_SC_PAM +-- Annuity (ANN) _SCHED_PRF_ANN :: Maybe Day -> Maybe Double -> Maybe Day -> Maybe ShiftedSchedule _SCHED_PRF_ANN _PRANX _PRNXT _IED = diff --git a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/STF/StateTransition.hs b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/STF/StateTransition.hs index 36f6ab98d0d..10523e7f88a 100644 --- a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/STF/StateTransition.hs +++ b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/STF/StateTransition.hs @@ -72,7 +72,7 @@ stateTransition ev RiskFactors{..} terms@ContractTerms{..} st@ContractStatePoly{ _ -> st LAM -> case ev of - AD -> _STF_AD_LAM st t y_sd_t + AD -> _STF_AD_PAM st t y_sd_t IED -> _STF_IED_LAM st t y_ipanx_t ct_IPNR ct_IPANX ct_CNTRL ct_IPAC (fromJust ct_NT) ct_IPCB ct_IPCBA PR -> _STF_PR_LAM st t y_sd_t y_tfpminus_t y_tfpminus_tfpplus ct_FEB ct_FER' ct_CNTRL ct_IPCB MD -> _STF_MD_LAM st t @@ -80,34 +80,35 @@ stateTransition ev RiskFactors{..} terms@ContractTerms{..} st@ContractStatePoly{ PY -> _STF_PY_LAM st t y_sd_t y_tfpminus_t y_tfpminus_tfpplus ct_FEB ct_FER' ct_CNTRL FP -> _STF_FP_LAM st t y_sd_t PRD -> _STF_PRD_LAM st t y_sd_t y_tfpminus_t y_tfpminus_tfpplus ct_FEB ct_FER' ct_CNTRL - TD -> _STF_TD_LAM st t - IP -> _STF_IP_LAM st t y_sd_t y_tfpminus_t y_tfpminus_tfpplus ct_FEB ct_FER' ct_CNTRL + TD -> _STF_TD_PAM st t + IP -> _STF_IP_PAM st t y_sd_t y_tfpminus_t y_tfpminus_tfpplus ct_FEB ct_FER' ct_CNTRL IPCI -> _STF_IPCI_LAM st t y_sd_t y_tfpminus_t y_tfpminus_tfpplus ct_FEB ct_FER' ct_CNTRL ct_IPCB IPCB -> _STF_IPCB_LAM st t y_sd_t y_tfpminus_t y_tfpminus_tfpplus ct_FEB ct_FER' ct_CNTRL RR -> _STF_RR_LAM st t y_sd_t y_tfpminus_t y_tfpminus_tfpplus ct_FEB ct_FER' ct_CNTRL ct_RRLF' ct_RRLC' ct_RRPC' ct_RRPF' ct_RRMLT' ct_RRSP' o_rf_RRMO RRF -> _STF_RRF_LAM st t y_sd_t y_tfpminus_t y_tfpminus_tfpplus ct_FEB ct_FER' ct_CNTRL ct_RRNXT SC -> _STF_SC_LAM st t y_sd_t y_tfpminus_t y_tfpminus_tfpplus ct_FEB ct_FER' ct_CNTRL ct_SCEF' o_rf_SCMO ct_SCCDD' - CE -> _STF_CE_LAM st t y_sd_t + CE -> _STF_CE_PAM st t y_sd_t _ -> st NAM -> case ev of - AD -> _STF_AD_NAM st t y_sd_t - IED -> _STF_IED_NAM st t y_ipanx_t ct_IPNR ct_IPANX ct_CNTRL ct_IPAC (fromJust ct_NT) ct_IPCB ct_IPCBA + AD -> _STF_AD_PAM st t y_sd_t + IED -> _STF_IED_LAM st t y_ipanx_t ct_IPNR ct_IPANX ct_CNTRL ct_IPAC (fromJust ct_NT) ct_IPCB ct_IPCBA PR -> _STF_PR_NAM st t pp_payoff y_sd_t y_tfpminus_t y_tfpminus_tfpplus ct_FEB ct_FER' ct_CNTRL ct_IPCB - MD -> _STF_MD_NAM st t - PP -> _STF_PP_NAM st t pp_payoff y_sd_t y_tfpminus_t y_tfpminus_tfpplus ct_FEB ct_FER' ct_CNTRL ct_IPCB - PY -> _STF_PY_NAM st t y_sd_t y_tfpminus_t y_tfpminus_tfpplus ct_FEB ct_FER' ct_CNTRL - FP -> _STF_FP_NAM st t y_sd_t - PRD -> _STF_PRD_NAM st t y_sd_t y_tfpminus_t y_tfpminus_tfpplus ct_FEB ct_FER' ct_CNTRL - TD -> _STF_TD_NAM st t - IP -> _STF_IP_NAM st t y_sd_t y_tfpminus_t y_tfpminus_tfpplus ct_FEB ct_FER' ct_CNTRL - IPCI -> _STF_IPCI_NAM st t y_sd_t y_tfpminus_t y_tfpminus_tfpplus ct_FEB ct_FER' ct_CNTRL ct_IPCB - IPCB -> _STF_IPCB_NAM st t y_sd_t y_tfpminus_t y_tfpminus_tfpplus ct_FEB ct_FER' ct_CNTRL - RR -> _STF_RR_NAM st t y_sd_t y_tfpminus_t y_tfpminus_tfpplus ct_FEB ct_FER' ct_CNTRL ct_RRLF' ct_RRLC' ct_RRPC' ct_RRPF' ct_RRMLT' ct_RRSP' o_rf_RRMO - RRF -> _STF_RRF_NAM st t y_sd_t y_tfpminus_t y_tfpminus_tfpplus ct_FEB ct_FER' ct_CNTRL ct_RRNXT - SC -> _STF_SC_NAM st t y_sd_t y_tfpminus_t y_tfpminus_tfpplus ct_FEB ct_FER' ct_CNTRL ct_SCEF' o_rf_SCMO ct_SCIED' - CE -> _STF_AD_NAM st t y_sd_t + MD -> _STF_MD_LAM st t + PP -> _STF_PP_LAM st t pp_payoff y_sd_t y_tfpminus_t y_tfpminus_tfpplus ct_FEB ct_FER' ct_CNTRL ct_IPCB + PY -> _STF_PY_LAM st t y_sd_t y_tfpminus_t y_tfpminus_tfpplus ct_FEB ct_FER' ct_CNTRL + FP -> _STF_FP_LAM st t y_sd_t + PRD -> _STF_PRD_LAM st t y_sd_t y_tfpminus_t y_tfpminus_tfpplus ct_FEB ct_FER' ct_CNTRL + TD -> _STF_TD_PAM st t + IP -> _STF_IP_PAM st t y_sd_t y_tfpminus_t y_tfpminus_tfpplus ct_FEB ct_FER' ct_CNTRL + IPCI -> _STF_IPCI_LAM st t y_sd_t y_tfpminus_t y_tfpminus_tfpplus ct_FEB ct_FER' ct_CNTRL ct_IPCB + IPCB -> _STF_IPCB_LAM st t y_sd_t y_tfpminus_t y_tfpminus_tfpplus ct_FEB ct_FER' ct_CNTRL + RR -> _STF_RR_LAM st t y_sd_t y_tfpminus_t y_tfpminus_tfpplus ct_FEB ct_FER' ct_CNTRL ct_RRLF' ct_RRLC' ct_RRPC' ct_RRPF' ct_RRMLT' ct_RRSP' o_rf_RRMO + RRF -> _STF_RRF_LAM st t y_sd_t y_tfpminus_t y_tfpminus_tfpplus ct_FEB ct_FER' ct_CNTRL ct_RRNXT + SC -> _STF_SC_LAM st t y_sd_t y_tfpminus_t y_tfpminus_tfpplus ct_FEB ct_FER' ct_CNTRL ct_SCEF' o_rf_SCMO ct_SCIED' + CE -> _STF_AD_PAM st t y_sd_t _ -> st + ANN -> let prDates = maybe [] (map calculationDay) prSchedule ++ maybeToList (maturity terms) prDatesAfterSd = filter (\d -> d > sd) prDates diff --git a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/STF/StateTransitionFs.hs b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/STF/StateTransitionFs.hs index e643e2612c4..3531678456a 100644 --- a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/STF/StateTransitionFs.hs +++ b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/STF/StateTransitionFs.hs @@ -84,7 +84,7 @@ stateTransitionFs ev terms@ContractTerms{..} t prevDate curDate continue = LAM -> addComment $ stateTransitionMarlowe ev t continue $ \event st -> case event of - AD -> _STF_AD_LAM st time y_sd_t + AD -> _STF_AD_PAM st time y_sd_t IED -> _STF_IED_LAM st time y_ipanx_t __IPNR __IPANX ct_CNTRL __IPAC __NT __IPCB __IPCBA PR -> _STF_PR_LAM st time y_sd_t y_tfpminus_t y_tfpminus_tfpplus __FEB __FER ct_CNTRL __IPCB MD -> _STF_MD_LAM st time @@ -92,32 +92,32 @@ stateTransitionFs ev terms@ContractTerms{..} t prevDate curDate continue = PY -> _STF_PY_LAM st time y_sd_t y_tfpminus_t y_tfpminus_tfpplus __FEB __FER ct_CNTRL FP -> _STF_FP_LAM st time y_sd_t PRD -> _STF_PRD_LAM st time y_sd_t y_tfpminus_t y_tfpminus_tfpplus __FEB __FER ct_CNTRL - TD -> _STF_TD_LAM st time - IP -> _STF_IP_LAM st time y_sd_t y_tfpminus_t y_tfpminus_tfpplus __FEB __FER ct_CNTRL + TD -> _STF_TD_PAM st time + IP -> _STF_IP_PAM st time y_sd_t y_tfpminus_t y_tfpminus_tfpplus __FEB __FER ct_CNTRL IPCI -> _STF_IPCI_LAM st time y_sd_t y_tfpminus_t y_tfpminus_tfpplus __FEB __FER ct_CNTRL __IPCB IPCB -> _STF_IPCB_LAM st time y_sd_t y_tfpminus_t y_tfpminus_tfpplus __FEB __FER ct_CNTRL RR -> _STF_RR_LAM st time y_sd_t y_tfpminus_t y_tfpminus_tfpplus __FEB __FER ct_CNTRL __RRLF __RRLC __RRPC __RRPF __RRMLT __RRSP __o_rf_RRMO RRF -> _STF_RRF_LAM st time y_sd_t y_tfpminus_t y_tfpminus_tfpplus __FEB __FER ct_CNTRL __RRNXT SC -> _STF_SC_LAM st time y_sd_t y_tfpminus_t y_tfpminus_tfpplus __FEB __FER ct_CNTRL (fromJust ct_SCEF) __o_rf_SCMO __SCIED - CE -> _STF_CE_LAM st time y_sd_t + CE -> _STF_CE_PAM st time y_sd_t _ -> st NAM -> addComment $ stateTransitionMarlowe ev t continue $ \event st -> case event of - AD -> _STF_AD_NAM st time y_sd_t - IED -> _STF_IED_NAM st time y_ipanx_t __IPNR __IPANX ct_CNTRL __IPAC __NT __IPCB __IPCBA + AD -> _STF_AD_PAM st time y_sd_t + IED -> _STF_IED_LAM st time y_ipanx_t __IPNR __IPANX ct_CNTRL __IPAC __NT __IPCB __IPCBA PR -> _STF_PR_NAM st time __pp_payoff y_sd_t y_tfpminus_t y_tfpminus_tfpplus __FEB __FER ct_CNTRL __IPCB - MD -> _STF_MD_NAM st time - PP -> _STF_PP_NAM st time __pp_payoff y_sd_t y_tfpminus_t y_tfpminus_tfpplus __FEB __FER ct_CNTRL __IPCB - PY -> _STF_PY_NAM st time y_sd_t y_tfpminus_t y_tfpminus_tfpplus __FEB __FER ct_CNTRL - FP -> _STF_FP_NAM st time y_sd_t - PRD -> _STF_PRD_NAM st time y_sd_t y_tfpminus_t y_tfpminus_tfpplus __FEB __FER ct_CNTRL - TD -> _STF_TD_NAM st time - IP -> _STF_IP_NAM st time y_sd_t y_tfpminus_t y_tfpminus_tfpplus __FEB __FER ct_CNTRL - IPCI -> _STF_IPCI_NAM st time y_sd_t y_tfpminus_t y_tfpminus_tfpplus __FEB __FER ct_CNTRL __IPCB - IPCB -> _STF_IPCB_NAM st time y_sd_t y_tfpminus_t y_tfpminus_tfpplus __FEB __FER ct_CNTRL - RR -> _STF_RR_NAM st time y_sd_t y_tfpminus_t y_tfpminus_tfpplus __FEB __FER ct_CNTRL __RRLF __RRLC __RRPC __RRPF __RRMLT __RRSP __o_rf_RRMO - RRF -> _STF_RRF_NAM st time y_sd_t y_tfpminus_t y_tfpminus_tfpplus __FEB __FER ct_CNTRL __RRNXT - SC -> _STF_SC_NAM st time y_sd_t y_tfpminus_t y_tfpminus_tfpplus __FEB __FER ct_CNTRL (fromJust ct_SCEF) __o_rf_SCMO __SCIED - CE -> _STF_AD_NAM st time y_sd_t + MD -> _STF_MD_LAM st time + PP -> _STF_PP_LAM st time __pp_payoff y_sd_t y_tfpminus_t y_tfpminus_tfpplus __FEB __FER ct_CNTRL __IPCB + PY -> _STF_PY_LAM st time y_sd_t y_tfpminus_t y_tfpminus_tfpplus __FEB __FER ct_CNTRL + FP -> _STF_FP_LAM st time y_sd_t + PRD -> _STF_PRD_LAM st time y_sd_t y_tfpminus_t y_tfpminus_tfpplus __FEB __FER ct_CNTRL + TD -> _STF_TD_PAM st time + IP -> _STF_IP_PAM st time y_sd_t y_tfpminus_t y_tfpminus_tfpplus __FEB __FER ct_CNTRL + IPCI -> _STF_IPCI_LAM st time y_sd_t y_tfpminus_t y_tfpminus_tfpplus __FEB __FER ct_CNTRL __IPCB + IPCB -> _STF_IPCB_LAM st time y_sd_t y_tfpminus_t y_tfpminus_tfpplus __FEB __FER ct_CNTRL + RR -> _STF_RR_LAM st time y_sd_t y_tfpminus_t y_tfpminus_tfpplus __FEB __FER ct_CNTRL __RRLF __RRLC __RRPC __RRPF __RRMLT __RRSP __o_rf_RRMO + RRF -> _STF_RRF_LAM st time y_sd_t y_tfpminus_t y_tfpminus_tfpplus __FEB __FER ct_CNTRL __RRNXT + SC -> _STF_SC_LAM st time y_sd_t y_tfpminus_t y_tfpminus_tfpplus __FEB __FER ct_CNTRL (fromJust ct_SCEF) __o_rf_SCMO __SCIED + CE -> _STF_AD_PAM st time y_sd_t _ -> st diff --git a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/STF/StateTransitionModel.hs b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/STF/StateTransitionModel.hs index 741c96f443a..712842a8309 100644 --- a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/STF/StateTransitionModel.hs +++ b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/STF/StateTransitionModel.hs @@ -133,9 +133,7 @@ _STF_SC_PAM st@ContractStatePoly{..} t y_sd_t y_tfpminus_t y_tfpminus_tfpplus _F _STF_CE_PAM :: ActusNum a => ContractStatePoly a b -> b -> a -> ContractStatePoly a b _STF_CE_PAM = _STF_AD_PAM --- Linear Amortiser -_STF_AD_LAM :: ActusNum a => ContractStatePoly a b -> b -> a -> ContractStatePoly a b -_STF_AD_LAM = _STF_AD_PAM +-- Linear Amortiser (LAM) _STF_IED_LAM :: (RoleSignOps a1, ActusNum a1, ActusOps a1, Ord a2) => ContractStatePoly a1 a2 -> a2 -> a1 -> Maybe a1 -> Maybe a2 -> CR -> Maybe a1 -> a1 -> Maybe IPCB -> Maybe a1 -> ContractStatePoly a1 a2 _STF_IED_LAM st t y_ipanx_t _IPNR _IPANX _CNTRL _IPAC _NT _IPCB _IPCBA = @@ -213,12 +211,6 @@ _STF_FP_LAM st@ContractStatePoly{..} t y_sd_t = st { _STF_PRD_LAM :: (RoleSignOps a, ActusNum a) => ContractStatePoly a b -> b -> a -> a -> a -> Maybe FEB -> a -> CR -> ContractStatePoly a b _STF_PRD_LAM = _STF_PY_LAM -_STF_TD_LAM :: ActusOps a => ContractStatePoly a b -> b -> ContractStatePoly a b -_STF_TD_LAM = _STF_TD_PAM - -_STF_IP_LAM :: (ActusOps a, ActusNum a) => ContractStatePoly a b -> b -> a -> a -> a -> Maybe FEB -> a -> CR -> ContractStatePoly a b -_STF_IP_LAM = _STF_IP_PAM - _STF_IPCI_LAM :: (ActusOps a, ActusNum a) => ContractStatePoly a b -> b -> a -> a -> a -> Maybe FEB -> a -> CR -> Maybe IPCB -> ContractStatePoly a b _STF_IPCI_LAM st@ContractStatePoly{..} t y_sd_t y_tfpminus_t y_tfpminus_tfpplus _FEB _FER _CNTRL _IPCB = let @@ -267,15 +259,7 @@ _STF_SC_LAM st@ContractStatePoly{..} t y_sd_t y_tfpminus_t y_tfpminus_tfpplus _F nsc in st' {nsc = nsc', isc = isc'} -_STF_CE_LAM :: ActusNum a => ContractStatePoly a b -> b -> a -> ContractStatePoly a b -_STF_CE_LAM = _STF_AD_PAM - --- Negative Amortizer -_STF_AD_NAM :: ActusNum a => ContractStatePoly a b -> b -> a -> ContractStatePoly a b -_STF_AD_NAM = _STF_AD_PAM - -_STF_IED_NAM :: (RoleSignOps a1, ActusNum a1, ActusOps a1, Ord a2) => ContractStatePoly a1 a2 -> a2 -> a1 -> Maybe a1 -> Maybe a2 -> CR -> Maybe a1 -> a1 -> Maybe IPCB -> Maybe a1 -> ContractStatePoly a1 a2 -_STF_IED_NAM = _STF_IED_LAM +-- Negative Amortizer (NAM) _STF_PR_NAM :: (RoleSignOps a, ActusOps a, ActusNum a) => ContractStatePoly a b -> b -> a -> a -> a -> a -> Maybe FEB -> a -> CR -> Maybe IPCB -> ContractStatePoly a b _STF_PR_NAM st@ContractStatePoly{..} t _ y_sd_t y_tfpminus_t y_tfpminus_tfpplus _FEB _FER _CNTRL _IPCB = @@ -301,45 +285,6 @@ _STF_PR_NAM st@ContractStatePoly{..} t _ y_sd_t y_tfpminus_t y_tfpminus_tfpplus in st'{ nt = nt', ipcb = ipcb' } -_STF_MD_NAM :: ActusOps a => ContractStatePoly a b -> b -> ContractStatePoly a b -_STF_MD_NAM = _STF_MD_LAM - -_STF_PP_NAM :: (RoleSignOps a, ActusNum a) => ContractStatePoly a b -> b -> a -> a -> a -> a -> Maybe FEB -> a -> CR -> Maybe IPCB -> ContractStatePoly a b -_STF_PP_NAM = _STF_PP_LAM - -_STF_PY_NAM :: (RoleSignOps a, ActusNum a) => ContractStatePoly a b -> b -> a -> a -> a -> Maybe FEB -> a -> CR -> ContractStatePoly a b -_STF_PY_NAM = _STF_PY_LAM - -_STF_FP_NAM :: (ActusNum a, ActusOps a) => ContractStatePoly a b -> b -> a -> ContractStatePoly a b -_STF_FP_NAM = _STF_FP_LAM - -_STF_PRD_NAM :: (RoleSignOps a, ActusNum a) => ContractStatePoly a b -> b -> a -> a -> a -> Maybe FEB -> a -> CR -> ContractStatePoly a b -_STF_PRD_NAM = _STF_PRD_LAM - -_STF_TD_NAM :: ActusOps a => ContractStatePoly a b -> b -> ContractStatePoly a b -_STF_TD_NAM = _STF_TD_PAM - -_STF_IP_NAM :: (ActusOps a, ActusNum a) => ContractStatePoly a b -> b -> a -> a -> a -> Maybe FEB -> a -> CR -> ContractStatePoly a b -_STF_IP_NAM = _STF_IP_PAM - -_STF_IPCI_NAM :: (ActusOps a, ActusNum a) => ContractStatePoly a b -> b -> a -> a -> a -> Maybe FEB -> a -> CR -> Maybe IPCB -> ContractStatePoly a b -_STF_IPCI_NAM = _STF_IPCI_LAM - -_STF_IPCB_NAM :: (RoleSignOps a, ActusNum a) => ContractStatePoly a b -> b -> a -> a -> a -> Maybe FEB -> a -> CR -> ContractStatePoly a b -_STF_IPCB_NAM = _STF_IPCB_LAM - -_STF_RR_NAM :: (ActusOps a, RoleSignOps a, ActusNum a) => ContractStatePoly a b -> b -> a -> a -> a -> Maybe FEB -> a -> CR -> a -> a -> a -> a -> a -> a -> a -> ContractStatePoly a b -_STF_RR_NAM = _STF_RR_LAM - -_STF_RRF_NAM :: (ActusOps a, RoleSignOps a, ActusNum a) => ContractStatePoly a b -> b -> a -> a -> a -> Maybe FEB -> a -> CR -> Maybe a -> ContractStatePoly a b -_STF_RRF_NAM = _STF_RRF_LAM - -_STF_SC_NAM :: (RoleSignOps a, ActusNum a) => ContractStatePoly a b -> b -> a -> a -> a -> Maybe FEB -> a -> CR -> SCEF -> a -> a -> ContractStatePoly a b -_STF_SC_NAM = _STF_SC_LAM - -_STF_CE_NAM :: ActusNum a => ContractStatePoly a b -> b -> a -> ContractStatePoly a b -_STF_CE_NAM = _STF_AD_PAM - -- Annuity (ANN) _STF_RR_ANN :: (ActusOps a, RoleSignOps a, ActusNum a) => ContractStatePoly a b -> b -> a -> a -> a -> Maybe FEB -> a -> CR -> a -> a -> a -> a -> a -> a -> a -> [a] -> ContractStatePoly a b From 69a4769f5a58bae7f98d23ce8e572069cb9952c1 Mon Sep 17 00:00:00 2001 From: Yves Hauser Date: Mon, 30 Aug 2021 17:24:51 +0200 Subject: [PATCH 04/28] scp-2709 - moved QCGenerator to testkit --- marlowe-actus/marlowe-actus.cabal | 5 +---- .../{src => testkit}/Language/Marlowe/ACTUS/QCGenerator.hs | 0 2 files changed, 1 insertion(+), 4 deletions(-) rename marlowe-actus/{src => testkit}/Language/Marlowe/ACTUS/QCGenerator.hs (100%) diff --git a/marlowe-actus/marlowe-actus.cabal b/marlowe-actus/marlowe-actus.cabal index a7ffe0b8bb5..514f3fb2811 100644 --- a/marlowe-actus/marlowe-actus.cabal +++ b/marlowe-actus/marlowe-actus.cabal @@ -33,7 +33,6 @@ library base -any, bytestring, containers -any, - mtl, newtype-generics, template-haskell -any, plutus-tx -any, @@ -44,8 +43,7 @@ library marlowe -any, time -any, sort -any, - validation -any, - QuickCheck + validation -any default-language: Haskell2010 default-extensions: ExplicitForAll ScopedTypeVariables DeriveGeneric StandaloneDeriving DeriveLift @@ -54,7 +52,6 @@ library exposed-modules: Language.Marlowe.ACTUS.MarloweCompat Language.Marlowe.ACTUS.Generator - Language.Marlowe.ACTUS.QCGenerator Language.Marlowe.ACTUS.Analysis Language.Marlowe.ACTUS.Definitions.BusinessEvents Language.Marlowe.ACTUS.Definitions.ContractTerms diff --git a/marlowe-actus/src/Language/Marlowe/ACTUS/QCGenerator.hs b/marlowe-actus/testkit/Language/Marlowe/ACTUS/QCGenerator.hs similarity index 100% rename from marlowe-actus/src/Language/Marlowe/ACTUS/QCGenerator.hs rename to marlowe-actus/testkit/Language/Marlowe/ACTUS/QCGenerator.hs From d9ff175f3a5b2052cd2db743f0c3fe9992fe49ea Mon Sep 17 00:00:00 2001 From: Yves Hauser Date: Mon, 30 Aug 2021 19:30:06 +0200 Subject: [PATCH 05/28] scp-2709 - replacing partial functions --- .../ACTUS/Model/SCHED/ContractSchedule.hs | 215 +++++++------- .../Model/SCHED/ContractScheduleModel.hs | 275 +++++++++--------- 2 files changed, 237 insertions(+), 253 deletions(-) diff --git a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/SCHED/ContractSchedule.hs b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/SCHED/ContractSchedule.hs index 9515cd4c719..2d511ebad65 100644 --- a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/SCHED/ContractSchedule.hs +++ b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/SCHED/ContractSchedule.hs @@ -3,7 +3,7 @@ module Language.Marlowe.ACTUS.Model.SCHED.ContractSchedule where import Control.Applicative (Alternative ((<|>))) -import Data.Maybe (fromJust, fromMaybe) +import Data.Maybe (fromMaybe) import Language.Marlowe.ACTUS.Definitions.BusinessEvents (EventType (..)) import Language.Marlowe.ACTUS.Definitions.ContractState (ContractStatePoly (tmd)) import Language.Marlowe.ACTUS.Definitions.ContractTerms (CT (..), ContractTerms (..)) @@ -14,120 +14,101 @@ import Language.Marlowe.ACTUS.Model.Utility.ANN.Maturity (mat import Language.Marlowe.ACTUS.Model.Utility.ScheduleGenerator (inf, sup) schedule :: EventType -> ContractTerms -> Maybe [ShiftedDay] -schedule ev - ct@ContractTerms { - ct_IED = ct_IED - , ct_FER = ct_FER - , ct_MD = ct_MD - , ct_PRD = ct_PRD - , ct_TD = ct_TD - , ct_SCEF = ct_SCEF - , ct_PYTP = ct_PYTP - , ct_PPEF = ct_PPEF - , ..} = - let - ct_IED' = fromJust ct_IED - ct_FER' = fromJust ct_FER - ct_MD' = fromJust ct_MD - ct_SCEF' = fromJust ct_SCEF - ct_PYTP' = fromJust ct_PYTP - ct_PPEF' = fromJust ct_PPEF - in - case contractType of - PAM -> case ev of - IED -> _SCHED_IED_PAM scfg ct_IED' - MD -> _SCHED_MD_PAM scfg ct_MD' - PP -> _SCHED_PP_PAM scfg ct_PPEF' ct_OPCL ct_IED' ct_OPANX ct_MD' - PY -> _SCHED_PY_PAM scfg ct_PYTP' ct_PPEF' ct_OPCL ct_IED' ct_OPANX ct_MD' - FP -> _SCHED_FP_PAM scfg ct_FER' ct_FECL ct_IED' ct_FEANX ct_MD' - PRD -> _SCHED_PRD_PAM scfg ct_PRD - TD -> _SCHED_TD_PAM scfg ct_TD - IP -> _SCHED_IP_PAM scfg ct_IPNR ct_IED' ct_IPANX ct_IPCL ct_IPCED ct_MD' - IPCI -> _SCHED_IPCI_PAM scfg ct_IED' ct_IPANX ct_IPCL ct_IPCED ct_MD' ct_IPNR - RR -> _SCHED_RR_PAM scfg ct_IED' ct_SD ct_RRANX ct_RRCL ct_RRNXT ct_MD' - RRF -> _SCHED_RRF_PAM scfg ct_IED' ct_RRANX ct_RRCL ct_RRNXT ct_MD' ct_SD - SC -> _SCHED_SC_PAM scfg ct_IED' ct_SCEF' ct_SCANX ct_SCCL ct_MD' - _ -> Nothing - LAM -> - let - -- Need LAM state initialization since MD schedule is Tmd0 which may consist of other terms - -- Also cannot call initializeState directly without cyclical imports - t0 = ct_SD - fpSchedule = schedule FP ct - tfp_minus = maybe t0 calculationDay ((\sc -> sup sc t0) =<< fpSchedule) - tfp_plus = maybe t0 calculationDay ((\sc -> inf sc t0) =<< fpSchedule) - ipSchedule = schedule IP ct - tminus = maybe t0 calculationDay ((\sc -> sup sc t0) =<< ipSchedule) - prSchedule = schedule PR ct - tpr_minus = maybe t0 calculationDay ((\sc -> sup sc t0) =<< prSchedule) - _tmd = tmd $ _INIT_LAM ct_SD tminus tpr_minus tfp_minus tfp_plus ct - in case ev of - IED -> _SCHED_IED_PAM scfg ct_IED' - PR -> _SCHED_PR_LAM scfg ct_PRCL ct_IED' ct_PRANX _tmd - MD -> _SCHED_MD_LAM scfg _tmd - PP -> _SCHED_PP_PAM scfg ct_PPEF' ct_OPCL ct_IED' ct_OPANX _tmd - PY -> _SCHED_PY_PAM scfg ct_PYTP' ct_PPEF' ct_OPCL ct_IED' ct_OPANX _tmd - FP -> _SCHED_FP_PAM scfg ct_FER' ct_FECL ct_IED' ct_FEANX _tmd - PRD -> _SCHED_PRD_PAM scfg ct_PRD - TD -> _SCHED_TD_PAM scfg ct_TD - IP -> _SCHED_IP_PAM scfg ct_IPNR ct_IED' ct_IPANX ct_IPCL ct_IPCED _tmd - IPCI -> _SCHED_IPCI_PAM scfg ct_IED' ct_IPANX ct_IPCL ct_IPCED _tmd ct_IPNR - IPCB -> _SCHED_IPCB_LAM scfg ct_IED' ct_IPCB ct_IPCBCL ct_IPCBANX _tmd - RR -> _SCHED_RR_PAM scfg ct_IED' ct_SD ct_RRANX ct_RRCL ct_RRNXT _tmd - RRF -> _SCHED_RRF_PAM scfg ct_IED' ct_RRANX ct_RRCL ct_RRNXT _tmd ct_SD - SC -> _SCHED_SC_PAM scfg ct_IED' ct_SCEF' ct_SCANX ct_SCCL _tmd - _ -> Nothing - NAM -> - -- Same as LAM - need to calculate Tmd0 - -- TODO: refactor for LAM and NAM - let - t0 = ct_SD - fpSchedule = schedule FP ct - tfp_minus = maybe t0 calculationDay ((\sc -> sup sc t0) =<< fpSchedule) - tfp_plus = maybe t0 calculationDay ((\sc -> inf sc t0) =<< fpSchedule) - ipSchedule = schedule IP ct - tminus = maybe t0 calculationDay ((\sc -> sup sc t0) =<< ipSchedule) - prSchedule = schedule PR ct - tpr_minus = maybe t0 calculationDay ((\sc -> sup sc t0) =<< prSchedule) - _tmd = tmd $ _INIT_NAM ct_SD tminus tpr_minus tfp_minus tfp_plus ct - in case ev of - IED -> _SCHED_IED_PAM scfg ct_IED' - PR -> _SCHED_PR_LAM scfg ct_PRCL ct_IED' ct_PRANX _tmd - MD -> _SCHED_MD_PAM scfg _tmd - PP -> _SCHED_PP_PAM scfg ct_PPEF' ct_OPCL ct_IED' ct_OPANX _tmd - PY -> _SCHED_PY_PAM scfg ct_PYTP' ct_PPEF' ct_OPCL ct_IED' ct_OPANX _tmd - FP -> _SCHED_FP_PAM scfg ct_FER' ct_FECL ct_IED' ct_FEANX _tmd - PRD -> _SCHED_PRD_PAM scfg ct_PRD - TD -> _SCHED_TD_PAM scfg ct_TD - IP -> _SCHED_IP_NAM scfg ct_IED' ct_PRCL ct_PRANX ct_IPCED ct_IPANX ct_IPCL _tmd - IPCI -> _SCHED_IPCI_NAM scfg ct_IED' ct_PRCL ct_PRANX ct_IPCED ct_IPANX ct_IPCL _tmd - IPCB -> _SCHED_IPCB_LAM scfg ct_IED' ct_IPCB ct_IPCBCL ct_IPCBANX _tmd - RR -> _SCHED_RR_PAM scfg ct_IED' ct_SD ct_RRANX ct_RRCL ct_RRNXT _tmd - RRF -> _SCHED_RRF_PAM scfg ct_IED' ct_RRANX ct_RRCL ct_RRNXT _tmd ct_SD - SC -> _SCHED_SC_PAM scfg ct_IED' ct_SCEF' ct_SCANX ct_SCCL _tmd - _ -> Nothing +schedule ev ct@ContractTerms{..} = + case contractType of + PAM -> case ev of + IED -> _SCHED_IED_PAM ct + MD -> _SCHED_MD_PAM ct + PP -> _SCHED_PP_PAM ct + PY -> _SCHED_PY_PAM ct + FP -> _SCHED_FP_PAM ct + PRD -> _SCHED_PRD_PAM ct + TD -> _SCHED_TD_PAM ct + IP -> _SCHED_IP_PAM ct + IPCI -> _SCHED_IPCI_PAM ct + RR -> _SCHED_RR_PAM ct + RRF -> _SCHED_RRF_PAM ct + SC -> _SCHED_SC_PAM ct + _ -> Nothing + LAM -> + let + -- Need LAM state initialization since MD schedule is Tmd0 which may consist of other terms + -- Also cannot call initializeState directly without cyclical imports + t0 = ct_SD + fpSchedule = schedule FP ct + tfp_minus = maybe t0 calculationDay ((\sc -> sup sc t0) =<< fpSchedule) + tfp_plus = maybe t0 calculationDay ((\sc -> inf sc t0) =<< fpSchedule) + ipSchedule = schedule IP ct + tminus = maybe t0 calculationDay ((\sc -> sup sc t0) =<< ipSchedule) + prSchedule = schedule PR ct + tpr_minus = maybe t0 calculationDay ((\sc -> sup sc t0) =<< prSchedule) + _tmd = Just $ tmd $ _INIT_LAM ct_SD tminus tpr_minus tfp_minus tfp_plus ct + in case ev of + IED -> _SCHED_IED_PAM ct + PR -> _SCHED_PR_LAM ct { ct_MD = _tmd } + MD -> _SCHED_MD_LAM ct { ct_MD = _tmd } + PP -> _SCHED_PP_PAM ct { ct_MD = _tmd } + PY -> _SCHED_PY_PAM ct { ct_MD = _tmd } + FP -> _SCHED_FP_PAM ct { ct_MD = _tmd } + PRD -> _SCHED_PRD_PAM ct + TD -> _SCHED_TD_PAM ct + IP -> _SCHED_IP_PAM ct { ct_MD = _tmd } + IPCI -> _SCHED_IPCI_PAM ct { ct_MD = _tmd } + IPCB -> _SCHED_IPCB_LAM ct { ct_MD = _tmd } + RR -> _SCHED_RR_PAM ct { ct_MD = _tmd } + RRF -> _SCHED_RRF_PAM ct { ct_MD = _tmd } + SC -> _SCHED_SC_PAM ct { ct_MD = _tmd } + _ -> Nothing + NAM -> + -- Same as LAM - need to calculate Tmd0 + -- TODO: refactor for LAM and NAM + let + t0 = ct_SD + fpSchedule = schedule FP ct + tfp_minus = maybe t0 calculationDay ((\sc -> sup sc t0) =<< fpSchedule) + tfp_plus = maybe t0 calculationDay ((\sc -> inf sc t0) =<< fpSchedule) + ipSchedule = schedule IP ct + tminus = maybe t0 calculationDay ((\sc -> sup sc t0) =<< ipSchedule) + prSchedule = schedule PR ct + tpr_minus = maybe t0 calculationDay ((\sc -> sup sc t0) =<< prSchedule) + _tmd = Just $ tmd $ _INIT_NAM ct_SD tminus tpr_minus tfp_minus tfp_plus ct + in case ev of + IED -> _SCHED_IED_PAM ct + PR -> _SCHED_PR_LAM ct { ct_MD = _tmd } + MD -> _SCHED_MD_PAM ct { ct_MD = _tmd } + PP -> _SCHED_PP_PAM ct { ct_MD = _tmd } + PY -> _SCHED_PY_PAM ct { ct_MD = _tmd } + FP -> _SCHED_FP_PAM ct { ct_MD = _tmd } + PRD -> _SCHED_PRD_PAM ct + TD -> _SCHED_TD_PAM ct + IP -> _SCHED_IP_NAM ct { ct_MD = _tmd } + IPCI -> _SCHED_IPCI_NAM ct { ct_MD = _tmd } + IPCB -> _SCHED_IPCB_LAM ct { ct_MD = _tmd } + RR -> _SCHED_RR_PAM ct { ct_MD = _tmd } + RRF -> _SCHED_RRF_PAM ct { ct_MD = _tmd } + SC -> _SCHED_SC_PAM ct { ct_MD = _tmd } + _ -> Nothing - ANN -> - let mat = maturity ct - _tmd = ct_AD <|> mat - - in case ev of - IED -> _SCHED_IED_PAM scfg ct_IED' - PR -> _tmd >>= _SCHED_PR_LAM scfg ct_PRCL ct_IED' ct_PRANX - MD -> ct_MD <|> _tmd >>= _SCHED_MD_PAM scfg - PP -> _tmd >>= _SCHED_PP_PAM scfg ct_PPEF' ct_OPCL ct_IED' ct_OPANX - PY -> _tmd >>= _SCHED_PY_PAM scfg ct_PYTP' ct_PPEF' ct_OPCL ct_IED' ct_OPANX - FP -> _tmd >>= _SCHED_FP_PAM scfg ct_FER' ct_FECL ct_IED' ct_FEANX - PRD -> _SCHED_PRD_PAM scfg ct_PRD - TD -> _SCHED_TD_PAM scfg ct_TD - IP -> ct_MD <|> _tmd >>= _SCHED_IP_NAM scfg ct_IED' ct_PRCL ct_PRANX ct_IPCED ct_IPANX ct_IPCL - IPCI -> _tmd >>= \t -> _SCHED_IPCI_PAM scfg ct_IED' ct_IPANX ct_IPCL ct_IPCED t ct_IPNR - IPCB -> _tmd >>= _SCHED_IPCB_LAM scfg ct_IED' ct_IPCB ct_IPCBCL ct_IPCBANX - RR -> _tmd >>= _SCHED_RR_PAM scfg ct_IED' ct_SD ct_RRANX ct_RRCL ct_RRNXT - RRF -> _tmd >>= \t -> _SCHED_RRF_PAM scfg ct_IED' ct_RRANX ct_RRCL ct_RRNXT t ct_SD - SC -> _tmd >>= _SCHED_SC_PAM scfg ct_IED' ct_SCEF' ct_SCANX ct_SCCL - PRF -> let prf = _SCHED_PRF_ANN ct_PRANX ct_PRNXT ct_IED - rr = _tmd >>= _SCHED_RR_PAM scfg ct_IED' ct_SD ct_RRANX ct_RRCL ct_RRNXT - rrf = _tmd >>= \t -> _SCHED_RRF_PAM scfg ct_IED' ct_RRANX ct_RRCL ct_RRNXT t ct_SD - in Just $ fromMaybe [] prf ++ fromMaybe [] rr ++ fromMaybe [] rrf - _ -> Nothing + ANN -> + let mat = maturity ct + _tmd = ct_AD <|> mat + in case ev of + IED -> _SCHED_IED_PAM ct + PR -> _SCHED_PR_LAM ct { ct_MD = _tmd } + MD -> _SCHED_MD_PAM ct { ct_MD = ct_MD <|> _tmd } + PP -> _SCHED_PP_PAM ct { ct_MD = _tmd } + PY -> _SCHED_PY_PAM ct { ct_MD = _tmd } + FP -> _SCHED_FP_PAM ct { ct_MD = _tmd } + PRD -> _SCHED_PRD_PAM ct { ct_MD = _tmd } + TD -> _SCHED_TD_PAM ct { ct_MD = _tmd } + IP -> _SCHED_IP_NAM ct { ct_MD = ct_MD <|> _tmd } + IPCI -> _SCHED_IPCI_PAM ct { ct_MD = _tmd } + IPCB -> _SCHED_IPCB_LAM ct { ct_MD = _tmd } + RR -> _SCHED_RR_PAM ct { ct_MD = _tmd } + RRF -> _SCHED_RRF_PAM ct { ct_MD = _tmd } + SC -> _SCHED_SC_PAM ct { ct_MD = _tmd } + PRF -> let prf = _SCHED_PRF_ANN ct { ct_MD = _tmd } + rr = _SCHED_RR_PAM ct { ct_MD = _tmd } + rrf = _SCHED_RRF_PAM ct { ct_MD = _tmd } + in Just $ fromMaybe [] prf ++ fromMaybe [] rr ++ fromMaybe [] rrf + _ -> Nothing diff --git a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/SCHED/ContractScheduleModel.hs b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/SCHED/ContractScheduleModel.hs index f4c295daa30..9c3e776eae1 100644 --- a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/SCHED/ContractScheduleModel.hs +++ b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/SCHED/ContractScheduleModel.hs @@ -1,205 +1,208 @@ {-# LANGUAGE RecordWildCards #-} module Language.Marlowe.ACTUS.Model.SCHED.ContractScheduleModel where +import Control.Applicative +import Control.Monad (join, liftM4) import Data.List as L (find, nub) -import Data.Maybe (fromJust, fromMaybe, isJust, isNothing) +import Data.Maybe (fromMaybe, isJust, isNothing) import Data.Time (Day) import Data.Time.Calendar (addDays) -import Language.Marlowe.ACTUS.Definitions.ContractTerms (Cycle (..), IPCB (IPCB_NTL), PPEF (..), - PYTP (..), SCEF (..), ScheduleConfig) +import Language.Marlowe.ACTUS.Definitions.ContractTerms (ContractTerms (..), Cycle (..), + IPCB (IPCB_NTL), PPEF (..), PYTP (..), + SCEF (..), ScheduleConfig) import Language.Marlowe.ACTUS.Definitions.Schedule (ShiftedDay (..), ShiftedSchedule) import Language.Marlowe.ACTUS.Model.Utility.DateShift (applyBDCWithCfg) import Language.Marlowe.ACTUS.Model.Utility.ScheduleGenerator (generateRecurrentScheduleWithCorrections, inf, minusCycle, plusCycle, remove) -_S :: Day -> Cycle -> Day -> ScheduleConfig -> ShiftedSchedule -_S = generateRecurrentScheduleWithCorrections +_S :: Maybe Day -> Maybe Cycle -> Maybe Day -> Maybe ScheduleConfig -> Maybe ShiftedSchedule +_S = liftM4 generateRecurrentScheduleWithCorrections shift :: ScheduleConfig -> Day -> ShiftedDay shift = applyBDCWithCfg -- Principal at Maturity (PAM) -_SCHED_IED_PAM :: ScheduleConfig -> Day -> Maybe [ShiftedDay] -_SCHED_IED_PAM scfg _IED = Just [shift scfg _IED] - -_SCHED_MD_PAM :: ScheduleConfig -> Day -> Maybe [ShiftedDay] -_SCHED_MD_PAM scfg tmd = Just [shift scfg tmd] - -_SCHED_PP_PAM :: ScheduleConfig -> PPEF -> Maybe Cycle -> Day -> Maybe Day -> Day -> Maybe ShiftedSchedule -_SCHED_PP_PAM _ PPEF_N _OPCL _IED _OPANX _MD = Nothing -_SCHED_PP_PAM scfg _PREF _OPCL _IED _OPANX _MD = - let maybeS | isNothing _OPANX && isNothing _OPCL = Nothing - | isNothing _OPANX = Just $ _IED `plusCycle` fromJust _OPCL - | otherwise = _OPANX - in (\s -> _S s (fromJust _OPCL) _MD scfg) <$> maybeS - -_SCHED_PY_PAM :: ScheduleConfig -> PYTP -> PPEF -> Maybe Cycle -> Day -> Maybe Day -> Day -> Maybe ShiftedSchedule -_SCHED_PY_PAM _ PYTP_O _PREF _OPCL _IED _OPANX _MD = Nothing -_SCHED_PY_PAM scfg _PYTP _PREF _OPCL _IED _OPANX _MD = _SCHED_PP_PAM scfg _PREF _OPCL _IED _OPANX _MD - -_SCHED_FP_PAM :: (Eq a, Fractional a) => ScheduleConfig -> a -> Maybe Cycle -> Day -> Maybe Day -> Day -> Maybe ShiftedSchedule -_SCHED_FP_PAM scfg _FER _FECL _IED _FEANX _MD = - let maybeS | isNothing _FEANX && isNothing _FECL = Nothing - | isNothing _FEANX = Just $ _IED `plusCycle` fromJust _FECL - | otherwise = _FEANX - - result | _FER == 0.0 = Nothing - | otherwise = (\s -> _S s (fromJust _FECL){ includeEndDay = True } _MD scfg) <$> maybeS - in result - -_SCHED_PRD_PAM :: ScheduleConfig -> Maybe Day -> Maybe [ShiftedDay] -_SCHED_PRD_PAM scfg (Just _PRD) = Just [shift scfg _PRD] -_SCHED_PRD_PAM _ _ = Nothing - -_SCHED_TD_PAM :: ScheduleConfig -> Maybe Day -> Maybe [ShiftedDay] -_SCHED_TD_PAM scfg (Just _TD) = Just [shift scfg _TD] -_SCHED_TD_PAM _ _ = Nothing - -_SCHED_IP_PAM :: ScheduleConfig -> Maybe a -> Day -> Maybe Day -> Maybe Cycle -> Maybe Day -> Day -> Maybe [ShiftedDay] -_SCHED_IP_PAM scfg _IPNR _IED _IPANX _IPCL _IPCED _MD = - let maybeS | isNothing _IPANX && isNothing _IPCL = Nothing - | isNothing _IPANX = Just $ _IED `plusCycle` fromJust _IPCL - | otherwise = _IPANX - - result | isNothing _IPNR = Nothing - | otherwise = (\s -> _S s (fromJust _IPCL){ includeEndDay = True } _MD scfg) <$> maybeS - - result' | isJust result && isJust _IPCED = Just $ filter (\ss -> calculationDay ss > fromJust _IPCED) $ fromJust result - | otherwise = result +_SCHED_IED_PAM :: ContractTerms -> Maybe [ShiftedDay] +_SCHED_IED_PAM ContractTerms{..} = (:[]) <$> liftA2 applyBDCWithCfg (Just scfg) ct_IED + +_SCHED_MD_PAM :: ContractTerms -> Maybe [ShiftedDay] +_SCHED_MD_PAM ContractTerms{..} = (:[]) <$> liftA2 applyBDCWithCfg (Just scfg) ct_MD + +_SCHED_PP_PAM :: ContractTerms -> Maybe ShiftedSchedule +_SCHED_PP_PAM ContractTerms{..} | ct_PPEF == Just PPEF_N = Nothing +_SCHED_PP_PAM ContractTerms{..} = + let s | isNothing ct_OPANX && isNothing ct_OPCL = Nothing + | isNothing ct_OPANX = liftA2 plusCycle ct_IED ct_OPCL + | otherwise = ct_OPANX + in _S s ct_OPCL ct_MD (Just scfg) + +_SCHED_PY_PAM :: ContractTerms -> Maybe ShiftedSchedule +_SCHED_PY_PAM ContractTerms{..} | ct_PYTP == Just PYTP_O = Nothing +_SCHED_PY_PAM ct = _SCHED_PP_PAM ct + +_SCHED_FP_PAM :: ContractTerms -> Maybe ShiftedSchedule +_SCHED_FP_PAM ContractTerms{..} = + let s | isNothing ct_FEANX && isNothing ct_FECL = Nothing + | isNothing ct_FEANX = liftA2 plusCycle ct_IED ct_FECL + | otherwise = ct_FEANX + + r | ct_FER == Just 0.0 = Nothing + | otherwise = _S s ((\c -> c {includeEndDay = True}) <$> ct_FECL) ct_MD (Just scfg) + in r + +_SCHED_PRD_PAM :: ContractTerms -> Maybe [ShiftedDay] +_SCHED_PRD_PAM ContractTerms{..} | isJust ct_PRD = (:[]) <$> liftA2 applyBDCWithCfg (Just scfg) ct_PRD +_SCHED_PRD_PAM _ = Nothing + +_SCHED_TD_PAM :: ContractTerms -> Maybe [ShiftedDay] +_SCHED_TD_PAM ContractTerms{..} | isJust ct_TD = (:[]) <$> liftA2 applyBDCWithCfg (Just scfg) ct_TD +_SCHED_TD_PAM _ = Nothing + +_SCHED_IP_PAM :: ContractTerms -> Maybe [ShiftedDay] +_SCHED_IP_PAM ContractTerms{..} = + let s | isNothing ct_IPANX && isNothing ct_IPCL = Nothing + | isNothing ct_IPANX = liftA2 plusCycle ct_IED ct_IPCL + | otherwise = ct_IPANX + + result | isNothing ct_IPNR = Nothing + | otherwise = _S s ((\c -> c {includeEndDay = True }) <$> ct_IPCL) ct_MD (Just scfg) + + result' | isJust result && isJust ct_IPCED = filter (\d -> Just (calculationDay d) > ct_IPCED) <$> result + | otherwise = result in result' -_SCHED_IPCI_PAM :: ScheduleConfig -> Day -> Maybe Day -> Maybe Cycle -> Maybe Day -> Day -> Maybe a -> Maybe [ShiftedDay] -_SCHED_IPCI_PAM scfg _IED _IPANX _IPCL _IPCED _MD _IPNR = - -- calculate IP sched: - let maybeS | isNothing _IPANX && isNothing _IPCL = Nothing - | isNothing _IPANX = Just $ _IED `plusCycle` fromJust _IPCL - | otherwise = _IPANX +_SCHED_IPCI_PAM :: ContractTerms -> Maybe [ShiftedDay] +_SCHED_IPCI_PAM ContractTerms{..} = + let s | isNothing ct_IPANX && isNothing ct_IPCL = Nothing + | isNothing ct_IPANX = liftA2 plusCycle ct_IED ct_IPCL + | otherwise = ct_IPANX - schedIP | isNothing _IPNR = Nothing - | otherwise = (\s -> _S s (fromJust _IPCL){ includeEndDay = True } _MD scfg) <$> maybeS + schedIP | isNothing ct_IPNR = Nothing + | otherwise = _S s ((\c -> c { includeEndDay = True }) <$> ct_IPCL) ct_MD (Just scfg) - result | isJust _IPCL && isJust _IPCED = Just $ filter (\s -> calculationDay s < fromJust _IPCED) (fromJust schedIP) ++ [shift scfg $ fromJust _IPCED] - | otherwise = Nothing + result | isJust ct_IPCL && isJust ct_IPCED = let a = filter (\d -> Just (calculationDay d) < ct_IPCED) <$> schedIP + b = (:[]) <$> liftA2 applyBDCWithCfg (Just scfg) ct_IPCED + in liftA2 (++) a b + | otherwise = Nothing in result -_SCHED_RR_PAM :: ScheduleConfig -> Day -> Day -> Maybe Day -> Maybe Cycle -> Maybe a -> Day -> Maybe [ShiftedDay] -_SCHED_RR_PAM scfg _IED _SD _RRANX _RRCL _RRNXT _MD = - let maybeS | isNothing _RRANX = Just $ _IED `plusCycle` fromJust _RRCL - | otherwise = _RRANX +_SCHED_RR_PAM :: ContractTerms -> Maybe [ShiftedDay] +_SCHED_RR_PAM ContractTerms{..} = + let s | isNothing ct_RRANX = liftA2 plusCycle ct_IED ct_RRCL + | otherwise = ct_RRANX - tt = (\s -> _S s (fromJust _RRCL){ includeEndDay = False } _MD scfg) <$> maybeS - trry = fromJust $ inf (fromJust tt) _SD + tt = _S s ((\c -> c { includeEndDay = False }) <$> ct_RRCL) ct_MD (Just scfg) + trry = join $ liftA2 inf tt (Just ct_SD) - result | isNothing _RRANX && isNothing _RRCL = Nothing - | isJust _RRNXT = remove trry <$> tt - | otherwise = tt + result | isNothing ct_RRANX && isNothing ct_RRCL = Nothing + | isJust ct_RRNXT = liftA2 remove trry tt + | otherwise = tt in result --- ACTUS techspec implementation -_SCHED_RRF_PAM :: ScheduleConfig -> Day -> Maybe Day -> Maybe Cycle -> Maybe a -> Day -> Day -> Maybe [ShiftedDay] -_SCHED_RRF_PAM scfg _IED _RRANX _RRCL _RRNXT _MD _SD = - let maybeS | isNothing _RRANX = Just $ _IED `plusCycle` fromJust _RRCL - | otherwise = _RRANX +_SCHED_RRF_PAM :: ContractTerms -> Maybe ShiftedSchedule +_SCHED_RRF_PAM ContractTerms {..} = + let s | isNothing ct_RRANX = liftA2 plusCycle ct_IED ct_RRCL + | otherwise = ct_RRANX - tt = (\s -> _S s (fromJust _RRCL) _MD scfg) <$> maybeS + tt = _S s ct_RRCL ct_MD (Just scfg) - result | isNothing _RRANX && isNothing _RRCL = Nothing - | otherwise = tt + result | isNothing ct_RRANX && isNothing ct_RRCL = Nothing + | otherwise = tt in - if isJust _RRNXT then - fmap (:[]) (L.find (\ShiftedDay{..} -> calculationDay > _SD) (fromMaybe [] result)) + if isJust ct_RRNXT then + fmap (:[]) (L.find (\ShiftedDay{..} -> calculationDay > ct_SD) (fromMaybe [] result)) else Nothing -_SCHED_SC_PAM :: ScheduleConfig -> Day -> SCEF -> Maybe Day -> Maybe Cycle -> Day -> Maybe ShiftedSchedule -_SCHED_SC_PAM scfg _IED _SCEF _SCANX _SCCL _MD = - let maybeS | isNothing _SCANX && isNothing _SCCL = Nothing - | isNothing _SCANX = Just $ _IED `plusCycle` fromJust _SCCL - | otherwise = _SCANX +_SCHED_SC_PAM :: ContractTerms -> Maybe ShiftedSchedule +_SCHED_SC_PAM ContractTerms{..} = + let s | isNothing ct_SCANX && isNothing ct_SCCL = Nothing + | isNothing ct_SCANX = liftA2 plusCycle ct_IED ct_SCCL + | otherwise = ct_SCANX - tt = (\s -> _S s (fromJust _SCCL){ includeEndDay = False } _MD scfg) <$> maybeS + tt = _S s ((\c -> c { includeEndDay = False }) <$> ct_SCCL) ct_MD (Just scfg) - result | _SCEF == SE_000 = Nothing - | otherwise = tt + result | ct_SCEF == Just SE_000 = Nothing + | otherwise = tt in result -- Linear Amortizer (LAM) -_SCHED_PR_LAM :: ScheduleConfig -> Maybe Cycle -> Day -> Maybe Day -> Day -> Maybe ShiftedSchedule -_SCHED_PR_LAM scfg _PRCL _IED _PRANX _MD = - let maybeS | isNothing _PRANX && isNothing _PRCL = Nothing - | isNothing _PRANX = Just $ _IED `plusCycle` fromJust _PRCL - | otherwise = _PRANX - in (\s -> _S s (fromJust _PRCL){ includeEndDay = False } _MD scfg ) <$> maybeS +_SCHED_PR_LAM :: ContractTerms -> Maybe ShiftedSchedule +_SCHED_PR_LAM ContractTerms{..} = + let s | isNothing ct_PRANX && isNothing ct_PRCL = Nothing + | isNothing ct_PRANX = liftA2 plusCycle ct_IED ct_PRCL + | otherwise = ct_PRANX + in _S s ((\c -> c { includeEndDay = False }) <$> ct_PRCL) ct_MD (Just scfg) -_SCHED_MD_LAM :: ScheduleConfig -> Day -> Maybe [ShiftedDay] -_SCHED_MD_LAM scfg tmd = Just [shift scfg tmd] +_SCHED_MD_LAM :: ContractTerms -> Maybe [ShiftedDay] +_SCHED_MD_LAM ContractTerms{..} = (:[]) <$> liftA2 applyBDCWithCfg (Just scfg) ct_MD -_SCHED_IPCB_LAM :: ScheduleConfig -> Day -> Maybe IPCB -> Maybe Cycle -> Maybe Day -> Day -> Maybe ShiftedSchedule -_SCHED_IPCB_LAM scfg _IED _IPCB _IPCBCL _IPCBANX _MD = - let maybeS | isNothing _IPCBANX && isNothing _IPCBCL = Nothing - | isNothing _IPCBANX = Just $ _IED `plusCycle` fromJust _IPCBCL - | otherwise = _IPCBANX +_SCHED_IPCB_LAM :: ContractTerms -> Maybe ShiftedSchedule +_SCHED_IPCB_LAM ContractTerms{..} = + let s | isNothing ct_IPCBANX && isNothing ct_IPCBCL = Nothing + | isNothing ct_IPCBANX = liftA2 plusCycle ct_IED ct_IPCBCL + | otherwise = ct_IPCBANX - result | fromJust _IPCB /= IPCB_NTL = Nothing -- This means that IPCB != 'NTL', since there is no cycle - | otherwise = (\s -> _S s (fromJust _IPCBCL){ includeEndDay = False } _MD scfg) <$> maybeS + result | ct_IPCB /= Just IPCB_NTL = Nothing -- This means that IPCB != 'NTL', since there is no cycle + | otherwise = _S s ((\c -> c { includeEndDay = False }) <$> ct_IPCBCL) ct_MD (Just scfg) in result -- Negative Amortizer (NAM) -_SCHED_IP_NAM :: ScheduleConfig -> Day -> Maybe Cycle -> Maybe Day -> Maybe Day -> Maybe Day -> Maybe Cycle -> Day -> Maybe [ShiftedDay] -_SCHED_IP_NAM scfg _IED _PRCL _PRANX _IPCED _IPANX _IPCL _MD = - let maybeS | isNothing _PRANX = Just $ _IED `plusCycle` fromJust _PRCL - | otherwise = _PRANX +_SCHED_IP_NAM :: ContractTerms -> Maybe [ShiftedDay] +_SCHED_IP_NAM ContractTerms{..} = + let s | isNothing ct_PRANX = liftA2 plusCycle ct_IED ct_PRCL + | otherwise = ct_PRANX - _T = fromJust maybeS `minusCycle` fromJust _PRCL + _T = liftA2 minusCycle s ct_PRCL - r | isJust _IPANX = _IPANX - | isJust _IPCL = Just $ _IED `plusCycle` fromJust _IPCL - | otherwise = Nothing + r | isJust ct_IPANX = ct_IPANX + | isJust ct_IPCL = liftA2 plusCycle ct_IED ct_IPCL + | otherwise = Nothing - u | isNothing _IPANX && isNothing _IPCL = Nothing - | isJust _IPCED && fromJust _IPCED > _T = Nothing - | otherwise = (\s -> _S s (fromJust _IPCL){ includeEndDay = True } _MD scfg) <$> r + u | isNothing ct_IPANX && isNothing ct_IPCL = Nothing + | isJust ct_IPCED && fromMaybe False (liftA2 (>) ct_IPCED _T) = Nothing + | otherwise = _S r ((\c -> c { includeEndDay = True }) <$> ct_IPCL) ct_MD (Just scfg) - v = (\s -> _S s (fromJust _PRCL) _MD scfg) <$> maybeS + v = _S s ct_PRCL ct_MD (Just scfg) - result = Just $ nub (fromMaybe [] u ++ fromMaybe [] v) + result = nub <$> liftA2 (++) u v - result' | isJust result && isJust _IPCED = Just $ filter (\ss -> calculationDay ss > fromJust _IPCED) $ fromJust result + result' | isJust result && isJust ct_IPCED = filter (\ShiftedDay{..} -> Just calculationDay > ct_IPCED) <$> result | otherwise = result in result' -_SCHED_IPCI_NAM :: ScheduleConfig -> Day -> Maybe Cycle -> Maybe Day -> Maybe Day -> Maybe Day -> Maybe Cycle -> Day -> Maybe [ShiftedDay] -_SCHED_IPCI_NAM scfg _IED _PRCL _PRANX _IPCED _IPANX _IPCL _MD = - let maybeS | isNothing _PRANX = Just $ _IED `plusCycle` fromJust _PRCL - | otherwise = _PRANX +_SCHED_IPCI_NAM :: ContractTerms -> Maybe [ShiftedDay] +_SCHED_IPCI_NAM ContractTerms{..} = + let s | isNothing ct_PRANX = liftA2 plusCycle ct_IED ct_PRCL + | otherwise = ct_PRANX - _T = fromJust maybeS `minusCycle` fromJust _PRCL + _T = liftA2 minusCycle s ct_PRCL - r | isJust _IPCED = _IPCED - | isJust _IPANX = _IPANX - | isJust _IPCL = Just $ _IED `plusCycle` fromJust _IPCL - | otherwise = Nothing + r | isJust ct_IPCED = ct_IPCED + | isJust ct_IPANX = ct_IPANX + | isJust ct_IPCL = liftA2 plusCycle ct_IED ct_IPCL + | otherwise = Nothing - u | isNothing _IPANX && isNothing _IPCL = Nothing - | isJust _IPCED && fromJust _IPCED > _T = Nothing - | otherwise = (\s -> _S s (fromJust _IPCL){ includeEndDay = True } _MD scfg) <$> r + u | isNothing ct_IPANX && isNothing ct_IPCL = Nothing + | isJust ct_IPCED && fromMaybe False (liftA2 (>) ct_IPCED _T) = Nothing + | otherwise = _S r ((\c -> c { includeEndDay = True }) <$> ct_IPCL) ct_MD (Just scfg) - v = (\s -> _S s (fromJust _PRCL) _MD scfg) <$> maybeS + v = _S s ct_PRCL ct_MD (Just scfg) result = Just $ nub (fromMaybe [] u ++ fromMaybe [] v) - result' | isJust result && isJust _IPCED = Just $ filter (\ss -> calculationDay ss <= fromJust _IPCED) $ fromJust result + result' | isJust result && isJust ct_IPCED = filter (\ShiftedDay{..} -> Just calculationDay <= ct_IPCED) <$> result | otherwise = Nothing in result' -- Annuity (ANN) -_SCHED_PRF_ANN :: Maybe Day -> Maybe Double -> Maybe Day -> Maybe ShiftedSchedule -_SCHED_PRF_ANN _PRANX _PRNXT _IED = - let result | isJust _PRANX && isNothing _PRNXT && _PRANX > _IED = let previousDay = addDays (-1) $ fromJust _PRANX in Just [ShiftedDay previousDay previousDay] - | otherwise = Nothing +_SCHED_PRF_ANN :: ContractTerms -> Maybe ShiftedSchedule +_SCHED_PRF_ANN ContractTerms{..} = + let result | isJust ct_PRANX && isNothing ct_PRNXT && ct_PRANX > ct_IED = ct_PRANX >>= (\p -> Just [ShiftedDay p p]) . addDays (-1) + | otherwise = Nothing in result From b485ccd7c761064b35feca7766281ad261d279ab Mon Sep 17 00:00:00 2001 From: Yves Hauser Date: Tue, 31 Aug 2021 09:56:48 +0200 Subject: [PATCH 06/28] scp-2709 - small refactorings * StateInitializationFs removed, as state transalted to Marlowe after initialization * more concise functions * typos --- marlowe-actus/marlowe-actus.cabal | 3 - .../src/Language/Marlowe/ACTUS/Analysis.hs | 281 +++++++----------- .../ACTUS/Definitions/BusinessEvents.hs | 4 + .../ACTUS/Definitions/ContractTerms.hs | 105 ++----- .../src/Language/Marlowe/ACTUS/Generator.hs | 56 ++-- .../ACTUS/Model/INIT/StateInitialization.hs | 4 +- .../ACTUS/Model/INIT/StateInitializationFs.hs | 29 -- 7 files changed, 185 insertions(+), 297 deletions(-) delete mode 100644 marlowe-actus/src/Language/Marlowe/ACTUS/Model/INIT/StateInitializationFs.hs diff --git a/marlowe-actus/marlowe-actus.cabal b/marlowe-actus/marlowe-actus.cabal index 514f3fb2811..7560bf7b73c 100644 --- a/marlowe-actus/marlowe-actus.cabal +++ b/marlowe-actus/marlowe-actus.cabal @@ -67,7 +67,6 @@ library Language.Marlowe.ACTUS.Model.SCHED.ContractSchedule Language.Marlowe.ACTUS.Model.INIT.StateInitializationModel Language.Marlowe.ACTUS.Model.INIT.StateInitialization - Language.Marlowe.ACTUS.Model.INIT.StateInitializationFs Language.Marlowe.ACTUS.Model.APPLICABILITY.Applicability Language.Marlowe.ACTUS.Model.APPLICABILITY.ApplicabilityModel Language.Marlowe.ACTUS.Model.Utility.ANN.Annuity @@ -105,7 +104,6 @@ executable marlowe-shiny Language.Marlowe.ACTUS.Model.SCHED.ContractSchedule Language.Marlowe.ACTUS.Model.INIT.StateInitializationModel Language.Marlowe.ACTUS.Model.INIT.StateInitialization - Language.Marlowe.ACTUS.Model.INIT.StateInitializationFs Language.Marlowe.ACTUS.Model.Utility.DateShift Language.Marlowe.ACTUS.Model.Utility.ScheduleGenerator Language.Marlowe.ACTUS.Model.Utility.YearFraction @@ -162,7 +160,6 @@ executable marlowe-actus-test-kit Language.Marlowe.ACTUS.Model.SCHED.ContractSchedule Language.Marlowe.ACTUS.Model.INIT.StateInitializationModel Language.Marlowe.ACTUS.Model.INIT.StateInitialization - Language.Marlowe.ACTUS.Model.INIT.StateInitializationFs Language.Marlowe.ACTUS.Model.Utility.DateShift Language.Marlowe.ACTUS.Model.Utility.ScheduleGenerator Language.Marlowe.ACTUS.Model.Utility.YearFraction diff --git a/marlowe-actus/src/Language/Marlowe/ACTUS/Analysis.hs b/marlowe-actus/src/Language/Marlowe/ACTUS/Analysis.hs index 916c80cffdb..451ab1b27f5 100644 --- a/marlowe-actus/src/Language/Marlowe/ACTUS/Analysis.hs +++ b/marlowe-actus/src/Language/Marlowe/ACTUS/Analysis.hs @@ -1,189 +1,122 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TupleSections #-} -module Language.Marlowe.ACTUS.Analysis(sampleCashflows, genProjectedCashflows, genZeroRiskAssertions) where - -import Control.Applicative -import qualified Data.List as L (dropWhile, filter, find, groupBy, scanl, - tail, zip) -import qualified Data.Map as M (empty, fromList, lookup) -import Data.Maybe (fromJust, fromMaybe, isJust, isNothing) +module Language.Marlowe.ACTUS.Analysis + (genProjectedCashflows) +where + +import Control.Applicative (Alternative ((<|>))) +import qualified Data.List as L (dropWhile, find, groupBy, scanl, tail, zip) +import qualified Data.Map as M (fromList, lookup) +import Data.Maybe (fromJust, fromMaybe, isNothing) import Data.Sort (sortOn) import Data.Time (Day) - -import Language.Marlowe (Contract (Assert), Observation (..), Value (..)) import Language.Marlowe.ACTUS.Definitions.BusinessEvents (DataObserved, EventType (..), RiskFactors (..), ValueObserved (..), ValuesObserved (..)) import Language.Marlowe.ACTUS.Definitions.ContractState (ContractState) -import Language.Marlowe.ACTUS.Definitions.ContractTerms (Assertion (..), CT (..), ContractTerms (..)) +import Language.Marlowe.ACTUS.Definitions.ContractTerms (CT (..), ContractTerms (..)) import Language.Marlowe.ACTUS.Definitions.Schedule (CashFlow (..), ShiftedDay (..), calculationDay, paymentDay) -import Language.Marlowe.ACTUS.MarloweCompat (constnt, useval) -import Language.Marlowe.ACTUS.Model.INIT.StateInitialization (inititializeState) +import Language.Marlowe.ACTUS.Model.INIT.StateInitialization (initializeState) import Language.Marlowe.ACTUS.Model.POF.Payoff (payoff) import Language.Marlowe.ACTUS.Model.SCHED.ContractSchedule (schedule) import Language.Marlowe.ACTUS.Model.STF.StateTransition (stateTransition) import Language.Marlowe.ACTUS.Model.Utility.ANN.Maturity (maturity) -import Language.Marlowe.ACTUS.Ops (ActusNum (..), YearFractionOps (_y)) -import Prelude hiding (Fractional, Num, (*), (+), (-), (/)) - - genProjectedCashflows :: DataObserved -> ContractTerms -> [CashFlow] -genProjectedCashflows = sampleCashflows - -postProcessSchedule :: ContractTerms -> [(EventType, ShiftedDay)] -> [(EventType, ShiftedDay)] -postProcessSchedule ct = - let trim = L.dropWhile (\(_, d) -> calculationDay d < ct_SD ct) - prioritised = [IED, FP, PR, PD, PY, PP, IP, IPCI, CE, RRF, RR, PRF, DV, PRD, MR, TD, SC, IPCB, MD, XD, STD, AD] - - priority :: (EventType, ShiftedDay) -> Integer - priority (event, _) = fromJust $ M.lookup event $ M.fromList (zip prioritised [1..]) - - similarity (_, l) (_, r) = calculationDay l == calculationDay r - regroup = L.groupBy similarity - - overwrite = map (sortOn priority) . regroup - in concat . (overwrite . trim) - - -sampleCashflows :: DataObserved -> ContractTerms -> [CashFlow] -sampleCashflows dataObserved ct@ContractTerms{..} = - let - -- schedule - scheduleEvent e = maybe [] (fmap (e,)) (schedule e ct) - - -- events - eventTypes = [IED, MD, RR, RRF, IP, PR, PRF, IPCB, IPCI, PRD, TD, SC] - - events = sortOn (paymentDay . snd) $ concatMap scheduleEvent eventTypes - events' = postProcessSchedule ct events - events'' = filterEvents ct events' - - -- states - applyStateTransition (st, ev, date) (ev', date') = - (stateTransition ev (getRiskFactors dataObserved ev (calculationDay date) ct) ct st (calculationDay date), ev', date') - - initialState = (inititializeState ct ,AD ,ShiftedDay ct_SD ct_SD) - - states = L.tail $ L.scanl applyStateTransition initialState events'' - states' = filterStates ct states - - -- payoff - calculatePayoff (st, ev, date) = - payoff ev (getRiskFactors dataObserved ev (calculationDay date) ct) ct st (calculationDay date) - payoffs = calculatePayoff <$> states' - - genCashflow ((_, ev, d), pff) = CashFlow - { tick = 0 - , cashContractId = "0" - , cashParty = "party" - , cashCounterParty = "counterparty" - , cashPaymentDay = paymentDay d - , cashCalculationDay = calculationDay d - , cashEvent = ev - , amount = pff - , currency = "ada" - } - in - sortOn cashPaymentDay $ genCashflow <$> L.zip states' payoffs - -filterEvents :: ContractTerms -> [(EventType, ShiftedDay)] -> [(EventType, ShiftedDay)] -filterEvents terms@ContractTerms{ contractType = contractType } events = - case contractType of - PAM -> - if isJust (ct_TD terms) then - L.filter (\(_, ShiftedDay{..}) -> calculationDay <= fromJust (ct_TD terms)) events - else - events - LAM -> - if isJust (ct_TD terms) then - L.filter (\(_, ShiftedDay{..}) -> calculationDay <= fromJust (ct_TD terms)) events - else - events - NAM -> - if isJust (ct_TD terms) then - L.filter (\(_, ShiftedDay{..}) -> calculationDay <= fromJust (ct_TD terms)) events - else - events - ANN -> - if isJust (ct_TD terms) then - L.filter (\(_, ShiftedDay{..}) -> calculationDay <= fromJust (ct_TD terms)) events - else - events - -filterStates :: ContractTerms -> [(ContractState, EventType, ShiftedDay)] -> [(ContractState, EventType, ShiftedDay)] -filterStates ct@ContractTerms{..} states = - case contractType of - PAM -> - if isJust ct_PRD then - L.filter (\(_, _, ShiftedDay{..}) -> calculationDay >= fromJust ct_PRD) states - else - states - LAM -> - if isJust ct_PRD then - L.filter (\(_, eventType, ShiftedDay{..}) -> eventType == PRD || calculationDay > fromJust ct_PRD) states - else - states - NAM -> - if isJust ct_PRD then - L.filter (\(_, eventType, ShiftedDay{..}) -> eventType == PRD || calculationDay > fromJust ct_PRD) states - else - states - ANN -> - let states' = if isJust ct_PRD then - L.filter (\(_, eventType, ShiftedDay{..}) -> eventType == PRD || calculationDay > fromJust ct_PRD) states - else states - in - let m = ct_MD <|> ct_AD <|> maturity ct - f (_, PR, ShiftedDay{..}) = isNothing m || Just calculationDay <= m - f (_, _, _) = True - in L.filter f states' - -genZeroRiskAssertions :: ContractTerms -> Assertion -> Contract -> Contract -genZeroRiskAssertions terms@ContractTerms{..} NpvAssertionAgainstZeroRiskBond{..} continue = - let - cfs = genProjectedCashflows M.empty terms - - dateToYearFraction :: Day -> Double - dateToYearFraction dt = _y (fromJust ct_DCC) ct_SD dt ct_MD - - dateToDiscountFactor dt = (1 - zeroRiskInterest) ** dateToYearFraction dt - - accumulateAndDiscount :: Value Observation -> (CashFlow, Integer) -> Value Observation - accumulateAndDiscount acc (cf, t) = - let discountFactor = dateToDiscountFactor $ cashCalculationDay cf - sign x = if amount cf < 0.0 then NegValue x else x - in constnt discountFactor * (sign $ useval "payoff" t) + acc - npv = foldl accumulateAndDiscount (constnt 0) (zip cfs [1..]) - in Assert (ValueLT (constnt expectedNpv) npv) continue - -getRiskFactors :: DataObserved -> EventType -> Day -> ContractTerms -> RiskFactors -getRiskFactors dataObserved ev date ContractTerms{..} = - let riskFactors = - RiskFactors { - o_rf_CURS = 1.0 - , o_rf_RRMO = 1.0 - , o_rf_SCMO = 1.0 - , pp_payoff = 0.0 - } - observedKey = - case ev of - RR -> - ct_RRMO - SC -> - ct_SCMO - _ -> - ct_CURS - value = fromMaybe 1.0 $ do observedKey' <- observedKey - ValuesObserved{ values = values } <- M.lookup observedKey' dataObserved - ValueObserved{ value = valueObserved } <- - L.find (\ ValueObserved { timestamp = timestamp } -> timestamp == date) values - return valueObserved - in - case ev of - RR -> - riskFactors { o_rf_RRMO = value } - SC -> - riskFactors { o_rf_SCMO = value } - _ -> - riskFactors { o_rf_CURS = value } +genProjectedCashflows dataObserved ct@ContractTerms {..} = + let -- schedule + scheduleEvent e = maybe [] (fmap (e,)) (schedule e ct) + + -- events + eventTypes = [IED, MD, RR, RRF, IP, PR, PRF, IPCB, IPCI, PRD, TD, SC] + + events = + let e = concatMap scheduleEvent eventTypes + in filter filtersEvents . postProcessSchedule . sortOn (paymentDay . snd) $ e + + -- states + applyStateTransition (st, ev, date) (ev', date') = + let t = calculationDay date + rf = getRiskFactors ev t + in (stateTransition ev rf ct st t, ev', date') + + states = + let initialState = (initializeState ct, AD, ShiftedDay ct_SD ct_SD) + in filter filtersStates $ L.tail $ L.scanl applyStateTransition initialState events + + -- payoff + calculatePayoff (st, ev, date) = + let t = calculationDay date + rf = getRiskFactors ev t + in payoff ev rf ct st t + + payoffs = calculatePayoff <$> states + + genCashflow ((_, ev, d), pff) = + CashFlow + { tick = 0, + cashContractId = "0", + cashParty = "party", + cashCounterParty = "counterparty", + cashPaymentDay = paymentDay d, + cashCalculationDay = calculationDay d, + cashEvent = ev, + amount = pff, + currency = "ada" + } + + in sortOn cashPaymentDay $ genCashflow <$> L.zip states payoffs + + where + + filtersEvents :: (EventType, ShiftedDay) -> Bool + filtersEvents (_, ShiftedDay {..}) = isNothing ct_TD || Just calculationDay <= ct_TD + + filtersStates :: (ContractState, EventType, ShiftedDay) -> Bool + filtersStates (_, ev, ShiftedDay {..}) = + case contractType of + PAM -> isNothing ct_PRD || Just calculationDay >= ct_PRD + LAM -> isNothing ct_PRD || ev == PRD || Just calculationDay > ct_PRD + NAM -> isNothing ct_PRD || ev == PRD || Just calculationDay > ct_PRD + ANN -> + let b1 = isNothing ct_PRD || ev == PRD || Just calculationDay > ct_PRD + b2 = let m = ct_MD <|> ct_AD <|> maturity ct in isNothing m || Just calculationDay <= m + in b1 && b2 + + postProcessSchedule :: [(EventType, ShiftedDay)] -> [(EventType, ShiftedDay)] + postProcessSchedule = + let trim = L.dropWhile (\(_, d) -> calculationDay d < ct_SD) + prioritised = [IED, FP, PR, PD, PY, PP, IP, IPCI, CE, RRF, RR, PRF, DV, PRD, MR, TD, SC, IPCB, MD, XD, STD, AD] + + priority :: (EventType, ShiftedDay) -> Integer + priority (event, _) = fromJust $ M.lookup event $ M.fromList (zip prioritised [1 ..]) + + similarity (_, l) (_, r) = calculationDay l == calculationDay r + regroup = L.groupBy similarity + + overwrite = map (sortOn priority) . regroup + in concat . (overwrite . trim) + + getRiskFactors :: EventType -> Day -> RiskFactors + getRiskFactors ev date = + let riskFactors = + RiskFactors + { o_rf_CURS = 1.0, + o_rf_RRMO = 1.0, + o_rf_SCMO = 1.0, + pp_payoff = 0.0 + } + + observedKey RR = ct_RRMO + observedKey SC = ct_SCMO + observedKey _ = ct_CURS + + value = fromMaybe 1.0 $ do + k <- observedKey ev + ValuesObserved {values = values} <- M.lookup k dataObserved + ValueObserved {value = valueObserved} <- L.find (\ValueObserved {timestamp = timestamp} -> timestamp == date) values + return valueObserved + in case ev of + RR -> riskFactors {o_rf_RRMO = value} + SC -> riskFactors {o_rf_SCMO = value} + _ -> riskFactors {o_rf_CURS = value} diff --git a/marlowe-actus/src/Language/Marlowe/ACTUS/Definitions/BusinessEvents.hs b/marlowe-actus/src/Language/Marlowe/ACTUS/Definitions/BusinessEvents.hs index e108df5e25a..ddf63029225 100644 --- a/marlowe-actus/src/Language/Marlowe/ACTUS/Definitions/BusinessEvents.hs +++ b/marlowe-actus/src/Language/Marlowe/ACTUS/Definitions/BusinessEvents.hs @@ -38,6 +38,8 @@ data EventType = | PD -- Principal Drawing deriving (Eq, Show, Read, Ord) +{-| Risk factor observer +-} data RiskFactors = RiskFactors { o_rf_CURS :: Double , o_rf_RRMO :: Double @@ -47,6 +49,8 @@ data RiskFactors = RiskFactors deriving stock (Generic) deriving (Show, ToJSON) +{-| Observed data +-} type DataObserved = Map String ValuesObserved data ValuesObserved = ValuesObserved diff --git a/marlowe-actus/src/Language/Marlowe/ACTUS/Definitions/ContractTerms.hs b/marlowe-actus/src/Language/Marlowe/ACTUS/Definitions/ContractTerms.hs index eeae525b8b7..4a4e15d79a4 100644 --- a/marlowe-actus/src/Language/Marlowe/ACTUS/Definitions/ContractTerms.hs +++ b/marlowe-actus/src/Language/Marlowe/ACTUS/Definitions/ContractTerms.hs @@ -261,79 +261,40 @@ data ContractTerms = ContractTerms deriving stock (Show, Generic) deriving anyclass (FromJSON, ToJSON) -defaultSCIP :: Double -defaultSCIP = 1 - -defaultPDIED :: Double -defaultPDIED = 0 - -defaultSCNT :: Double -defaultSCNT = 1 - -defaultPYRT :: Double -defaultPYRT = 0 - -defaultRRSP :: Double -defaultRRSP = 0 - -defaultRRMLT :: Double -defaultRRMLT = 1.0 - -infinity :: Double -infinity = 1/0 :: Double - -applyDefault :: a -> Maybe a -> Maybe a -applyDefault v = Just . fromMaybe v - setDefaultContractTermValues :: ContractTerms -> ContractTerms setDefaultContractTermValues ct@ContractTerms{..} = - let ScheduleConfig{..} = scfg - eomc' = applyDefault EOMC_SD eomc - bdc' = applyDefault BDC_NULL bdc - calendar' = applyDefault CLDR_NC calendar - _PRF = applyDefault PRF_PF ct_PRF - _IPCB = applyDefault IPCB_NT ct_IPCB - _PDIED = applyDefault defaultPDIED ct_PDIED - _SCEF = applyDefault SE_000 ct_SCEF - _PYRT = applyDefault defaultPYRT ct_PYRT - _PYTP = applyDefault PYTP_O ct_PYTP - _PPEF = applyDefault PPEF_N ct_PPEF - _RRSP = applyDefault defaultRRSP ct_RRSP - _RRMLT = applyDefault defaultRRMLT ct_RRMLT - _FEAC = applyDefault 0.0 ct_FEAC - _FER = applyDefault 0.0 ct_FER - _IPAC = applyDefault 0.0 ct_IPAC - _IPNR = applyDefault 0.0 ct_IPNR - _PPRD = applyDefault 0.0 ct_PPRD - _PTD = applyDefault 0.0 ct_PTD - _SCCDD = applyDefault 0.0 ct_SCCDD - _RRPF = applyDefault (-infinity) ct_RRPF - _RRPC = applyDefault infinity ct_RRPC - _RRLC = applyDefault infinity ct_RRLC - _RRLF = applyDefault (-infinity) ct_RRLF - _IPCBA = applyDefault 0.0 ct_IPCBA - in + let ScheduleConfig{..} = scfg in ct { - scfg = scfg { eomc = eomc', bdc = bdc', calendar = calendar' } - , ct_PRF = _PRF - , ct_IPCB = _IPCB - , ct_PDIED = _PDIED - , ct_SCEF = _SCEF - , ct_PYRT = _PYRT - , ct_PYTP = _PYTP - , ct_PPEF = _PPEF - , ct_RRSP = _RRSP - , ct_RRMLT = _RRMLT - , ct_FEAC = _FEAC - , ct_FER = _FER - , ct_IPAC = _IPAC - , ct_IPNR = _IPNR - , ct_PPRD = _PPRD - , ct_PTD = _PTD - , ct_SCCDD = _SCCDD - , ct_RRPF = _RRPF - , ct_RRPC = _RRPC - , ct_RRLC = _RRLC - , ct_RRLF = _RRLF - , ct_IPCBA = _IPCBA + scfg = scfg + { eomc = applyDefault EOMC_SD eomc + , bdc = applyDefault BDC_NULL bdc + , calendar = applyDefault CLDR_NC calendar + } + , ct_PRF = applyDefault PRF_PF ct_PRF + , ct_IPCB = applyDefault IPCB_NT ct_IPCB + , ct_PDIED = applyDefault 0.0 ct_PDIED + , ct_SCEF = applyDefault SE_000 ct_SCEF + , ct_PYRT = applyDefault 0.0 ct_PYRT + , ct_PYTP = applyDefault PYTP_O ct_PYTP + , ct_PPEF = applyDefault PPEF_N ct_PPEF + , ct_RRSP = applyDefault 0.0 ct_RRSP + , ct_RRMLT = applyDefault 1.0 ct_RRMLT + , ct_FEAC = applyDefault 0.0 ct_FEAC + , ct_FER = applyDefault 0.0 ct_FER + , ct_IPAC = applyDefault 0.0 ct_IPAC + , ct_IPNR = applyDefault 0.0 ct_IPNR + , ct_PPRD = applyDefault 0.0 ct_PPRD + , ct_PTD = applyDefault 0.0 ct_PTD + , ct_SCCDD = applyDefault 0.0 ct_SCCDD + , ct_RRPF = applyDefault (-infinity) ct_RRPF + , ct_RRPC = applyDefault infinity ct_RRPC + , ct_RRLC = applyDefault infinity ct_RRLC + , ct_RRLF = applyDefault (-infinity) ct_RRLF + , ct_IPCBA = applyDefault 0.0 ct_IPCBA } + where + infinity :: Double + infinity = 1/0 :: Double + + applyDefault :: a -> Maybe a -> Maybe a + applyDefault v = Just . fromMaybe v diff --git a/marlowe-actus/src/Language/Marlowe/ACTUS/Generator.hs b/marlowe-actus/src/Language/Marlowe/ACTUS/Generator.hs index fa9384c6b12..4e36e14edb3 100644 --- a/marlowe-actus/src/Language/Marlowe/ACTUS/Generator.hs +++ b/marlowe-actus/src/Language/Marlowe/ACTUS/Generator.hs @@ -10,33 +10,33 @@ where import qualified Data.List as L (foldl', zip6) import Data.Map as M (empty) -import Data.Maybe (fromMaybe, isNothing, maybeToList) -import Data.Monoid +import Data.Maybe (fromJust, fromMaybe, isNothing, maybeToList) +import Data.Monoid (Endo (Endo, appEndo)) import Data.String (IsString (fromString)) import Data.Time (Day) import Data.Validation (Validation (..)) -import Language.Marlowe (Action (Choice, Deposit), Bound (Bound), - Case (Case), ChoiceId (ChoiceId), - Contract (Close, Let, Pay, When), - Observation, Party (Role), Payee (Party), - Slot (..), - Value (ChoiceValue, Constant, NegValue, UseValue), - ValueId (ValueId), ada) -import Language.Marlowe.ACTUS.Analysis (genProjectedCashflows, genZeroRiskAssertions) +import Language.Marlowe (Action (..), Bound (..), Case (..), + ChoiceId (..), Contract (..), + Observation (..), Party (..), Payee (..), + Slot (..), Value (..), ValueId (ValueId), + ada) +import Language.Marlowe.ACTUS.Analysis (genProjectedCashflows) import Language.Marlowe.ACTUS.Definitions.BusinessEvents (EventType (..)) -import Language.Marlowe.ACTUS.Definitions.ContractTerms (AssertionContext (..), Assertions (..), - ContractTerms (collateralAmount, constraints, ct_SD, enableSettlement), +import Language.Marlowe.ACTUS.Definitions.ContractTerms (Assertion (..), AssertionContext (..), + Assertions (..), ContractTerms (..), TermValidationError (..), setDefaultContractTermValues) import Language.Marlowe.ACTUS.Definitions.Schedule (CashFlow (..)) import Language.Marlowe.ACTUS.MarloweCompat (constnt, dayToSlotNumber, - toMarloweFixedPoint) + stateInitialisation, toMarloweFixedPoint, + useval) import Language.Marlowe.ACTUS.Model.APPLICABILITY.Applicability (validateTerms) -import Language.Marlowe.ACTUS.Model.INIT.StateInitializationFs (inititializeStateFs) +import Language.Marlowe.ACTUS.Model.INIT.StateInitialization (initializeState) import Language.Marlowe.ACTUS.Model.POF.PayoffFs (payoffFs) import Language.Marlowe.ACTUS.Model.STF.StateTransitionFs (stateTransitionFs) +import Language.Marlowe.ACTUS.Ops as O (ActusNum (..), YearFractionOps (_y)) import Ledger.Value (TokenName (TokenName)) - +import Prelude as P hiding (Fractional, Num, (*), (+), (/)) receiveCollateral :: String -> Integer -> Integer -> Contract -> Contract receiveCollateral from amount timeout continue = @@ -208,8 +208,30 @@ genFsContract terms = genContract . setDefaultContractTermValues <$> validateTer -- (Constant $ collateralAmount terms) date cont - where pof = payoffFs ev terms' t (t - 1) prevDate (cashCalculationDay cf) + where pof = payoffFs ev terms' t (t P.- 1) prevDate (cashCalculationDay cf) scheduleAcc = foldr gen (postProcess Close) $ L.zip6 schedCfs previousDates schedEvents schedDates cfsDirections [1..] withCollateral cont = receiveCollateral "counterparty" (collateralAmount terms') (dayToSlotNumber $ ct_SD terms') cont - in withCollateral $ inititializeStateFs terms' scheduleAcc + in withCollateral $ initializeStateFs terms' scheduleAcc + + initializeStateFs :: ContractTerms -> Contract -> Contract + initializeStateFs ct cont = let s = initializeState ct in stateInitialisation s cont + +genZeroRiskAssertions :: ContractTerms -> Assertion -> Contract -> Contract +genZeroRiskAssertions terms@ContractTerms{..} NpvAssertionAgainstZeroRiskBond{..} continue = + let + cfs = genProjectedCashflows M.empty terms + + dateToYearFraction :: Day -> Double + dateToYearFraction dt = _y (fromJust ct_DCC) ct_SD dt ct_MD + + dateToDiscountFactor dt = (1 O.- zeroRiskInterest) ** dateToYearFraction dt + + accumulateAndDiscount :: Value Observation -> (CashFlow, Integer) -> Value Observation + accumulateAndDiscount acc (cf, t) = + let discountFactor = dateToDiscountFactor $ cashCalculationDay cf + sign x = if amount cf < 0.0 then NegValue x else x + in constnt discountFactor * (sign $ useval "payoff" t) + acc + + npv = foldl accumulateAndDiscount (constnt 0) (zip cfs [1..]) + in Assert (ValueLT (constnt expectedNpv) npv) continue diff --git a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/INIT/StateInitialization.hs b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/INIT/StateInitialization.hs index dc1866cc7d1..136d8b6df82 100644 --- a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/INIT/StateInitialization.hs +++ b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/INIT/StateInitialization.hs @@ -12,8 +12,8 @@ import Language.Marlowe.ACTUS.Model.Utility.ANN.Maturity (mat import Language.Marlowe.ACTUS.Model.Utility.ScheduleGenerator (inf, sup) import Language.Marlowe.ACTUS.Ops (YearFractionOps (_y)) -inititializeState :: ContractTerms -> ContractState -inititializeState terms@ContractTerms {..} = +initializeState :: ContractTerms -> ContractState +initializeState terms@ContractTerms {..} = let t0 = ct_SD -- PAM fpSchedule = schedule FP terms diff --git a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/INIT/StateInitializationFs.hs b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/INIT/StateInitializationFs.hs deleted file mode 100644 index ea9cb8d9b27..00000000000 --- a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/INIT/StateInitializationFs.hs +++ /dev/null @@ -1,29 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} -module Language.Marlowe.ACTUS.Model.INIT.StateInitializationFs where - -import Language.Marlowe -import Language.Marlowe.ACTUS.Definitions.BusinessEvents (EventType (FP, IP, PR)) -import Language.Marlowe.ACTUS.Definitions.ContractTerms (CT (LAM, NAM, PAM), ContractTerms (..)) -import Language.Marlowe.ACTUS.Definitions.Schedule (ShiftedDay (calculationDay)) -import Language.Marlowe.ACTUS.MarloweCompat (stateInitialisation) -import Language.Marlowe.ACTUS.Model.INIT.StateInitializationModel (_INIT_LAM, _INIT_NAM, _INIT_PAM) -import Language.Marlowe.ACTUS.Model.SCHED.ContractSchedule (schedule) -import Language.Marlowe.ACTUS.Model.Utility.ScheduleGenerator (inf, sup) - -inititializeStateFs :: ContractTerms -> Contract -> Contract -inititializeStateFs terms@ContractTerms {..} continue = - let t0 = ct_SD - -- PAM - fpSchedule = schedule FP terms - tfp_minus = maybe t0 calculationDay ((\sc -> sup sc t0) =<< fpSchedule) - tfp_plus = maybe t0 calculationDay ((\sc -> inf sc t0) =<< fpSchedule) - ipSchedule = schedule IP terms - tminus = maybe t0 calculationDay ((\sc -> sup sc t0) =<< ipSchedule) - -- LAM, NAM - prSchedule = schedule PR terms - tpr_minus = maybe t0 calculationDay ((\sc -> sup sc t0) =<< prSchedule) - initialState = case contractType of - PAM -> _INIT_PAM t0 tminus tfp_minus tfp_plus terms - LAM -> _INIT_LAM t0 tminus tpr_minus tfp_minus tfp_plus terms - NAM -> _INIT_NAM t0 tminus tpr_minus tfp_minus tfp_plus terms - in stateInitialisation initialState continue From b33e28558f501aae1727baa66004f225a8fbc3e3 Mon Sep 17 00:00:00 2001 From: Yves Hauser Date: Tue, 31 Aug 2021 11:41:46 +0200 Subject: [PATCH 07/28] scp-2709 - moved maturity into ContractSchedule --- marlowe-actus/marlowe-actus.cabal | 1 - .../src/Language/Marlowe/ACTUS/Analysis.hs | 6 +- .../ACTUS/Model/INIT/StateInitialization.hs | 3 +- .../ACTUS/Model/SCHED/ContractSchedule.hs | 245 ++++++++++-------- .../Model/SCHED/ContractScheduleModel.hs | 13 +- .../ACTUS/Model/STF/StateTransition.hs | 11 +- .../ACTUS/Model/Utility/ANN/Maturity.hs | 71 ----- 7 files changed, 159 insertions(+), 191 deletions(-) delete mode 100644 marlowe-actus/src/Language/Marlowe/ACTUS/Model/Utility/ANN/Maturity.hs diff --git a/marlowe-actus/marlowe-actus.cabal b/marlowe-actus/marlowe-actus.cabal index 7560bf7b73c..8af86e7f2b4 100644 --- a/marlowe-actus/marlowe-actus.cabal +++ b/marlowe-actus/marlowe-actus.cabal @@ -70,7 +70,6 @@ library Language.Marlowe.ACTUS.Model.APPLICABILITY.Applicability Language.Marlowe.ACTUS.Model.APPLICABILITY.ApplicabilityModel Language.Marlowe.ACTUS.Model.Utility.ANN.Annuity - Language.Marlowe.ACTUS.Model.Utility.ANN.Maturity Language.Marlowe.ACTUS.Model.Utility.DateShift Language.Marlowe.ACTUS.Model.Utility.ScheduleGenerator Language.Marlowe.ACTUS.Model.Utility.YearFraction diff --git a/marlowe-actus/src/Language/Marlowe/ACTUS/Analysis.hs b/marlowe-actus/src/Language/Marlowe/ACTUS/Analysis.hs index 451ab1b27f5..1fb83c5474b 100644 --- a/marlowe-actus/src/Language/Marlowe/ACTUS/Analysis.hs +++ b/marlowe-actus/src/Language/Marlowe/ACTUS/Analysis.hs @@ -18,9 +18,8 @@ import Language.Marlowe.ACTUS.Definitions.Schedule (CashFlow paymentDay) import Language.Marlowe.ACTUS.Model.INIT.StateInitialization (initializeState) import Language.Marlowe.ACTUS.Model.POF.Payoff (payoff) -import Language.Marlowe.ACTUS.Model.SCHED.ContractSchedule (schedule) +import Language.Marlowe.ACTUS.Model.SCHED.ContractSchedule (maturity, schedule) import Language.Marlowe.ACTUS.Model.STF.StateTransition (stateTransition) -import Language.Marlowe.ACTUS.Model.Utility.ANN.Maturity (maturity) genProjectedCashflows :: DataObserved -> ContractTerms -> [CashFlow] genProjectedCashflows dataObserved ct@ContractTerms {..} = @@ -42,7 +41,7 @@ genProjectedCashflows dataObserved ct@ContractTerms {..} = states = let initialState = (initializeState ct, AD, ShiftedDay ct_SD ct_SD) - in filter filtersStates $ L.tail $ L.scanl applyStateTransition initialState events + in filter filtersStates . L.tail $ L.scanl applyStateTransition initialState events -- payoff calculatePayoff (st, ev, date) = @@ -116,6 +115,7 @@ genProjectedCashflows dataObserved ct@ContractTerms {..} = ValuesObserved {values = values} <- M.lookup k dataObserved ValueObserved {value = valueObserved} <- L.find (\ValueObserved {timestamp = timestamp} -> timestamp == date) values return valueObserved + in case ev of RR -> riskFactors {o_rf_RRMO = value} SC -> riskFactors {o_rf_SCMO = value} diff --git a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/INIT/StateInitialization.hs b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/INIT/StateInitialization.hs index 136d8b6df82..c749a895ea4 100644 --- a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/INIT/StateInitialization.hs +++ b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/INIT/StateInitialization.hs @@ -7,8 +7,7 @@ import Language.Marlowe.ACTUS.Definitions.ContractState (Con import Language.Marlowe.ACTUS.Definitions.ContractTerms (CT (..), ContractTerms (..)) import Language.Marlowe.ACTUS.Definitions.Schedule (ShiftedDay (calculationDay)) import Language.Marlowe.ACTUS.Model.INIT.StateInitializationModel (_INIT_ANN, _INIT_LAM, _INIT_NAM, _INIT_PAM) -import Language.Marlowe.ACTUS.Model.SCHED.ContractSchedule (schedule) -import Language.Marlowe.ACTUS.Model.Utility.ANN.Maturity (maturity) +import Language.Marlowe.ACTUS.Model.SCHED.ContractSchedule (maturity, schedule) import Language.Marlowe.ACTUS.Model.Utility.ScheduleGenerator (inf, sup) import Language.Marlowe.ACTUS.Ops (YearFractionOps (_y)) diff --git a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/SCHED/ContractSchedule.hs b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/SCHED/ContractSchedule.hs index 2d511ebad65..44080415b78 100644 --- a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/SCHED/ContractSchedule.hs +++ b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/SCHED/ContractSchedule.hs @@ -3,112 +3,151 @@ module Language.Marlowe.ACTUS.Model.SCHED.ContractSchedule where import Control.Applicative (Alternative ((<|>))) -import Data.Maybe (fromMaybe) +import Data.Ord (Down (..)) +import Data.Sort (sortOn) +import Data.Time (Day) import Language.Marlowe.ACTUS.Definitions.BusinessEvents (EventType (..)) import Language.Marlowe.ACTUS.Definitions.ContractState (ContractStatePoly (tmd)) -import Language.Marlowe.ACTUS.Definitions.ContractTerms (CT (..), ContractTerms (..)) -import Language.Marlowe.ACTUS.Definitions.Schedule (ShiftedDay (calculationDay)) +import Language.Marlowe.ACTUS.Definitions.ContractTerms (CT (..), ContractTerms (..), Cycle (..), + DCC, ScheduleConfig) +import Language.Marlowe.ACTUS.Definitions.Schedule (ShiftedDay (ShiftedDay, calculationDay, paymentDay), + ShiftedSchedule) import Language.Marlowe.ACTUS.Model.INIT.StateInitializationModel (_INIT_LAM, _INIT_NAM) import Language.Marlowe.ACTUS.Model.SCHED.ContractScheduleModel -import Language.Marlowe.ACTUS.Model.Utility.ANN.Maturity (maturity) -import Language.Marlowe.ACTUS.Model.Utility.ScheduleGenerator (inf, sup) +import Language.Marlowe.ACTUS.Model.Utility.DateShift (applyBDCWithCfg) +import Language.Marlowe.ACTUS.Model.Utility.ScheduleGenerator (generateRecurrentScheduleWithCorrections, + inf, plusCycle, sup) +import Language.Marlowe.ACTUS.Ops (YearFractionOps (_y)) + schedule :: EventType -> ContractTerms -> Maybe [ShiftedDay] -schedule ev ct@ContractTerms{..} = - case contractType of - PAM -> case ev of - IED -> _SCHED_IED_PAM ct - MD -> _SCHED_MD_PAM ct - PP -> _SCHED_PP_PAM ct - PY -> _SCHED_PY_PAM ct - FP -> _SCHED_FP_PAM ct - PRD -> _SCHED_PRD_PAM ct - TD -> _SCHED_TD_PAM ct - IP -> _SCHED_IP_PAM ct - IPCI -> _SCHED_IPCI_PAM ct - RR -> _SCHED_RR_PAM ct - RRF -> _SCHED_RRF_PAM ct - SC -> _SCHED_SC_PAM ct - _ -> Nothing - LAM -> - let - -- Need LAM state initialization since MD schedule is Tmd0 which may consist of other terms - -- Also cannot call initializeState directly without cyclical imports - t0 = ct_SD - fpSchedule = schedule FP ct - tfp_minus = maybe t0 calculationDay ((\sc -> sup sc t0) =<< fpSchedule) - tfp_plus = maybe t0 calculationDay ((\sc -> inf sc t0) =<< fpSchedule) - ipSchedule = schedule IP ct - tminus = maybe t0 calculationDay ((\sc -> sup sc t0) =<< ipSchedule) - prSchedule = schedule PR ct - tpr_minus = maybe t0 calculationDay ((\sc -> sup sc t0) =<< prSchedule) - _tmd = Just $ tmd $ _INIT_LAM ct_SD tminus tpr_minus tfp_minus tfp_plus ct - in case ev of - IED -> _SCHED_IED_PAM ct - PR -> _SCHED_PR_LAM ct { ct_MD = _tmd } - MD -> _SCHED_MD_LAM ct { ct_MD = _tmd } - PP -> _SCHED_PP_PAM ct { ct_MD = _tmd } - PY -> _SCHED_PY_PAM ct { ct_MD = _tmd } - FP -> _SCHED_FP_PAM ct { ct_MD = _tmd } - PRD -> _SCHED_PRD_PAM ct - TD -> _SCHED_TD_PAM ct - IP -> _SCHED_IP_PAM ct { ct_MD = _tmd } - IPCI -> _SCHED_IPCI_PAM ct { ct_MD = _tmd } - IPCB -> _SCHED_IPCB_LAM ct { ct_MD = _tmd } - RR -> _SCHED_RR_PAM ct { ct_MD = _tmd } - RRF -> _SCHED_RRF_PAM ct { ct_MD = _tmd } - SC -> _SCHED_SC_PAM ct { ct_MD = _tmd } - _ -> Nothing - NAM -> - -- Same as LAM - need to calculate Tmd0 - -- TODO: refactor for LAM and NAM - let - t0 = ct_SD - fpSchedule = schedule FP ct - tfp_minus = maybe t0 calculationDay ((\sc -> sup sc t0) =<< fpSchedule) - tfp_plus = maybe t0 calculationDay ((\sc -> inf sc t0) =<< fpSchedule) - ipSchedule = schedule IP ct - tminus = maybe t0 calculationDay ((\sc -> sup sc t0) =<< ipSchedule) - prSchedule = schedule PR ct - tpr_minus = maybe t0 calculationDay ((\sc -> sup sc t0) =<< prSchedule) - _tmd = Just $ tmd $ _INIT_NAM ct_SD tminus tpr_minus tfp_minus tfp_plus ct - in case ev of - IED -> _SCHED_IED_PAM ct - PR -> _SCHED_PR_LAM ct { ct_MD = _tmd } - MD -> _SCHED_MD_PAM ct { ct_MD = _tmd } - PP -> _SCHED_PP_PAM ct { ct_MD = _tmd } - PY -> _SCHED_PY_PAM ct { ct_MD = _tmd } - FP -> _SCHED_FP_PAM ct { ct_MD = _tmd } - PRD -> _SCHED_PRD_PAM ct - TD -> _SCHED_TD_PAM ct - IP -> _SCHED_IP_NAM ct { ct_MD = _tmd } - IPCI -> _SCHED_IPCI_NAM ct { ct_MD = _tmd } - IPCB -> _SCHED_IPCB_LAM ct { ct_MD = _tmd } - RR -> _SCHED_RR_PAM ct { ct_MD = _tmd } - RRF -> _SCHED_RRF_PAM ct { ct_MD = _tmd } - SC -> _SCHED_SC_PAM ct { ct_MD = _tmd } - _ -> Nothing - - ANN -> - let mat = maturity ct - _tmd = ct_AD <|> mat - in case ev of - IED -> _SCHED_IED_PAM ct - PR -> _SCHED_PR_LAM ct { ct_MD = _tmd } - MD -> _SCHED_MD_PAM ct { ct_MD = ct_MD <|> _tmd } - PP -> _SCHED_PP_PAM ct { ct_MD = _tmd } - PY -> _SCHED_PY_PAM ct { ct_MD = _tmd } - FP -> _SCHED_FP_PAM ct { ct_MD = _tmd } - PRD -> _SCHED_PRD_PAM ct { ct_MD = _tmd } - TD -> _SCHED_TD_PAM ct { ct_MD = _tmd } - IP -> _SCHED_IP_NAM ct { ct_MD = ct_MD <|> _tmd } - IPCI -> _SCHED_IPCI_PAM ct { ct_MD = _tmd } - IPCB -> _SCHED_IPCB_LAM ct { ct_MD = _tmd } - RR -> _SCHED_RR_PAM ct { ct_MD = _tmd } - RRF -> _SCHED_RRF_PAM ct { ct_MD = _tmd } - SC -> _SCHED_SC_PAM ct { ct_MD = _tmd } - PRF -> let prf = _SCHED_PRF_ANN ct { ct_MD = _tmd } - rr = _SCHED_RR_PAM ct { ct_MD = _tmd } - rrf = _SCHED_RRF_PAM ct { ct_MD = _tmd } - in Just $ fromMaybe [] prf ++ fromMaybe [] rr ++ fromMaybe [] rrf - _ -> Nothing +schedule ev c = let m = maturity c in schedule' ev c { ct_MD = m } + where + + schedule' :: EventType -> ContractTerms -> Maybe [ShiftedDay] + schedule' IED ct@ContractTerms{ contractType = PAM } = _SCHED_IED_PAM ct + schedule' MD ct@ContractTerms{ contractType = PAM } = _SCHED_MD_PAM ct + schedule' PP ct@ContractTerms{ contractType = PAM } = _SCHED_PP_PAM ct + schedule' PY ct@ContractTerms{ contractType = PAM } = _SCHED_PY_PAM ct + schedule' FP ct@ContractTerms{ contractType = PAM } = _SCHED_FP_PAM ct + schedule' PRD ct@ContractTerms{ contractType = PAM } = _SCHED_PRD_PAM ct + schedule' TD ct@ContractTerms{ contractType = PAM } = _SCHED_TD_PAM ct + schedule' IP ct@ContractTerms{ contractType = PAM } = _SCHED_IP_PAM ct + schedule' IPCI ct@ContractTerms{ contractType = PAM } = _SCHED_IPCI_PAM ct + schedule' RR ct@ContractTerms{ contractType = PAM } = _SCHED_RR_PAM ct + schedule' RRF ct@ContractTerms{ contractType = PAM } = _SCHED_RRF_PAM ct + schedule' SC ct@ContractTerms{ contractType = PAM } = _SCHED_SC_PAM ct + + schedule' IED ct@ContractTerms{ contractType = LAM } = _SCHED_IED_PAM ct + schedule' PR ct@ContractTerms{ contractType = LAM } = _SCHED_PR_LAM ct + schedule' MD ct@ContractTerms{ contractType = LAM } = _SCHED_MD_LAM ct + schedule' PP ct@ContractTerms{ contractType = LAM } = _SCHED_PP_PAM ct + schedule' PY ct@ContractTerms{ contractType = LAM } = _SCHED_PY_PAM ct + schedule' FP ct@ContractTerms{ contractType = LAM } = _SCHED_FP_PAM ct + schedule' PRD ct@ContractTerms{ contractType = LAM } = _SCHED_PRD_PAM ct + schedule' TD ct@ContractTerms{ contractType = LAM } = _SCHED_TD_PAM ct + schedule' IP ct@ContractTerms{ contractType = LAM } = _SCHED_IP_PAM ct + schedule' IPCI ct@ContractTerms{ contractType = LAM } = _SCHED_IPCI_PAM ct + schedule' IPCB ct@ContractTerms{ contractType = LAM } = _SCHED_IPCB_LAM ct + schedule' RR ct@ContractTerms{ contractType = LAM } = _SCHED_RR_PAM ct + schedule' RRF ct@ContractTerms{ contractType = LAM } = _SCHED_RRF_PAM ct + schedule' SC ct@ContractTerms{ contractType = LAM } = _SCHED_SC_PAM ct + + schedule' IED ct@ContractTerms{ contractType = NAM } = _SCHED_IED_PAM ct + schedule' PR ct@ContractTerms{ contractType = NAM } = _SCHED_PR_LAM ct + schedule' MD ct@ContractTerms{ contractType = NAM } = _SCHED_MD_PAM ct + schedule' PP ct@ContractTerms{ contractType = NAM } = _SCHED_PP_PAM ct + schedule' PY ct@ContractTerms{ contractType = NAM } = _SCHED_PY_PAM ct + schedule' FP ct@ContractTerms{ contractType = NAM } = _SCHED_FP_PAM ct + schedule' PRD ct@ContractTerms{ contractType = NAM } = _SCHED_PRD_PAM ct + schedule' TD ct@ContractTerms{ contractType = NAM } = _SCHED_TD_PAM ct + schedule' IP ct@ContractTerms{ contractType = NAM } = _SCHED_IP_NAM ct + schedule' IPCI ct@ContractTerms{ contractType = NAM } = _SCHED_IPCI_NAM ct + schedule' IPCB ct@ContractTerms{ contractType = NAM } = _SCHED_IPCB_LAM ct + schedule' RR ct@ContractTerms{ contractType = NAM } = _SCHED_RR_PAM ct + schedule' RRF ct@ContractTerms{ contractType = NAM } = _SCHED_RRF_PAM ct + schedule' SC ct@ContractTerms{ contractType = NAM } = _SCHED_SC_PAM ct + + schedule' IED ct@ContractTerms{ contractType = ANN } = _SCHED_IED_PAM ct + schedule' PR ct@ContractTerms{ contractType = ANN } = _SCHED_PR_LAM ct + schedule' MD ct@ContractTerms{ contractType = ANN } = _SCHED_MD_PAM c { ct_MD = ct_MD c <|> ct_MD ct } + schedule' PP ct@ContractTerms{ contractType = ANN } = _SCHED_PP_PAM ct + schedule' PY ct@ContractTerms{ contractType = ANN } = _SCHED_PY_PAM ct + schedule' FP ct@ContractTerms{ contractType = ANN } = _SCHED_FP_PAM ct + schedule' PRD ct@ContractTerms{ contractType = ANN } = _SCHED_PRD_PAM ct + schedule' TD ct@ContractTerms{ contractType = ANN } = _SCHED_TD_PAM ct + schedule' IP ct@ContractTerms{ contractType = ANN } = _SCHED_IP_NAM c { ct_MD = ct_MD c <|> ct_MD ct } + schedule' IPCI ct@ContractTerms{ contractType = ANN } = _SCHED_IPCI_PAM ct + schedule' IPCB ct@ContractTerms{ contractType = ANN } = _SCHED_IPCB_LAM ct + schedule' RR ct@ContractTerms{ contractType = ANN } = _SCHED_RR_PAM ct + schedule' RRF ct@ContractTerms{ contractType = ANN } = _SCHED_RRF_PAM ct + schedule' SC ct@ContractTerms{ contractType = ANN } = _SCHED_SC_PAM ct + schedule' PRF ct@ContractTerms{ contractType = ANN } = _SCHED_PRF_ANN ct + + schedule' _ _ = Nothing + + +maturity :: ContractTerms -> Maybe Day +maturity ContractTerms{ contractType = PAM, ..} = ct_MD +maturity ct@ContractTerms{ contractType = LAM, ..} = + let t0 = ct_SD + fpSchedule = schedule FP ct + tfp_minus = maybe t0 calculationDay ((\sc -> sup sc t0) =<< fpSchedule) + tfp_plus = maybe t0 calculationDay ((\sc -> inf sc t0) =<< fpSchedule) + ipSchedule = schedule IP ct + tminus = maybe t0 calculationDay ((\sc -> sup sc t0) =<< ipSchedule) + prSchedule = schedule PR ct + tpr_minus = maybe t0 calculationDay ((\sc -> sup sc t0) =<< prSchedule) + in Just $ tmd $ _INIT_LAM ct_SD tminus tpr_minus tfp_minus tfp_plus ct + +maturity ct@ContractTerms{ contractType = NAM, ..} = + let t0 = ct_SD + fpSchedule = schedule FP ct + tfp_minus = maybe t0 calculationDay ((\sc -> sup sc t0) =<< fpSchedule) + tfp_plus = maybe t0 calculationDay ((\sc -> inf sc t0) =<< fpSchedule) + ipSchedule = schedule IP ct + tminus = maybe t0 calculationDay ((\sc -> sup sc t0) =<< ipSchedule) + prSchedule = schedule PR ct + tpr_minus = maybe t0 calculationDay ((\sc -> sup sc t0) =<< prSchedule) + in Just $ tmd $ _INIT_NAM ct_SD tminus tpr_minus tfp_minus tfp_plus ct + +maturity ContractTerms{ contractType = ANN, ..} = maturity' ct_SD ct_SD ct_DCC ct_AD ct_MD ct_IED ct_PRANX ct_PRCL ct_PRNXT ct_IPNR ct_NT + where + maturity' :: Day -- t0 + -> Day -- status date + -> Maybe DCC -- day count convention + -> Maybe Day -- amorization date + -> Maybe Day -- maturity date + -> Maybe Day -- initial exchange date + -> Maybe Day -- cycle anchor date of principal redemption + -> Maybe Cycle -- cycle of principal redemption + -> Maybe Double -- next principal redemption payment + -> Maybe Double -- nominal interest rate + -> Maybe Double -- notional principal + -> Maybe Day -- maturity + + maturity' t0 sd (Just dcc) Nothing Nothing (Just ied) (Just pranx) (Just prcl) (Just prnxt) (Just ipnr) (Just nt) = + let tplus = ied `plusCycle` prcl + + lastEvent + | pranx >= t0 = pranx + | tplus >= t0 = tplus + | otherwise = + let previousEvents = _S sd prcl pranx scfg + in calculationDay . head . sortOn (Down . calculationDay) . filter (\ShiftedDay {..} -> calculationDay > t0) $ previousEvents + + timeFromLastEventPlusOneCycle = _y dcc lastEvent (lastEvent `plusCycle` prcl) Nothing + + redemptionPerCycle = prnxt - timeFromLastEventPlusOneCycle * ipnr * nt + + remainingPeriods = (ceiling (nt / redemptionPerCycle) - 1) :: Integer + + in Just . calculationDay . applyBDCWithCfg scfg $ lastEvent `plusCycle` prcl {n = remainingPeriods} + + where + _S :: Day -> Cycle -> Day -> ScheduleConfig -> ShiftedSchedule + _S = generateRecurrentScheduleWithCorrections + + maturity' _ _ _ ad@(Just _) _ _ _ _ _ _ _ = ad + maturity' _ _ _ Nothing md@(Just _) _ _ _ _ _ _ = md + maturity' _ _ _ _ _ _ _ _ _ _ _ = Nothing diff --git a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/SCHED/ContractScheduleModel.hs b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/SCHED/ContractScheduleModel.hs index 9c3e776eae1..0e308ad196b 100644 --- a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/SCHED/ContractScheduleModel.hs +++ b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/SCHED/ContractScheduleModel.hs @@ -1,7 +1,7 @@ {-# LANGUAGE RecordWildCards #-} module Language.Marlowe.ACTUS.Model.SCHED.ContractScheduleModel where -import Control.Applicative +import Control.Applicative (liftA2) import Control.Monad (join, liftM4) import Data.List as L (find, nub) import Data.Maybe (fromMaybe, isJust, isNothing) @@ -14,6 +14,7 @@ import Language.Marlowe.ACTUS.Definitions.Schedule (Shifted import Language.Marlowe.ACTUS.Model.Utility.DateShift (applyBDCWithCfg) import Language.Marlowe.ACTUS.Model.Utility.ScheduleGenerator (generateRecurrentScheduleWithCorrections, inf, minusCycle, plusCycle, remove) + _S :: Maybe Day -> Maybe Cycle -> Maybe Day -> Maybe ScheduleConfig -> Maybe ShiftedSchedule _S = liftM4 generateRecurrentScheduleWithCorrections @@ -202,7 +203,9 @@ _SCHED_IPCI_NAM ContractTerms{..} = -- Annuity (ANN) _SCHED_PRF_ANN :: ContractTerms -> Maybe ShiftedSchedule -_SCHED_PRF_ANN ContractTerms{..} = - let result | isJust ct_PRANX && isNothing ct_PRNXT && ct_PRANX > ct_IED = ct_PRANX >>= (\p -> Just [ShiftedDay p p]) . addDays (-1) - | otherwise = Nothing - in result +_SCHED_PRF_ANN ct@ContractTerms{..} = + let prf | isJust ct_PRANX && isNothing ct_PRNXT && ct_PRANX > ct_IED = ct_PRANX >>= (\p -> Just [ShiftedDay p p]) . addDays (-1) + | otherwise = Nothing + rr = _SCHED_RR_PAM ct + rrf = _SCHED_RRF_PAM ct + in Just $ fromMaybe [] prf ++ fromMaybe [] rr ++ fromMaybe [] rrf diff --git a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/STF/StateTransition.hs b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/STF/StateTransition.hs index 10523e7f88a..6779535259b 100644 --- a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/STF/StateTransition.hs +++ b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/STF/StateTransition.hs @@ -2,15 +2,14 @@ module Language.Marlowe.ACTUS.Model.STF.StateTransition where -import Data.Maybe (fromJust, fromMaybe, maybeToList) +import Data.Maybe (fromJust, maybeToList) import Data.Time (Day) import Language.Marlowe.ACTUS.Definitions.BusinessEvents (EventType (..), RiskFactors (..)) import Language.Marlowe.ACTUS.Definitions.ContractState (ContractState, ContractStatePoly (..)) import Language.Marlowe.ACTUS.Definitions.ContractTerms (CT (..), ContractTerms (..), ScheduleConfig) import Language.Marlowe.ACTUS.Definitions.Schedule (ShiftedDay (calculationDay)) -import Language.Marlowe.ACTUS.Model.SCHED.ContractSchedule (schedule) +import Language.Marlowe.ACTUS.Model.SCHED.ContractSchedule (maturity, schedule) import Language.Marlowe.ACTUS.Model.STF.StateTransitionModel -import Language.Marlowe.ACTUS.Model.Utility.ANN.Maturity (maturity) import Language.Marlowe.ACTUS.Model.Utility.DateShift import Language.Marlowe.ACTUS.Model.Utility.ScheduleGenerator (inf, sup) import Language.Marlowe.ACTUS.Ops (YearFractionOps (_y)) @@ -110,9 +109,9 @@ stateTransition ev RiskFactors{..} terms@ContractTerms{..} st@ContractStatePoly{ _ -> st ANN -> - let prDates = maybe [] (map calculationDay) prSchedule ++ maybeToList (maturity terms) - prDatesAfterSd = filter (\d -> d > sd) prDates - ti = zipWith (\tn tm -> _y (fromJust ct_DCC) tn tm ct_MD) prDatesAfterSd (tail prDatesAfterSd) + let prDates = maybe [] (map calculationDay) prSchedule ++ maybeToList (maturity terms) + prDatesAfterSd = filter (\d -> d > sd) prDates + ti = zipWith (\tn tm -> _y (fromJust ct_DCC) tn tm ct_MD) prDatesAfterSd (tail prDatesAfterSd) in case ev of AD -> _STF_AD_PAM st t y_sd_t diff --git a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/Utility/ANN/Maturity.hs b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/Utility/ANN/Maturity.hs deleted file mode 100644 index 4298d3e65d6..00000000000 --- a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/Utility/ANN/Maturity.hs +++ /dev/null @@ -1,71 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} -module Language.Marlowe.ACTUS.Model.Utility.ANN.Maturity - (maturity) -where - -import Data.Ord (Down (..)) -import Data.Sort (sortOn) -import Data.Time (Day) -import Language.Marlowe.ACTUS.Definitions.ContractTerms (ContractTerms (..), Cycle (n), DCC, - ScheduleConfig) -import Language.Marlowe.ACTUS.Definitions.Schedule (ShiftedDay (ShiftedDay, calculationDay, paymentDay), - ShiftedSchedule) -import Language.Marlowe.ACTUS.Model.Utility.DateShift (applyBDCWithCfg) -import Language.Marlowe.ACTUS.Model.Utility.ScheduleGenerator (generateRecurrentScheduleWithCorrections, - plusCycle) -import Language.Marlowe.ACTUS.Ops (YearFractionOps (_y)) - -maturity :: ContractTerms -> Maybe Day -maturity ContractTerms{..} = - maturity' - ct_SD - ct_SD - scfg - ct_DCC - ct_AD - ct_MD - ct_IED - ct_PRANX - ct_PRCL - ct_PRNXT - ct_IPNR - ct_NT - -maturity' :: Day -- t0 - -> Day -- status date - -> ScheduleConfig -- schedule config - -> Maybe DCC -- day count convention - -> Maybe Day -- amorization date - -> Maybe Day -- maturity date - -> Maybe Day -- initial exchange date - -> Maybe Day -- cycle anchor date of principal redemption - -> Maybe Cycle -- cycle of principal redemption - -> Maybe Double -- next principal redemption payment - -> Maybe Double -- nominal interest rate - -> Maybe Double -- notional principal - -> Maybe Day -- maturity -maturity' t0 sd scfg (Just dcc) Nothing Nothing (Just ied) (Just pranx) (Just prcl) (Just prnxt) (Just ipnr) (Just nt) = - let tplus = ied `plusCycle` prcl - - lastEvent - | pranx >= t0 = pranx - | tplus >= t0 = tplus - | otherwise = - let previousEvents = _S sd prcl pranx scfg - in calculationDay . head . sortOn (Down . calculationDay) . filter (\ShiftedDay {..} -> calculationDay > t0) $ previousEvents - - timeFromLastEventPlusOneCycle = _y dcc lastEvent (lastEvent `plusCycle` prcl) Nothing - - redemptionPerCycle = prnxt - timeFromLastEventPlusOneCycle * ipnr * nt - - remainingPeriods = (ceiling (nt / redemptionPerCycle) - 1) :: Integer - - in Just . calculationDay . applyBDCWithCfg scfg $ lastEvent `plusCycle` prcl {n = remainingPeriods} - - where - _S :: Day -> Cycle -> Day -> ScheduleConfig -> ShiftedSchedule - _S = generateRecurrentScheduleWithCorrections - -maturity' _ _ _ _ ad@(Just _) _ _ _ _ _ _ _ = ad -maturity' _ _ _ _ Nothing md@(Just _) _ _ _ _ _ _ = md -maturity' _ _ _ _ _ _ _ _ _ _ _ _ = Nothing From fd5345d1344643516baea159c5e1915df2043a61 Mon Sep 17 00:00:00 2001 From: Yves Hauser Date: Wed, 1 Sep 2021 10:13:09 +0200 Subject: [PATCH 08/28] scp-2709 - refactoring ACTUS code * pattern match Maybes instead of calling fromJust --- .../ACTUS/Model/INIT/StateInitialization.hs | 34 +- .../Model/INIT/StateInitializationModel.hs | 424 ++++++++---------- .../ACTUS/Model/SCHED/ContractSchedule.hs | 185 ++++---- .../ACTUS/Model/Utility/ScheduleGenerator.hs | 8 + 4 files changed, 299 insertions(+), 352 deletions(-) diff --git a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/INIT/StateInitialization.hs b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/INIT/StateInitialization.hs index c749a895ea4..9d9a2acbea0 100644 --- a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/INIT/StateInitialization.hs +++ b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/INIT/StateInitialization.hs @@ -1,35 +1,9 @@ -{-# LANGUAGE RecordWildCards #-} module Language.Marlowe.ACTUS.Model.INIT.StateInitialization where -import Data.Maybe (fromJust, maybeToList) -import Language.Marlowe.ACTUS.Definitions.BusinessEvents (EventType (FP, IP, PR)) +import Data.Maybe (fromJust) import Language.Marlowe.ACTUS.Definitions.ContractState (ContractState) -import Language.Marlowe.ACTUS.Definitions.ContractTerms (CT (..), ContractTerms (..)) -import Language.Marlowe.ACTUS.Definitions.Schedule (ShiftedDay (calculationDay)) -import Language.Marlowe.ACTUS.Model.INIT.StateInitializationModel (_INIT_ANN, _INIT_LAM, _INIT_NAM, _INIT_PAM) -import Language.Marlowe.ACTUS.Model.SCHED.ContractSchedule (maturity, schedule) -import Language.Marlowe.ACTUS.Model.Utility.ScheduleGenerator (inf, sup) -import Language.Marlowe.ACTUS.Ops (YearFractionOps (_y)) +import Language.Marlowe.ACTUS.Definitions.ContractTerms (ContractTerms) +import Language.Marlowe.ACTUS.Model.INIT.StateInitializationModel (initialize) initializeState :: ContractTerms -> ContractState -initializeState terms@ContractTerms {..} = - let t0 = ct_SD - -- PAM - fpSchedule = schedule FP terms - tfp_minus = maybe t0 calculationDay ((\sc -> sup sc t0) =<< fpSchedule) - tfp_plus = maybe t0 calculationDay ((\sc -> inf sc t0) =<< fpSchedule) - ipSchedule = schedule IP terms - tminus = maybe t0 calculationDay ((\sc -> sup sc t0) =<< ipSchedule) - - -- LAM, NAM, ANN - prSchedule = schedule PR terms - tpr_minus = maybe t0 calculationDay ((\sc -> sup sc t0) =<< prSchedule) - - in case contractType of - PAM -> _INIT_PAM t0 tminus tfp_minus tfp_plus terms - LAM -> _INIT_LAM t0 tminus tpr_minus tfp_minus tfp_plus terms - NAM -> _INIT_NAM t0 tminus tpr_minus tfp_minus tfp_plus terms - ANN -> let prDates = maybe [] (map calculationDay) prSchedule ++ maybeToList (maturity terms) - ti = zipWith (\tn tm -> _y (fromJust ct_DCC) tn tm ct_MD) prDates (tail prDates) - in _INIT_ANN t0 tminus tpr_minus tfp_minus tfp_plus ti terms - +initializeState = fromJust . initialize -- FIXME: reconsider fromJust diff --git a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/INIT/StateInitializationModel.hs b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/INIT/StateInitializationModel.hs index af726e032c6..ac6a44dde66 100644 --- a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/INIT/StateInitializationModel.hs +++ b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/INIT/StateInitializationModel.hs @@ -1,254 +1,194 @@ + {-# LANGUAGE RecordWildCards #-} +{-| = ACTUS contract state initialization per t0 + +The implementation is a transliteration of the ACTUS specification v1.1 +Note: initial states rely also on some schedules (and vice versa) + +-} + module Language.Marlowe.ACTUS.Model.INIT.StateInitializationModel where -import Data.List as L (filter, head) -import Data.Maybe (fromJust, fromMaybe, isJust, isNothing) +import Data.Maybe (isJust, isNothing, maybeToList) import Data.Time.Calendar (Day) -import Language.Marlowe.ACTUS.Definitions.ContractState (ContractStatePoly (ContractStatePoly, feac, ipac, ipcb, ipnr, isc, nsc, nt, prf, prnxt, sd, tmd)) -import Language.Marlowe.ACTUS.Definitions.ContractTerms (CR, ContractTerms (..), Cycle (..), DCC, - FEB (FEB_N), IPCB (IPCB_NT), - SCEF (SE_0N0, SE_0NM, SE_I00, SE_I0M, SE_IN0, SE_INM), - ScheduleConfig (..), n) +import Language.Marlowe.ACTUS.Definitions.BusinessEvents +import Language.Marlowe.ACTUS.Definitions.ContractState (ContractState, ContractStatePoly (..)) +import Language.Marlowe.ACTUS.Definitions.ContractTerms (CR, CT (..), ContractTerms (..), Cycle (..), + DCC, FEB (..), IPCB (..), SCEF (..), + ScheduleConfig) import Language.Marlowe.ACTUS.Definitions.Schedule (ShiftedDay (..), ShiftedSchedule) +import Language.Marlowe.ACTUS.Model.SCHED.ContractSchedule (maturity, schedule) import Language.Marlowe.ACTUS.Model.Utility.ANN.Annuity (annuity) import Language.Marlowe.ACTUS.Model.Utility.ContractRoleSign (contractRoleSign) -import Language.Marlowe.ACTUS.Model.Utility.ScheduleGenerator (applyEOMC, - generateRecurrentScheduleWithCorrections, - minusCycle, plusCycle) +import Language.Marlowe.ACTUS.Model.Utility.ScheduleGenerator (generateRecurrentScheduleWithCorrections, inf, + sup) import Language.Marlowe.ACTUS.Model.Utility.YearFraction (yearFraction) +import Language.Marlowe.ACTUS.Ops (YearFractionOps (_y)) {-# ANN module "HLint: ignore Use camelCase" #-} -_S :: Day -> Cycle -> Day -> ScheduleConfig -> ShiftedSchedule -_S = generateRecurrentScheduleWithCorrections - -r :: CR -> Double -r = contractRoleSign - -y :: DCC -> Day -> Day -> Maybe Day -> Double -y = yearFraction - -scef_xNx :: SCEF -> Bool -scef_xNx SE_0N0 = True -scef_xNx SE_0NM = True -scef_xNx SE_IN0 = True -scef_xNx SE_INM = True -scef_xNx _ = False - -scef_Ixx :: SCEF -> Bool -scef_Ixx SE_IN0 = True -scef_Ixx SE_INM = True -scef_Ixx SE_I00 = True -scef_Ixx SE_I0M = True -scef_Ixx _ = False - - - -_INIT_PAM :: Day -> Day -> Day -> Day -> ContractTerms -> ContractStatePoly Double Day -_INIT_PAM t0 tminus tfp_minus tfp_plus - ContractTerms{..} = - let - _IED = fromJust ct_IED - _DCC = fromJust ct_DCC - _PRF = fromJust ct_PRF - _SCEF = fromJust ct_SCEF - _SCNT = fromJust ct_SCNT - _SCIP = fromJust ct_SCIP - - tmd = fromJust ct_MD - nt - | _IED > t0 = 0.0 - | otherwise = r ct_CNTRL * fromJust ct_NT - - ipnr - | _IED > t0 = 0.0 - | otherwise = fromMaybe 0.0 ct_IPNR - ipac - | isNothing ct_IPNR = 0.0 - | isJust ct_IPAC = r ct_CNTRL * fromJust ct_IPAC - | otherwise = y _DCC tminus t0 ct_MD * nt * ipnr - feac - | isNothing ct_FER = 0.0 - | isJust ct_FEAC = fromJust ct_FEAC - | fromJust ct_FEB == FEB_N = y _DCC tfp_minus t0 ct_MD * nt * fromJust ct_FER - | otherwise = y _DCC tfp_minus t0 ct_MD / y _DCC tfp_minus tfp_plus ct_MD * fromJust ct_FER - - nsc - | scef_xNx _SCEF = _SCNT - | otherwise = 1.0 - - isc - | scef_Ixx _SCEF = _SCIP - | otherwise = 1.0 - - prf = _PRF - - sd = t0 - in ContractStatePoly { prnxt = 0.0, ipcb = 0.0, tmd = tmd, nt = nt, ipnr = ipnr, ipac = ipac, feac = feac, nsc = nsc, isc = isc, prf = prf, sd = sd } - -_INIT_LAM :: Day -> Day -> Day -> Day -> Day -> ContractTerms -> ContractStatePoly Double Day -_INIT_LAM t0 tminus _ tfp_minus tfp_plus - terms@ContractTerms{..} = - let - _IED' = fromJust ct_IED - _DCC' = fromJust ct_DCC - - -- TMD - -- maybeTMinus - -- | isJust _PRANX && ((fromJust _PRANX) >= t0) = _PRANX - -- | (_IED' `plusCycle` fromJust ct_PRCL) >= t0 = Just $ _IED' `plusCycle` fromJust ct_PRCL - -- | otherwise = Just tpr_minus - -- tmd - -- | isJust ct_MD = fromJust ct_MD - -- | otherwise = fromJust maybeTMinus `plusCycle` (fromJust ct_PRCL) { n = ((ceiling ((fromJust ct_NT) / (fromJust ct_PRNXT))) * (n (fromJust ct_PRCL))) } - - -- TMD - tmd - | isJust ct_MD = fromJust ct_MD - | otherwise = - let - (lastEvent, remainingPeriods) = - if isJust ct_PRANX && fromJust ct_PRANX < ct_SD then - let - previousEvents = (\s -> _S s (fromJust ct_PRCL) ct_SD scfg ) <$> ct_PRANX - previousEvents' = L.filter(\ShiftedDay{ calculationDay = calculationDay } -> calculationDay > minusCycle ct_SD (fromJust ct_IPCL)) (fromMaybe [] previousEvents) - previousEvents'' = L.filter(\ShiftedDay{ calculationDay = calculationDay } -> calculationDay == ct_SD) previousEvents' - ShiftedDay{ calculationDay = lastEventCalcDay } = L.head previousEvents'' - in - (lastEventCalcDay, fromJust ct_NT / fromJust ct_PRNXT) - else - -- TODO: check applicability for PRANX - (fromJust ct_PRANX, fromJust ct_NT / fromJust ct_PRNXT - 1) - c@Cycle{ n = n } = fromJust ct_PRCL - maturity = plusCycle lastEvent c { n = n * round remainingPeriods :: Integer} - in - applyEOMC lastEvent c (fromJust (eomc scfg)) maturity - - - pam_init = _INIT_PAM t0 tminus tfp_minus tfp_plus terms - - -- PRNXT - -- s - -- | isJust ct_PRANX && ((fromJust ct_PRANX) > t0) = fromJust ct_PRANX - -- | isNothing ct_PRANX && ((_IED' `plusCycle` fromJust ct_PRCL) > t0) = _IED' `plusCycle` fromJust ct_PRCL - -- | otherwise = tpr_minus - prnxt - | isJust ct_PRNXT = fromJust ct_PRNXT - {- ACTUS implementation - -- | otherwise = (fromJust ct_NT) * (1.0 / (fromIntegral $ ((ceiling (y _DCC' s tmd (Just tmd) / y _DCC' s (s `plusCycle` fromJust ct_PRCL) (Just tmd))) :: Integer))) - -} - - -- Java implementation - | otherwise = fromJust ct_NT / fromIntegral (length $ fromJust ((\s -> _S s (fromJust ct_PRCL){ includeEndDay = True } tmd scfg ) <$> ct_PRANX)) - -- IPCB - ipcb - | t0 < _IED' = 0.0 - | fromJust ct_IPCB == IPCB_NT = r ct_CNTRL * fromJust ct_NT - | otherwise = r ct_CNTRL * fromJust ct_IPCBA - -- All is same as PAM except PRNXT, IPCB, and TMD - in pam_init { prnxt = prnxt, ipcb = ipcb, tmd = tmd } - -_INIT_NAM :: Day -> Day -> Day -> Day -> Day -> ContractTerms -> ContractStatePoly Double Day -_INIT_NAM t0 tminus _ tfp_minus tfp_plus - terms@ContractTerms{..} = - let - _IED = fromJust ct_IED - _DCC = fromJust ct_DCC - _PRNXT = fromJust ct_PRNXT - - {- - -- TMD - -- maybeTMinus - -- | isJust ct_PRANX && fromJust ct_PRANX >= t0 = ct_PRANX - -- | (_IED `plusCycle` fromJust ct_PRCL) >= t0 = Just $ _IED `plusCycle` fromJust ct_PRCL - -- | otherwise = Just tpr_minus - -} - - tmd - | isJust ct_MD = fromJust ct_MD - | otherwise = - let - lastEvent - | isJust ct_PRANX && fromJust ct_PRANX >= ct_SD = - fromJust ct_PRANX - | _IED `plusCycle` fromJust ct_PRCL >= ct_SD = - _IED `plusCycle` fromJust ct_PRCL - | otherwise = - let previousEvents = (\s -> _S s (fromJust ct_PRCL) ct_SD scfg ) <$> ct_PRANX - previousEvents' = L.filter(\ShiftedDay{ calculationDay = calculationDay } -> calculationDay >= ct_SD ) (fromMaybe [] previousEvents) - previousEvents'' = L.filter(\ShiftedDay{ calculationDay = calculationDay } -> calculationDay == ct_SD) previousEvents' - ShiftedDay{ calculationDay = lastEventCalcDay } = L.head previousEvents'' - in - lastEventCalcDay - yLastEventPlusPRCL = y _DCC lastEvent (lastEvent `plusCycle` fromJust ct_PRCL) ct_MD - redemptionPerCycle = _PRNXT - (yLastEventPlusPRCL * fromJust ct_IPNR * fromJust ct_NT) - remainingPeriods = ceiling (fromJust ct_NT / redemptionPerCycle) - 1 - c@Cycle{ n = n } = fromJust ct_PRCL - maturity = plusCycle lastEvent c { n = n * remainingPeriods} - in - applyEOMC lastEvent c (fromJust (eomc scfg)) maturity - {- - -- | otherwise = fromJust maybeTMinus `plusCycle` (fromJust ct_PRCL) { n = ceiling((fromJust ct_NT) / (_PRNXT' - (fromJust ct_NT) * (y _DCC' tminus (tminus `plusCycle` fromJust ct_PRCL) ct_MD) * fromJust ct_IPNR))} - - -} - -- PRNXT - prnxt = _PRNXT - - -- IPCB - ipcb - | t0 < _IED = 0.0 - | fromJust ct_IPCB == IPCB_NT = r ct_CNTRL * fromJust ct_NT - | otherwise = r ct_CNTRL * fromJust ct_IPCBA - - pam_init = _INIT_PAM t0 tminus tfp_minus tfp_plus terms - - -- All is same as PAM except PRNXT and TMD, IPCB same as LAM - in pam_init { prnxt = prnxt, ipcb = ipcb, tmd = tmd } - -_INIT_ANN :: Day -> Day -> Day -> Day -> Day -> [Double] -> ContractTerms -> ContractStatePoly Double Day -_INIT_ANN t0 tminus tpr_minus tfp_minus tfp_plus ti - terms@ContractTerms{..} = - let - _IED = fromJust ct_IED - _DCC = fromJust ct_DCC - - -- TMD - maybeTMinus - | isJust ct_PRANX && (fromJust ct_PRANX >= t0) = ct_PRANX - | (_IED `plusCycle` fromJust ct_PRCL) >= t0 = Just $ _IED `plusCycle` fromJust ct_PRCL - | otherwise = Just tpr_minus - - pam_init = _INIT_PAM t0 tminus tfp_minus tfp_plus terms - - -- PRNXT - nt - | _IED > t0 = 0.0 - | otherwise = r ct_CNTRL * fromJust ct_NT - ipnr - | _IED > t0 = 0.0 - | otherwise = fromMaybe 0.0 ct_IPNR - ipac - | isNothing ct_IPNR = 0.0 - | isJust ct_IPAC = fromJust ct_IPAC - | otherwise = y _DCC tminus t0 ct_MD * nt * ipnr - - prnxt - -- | isJust ct_PRNXT = r ct_CNTRL * fromJust ct_PRNXT - | isJust ct_PRNXT = fromJust ct_PRNXT - | otherwise = let scale = fromJust ct_NT + ipac - frac = annuity ipnr ti - in frac * scale - - tmd - | isJust ct_MD = fromJust ct_MD - | otherwise = fromJust maybeTMinus `plusCycle` (fromJust ct_PRCL) { n = ceiling(fromJust ct_NT / (prnxt - fromJust ct_NT * y _DCC tminus (tminus `plusCycle` fromJust ct_PRCL) ct_MD * fromJust ct_IPNR))} - - -- IPCB - ipcb - | t0 < _IED = 0.0 - | fromJust ct_IPCB == IPCB_NT = r ct_CNTRL * fromJust ct_NT - | otherwise = r ct_CNTRL * fromJust ct_IPCBA - -- All is same as PAM except PRNXT and TMD, IPCB same as LAM - in pam_init { prnxt = prnxt, ipcb = ipcb, tmd = tmd } - +-- |init initializes the state variables at t0 +initialize :: ContractTerms -> Maybe ContractState +initialize ct@ContractTerms {..} = + let mat = maturity ct + in do + tmd <- mat + + nt <- + let nt + | ct_IED > Just t0 = Just 0.0 + | otherwise = (\x -> r ct_CNTRL * x) <$> ct_NT + in nt + + ipnr <- + let ipnr + | ct_IED > Just t0 = Just 0.0 + | otherwise = ct_IPNR + in ipnr + + ipac <- + let ipac + | isNothing ct_IPNR = Just 0.0 + | isJust ct_IPAC = ct_IPAC + | otherwise = (\d -> y d tminus t0 ct_MD * nt * ipnr) <$> ct_DCC + in ipac + + feac <- feeAccrued ct { ct_MD = mat } + + nsc <- + let nsc + | maybe False scef_xNx ct_SCEF = ct_SCNT + | otherwise = Just 1.0 + in nsc + + isc <- + let isc + | maybe False scef_Ixx ct_SCEF = ct_SCIP + | otherwise = Just 1.0 + in isc + + prf <- ct_PRF + + let sd = ct_SD + + prnxt <- nextPrincipalRedemptionPayment ct { ct_MD = mat } + ipcb <- interestPaymentCalculationBase ct { ct_MD = mat } + + return + ContractStatePoly + { prnxt = prnxt, + ipcb = ipcb, + tmd = tmd, + nt = nt, + ipnr = ipnr, + ipac = ipac, + feac = feac, + nsc = nsc, + isc = isc, + prf = prf, + sd = sd + } + where + fpSchedule = schedule FP ct + ipSchedule = schedule IP ct + prSchedule = schedule PR ct + + t0 = ct_SD + tfp_minus = maybe t0 calculationDay ((\sc -> sup sc t0) =<< fpSchedule) + tfp_plus = maybe t0 calculationDay ((\sc -> inf sc t0) =<< fpSchedule) + tminus = maybe t0 calculationDay ((\sc -> sup sc t0) =<< ipSchedule) + + r :: CR -> Double + r = contractRoleSign + + y :: DCC -> Day -> Day -> Maybe Day -> Double + y = yearFraction + + _S :: Day -> Cycle -> Day -> ScheduleConfig -> ShiftedSchedule + _S = generateRecurrentScheduleWithCorrections + + scef_xNx :: SCEF -> Bool + scef_xNx SE_0N0 = True + scef_xNx SE_0NM = True + scef_xNx SE_IN0 = True + scef_xNx SE_INM = True + scef_xNx _ = False + + scef_Ixx :: SCEF -> Bool + scef_Ixx SE_IN0 = True + scef_Ixx SE_INM = True + scef_Ixx SE_I00 = True + scef_Ixx SE_I0M = True + scef_Ixx _ = False + + nextPrincipalRedemptionPayment :: ContractTerms -> Maybe Double + nextPrincipalRedemptionPayment ContractTerms {contractType = PAM} = Just 0.0 + nextPrincipalRedemptionPayment ContractTerms {ct_PRNXT = prnxt@(Just _)} = prnxt + nextPrincipalRedemptionPayment + ContractTerms + { contractType = LAM, + ct_PRNXT = Nothing, + ct_MD = Just maturityDate, + ct_NT = Just notionalPrincipal, + ct_PRCL = Just principalRedemptionCycle, + ct_PRANX = Just principalRedemptionAnchor, + scfg = scheduleConfig + } = Just $ notionalPrincipal / fromIntegral (length $ _S principalRedemptionAnchor (principalRedemptionCycle {includeEndDay = True}) maturityDate scheduleConfig) + nextPrincipalRedemptionPayment + ContractTerms + { contractType = ANN, + ct_PRNXT = Nothing, + ct_IPAC = Just interestAccrued, + ct_MD = md, + ct_NT = Just nominalPrincipal, + ct_IPNR = Just nominalInterestRate, + ct_DCC = Just dayCountConvention + } = + let scale = nominalPrincipal + interestAccrued + frac = annuity nominalInterestRate ti + in Just $ frac * scale + where + prDates = maybe [] (map calculationDay) prSchedule ++ maybeToList (maturity ct) + ti = zipWith (\tn tm -> _y dayCountConvention tn tm md) prDates (tail prDates) + nextPrincipalRedemptionPayment _ = Nothing + + interestPaymentCalculationBase :: ContractTerms -> Maybe Double + interestPaymentCalculationBase + ContractTerms + { contractType = LAM, + ct_IED = Just initialExchangeDate + } | t0 < initialExchangeDate = Just 0.0 + interestPaymentCalculationBase + ContractTerms + { ct_NT = Just notionalPrincipal, + ct_IPCB = Just ipcb + } | ipcb == IPCB_NT = Just $ r ct_CNTRL * notionalPrincipal + interestPaymentCalculationBase + ContractTerms + { ct_IPCBA = Just ipcba + } = Just $ r ct_CNTRL * ipcba + interestPaymentCalculationBase _ = Nothing + + feeAccrued :: ContractTerms -> Maybe Double + feeAccrued + ContractTerms + { ct_FER = Nothing + } = Just 0.0 + feeAccrued + ContractTerms + { ct_FEAC = feac@(Just _) + } = feac + feeAccrued + ContractTerms + { ct_FEB = Just feb, + ct_DCC = Just dayCountConvention, + ct_FER = Just fer, + ct_NT = Just notionalPrincipal + } | feb == FEB_N = Just $ y dayCountConvention tfp_minus t0 ct_MD * notionalPrincipal * fer + feeAccrued + ContractTerms + { ct_DCC = Just dayCountConvention, + ct_FER = Just fer + } = Just $ y dayCountConvention tfp_minus t0 ct_MD / y dayCountConvention tfp_minus tfp_plus ct_MD * fer + feeAccrued _ = Nothing diff --git a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/SCHED/ContractSchedule.hs b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/SCHED/ContractSchedule.hs index 44080415b78..833a4ed431d 100644 --- a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/SCHED/ContractSchedule.hs +++ b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/SCHED/ContractSchedule.hs @@ -2,23 +2,21 @@ module Language.Marlowe.ACTUS.Model.SCHED.ContractSchedule where -import Control.Applicative (Alternative ((<|>))) -import Data.Ord (Down (..)) -import Data.Sort (sortOn) -import Data.Time (Day) -import Language.Marlowe.ACTUS.Definitions.BusinessEvents (EventType (..)) -import Language.Marlowe.ACTUS.Definitions.ContractState (ContractStatePoly (tmd)) -import Language.Marlowe.ACTUS.Definitions.ContractTerms (CT (..), ContractTerms (..), Cycle (..), - DCC, ScheduleConfig) -import Language.Marlowe.ACTUS.Definitions.Schedule (ShiftedDay (ShiftedDay, calculationDay, paymentDay), - ShiftedSchedule) -import Language.Marlowe.ACTUS.Model.INIT.StateInitializationModel (_INIT_LAM, _INIT_NAM) +import Control.Applicative (Alternative ((<|>))) +import Data.Ord (Down (..)) +import Data.Sort (sortOn) +import Data.Time (Day) +import Language.Marlowe.ACTUS.Definitions.BusinessEvents (EventType (..)) +import Language.Marlowe.ACTUS.Definitions.ContractTerms (CT (..), ContractTerms (..), Cycle (..), + ScheduleConfig (..)) +import Language.Marlowe.ACTUS.Definitions.Schedule (ShiftedDay (..)) import Language.Marlowe.ACTUS.Model.SCHED.ContractScheduleModel -import Language.Marlowe.ACTUS.Model.Utility.DateShift (applyBDCWithCfg) -import Language.Marlowe.ACTUS.Model.Utility.ScheduleGenerator (generateRecurrentScheduleWithCorrections, - inf, plusCycle, sup) -import Language.Marlowe.ACTUS.Ops (YearFractionOps (_y)) - +import Language.Marlowe.ACTUS.Model.Utility.DateShift (applyBDCWithCfg) +import Language.Marlowe.ACTUS.Model.Utility.ScheduleGenerator (applyEOMC, + generateRecurrentScheduleWithCorrections, + (<+>), (<->)) +import Language.Marlowe.ACTUS.Model.Utility.YearFraction (yearFraction) +import Language.Marlowe.ACTUS.Ops (YearFractionOps (_y)) schedule :: EventType -> ContractTerms -> Maybe [ShiftedDay] schedule ev c = let m = maturity c in schedule' ev c { ct_MD = m } @@ -86,68 +84,95 @@ schedule ev c = let m = maturity c in schedule' ev c { ct_MD = m } schedule' _ _ = Nothing - maturity :: ContractTerms -> Maybe Day -maturity ContractTerms{ contractType = PAM, ..} = ct_MD -maturity ct@ContractTerms{ contractType = LAM, ..} = - let t0 = ct_SD - fpSchedule = schedule FP ct - tfp_minus = maybe t0 calculationDay ((\sc -> sup sc t0) =<< fpSchedule) - tfp_plus = maybe t0 calculationDay ((\sc -> inf sc t0) =<< fpSchedule) - ipSchedule = schedule IP ct - tminus = maybe t0 calculationDay ((\sc -> sup sc t0) =<< ipSchedule) - prSchedule = schedule PR ct - tpr_minus = maybe t0 calculationDay ((\sc -> sup sc t0) =<< prSchedule) - in Just $ tmd $ _INIT_LAM ct_SD tminus tpr_minus tfp_minus tfp_plus ct - -maturity ct@ContractTerms{ contractType = NAM, ..} = - let t0 = ct_SD - fpSchedule = schedule FP ct - tfp_minus = maybe t0 calculationDay ((\sc -> sup sc t0) =<< fpSchedule) - tfp_plus = maybe t0 calculationDay ((\sc -> inf sc t0) =<< fpSchedule) - ipSchedule = schedule IP ct - tminus = maybe t0 calculationDay ((\sc -> sup sc t0) =<< ipSchedule) - prSchedule = schedule PR ct - tpr_minus = maybe t0 calculationDay ((\sc -> sup sc t0) =<< prSchedule) - in Just $ tmd $ _INIT_NAM ct_SD tminus tpr_minus tfp_minus tfp_plus ct - -maturity ContractTerms{ contractType = ANN, ..} = maturity' ct_SD ct_SD ct_DCC ct_AD ct_MD ct_IED ct_PRANX ct_PRCL ct_PRNXT ct_IPNR ct_NT - where - maturity' :: Day -- t0 - -> Day -- status date - -> Maybe DCC -- day count convention - -> Maybe Day -- amorization date - -> Maybe Day -- maturity date - -> Maybe Day -- initial exchange date - -> Maybe Day -- cycle anchor date of principal redemption - -> Maybe Cycle -- cycle of principal redemption - -> Maybe Double -- next principal redemption payment - -> Maybe Double -- nominal interest rate - -> Maybe Double -- notional principal - -> Maybe Day -- maturity - - maturity' t0 sd (Just dcc) Nothing Nothing (Just ied) (Just pranx) (Just prcl) (Just prnxt) (Just ipnr) (Just nt) = - let tplus = ied `plusCycle` prcl - - lastEvent - | pranx >= t0 = pranx - | tplus >= t0 = tplus - | otherwise = - let previousEvents = _S sd prcl pranx scfg - in calculationDay . head . sortOn (Down . calculationDay) . filter (\ShiftedDay {..} -> calculationDay > t0) $ previousEvents - - timeFromLastEventPlusOneCycle = _y dcc lastEvent (lastEvent `plusCycle` prcl) Nothing - - redemptionPerCycle = prnxt - timeFromLastEventPlusOneCycle * ipnr * nt - - remainingPeriods = (ceiling (nt / redemptionPerCycle) - 1) :: Integer - - in Just . calculationDay . applyBDCWithCfg scfg $ lastEvent `plusCycle` prcl {n = remainingPeriods} - - where - _S :: Day -> Cycle -> Day -> ScheduleConfig -> ShiftedSchedule - _S = generateRecurrentScheduleWithCorrections - - maturity' _ _ _ ad@(Just _) _ _ _ _ _ _ _ = ad - maturity' _ _ _ Nothing md@(Just _) _ _ _ _ _ _ = md - maturity' _ _ _ _ _ _ _ _ _ _ _ = Nothing +maturity ContractTerms {contractType = PAM, ..} = ct_MD +maturity ContractTerms {contractType = LAM, ct_MD = md@(Just _)} = md +maturity + ContractTerms + { contractType = LAM, + ct_MD = Nothing, + ct_PRANX = Just principalRedemptionAnchor, + ct_IPCL = Just interestPaymentCycle, + ct_PRCL = Just principalRedemptionCycle, + ct_PRNXT = Just nextPrincipalRedemptionPayment, + ct_NT = Just notionalPrincipal, + ct_SD = statusDate, + scfg = scheduleConfig + } = + let (lastEvent, remainingPeriods) + | principalRedemptionAnchor < statusDate = + let previousEvents = generateRecurrentScheduleWithCorrections principalRedemptionAnchor principalRedemptionCycle statusDate scheduleConfig + f1 = (\ShiftedDay {..} -> calculationDay > statusDate <-> interestPaymentCycle) + f2 = (\ShiftedDay {..} -> calculationDay == statusDate) + ShiftedDay {calculationDay = lastEventCalcDay} = head . filter f2 . filter f1 $ previousEvents + in (lastEventCalcDay, notionalPrincipal / nextPrincipalRedemptionPayment) + | otherwise = (principalRedemptionAnchor, notionalPrincipal / nextPrincipalRedemptionPayment - 1) + m = lastEvent <+> (principalRedemptionCycle {n = n principalRedemptionCycle * round remainingPeriods :: Integer}) + in eomc scheduleConfig >>= \d -> return $ applyEOMC lastEvent principalRedemptionCycle d m +maturity ContractTerms {contractType = NAM, ct_MD = md@(Just _)} = md +maturity + ContractTerms + { contractType = NAM, + ct_MD = Nothing, + ct_PRANX = Just principalRedemptionAnchor, + ct_PRNXT = Just nextPrincipalRedemptionPayment, + ct_IED = Just initialExchangeDate, + ct_PRCL = Just principalRedemptionCycle, + ct_NT = Just notionalPrincipal, + ct_IPNR = Just nominalInterestRate, + ct_DCC = Just dayCountConvention, + ct_SD = statusDate, + scfg = scheduleConfig + } = + let lastEvent + | principalRedemptionAnchor >= statusDate = principalRedemptionAnchor + | initialExchangeDate <+> principalRedemptionCycle >= statusDate = initialExchangeDate <+> principalRedemptionCycle + | otherwise = + let previousEvents = generateRecurrentScheduleWithCorrections principalRedemptionAnchor principalRedemptionCycle statusDate scheduleConfig + f = (\ShiftedDay {..} -> calculationDay == statusDate) + ShiftedDay {calculationDay = lastEventCalcDay} = head . filter f $ previousEvents + in lastEventCalcDay + + yLastEventPlusPRCL = yearFraction dayCountConvention lastEvent (lastEvent <+> principalRedemptionCycle) Nothing + redemptionPerCycle = nextPrincipalRedemptionPayment - (yLastEventPlusPRCL * nominalInterestRate * notionalPrincipal) + remainingPeriods = ceiling (notionalPrincipal / redemptionPerCycle) - 1 + m = lastEvent <+> principalRedemptionCycle {n = n principalRedemptionCycle * remainingPeriods} + in eomc scheduleConfig >>= \d -> return $ applyEOMC lastEvent principalRedemptionCycle d m +maturity + ContractTerms + { contractType = ANN, + ct_AD = Nothing, + ct_MD = Nothing, + ct_PRANX = Just principalRedemptionAnchor, + ct_PRNXT = Just nextPrincipalRedemptionPayment, + ct_IED = Just initialExchangeDate, + ct_PRCL = Just principalRedemptionCycle, + ct_NT = Just notionalPrincipal, + ct_IPNR = Just nominalInterestRate, + ct_DCC = Just dayCountConvention, + ct_SD = t0, + scfg = scheduleConfig + } = + let tplus = initialExchangeDate <+> principalRedemptionCycle + lastEvent + | principalRedemptionAnchor >= t0 = principalRedemptionAnchor + | tplus >= t0 = tplus + | otherwise = + let previousEvents = generateRecurrentScheduleWithCorrections t0 principalRedemptionCycle principalRedemptionAnchor scheduleConfig + in calculationDay . head . sortOn (Down . calculationDay) . filter (\ShiftedDay {..} -> calculationDay > t0) $ previousEvents + timeFromLastEventPlusOneCycle = _y dayCountConvention lastEvent (lastEvent <+> principalRedemptionCycle) Nothing + redemptionPerCycle = nextPrincipalRedemptionPayment - timeFromLastEventPlusOneCycle * nominalInterestRate * notionalPrincipal + remainingPeriods = (ceiling (notionalPrincipal / redemptionPerCycle) - 1) :: Integer + in Just . calculationDay . applyBDCWithCfg scheduleConfig $ lastEvent <+> principalRedemptionCycle { n = remainingPeriods } +maturity + ContractTerms + { contractType = ANN, + ct_AD = ad@(Just _) + } = ad +maturity + ContractTerms + { contractType = ANN, + ct_AD = Nothing, + ct_MD = md@(Just _) + } = md +maturity _ = Nothing diff --git a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/Utility/ScheduleGenerator.hs b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/Utility/ScheduleGenerator.hs index 99e8175aa8d..e7fa296cfde 100644 --- a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/Utility/ScheduleGenerator.hs +++ b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/Utility/ScheduleGenerator.hs @@ -5,6 +5,8 @@ module Language.Marlowe.ACTUS.Model.Utility.ScheduleGenerator ( generateRecurrentScheduleWithCorrections , plusCycle , minusCycle + , (<+>) + , (<->) , sup , inf , remove @@ -101,6 +103,12 @@ plusCycle date cycle = shiftDate date (n cycle) (p cycle) minusCycle :: Day -> Cycle -> Day minusCycle date cycle = shiftDate date (-n cycle) (p cycle) +(<+>) :: Day -> Cycle -> Day +(<+>) = plusCycle + +(<->) :: Day -> Cycle -> Day +(<->) = minusCycle + shiftDate :: Day -> Integer -> Period -> Day shiftDate date n p = case p of P_D -> addDays n date From f16963ab602f1377278e7c381557e16beac5bc27 Mon Sep 17 00:00:00 2001 From: Yves Hauser Date: Wed, 1 Sep 2021 10:55:45 +0200 Subject: [PATCH 09/28] scp-2709 - refactoring ACTUS code * pattern matching --- .../Marlowe/ACTUS/Model/POF/Payoff.hs | 218 +++++++++++++----- 1 file changed, 163 insertions(+), 55 deletions(-) diff --git a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/POF/Payoff.hs b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/POF/Payoff.hs index 3bb1b4d3a04..60561e93d35 100644 --- a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/POF/Payoff.hs +++ b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/POF/Payoff.hs @@ -2,7 +2,6 @@ module Language.Marlowe.ACTUS.Model.POF.Payoff where -import Data.Maybe (fromJust) import Data.Time (Day) import Language.Marlowe.ACTUS.Definitions.BusinessEvents (EventType (..), RiskFactors (..)) import Language.Marlowe.ACTUS.Definitions.ContractState (ContractState, ContractStatePoly (..)) @@ -10,58 +9,167 @@ import Language.Marlowe.ACTUS.Definitions.ContractTerms (CT (..), Con import Language.Marlowe.ACTUS.Model.POF.PayoffModel import Language.Marlowe.ACTUS.Ops (YearFractionOps (_y)) - - payoff :: EventType -> RiskFactors -> ContractTerms -> ContractState -> Day -> Double -payoff ev RiskFactors{..} ContractTerms{..} ContractStatePoly {..} t = - let - y_sd_t = _y (fromJust ct_DCC) sd t ct_MD - in case contractType of - PAM -> - case ev of - IED -> _POF_IED_PAM o_rf_CURS ct_CNTRL (fromJust ct_NT) (fromJust ct_PDIED) - MD -> _POF_MD_PAM o_rf_CURS nsc nt isc ipac feac - PP -> _POF_PP_PAM o_rf_CURS pp_payoff - PY -> _POF_PY_PAM (fromJust ct_PYTP) o_rf_CURS o_rf_RRMO (fromJust ct_PYRT) ct_cPYRT ct_CNTRL nt ipnr y_sd_t - FP -> _POF_FP_PAM (fromJust ct_FEB) (fromJust ct_FER) o_rf_CURS ct_CNTRL nt feac y_sd_t - PRD -> _POF_PRD_PAM o_rf_CURS ct_CNTRL (fromJust ct_PPRD) ipac ipnr nt y_sd_t - TD -> _POF_TD_PAM o_rf_CURS ct_CNTRL (fromJust ct_PTD) ipac ipnr nt y_sd_t - IP -> _POF_IP_PAM o_rf_CURS isc ipac ipnr nt y_sd_t - _ -> 0.0 - LAM -> - case ev of - IED -> _POF_IED_PAM o_rf_CURS ct_CNTRL (fromJust ct_NT) (fromJust ct_PDIED) - PR -> _POF_PR_LAM o_rf_CURS ct_CNTRL nt nsc prnxt - MD -> _POF_MD_PAM o_rf_CURS nsc nt isc ipac feac - PP -> _POF_PP_PAM o_rf_CURS pp_payoff - PY -> _POF_PY_PAM (fromJust ct_PYTP) o_rf_CURS o_rf_RRMO (fromJust ct_PYRT) ct_cPYRT ct_CNTRL nt ipnr y_sd_t - FP -> _POF_FP_PAM (fromJust ct_FEB) (fromJust ct_FER) o_rf_CURS ct_CNTRL nt feac y_sd_t - PRD -> _POF_PRD_LAM o_rf_CURS ct_CNTRL (fromJust ct_PPRD) ipac ipnr ipcb y_sd_t - TD -> _POF_TD_LAM o_rf_CURS ct_CNTRL (fromJust ct_PTD) ipac ipnr ipcb y_sd_t - IP -> _POF_IP_LAM o_rf_CURS isc ipac ipnr ipcb y_sd_t - _ -> 0.0 - NAM -> - case ev of - IED -> _POF_IED_PAM o_rf_CURS ct_CNTRL (fromJust ct_NT) (fromJust ct_PDIED) - PR -> _POF_PR_NAM o_rf_CURS ct_CNTRL nsc prnxt ipac y_sd_t ipnr ipcb nt - MD -> _POF_MD_PAM o_rf_CURS nsc nt isc ipac feac - PP -> _POF_PP_PAM o_rf_CURS pp_payoff - PY -> _POF_PY_PAM (fromJust ct_PYTP) o_rf_CURS o_rf_RRMO (fromJust ct_PYRT) ct_cPYRT ct_CNTRL nt ipnr y_sd_t - FP -> _POF_FP_PAM (fromJust ct_FEB) (fromJust ct_FER) o_rf_CURS ct_CNTRL nt feac y_sd_t - PRD -> _POF_PRD_LAM o_rf_CURS ct_CNTRL (fromJust ct_PPRD) ipac ipnr ipcb y_sd_t - TD -> _POF_TD_LAM o_rf_CURS ct_CNTRL (fromJust ct_PTD) ipac ipnr ipcb y_sd_t - IP -> _POF_IP_LAM o_rf_CURS isc ipac ipnr ipcb y_sd_t - _ -> 0.0 - ANN -> - case ev of - IED -> _POF_IED_PAM o_rf_CURS ct_CNTRL (fromJust ct_NT) (fromJust ct_PDIED) - PR -> _POF_PR_NAM o_rf_CURS ct_CNTRL nsc prnxt ipac y_sd_t ipnr ipcb nt - MD -> _POF_MD_PAM o_rf_CURS nsc nt isc ipac feac - PP -> _POF_PP_PAM o_rf_CURS pp_payoff - PY -> _POF_PY_PAM (fromJust ct_PYTP) o_rf_CURS o_rf_RRMO (fromJust ct_PYRT) ct_cPYRT ct_CNTRL nt ipnr y_sd_t - FP -> _POF_FP_PAM (fromJust ct_FEB) (fromJust ct_FER) o_rf_CURS ct_CNTRL nt feac y_sd_t - PRD -> _POF_PRD_LAM o_rf_CURS ct_CNTRL (fromJust ct_PPRD) ipac ipnr ipcb y_sd_t - TD -> _POF_TD_LAM o_rf_CURS ct_CNTRL (fromJust ct_PTD) ipac ipnr ipcb y_sd_t - IP -> _POF_IP_LAM o_rf_CURS isc ipac ipnr ipcb y_sd_t - _ -> 0.0 - +-- IED +payoff + IED + RiskFactors {..} + ContractTerms + { ct_NT = Just notionalPrincipal, + ct_PDIED = Just pdied, + ct_CNTRL = cntrl + } + _ + _ = _POF_IED_PAM o_rf_CURS cntrl notionalPrincipal pdied +-- PR +payoff + PR + RiskFactors {..} + ContractTerms + { contractType = LAM, + ct_CNTRL = cntrl + } + ContractStatePoly {..} + _ = _POF_PR_LAM o_rf_CURS cntrl nt nsc prnxt +payoff + PR + RiskFactors {..} + ContractTerms + { contractType = NAM, + ct_DCC = Just dayCountConvention, + ct_CNTRL = cntrl, + ct_MD = md + } + ContractStatePoly {..} + t = + let y_sd_t = _y dayCountConvention sd t md + in _POF_PR_NAM o_rf_CURS cntrl nsc prnxt ipac y_sd_t ipnr ipcb nt +payoff + PR + RiskFactors {..} + ContractTerms + { contractType = ANN, + ct_DCC = Just dayCountConvention, + ct_CNTRL = cntrl, + ct_MD = md + } + ContractStatePoly {..} + t = + let y_sd_t = _y dayCountConvention sd t md + in _POF_PR_NAM o_rf_CURS cntrl nsc prnxt ipac y_sd_t ipnr ipcb nt +-- MD +payoff MD RiskFactors {..} _ ContractStatePoly {..} _ = _POF_MD_PAM o_rf_CURS nsc nt isc ipac feac +-- PP +payoff PP RiskFactors {..} _ _ _ = _POF_PP_PAM o_rf_CURS pp_payoff +-- PY +payoff + PY + RiskFactors {..} + ContractTerms + { ct_PYTP = Just pytp, + ct_PYRT = Just pyrt, + ct_cPYRT = cpyrt, + ct_DCC = Just dayCountConvention, + ct_CNTRL = cntrl, + ct_MD = md + } + ContractStatePoly {..} + t = + let y_sd_t = _y dayCountConvention sd t md + in _POF_PY_PAM pytp o_rf_CURS o_rf_RRMO pyrt cpyrt cntrl nt ipnr y_sd_t +-- FP +payoff + FP + RiskFactors {..} + ContractTerms + { ct_DCC = Just dayCountConvention, + ct_CNTRL = cntrl, + ct_FEB = Just feb, + ct_FER = Just fer, + ct_MD = md + } + ContractStatePoly {..} + t = + let y_sd_t = _y dayCountConvention sd t md + in _POF_FP_PAM feb fer o_rf_CURS cntrl nt feac y_sd_t +-- PRD +payoff + PRD + RiskFactors {..} + ContractTerms + { contractType = PAM, + ct_DCC = Just dayCountConvention, + ct_CNTRL = cntrl, + ct_PPRD = Just pprd, + ct_MD = md + } + ContractStatePoly {..} + t = + let y_sd_t = _y dayCountConvention sd t md + in _POF_PRD_PAM o_rf_CURS cntrl pprd ipac ipnr nt y_sd_t +payoff + PRD + RiskFactors {..} + ContractTerms + { ct_DCC = Just dayCountConvention, + ct_CNTRL = cntrl, + ct_PPRD = Just pprd, + ct_MD = md + } + ContractStatePoly {..} + t = + let y_sd_t = _y dayCountConvention sd t md + in _POF_PRD_LAM o_rf_CURS cntrl pprd ipac ipnr ipcb y_sd_t +-- TD +payoff + TD + RiskFactors {..} + ContractTerms + { contractType = PAM, + ct_DCC = Just dayCountConvention, + ct_CNTRL = cntrl, + ct_PTD = Just ptd, + ct_MD = md + } + ContractStatePoly {..} + t = + let y_sd_t = _y dayCountConvention sd t md + in _POF_TD_PAM o_rf_CURS cntrl ptd ipac ipnr nt y_sd_t +payoff + TD + RiskFactors {..} + ContractTerms + { ct_DCC = Just dayCountConvention, + ct_CNTRL = cntrl, + ct_PTD = Just ptd, + ct_MD = md + } + ContractStatePoly {..} + t = + let y_sd_t = _y dayCountConvention sd t md + in _POF_TD_LAM o_rf_CURS cntrl ptd ipac ipnr ipcb y_sd_t +-- IP +payoff + IP + RiskFactors {..} + ContractTerms + { contractType = PAM, + ct_DCC = Just dayCountConvention, + ct_MD = md + } + ContractStatePoly {..} + t = + let y_sd_t = _y dayCountConvention sd t md + in _POF_IP_PAM o_rf_CURS isc ipac ipnr nt y_sd_t +payoff + IP + RiskFactors {..} + ContractTerms + { ct_DCC = Just dayCountConvention, + ct_MD = md + } + ContractStatePoly {..} + t = + let y_sd_t = _y dayCountConvention sd t md + in _POF_IP_LAM o_rf_CURS isc ipac ipnr ipcb y_sd_t +payoff _ _ _ _ _ = 0.0 From 9ceead04d7a02fd94c41c9f02c1548c0c3d94cb9 Mon Sep 17 00:00:00 2001 From: Yves Hauser Date: Wed, 1 Sep 2021 18:10:33 +0200 Subject: [PATCH 10/28] scp-2709 - refactoring ACTUS code * eliminating partial functions --- .../Marlowe/ACTUS/Model/POF/PayoffFs.hs | 150 ++++---- .../ACTUS/Model/STF/StateTransition.hs | 272 ++++++++------- .../ACTUS/Model/STF/StateTransitionFs.hs | 325 ++++++++++++------ .../ACTUS/Model/STF/StateTransitionModel.hs | 63 ++-- 4 files changed, 494 insertions(+), 316 deletions(-) diff --git a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/POF/PayoffFs.hs b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/POF/PayoffFs.hs index 5d31052183c..b84d4c44898 100644 --- a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/POF/PayoffFs.hs +++ b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/POF/PayoffFs.hs @@ -2,11 +2,10 @@ module Language.Marlowe.ACTUS.Model.POF.PayoffFs where -import Data.Maybe (fromJust) import Data.Time (Day) import Language.Marlowe (Observation, Value) -import Language.Marlowe.ACTUS.Definitions.BusinessEvents (EventType (FP, IED, IP, MD, PP, PR, PRD, PY, TD)) -import Language.Marlowe.ACTUS.Definitions.ContractTerms (CT (LAM, NAM, PAM), ContractTerms (..)) +import Language.Marlowe.ACTUS.Definitions.BusinessEvents (EventType (..)) +import Language.Marlowe.ACTUS.Definitions.ContractTerms (CT (..), ContractTerms (..)) import Language.Marlowe.ACTUS.MarloweCompat (constnt, enum, useval) import Language.Marlowe.ACTUS.Model.POF.PayoffModel import Language.Marlowe.ACTUS.Ops (ActusNum (..), YearFractionOps (_y), @@ -14,61 +13,90 @@ import Language.Marlowe.ACTUS.Ops (ActusNum (.. import Prelude hiding (Fractional, Num, (*), (+), (-), (/)) payoffFs :: EventType -> ContractTerms -> Integer -> Integer -> Day -> Day -> Maybe (Value Observation) -payoffFs ev ContractTerms{..} t t_minus prevDate curDate = - let __NT = constnt (fromJust ct_NT) - __PDIED = constnt (fromJust ct_PDIED) - __PYTP = enum (fromJust ct_PYTP) - __FEB = enum (fromJust ct_FEB) - __FER = constnt (fromJust ct_FER) - (__PPRD, __PTD ) = (constnt (fromJust ct_PPRD), constnt (fromJust ct_PTD)) - (__PYRT, __cPYRT) = (constnt (fromJust ct_PYRT), constnt ct_cPYRT) - - - __o_rf_CURS = useval "o_rf_CURS" t - __o_rf_RRMO = useval "o_rf_RRMO" t - __pp_payoff = useval "pp_payoff" t - __nsc = useval "nsc" t_minus - __nt = useval "nt" t_minus - __isc = useval "isc" t_minus - __ipac = useval "ipac" t_minus - __feac = useval "feac" t_minus - __ipnr = useval "ipnr" t_minus - __ipcb = useval "ipcb" t_minus - __prnxt = useval "prnxt" t_minus - - y_sd_t = constnt $ _y (fromJust ct_DCC) prevDate curDate ct_MD - - pof = case contractType of - PAM -> case ev of - IED -> Just $ _POF_IED_PAM __o_rf_CURS ct_CNTRL __NT __PDIED - MD -> Just $ _POF_MD_PAM __o_rf_CURS __nsc __nt __isc __ipac __feac - PP -> Just $ _POF_PP_PAM __o_rf_CURS __pp_payoff - PY -> Just $ _POF_PY_PAM __PYTP __o_rf_CURS __o_rf_RRMO __PYRT __cPYRT ct_CNTRL __nt __ipnr y_sd_t - FP -> Just $ _POF_FP_PAM __FEB __FER __o_rf_CURS ct_CNTRL __nt __feac y_sd_t - PRD -> Just $ _POF_PRD_PAM __o_rf_CURS ct_CNTRL __PPRD __ipac __ipnr __nt y_sd_t - TD -> Just $ _POF_TD_PAM __o_rf_CURS ct_CNTRL __PTD __ipac __ipnr __nt y_sd_t - IP -> Just $ _POF_IP_PAM __o_rf_CURS __isc __ipac __ipnr __nt y_sd_t - _ -> Nothing - LAM -> case ev of - IED -> Just $ _POF_IED_PAM __o_rf_CURS ct_CNTRL __NT __PDIED - PR -> Just $ _POF_PR_LAM __o_rf_CURS ct_CNTRL __nt __nsc __prnxt - MD -> Just $ _POF_MD_PAM __o_rf_CURS __nsc __nt __isc __ipac __feac - PP -> Just $ _POF_PP_PAM __o_rf_CURS __pp_payoff - PY -> Just $ _POF_PY_PAM __PYTP __o_rf_CURS __o_rf_RRMO __PYRT __cPYRT ct_CNTRL __nt __ipnr y_sd_t - FP -> Just $ _POF_FP_PAM __FEB __FER __o_rf_CURS ct_CNTRL __nt __feac y_sd_t - PRD -> Just $ _POF_PRD_LAM __o_rf_CURS ct_CNTRL __PPRD __ipac __ipnr __ipcb y_sd_t - TD -> Just $ _POF_TD_LAM __o_rf_CURS ct_CNTRL __PTD __ipac __ipnr __ipcb y_sd_t - IP -> Just $ _POF_IP_LAM __o_rf_CURS __isc __ipac __ipnr __ipcb y_sd_t - _ -> Nothing - NAM -> case ev of - IED -> Just $ _POF_IED_PAM __o_rf_CURS ct_CNTRL __NT __PDIED - PR -> Just $ _POF_PR_NAM __o_rf_CURS ct_CNTRL __nsc __prnxt __ipac y_sd_t __ipnr __ipcb __nt - MD -> Just $ _POF_MD_PAM __o_rf_CURS __nsc __nt __isc __ipac __feac - PP -> Just $ _POF_PP_PAM __o_rf_CURS __pp_payoff - PY -> Just $ _POF_PY_PAM __PYTP __o_rf_CURS __o_rf_RRMO __PYRT __cPYRT ct_CNTRL __nt __ipnr y_sd_t - FP -> Just $ _POF_FP_PAM __FEB __FER __o_rf_CURS ct_CNTRL __nt __feac y_sd_t - PRD -> Just $ _POF_PRD_LAM __o_rf_CURS ct_CNTRL __PPRD __ipac __ipnr __ipcb y_sd_t - TD -> Just $ _POF_TD_LAM __o_rf_CURS ct_CNTRL __PTD __ipac __ipnr __ipcb y_sd_t - IP -> Just $ _POF_IP_LAM __o_rf_CURS __isc __ipac __ipnr __ipcb y_sd_t - _ -> Nothing - in (\x -> x / (constnt $ fromIntegral marloweFixedPoint)) <$> pof +payoffFs + ev + ContractTerms + { ct_NT = Just np, + ct_PDIED = Just pdied, + ct_PYTP = Just pytp, + ct_FEB = Just feb, + ct_FER = Just fer, + ct_PPRD = Just pprd, + ct_PYRT = Just pyrt, + ct_PTD = Just ptd, + ct_DCC = Just dayCountConvention, + ct_cPYRT = cpyrt, + .. + } + t + t_minus + prevDate + curDate = + let pof = case contractType of + PAM -> case ev of + IED -> Just $ _POF_IED_PAM o_rf_CURS ct_CNTRL notionalPrincipal premiumDiscount + MD -> Just $ _POF_MD_PAM o_rf_CURS nsc nt isc ipac feac + PP -> Just $ _POF_PP_PAM o_rf_CURS pp_payoff + PY -> Just $ _POF_PY_PAM penaltyType o_rf_CURS o_rf_RRMO penaltyRate cPenaltyRate ct_CNTRL nt ipnr y_sd_t + FP -> Just $ _POF_FP_PAM feeBase feeRate o_rf_CURS ct_CNTRL nt feac y_sd_t + PRD -> Just $ _POF_PRD_PAM o_rf_CURS ct_CNTRL priceAtPurchaseDate ipac ipnr nt y_sd_t + TD -> Just $ _POF_TD_PAM o_rf_CURS ct_CNTRL priceAtTerminationDate ipac ipnr nt y_sd_t + IP -> Just $ _POF_IP_PAM o_rf_CURS isc ipac ipnr nt y_sd_t + _ -> Nothing + LAM -> case ev of + IED -> Just $ _POF_IED_PAM o_rf_CURS ct_CNTRL notionalPrincipal premiumDiscount + PR -> Just $ _POF_PR_LAM o_rf_CURS ct_CNTRL nt nsc prnxt + MD -> Just $ _POF_MD_PAM o_rf_CURS nsc nt isc ipac feac + PP -> Just $ _POF_PP_PAM o_rf_CURS pp_payoff + PY -> Just $ _POF_PY_PAM penaltyType o_rf_CURS o_rf_RRMO penaltyRate cPenaltyRate ct_CNTRL nt ipnr y_sd_t + FP -> Just $ _POF_FP_PAM feeBase feeRate o_rf_CURS ct_CNTRL nt feac y_sd_t + PRD -> Just $ _POF_PRD_LAM o_rf_CURS ct_CNTRL priceAtPurchaseDate ipac ipnr ipcb y_sd_t + TD -> Just $ _POF_TD_LAM o_rf_CURS ct_CNTRL priceAtTerminationDate ipac ipnr ipcb y_sd_t + IP -> Just $ _POF_IP_LAM o_rf_CURS isc ipac ipnr ipcb y_sd_t + _ -> Nothing + NAM -> case ev of + IED -> Just $ _POF_IED_PAM o_rf_CURS ct_CNTRL notionalPrincipal premiumDiscount + PR -> Just $ _POF_PR_NAM o_rf_CURS ct_CNTRL nsc prnxt ipac y_sd_t ipnr ipcb nt + MD -> Just $ _POF_MD_PAM o_rf_CURS nsc nt isc ipac feac + PP -> Just $ _POF_PP_PAM o_rf_CURS pp_payoff + PY -> Just $ _POF_PY_PAM penaltyType o_rf_CURS o_rf_RRMO penaltyRate cPenaltyRate ct_CNTRL nt ipnr y_sd_t + FP -> Just $ _POF_FP_PAM feeBase feeRate o_rf_CURS ct_CNTRL nt feac y_sd_t + PRD -> Just $ _POF_PRD_LAM o_rf_CURS ct_CNTRL priceAtPurchaseDate ipac ipnr ipcb y_sd_t + TD -> Just $ _POF_TD_LAM o_rf_CURS ct_CNTRL priceAtTerminationDate ipac ipnr ipcb y_sd_t + IP -> Just $ _POF_IP_LAM o_rf_CURS isc ipac ipnr ipcb y_sd_t + _ -> Nothing + ANN -> case ev of + IED -> Just $ _POF_IED_PAM o_rf_CURS ct_CNTRL notionalPrincipal premiumDiscount + PR -> Just $ _POF_PR_NAM o_rf_CURS ct_CNTRL nsc prnxt ipac y_sd_t ipnr ipcb nt + MD -> Just $ _POF_MD_PAM o_rf_CURS nsc nt isc ipac feac + PP -> Just $ _POF_PP_PAM o_rf_CURS pp_payoff + PY -> Just $ _POF_PY_PAM penaltyType o_rf_CURS o_rf_RRMO penaltyRate cPenaltyRate ct_CNTRL nt ipnr y_sd_t + FP -> Just $ _POF_FP_PAM feeBase feeRate o_rf_CURS ct_CNTRL nt feac y_sd_t + PRD -> Just $ _POF_PRD_LAM o_rf_CURS ct_CNTRL priceAtPurchaseDate ipac ipnr ipcb y_sd_t + TD -> Just $ _POF_TD_LAM o_rf_CURS ct_CNTRL priceAtTerminationDate ipac ipnr ipcb y_sd_t + IP -> Just $ _POF_IP_LAM o_rf_CURS isc ipac ipnr ipcb y_sd_t + _ -> Nothing + in (\x -> x / (constnt $ fromIntegral marloweFixedPoint)) <$> pof + where + notionalPrincipal = constnt np + premiumDiscount = constnt pdied + penaltyType = enum pytp + feeBase = enum feb + feeRate = constnt fer + priceAtPurchaseDate = constnt pprd + priceAtTerminationDate = constnt ptd + penaltyRate = constnt pyrt + cPenaltyRate = constnt cpyrt + o_rf_CURS = useval "o_rf_CURS" t + o_rf_RRMO = useval "o_rf_RRMO" t + pp_payoff = useval "pp_payoff" t + nsc = useval "nsc" t_minus + nt = useval "nt" t_minus + isc = useval "isc" t_minus + ipac = useval "ipac" t_minus + feac = useval "feac" t_minus + ipnr = useval "ipnr" t_minus + ipcb = useval "ipcb" t_minus + prnxt = useval "prnxt" t_minus + y_sd_t = constnt $ _y dayCountConvention prevDate curDate ct_MD +payoffFs _ _ _ _ _ _ = Nothing diff --git a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/STF/StateTransition.hs b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/STF/StateTransition.hs index 6779535259b..d12b5048c8a 100644 --- a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/STF/StateTransition.hs +++ b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/STF/StateTransition.hs @@ -2,135 +2,171 @@ module Language.Marlowe.ACTUS.Model.STF.StateTransition where -import Data.Maybe (fromJust, maybeToList) +import Data.Maybe (maybeToList) import Data.Time (Day) import Language.Marlowe.ACTUS.Definitions.BusinessEvents (EventType (..), RiskFactors (..)) import Language.Marlowe.ACTUS.Definitions.ContractState (ContractState, ContractStatePoly (..)) -import Language.Marlowe.ACTUS.Definitions.ContractTerms (CT (..), ContractTerms (..), ScheduleConfig) +import Language.Marlowe.ACTUS.Definitions.ContractTerms (CT (..), ContractTerms (..)) import Language.Marlowe.ACTUS.Definitions.Schedule (ShiftedDay (calculationDay)) import Language.Marlowe.ACTUS.Model.SCHED.ContractSchedule (maturity, schedule) import Language.Marlowe.ACTUS.Model.STF.StateTransitionModel -import Language.Marlowe.ACTUS.Model.Utility.DateShift import Language.Marlowe.ACTUS.Model.Utility.ScheduleGenerator (inf, sup) import Language.Marlowe.ACTUS.Ops (YearFractionOps (_y)) - -shift :: ScheduleConfig -> Day -> ShiftedDay -shift = applyBDCWithCfg - stateTransition :: EventType -> RiskFactors -> ContractTerms -> ContractState -> Day -> ContractState -stateTransition ev RiskFactors{..} terms@ContractTerms{..} st@ContractStatePoly{..} t = - let - ct_DCC' = fromJust ct_DCC - ct_FER' = fromJust ct_FER - ct_RRLF' = fromJust ct_RRLF - ct_RRLC' = fromJust ct_RRLC - ct_RRPC' = fromJust ct_RRPC - ct_RRPF' = fromJust ct_RRPF - ct_RRMLT' = fromJust ct_RRMLT - ct_RRSP' = fromJust ct_RRSP - ct_SCEF' = fromJust ct_SCEF - ct_SCIED' = fromJust ct_SCIED -- TODO: check for other CTs - ct_SCCDD' = fromJust ct_SCCDD - - fpSchedule = schedule FP terms - prSchedule = schedule PR terms - - tfp_minus = maybe t calculationDay ((\sc -> sup sc t) =<< fpSchedule) - tfp_plus = maybe t calculationDay ((\sc -> inf sc t) =<< fpSchedule) - - tpr_minus = maybe t calculationDay ((\sc -> sup sc t) =<< prSchedule) - tpr_plus = maybe t calculationDay ((\sc -> inf sc t) =<< prSchedule) - - y_sd_t = _y ct_DCC' sd t ct_MD - y_tfpminus_t = _y ct_DCC' tfp_minus t ct_MD - y_tfpminus_tfpplus = _y ct_DCC' tfp_minus tfp_plus ct_MD - y_ipanx_t = _y ct_DCC' (fromJust ct_IPANX) t ct_MD - - y_tprminus_t = _y ct_DCC' tpr_minus t ct_MD - y_tprminus_tprplus = _y ct_DCC' tpr_minus tpr_plus ct_MD +stateTransition + ev + RiskFactors {..} + ct@ContractTerms + { ct_DCC = Just dayCountConvention, + ct_FER = Just feeRate, + ct_IPANX = ipanx@(Just interestPaymentAnchor), + .. + } + st@ContractStatePoly {..} + t = stf ev ct + where + stf :: EventType -> ContractTerms -> ContractState + stf AD _ = _STF_AD_PAM st t y_sd_t + stf + IED + ContractTerms + { contractType = PAM, + ct_NT = Just notionalPrincipal + } = _STF_IED_PAM st t y_ipanx_t ct_IPNR ipanx ct_CNTRL ct_IPAC notionalPrincipal + stf + IED + ContractTerms + { ct_NT = Just notionalPrincipal + } = _STF_IED_LAM st t y_ipanx_t ct_IPNR ipanx ct_CNTRL ct_IPAC notionalPrincipal ct_IPCB ct_IPCBA + stf PR ContractTerms {contractType = LAM} = _STF_PR_LAM st t y_sd_t y_tfpminus_t y_tfpminus_tfpplus ct_FEB feeRate ct_CNTRL ct_IPCB + stf PR ContractTerms {contractType = NAM} = _STF_PR_NAM st t pp_payoff y_sd_t y_tfpminus_t y_tfpminus_tfpplus ct_FEB feeRate ct_CNTRL ct_IPCB + stf PR ContractTerms {contractType = ANN} = _STF_PR_NAM st t pp_payoff y_sd_t y_tfpminus_t y_tfpminus_tfpplus ct_FEB feeRate ct_CNTRL ct_IPCB + stf MD _ = _STF_MD_PAM st t + stf PP ContractTerms {contractType = PAM} = _STF_PP_PAM st t pp_payoff y_sd_t y_tfpminus_t y_tfpminus_tfpplus ct_FEB feeRate ct_CNTRL + stf PP ContractTerms {contractType = LAM} = _STF_PP_LAM st t pp_payoff y_sd_t y_tfpminus_t y_tfpminus_tfpplus ct_FEB feeRate ct_CNTRL ct_IPCB + stf PP ContractTerms {contractType = NAM} = _STF_PP_LAM st t pp_payoff y_sd_t y_tfpminus_t y_tfpminus_tfpplus ct_FEB feeRate ct_CNTRL ct_IPCB + stf PP ContractTerms {contractType = ANN} = _STF_PP_LAM st t pp_payoff y_sd_t y_tfpminus_t y_tfpminus_tfpplus ct_FEB feeRate ct_CNTRL ct_IPCB + stf PY ContractTerms {contractType = PAM} = _STF_PY_PAM st t y_sd_t y_tfpminus_t y_tfpminus_tfpplus ct_FEB feeRate ct_CNTRL + stf PY ContractTerms {contractType = LAM} = _STF_PY_LAM st t y_sd_t y_tfpminus_t y_tfpminus_tfpplus ct_FEB feeRate ct_CNTRL + stf PY ContractTerms {contractType = NAM} = _STF_PY_LAM st t y_sd_t y_tfpminus_t y_tfpminus_tfpplus ct_FEB feeRate ct_CNTRL + stf PY ContractTerms {contractType = ANN} = _STF_PY_LAM st t y_sd_t y_tfpminus_t y_tfpminus_tfpplus ct_FEB feeRate ct_CNTRL + stf FP ContractTerms {contractType = PAM} = _STF_FP_PAM st t y_sd_t + stf FP ContractTerms {contractType = LAM} = _STF_FP_LAM st t y_sd_t + stf FP ContractTerms {contractType = NAM} = _STF_FP_LAM st t y_sd_t + stf FP ContractTerms {contractType = ANN} = _STF_FP_LAM st t y_sd_t + stf PRD ContractTerms {contractType = PAM} = _STF_PRD_PAM st t y_sd_t y_tfpminus_t y_tfpminus_tfpplus ct_FEB feeRate ct_CNTRL + stf PRD ContractTerms {contractType = LAM} = _STF_PRD_LAM st t y_sd_t y_tfpminus_t y_tfpminus_tfpplus ct_FEB feeRate ct_CNTRL + stf PRD ContractTerms {contractType = NAM} = _STF_PRD_LAM st t y_sd_t y_tfpminus_t y_tfpminus_tfpplus ct_FEB feeRate ct_CNTRL + stf PRD ContractTerms {contractType = ANN} = _STF_PRD_LAM st t y_sd_t y_tfpminus_t y_tfpminus_tfpplus ct_FEB feeRate ct_CNTRL + stf TD _ = _STF_TD_PAM st t + stf IP _ = _STF_IP_PAM st t y_sd_t y_tfpminus_t y_tfpminus_tfpplus ct_FEB feeRate ct_CNTRL + stf IPCI ContractTerms {contractType = PAM} = _STF_IPCI_PAM st t y_sd_t y_tfpminus_t y_tfpminus_tfpplus ct_FEB feeRate ct_CNTRL + stf IPCI ContractTerms {contractType = LAM} = _STF_IPCI_LAM st t y_sd_t y_tfpminus_t y_tfpminus_tfpplus ct_FEB feeRate ct_CNTRL ct_IPCB + stf IPCI ContractTerms {contractType = NAM} = _STF_IPCI_LAM st t y_sd_t y_tfpminus_t y_tfpminus_tfpplus ct_FEB feeRate ct_CNTRL ct_IPCB + stf IPCI ContractTerms {contractType = ANN} = _STF_IPCI_LAM st t y_sd_t y_tfpminus_t y_tfpminus_tfpplus ct_FEB feeRate ct_CNTRL ct_IPCB + stf IPCB ContractTerms {contractType = LAM} = _STF_IPCB_LAM st t y_sd_t y_tfpminus_t y_tfpminus_tfpplus ct_FEB feeRate ct_CNTRL + stf IPCB ContractTerms {contractType = NAM} = _STF_IPCB_LAM st t y_sd_t y_tfpminus_t y_tfpminus_tfpplus ct_FEB feeRate ct_CNTRL + stf IPCB ContractTerms {contractType = ANN} = _STF_IPCB_LAM st t y_sd_t y_tfpminus_t y_tfpminus_tfpplus ct_FEB feeRate ct_CNTRL + stf + RR + ContractTerms + { contractType = PAM, + ct_RRLF = Just rrlf, + ct_RRLC = Just rrlc, + ct_RRPC = Just rrpc, + ct_RRPF = Just rrpf, + ct_RRMLT = Just rrmlt, + ct_RRSP = Just rrsp + } = _STF_RR_PAM st t y_sd_t y_tfpminus_t y_tfpminus_tfpplus ct_FEB feeRate ct_CNTRL rrlf rrlc rrpc rrpf rrmlt rrsp o_rf_RRMO + stf + RR + ContractTerms + { contractType = LAM, + ct_RRLF = Just rrlf, + ct_RRLC = Just rrlc, + ct_RRPC = Just rrpc, + ct_RRPF = Just rrpf, + ct_RRMLT = Just rrmlt, + ct_RRSP = Just rrsp + } = _STF_RR_LAM st t y_sd_t y_tfpminus_t y_tfpminus_tfpplus ct_FEB feeRate ct_CNTRL rrlf rrlc rrpc rrpf rrmlt rrsp o_rf_RRMO + stf + RR + ContractTerms + { contractType = NAM, + ct_RRLF = Just rrlf, + ct_RRLC = Just rrlc, + ct_RRPC = Just rrpc, + ct_RRPF = Just rrpf, + ct_RRMLT = Just rrmlt, + ct_RRSP = Just rrsp + } = _STF_RR_LAM st t y_sd_t y_tfpminus_t y_tfpminus_tfpplus ct_FEB feeRate ct_CNTRL rrlf rrlc rrpc rrpf rrmlt rrsp o_rf_RRMO + stf + RR + ContractTerms + { contractType = ANN, + ct_RRLF = Just rrlf, + ct_RRLC = Just rrlc, + ct_RRPC = Just rrpc, + ct_RRPF = Just rrpf, + ct_RRMLT = Just rrmlt, + ct_RRSP = Just rrsp + } = _STF_RR_ANN st t y_sd_t y_tfpminus_t y_tfpminus_tfpplus ct_FEB feeRate ct_CNTRL rrlf rrlc rrpc rrpf rrmlt rrsp o_rf_RRMO ti + stf RRF ContractTerms {contractType = PAM} = _STF_RRF_PAM st t y_sd_t y_tfpminus_t y_tfpminus_tfpplus ct_FEB feeRate ct_CNTRL ct_RRNXT + stf RRF ContractTerms {contractType = LAM} = _STF_RRF_LAM st t y_sd_t y_tfpminus_t y_tfpminus_tfpplus ct_FEB feeRate ct_CNTRL ct_RRNXT + stf RRF ContractTerms {contractType = NAM} = _STF_RRF_LAM st t y_sd_t y_tfpminus_t y_tfpminus_tfpplus ct_FEB feeRate ct_CNTRL ct_RRNXT + stf + RRF + ContractTerms + { contractType = ANN, + ct_RRNXT = Just rrnxt + } = _STF_RRF_ANN st t y_sd_t y_tfpminus_t y_tfpminus_tfpplus ct_FEB feeRate ct_CNTRL rrnxt ti + stf PRF ContractTerms {contractType = ANN} = _STF_PRF_ANN st t y_sd_t y_tfpminus_t y_tfpminus_tfpplus ct_FEB feeRate ct_CNTRL ct_RRNXT y_t ti + stf + SC + ContractTerms + { contractType = PAM, + ct_SCEF = Just scef, + ct_SCIED = Just scied + } = _STF_SC_PAM st t y_sd_t y_tfpminus_t y_tfpminus_tfpplus ct_FEB feeRate ct_CNTRL scef o_rf_SCMO scied + stf + SC + ContractTerms + { contractType = LAM, + ct_SCEF = Just scef, + ct_SCCDD = Just sccdd + } = _STF_SC_LAM st t y_sd_t y_tfpminus_t y_tfpminus_tfpplus ct_FEB feeRate ct_CNTRL scef o_rf_SCMO sccdd + stf + SC + ContractTerms + { contractType = NAM, + ct_SCEF = Just scef, + ct_SCCDD = Just sccdd + } = _STF_SC_LAM st t y_sd_t y_tfpminus_t y_tfpminus_tfpplus ct_FEB feeRate ct_CNTRL scef o_rf_SCMO sccdd + stf + SC + ContractTerms + { contractType = ANN, + ct_SCEF = Just scef, + ct_SCCDD = Just sccdd + } = _STF_SC_LAM st t y_sd_t y_tfpminus_t y_tfpminus_tfpplus ct_FEB feeRate ct_CNTRL scef o_rf_SCMO sccdd + stf CE _ = _STF_CE_PAM st t y_sd_t + stf _ _ = st - y_t = _y ct_DCC' t tpr_plus ct_MD - in case contractType of - PAM -> - case ev of - AD -> _STF_AD_PAM st t y_sd_t - IED -> _STF_IED_PAM st t y_ipanx_t ct_IPNR ct_IPANX ct_CNTRL ct_IPAC (fromJust ct_NT) - MD -> _STF_MD_PAM st t - PP -> _STF_PP_PAM st t pp_payoff y_sd_t y_tfpminus_t y_tfpminus_tfpplus ct_FEB ct_FER' ct_CNTRL - PY -> _STF_PY_PAM st t y_sd_t y_tfpminus_t y_tfpminus_tfpplus ct_FEB ct_FER' ct_CNTRL - FP -> _STF_FP_PAM st t y_sd_t - PRD -> _STF_PRD_PAM st t y_sd_t y_tfpminus_t y_tfpminus_tfpplus ct_FEB ct_FER' ct_CNTRL - TD -> _STF_TD_PAM st t - IP -> _STF_IP_PAM st t y_sd_t y_tfpminus_t y_tfpminus_tfpplus ct_FEB ct_FER' ct_CNTRL - IPCI -> _STF_IPCI_PAM st t y_sd_t y_tfpminus_t y_tfpminus_tfpplus ct_FEB ct_FER' ct_CNTRL - RR -> _STF_RR_PAM st t y_sd_t y_tfpminus_t y_tfpminus_tfpplus ct_FEB ct_FER' ct_CNTRL ct_RRLF' ct_RRLC' ct_RRPC' ct_RRPF' ct_RRMLT' ct_RRSP' o_rf_RRMO - RRF -> _STF_RRF_PAM st t y_sd_t y_tfpminus_t y_tfpminus_tfpplus ct_FEB ct_FER' ct_CNTRL ct_RRNXT - SC -> _STF_SC_PAM st t y_sd_t y_tfpminus_t y_tfpminus_tfpplus ct_FEB ct_FER' ct_CNTRL ct_SCEF' o_rf_SCMO ct_SCIED' - CE -> _STF_CE_PAM st t y_sd_t - _ -> st - LAM -> - case ev of - AD -> _STF_AD_PAM st t y_sd_t - IED -> _STF_IED_LAM st t y_ipanx_t ct_IPNR ct_IPANX ct_CNTRL ct_IPAC (fromJust ct_NT) ct_IPCB ct_IPCBA - PR -> _STF_PR_LAM st t y_sd_t y_tfpminus_t y_tfpminus_tfpplus ct_FEB ct_FER' ct_CNTRL ct_IPCB - MD -> _STF_MD_LAM st t - PP -> _STF_PP_LAM st t pp_payoff y_sd_t y_tfpminus_t y_tfpminus_tfpplus ct_FEB ct_FER' ct_CNTRL ct_IPCB - PY -> _STF_PY_LAM st t y_sd_t y_tfpminus_t y_tfpminus_tfpplus ct_FEB ct_FER' ct_CNTRL - FP -> _STF_FP_LAM st t y_sd_t - PRD -> _STF_PRD_LAM st t y_sd_t y_tfpminus_t y_tfpminus_tfpplus ct_FEB ct_FER' ct_CNTRL - TD -> _STF_TD_PAM st t - IP -> _STF_IP_PAM st t y_sd_t y_tfpminus_t y_tfpminus_tfpplus ct_FEB ct_FER' ct_CNTRL - IPCI -> _STF_IPCI_LAM st t y_sd_t y_tfpminus_t y_tfpminus_tfpplus ct_FEB ct_FER' ct_CNTRL ct_IPCB - IPCB -> _STF_IPCB_LAM st t y_sd_t y_tfpminus_t y_tfpminus_tfpplus ct_FEB ct_FER' ct_CNTRL - RR -> _STF_RR_LAM st t y_sd_t y_tfpminus_t y_tfpminus_tfpplus ct_FEB ct_FER' ct_CNTRL ct_RRLF' ct_RRLC' ct_RRPC' ct_RRPF' ct_RRMLT' ct_RRSP' o_rf_RRMO - RRF -> _STF_RRF_LAM st t y_sd_t y_tfpminus_t y_tfpminus_tfpplus ct_FEB ct_FER' ct_CNTRL ct_RRNXT - SC -> _STF_SC_LAM st t y_sd_t y_tfpminus_t y_tfpminus_tfpplus ct_FEB ct_FER' ct_CNTRL ct_SCEF' o_rf_SCMO ct_SCCDD' - CE -> _STF_CE_PAM st t y_sd_t - _ -> st - NAM -> - case ev of - AD -> _STF_AD_PAM st t y_sd_t - IED -> _STF_IED_LAM st t y_ipanx_t ct_IPNR ct_IPANX ct_CNTRL ct_IPAC (fromJust ct_NT) ct_IPCB ct_IPCBA - PR -> _STF_PR_NAM st t pp_payoff y_sd_t y_tfpminus_t y_tfpminus_tfpplus ct_FEB ct_FER' ct_CNTRL ct_IPCB - MD -> _STF_MD_LAM st t - PP -> _STF_PP_LAM st t pp_payoff y_sd_t y_tfpminus_t y_tfpminus_tfpplus ct_FEB ct_FER' ct_CNTRL ct_IPCB - PY -> _STF_PY_LAM st t y_sd_t y_tfpminus_t y_tfpminus_tfpplus ct_FEB ct_FER' ct_CNTRL - FP -> _STF_FP_LAM st t y_sd_t - PRD -> _STF_PRD_LAM st t y_sd_t y_tfpminus_t y_tfpminus_tfpplus ct_FEB ct_FER' ct_CNTRL - TD -> _STF_TD_PAM st t - IP -> _STF_IP_PAM st t y_sd_t y_tfpminus_t y_tfpminus_tfpplus ct_FEB ct_FER' ct_CNTRL - IPCI -> _STF_IPCI_LAM st t y_sd_t y_tfpminus_t y_tfpminus_tfpplus ct_FEB ct_FER' ct_CNTRL ct_IPCB - IPCB -> _STF_IPCB_LAM st t y_sd_t y_tfpminus_t y_tfpminus_tfpplus ct_FEB ct_FER' ct_CNTRL - RR -> _STF_RR_LAM st t y_sd_t y_tfpminus_t y_tfpminus_tfpplus ct_FEB ct_FER' ct_CNTRL ct_RRLF' ct_RRLC' ct_RRPC' ct_RRPF' ct_RRMLT' ct_RRSP' o_rf_RRMO - RRF -> _STF_RRF_LAM st t y_sd_t y_tfpminus_t y_tfpminus_tfpplus ct_FEB ct_FER' ct_CNTRL ct_RRNXT - SC -> _STF_SC_LAM st t y_sd_t y_tfpminus_t y_tfpminus_tfpplus ct_FEB ct_FER' ct_CNTRL ct_SCEF' o_rf_SCMO ct_SCIED' - CE -> _STF_AD_PAM st t y_sd_t - _ -> st + fpSchedule = schedule FP ct + prSchedule = schedule PR ct - ANN -> - let prDates = maybe [] (map calculationDay) prSchedule ++ maybeToList (maturity terms) - prDatesAfterSd = filter (\d -> d > sd) prDates - ti = zipWith (\tn tm -> _y (fromJust ct_DCC) tn tm ct_MD) prDatesAfterSd (tail prDatesAfterSd) - in - case ev of - AD -> _STF_AD_PAM st t y_sd_t - IED -> _STF_IED_LAM st t y_ipanx_t ct_IPNR ct_IPANX ct_CNTRL ct_IPAC (fromJust ct_NT) ct_IPCB ct_IPCBA - PR -> _STF_PR_NAM st t pp_payoff y_sd_t y_tfpminus_t y_tfpminus_tfpplus ct_FEB ct_FER' ct_CNTRL ct_IPCB - MD -> _STF_MD_LAM st t - PP -> _STF_PP_LAM st t pp_payoff y_sd_t y_tfpminus_t y_tfpminus_tfpplus ct_FEB ct_FER' ct_CNTRL ct_IPCB - PY -> _STF_PY_LAM st t y_sd_t y_tfpminus_t y_tfpminus_tfpplus ct_FEB ct_FER' ct_CNTRL - FP -> _STF_FP_LAM st t y_sd_t - PRD -> _STF_PRD_LAM st t y_sd_t y_tfpminus_t y_tfpminus_tfpplus ct_FEB ct_FER' ct_CNTRL - TD -> _STF_TD_PAM st t - IP -> _STF_IP_PAM st t y_sd_t y_tfpminus_t y_tfpminus_tfpplus ct_FEB ct_FER' ct_CNTRL - IPCI -> _STF_IPCI_LAM st t y_sd_t y_tfpminus_t y_tfpminus_tfpplus ct_FEB ct_FER' ct_CNTRL ct_IPCB - IPCB -> _STF_IPCB_LAM st t y_sd_t y_tfpminus_t y_tfpminus_tfpplus ct_FEB ct_FER' ct_CNTRL - RR -> _STF_RR_ANN st t y_sd_t y_tfpminus_t y_tfpminus_tfpplus ct_FEB ct_FER' ct_CNTRL ct_RRLF' ct_RRLC' ct_RRPC' ct_RRPF' ct_RRMLT' ct_RRSP' o_rf_RRMO ti - RRF -> _STF_RRF_ANN st t y_sd_t y_tfpminus_t y_tfpminus_tfpplus ct_FEB ct_FER' ct_CNTRL (fromJust ct_RRNXT) ti - SC -> _STF_SC_LAM st t y_sd_t y_tfpminus_t y_tfpminus_tfpplus ct_FEB ct_FER' ct_CNTRL ct_SCEF' o_rf_SCMO ct_SCIED' - CE -> _STF_AD_PAM st t y_sd_t - PRF -> _STF_PRF_ANN st t y_sd_t y_tfpminus_t y_tfpminus_tfpplus y_tprminus_t y_tprminus_tprplus ct_FEB ct_FER' ct_CNTRL ct_RRNXT y_t ti - _ -> st + tfp_minus = maybe t calculationDay ((\sc -> sup sc t) =<< fpSchedule) + tfp_plus = maybe t calculationDay ((\sc -> inf sc t) =<< fpSchedule) + tpr_plus = maybe t calculationDay ((\sc -> inf sc t) =<< prSchedule) + y_sd_t = _y dayCountConvention sd t ct_MD + y_tfpminus_t = _y dayCountConvention tfp_minus t ct_MD + y_tfpminus_tfpplus = _y dayCountConvention tfp_minus tfp_plus ct_MD + y_ipanx_t = _y dayCountConvention interestPaymentAnchor t ct_MD + y_t = _y dayCountConvention t tpr_plus ct_MD + prDates = maybe [] (map calculationDay) prSchedule ++ maybeToList (maturity ct) + prDatesAfterSd = filter (\d -> d > sd) prDates + ti = zipWith (\tn tm -> _y dayCountConvention tn tm ct_MD) prDatesAfterSd (tail prDatesAfterSd) +stateTransition _ _ _ s _ = s diff --git a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/STF/StateTransitionFs.hs b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/STF/StateTransitionFs.hs index 3531678456a..99e73a715cd 100644 --- a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/STF/StateTransitionFs.hs +++ b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/STF/StateTransitionFs.hs @@ -2,122 +2,233 @@ module Language.Marlowe.ACTUS.Model.STF.StateTransitionFs (stateTransitionFs) where +import Data.Maybe (maybeToList) import Data.Time (Day) - import Language.Marlowe.ACTUS.Definitions.BusinessEvents (EventType (..)) - -import Data.Maybe (fromJust, fromMaybe) -import Language.Marlowe.ACTUS.Definitions.ContractTerms (CT (LAM, NAM, PAM), ContractTerms (..)) +import Language.Marlowe.ACTUS.Definitions.ContractTerms (CT (..), ContractTerms (..)) import Language.Marlowe.ACTUS.Definitions.Schedule (ShiftedDay (calculationDay)) -import Language.Marlowe.ACTUS.Model.SCHED.ContractSchedule (schedule) +import Language.Marlowe.ACTUS.Model.SCHED.ContractSchedule (maturity, schedule) import Language.Marlowe.ACTUS.Model.STF.StateTransitionModel import Language.Marlowe.ACTUS.Model.Utility.ScheduleGenerator (inf, sup) import Language.Marlowe.ACTUS.Ops (YearFractionOps (_y)) import Language.Marlowe (Contract) -import Language.Marlowe.ACTUS.MarloweCompat (constnt, enum, letval, marloweDate, - stateTransitionMarlowe, useval) - +import Language.Marlowe.ACTUS.MarloweCompat (ContractStateMarlowe, constnt, enum, letval, + marloweDate, stateTransitionMarlowe, useval) stateTransitionFs :: EventType -> ContractTerms -> Integer -> Day -> Day -> Contract -> Contract -stateTransitionFs ev terms@ContractTerms{..} t prevDate curDate continue = - let - -- value wrappers: - __IPANX = marloweDate <$> ct_IPANX - __IPNR = constnt <$> ct_IPNR - __IPAC = constnt <$> ct_IPAC - __NT = constnt (fromJust ct_NT) - __FEB = enum ct_FEB - __FER = constnt (fromJust ct_FER) - __IPCB = enum <$> ct_IPCB - __IPCBA = constnt <$> ct_IPCBA - (__RRLF, __RRLC, __RRPC, __RRPF, __RRMLT, __RRSP) = - ( constnt (fromJust ct_RRLF) - , constnt (fromJust ct_RRLC) - , constnt (fromJust ct_RRPC) - , constnt (fromJust ct_RRPF) - , constnt (fromJust ct_RRMLT) - , constnt (fromJust ct_RRSP) - ) - __RRNXT = constnt <$> ct_RRNXT - __SCIED = constnt (fromJust ct_SCIED) - __o_rf_RRMO = useval "o_rf_RRMO" t - __o_rf_SCMO = useval "o_rf_SCMO" t - __pp_payoff = useval "pp_payoff" t +stateTransitionFs + ev + ct@ContractTerms + { ct_NT = Just nt, + ct_FER = Just fer, + ct_DCC = Just dayCountConvention, + ct_IPANX = Just ipanx, + .. + } + t + prevDate + curDate + continue = addComment $ stateTransitionMarlowe ev t continue $ stf ct + where + stf :: ContractTerms -> EventType -> ContractStateMarlowe -> ContractStateMarlowe + + stf _ AD st = _STF_AD_PAM st time y_sd_t + stf ContractTerms {contractType = PAM} IED st = _STF_IED_PAM st time y_ipanx_t nominalInterestRate interestPaymentAnchor ct_CNTRL interestAccrued notionalPrincipal + stf ContractTerms {contractType = LAM} IED st = _STF_IED_LAM st time y_ipanx_t nominalInterestRate interestPaymentAnchor ct_CNTRL interestAccrued notionalPrincipal interestCalculationBase interestCalculationBaseAmont + stf ContractTerms {contractType = NAM} IED st = _STF_IED_LAM st time y_ipanx_t nominalInterestRate interestPaymentAnchor ct_CNTRL interestAccrued notionalPrincipal interestCalculationBase interestCalculationBaseAmont + stf ContractTerms {contractType = ANN} IED st = _STF_IED_LAM st time y_ipanx_t nominalInterestRate interestPaymentAnchor ct_CNTRL interestAccrued notionalPrincipal interestCalculationBase interestCalculationBaseAmont + stf ContractTerms {contractType = LAM} PR st = _STF_PR_LAM st time y_sd_t y_tfpminus_t y_tfpminus_tfpplus feeBase feeRate ct_CNTRL interestCalculationBase + stf ContractTerms {contractType = NAM} PR st = _STF_PR_NAM st time pp_payoff y_sd_t y_tfpminus_t y_tfpminus_tfpplus feeBase feeRate ct_CNTRL interestCalculationBase + stf ContractTerms {contractType = ANN} PR st = _STF_PR_NAM st time pp_payoff y_sd_t y_tfpminus_t y_tfpminus_tfpplus feeBase feeRate ct_CNTRL interestCalculationBase + stf ContractTerms {contractType = PAM} MD st = _STF_MD_PAM st time + stf ContractTerms {contractType = LAM} MD st = _STF_MD_LAM st time + stf ContractTerms {contractType = NAM} MD st = _STF_MD_LAM st time + stf ContractTerms {contractType = ANN} MD st = _STF_MD_LAM st time + stf ContractTerms {contractType = PAM} PP st = _STF_PP_PAM st time pp_payoff y_sd_t y_tfpminus_t y_tfpminus_tfpplus feeBase feeRate ct_CNTRL + stf ContractTerms {contractType = LAM} PP st = _STF_PP_LAM st time pp_payoff y_sd_t y_tfpminus_t y_tfpminus_tfpplus feeBase feeRate ct_CNTRL interestCalculationBase + stf ContractTerms {contractType = NAM} PP st = _STF_PP_LAM st time pp_payoff y_sd_t y_tfpminus_t y_tfpminus_tfpplus feeBase feeRate ct_CNTRL interestCalculationBase + stf ContractTerms {contractType = ANN} PP st = _STF_PP_LAM st time pp_payoff y_sd_t y_tfpminus_t y_tfpminus_tfpplus feeBase feeRate ct_CNTRL interestCalculationBase + stf ContractTerms {contractType = PAM} PY st = _STF_PY_PAM st time y_sd_t y_tfpminus_t y_tfpminus_tfpplus feeBase feeRate ct_CNTRL + stf ContractTerms {contractType = LAM} PY st = _STF_PY_LAM st time y_sd_t y_tfpminus_t y_tfpminus_tfpplus feeBase feeRate ct_CNTRL + stf ContractTerms {contractType = NAM} PY st = _STF_PY_LAM st time y_sd_t y_tfpminus_t y_tfpminus_tfpplus feeBase feeRate ct_CNTRL + stf ContractTerms {contractType = ANN} PY st = _STF_PY_LAM st time y_sd_t y_tfpminus_t y_tfpminus_tfpplus feeBase feeRate ct_CNTRL + stf ContractTerms {contractType = PAM} FP st = _STF_FP_PAM st time y_sd_t + stf ContractTerms {contractType = LAM} FP st = _STF_FP_LAM st time y_sd_t + stf ContractTerms {contractType = NAM} FP st = _STF_FP_LAM st time y_sd_t + stf ContractTerms {contractType = ANN} FP st = _STF_FP_LAM st time y_sd_t + stf ContractTerms {contractType = PAM} PRD st = _STF_PRD_PAM st time y_sd_t y_tfpminus_t y_tfpminus_tfpplus feeBase feeRate ct_CNTRL + stf ContractTerms {contractType = LAM} PRD st = _STF_PRD_LAM st time y_sd_t y_tfpminus_t y_tfpminus_tfpplus feeBase feeRate ct_CNTRL + stf ContractTerms {contractType = NAM} PRD st = _STF_PRD_LAM st time y_sd_t y_tfpminus_t y_tfpminus_tfpplus feeBase feeRate ct_CNTRL + stf ContractTerms {contractType = ANN} PRD st = _STF_PRD_LAM st time y_sd_t y_tfpminus_t y_tfpminus_tfpplus feeBase feeRate ct_CNTRL + stf _ TD st = _STF_TD_PAM st time + stf _ IP st = _STF_IP_PAM st time y_sd_t y_tfpminus_t y_tfpminus_tfpplus feeBase feeRate ct_CNTRL + stf ContractTerms {contractType = PAM} IPCI st = _STF_IPCI_PAM st time y_sd_t y_tfpminus_t y_tfpminus_tfpplus feeBase feeRate ct_CNTRL + stf ContractTerms {contractType = LAM} IPCI st = _STF_IPCI_LAM st time y_sd_t y_tfpminus_t y_tfpminus_tfpplus feeBase feeRate ct_CNTRL interestCalculationBase + stf ContractTerms {contractType = NAM} IPCI st = _STF_IPCI_LAM st time y_sd_t y_tfpminus_t y_tfpminus_tfpplus feeBase feeRate ct_CNTRL interestCalculationBase + stf ContractTerms {contractType = ANN} IPCI st = _STF_IPCI_LAM st time y_sd_t y_tfpminus_t y_tfpminus_tfpplus feeBase feeRate ct_CNTRL interestCalculationBase + stf ContractTerms {contractType = LAM} IPCB st = _STF_IPCB_LAM st time y_sd_t y_tfpminus_t y_tfpminus_tfpplus feeBase feeRate ct_CNTRL + stf ContractTerms {contractType = NAM} IPCB st = _STF_IPCB_LAM st time y_sd_t y_tfpminus_t y_tfpminus_tfpplus feeBase feeRate ct_CNTRL + stf ContractTerms {contractType = ANN} IPCB st = _STF_IPCB_LAM st time y_sd_t y_tfpminus_t y_tfpminus_tfpplus feeBase feeRate ct_CNTRL + stf + ContractTerms + { contractType = PAM, + ct_RRLF = Just rrlf, + ct_RRLC = Just rrlc, + ct_RRPC = Just rrpc, + ct_RRPF = Just rrpf, + ct_RRMLT = Just rrmlt, + ct_RRSP = Just rrsp + } + RR + st = + let rrlf' = constnt rrlf + rrlc' = constnt rrlc + rrpc' = constnt rrpc + rrpf' = constnt rrpf + rrmlt' = constnt rrmlt + rrsp' = constnt rrsp + in _STF_RR_PAM st time y_sd_t y_tfpminus_t y_tfpminus_tfpplus feeBase feeRate ct_CNTRL rrlf' rrlc' rrpc' rrpf' rrmlt' rrsp' o_rf_RRMO + stf + ContractTerms + { contractType = LAM, + ct_RRLF = Just rrlf, + ct_RRLC = Just rrlc, + ct_RRPC = Just rrpc, + ct_RRPF = Just rrpf, + ct_RRMLT = Just rrmlt, + ct_RRSP = Just rrsp + } + RR + st = + let rrlf' = constnt rrlf + rrlc' = constnt rrlc + rrpc' = constnt rrpc + rrpf' = constnt rrpf + rrmlt' = constnt rrmlt + rrsp' = constnt rrsp + in _STF_RR_LAM st time y_sd_t y_tfpminus_t y_tfpminus_tfpplus feeBase feeRate ct_CNTRL rrlf' rrlc' rrpc' rrpf' rrmlt' rrsp' o_rf_RRMO + stf + ContractTerms + { contractType = NAM, + ct_RRLF = Just rrlf, + ct_RRLC = Just rrlc, + ct_RRPC = Just rrpc, + ct_RRPF = Just rrpf, + ct_RRMLT = Just rrmlt, + ct_RRSP = Just rrsp + } + RR + st = + let rrlf' = constnt rrlf + rrlc' = constnt rrlc + rrpc' = constnt rrpc + rrpf' = constnt rrpf + rrmlt' = constnt rrmlt + rrsp' = constnt rrsp + in _STF_RR_LAM st time y_sd_t y_tfpminus_t y_tfpminus_tfpplus feeBase feeRate ct_CNTRL rrlf' rrlc' rrpc' rrpf' rrmlt' rrsp' o_rf_RRMO + stf + ContractTerms + { contractType = ANN, + ct_RRLF = Just rrlf, + ct_RRLC = Just rrlc, + ct_RRPC = Just rrpc, + ct_RRPF = Just rrpf, + ct_RRMLT = Just rrmlt, + ct_RRSP = Just rrsp + } + RR + st = + let rrlf' = constnt rrlf + rrlc' = constnt rrlc + rrpc' = constnt rrpc + rrpf' = constnt rrpf + rrmlt' = constnt rrmlt + rrsp' = constnt rrsp + in _STF_RR_ANN st time y_sd_t y_tfpminus_t y_tfpminus_tfpplus feeBase feeRate ct_CNTRL rrlf' rrlc' rrpc' rrpf' rrmlt' rrsp' o_rf_RRMO ti + stf ContractTerms {contractType = PAM} RRF st = _STF_RRF_PAM st time y_sd_t y_tfpminus_t y_tfpminus_tfpplus feeBase feeRate ct_CNTRL nextRateReset + stf ContractTerms {contractType = LAM} RRF st = _STF_RRF_LAM st time y_sd_t y_tfpminus_t y_tfpminus_tfpplus feeBase feeRate ct_CNTRL nextRateReset + stf ContractTerms {contractType = NAM} RRF st = _STF_RRF_LAM st time y_sd_t y_tfpminus_t y_tfpminus_tfpplus feeBase feeRate ct_CNTRL nextRateReset + stf ContractTerms {contractType = ANN, + ct_RRNXT = Just rrnxt} RRF st = _STF_RRF_ANN st time y_sd_t y_tfpminus_t y_tfpminus_tfpplus feeBase feeRate ct_CNTRL (constnt rrnxt) ti + stf + ContractTerms + { contractType = PAM, + ct_SCEF = Just scef, + ct_SCIED = Just scied + } + SC + st = _STF_SC_PAM st time y_sd_t y_tfpminus_t y_tfpminus_tfpplus feeBase feeRate ct_CNTRL scef o_rf_SCMO (constnt scied) + stf ContractTerms {contractType = ANN} PRF st = _STF_PRF_ANN st time y_sd_t y_tfpminus_t y_tfpminus_tfpplus ct_FEB feeRate ct_CNTRL nextRateReset y_t ti + stf ContractTerms {contractType = PAM} CE st = _STF_CE_PAM st time y_sd_t + stf + ContractTerms + { contractType = LAM, + ct_SCEF = Just scef, + ct_SCIED = Just scied + } + SC + st = _STF_SC_LAM st time y_sd_t y_tfpminus_t y_tfpminus_tfpplus feeBase feeRate ct_CNTRL scef o_rf_SCMO (constnt scied) + stf ContractTerms {contractType = LAM} CE st = _STF_CE_PAM st time y_sd_t + stf + ContractTerms + { contractType = NAM, + ct_SCEF = Just scef, + ct_SCIED = Just scied + } + SC + st = _STF_SC_LAM st time y_sd_t y_tfpminus_t y_tfpminus_tfpplus feeBase feeRate ct_CNTRL scef o_rf_SCMO (constnt scied) + stf + ContractTerms + { contractType = ANN, + ct_SCEF = Just scef, + ct_SCIED = Just scied + } + SC + st = _STF_SC_LAM st time y_sd_t y_tfpminus_t y_tfpminus_tfpplus feeBase feeRate ct_CNTRL scef o_rf_SCMO (constnt scied) + + stf _ CE st = _STF_AD_PAM st time y_sd_t + + stf _ _ st = st + + interestPaymentAnchor = marloweDate <$> Just ipanx + nominalInterestRate = constnt <$> ct_IPNR + interestAccrued = constnt <$> ct_IPAC + notionalPrincipal = constnt nt + feeBase = enum ct_FEB + feeRate = constnt fer + + interestCalculationBase = enum <$> ct_IPCB + interestCalculationBaseAmont = constnt <$> ct_IPCBA + nextRateReset = constnt <$> ct_RRNXT + + o_rf_RRMO = useval "o_rf_RRMO" t + o_rf_SCMO = useval "o_rf_SCMO" t + pp_payoff = useval "pp_payoff" t + + time = marloweDate curDate + fpSchedule = schedule FP ct + prSchedule = schedule PR ct + + tfp_minus = maybe curDate calculationDay ((\sc -> sup sc curDate) =<< fpSchedule) + tfp_plus = maybe curDate calculationDay ((\sc -> inf sc curDate) =<< fpSchedule) + tpr_plus = maybe curDate calculationDay ((\sc -> inf sc curDate) =<< prSchedule) + + y_tfpminus_t = constnt $ _y dayCountConvention tfp_minus curDate ct_MD + y_tfpminus_tfpplus = constnt $ _y dayCountConvention tfp_minus tfp_plus ct_MD + y_ipanx_t = constnt $ _y dayCountConvention ipanx curDate ct_MD + y_sd_t = constnt $ _y dayCountConvention prevDate curDate ct_MD + y_t = constnt $ _y dayCountConvention curDate tpr_plus ct_MD - -- dates: - time = marloweDate curDate - fpSchedule = schedule FP terms - tfp_minus = maybe curDate calculationDay ((\sc -> sup sc curDate) =<< fpSchedule) - tfp_plus = maybe curDate calculationDay ((\sc -> inf sc curDate) =<< fpSchedule) - y_tfpminus_t = constnt $ _y (fromJust ct_DCC) tfp_minus curDate ct_MD - y_tfpminus_tfpplus = constnt $ _y (fromJust ct_DCC) tfp_minus tfp_plus ct_MD - y_ipanx_t = constnt $ _y (fromJust ct_DCC) (fromJust ct_IPANX) curDate ct_MD - y_sd_t = constnt $ _y (fromJust ct_DCC) prevDate curDate ct_MD + prDates = maybe [] (map calculationDay) prSchedule ++ maybeToList (maturity ct) + prDatesAfterSd = filter (\d -> d > curDate) prDates + ti = zipWith (\tn tm -> constnt $ _y dayCountConvention tn tm ct_MD) prDatesAfterSd (tail prDatesAfterSd) - addComment cont = case ev of - IED -> letval "IED" t (constnt 0) cont - MD -> letval "MD" t (constnt 0) cont - IP -> letval ("IP:" ++ show curDate ++ show prevDate) t (constnt 0) cont - RR -> letval ("RR:" ++ show curDate) t (constnt 0) cont - FP -> letval ("FP:" ++ show curDate) t (constnt 0) cont - _ -> cont - in case contractType of - PAM -> - addComment $ stateTransitionMarlowe ev t continue $ \event st -> - case event of - AD -> _STF_AD_PAM st time y_sd_t - IED -> _STF_IED_PAM st time y_ipanx_t __IPNR __IPANX ct_CNTRL __IPAC __NT - MD -> _STF_MD_PAM st time - PP -> _STF_PP_PAM st time __pp_payoff y_sd_t y_tfpminus_t y_tfpminus_tfpplus __FEB __FER ct_CNTRL - PY -> _STF_PY_PAM st time y_sd_t y_tfpminus_t y_tfpminus_tfpplus __FEB __FER ct_CNTRL - FP -> _STF_FP_PAM st time y_sd_t - PRD -> _STF_PRD_PAM st time y_sd_t y_tfpminus_t y_tfpminus_tfpplus __FEB __FER ct_CNTRL - TD -> _STF_TD_PAM st time - IP -> _STF_IP_PAM st time y_sd_t y_tfpminus_t y_tfpminus_tfpplus __FEB __FER ct_CNTRL - IPCI -> _STF_IPCI_PAM st time y_sd_t y_tfpminus_t y_tfpminus_tfpplus __FEB __FER ct_CNTRL - RR -> _STF_RR_PAM st time y_sd_t y_tfpminus_t y_tfpminus_tfpplus __FEB __FER ct_CNTRL __RRLF __RRLC __RRPC __RRPF __RRMLT __RRSP __o_rf_RRMO - RRF -> _STF_RRF_PAM st time y_sd_t y_tfpminus_t y_tfpminus_tfpplus __FEB __FER ct_CNTRL __RRNXT - SC -> _STF_SC_PAM st time y_sd_t y_tfpminus_t y_tfpminus_tfpplus __FEB __FER ct_CNTRL (fromJust ct_SCEF) __o_rf_SCMO __SCIED - CE -> _STF_CE_PAM st time y_sd_t - _ -> st - LAM -> - addComment $ stateTransitionMarlowe ev t continue $ \event st -> - case event of - AD -> _STF_AD_PAM st time y_sd_t - IED -> _STF_IED_LAM st time y_ipanx_t __IPNR __IPANX ct_CNTRL __IPAC __NT __IPCB __IPCBA - PR -> _STF_PR_LAM st time y_sd_t y_tfpminus_t y_tfpminus_tfpplus __FEB __FER ct_CNTRL __IPCB - MD -> _STF_MD_LAM st time - PP -> _STF_PP_LAM st time __pp_payoff y_sd_t y_tfpminus_t y_tfpminus_tfpplus __FEB __FER ct_CNTRL __IPCB - PY -> _STF_PY_LAM st time y_sd_t y_tfpminus_t y_tfpminus_tfpplus __FEB __FER ct_CNTRL - FP -> _STF_FP_LAM st time y_sd_t - PRD -> _STF_PRD_LAM st time y_sd_t y_tfpminus_t y_tfpminus_tfpplus __FEB __FER ct_CNTRL - TD -> _STF_TD_PAM st time - IP -> _STF_IP_PAM st time y_sd_t y_tfpminus_t y_tfpminus_tfpplus __FEB __FER ct_CNTRL - IPCI -> _STF_IPCI_LAM st time y_sd_t y_tfpminus_t y_tfpminus_tfpplus __FEB __FER ct_CNTRL __IPCB - IPCB -> _STF_IPCB_LAM st time y_sd_t y_tfpminus_t y_tfpminus_tfpplus __FEB __FER ct_CNTRL - RR -> _STF_RR_LAM st time y_sd_t y_tfpminus_t y_tfpminus_tfpplus __FEB __FER ct_CNTRL __RRLF __RRLC __RRPC __RRPF __RRMLT __RRSP __o_rf_RRMO - RRF -> _STF_RRF_LAM st time y_sd_t y_tfpminus_t y_tfpminus_tfpplus __FEB __FER ct_CNTRL __RRNXT - SC -> _STF_SC_LAM st time y_sd_t y_tfpminus_t y_tfpminus_tfpplus __FEB __FER ct_CNTRL (fromJust ct_SCEF) __o_rf_SCMO __SCIED - CE -> _STF_CE_PAM st time y_sd_t - _ -> st - NAM -> - addComment $ stateTransitionMarlowe ev t continue $ \event st -> - case event of - AD -> _STF_AD_PAM st time y_sd_t - IED -> _STF_IED_LAM st time y_ipanx_t __IPNR __IPANX ct_CNTRL __IPAC __NT __IPCB __IPCBA - PR -> _STF_PR_NAM st time __pp_payoff y_sd_t y_tfpminus_t y_tfpminus_tfpplus __FEB __FER ct_CNTRL __IPCB - MD -> _STF_MD_LAM st time - PP -> _STF_PP_LAM st time __pp_payoff y_sd_t y_tfpminus_t y_tfpminus_tfpplus __FEB __FER ct_CNTRL __IPCB - PY -> _STF_PY_LAM st time y_sd_t y_tfpminus_t y_tfpminus_tfpplus __FEB __FER ct_CNTRL - FP -> _STF_FP_LAM st time y_sd_t - PRD -> _STF_PRD_LAM st time y_sd_t y_tfpminus_t y_tfpminus_tfpplus __FEB __FER ct_CNTRL - TD -> _STF_TD_PAM st time - IP -> _STF_IP_PAM st time y_sd_t y_tfpminus_t y_tfpminus_tfpplus __FEB __FER ct_CNTRL - IPCI -> _STF_IPCI_LAM st time y_sd_t y_tfpminus_t y_tfpminus_tfpplus __FEB __FER ct_CNTRL __IPCB - IPCB -> _STF_IPCB_LAM st time y_sd_t y_tfpminus_t y_tfpminus_tfpplus __FEB __FER ct_CNTRL - RR -> _STF_RR_LAM st time y_sd_t y_tfpminus_t y_tfpminus_tfpplus __FEB __FER ct_CNTRL __RRLF __RRLC __RRPC __RRPF __RRMLT __RRSP __o_rf_RRMO - RRF -> _STF_RRF_LAM st time y_sd_t y_tfpminus_t y_tfpminus_tfpplus __FEB __FER ct_CNTRL __RRNXT - SC -> _STF_SC_LAM st time y_sd_t y_tfpminus_t y_tfpminus_tfpplus __FEB __FER ct_CNTRL (fromJust ct_SCEF) __o_rf_SCMO __SCIED - CE -> _STF_AD_PAM st time y_sd_t - _ -> st + addComment cont = case ev of + IED -> letval "IED" t (constnt 0) cont + MD -> letval "MD" t (constnt 0) cont + IP -> letval ("IP:" ++ show curDate ++ show prevDate) t (constnt 0) cont + RR -> letval ("RR:" ++ show curDate) t (constnt 0) cont + FP -> letval ("FP:" ++ show curDate) t (constnt 0) cont + _ -> cont +stateTransitionFs _ _ _ _ _ c = c diff --git a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/STF/StateTransitionModel.hs b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/STF/StateTransitionModel.hs index 712842a8309..613f0a5cb81 100644 --- a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/STF/StateTransitionModel.hs +++ b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/STF/StateTransitionModel.hs @@ -2,7 +2,7 @@ module Language.Marlowe.ACTUS.Model.STF.StateTransitionModel where -import Data.Maybe (fromJust, fromMaybe, isJust, isNothing) +import Data.Maybe (fromMaybe) import Language.Marlowe.ACTUS.Definitions.ContractState (ContractStatePoly (ContractStatePoly, feac, ipac, ipcb, ipnr, isc, nsc, nt, prf, prnxt, sd, tmd)) import Language.Marlowe.ACTUS.Definitions.ContractTerms (CR, FEB (FEB_N), IPCB (..), SCEF (SE_00M, SE_0N0, SE_0NM, SE_I00)) @@ -22,12 +22,14 @@ _STF_IED_PAM :: (RoleSignOps a1, ActusNum a1, DateOps a2 a1, ActusOps a1) => Con _STF_IED_PAM st t y_ipanx_t _IPNR _IPANX _CNTRL _IPAC _NT = let nt' = _r _CNTRL * _NT - ipnr' | isNothing _IPNR = _zero - | otherwise = fromJust _IPNR + ipnr' = fromMaybe _zero _IPNR + + interestAccured (Just x) _ = x + interestAccured _ (Just x) = _lt x t * y_ipanx_t * nt' * ipnr' + interestAccured _ _ = _zero + + ipac' = interestAccured _IPAC _IPANX - ipac' | isJust _IPAC = fromJust _IPAC - | isJust _IPANX = _lt (fromJust _IPANX) t * y_ipanx_t * nt' * ipnr' - | otherwise = _zero in st { nt = nt', ipnr = ipnr', ipac = ipac', sd = t } _STF_MD_PAM :: ActusOps a => ContractStatePoly a b -> b -> ContractStatePoly a b @@ -136,22 +138,23 @@ _STF_CE_PAM = _STF_AD_PAM -- Linear Amortiser (LAM) _STF_IED_LAM :: (RoleSignOps a1, ActusNum a1, ActusOps a1, Ord a2) => ContractStatePoly a1 a2 -> a2 -> a1 -> Maybe a1 -> Maybe a2 -> CR -> Maybe a1 -> a1 -> Maybe IPCB -> Maybe a1 -> ContractStatePoly a1 a2 -_STF_IED_LAM st t y_ipanx_t _IPNR _IPANX _CNTRL _IPAC _NT _IPCB _IPCBA = +_STF_IED_LAM st t y_ipanx_t (Just ipnr') _IPANX _CNTRL _IPAC _NT _IPCB _IPCBA = let nt' = _r _CNTRL * _NT - ipnr' = fromJust _IPNR - ipcb' | fromJust _IPCB == IPCB_NT = nt' - | otherwise = _r _CNTRL * fromJust _IPCBA + interestCalculationBase (Just IPCB_NT) _ = nt' + interestCalculationBase _ (Just interestCalculationBaseAmount) = _r _CNTRL * interestCalculationBaseAmount + interestCalculationBase _ _ = _zero + + ipcb' = interestCalculationBase _IPCB _IPCBA - ipac' | isJust _IPAC = _r _CNTRL * fromJust _IPAC - {- - -- | isJust _IPANX = _lt (fromJust _IPANX) t * y_ipanx_t * nt' * ipnr' - -} - | isJust _IPANX && fromJust _IPANX < t = y_ipanx_t * nt' * ipcb' - | otherwise = _zero + interestAccured (Just x) _ = _r _CNTRL * x + interestAccured _ (Just x) | x < t = y_ipanx_t * nt' * ipcb' + interestAccured _ _ = _zero + ipac' = interestAccured _IPAC _IPANX in st { nt = nt', ipnr = ipnr', ipac = ipac', ipcb = ipcb', sd = t } +_STF_IED_LAM st _ _ Nothing _ _ _ _ _ _ = st _STF_PR_LAM :: (ActusNum a, ActusOps a, RoleSignOps a) => ContractStatePoly a b -> b -> a -> a -> a -> Maybe FEB -> a -> CR -> Maybe IPCB -> ContractStatePoly a b _STF_PR_LAM st@ContractStatePoly{..} t y_sd_t _ _ _FEB _FER _CNTRL _IPCB = @@ -163,9 +166,9 @@ _STF_PR_LAM st@ContractStatePoly{..} t y_sd_t _ _ _FEB _FER _CNTRL _IPCB = -- _ -> (_max _zero (y_tfpminus_t / y_tfpminus_tfpplus)) * _r _CNTRL * _FER feac' = feac + y_sd_t * nt * _FER - ipcb' = case fromJust _IPCB of - IPCB_NTL -> ipcb - _ -> nt' + ipcb' = case _IPCB of + Just IPCB_NTL -> ipcb + _ -> nt' ipac' = ipac + ipnr * ipcb * y_sd_t @@ -185,9 +188,9 @@ _STF_PP_LAM st@ContractStatePoly{..} t pp_payoff y_sd_t y_tfpminus_t y_tfpminus_ let st' = _STF_PY_LAM st t y_sd_t y_tfpminus_t y_tfpminus_tfpplus _FEB _FER _CNTRL nt' = nt - pp_payoff - ipcb' = case fromJust _IPCB of - IPCB_NT -> nt' - _ -> ipcb + ipcb' = case _IPCB of + Just IPCB_NT -> nt' + _ -> ipcb in st' {nt = nt', ipcb = ipcb'} _STF_PY_LAM :: (RoleSignOps a, ActusNum a) => ContractStatePoly a b -> b -> a -> a -> a -> Maybe FEB -> a -> CR -> ContractStatePoly a b @@ -216,9 +219,9 @@ _STF_IPCI_LAM st@ContractStatePoly{..} t y_sd_t y_tfpminus_t y_tfpminus_tfpplus let st' = _STF_IP_PAM st t y_sd_t y_tfpminus_t y_tfpminus_tfpplus _FEB _FER _CNTRL nt' = nt + ipac + y_sd_t * ipnr * ipcb - ipcb' = case fromJust _IPCB of - IPCB_NT -> nt' - _ -> ipcb + ipcb' = case _IPCB of + Just IPCB_NT -> nt' + _ -> ipcb in st' {nt = nt', ipcb = ipcb'} _STF_IPCB_LAM :: (RoleSignOps a, ActusNum a) => ContractStatePoly a b -> b -> a -> a -> a -> Maybe FEB -> a -> CR -> ContractStatePoly a b @@ -276,9 +279,9 @@ _STF_PR_NAM st@ContractStatePoly{..} t _ y_sd_t y_tfpminus_t y_tfpminus_tfpplus nt' = nt - _r _CNTRL * r -- ACTUS implementation - ipcb' = case fromJust _IPCB of - IPCB_NT -> nt' - _ -> ipcb + ipcb' = case _IPCB of + Just IPCB_NT -> nt' + _ -> ipcb -- -- Java implementation -- ipcb' = nt' @@ -330,8 +333,8 @@ _STF_RRF_ANN st@ContractStatePoly{..} t y_sd_t y_tfpminus_t y_tfpminus_tfpplus _ sd = t } -_STF_PRF_ANN :: (ActusOps a, RoleSignOps a, ActusNum a) => ContractStatePoly a b -> b -> a-> a-> a -> a -> a -> Maybe FEB -> a -> CR -> Maybe a -> a -> [a] -> ContractStatePoly a b -_STF_PRF_ANN st@ContractStatePoly{..} t y_sd_t y_tfpminus_t y_tfpminus_tfpplus _ _ _FEB _FER _CNTRL _RRNXT y_t ti = +_STF_PRF_ANN :: (ActusOps a, RoleSignOps a, ActusNum a) => ContractStatePoly a b -> b -> a-> a-> a -> Maybe FEB -> a -> CR -> Maybe a -> a -> [a] -> ContractStatePoly a b +_STF_PRF_ANN st@ContractStatePoly{..} t y_sd_t y_tfpminus_t y_tfpminus_tfpplus _FEB _FER _CNTRL _RRNXT y_t ti = let accruedInterest = ipac + y_sd_t * ipnr * ipcb feeAccrued = case _FEB of From 48eaa5561995548c7ef89fcb4928a5a5796a9505 Mon Sep 17 00:00:00 2001 From: Yves Hauser Date: Wed, 1 Sep 2021 20:13:11 +0200 Subject: [PATCH 11/28] scp-2709 - refactoring ACTUS code * added Enum for events --- .../src/Language/Marlowe/ACTUS/Analysis.hs | 21 ++++++------ .../ACTUS/Definitions/BusinessEvents.hs | 32 +++++++++---------- 2 files changed, 26 insertions(+), 27 deletions(-) diff --git a/marlowe-actus/src/Language/Marlowe/ACTUS/Analysis.hs b/marlowe-actus/src/Language/Marlowe/ACTUS/Analysis.hs index 1fb83c5474b..c91191571d9 100644 --- a/marlowe-actus/src/Language/Marlowe/ACTUS/Analysis.hs +++ b/marlowe-actus/src/Language/Marlowe/ACTUS/Analysis.hs @@ -4,10 +4,10 @@ module Language.Marlowe.ACTUS.Analysis (genProjectedCashflows) where -import Control.Applicative (Alternative ((<|>))) -import qualified Data.List as L (dropWhile, find, groupBy, scanl, tail, zip) -import qualified Data.Map as M (fromList, lookup) -import Data.Maybe (fromJust, fromMaybe, isNothing) +import Control.Applicative ((<|>)) +import qualified Data.List as L (find, groupBy) +import qualified Data.Map as M (lookup) +import Data.Maybe (fromMaybe, isNothing) import Data.Sort (sortOn) import Data.Time (Day) import Language.Marlowe.ACTUS.Definitions.BusinessEvents (DataObserved, EventType (..), RiskFactors (..), @@ -41,7 +41,7 @@ genProjectedCashflows dataObserved ct@ContractTerms {..} = states = let initialState = (initializeState ct, AD, ShiftedDay ct_SD ct_SD) - in filter filtersStates . L.tail $ L.scanl applyStateTransition initialState events + in filter filtersStates . tail $ scanl applyStateTransition initialState events -- payoff calculatePayoff (st, ev, date) = @@ -64,7 +64,7 @@ genProjectedCashflows dataObserved ct@ContractTerms {..} = currency = "ada" } - in sortOn cashPaymentDay $ genCashflow <$> L.zip states payoffs + in sortOn cashPaymentDay $ genCashflow <$> zip states payoffs where @@ -84,17 +84,16 @@ genProjectedCashflows dataObserved ct@ContractTerms {..} = postProcessSchedule :: [(EventType, ShiftedDay)] -> [(EventType, ShiftedDay)] postProcessSchedule = - let trim = L.dropWhile (\(_, d) -> calculationDay d < ct_SD) - prioritised = [IED, FP, PR, PD, PY, PP, IP, IPCI, CE, RRF, RR, PRF, DV, PRD, MR, TD, SC, IPCB, MD, XD, STD, AD] + let trim = dropWhile (\(_, d) -> calculationDay d < ct_SD) - priority :: (EventType, ShiftedDay) -> Integer - priority (event, _) = fromJust $ M.lookup event $ M.fromList (zip prioritised [1 ..]) + priority :: (EventType, ShiftedDay) -> Int + priority (event, _) = fromEnum event similarity (_, l) (_, r) = calculationDay l == calculationDay r regroup = L.groupBy similarity overwrite = map (sortOn priority) . regroup - in concat . (overwrite . trim) + in concat . overwrite . trim getRiskFactors :: EventType -> Day -> RiskFactors getRiskFactors ev date = diff --git a/marlowe-actus/src/Language/Marlowe/ACTUS/Definitions/BusinessEvents.hs b/marlowe-actus/src/Language/Marlowe/ACTUS/Definitions/BusinessEvents.hs index ddf63029225..1e3d93a6266 100644 --- a/marlowe-actus/src/Language/Marlowe/ACTUS/Definitions/BusinessEvents.hs +++ b/marlowe-actus/src/Language/Marlowe/ACTUS/Definitions/BusinessEvents.hs @@ -13,30 +13,30 @@ import GHC.Generics (Generic) https://github.com/actusfrf/actus-dictionary/blob/master/actus-dictionary-event.json -} data EventType = - AD -- Monitoring - | IED -- Initial Exchange + IED -- Initial Exchange + | FP -- Fee Payment | PR -- Principal Redemption - | PI -- Principal Increase - | PRF -- Principal Payment Amount Fixing + | PD -- Principal Drawing | PY -- Penalty Payment - | FP -- Fee Payment - | PRD -- Purchase - | TD -- Termination + | PP -- Principal Prepayment (unscheduled event) | IP -- Interest Payment | IPCI -- Interest Capitalization - | IPCB -- Interest Calculation Base Fixing - | RR -- Rate Reset Fixing with Unknown Rate - | PP -- Principal Prepayment (unscheduled event) | CE -- Credit Event - | MD -- Maturity | RRF -- Rate Reset Fixing with Known Rate - | SC -- Scaling Index Fixing - | STD -- Settlement + | RR -- Rate Reset Fixing with Unknown Rate + | PRF -- Principal Payment Amount Fixing | DV -- Dividend Payment - | XD -- Exercise + | PRD -- Purchase | MR -- Margin Call - | PD -- Principal Drawing - deriving (Eq, Show, Read, Ord) + | TD -- Termination + | SC -- Scaling Index Fixing + | IPCB -- Interest Calculation Base Fixing + | MD -- Maturity + | XD -- Exercise + | STD -- Settlement + | PI -- Principal Increase + | AD -- Monitoring + deriving (Eq, Show, Read, Ord, Enum) {-| Risk factor observer -} From a98a409abad49f4b6f4695ac27470db224d294e4 Mon Sep 17 00:00:00 2001 From: Yves Hauser Date: Thu, 2 Sep 2021 11:23:44 +0200 Subject: [PATCH 12/28] scp-2709 - refactoring ACTUS code * replaced `fromJust` calls --- marlowe-actus/marlowe-actus.cabal | 3 - .../src/Language/Marlowe/ACTUS/Analysis.hs | 124 +++++++++--------- .../src/Language/Marlowe/ACTUS/Generator.hs | 66 +++++----- .../ACTUS/Model/INIT/StateInitialization.hs | 9 -- .../Marlowe/ACTUS/Model/Utility/DateShift.hs | 9 +- .../ACTUS/Model/Utility/ScheduleGenerator.hs | 23 +++- 6 files changed, 119 insertions(+), 115 deletions(-) delete mode 100644 marlowe-actus/src/Language/Marlowe/ACTUS/Model/INIT/StateInitialization.hs diff --git a/marlowe-actus/marlowe-actus.cabal b/marlowe-actus/marlowe-actus.cabal index 8af86e7f2b4..0f4e5a27491 100644 --- a/marlowe-actus/marlowe-actus.cabal +++ b/marlowe-actus/marlowe-actus.cabal @@ -66,7 +66,6 @@ library Language.Marlowe.ACTUS.Model.SCHED.ContractScheduleModel Language.Marlowe.ACTUS.Model.SCHED.ContractSchedule Language.Marlowe.ACTUS.Model.INIT.StateInitializationModel - Language.Marlowe.ACTUS.Model.INIT.StateInitialization Language.Marlowe.ACTUS.Model.APPLICABILITY.Applicability Language.Marlowe.ACTUS.Model.APPLICABILITY.ApplicabilityModel Language.Marlowe.ACTUS.Model.Utility.ANN.Annuity @@ -102,7 +101,6 @@ executable marlowe-shiny Language.Marlowe.ACTUS.Model.SCHED.ContractScheduleModel Language.Marlowe.ACTUS.Model.SCHED.ContractSchedule Language.Marlowe.ACTUS.Model.INIT.StateInitializationModel - Language.Marlowe.ACTUS.Model.INIT.StateInitialization Language.Marlowe.ACTUS.Model.Utility.DateShift Language.Marlowe.ACTUS.Model.Utility.ScheduleGenerator Language.Marlowe.ACTUS.Model.Utility.YearFraction @@ -158,7 +156,6 @@ executable marlowe-actus-test-kit Language.Marlowe.ACTUS.Model.SCHED.ContractScheduleModel Language.Marlowe.ACTUS.Model.SCHED.ContractSchedule Language.Marlowe.ACTUS.Model.INIT.StateInitializationModel - Language.Marlowe.ACTUS.Model.INIT.StateInitialization Language.Marlowe.ACTUS.Model.Utility.DateShift Language.Marlowe.ACTUS.Model.Utility.ScheduleGenerator Language.Marlowe.ACTUS.Model.Utility.YearFraction diff --git a/marlowe-actus/src/Language/Marlowe/ACTUS/Analysis.hs b/marlowe-actus/src/Language/Marlowe/ACTUS/Analysis.hs index c91191571d9..8228ecac54b 100644 --- a/marlowe-actus/src/Language/Marlowe/ACTUS/Analysis.hs +++ b/marlowe-actus/src/Language/Marlowe/ACTUS/Analysis.hs @@ -4,70 +4,71 @@ module Language.Marlowe.ACTUS.Analysis (genProjectedCashflows) where -import Control.Applicative ((<|>)) -import qualified Data.List as L (find, groupBy) -import qualified Data.Map as M (lookup) -import Data.Maybe (fromMaybe, isNothing) -import Data.Sort (sortOn) -import Data.Time (Day) -import Language.Marlowe.ACTUS.Definitions.BusinessEvents (DataObserved, EventType (..), RiskFactors (..), - ValueObserved (..), ValuesObserved (..)) -import Language.Marlowe.ACTUS.Definitions.ContractState (ContractState) -import Language.Marlowe.ACTUS.Definitions.ContractTerms (CT (..), ContractTerms (..)) -import Language.Marlowe.ACTUS.Definitions.Schedule (CashFlow (..), ShiftedDay (..), calculationDay, - paymentDay) -import Language.Marlowe.ACTUS.Model.INIT.StateInitialization (initializeState) -import Language.Marlowe.ACTUS.Model.POF.Payoff (payoff) -import Language.Marlowe.ACTUS.Model.SCHED.ContractSchedule (maturity, schedule) -import Language.Marlowe.ACTUS.Model.STF.StateTransition (stateTransition) +import Control.Applicative ((<|>)) +import qualified Data.List as L (find, groupBy) +import qualified Data.Map as M (lookup) +import Data.Maybe (fromMaybe, isNothing) +import Data.Sort (sortOn) +import Data.Time (Day) +import Language.Marlowe.ACTUS.Definitions.BusinessEvents (DataObserved, EventType (..), + RiskFactors (..), ValueObserved (..), + ValuesObserved (..)) +import Language.Marlowe.ACTUS.Definitions.ContractState (ContractState) +import Language.Marlowe.ACTUS.Definitions.ContractTerms (CT (..), ContractTerms (..)) +import Language.Marlowe.ACTUS.Definitions.Schedule (CashFlow (..), ShiftedDay (..), + calculationDay, paymentDay) +import Language.Marlowe.ACTUS.Model.INIT.StateInitializationModel (initialize) +import Language.Marlowe.ACTUS.Model.POF.Payoff (payoff) +import Language.Marlowe.ACTUS.Model.SCHED.ContractSchedule (maturity, schedule) +import Language.Marlowe.ACTUS.Model.STF.StateTransition (stateTransition) genProjectedCashflows :: DataObserved -> ContractTerms -> [CashFlow] -genProjectedCashflows dataObserved ct@ContractTerms {..} = - let -- schedule - scheduleEvent e = maybe [] (fmap (e,)) (schedule e ct) - - -- events - eventTypes = [IED, MD, RR, RRF, IP, PR, PRF, IPCB, IPCI, PRD, TD, SC] - - events = - let e = concatMap scheduleEvent eventTypes - in filter filtersEvents . postProcessSchedule . sortOn (paymentDay . snd) $ e - - -- states - applyStateTransition (st, ev, date) (ev', date') = - let t = calculationDay date - rf = getRiskFactors ev t - in (stateTransition ev rf ct st t, ev', date') - - states = - let initialState = (initializeState ct, AD, ShiftedDay ct_SD ct_SD) - in filter filtersStates . tail $ scanl applyStateTransition initialState events - - -- payoff - calculatePayoff (st, ev, date) = - let t = calculationDay date - rf = getRiskFactors ev t - in payoff ev rf ct st t - - payoffs = calculatePayoff <$> states - - genCashflow ((_, ev, d), pff) = - CashFlow - { tick = 0, - cashContractId = "0", - cashParty = "party", - cashCounterParty = "counterparty", - cashPaymentDay = paymentDay d, - cashCalculationDay = calculationDay d, - cashEvent = ev, - amount = pff, - currency = "ada" - } - - in sortOn cashPaymentDay $ genCashflow <$> zip states payoffs - +genProjectedCashflows dataObserved ct@ContractTerms {..} = fromMaybe [] $ + do + st0 <- initialize ct + return $ + let -- schedule + scheduleEvent e = maybe [] (fmap (e,)) (schedule e ct) + + -- events + eventTypes = [IED, MD, RR, RRF, IP, PR, PRF, IPCB, IPCI, PRD, TD, SC] + + events = + let e = concatMap scheduleEvent eventTypes + in filter filtersEvents . postProcessSchedule . sortOn (paymentDay . snd) $ e + + -- states + applyStateTransition (st, ev, date) (ev', date') = + let t = calculationDay date + rf = getRiskFactors ev t + in (stateTransition ev rf ct st t, ev', date') + + states = + let initialState = (st0, AD, ShiftedDay ct_SD ct_SD) + in filter filtersStates . tail $ scanl applyStateTransition initialState events + + -- payoff + calculatePayoff (st, ev, date) = + let t = calculationDay date + rf = getRiskFactors ev t + in payoff ev rf ct st t + + payoffs = calculatePayoff <$> states + + genCashflow ((_, ev, d), pff) = + CashFlow + { tick = 0, + cashContractId = "0", + cashParty = "party", + cashCounterParty = "counterparty", + cashPaymentDay = paymentDay d, + cashCalculationDay = calculationDay d, + cashEvent = ev, + amount = pff, + currency = "ada" + } + in sortOn cashPaymentDay $ genCashflow <$> zip states payoffs where - filtersEvents :: (EventType, ShiftedDay) -> Bool filtersEvents (_, ShiftedDay {..}) = isNothing ct_TD || Just calculationDay <= ct_TD @@ -114,7 +115,6 @@ genProjectedCashflows dataObserved ct@ContractTerms {..} = ValuesObserved {values = values} <- M.lookup k dataObserved ValueObserved {value = valueObserved} <- L.find (\ValueObserved {timestamp = timestamp} -> timestamp == date) values return valueObserved - in case ev of RR -> riskFactors {o_rf_RRMO = value} SC -> riskFactors {o_rf_SCMO = value} diff --git a/marlowe-actus/src/Language/Marlowe/ACTUS/Generator.hs b/marlowe-actus/src/Language/Marlowe/ACTUS/Generator.hs index 4e36e14edb3..122ab6e0b14 100644 --- a/marlowe-actus/src/Language/Marlowe/ACTUS/Generator.hs +++ b/marlowe-actus/src/Language/Marlowe/ACTUS/Generator.hs @@ -8,35 +8,35 @@ module Language.Marlowe.ACTUS.Generator ) where -import qualified Data.List as L (foldl', zip6) -import Data.Map as M (empty) -import Data.Maybe (fromJust, fromMaybe, isNothing, maybeToList) -import Data.Monoid (Endo (Endo, appEndo)) -import Data.String (IsString (fromString)) -import Data.Time (Day) -import Data.Validation (Validation (..)) -import Language.Marlowe (Action (..), Bound (..), Case (..), - ChoiceId (..), Contract (..), - Observation (..), Party (..), Payee (..), - Slot (..), Value (..), ValueId (ValueId), - ada) -import Language.Marlowe.ACTUS.Analysis (genProjectedCashflows) -import Language.Marlowe.ACTUS.Definitions.BusinessEvents (EventType (..)) -import Language.Marlowe.ACTUS.Definitions.ContractTerms (Assertion (..), AssertionContext (..), - Assertions (..), ContractTerms (..), - TermValidationError (..), - setDefaultContractTermValues) -import Language.Marlowe.ACTUS.Definitions.Schedule (CashFlow (..)) -import Language.Marlowe.ACTUS.MarloweCompat (constnt, dayToSlotNumber, - stateInitialisation, toMarloweFixedPoint, - useval) -import Language.Marlowe.ACTUS.Model.APPLICABILITY.Applicability (validateTerms) -import Language.Marlowe.ACTUS.Model.INIT.StateInitialization (initializeState) -import Language.Marlowe.ACTUS.Model.POF.PayoffFs (payoffFs) -import Language.Marlowe.ACTUS.Model.STF.StateTransitionFs (stateTransitionFs) -import Language.Marlowe.ACTUS.Ops as O (ActusNum (..), YearFractionOps (_y)) -import Ledger.Value (TokenName (TokenName)) -import Prelude as P hiding (Fractional, Num, (*), (+), (/)) +import qualified Data.List as L (foldl', zip6) +import Data.Map as M (empty) +import Data.Maybe (fromMaybe, isNothing, maybeToList) +import Data.Monoid (Endo (Endo, appEndo)) +import Data.String (IsString (fromString)) +import Data.Time (Day) +import Data.Validation (Validation (..)) +import Language.Marlowe (Action (..), Bound (..), Case (..), + ChoiceId (..), Contract (..), + Observation (..), Party (..), Payee (..), + Slot (..), Value (..), ValueId (ValueId), + ada) +import Language.Marlowe.ACTUS.Analysis (genProjectedCashflows) +import Language.Marlowe.ACTUS.Definitions.BusinessEvents (EventType (..)) +import Language.Marlowe.ACTUS.Definitions.ContractTerms (Assertion (..), AssertionContext (..), + Assertions (..), ContractTerms (..), + TermValidationError (..), + setDefaultContractTermValues) +import Language.Marlowe.ACTUS.Definitions.Schedule (CashFlow (..)) +import Language.Marlowe.ACTUS.MarloweCompat (constnt, dayToSlotNumber, + stateInitialisation, toMarloweFixedPoint, + useval) +import Language.Marlowe.ACTUS.Model.APPLICABILITY.Applicability (validateTerms) +import Language.Marlowe.ACTUS.Model.INIT.StateInitializationModel (initialize) +import Language.Marlowe.ACTUS.Model.POF.PayoffFs (payoffFs) +import Language.Marlowe.ACTUS.Model.STF.StateTransitionFs (stateTransitionFs) +import Language.Marlowe.ACTUS.Ops as O (ActusNum (..), YearFractionOps (_y)) +import Ledger.Value (TokenName (TokenName)) +import Prelude as P hiding (Fractional, Num, (*), (+), (/)) receiveCollateral :: String -> Integer -> Integer -> Contract -> Contract receiveCollateral from amount timeout continue = @@ -215,15 +215,15 @@ genFsContract terms = genContract . setDefaultContractTermValues <$> validateTer in withCollateral $ initializeStateFs terms' scheduleAcc initializeStateFs :: ContractTerms -> Contract -> Contract - initializeStateFs ct cont = let s = initializeState ct in stateInitialisation s cont + initializeStateFs ct cont = maybe cont (flip stateInitialisation cont) (initialize ct) genZeroRiskAssertions :: ContractTerms -> Assertion -> Contract -> Contract -genZeroRiskAssertions terms@ContractTerms{..} NpvAssertionAgainstZeroRiskBond{..} continue = +genZeroRiskAssertions terms@ContractTerms{ct_DCC = Just dcc, ..} NpvAssertionAgainstZeroRiskBond{..} continue = let cfs = genProjectedCashflows M.empty terms dateToYearFraction :: Day -> Double - dateToYearFraction dt = _y (fromJust ct_DCC) ct_SD dt ct_MD + dateToYearFraction dt = _y dcc ct_SD dt ct_MD dateToDiscountFactor dt = (1 O.- zeroRiskInterest) ** dateToYearFraction dt @@ -235,3 +235,5 @@ genZeroRiskAssertions terms@ContractTerms{..} NpvAssertionAgainstZeroRiskBond{.. npv = foldl accumulateAndDiscount (constnt 0) (zip cfs [1..]) in Assert (ValueLT (constnt expectedNpv) npv) continue +genZeroRiskAssertions _ _ c = c + diff --git a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/INIT/StateInitialization.hs b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/INIT/StateInitialization.hs deleted file mode 100644 index 9d9a2acbea0..00000000000 --- a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/INIT/StateInitialization.hs +++ /dev/null @@ -1,9 +0,0 @@ -module Language.Marlowe.ACTUS.Model.INIT.StateInitialization where - -import Data.Maybe (fromJust) -import Language.Marlowe.ACTUS.Definitions.ContractState (ContractState) -import Language.Marlowe.ACTUS.Definitions.ContractTerms (ContractTerms) -import Language.Marlowe.ACTUS.Model.INIT.StateInitializationModel (initialize) - -initializeState :: ContractTerms -> ContractState -initializeState = fromJust . initialize -- FIXME: reconsider fromJust diff --git a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/Utility/DateShift.hs b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/Utility/DateShift.hs index 7a1b37d3263..f42b2a4b4c7 100644 --- a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/Utility/DateShift.hs +++ b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/Utility/DateShift.hs @@ -6,7 +6,6 @@ module Language.Marlowe.ACTUS.Model.Utility.DateShift ) where -import Data.Maybe (fromJust) import Data.Time (Day, addDays, toGregorian) import Data.Time.Calendar.WeekDate (toWeekDate) import Language.Marlowe.ACTUS.Definitions.ContractTerms (BDC (..), Calendar (..), ScheduleConfig (..)) @@ -15,7 +14,13 @@ import Language.Marlowe.ACTUS.Definitions.Schedule (ShiftedDay (. {- Business Day Convention -} applyBDCWithCfg :: ScheduleConfig -> Day -> ShiftedDay -applyBDCWithCfg ScheduleConfig {..} = applyBDC (fromJust bdc) (fromJust calendar) +applyBDCWithCfg + ScheduleConfig + { bdc = Just bdc', + calendar = Just calendar' + } + d = applyBDC bdc' calendar' d +applyBDCWithCfg _ date = ShiftedDay {paymentDay = date, calculationDay = date} applyBDC :: BDC -> Calendar -> Day -> ShiftedDay applyBDC BDC_NULL _ date = diff --git a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/Utility/ScheduleGenerator.hs b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/Utility/ScheduleGenerator.hs index e7fa296cfde..dbca72c870c 100644 --- a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/Utility/ScheduleGenerator.hs +++ b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/Utility/ScheduleGenerator.hs @@ -18,7 +18,6 @@ where import Control.Arrow ((>>>)) import Data.Function ((&)) import qualified Data.List as L (delete, init, last, length) -import Data.Maybe (fromJust) import Data.Time.Calendar (Day, addDays, addGregorianMonthsClip, addGregorianYearsClip, fromGregorian, gregorianMonthLength, toGregorian) @@ -90,12 +89,22 @@ generateRecurrentSchedule Cycle {..} anchorDate endDate = in go anchorDate 1 [] generateRecurrentScheduleWithCorrections :: Day -> Cycle -> Day -> ScheduleConfig -> ShiftedSchedule -generateRecurrentScheduleWithCorrections anchorDate cycle endDate ScheduleConfig {..} - = generateRecurrentSchedule cycle anchorDate endDate & - (correction cycle anchorDate endDate >>> - (fmap $ applyEOMC anchorDate cycle (fromJust eomc)) >>> - (fmap $ applyBDC (fromJust bdc) (fromJust calendar)) >>> - addEndDay (includeEndDay cycle) endDate) +generateRecurrentScheduleWithCorrections + anchorDate + cycle + endDate + ScheduleConfig + { eomc = Just eomc', + calendar = Just calendar', + bdc = Just bdc' + } = + generateRecurrentSchedule cycle anchorDate endDate + & ( correction cycle anchorDate endDate + >>> (fmap $ applyEOMC anchorDate cycle eomc') + >>> (fmap $ applyBDC bdc' calendar') + >>> addEndDay (includeEndDay cycle) endDate + ) +generateRecurrentScheduleWithCorrections _ _ _ _ = [] plusCycle :: Day -> Cycle -> Day plusCycle date cycle = shiftDate date (n cycle) (p cycle) From 6a6b459bc28e25859a011053338d6efd126194de Mon Sep 17 00:00:00 2001 From: Yves Hauser Date: Thu, 2 Sep 2021 15:07:47 +0200 Subject: [PATCH 13/28] scp-2709 - ACTUS code refactoring * comments * minor changes --- marlowe-actus/README.md | 34 ++++++- .../src/Language/Marlowe/ACTUS/Analysis.hs | 10 ++- .../src/Language/Marlowe/ACTUS/Generator.hs | 43 +++++---- .../Language/Marlowe/ACTUS/MarloweCompat.hs | 90 ++++++++----------- .../Model/INIT/StateInitializationModel.hs | 5 +- .../ACTUS/Model/SCHED/ContractSchedule.hs | 12 ++- .../Model/SCHED/ContractScheduleModel.hs | 4 +- .../Marlowe/ACTUS/Model/Utility/DateShift.hs | 2 +- 8 files changed, 121 insertions(+), 79 deletions(-) diff --git a/marlowe-actus/README.md b/marlowe-actus/README.md index 7a3ced9233d..5b93cf7749a 100644 --- a/marlowe-actus/README.md +++ b/marlowe-actus/README.md @@ -1,5 +1,35 @@ # Marlowe ACTUS: standardised financial contracts on Cardano Computation Layer -Here we present a library to generate Marlowe contracts from ACTUS contract terms +_marlowe-actus_ is a library to generate Marlowe contracts from ACTUS contract terms -See: https://www.actusfrf.org/ +## ACTUS (algorithmic contract types unified standards) + +ACTUS is a foundation that defines the ACTUS taxonomy of financial contracts, see https://www.actusfrf.org/ + +### Contract types + +The following contract types are implemented in Haskell and Marlowe. + +#### Amortizing loans + +An amortizing loan is a loan that requires periodic payments where a payement consists of the interest payment and the principal. + +##### Principal at maturity (PAM) + +Principal at maturity only defines periodic interest payments, the full principal is due at maturity. + +##### Linear Amortizer (LAM) + +Regular princial repayments over time, the interest payments decrease linearly. + +##### Negative Amortizer (NAM) + +Negative amortization means that the payments per period are smaller the interest, i.e. the balance of the loan increases over time. + +##### Annuity (ANN) + +The annuity amortization consists of regular payments of equal aomounts over the lifetime of the loan. + +## Test cases + +For the contract types mentioned above the implementation is tested with the test cases provided by ACTUS: https://github.com/actusfrf/actus-tests diff --git a/marlowe-actus/src/Language/Marlowe/ACTUS/Analysis.hs b/marlowe-actus/src/Language/Marlowe/ACTUS/Analysis.hs index 8228ecac54b..6857d151dc4 100644 --- a/marlowe-actus/src/Language/Marlowe/ACTUS/Analysis.hs +++ b/marlowe-actus/src/Language/Marlowe/ACTUS/Analysis.hs @@ -1,9 +1,15 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TupleSections #-} module Language.Marlowe.ACTUS.Analysis - (genProjectedCashflows) + ( genProjectedCashflows ) where +{-| = ACTUS Analysis + +Given an ACTUS contract cashflows can be projected. + +-} + import Control.Applicative ((<|>)) import qualified Data.List as L (find, groupBy) import qualified Data.Map as M (lookup) @@ -22,6 +28,8 @@ import Language.Marlowe.ACTUS.Model.POF.Payoff (pay import Language.Marlowe.ACTUS.Model.SCHED.ContractSchedule (maturity, schedule) import Language.Marlowe.ACTUS.Model.STF.StateTransition (stateTransition) +-- |genProjectedCashflows generates a list of projected cashflows for +-- given contract terms together with the observed data genProjectedCashflows :: DataObserved -> ContractTerms -> [CashFlow] genProjectedCashflows dataObserved ct@ContractTerms {..} = fromMaybe [] $ do diff --git a/marlowe-actus/src/Language/Marlowe/ACTUS/Generator.hs b/marlowe-actus/src/Language/Marlowe/ACTUS/Generator.hs index 122ab6e0b14..984151635e2 100644 --- a/marlowe-actus/src/Language/Marlowe/ACTUS/Generator.hs +++ b/marlowe-actus/src/Language/Marlowe/ACTUS/Generator.hs @@ -1,9 +1,13 @@ {-# LANGUAGE RecordWildCards #-} -{- This module contains templates for Marlowe constructs required by ACTUS logic -} +{-| = ACTUS Generator + +This module contains templates for Marlowe constructs required by ACTUS logic + +-} + module Language.Marlowe.ACTUS.Generator - ( - genStaticContract + ( genStaticContract , genFsContract ) where @@ -38,19 +42,20 @@ import Language.Marlowe.ACTUS.Ops as O import Ledger.Value (TokenName (TokenName)) import Prelude as P hiding (Fractional, Num, (*), (+), (/)) -receiveCollateral :: String -> Integer -> Integer -> Contract -> Contract -receiveCollateral from amount timeout continue = - if amount == 0 - then continue - else - let party = Role $ TokenName $ fromString from - in When - [ Case - (Deposit party party ada (Constant amount)) - continue - ] - (Slot timeout) - Close +-- receiveCollateral :: String -> Integer -> Integer -> Contract -> Contract +-- Any collateral-related code is commented out, until implemented properly +-- receiveCollateral from amount timeout continue = +-- if amount == 0 +-- then continue +-- else +-- let party = Role $ TokenName $ fromString from +-- in When +-- [ Case +-- (Deposit party party ada (Constant amount)) +-- continue +-- ] +-- (Slot timeout) +-- Close -- Any collateral-related code is commented out, until implemented properly -- invoice :: String -> String -> Value Observation -> Value Observation -> Slot -> Contract -> Contract @@ -211,8 +216,9 @@ genFsContract terms = genContract . setDefaultContractTermValues <$> validateTer where pof = payoffFs ev terms' t (t P.- 1) prevDate (cashCalculationDay cf) scheduleAcc = foldr gen (postProcess Close) $ L.zip6 schedCfs previousDates schedEvents schedDates cfsDirections [1..] - withCollateral cont = receiveCollateral "counterparty" (collateralAmount terms') (dayToSlotNumber $ ct_SD terms') cont - in withCollateral $ initializeStateFs terms' scheduleAcc + -- withCollateral cont = receiveCollateral "counterparty" (collateralAmount terms') (dayToSlotNumber $ ct_SD terms') cont + -- in withCollateral $ initializeStateFs terms' scheduleAcc + in initializeStateFs terms' scheduleAcc initializeStateFs :: ContractTerms -> Contract -> Contract initializeStateFs ct cont = maybe cont (flip stateInitialisation cont) (initialize ct) @@ -236,4 +242,3 @@ genZeroRiskAssertions terms@ContractTerms{ct_DCC = Just dcc, ..} NpvAssertionAga npv = foldl accumulateAndDiscount (constnt 0) (zip cfs [1..]) in Assert (ValueLT (constnt expectedNpv) npv) continue genZeroRiskAssertions _ _ c = c - diff --git a/marlowe-actus/src/Language/Marlowe/ACTUS/MarloweCompat.hs b/marlowe-actus/src/Language/Marlowe/ACTUS/MarloweCompat.hs index c08cac14a24..73ca338204c 100644 --- a/marlowe-actus/src/Language/Marlowe/ACTUS/MarloweCompat.hs +++ b/marlowe-actus/src/Language/Marlowe/ACTUS/MarloweCompat.hs @@ -2,7 +2,6 @@ {- This module provides compatibility to Marlowe DSL -} - module Language.Marlowe.ACTUS.MarloweCompat where import Language.Marlowe (Contract (Let), Observation, @@ -16,9 +15,7 @@ import Language.Marlowe.ACTUS.Definitions.ContractState (ContractStat import Language.Marlowe.ACTUS.Ops (marloweFixedPoint) type EventHandlerSTF = EventType -> ContractStateMarlowe -> ContractStateMarlowe - -type ContractStateMarlowe - = ContractStatePoly (Value Observation) (Value Observation) +type ContractStateMarlowe = ContractStatePoly (Value Observation) (Value Observation) useval :: String -> Integer -> Value Observation useval name t = UseValue $ ValueId $ fromString $ name ++ "_" ++ show t @@ -37,61 +34,52 @@ enum = id stateTransitionMarlowe :: EventType -> Integer -> Contract -> EventHandlerSTF -> Contract stateTransitionMarlowe ev t continue handler = - let inputState = ContractStatePoly { tmd = useval "tmd" $ t - 1 - , nt = useval "nt" $ t - 1 - , ipnr = useval "ipnr" $ t - 1 - , ipac = useval "ipac" $ t - 1 - , feac = useval "feac" $ t - 1 - , nsc = useval "nsc" $ t - 1 - , isc = useval "isc" $ t - 1 - , sd = useval "sd" $ t - 1 - , prnxt = useval "prnxt" $ t - 1 - , ipcb = useval "ipcb" $ t - 1 - , prf = undefined - } - handler_tmd = tmd $ handler ev inputState - handler_nt = nt $ handler ev inputState - handler_ipnr = ipnr $ handler ev inputState - handler_ipac = ipac $ handler ev inputState - handler_feac = feac $ handler ev inputState - handler_nsc = nsc $ handler ev inputState - handler_isc = isc $ handler ev inputState - handler_sd = sd $ handler ev inputState - handler_prnxt = prnxt $ handler ev inputState - handler_ipcb = ipcb $ handler ev inputState - in letval "tmd" t handler_tmd - $ letval "nt" t handler_nt - $ letval "ipnr" t handler_ipnr - $ letval "ipac" t handler_ipac - $ letval "feac" t handler_feac - $ letval "nsc" t handler_nsc - $ letval "isc" t handler_isc - $ letval "sd" t handler_sd - $ letval "prnxt" t handler_prnxt - $ letval "ipcb" t handler_ipcb - continue + let inputState = + ContractStatePoly + { tmd = useval "tmd" $ t - 1, + nt = useval "nt" $ t - 1, + ipnr = useval "ipnr" $ t - 1, + ipac = useval "ipac" $ t - 1, + feac = useval "feac" $ t - 1, + nsc = useval "nsc" $ t - 1, + isc = useval "isc" $ t - 1, + sd = useval "sd" $ t - 1, + prnxt = useval "prnxt" $ t - 1, + ipcb = useval "ipcb" $ t - 1, + prf = undefined + } + h = handler ev inputState + in letval "tmd" t (tmd h) $ + letval "nt" t (nt h) $ + letval "ipnr" t (ipnr h) $ + letval "ipac" t (ipac h) $ + letval "feac" t (feac h) $ + letval "nsc" t (nsc h) $ + letval "isc" t (isc h) $ + letval "sd" t (sd h) $ + letval "prnxt" t (prnxt h) $ + letval "ipcb" t (ipcb h) continue stateInitialisation :: ContractState -> Contract -> Contract -stateInitialisation ContractStatePoly{..} continue = - letval "tmd" 0 (marloweDate tmd) - $ letval "nt" 0 (constnt nt) - $ letval "ipnr" 0 (constnt ipnr) - $ letval "ipac" 0 (constnt ipac) - $ letval "feac" 0 (constnt feac) - $ letval "nsc" 0 (constnt nsc) - $ letval "isc" 0 (constnt isc) - $ letval "sd" 0 (marloweDate sd) - $ letval "prnxt" 0 (constnt prnxt) - $ letval "ipcb" 0 (constnt ipcb) - continue +stateInitialisation ContractStatePoly {..} continue = + letval "tmd" 0 (marloweDate tmd) $ + letval "nt" 0 (constnt nt) $ + letval "ipnr" 0 (constnt ipnr) $ + letval "ipac" 0 (constnt ipac) $ + letval "feac" 0 (constnt feac) $ + letval "nsc" 0 (constnt nsc) $ + letval "isc" 0 (constnt isc) $ + letval "sd" 0 (marloweDate sd) $ + letval "prnxt" 0 (constnt prnxt) $ + letval "ipcb" 0 (constnt ipcb) continue cardanoEpochStart :: Integer cardanoEpochStart = 100 dayToSlotNumber :: Day -> Integer dayToSlotNumber d = - let (MkSystemTime secs _) = utcToSystemTime (UTCTime d 0) - in fromIntegral secs - cardanoEpochStart + let (MkSystemTime secs _) = utcToSystemTime (UTCTime d 0) + in fromIntegral secs - cardanoEpochStart marloweDate :: Day -> Value Observation marloweDate = Constant . fromInteger . dayToSlotNumber diff --git a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/INIT/StateInitializationModel.hs b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/INIT/StateInitializationModel.hs index ac6a44dde66..60eac5bd4e6 100644 --- a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/INIT/StateInitializationModel.hs +++ b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/INIT/StateInitializationModel.hs @@ -1,4 +1,3 @@ - {-# LANGUAGE RecordWildCards #-} {-| = ACTUS contract state initialization per t0 @@ -8,7 +7,9 @@ Note: initial states rely also on some schedules (and vice versa) -} -module Language.Marlowe.ACTUS.Model.INIT.StateInitializationModel where +module Language.Marlowe.ACTUS.Model.INIT.StateInitializationModel + ( initialize ) +where import Data.Maybe (isJust, isNothing, maybeToList) import Data.Time.Calendar (Day) diff --git a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/SCHED/ContractSchedule.hs b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/SCHED/ContractSchedule.hs index 833a4ed431d..d0b6cf77237 100644 --- a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/SCHED/ContractSchedule.hs +++ b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/SCHED/ContractSchedule.hs @@ -1,6 +1,16 @@ {-# LANGUAGE RecordWildCards #-} -module Language.Marlowe.ACTUS.Model.SCHED.ContractSchedule where +{-| = ACTUS contract schedules + +The implementation is a transliteration of the ACTUS specification v1.1 + +-} + +module Language.Marlowe.ACTUS.Model.SCHED.ContractSchedule + ( schedule + , maturity + ) +where import Control.Applicative (Alternative ((<|>))) import Data.Ord (Down (..)) diff --git a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/SCHED/ContractScheduleModel.hs b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/SCHED/ContractScheduleModel.hs index 0e308ad196b..eeaaa92dde3 100644 --- a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/SCHED/ContractScheduleModel.hs +++ b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/SCHED/ContractScheduleModel.hs @@ -163,7 +163,7 @@ _SCHED_IP_NAM ContractTerms{..} = | otherwise = Nothing u | isNothing ct_IPANX && isNothing ct_IPCL = Nothing - | isJust ct_IPCED && fromMaybe False (liftA2 (>) ct_IPCED _T) = Nothing + | isJust ct_IPCED && Just True == liftA2 (>) ct_IPCED _T = Nothing | otherwise = _S r ((\c -> c { includeEndDay = True }) <$> ct_IPCL) ct_MD (Just scfg) v = _S s ct_PRCL ct_MD (Just scfg) @@ -188,7 +188,7 @@ _SCHED_IPCI_NAM ContractTerms{..} = | otherwise = Nothing u | isNothing ct_IPANX && isNothing ct_IPCL = Nothing - | isJust ct_IPCED && fromMaybe False (liftA2 (>) ct_IPCED _T) = Nothing + | isJust ct_IPCED && Just True == liftA2 (>) ct_IPCED _T = Nothing | otherwise = _S r ((\c -> c { includeEndDay = True }) <$> ct_IPCL) ct_MD (Just scfg) v = _S s ct_PRCL ct_MD (Just scfg) diff --git a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/Utility/DateShift.hs b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/Utility/DateShift.hs index f42b2a4b4c7..60f17d6cf1a 100644 --- a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/Utility/DateShift.hs +++ b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/Utility/DateShift.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RecordWildCards #-} + module Language.Marlowe.ACTUS.Model.Utility.DateShift ( applyBDC From e0ee3330f375d3a20d47203d78774622b99e1d51 Mon Sep 17 00:00:00 2001 From: Yves Hauser Date: Fri, 3 Sep 2021 08:13:47 +0200 Subject: [PATCH 14/28] scp-2709 - typos --- marlowe-actus/README.md | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/marlowe-actus/README.md b/marlowe-actus/README.md index 5b93cf7749a..3f49ca64932 100644 --- a/marlowe-actus/README.md +++ b/marlowe-actus/README.md @@ -12,7 +12,7 @@ The following contract types are implemented in Haskell and Marlowe. #### Amortizing loans -An amortizing loan is a loan that requires periodic payments where a payement consists of the interest payment and the principal. +An amortizing loan is a loan that requires periodic payments where a payment consists of the interest payment and the principal. ##### Principal at maturity (PAM) @@ -20,7 +20,7 @@ Principal at maturity only defines periodic interest payments, the full principa ##### Linear Amortizer (LAM) -Regular princial repayments over time, the interest payments decrease linearly. +Regular principal repayments over time, the interest payments decrease linearly. ##### Negative Amortizer (NAM) @@ -28,7 +28,7 @@ Negative amortization means that the payments per period are smaller the interes ##### Annuity (ANN) -The annuity amortization consists of regular payments of equal aomounts over the lifetime of the loan. +The annuity amortization consists of regular payments of equal amounts over the lifetime of the loan. ## Test cases From ae28b008d19d1ee00e9467c72a4c31fc9f2430b2 Mon Sep 17 00:00:00 2001 From: Yves Hauser Date: Fri, 3 Sep 2021 08:52:47 +0200 Subject: [PATCH 15/28] scp-2708 - ACTUS code refactoring * fixed shadowing warnings --- .../Marlowe/ACTUS/Model/Utility/DateShift.hs | 60 +++++++++---------- marlowe-actus/test/Spec/Marlowe/Util.hs | 47 +++++++-------- 2 files changed, 52 insertions(+), 55 deletions(-) diff --git a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/Utility/DateShift.hs b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/Utility/DateShift.hs index 60f17d6cf1a..8ab04608a8b 100644 --- a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/Utility/DateShift.hs +++ b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/Utility/DateShift.hs @@ -26,68 +26,68 @@ applyBDC :: BDC -> Calendar -> Day -> ShiftedDay applyBDC BDC_NULL _ date = ShiftedDay { paymentDay = date, calculationDay = date } -applyBDC BDC_SCF calendar date = ShiftedDay - { paymentDay = getFollowingBusinessDay date calendar - , calculationDay = getFollowingBusinessDay date calendar +applyBDC BDC_SCF cal date = ShiftedDay + { paymentDay = getFollowingBusinessDay date cal + , calculationDay = getFollowingBusinessDay date cal } -applyBDC BDC_SCMF calendar date = ShiftedDay - { paymentDay = shiftModifiedFollowing date calendar - , calculationDay = shiftModifiedFollowing date calendar +applyBDC BDC_SCMF cal date = ShiftedDay + { paymentDay = shiftModifiedFollowing date cal + , calculationDay = shiftModifiedFollowing date cal } -applyBDC BDC_CSF calendar date = ShiftedDay - { paymentDay = getFollowingBusinessDay date calendar +applyBDC BDC_CSF cal date = ShiftedDay + { paymentDay = getFollowingBusinessDay date cal , calculationDay = date } -applyBDC BDC_CSMF calendar date = ShiftedDay - { paymentDay = shiftModifiedFollowing date calendar +applyBDC BDC_CSMF cal date = ShiftedDay + { paymentDay = shiftModifiedFollowing date cal , calculationDay = date } -applyBDC BDC_SCP calendar date = ShiftedDay - { paymentDay = getPreceedingBusinessDay date calendar - , calculationDay = getPreceedingBusinessDay date calendar +applyBDC BDC_SCP cal date = ShiftedDay + { paymentDay = getPreceedingBusinessDay date cal + , calculationDay = getPreceedingBusinessDay date cal } -applyBDC BDC_SCMP calendar date = ShiftedDay - { paymentDay = shiftModifiedPreceeding date calendar - , calculationDay = shiftModifiedPreceeding date calendar +applyBDC BDC_SCMP cal date = ShiftedDay + { paymentDay = shiftModifiedPreceeding date cal + , calculationDay = shiftModifiedPreceeding date cal } -applyBDC BDC_CSP calendar date = ShiftedDay - { paymentDay = getPreceedingBusinessDay date calendar +applyBDC BDC_CSP cal date = ShiftedDay + { paymentDay = getPreceedingBusinessDay date cal , calculationDay = date } -applyBDC BDC_CSMP calendar date = ShiftedDay - { paymentDay = shiftModifiedPreceeding date calendar +applyBDC BDC_CSMP cal date = ShiftedDay + { paymentDay = shiftModifiedPreceeding date cal , calculationDay = date } shiftModifiedFollowing :: Day -> Calendar -> Day -shiftModifiedFollowing date calendar = +shiftModifiedFollowing date cal = let (_, month, _) = toGregorian date - shiftedFollowing = getFollowingBusinessDay date calendar + shiftedFollowing = getFollowingBusinessDay date cal (_, shiftedMonth, _) = toGregorian shiftedFollowing in if month == shiftedMonth then shiftedFollowing - else getPreceedingBusinessDay date calendar + else getPreceedingBusinessDay date cal shiftModifiedPreceeding :: Day -> Calendar -> Day -shiftModifiedPreceeding date calendar = +shiftModifiedPreceeding date cal = let (_, month, _) = toGregorian date - shiftedPreceeding = getPreceedingBusinessDay date calendar + shiftedPreceeding = getPreceedingBusinessDay date cal (_, shiftedMonth, _) = toGregorian shiftedPreceeding in if month == shiftedMonth then shiftedPreceeding - else getFollowingBusinessDay date calendar + else getFollowingBusinessDay date cal getFollowingBusinessDay :: Day -> Calendar -> Day -getFollowingBusinessDay date calendarType = - case calendarType of +getFollowingBusinessDay date cal = + case cal of CLDR_MF -> case toWeekDate date of (_, _, 6) -> @@ -100,8 +100,8 @@ getFollowingBusinessDay date calendarType = date getPreceedingBusinessDay :: Day -> Calendar -> Day -getPreceedingBusinessDay date calendarType = - case calendarType of +getPreceedingBusinessDay date cal = + case cal of CLDR_MF -> case toWeekDate date of (_, _, 6) -> diff --git a/marlowe-actus/test/Spec/Marlowe/Util.hs b/marlowe-actus/test/Spec/Marlowe/Util.hs index deb5b94c05a..9d81640b62e 100644 --- a/marlowe-actus/test/Spec/Marlowe/Util.hs +++ b/marlowe-actus/test/Spec/Marlowe/Util.hs @@ -60,41 +60,41 @@ termsToString = Map.map (\case parseObservedValues :: Map String Value -> DataObserved parseObservedValues = Map.map(\(Object valuesObserved) -> - let String identifier = valuesObserved HashMap.! "identifier" - Array values = valuesObserved HashMap.! "data" + let String identifier' = valuesObserved HashMap.! "identifier" + Array values' = valuesObserved HashMap.! "data" in ValuesObserved{ - identifier = unpack identifier + identifier = unpack identifier' , values = Vector.toList $ Vector.map (\(Object observedValue) -> - let String timestamp = observedValue HashMap.! "timestamp" - String value = observedValue HashMap.! "value" + let String timestamp' = observedValue HashMap.! "timestamp" + String value' = observedValue HashMap.! "value" in ValueObserved{ - timestamp = fromJust $ parseMaybeDate $ Just $ unpack timestamp - , value = read (unpack value) :: Double + timestamp = fromJust $ parseMaybeDate $ Just $ unpack timestamp' + , value = read (unpack value') :: Double } - ) values + ) values' } ) assertTestResults :: [CashFlow] -> [TestResult] -> String -> IO () assertTestResults [] [] _ = return () -assertTestResults (cashFlow: restCash) (testResult: restTest) identifier = do - assertTestResult cashFlow testResult identifier - assertTestResults restCash restTest identifier +assertTestResults (cashFlow: restCash) (testResult: restTest) identifier' = do + assertTestResult cashFlow testResult identifier' + assertTestResults restCash restTest identifier' assertTestResult :: CashFlow -> TestResult -> String -> IO () assertTestResult - CashFlow{cashPaymentDay = date, cashEvent = event, amount = payoff} - testResult@TestResult{eventDate = testDate, eventType = testEvent, payoff = testPayoff} identifier = do - assertBool ("[" ++ show identifier ++ "] Generated event and test event types should be the same: actual " ++ show event ++ ", expected for " ++ show testResult) $ event == (read testEvent :: EventType) - assertBool ("Generated date and test date should be the same: actual " ++ show date ++ ", expected for " ++ show testResult ++ " in " ++ identifier) (date == (fromJust $ parseDate testDate)) - assertBool ("[" ++ show identifier ++ "] Generated payoff and test payoff should be the same: actual " ++ show payoff ++ ", expected for " ++ show testResult) $ (realToFrac payoff :: Float) == (realToFrac testPayoff :: Float) + CashFlow{cashPaymentDay = date, cashEvent = event, amount = payoff'} + testResult@TestResult{eventDate = testDate, eventType = testEvent, payoff = testPayoff} identifier' = do + assertBool ("[" ++ show identifier' ++ "] Generated event and test event types should be the same: actual " ++ show event ++ ", expected for " ++ show testResult) $ event == (read testEvent :: EventType) + assertBool ("Generated date and test date should be the same: actual " ++ show date ++ ", expected for " ++ show testResult ++ " in " ++ identifier') (date == (fromJust $ parseDate testDate)) + assertBool ("[" ++ show identifier' ++ "] Generated payoff and test payoff should be the same: actual " ++ show payoff' ++ ", expected for " ++ show testResult) $ (realToFrac payoff' :: Float) == (realToFrac testPayoff :: Float) testToContractTerms :: TestCase -> ContractTerms -testToContractTerms TestCase{terms = terms} = - let terms' = termsToString terms +testToContractTerms TestCase{terms = t} = + let terms' = termsToString t in ContractTerms { contractId = terms' Map.! "contractID" @@ -139,7 +139,7 @@ testToContractTerms TestCase{terms = terms} = , ct_SCIED = readMaybe $ Map.lookup "scalingIndexAtStatusDate" terms' :: Maybe Double , ct_SCANX = parseMaybeDate $ Map.lookup "cycleAnchorDateOfScalingIndex" terms' , ct_SCCL = parseMaybeCycle $ Map.lookup "cycleOfScalingIndex" terms' - , ct_SCEF = readMaybe (maybeReplace "O" "0" (maybeConcatPrefix "SE_" (Map.lookup "scalingEffect" terms'))) :: Maybe SCEF + , ct_SCEF = readMaybe (replace "O" "0" <$> (maybeConcatPrefix "SE_" (Map.lookup "scalingEffect" terms'))) :: Maybe SCEF , ct_SCCDD = readMaybe $ Map.lookup "scalingIndexAtContractDealDate" terms' :: Maybe Double , ct_SCMO = Map.lookup "marketObjectCodeOfScalingIndex" terms' , ct_SCNT = readMaybe $ Map.lookup "notionalScalingMultiplier" terms' :: Maybe Double @@ -181,10 +181,10 @@ parseMaybeCycle :: Maybe String -> Maybe Cycle parseMaybeCycle stringCycle = case stringCycle of Just (_:stringCycle') -> - let n = read (takeWhile (< 'A') stringCycle') :: Integer - [p, _, s] = dropWhile (< 'A') stringCycle' + let n' = read (takeWhile (< 'A') stringCycle') :: Integer + [p', _, s] = dropWhile (< 'A') stringCycle' in - Just Cycle { n = n, p = read $ "P_" ++ [p] :: Period, stub = parseStub [s], includeEndDay = False } + Just Cycle { n = n', p = read $ "P_" ++ [p'] :: Period, stub = parseStub [s], includeEndDay = False } Nothing -> Nothing @@ -203,6 +203,3 @@ maybeDCCFromString dcc = maybeConcatPrefix :: String -> Maybe String -> Maybe String maybeConcatPrefix prefix = fmap (prefix ++) - -maybeReplace :: String -> String -> Maybe String -> Maybe String -maybeReplace from to = fmap (replace from to) From c0171e85ed9a9ee13ff12768dcda1ac9ae82a309 Mon Sep 17 00:00:00 2001 From: Yves Hauser Date: Fri, 3 Sep 2021 14:16:13 +0200 Subject: [PATCH 16/28] scp-2709 - ACTUS code refactoring * moved test data structures into test directory --- .../src/Language/Marlowe/ACTUS/Analysis.hs | 34 ++------------ .../ACTUS/Definitions/BusinessEvents.hs | 17 ------- .../src/Language/Marlowe/ACTUS/Generator.hs | 18 +++++--- marlowe-actus/test/Spec/Marlowe/Actus.hs | 45 ++++++++++++++++--- marlowe-actus/test/Spec/Marlowe/Util.hs | 17 +++++-- 5 files changed, 69 insertions(+), 62 deletions(-) diff --git a/marlowe-actus/src/Language/Marlowe/ACTUS/Analysis.hs b/marlowe-actus/src/Language/Marlowe/ACTUS/Analysis.hs index 6857d151dc4..8d47cc7e88c 100644 --- a/marlowe-actus/src/Language/Marlowe/ACTUS/Analysis.hs +++ b/marlowe-actus/src/Language/Marlowe/ACTUS/Analysis.hs @@ -11,14 +11,11 @@ Given an ACTUS contract cashflows can be projected. -} import Control.Applicative ((<|>)) -import qualified Data.List as L (find, groupBy) -import qualified Data.Map as M (lookup) +import qualified Data.List as L (groupBy) import Data.Maybe (fromMaybe, isNothing) import Data.Sort (sortOn) import Data.Time (Day) -import Language.Marlowe.ACTUS.Definitions.BusinessEvents (DataObserved, EventType (..), - RiskFactors (..), ValueObserved (..), - ValuesObserved (..)) +import Language.Marlowe.ACTUS.Definitions.BusinessEvents (EventType (..), RiskFactors (..)) import Language.Marlowe.ACTUS.Definitions.ContractState (ContractState) import Language.Marlowe.ACTUS.Definitions.ContractTerms (CT (..), ContractTerms (..)) import Language.Marlowe.ACTUS.Definitions.Schedule (CashFlow (..), ShiftedDay (..), @@ -30,8 +27,8 @@ import Language.Marlowe.ACTUS.Model.STF.StateTransition (sta -- |genProjectedCashflows generates a list of projected cashflows for -- given contract terms together with the observed data -genProjectedCashflows :: DataObserved -> ContractTerms -> [CashFlow] -genProjectedCashflows dataObserved ct@ContractTerms {..} = fromMaybe [] $ +genProjectedCashflows :: (EventType -> Day -> RiskFactors) -> ContractTerms -> [CashFlow] +genProjectedCashflows getRiskFactors ct@ContractTerms {..} = fromMaybe [] $ do st0 <- initialize ct return $ @@ -104,26 +101,3 @@ genProjectedCashflows dataObserved ct@ContractTerms {..} = fromMaybe [] $ overwrite = map (sortOn priority) . regroup in concat . overwrite . trim - getRiskFactors :: EventType -> Day -> RiskFactors - getRiskFactors ev date = - let riskFactors = - RiskFactors - { o_rf_CURS = 1.0, - o_rf_RRMO = 1.0, - o_rf_SCMO = 1.0, - pp_payoff = 0.0 - } - - observedKey RR = ct_RRMO - observedKey SC = ct_SCMO - observedKey _ = ct_CURS - - value = fromMaybe 1.0 $ do - k <- observedKey ev - ValuesObserved {values = values} <- M.lookup k dataObserved - ValueObserved {value = valueObserved} <- L.find (\ValueObserved {timestamp = timestamp} -> timestamp == date) values - return valueObserved - in case ev of - RR -> riskFactors {o_rf_RRMO = value} - SC -> riskFactors {o_rf_SCMO = value} - _ -> riskFactors {o_rf_CURS = value} diff --git a/marlowe-actus/src/Language/Marlowe/ACTUS/Definitions/BusinessEvents.hs b/marlowe-actus/src/Language/Marlowe/ACTUS/Definitions/BusinessEvents.hs index 1e3d93a6266..aaa43122c44 100644 --- a/marlowe-actus/src/Language/Marlowe/ACTUS/Definitions/BusinessEvents.hs +++ b/marlowe-actus/src/Language/Marlowe/ACTUS/Definitions/BusinessEvents.hs @@ -5,8 +5,6 @@ module Language.Marlowe.ACTUS.Definitions.BusinessEvents where import Data.Aeson.Types (ToJSON) -import Data.Map -import Data.Time import GHC.Generics (Generic) {-| ACTUS event types @@ -49,18 +47,3 @@ data RiskFactors = RiskFactors deriving stock (Generic) deriving (Show, ToJSON) -{-| Observed data --} -type DataObserved = Map String ValuesObserved - -data ValuesObserved = ValuesObserved - { identifier :: String - , values :: [ValueObserved] - } - deriving (Show) - -data ValueObserved = ValueObserved - { timestamp :: Day - , value :: Double - } - deriving (Show) diff --git a/marlowe-actus/src/Language/Marlowe/ACTUS/Generator.hs b/marlowe-actus/src/Language/Marlowe/ACTUS/Generator.hs index 984151635e2..a46d592a284 100644 --- a/marlowe-actus/src/Language/Marlowe/ACTUS/Generator.hs +++ b/marlowe-actus/src/Language/Marlowe/ACTUS/Generator.hs @@ -13,7 +13,6 @@ module Language.Marlowe.ACTUS.Generator where import qualified Data.List as L (foldl', zip6) -import Data.Map as M (empty) import Data.Maybe (fromMaybe, isNothing, maybeToList) import Data.Monoid (Endo (Endo, appEndo)) import Data.String (IsString (fromString)) @@ -25,7 +24,7 @@ import Language.Marlowe (Act Slot (..), Value (..), ValueId (ValueId), ada) import Language.Marlowe.ACTUS.Analysis (genProjectedCashflows) -import Language.Marlowe.ACTUS.Definitions.BusinessEvents (EventType (..)) +import Language.Marlowe.ACTUS.Definitions.BusinessEvents (EventType (..), RiskFactors (..)) import Language.Marlowe.ACTUS.Definitions.ContractTerms (Assertion (..), AssertionContext (..), Assertions (..), ContractTerms (..), TermValidationError (..), @@ -133,13 +132,22 @@ inquiryFs ev ct timePosfix date oracle context continue = in riskFactorsInquiryEv ev continue +defaultRiskFactors :: EventType -> Day -> RiskFactors +defaultRiskFactors _ _ = + RiskFactors + { o_rf_CURS = 1.0, + o_rf_RRMO = 1.0, + o_rf_SCMO = 1.0, + pp_payoff = 0.0 + } + genStaticContract :: ContractTerms -> Validation [TermValidationError] Contract genStaticContract terms = genContract . setDefaultContractTermValues <$> validateTerms terms where genContract :: ContractTerms -> Contract genContract t = let - cfs = genProjectedCashflows M.empty t + cfs = genProjectedCashflows defaultRiskFactors t gen CashFlow {..} | amount == 0.0 = id | amount > 0.0 @@ -182,7 +190,7 @@ genFsContract terms = genContract . setDefaultContractTermValues <$> validateTer in compose toAssert cont payoffAt t = ValueId $ fromString $ "payoff_" ++ show t - schedCfs = genProjectedCashflows M.empty terms' + schedCfs = genProjectedCashflows defaultRiskFactors terms' schedEvents = cashEvent <$> schedCfs schedDates = Slot . dayToSlotNumber . cashPaymentDay <$> schedCfs previousDates = ct_SD terms' : (cashCalculationDay <$> schedCfs) @@ -226,7 +234,7 @@ genFsContract terms = genContract . setDefaultContractTermValues <$> validateTer genZeroRiskAssertions :: ContractTerms -> Assertion -> Contract -> Contract genZeroRiskAssertions terms@ContractTerms{ct_DCC = Just dcc, ..} NpvAssertionAgainstZeroRiskBond{..} continue = let - cfs = genProjectedCashflows M.empty terms + cfs = genProjectedCashflows defaultRiskFactors terms dateToYearFraction :: Day -> Double dateToYearFraction dt = _y dcc ct_SD dt ct_MD diff --git a/marlowe-actus/test/Spec/Marlowe/Actus.hs b/marlowe-actus/test/Spec/Marlowe/Actus.hs index ba5dfb5720b..99fa0e07ab0 100644 --- a/marlowe-actus/test/Spec/Marlowe/Actus.hs +++ b/marlowe-actus/test/Spec/Marlowe/Actus.hs @@ -1,25 +1,56 @@ -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} module Spec.Marlowe.Actus ( tests, TestCase(..) ) where -import Language.Marlowe.ACTUS.Analysis (genProjectedCashflows) -import Language.Marlowe.ACTUS.Definitions.ContractTerms hiding (Assertion) +import qualified Data.List as L (find) +import qualified Data.Map as M (lookup) +import Data.Maybe (fromMaybe) +import GHC.Records (getField) +import Language.Marlowe.ACTUS.Analysis (genProjectedCashflows) +import Language.Marlowe.ACTUS.Definitions.BusinessEvents (EventType (..), RiskFactors (..)) +import Language.Marlowe.ACTUS.Definitions.ContractTerms hiding (Assertion) import Language.Marlowe.ACTUS.Definitions.Schedule import Spec.Marlowe.Util import Test.Tasty import Test.Tasty.HUnit tests :: String -> [TestCase] -> TestTree -tests n t = testGroup n $ [ testCase (identifier tc) (runTest tc) | tc <- t] +tests n t = testGroup n $ [ testCase (getField @"identifier" tc) (runTest tc) | tc <- t] runTest :: TestCase -> Assertion -runTest tc@TestCase{..} = +runTest tc@TestCase {..} = let testcase = testToContractTerms tc contract = setDefaultContractTermValues testcase observed = parseObservedValues dataObserved - cashFlows = genProjectedCashflows observed contract + + getRiskFactors ev date = + let riskFactors = + RiskFactors + { o_rf_CURS = 1.0, + o_rf_RRMO = 1.0, + o_rf_SCMO = 1.0, + pp_payoff = 0.0 + } + + observedKey RR = ct_RRMO contract + observedKey SC = ct_SCMO contract + observedKey _ = ct_CURS contract + + value = fromMaybe 1.0 $ do + k <- observedKey ev + ValuesObserved {values = values} <- M.lookup k observed + ValueObserved {value = valueObserved} <- L.find (\ValueObserved {timestamp = timestamp} -> timestamp == date) values + return valueObserved + in case ev of + RR -> riskFactors {o_rf_RRMO = value} + SC -> riskFactors {o_rf_SCMO = value} + _ -> riskFactors {o_rf_CURS = value} + + cashFlows = genProjectedCashflows getRiskFactors contract cashFlowsTo = maybe cashFlows (\d -> filter (\cf -> cashCalculationDay cf <= d) cashFlows) (parseDate to) - in assertTestResults cashFlowsTo results identifier + in assertTestResults cashFlowsTo results identifier diff --git a/marlowe-actus/test/Spec/Marlowe/Util.hs b/marlowe-actus/test/Spec/Marlowe/Util.hs index 9d81640b62e..ab4eb3cb0cd 100644 --- a/marlowe-actus/test/Spec/Marlowe/Util.hs +++ b/marlowe-actus/test/Spec/Marlowe/Util.hs @@ -21,13 +21,24 @@ import Data.Text (unpack) import Data.Time (Day, defaultTimeLocale, parseTimeM) import Data.Vector as Vector (map, toList) import GHC.Generics (Generic) -import Language.Marlowe.ACTUS.Definitions.BusinessEvents (DataObserved, EventType, - ValueObserved (ValueObserved, timestamp, value), - ValuesObserved (ValuesObserved, identifier, values)) +import Language.Marlowe.ACTUS.Definitions.BusinessEvents (EventType) import Language.Marlowe.ACTUS.Definitions.ContractTerms import Language.Marlowe.ACTUS.Definitions.Schedule (CashFlow (CashFlow, amount, cashEvent, cashPaymentDay)) import Test.Tasty.HUnit (assertBool) +type DataObserved = Map String ValuesObserved + +data ValuesObserved = ValuesObserved + { identifier :: String + , values :: [ValueObserved] + } + deriving (Show) + +data ValueObserved = ValueObserved + { timestamp :: Day + , value :: Double + } + deriving (Show) data TestResult = TestResult{ eventDate :: String From 241c95589a5e9100d9fb9239a8b266ff16516b90 Mon Sep 17 00:00:00 2001 From: Yves Hauser Date: Mon, 6 Sep 2021 15:21:50 +0200 Subject: [PATCH 17/28] scp-2709 - refactoring ACTUS code * added RiskFactorsPoly to allow to pass risk factors into the model properly --- .../src/Language/Marlowe/ACTUS/Analysis.hs | 2 +- .../ACTUS/Definitions/BusinessEvents.hs | 11 ++++--- .../src/Language/Marlowe/ACTUS/Generator.hs | 31 ++++++++++++++----- .../Language/Marlowe/ACTUS/MarloweCompat.hs | 8 ++--- .../Marlowe/ACTUS/Model/POF/Payoff.hs | 30 +++++++++--------- .../Marlowe/ACTUS/Model/POF/PayoffFs.hs | 11 +++---- .../ACTUS/Model/STF/StateTransition.hs | 5 +-- .../ACTUS/Model/STF/StateTransitionFs.hs | 16 +++++----- marlowe-actus/test/Spec/Marlowe/Actus.hs | 4 +-- 9 files changed, 66 insertions(+), 52 deletions(-) diff --git a/marlowe-actus/src/Language/Marlowe/ACTUS/Analysis.hs b/marlowe-actus/src/Language/Marlowe/ACTUS/Analysis.hs index 8d47cc7e88c..a85a5106dce 100644 --- a/marlowe-actus/src/Language/Marlowe/ACTUS/Analysis.hs +++ b/marlowe-actus/src/Language/Marlowe/ACTUS/Analysis.hs @@ -15,7 +15,7 @@ import qualified Data.List as L import Data.Maybe (fromMaybe, isNothing) import Data.Sort (sortOn) import Data.Time (Day) -import Language.Marlowe.ACTUS.Definitions.BusinessEvents (EventType (..), RiskFactors (..)) +import Language.Marlowe.ACTUS.Definitions.BusinessEvents (EventType (..), RiskFactors) import Language.Marlowe.ACTUS.Definitions.ContractState (ContractState) import Language.Marlowe.ACTUS.Definitions.ContractTerms (CT (..), ContractTerms (..)) import Language.Marlowe.ACTUS.Definitions.Schedule (CashFlow (..), ShiftedDay (..), diff --git a/marlowe-actus/src/Language/Marlowe/ACTUS/Definitions/BusinessEvents.hs b/marlowe-actus/src/Language/Marlowe/ACTUS/Definitions/BusinessEvents.hs index aaa43122c44..7f5c4963cac 100644 --- a/marlowe-actus/src/Language/Marlowe/ACTUS/Definitions/BusinessEvents.hs +++ b/marlowe-actus/src/Language/Marlowe/ACTUS/Definitions/BusinessEvents.hs @@ -38,12 +38,13 @@ data EventType = {-| Risk factor observer -} -data RiskFactors = RiskFactors - { o_rf_CURS :: Double - , o_rf_RRMO :: Double - , o_rf_SCMO :: Double - , pp_payoff :: Double +data RiskFactorsPoly a = RiskFactorsPoly + { o_rf_CURS :: a + , o_rf_RRMO :: a + , o_rf_SCMO :: a + , pp_payoff :: a } deriving stock (Generic) deriving (Show, ToJSON) +type RiskFactors = RiskFactorsPoly Double diff --git a/marlowe-actus/src/Language/Marlowe/ACTUS/Generator.hs b/marlowe-actus/src/Language/Marlowe/ACTUS/Generator.hs index a46d592a284..372de6bf30b 100644 --- a/marlowe-actus/src/Language/Marlowe/ACTUS/Generator.hs +++ b/marlowe-actus/src/Language/Marlowe/ACTUS/Generator.hs @@ -24,7 +24,8 @@ import Language.Marlowe (Act Slot (..), Value (..), ValueId (ValueId), ada) import Language.Marlowe.ACTUS.Analysis (genProjectedCashflows) -import Language.Marlowe.ACTUS.Definitions.BusinessEvents (EventType (..), RiskFactors (..)) +import Language.Marlowe.ACTUS.Definitions.BusinessEvents (EventType (..), RiskFactors, + RiskFactorsPoly (..)) import Language.Marlowe.ACTUS.Definitions.ContractTerms (Assertion (..), AssertionContext (..), Assertions (..), ContractTerms (..), TermValidationError (..), @@ -98,6 +99,7 @@ inquiryFs inquiryFs ev ct timePosfix date oracle context continue = let oracleRole = Role $ TokenName $ fromString oracle + letTemplate inputChoiceId inputOwner cont = Let (ValueId inputChoiceId) @@ -116,25 +118,26 @@ inquiryFs ev ct timePosfix date oracle context continue = ("o_rf_RRMO", Just AssertionContext{..}) -> [Bound (toMarloweFixedPoint rrmoMin) (toMarloweFixedPoint rrmoMax)] _ -> [Bound 0 maxPseudoDecimalValue] + riskFactorInquiry name = inputTemplate (fromString (name ++ timePosfix)) oracleRole (inferBounds name context) + riskFactorsInquiryEv AD = id riskFactorsInquiryEv SC = riskFactorInquiry "o_rf_SCMO" riskFactorsInquiryEv RR = riskFactorInquiry "o_rf_RRMO" - riskFactorsInquiryEv PP = - riskFactorInquiry "o_rf_CURS" . - riskFactorInquiry "pp_payoff" + riskFactorsInquiryEv PP = riskFactorInquiry "o_rf_CURS" . riskFactorInquiry "pp_payoff" riskFactorsInquiryEv _ = if enableSettlement ct then riskFactorInquiry "o_rf_CURS" else Let (ValueId (fromString ("o_rf_CURS" ++ timePosfix))) (constnt 1.0) + in riskFactorsInquiryEv ev continue defaultRiskFactors :: EventType -> Day -> RiskFactors defaultRiskFactors _ _ = - RiskFactors + RiskFactorsPoly { o_rf_CURS = 1.0, o_rf_RRMO = 1.0, o_rf_SCMO = 1.0, @@ -200,7 +203,14 @@ genFsContract terms = genContract . setDefaultContractTermValues <$> validateTer gen :: (CashFlow, Day, EventType, Slot, Double, Integer) -> Contract -> Contract gen (cf, prevDate, ev, date, r, t) cont = inquiryFs ev terms' ("_" ++ show t) date "oracle" ctx - $ stateTransitionFs ev terms' t prevDate (cashCalculationDay cf) + $ stateTransitionFs ev + RiskFactorsPoly { + o_rf_CURS = useval "o_rf_CURS" t + , o_rf_RRMO = useval "o_rf_RRMO" t + , o_rf_SCMO = useval "o_rf_SCMO" t + , pp_payoff = useval "pp_payoff" t + } + terms' t prevDate (cashCalculationDay cf) $ Let (payoffAt t) (fromMaybe (constnt 0.0) pof) $ if isNothing pof then cont else if r > 0.0 then @@ -221,7 +231,14 @@ genFsContract terms = genContract . setDefaultContractTermValues <$> validateTer -- (Constant $ collateralAmount terms) date cont - where pof = payoffFs ev terms' t (t P.- 1) prevDate (cashCalculationDay cf) + where pof = payoffFs ev + RiskFactorsPoly { + o_rf_CURS = useval "o_rf_CURS" t + , o_rf_RRMO = useval "o_rf_RRMO" t + , o_rf_SCMO = useval "o_rf_SCMO" t + , pp_payoff = useval "pp_payoff" t + } + terms' (t P.- 1) prevDate (cashCalculationDay cf) scheduleAcc = foldr gen (postProcess Close) $ L.zip6 schedCfs previousDates schedEvents schedDates cfsDirections [1..] -- withCollateral cont = receiveCollateral "counterparty" (collateralAmount terms') (dayToSlotNumber $ ct_SD terms') cont diff --git a/marlowe-actus/src/Language/Marlowe/ACTUS/MarloweCompat.hs b/marlowe-actus/src/Language/Marlowe/ACTUS/MarloweCompat.hs index 73ca338204c..8261ea71a48 100644 --- a/marlowe-actus/src/Language/Marlowe/ACTUS/MarloweCompat.hs +++ b/marlowe-actus/src/Language/Marlowe/ACTUS/MarloweCompat.hs @@ -4,18 +4,18 @@ module Language.Marlowe.ACTUS.MarloweCompat where -import Language.Marlowe (Contract (Let), Observation, - Value (Constant, UseValue), ValueId (ValueId)) - import Data.String (IsString (fromString)) import Data.Time (Day, UTCTime (UTCTime)) import Data.Time.Clock.System (SystemTime (MkSystemTime), utcToSystemTime) -import Language.Marlowe.ACTUS.Definitions.BusinessEvents (EventType) +import Language.Marlowe (Contract (Let), Observation, + Value (Constant, UseValue), ValueId (ValueId)) +import Language.Marlowe.ACTUS.Definitions.BusinessEvents (EventType, RiskFactorsPoly (..)) import Language.Marlowe.ACTUS.Definitions.ContractState (ContractState, ContractStatePoly (..)) import Language.Marlowe.ACTUS.Ops (marloweFixedPoint) type EventHandlerSTF = EventType -> ContractStateMarlowe -> ContractStateMarlowe type ContractStateMarlowe = ContractStatePoly (Value Observation) (Value Observation) +type RiskFactorsMarlowe = RiskFactorsPoly (Value Observation) useval :: String -> Integer -> Value Observation useval name t = UseValue $ ValueId $ fromString $ name ++ "_" ++ show t diff --git a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/POF/Payoff.hs b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/POF/Payoff.hs index 60561e93d35..7bdd71c242a 100644 --- a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/POF/Payoff.hs +++ b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/POF/Payoff.hs @@ -3,7 +3,7 @@ module Language.Marlowe.ACTUS.Model.POF.Payoff where import Data.Time (Day) -import Language.Marlowe.ACTUS.Definitions.BusinessEvents (EventType (..), RiskFactors (..)) +import Language.Marlowe.ACTUS.Definitions.BusinessEvents (EventType (..), RiskFactors, RiskFactorsPoly (..)) import Language.Marlowe.ACTUS.Definitions.ContractState (ContractState, ContractStatePoly (..)) import Language.Marlowe.ACTUS.Definitions.ContractTerms (CT (..), ContractTerms (..)) import Language.Marlowe.ACTUS.Model.POF.PayoffModel @@ -13,7 +13,7 @@ payoff :: EventType -> RiskFactors -> ContractTerms -> ContractState -> Day -> D -- IED payoff IED - RiskFactors {..} + RiskFactorsPoly {..} ContractTerms { ct_NT = Just notionalPrincipal, ct_PDIED = Just pdied, @@ -24,7 +24,7 @@ payoff -- PR payoff PR - RiskFactors {..} + RiskFactorsPoly {..} ContractTerms { contractType = LAM, ct_CNTRL = cntrl @@ -33,7 +33,7 @@ payoff _ = _POF_PR_LAM o_rf_CURS cntrl nt nsc prnxt payoff PR - RiskFactors {..} + RiskFactorsPoly {..} ContractTerms { contractType = NAM, ct_DCC = Just dayCountConvention, @@ -46,7 +46,7 @@ payoff in _POF_PR_NAM o_rf_CURS cntrl nsc prnxt ipac y_sd_t ipnr ipcb nt payoff PR - RiskFactors {..} + RiskFactorsPoly {..} ContractTerms { contractType = ANN, ct_DCC = Just dayCountConvention, @@ -58,13 +58,13 @@ payoff let y_sd_t = _y dayCountConvention sd t md in _POF_PR_NAM o_rf_CURS cntrl nsc prnxt ipac y_sd_t ipnr ipcb nt -- MD -payoff MD RiskFactors {..} _ ContractStatePoly {..} _ = _POF_MD_PAM o_rf_CURS nsc nt isc ipac feac +payoff MD RiskFactorsPoly {..} _ ContractStatePoly {..} _ = _POF_MD_PAM o_rf_CURS nsc nt isc ipac feac -- PP -payoff PP RiskFactors {..} _ _ _ = _POF_PP_PAM o_rf_CURS pp_payoff +payoff PP RiskFactorsPoly {..} _ _ _ = _POF_PP_PAM o_rf_CURS pp_payoff -- PY payoff PY - RiskFactors {..} + RiskFactorsPoly {..} ContractTerms { ct_PYTP = Just pytp, ct_PYRT = Just pyrt, @@ -80,7 +80,7 @@ payoff -- FP payoff FP - RiskFactors {..} + RiskFactorsPoly {..} ContractTerms { ct_DCC = Just dayCountConvention, ct_CNTRL = cntrl, @@ -95,7 +95,7 @@ payoff -- PRD payoff PRD - RiskFactors {..} + RiskFactorsPoly {..} ContractTerms { contractType = PAM, ct_DCC = Just dayCountConvention, @@ -109,7 +109,7 @@ payoff in _POF_PRD_PAM o_rf_CURS cntrl pprd ipac ipnr nt y_sd_t payoff PRD - RiskFactors {..} + RiskFactorsPoly {..} ContractTerms { ct_DCC = Just dayCountConvention, ct_CNTRL = cntrl, @@ -123,7 +123,7 @@ payoff -- TD payoff TD - RiskFactors {..} + RiskFactorsPoly {..} ContractTerms { contractType = PAM, ct_DCC = Just dayCountConvention, @@ -137,7 +137,7 @@ payoff in _POF_TD_PAM o_rf_CURS cntrl ptd ipac ipnr nt y_sd_t payoff TD - RiskFactors {..} + RiskFactorsPoly {..} ContractTerms { ct_DCC = Just dayCountConvention, ct_CNTRL = cntrl, @@ -151,7 +151,7 @@ payoff -- IP payoff IP - RiskFactors {..} + RiskFactorsPoly {..} ContractTerms { contractType = PAM, ct_DCC = Just dayCountConvention, @@ -163,7 +163,7 @@ payoff in _POF_IP_PAM o_rf_CURS isc ipac ipnr nt y_sd_t payoff IP - RiskFactors {..} + RiskFactorsPoly {..} ContractTerms { ct_DCC = Just dayCountConvention, ct_MD = md diff --git a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/POF/PayoffFs.hs b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/POF/PayoffFs.hs index b84d4c44898..d8a1cf1be2c 100644 --- a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/POF/PayoffFs.hs +++ b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/POF/PayoffFs.hs @@ -4,17 +4,18 @@ module Language.Marlowe.ACTUS.Model.POF.PayoffFs where import Data.Time (Day) import Language.Marlowe (Observation, Value) -import Language.Marlowe.ACTUS.Definitions.BusinessEvents (EventType (..)) +import Language.Marlowe.ACTUS.Definitions.BusinessEvents (EventType (..), RiskFactorsPoly (..)) import Language.Marlowe.ACTUS.Definitions.ContractTerms (CT (..), ContractTerms (..)) -import Language.Marlowe.ACTUS.MarloweCompat (constnt, enum, useval) +import Language.Marlowe.ACTUS.MarloweCompat (RiskFactorsMarlowe, constnt, enum, useval) import Language.Marlowe.ACTUS.Model.POF.PayoffModel import Language.Marlowe.ACTUS.Ops (ActusNum (..), YearFractionOps (_y), marloweFixedPoint) import Prelude hiding (Fractional, Num, (*), (+), (-), (/)) -payoffFs :: EventType -> ContractTerms -> Integer -> Integer -> Day -> Day -> Maybe (Value Observation) +payoffFs :: EventType -> RiskFactorsMarlowe -> ContractTerms -> Integer -> Day -> Day -> Maybe (Value Observation) payoffFs ev + RiskFactorsPoly {..} ContractTerms { ct_NT = Just np, ct_PDIED = Just pdied, @@ -28,7 +29,6 @@ payoffFs ct_cPYRT = cpyrt, .. } - t t_minus prevDate curDate = @@ -87,9 +87,6 @@ payoffFs priceAtTerminationDate = constnt ptd penaltyRate = constnt pyrt cPenaltyRate = constnt cpyrt - o_rf_CURS = useval "o_rf_CURS" t - o_rf_RRMO = useval "o_rf_RRMO" t - pp_payoff = useval "pp_payoff" t nsc = useval "nsc" t_minus nt = useval "nt" t_minus isc = useval "isc" t_minus diff --git a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/STF/StateTransition.hs b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/STF/StateTransition.hs index d12b5048c8a..3d58007a5b9 100644 --- a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/STF/StateTransition.hs +++ b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/STF/StateTransition.hs @@ -4,7 +4,8 @@ module Language.Marlowe.ACTUS.Model.STF.StateTransition where import Data.Maybe (maybeToList) import Data.Time (Day) -import Language.Marlowe.ACTUS.Definitions.BusinessEvents (EventType (..), RiskFactors (..)) +import Language.Marlowe.ACTUS.Definitions.BusinessEvents (EventType (..), RiskFactors, + RiskFactorsPoly (..)) import Language.Marlowe.ACTUS.Definitions.ContractState (ContractState, ContractStatePoly (..)) import Language.Marlowe.ACTUS.Definitions.ContractTerms (CT (..), ContractTerms (..)) import Language.Marlowe.ACTUS.Definitions.Schedule (ShiftedDay (calculationDay)) @@ -16,7 +17,7 @@ import Language.Marlowe.ACTUS.Ops (YearFra stateTransition :: EventType -> RiskFactors -> ContractTerms -> ContractState -> Day -> ContractState stateTransition ev - RiskFactors {..} + RiskFactorsPoly {..} ct@ContractTerms { ct_DCC = Just dayCountConvention, ct_FER = Just feeRate, diff --git a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/STF/StateTransitionFs.hs b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/STF/StateTransitionFs.hs index 99e73a715cd..245cbdc1460 100644 --- a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/STF/StateTransitionFs.hs +++ b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/STF/StateTransitionFs.hs @@ -4,7 +4,6 @@ module Language.Marlowe.ACTUS.Model.STF.StateTransitionFs (stateTransitionFs) wh import Data.Maybe (maybeToList) import Data.Time (Day) -import Language.Marlowe.ACTUS.Definitions.BusinessEvents (EventType (..)) import Language.Marlowe.ACTUS.Definitions.ContractTerms (CT (..), ContractTerms (..)) import Language.Marlowe.ACTUS.Definitions.Schedule (ShiftedDay (calculationDay)) import Language.Marlowe.ACTUS.Model.SCHED.ContractSchedule (maturity, schedule) @@ -13,12 +12,15 @@ import Language.Marlowe.ACTUS.Model.Utility.ScheduleGenerator (inf, su import Language.Marlowe.ACTUS.Ops (YearFractionOps (_y)) import Language.Marlowe (Contract) -import Language.Marlowe.ACTUS.MarloweCompat (ContractStateMarlowe, constnt, enum, letval, - marloweDate, stateTransitionMarlowe, useval) +import Language.Marlowe.ACTUS.Definitions.BusinessEvents (EventType (..), RiskFactorsPoly (..)) +import Language.Marlowe.ACTUS.MarloweCompat (ContractStateMarlowe, RiskFactorsMarlowe, + constnt, enum, letval, marloweDate, + stateTransitionMarlowe) -stateTransitionFs :: EventType -> ContractTerms -> Integer -> Day -> Day -> Contract -> Contract +stateTransitionFs :: EventType -> RiskFactorsMarlowe -> ContractTerms -> Integer -> Day -> Day -> Contract -> Contract stateTransitionFs ev + RiskFactorsPoly{..} ct@ContractTerms { ct_NT = Just nt, ct_FER = Just fer, @@ -202,10 +204,6 @@ stateTransitionFs interestCalculationBaseAmont = constnt <$> ct_IPCBA nextRateReset = constnt <$> ct_RRNXT - o_rf_RRMO = useval "o_rf_RRMO" t - o_rf_SCMO = useval "o_rf_SCMO" t - pp_payoff = useval "pp_payoff" t - time = marloweDate curDate fpSchedule = schedule FP ct prSchedule = schedule PR ct @@ -231,4 +229,4 @@ stateTransitionFs RR -> letval ("RR:" ++ show curDate) t (constnt 0) cont FP -> letval ("FP:" ++ show curDate) t (constnt 0) cont _ -> cont -stateTransitionFs _ _ _ _ _ c = c +stateTransitionFs _ _ _ _ _ _ c = c diff --git a/marlowe-actus/test/Spec/Marlowe/Actus.hs b/marlowe-actus/test/Spec/Marlowe/Actus.hs index 99fa0e07ab0..f91144db882 100644 --- a/marlowe-actus/test/Spec/Marlowe/Actus.hs +++ b/marlowe-actus/test/Spec/Marlowe/Actus.hs @@ -12,7 +12,7 @@ import qualified Data.Map as M (lookup) import Data.Maybe (fromMaybe) import GHC.Records (getField) import Language.Marlowe.ACTUS.Analysis (genProjectedCashflows) -import Language.Marlowe.ACTUS.Definitions.BusinessEvents (EventType (..), RiskFactors (..)) +import Language.Marlowe.ACTUS.Definitions.BusinessEvents (EventType (..), RiskFactorsPoly (..)) import Language.Marlowe.ACTUS.Definitions.ContractTerms hiding (Assertion) import Language.Marlowe.ACTUS.Definitions.Schedule import Spec.Marlowe.Util @@ -30,7 +30,7 @@ runTest tc@TestCase {..} = getRiskFactors ev date = let riskFactors = - RiskFactors + RiskFactorsPoly { o_rf_CURS = 1.0, o_rf_RRMO = 1.0, o_rf_SCMO = 1.0, From 5da3743cfc00e394d127e90ab8be8ebb0f0de5f2 Mon Sep 17 00:00:00 2001 From: Yves Hauser Date: Thu, 9 Sep 2021 11:52:51 +0200 Subject: [PATCH 18/28] SCP-2709 - update materialized nix files --- .../materialized-darwin/.plan.nix/marlowe-actus.nix | 10 +--------- .../materialized-linux/.plan.nix/marlowe-actus.nix | 10 +--------- .../materialized-windows/.plan.nix/marlowe-actus.nix | 10 +--------- 3 files changed, 3 insertions(+), 27 deletions(-) diff --git a/nix/pkgs/haskell/materialized-darwin/.plan.nix/marlowe-actus.nix b/nix/pkgs/haskell/materialized-darwin/.plan.nix/marlowe-actus.nix index 319bd38af11..f5bc07306ca 100644 --- a/nix/pkgs/haskell/materialized-darwin/.plan.nix/marlowe-actus.nix +++ b/nix/pkgs/haskell/materialized-darwin/.plan.nix/marlowe-actus.nix @@ -37,7 +37,6 @@ (hsPkgs."base" or (errorHandler.buildDepError "base")) (hsPkgs."bytestring" or (errorHandler.buildDepError "bytestring")) (hsPkgs."containers" or (errorHandler.buildDepError "containers")) - (hsPkgs."mtl" or (errorHandler.buildDepError "mtl")) (hsPkgs."newtype-generics" or (errorHandler.buildDepError "newtype-generics")) (hsPkgs."template-haskell" or (errorHandler.buildDepError "template-haskell")) (hsPkgs."plutus-tx" or (errorHandler.buildDepError "plutus-tx")) @@ -49,14 +48,12 @@ (hsPkgs."time" or (errorHandler.buildDepError "time")) (hsPkgs."sort" or (errorHandler.buildDepError "sort")) (hsPkgs."validation" or (errorHandler.buildDepError "validation")) - (hsPkgs."QuickCheck" or (errorHandler.buildDepError "QuickCheck")) ]; buildable = true; modules = [ "Language/Marlowe/ACTUS/Ops" "Language/Marlowe/ACTUS/MarloweCompat" "Language/Marlowe/ACTUS/Generator" - "Language/Marlowe/ACTUS/QCGenerator" "Language/Marlowe/ACTUS/Analysis" "Language/Marlowe/ACTUS/Definitions/BusinessEvents" "Language/Marlowe/ACTUS/Definitions/ContractTerms" @@ -71,10 +68,9 @@ "Language/Marlowe/ACTUS/Model/SCHED/ContractScheduleModel" "Language/Marlowe/ACTUS/Model/SCHED/ContractSchedule" "Language/Marlowe/ACTUS/Model/INIT/StateInitializationModel" - "Language/Marlowe/ACTUS/Model/INIT/StateInitialization" - "Language/Marlowe/ACTUS/Model/INIT/StateInitializationFs" "Language/Marlowe/ACTUS/Model/APPLICABILITY/Applicability" "Language/Marlowe/ACTUS/Model/APPLICABILITY/ApplicabilityModel" + "Language/Marlowe/ACTUS/Model/Utility/ANN/Annuity" "Language/Marlowe/ACTUS/Model/Utility/DateShift" "Language/Marlowe/ACTUS/Model/Utility/ScheduleGenerator" "Language/Marlowe/ACTUS/Model/Utility/YearFraction" @@ -128,8 +124,6 @@ "Language/Marlowe/ACTUS/Model/SCHED/ContractScheduleModel" "Language/Marlowe/ACTUS/Model/SCHED/ContractSchedule" "Language/Marlowe/ACTUS/Model/INIT/StateInitializationModel" - "Language/Marlowe/ACTUS/Model/INIT/StateInitialization" - "Language/Marlowe/ACTUS/Model/INIT/StateInitializationFs" "Language/Marlowe/ACTUS/Model/Utility/DateShift" "Language/Marlowe/ACTUS/Model/Utility/ScheduleGenerator" "Language/Marlowe/ACTUS/Model/Utility/YearFraction" @@ -184,8 +178,6 @@ "Language/Marlowe/ACTUS/Model/SCHED/ContractScheduleModel" "Language/Marlowe/ACTUS/Model/SCHED/ContractSchedule" "Language/Marlowe/ACTUS/Model/INIT/StateInitializationModel" - "Language/Marlowe/ACTUS/Model/INIT/StateInitialization" - "Language/Marlowe/ACTUS/Model/INIT/StateInitializationFs" "Language/Marlowe/ACTUS/Model/Utility/DateShift" "Language/Marlowe/ACTUS/Model/Utility/ScheduleGenerator" "Language/Marlowe/ACTUS/Model/Utility/YearFraction" diff --git a/nix/pkgs/haskell/materialized-linux/.plan.nix/marlowe-actus.nix b/nix/pkgs/haskell/materialized-linux/.plan.nix/marlowe-actus.nix index 319bd38af11..f5bc07306ca 100644 --- a/nix/pkgs/haskell/materialized-linux/.plan.nix/marlowe-actus.nix +++ b/nix/pkgs/haskell/materialized-linux/.plan.nix/marlowe-actus.nix @@ -37,7 +37,6 @@ (hsPkgs."base" or (errorHandler.buildDepError "base")) (hsPkgs."bytestring" or (errorHandler.buildDepError "bytestring")) (hsPkgs."containers" or (errorHandler.buildDepError "containers")) - (hsPkgs."mtl" or (errorHandler.buildDepError "mtl")) (hsPkgs."newtype-generics" or (errorHandler.buildDepError "newtype-generics")) (hsPkgs."template-haskell" or (errorHandler.buildDepError "template-haskell")) (hsPkgs."plutus-tx" or (errorHandler.buildDepError "plutus-tx")) @@ -49,14 +48,12 @@ (hsPkgs."time" or (errorHandler.buildDepError "time")) (hsPkgs."sort" or (errorHandler.buildDepError "sort")) (hsPkgs."validation" or (errorHandler.buildDepError "validation")) - (hsPkgs."QuickCheck" or (errorHandler.buildDepError "QuickCheck")) ]; buildable = true; modules = [ "Language/Marlowe/ACTUS/Ops" "Language/Marlowe/ACTUS/MarloweCompat" "Language/Marlowe/ACTUS/Generator" - "Language/Marlowe/ACTUS/QCGenerator" "Language/Marlowe/ACTUS/Analysis" "Language/Marlowe/ACTUS/Definitions/BusinessEvents" "Language/Marlowe/ACTUS/Definitions/ContractTerms" @@ -71,10 +68,9 @@ "Language/Marlowe/ACTUS/Model/SCHED/ContractScheduleModel" "Language/Marlowe/ACTUS/Model/SCHED/ContractSchedule" "Language/Marlowe/ACTUS/Model/INIT/StateInitializationModel" - "Language/Marlowe/ACTUS/Model/INIT/StateInitialization" - "Language/Marlowe/ACTUS/Model/INIT/StateInitializationFs" "Language/Marlowe/ACTUS/Model/APPLICABILITY/Applicability" "Language/Marlowe/ACTUS/Model/APPLICABILITY/ApplicabilityModel" + "Language/Marlowe/ACTUS/Model/Utility/ANN/Annuity" "Language/Marlowe/ACTUS/Model/Utility/DateShift" "Language/Marlowe/ACTUS/Model/Utility/ScheduleGenerator" "Language/Marlowe/ACTUS/Model/Utility/YearFraction" @@ -128,8 +124,6 @@ "Language/Marlowe/ACTUS/Model/SCHED/ContractScheduleModel" "Language/Marlowe/ACTUS/Model/SCHED/ContractSchedule" "Language/Marlowe/ACTUS/Model/INIT/StateInitializationModel" - "Language/Marlowe/ACTUS/Model/INIT/StateInitialization" - "Language/Marlowe/ACTUS/Model/INIT/StateInitializationFs" "Language/Marlowe/ACTUS/Model/Utility/DateShift" "Language/Marlowe/ACTUS/Model/Utility/ScheduleGenerator" "Language/Marlowe/ACTUS/Model/Utility/YearFraction" @@ -184,8 +178,6 @@ "Language/Marlowe/ACTUS/Model/SCHED/ContractScheduleModel" "Language/Marlowe/ACTUS/Model/SCHED/ContractSchedule" "Language/Marlowe/ACTUS/Model/INIT/StateInitializationModel" - "Language/Marlowe/ACTUS/Model/INIT/StateInitialization" - "Language/Marlowe/ACTUS/Model/INIT/StateInitializationFs" "Language/Marlowe/ACTUS/Model/Utility/DateShift" "Language/Marlowe/ACTUS/Model/Utility/ScheduleGenerator" "Language/Marlowe/ACTUS/Model/Utility/YearFraction" diff --git a/nix/pkgs/haskell/materialized-windows/.plan.nix/marlowe-actus.nix b/nix/pkgs/haskell/materialized-windows/.plan.nix/marlowe-actus.nix index 319bd38af11..f5bc07306ca 100644 --- a/nix/pkgs/haskell/materialized-windows/.plan.nix/marlowe-actus.nix +++ b/nix/pkgs/haskell/materialized-windows/.plan.nix/marlowe-actus.nix @@ -37,7 +37,6 @@ (hsPkgs."base" or (errorHandler.buildDepError "base")) (hsPkgs."bytestring" or (errorHandler.buildDepError "bytestring")) (hsPkgs."containers" or (errorHandler.buildDepError "containers")) - (hsPkgs."mtl" or (errorHandler.buildDepError "mtl")) (hsPkgs."newtype-generics" or (errorHandler.buildDepError "newtype-generics")) (hsPkgs."template-haskell" or (errorHandler.buildDepError "template-haskell")) (hsPkgs."plutus-tx" or (errorHandler.buildDepError "plutus-tx")) @@ -49,14 +48,12 @@ (hsPkgs."time" or (errorHandler.buildDepError "time")) (hsPkgs."sort" or (errorHandler.buildDepError "sort")) (hsPkgs."validation" or (errorHandler.buildDepError "validation")) - (hsPkgs."QuickCheck" or (errorHandler.buildDepError "QuickCheck")) ]; buildable = true; modules = [ "Language/Marlowe/ACTUS/Ops" "Language/Marlowe/ACTUS/MarloweCompat" "Language/Marlowe/ACTUS/Generator" - "Language/Marlowe/ACTUS/QCGenerator" "Language/Marlowe/ACTUS/Analysis" "Language/Marlowe/ACTUS/Definitions/BusinessEvents" "Language/Marlowe/ACTUS/Definitions/ContractTerms" @@ -71,10 +68,9 @@ "Language/Marlowe/ACTUS/Model/SCHED/ContractScheduleModel" "Language/Marlowe/ACTUS/Model/SCHED/ContractSchedule" "Language/Marlowe/ACTUS/Model/INIT/StateInitializationModel" - "Language/Marlowe/ACTUS/Model/INIT/StateInitialization" - "Language/Marlowe/ACTUS/Model/INIT/StateInitializationFs" "Language/Marlowe/ACTUS/Model/APPLICABILITY/Applicability" "Language/Marlowe/ACTUS/Model/APPLICABILITY/ApplicabilityModel" + "Language/Marlowe/ACTUS/Model/Utility/ANN/Annuity" "Language/Marlowe/ACTUS/Model/Utility/DateShift" "Language/Marlowe/ACTUS/Model/Utility/ScheduleGenerator" "Language/Marlowe/ACTUS/Model/Utility/YearFraction" @@ -128,8 +124,6 @@ "Language/Marlowe/ACTUS/Model/SCHED/ContractScheduleModel" "Language/Marlowe/ACTUS/Model/SCHED/ContractSchedule" "Language/Marlowe/ACTUS/Model/INIT/StateInitializationModel" - "Language/Marlowe/ACTUS/Model/INIT/StateInitialization" - "Language/Marlowe/ACTUS/Model/INIT/StateInitializationFs" "Language/Marlowe/ACTUS/Model/Utility/DateShift" "Language/Marlowe/ACTUS/Model/Utility/ScheduleGenerator" "Language/Marlowe/ACTUS/Model/Utility/YearFraction" @@ -184,8 +178,6 @@ "Language/Marlowe/ACTUS/Model/SCHED/ContractScheduleModel" "Language/Marlowe/ACTUS/Model/SCHED/ContractSchedule" "Language/Marlowe/ACTUS/Model/INIT/StateInitializationModel" - "Language/Marlowe/ACTUS/Model/INIT/StateInitialization" - "Language/Marlowe/ACTUS/Model/INIT/StateInitializationFs" "Language/Marlowe/ACTUS/Model/Utility/DateShift" "Language/Marlowe/ACTUS/Model/Utility/ScheduleGenerator" "Language/Marlowe/ACTUS/Model/Utility/YearFraction" From 376b505b88a824076c50f8404d28e657b04f1e24 Mon Sep 17 00:00:00 2001 From: Yves Hauser Date: Thu, 9 Sep 2021 12:11:04 +0200 Subject: [PATCH 19/28] scp-2708 - commented NAM and ANN test cases - pull request still open https://github.com/actusfrf/actus-tests/pull/1 --- marlowe-actus/test/Spec.hs | 18 ++++++++++-------- 1 file changed, 10 insertions(+), 8 deletions(-) diff --git a/marlowe-actus/test/Spec.hs b/marlowe-actus/test/Spec.hs index 5f304a6e93b..9604009a534 100644 --- a/marlowe-actus/test/Spec.hs +++ b/marlowe-actus/test/Spec.hs @@ -16,19 +16,21 @@ main = do pamTests <- testCasesFromFile ["pam25"] $ p ++ "actus-tests-pam.json" -- pam25: dates include hours, minutes, second lamTests <- testCasesFromFile ["lam18"] $ p ++ "actus-tests-lam.json" -- lam18: dates include hours, minutes, second - namTests <- testCasesFromFile [] $ p ++ "actus-tests-nam.json" - annTests <- testCasesFromFile [ - "ann09" -- ann09: currently unsupported, see also actus-core AnnuityTest.java - , "ann19" -- ann19: dates include hours, minutes, second - , "ann26" -- ann26: dates include hours, minutes, second - ] $ p ++ "actus-tests-ann.json" +-- NAM, ANN temporarily commented - waiting for +-- https://github.com/actusfrf/actus-tests/pull/1 + -- namTests <- testCasesFromFile [] $ p ++ "actus-tests-nam.json" + -- annTests <- testCasesFromFile [ + -- "ann09" -- ann09: currently unsupported, see also actus-core AnnuityTest.java + -- , "ann19" -- ann19: dates include hours, minutes, second + -- , "ann26" -- ann26: dates include hours, minutes, second + -- ] $ p ++ "actus-tests-ann.json" defaultMain $ testGroup "ACTUS Contracts" [ Spec.Marlowe.Actus.tests "PAM" pamTests , Spec.Marlowe.Actus.tests "LAM" lamTests - , Spec.Marlowe.Actus.tests "NAM" namTests - , Spec.Marlowe.Actus.tests "ANN" annTests +-- , Spec.Marlowe.Actus.tests "NAM" namTests +-- , Spec.Marlowe.Actus.tests "ANN" annTests ] testCasesFromFile :: [String] -> FilePath -> IO [TestCase] From ee755a586e53e0afdc36733e9ad31bbffb35959c Mon Sep 17 00:00:00 2001 From: Yves Hauser Date: Thu, 9 Sep 2021 12:25:47 +0200 Subject: [PATCH 20/28] SCP-2709 - haddock parsing error --- marlowe-actus/src/Language/Marlowe/ACTUS/Analysis.hs | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/marlowe-actus/src/Language/Marlowe/ACTUS/Analysis.hs b/marlowe-actus/src/Language/Marlowe/ACTUS/Analysis.hs index a85a5106dce..4714500f0c1 100644 --- a/marlowe-actus/src/Language/Marlowe/ACTUS/Analysis.hs +++ b/marlowe-actus/src/Language/Marlowe/ACTUS/Analysis.hs @@ -1,8 +1,5 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TupleSections #-} -module Language.Marlowe.ACTUS.Analysis - ( genProjectedCashflows ) -where {-| = ACTUS Analysis @@ -10,6 +7,10 @@ Given an ACTUS contract cashflows can be projected. -} +module Language.Marlowe.ACTUS.Analysis + ( genProjectedCashflows ) +where + import Control.Applicative ((<|>)) import qualified Data.List as L (groupBy) import Data.Maybe (fromMaybe, isNothing) From eb258bbe1c8b8473f6615b67c78740f67cc13a92 Mon Sep 17 00:00:00 2001 From: Yves Hauser Date: Thu, 9 Sep 2021 13:06:25 +0200 Subject: [PATCH 21/28] SCP-2709 - adjusted testkit --- marlowe-actus/marlowe-actus.cabal | 2 ++ .../testkit/Language/Marlowe/ACTUS/QCGenerator.hs | 15 +++++++++++---- 2 files changed, 13 insertions(+), 4 deletions(-) diff --git a/marlowe-actus/marlowe-actus.cabal b/marlowe-actus/marlowe-actus.cabal index 0f4e5a27491..8e3e9c17ef6 100644 --- a/marlowe-actus/marlowe-actus.cabal +++ b/marlowe-actus/marlowe-actus.cabal @@ -101,6 +101,7 @@ executable marlowe-shiny Language.Marlowe.ACTUS.Model.SCHED.ContractScheduleModel Language.Marlowe.ACTUS.Model.SCHED.ContractSchedule Language.Marlowe.ACTUS.Model.INIT.StateInitializationModel + Language.Marlowe.ACTUS.Model.Utility.ANN.Annuity Language.Marlowe.ACTUS.Model.Utility.DateShift Language.Marlowe.ACTUS.Model.Utility.ScheduleGenerator Language.Marlowe.ACTUS.Model.Utility.YearFraction @@ -156,6 +157,7 @@ executable marlowe-actus-test-kit Language.Marlowe.ACTUS.Model.SCHED.ContractScheduleModel Language.Marlowe.ACTUS.Model.SCHED.ContractSchedule Language.Marlowe.ACTUS.Model.INIT.StateInitializationModel + Language.Marlowe.ACTUS.Model.Utility.ANN.Annuity Language.Marlowe.ACTUS.Model.Utility.DateShift Language.Marlowe.ACTUS.Model.Utility.ScheduleGenerator Language.Marlowe.ACTUS.Model.Utility.YearFraction diff --git a/marlowe-actus/testkit/Language/Marlowe/ACTUS/QCGenerator.hs b/marlowe-actus/testkit/Language/Marlowe/ACTUS/QCGenerator.hs index da4c22c5f5f..9c6be98e0b9 100644 --- a/marlowe-actus/testkit/Language/Marlowe/ACTUS/QCGenerator.hs +++ b/marlowe-actus/testkit/Language/Marlowe/ACTUS/QCGenerator.hs @@ -9,7 +9,7 @@ import qualified Data.Map as M import Data.Time import Data.Time.Clock.POSIX (posixSecondsToUTCTime) import Language.Marlowe.ACTUS.Analysis (genProjectedCashflows) -import Language.Marlowe.ACTUS.Definitions.BusinessEvents (RiskFactors (..)) +import Language.Marlowe.ACTUS.Definitions.BusinessEvents import Language.Marlowe.ACTUS.Definitions.ContractTerms import Language.Marlowe.ACTUS.Definitions.Schedule import Test.QuickCheck @@ -211,11 +211,18 @@ contractTermsGen = do riskAtTGen :: Gen RiskFactors -riskAtTGen = RiskFactors <$> percentage <*> percentage <*> percentage <*> smallamount +riskAtTGen = RiskFactorsPoly <$> percentage <*> percentage <*> percentage <*> smallamount riskFactorsGen :: ContractTerms -> Gen (M.Map Day RiskFactors) riskFactorsGen ct = do - let days = cashCalculationDay <$> genProjectedCashflows M.empty ct + let riskFactors _ _ = + RiskFactorsPoly + { o_rf_CURS = 1.0, + o_rf_RRMO = 1.0, + o_rf_SCMO = 1.0, + pp_payoff = 0.0 + } + let days = cashCalculationDay <$> genProjectedCashflows riskFactors ct rf <- vectorOf (L.length days) riskAtTGen return $ M.fromList $ L.zip days rf @@ -229,6 +236,6 @@ riskFactorsGenRandomWalkGen contractTerms = do fluctuate state fluctiation = state + (fluctiation - 50) / 100 walk rf st = let fluctuate' extractor = fluctuate (extractor rf) (extractor st) - in RiskFactors (fluctuate' o_rf_CURS) (fluctuate' o_rf_RRMO) (fluctuate' o_rf_SCMO) (fluctuate' pp_payoff) + in RiskFactorsPoly (fluctuate' o_rf_CURS) (fluctuate' o_rf_RRMO) (fluctuate' o_rf_SCMO) (fluctuate' pp_payoff) path = L.scanl walk riskAtT riskFactorsValues return $ M.fromList $ L.zip riskFactorsDates path From e15ece71e442de3b990bca6761d8b47b2464fb85 Mon Sep 17 00:00:00 2001 From: Yves Hauser Date: Thu, 9 Sep 2021 13:56:55 +0200 Subject: [PATCH 22/28] SCP-2708 - update materialized nix files --- .../haskell/materialized-darwin/.plan.nix/marlowe-actus.nix | 2 ++ nix/pkgs/haskell/materialized-linux/.plan.nix/marlowe-actus.nix | 2 ++ .../haskell/materialized-windows/.plan.nix/marlowe-actus.nix | 2 ++ 3 files changed, 6 insertions(+) diff --git a/nix/pkgs/haskell/materialized-darwin/.plan.nix/marlowe-actus.nix b/nix/pkgs/haskell/materialized-darwin/.plan.nix/marlowe-actus.nix index f5bc07306ca..25af017b3d9 100644 --- a/nix/pkgs/haskell/materialized-darwin/.plan.nix/marlowe-actus.nix +++ b/nix/pkgs/haskell/materialized-darwin/.plan.nix/marlowe-actus.nix @@ -124,6 +124,7 @@ "Language/Marlowe/ACTUS/Model/SCHED/ContractScheduleModel" "Language/Marlowe/ACTUS/Model/SCHED/ContractSchedule" "Language/Marlowe/ACTUS/Model/INIT/StateInitializationModel" + "Language/Marlowe/ACTUS/Model/Utility/ANN/Annuity" "Language/Marlowe/ACTUS/Model/Utility/DateShift" "Language/Marlowe/ACTUS/Model/Utility/ScheduleGenerator" "Language/Marlowe/ACTUS/Model/Utility/YearFraction" @@ -178,6 +179,7 @@ "Language/Marlowe/ACTUS/Model/SCHED/ContractScheduleModel" "Language/Marlowe/ACTUS/Model/SCHED/ContractSchedule" "Language/Marlowe/ACTUS/Model/INIT/StateInitializationModel" + "Language/Marlowe/ACTUS/Model/Utility/ANN/Annuity" "Language/Marlowe/ACTUS/Model/Utility/DateShift" "Language/Marlowe/ACTUS/Model/Utility/ScheduleGenerator" "Language/Marlowe/ACTUS/Model/Utility/YearFraction" diff --git a/nix/pkgs/haskell/materialized-linux/.plan.nix/marlowe-actus.nix b/nix/pkgs/haskell/materialized-linux/.plan.nix/marlowe-actus.nix index f5bc07306ca..25af017b3d9 100644 --- a/nix/pkgs/haskell/materialized-linux/.plan.nix/marlowe-actus.nix +++ b/nix/pkgs/haskell/materialized-linux/.plan.nix/marlowe-actus.nix @@ -124,6 +124,7 @@ "Language/Marlowe/ACTUS/Model/SCHED/ContractScheduleModel" "Language/Marlowe/ACTUS/Model/SCHED/ContractSchedule" "Language/Marlowe/ACTUS/Model/INIT/StateInitializationModel" + "Language/Marlowe/ACTUS/Model/Utility/ANN/Annuity" "Language/Marlowe/ACTUS/Model/Utility/DateShift" "Language/Marlowe/ACTUS/Model/Utility/ScheduleGenerator" "Language/Marlowe/ACTUS/Model/Utility/YearFraction" @@ -178,6 +179,7 @@ "Language/Marlowe/ACTUS/Model/SCHED/ContractScheduleModel" "Language/Marlowe/ACTUS/Model/SCHED/ContractSchedule" "Language/Marlowe/ACTUS/Model/INIT/StateInitializationModel" + "Language/Marlowe/ACTUS/Model/Utility/ANN/Annuity" "Language/Marlowe/ACTUS/Model/Utility/DateShift" "Language/Marlowe/ACTUS/Model/Utility/ScheduleGenerator" "Language/Marlowe/ACTUS/Model/Utility/YearFraction" diff --git a/nix/pkgs/haskell/materialized-windows/.plan.nix/marlowe-actus.nix b/nix/pkgs/haskell/materialized-windows/.plan.nix/marlowe-actus.nix index f5bc07306ca..25af017b3d9 100644 --- a/nix/pkgs/haskell/materialized-windows/.plan.nix/marlowe-actus.nix +++ b/nix/pkgs/haskell/materialized-windows/.plan.nix/marlowe-actus.nix @@ -124,6 +124,7 @@ "Language/Marlowe/ACTUS/Model/SCHED/ContractScheduleModel" "Language/Marlowe/ACTUS/Model/SCHED/ContractSchedule" "Language/Marlowe/ACTUS/Model/INIT/StateInitializationModel" + "Language/Marlowe/ACTUS/Model/Utility/ANN/Annuity" "Language/Marlowe/ACTUS/Model/Utility/DateShift" "Language/Marlowe/ACTUS/Model/Utility/ScheduleGenerator" "Language/Marlowe/ACTUS/Model/Utility/YearFraction" @@ -178,6 +179,7 @@ "Language/Marlowe/ACTUS/Model/SCHED/ContractScheduleModel" "Language/Marlowe/ACTUS/Model/SCHED/ContractSchedule" "Language/Marlowe/ACTUS/Model/INIT/StateInitializationModel" + "Language/Marlowe/ACTUS/Model/Utility/ANN/Annuity" "Language/Marlowe/ACTUS/Model/Utility/DateShift" "Language/Marlowe/ACTUS/Model/Utility/ScheduleGenerator" "Language/Marlowe/ACTUS/Model/Utility/YearFraction" From 0099748e5655ac7834584d85df26e7b2d27fe00a Mon Sep 17 00:00:00 2001 From: Yves Hauser Date: Thu, 9 Sep 2021 14:51:19 +0200 Subject: [PATCH 23/28] SCP-2708 - adjusted shiny app --- marlowe-actus/app/Main.hs | 39 ++++++++++++++++++++++++--------------- 1 file changed, 24 insertions(+), 15 deletions(-) diff --git a/marlowe-actus/app/Main.hs b/marlowe-actus/app/Main.hs index 890e42fd6e0..d2aaf64b686 100644 --- a/marlowe-actus/app/Main.hs +++ b/marlowe-actus/app/Main.hs @@ -4,30 +4,39 @@ module Main where -import Data.Aeson (decode) -import Data.Int (Int32) -import Data.Map as M (empty) -import Data.String (IsString (fromString)) -import Data.Time.Calendar (showGregorian) -import Language.Marlowe.ACTUS.Analysis (sampleCashflows) -import Language.Marlowe.ACTUS.Definitions.Schedule (CashFlow (..)) -import Language.R (R) -import qualified Language.R as R +import Data.Aeson (decode) +import Data.Int (Int32) +import Data.String (IsString (fromString)) +import Data.Time (Day) +import Data.Time.Calendar (showGregorian) +import Language.Marlowe.ACTUS.Analysis (genProjectedCashflows) +import Language.Marlowe.ACTUS.Definitions.BusinessEvents +import Language.Marlowe.ACTUS.Definitions.Schedule (CashFlow (..)) +import Language.R (R) +import qualified Language.R as R import Language.R.QQ +riskFactors :: EventType -> Day -> RiskFactors +riskFactors _ _ = + RiskFactorsPoly + { o_rf_CURS = 1.0, + o_rf_RRMO = 1.0, + o_rf_SCMO = 1.0, + pp_payoff = 0.0 + } + get_dates :: String -> R s [String] get_dates terms = return $ case (decode $ fromString terms) of - Just terms' -> - let - cfs = sampleCashflows M.empty terms' - date = showGregorian <$> cashCalculationDay <$> cfs - event = show <$> cashEvent <$> cfs + Just terms' -> let + cfs = genProjectedCashflows riskFactors terms' + date = showGregorian <$> cashCalculationDay <$> cfs + event = show <$> cashEvent <$> cfs in (\(d, e) -> d ++ " " ++ e) <$> (zip date event) Nothing -> [] get_cfs :: String -> R s [Double] get_cfs terms = return $ case (decode $ fromString terms) of - Just terms' -> amount <$> sampleCashflows M.empty terms' + Just terms' -> amount <$> genProjectedCashflows riskFactors terms' Nothing -> [] r_shiny :: R s Int32 From c4f39601ac5f573a6cab5b8bd217b3f66f9e9bee Mon Sep 17 00:00:00 2001 From: Yves Hauser Date: Thu, 9 Sep 2021 15:45:00 +0200 Subject: [PATCH 24/28] SCP-2708 - ANN contract type in blocky --- .../src/Marlowe/ActusBlockly.purs | 30 +++++++++++++++++++ 1 file changed, 30 insertions(+) diff --git a/marlowe-playground-client/src/Marlowe/ActusBlockly.purs b/marlowe-playground-client/src/Marlowe/ActusBlockly.purs index d7375493c5f..7f895ba19d7 100644 --- a/marlowe-playground-client/src/Marlowe/ActusBlockly.purs +++ b/marlowe-playground-client/src/Marlowe/ActusBlockly.purs @@ -554,6 +554,7 @@ newtype ActusContract , startDate :: ActusValue , initialExchangeDate :: ActusValue , maturityDate :: ActusValue + , amortizationDate :: ActusValue , terminationDate :: ActusValue , terminationPrice :: ActusValue , periodicPaymentAmount :: ActusValue @@ -636,6 +637,7 @@ parseActusContractType b = case getType b of "PaymentAtMaturity" -> PAM "LinearAmortizer" -> LAM "NegativeAmortizer" -> NAM + "Annuity" -> ANN _ -> PAM parseActusJsonCode :: String -> Either String ContractTerms @@ -726,6 +728,33 @@ instance hasBlockDefinitionActusContract :: HasBlockDefinition ActusContractType -- Any collateral-related code is commented out, until implemented properly -- , collateral: parseFieldActusValueJson g block "collateral" } + ANN -> + Either.Right + $ ActusContract + { contractType: parseActusContractType block + , startDate: parseFieldActusValueJson g block "start_date" + , initialExchangeDate: parseFieldActusValueJson g block "initial_exchange_date" + , maturityDate: parseFieldActusValueJson g block "maturity_date" + , amortizationDate: parseFieldActusValueJson g block "amortization_date" + , terminationDate: parseFieldActusValueJson g block "termination_date" + , terminationPrice: parseFieldActusValueJson g block "termination_price" + , periodicPaymentAmount: parseFieldActusValueJson g block "periodic_payment_amount" + , purchaseDate: parseFieldActusValueJson g block "purchase_date" + , purchasePrice: parseFieldActusValueJson g block "purchase_price" + , dayCountConvention: parseFieldActusValueJson g block "day_count_convention" + , endOfMonthConvention: parseFieldActusValueJson g block "end_of_month_convention" + , rateReset: parseFieldActusValueJson g block "rate_reset_cycle" + , notional: parseFieldActusValueJson g block "notional" + , premiumDiscount: parseFieldActusValueJson g block "premium_discount" + , interestRate: parseFieldActusValueJson g block "interest_rate" + , interestRateCycle: parseFieldActusValueJson g block "interest_rate_cycle" + , principalRedemptionCycle: parseFieldActusValueJson g block "principal_redemption_cycle" + , interestCalculationBaseCycle: parseFieldActusValueJson g block "interest_calculation_base_cycle" + , assertionCtx: parseFieldActusValueJson g block "interest_rate_ctr" + , assertion: parseFieldActusValueJson g block "payoff_ctr" + -- Any collateral-related code is commented out, until implemented properly + -- , collateral: parseFieldActusValueJson g block "collateral" + } instance hasBlockDefinitionValue :: HasBlockDefinition ActusValueType ActusValue where blockDefinition ActusDate g block = do @@ -920,6 +949,7 @@ actusContractToTerms raw = do , ct_IED: Just initialExchangeDate , ct_SD: startDate , ct_MD: maturityDate + , ct_AD: amortizationDate , ct_TD: terminationDate , ct_PRNXT: periodicPaymentAmount , ct_PRD: purchaseDate From 05706bd3a60fa5a3e9d04fceb34bc53fb3f647b7 Mon Sep 17 00:00:00 2001 From: Yves Hauser Date: Thu, 9 Sep 2021 16:18:46 +0200 Subject: [PATCH 25/28] SCP-2708 - amortization date --- marlowe-playground-client/src/Marlowe/ActusBlockly.purs | 1 + 1 file changed, 1 insertion(+) diff --git a/marlowe-playground-client/src/Marlowe/ActusBlockly.purs b/marlowe-playground-client/src/Marlowe/ActusBlockly.purs index 7f895ba19d7..d087bd440f7 100644 --- a/marlowe-playground-client/src/Marlowe/ActusBlockly.purs +++ b/marlowe-playground-client/src/Marlowe/ActusBlockly.purs @@ -902,6 +902,7 @@ actusContractToTerms raw = do contractType <- Either.Right c.contractType startDate <- Either.note "start date is a mandatory field!" <$> actusDateToDay c.startDate >>= identity maturityDate <- actusDateToDay c.maturityDate + amortizationDate <- actusDateToDay c.amortizationDate initialExchangeDate <- fromMaybe startDate <$> actusDateToDay c.initialExchangeDate terminationDate <- actusDateToDay c.terminationDate terminationPrice <- actusDecimalToNumber c.terminationPrice From 99ca436a7ca640b7357e782e35b60fe10c3773d1 Mon Sep 17 00:00:00 2001 From: Yves Hauser Date: Thu, 9 Sep 2021 17:07:49 +0200 Subject: [PATCH 26/28] SCP-2708 - amortization date --- marlowe-playground-client/src/Marlowe/ActusBlockly.purs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/marlowe-playground-client/src/Marlowe/ActusBlockly.purs b/marlowe-playground-client/src/Marlowe/ActusBlockly.purs index d087bd440f7..a032011d84e 100644 --- a/marlowe-playground-client/src/Marlowe/ActusBlockly.purs +++ b/marlowe-playground-client/src/Marlowe/ActusBlockly.purs @@ -657,6 +657,7 @@ instance hasBlockDefinitionActusContract :: HasBlockDefinition ActusContractType , startDate: parseFieldActusValueJson g block "start_date" , initialExchangeDate: parseFieldActusValueJson g block "initial_exchange_date" , maturityDate: parseFieldActusValueJson g block "maturity_date" + , amortizationDate: parseFieldActusValueJson g block "amortization_date" , terminationDate: parseFieldActusValueJson g block "termination_date" , terminationPrice: parseFieldActusValueJson g block "termination_price" , periodicPaymentAmount: NoActusValue @@ -683,6 +684,7 @@ instance hasBlockDefinitionActusContract :: HasBlockDefinition ActusContractType , startDate: parseFieldActusValueJson g block "start_date" , initialExchangeDate: parseFieldActusValueJson g block "initial_exchange_date" , maturityDate: parseFieldActusValueJson g block "maturity_date" + , amortizationDate: parseFieldActusValueJson g block "amortization_date" , terminationDate: parseFieldActusValueJson g block "termination_date" , terminationPrice: parseFieldActusValueJson g block "termination_price" , periodicPaymentAmount: parseFieldActusValueJson g block "periodic_payment_amount" @@ -709,6 +711,7 @@ instance hasBlockDefinitionActusContract :: HasBlockDefinition ActusContractType , startDate: parseFieldActusValueJson g block "start_date" , initialExchangeDate: parseFieldActusValueJson g block "initial_exchange_date" , maturityDate: parseFieldActusValueJson g block "maturity_date" + , amortizationDate: parseFieldActusValueJson g block "amortization_date" , terminationDate: parseFieldActusValueJson g block "termination_date" , terminationPrice: parseFieldActusValueJson g block "termination_price" , periodicPaymentAmount: parseFieldActusValueJson g block "periodic_payment_amount" From 377e5efb6354ce15af924073c10aba30b9086399 Mon Sep 17 00:00:00 2001 From: Yves Hauser Date: Thu, 9 Sep 2021 17:56:04 +0200 Subject: [PATCH 27/28] Update marlowe-actus/README.md Co-authored-by: Pablo Lamela --- marlowe-actus/README.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/marlowe-actus/README.md b/marlowe-actus/README.md index 3f49ca64932..cf02dfde677 100644 --- a/marlowe-actus/README.md +++ b/marlowe-actus/README.md @@ -24,7 +24,7 @@ Regular principal repayments over time, the interest payments decrease linearly. ##### Negative Amortizer (NAM) -Negative amortization means that the payments per period are smaller the interest, i.e. the balance of the loan increases over time. +Negative amortization means that the payments per period are smaller than the interest, i.e. the balance of the loan increases over time. ##### Annuity (ANN) From f555d03de8994e27a29b3183731e870bdc92e78c Mon Sep 17 00:00:00 2001 From: Yves Hauser Date: Thu, 9 Sep 2021 17:56:46 +0200 Subject: [PATCH 28/28] Update marlowe-actus/src/Language/Marlowe/ACTUS/Model/SCHED/ContractSchedule.hs Co-authored-by: Pablo Lamela --- .../src/Language/Marlowe/ACTUS/Model/SCHED/ContractSchedule.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/SCHED/ContractSchedule.hs b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/SCHED/ContractSchedule.hs index d0b6cf77237..587f072df7d 100644 --- a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/SCHED/ContractSchedule.hs +++ b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/SCHED/ContractSchedule.hs @@ -29,7 +29,7 @@ import Language.Marlowe.ACTUS.Model.Utility.YearFraction (yearF import Language.Marlowe.ACTUS.Ops (YearFractionOps (_y)) schedule :: EventType -> ContractTerms -> Maybe [ShiftedDay] -schedule ev c = let m = maturity c in schedule' ev c { ct_MD = m } +schedule ev c = schedule' ev c { ct_MD = maturity c } where schedule' :: EventType -> ContractTerms -> Maybe [ShiftedDay]