Skip to content

Commit

Permalink
fix sd
Browse files Browse the repository at this point in the history
  • Loading branch information
@dk14
dk14 committed Aug 3, 2020
1 parent dc43581 commit 3dcbeb6
Show file tree
Hide file tree
Showing 3 changed files with 23 additions and 27 deletions.
15 changes: 8 additions & 7 deletions marlowe-actus/src/Language/Marlowe/ACTUS/Generator.hs
View file
Expand Up @@ -9,11 +9,11 @@ module Language.Marlowe.ACTUS.Generator
)
where

import qualified Data.List as L (scanl, tail, zip, zip5)
import qualified Data.List as L (scanl, tail, zip, zip6)
import Data.Maybe (fromMaybe, isNothing)
import Data.String (IsString (fromString))
import Data.Sort (sortOn)
import Data.Time (fromGregorian)
import Data.Time (Day, fromGregorian)
import Language.Marlowe (AccountId (AccountId),
Action (Choice, Deposit), Bound (Bound),
Case (Case), ChoiceId (ChoiceId),
Expand All @@ -22,7 +22,7 @@ import Language.Marlowe (Accoun
Value (ChoiceValue, Constant, NegValue, UseValue),
ValueId (ValueId), ada)
import Language.Marlowe.ACTUS.Definitions.BusinessEvents (EventType (..), RiskFactors (..))
import Language.Marlowe.ACTUS.Definitions.ContractTerms (ContractTerms(ct_CURS))
import Language.Marlowe.ACTUS.Definitions.ContractTerms (ContractTerms(ct_CURS, ct_SD))
import Language.Marlowe.ACTUS.Definitions.Schedule (CashFlow (..), ShiftedDay (..),
calculationDay, paymentDay)
import Language.Marlowe.ACTUS.MarloweCompat (dayToSlotNumber, constnt)
Expand Down Expand Up @@ -155,14 +155,15 @@ genFsContract terms =
schedCfs = genProjectedCashflows terms
schedEvents = cashEvent <$> schedCfs
schedDates = Slot . dayToSlotNumber . cashPaymentDay <$> schedCfs
previousDates = ([ct_SD terms] ++ (cashCalculationDay <$> schedCfs))
cfsDirections = amount <$> schedCfs
gen :: (CashFlow, EventType, Slot, Double, Integer) -> Contract -> Contract
gen (cf, ev, date, r, t) cont = inquiryFs ev terms ("_" ++ show t) date "oracle"
$ stateTransitionFs ev terms t (cashCalculationDay cf)
gen :: (CashFlow, Day, EventType, Slot, Double, Integer) -> Contract -> Contract
gen (cf, prevDate, ev, date, r, t) cont = inquiryFs ev terms ("_" ++ show t) date "oracle"
$ stateTransitionFs ev terms t prevDate (cashCalculationDay cf)
$ Let (payoffAt t) (fromMaybe (constnt 0.0) pof)
$ if (isNothing pof) then cont
else if r > 0.0 then invoice "party" "counterparty" (UseValue $ payoffAt t) date cont
else invoice "counterparty" "party" (NegValue $ UseValue $ payoffAt t) date cont
where pof = (payoffFs ev terms t (t - 1) (cashCalculationDay cf))
scheduleAcc = foldr gen Close $ L.zip5 schedCfs schedEvents schedDates cfsDirections [1..]
scheduleAcc = foldr gen Close $ L.zip6 schedCfs previousDates schedEvents schedDates cfsDirections [1..]
in inititializeStateFs terms scheduleAcc
14 changes: 1 addition & 13 deletions marlowe-actus/src/Language/Marlowe/ACTUS/MarloweCompat.hs
View file
Expand Up @@ -92,19 +92,7 @@ cardanoEpochStart = 100
dayToSlotNumber :: Day -> Integer
dayToSlotNumber d =
let (MkSystemTime secs _) = utcToSystemTime (UTCTime d 0)
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

in (fromIntegral secs `div` 20) - cardanoEpochStart

marloweDate :: Day -> Value Observation
marloweDate = Constant . fromInteger . dayToSlotNumber

backFromMarloweDate :: Value Observation -> Day
backFromMarloweDate (Constant x) = slotNumberToDay x
backFromMarloweDate _ = slotNumberToDay 0
21 changes: 14 additions & 7 deletions marlowe-actus/src/Language/Marlowe/ACTUS/Model/STF/StateTransitionFs.hs
View file
Expand Up @@ -21,12 +21,12 @@ 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, backFromMarloweDate,
stateTransitionMarlowe, useval)
import Language.Marlowe.ACTUS.MarloweCompat (constnt, enum, marloweDate,
stateTransitionMarlowe, useval, letval)


stateTransitionFs :: EventType -> ContractTerms -> Integer -> Day -> Contract -> Contract
stateTransitionFs ev terms@ContractTerms{..} t curDate continue =
stateTransitionFs :: EventType -> ContractTerms -> Integer -> Day -> Day -> Contract -> Contract
stateTransitionFs ev terms@ContractTerms{..} t prevDate curDate continue =
let
-- value wrappers:
__IPANX = marloweDate <$> ct_IPANX
Expand Down Expand Up @@ -57,12 +57,19 @@ stateTransitionFs ev terms@ContractTerms{..} t curDate continue =
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
y_sd_t = constnt $ _y ct_DCC prevDate curDate ct_MD

addComment cont = case ev of
IED -> letval "IED" t (constnt 0) cont
MD -> letval "MD" t (constnt 0) cont
IP -> letval ("IP:" ++ (show curDate)) 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 ->
stateTransitionMarlowe ev t continue $ \event st ->
let y_sd_t = constnt $ _y ct_DCC (backFromMarloweDate $ sd st) curDate ct_MD
in case event of
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
Expand Down

0 comments on commit 3dcbeb6

Please sign in to comment.