diff --git a/marlowe-actus/src/Language/Marlowe/ACTUS/MarloweCompat.hs b/marlowe-actus/src/Language/Marlowe/ACTUS/MarloweCompat.hs index 61b357eb8c6..b20feecdb68 100644 --- a/marlowe-actus/src/Language/Marlowe/ACTUS/MarloweCompat.hs +++ b/marlowe-actus/src/Language/Marlowe/ACTUS/MarloweCompat.hs @@ -10,7 +10,7 @@ import Language.Marlowe (Contract (Le import Data.String (IsString (fromString)) import Data.Time (Day, UTCTime (UTCTime)) -import Data.Time.Clock.System (SystemTime (MkSystemTime), utcToSystemTime) +import Data.Time.Clock.System (SystemTime (MkSystemTime), utcToSystemTime, systemToUTCTime) import Language.Marlowe.ACTUS.Definitions.BusinessEvents (EventType) import Language.Marlowe.ACTUS.Definitions.ContractState (ContractState, ContractStatePoly (..)) import Language.Marlowe.ACTUS.Ops (marloweFixedPoint) @@ -92,7 +92,19 @@ cardanoEpochStart = 100 dayToSlotNumber :: Day -> Integer dayToSlotNumber d = let (MkSystemTime secs _) = utcToSystemTime (UTCTime d 0) - in fromIntegral secs - cardanoEpochStart `mod` 20 + in (fromIntegral secs - cardanoEpochStart) `mod` 20 + +slotNumberToDay :: Integer -> Day +slotNumberToDay slot = + let + secs = cardanoEpochStart + slot * 20 + (UTCTime d _) = systemToUTCTime (MkSystemTime (fromIntegral secs) 0) + in d + marloweDate :: Day -> Value Observation marloweDate = Constant . fromInteger . dayToSlotNumber + +backFromMarloweDate :: Value Observation -> Day +backFromMarloweDate (Constant x) = slotNumberToDay x +backFromMarloweDate _ = slotNumberToDay 0 \ No newline at end of file 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 d1ee0df9b8e..fad0d47726f 100644 --- a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/STF/StateTransitionFs.hs +++ b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/STF/StateTransitionFs.hs @@ -9,6 +9,7 @@ import Language.Marlowe.ACTUS.Definitions.BusinessEvents (EventTy import Data.Maybe (fromJust, fromMaybe) import Language.Marlowe.ACTUS.Definitions.ContractTerms (ContractTerms (..), ContractType (LAM, PAM), ) +import Language.Marlowe.ACTUS.Definitions.ContractState (ContractStatePoly(sd)) import Language.Marlowe.ACTUS.Definitions.Schedule (ShiftedDay (calculationDay)) import Language.Marlowe.ACTUS.Model.SCHED.ContractSchedule (schedule) import Language.Marlowe.ACTUS.Model.STF.StateTransitionModel (_STF_AD_PAM, _STF_CE_PAM, _STF_FP_PAM, @@ -20,7 +21,7 @@ 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 (constnt, enum, marloweDate, +import Language.Marlowe.ACTUS.MarloweCompat (constnt, enum, marloweDate, backFromMarloweDate, stateTransitionMarlowe, useval) @@ -53,28 +54,29 @@ stateTransitionFs ev terms@ContractTerms{..} t curDate continue = fpSchedule = schedule FP terms tfp_minus = fromMaybe curDate $ calculationDay <$> ((\sc -> sup sc curDate) =<< fpSchedule) tfp_plus = fromMaybe curDate $ calculationDay <$> ((\sc -> inf sc curDate) =<< fpSchedule) - y_sd_t = constnt $ _y ct_DCC ct_SD curDate ct_MD y_tfpminus_t = constnt $ _y ct_DCC tfp_minus curDate ct_MD y_tfpminus_tfpplus = constnt $ _y ct_DCC tfp_minus tfp_plus ct_MD y_ipanx_t = constnt $ _y ct_DCC (fromJust ct_IPANX) curDate ct_MD in case contractType of PAM -> - 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_IP_PAM st time y_sd_t y_tfpminus_t y_tfpminus_tfpplus __FEB __FER ct_CNTRL - IP -> _STF_IPCI_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 ct_SCEF __o_rf_SCMO __SCIED - CE -> _STF_CE_PAM st time y_sd_t - _ -> st + stateTransitionMarlowe ev t continue $ \event st -> + let y_sd_t = constnt $ _y ct_DCC (backFromMarloweDate $ sd st) curDate ct_MD + in 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_IP_PAM st time y_sd_t y_tfpminus_t y_tfpminus_tfpplus __FEB __FER ct_CNTRL + IP -> _STF_IPCI_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 ct_SCEF __o_rf_SCMO __SCIED + CE -> _STF_CE_PAM st time y_sd_t + _ -> st LAM -> undefined