diff --git a/Haslo.hs b/Haslo.hs new file mode 100644 --- /dev/null +++ b/Haslo.hs @@ -0,0 +1,40 @@ +--------------------------------------------------------- +-- +-- Module : Haslo +-- Copyright : Bartosz Wójcik (2012) +-- License : BSD3 +-- +-- Maintainer : bartek@sudety.it +-- Stability : Unstable +-- Portability : portable +-- +-- | Haslo aplication interface. The only module from haslo library you need to import. +--------------------------------------------------------- + +module Haslo + (module Haslo.Parameters + ,module Haslo.ErrorHandling + ,module Haslo.InstalmentPlan + ,module Haslo.InstalmentPlanProps + ,module Haslo.CalcConfigurationType + ,module Haslo.CalcConstructors + ,module Haslo.Calculator + ,getVersionHaslo + ) +where + +import Haslo.Parameters +import Haslo.ErrorHandling +import Haslo.InstalmentPlan +import Haslo.InstalmentPlanProps +import Haslo.CalcConfigurationType +import Haslo.CalcConstructors +import Haslo.Calculator + +-- | Human friendly formatet output of list wrapped in the Either. +-- Usefull for quick validation of loan constructors. +niceShow :: (Show a, Show a1) => Either a1 [a] -> IO () +niceShow (Right xs) = mapM_ (putStrLn . show) xs +niceShow (Left err) = putStrLn $ show err + +getVersionHaslo = "0.1" diff --git a/Haslo/BasicType.hs b/Haslo/BasicType.hs new file mode 100644 --- /dev/null +++ b/Haslo/BasicType.hs @@ -0,0 +1,43 @@ +--------------------------------------------------------- +-- +-- Module : BasicType +-- Copyright : Bartosz Wójcik (2010) +-- License : BSD3 +-- +-- Maintainer : bartek@sudety.it +-- Stability : Unstable +-- Portability : portable +-- +-- Basic types of Haskell Loan. +--------------------------------------------------------- +{-# LANGUAGE TypeSynonymInstances #-} +module Haslo.BasicType +where + +import Text.PrettyShow + + +-- | Each amount has its own fix precision. Usually two digits after decimal point, sometimes +-- even till full hundrest or thousends. Therefore all amounts are stored as Ints. This prevents +-- situation where rounded amounts don't sum up to given value. Alternatilvely @Int@ would be +-- suitable. +type Amount = Integer + +-- | Interest calculated. Interest paid is of @Amount@ data type. +type Interest = Double + +-- | Interest rate. +type Rate = Double + +-- | Duration of the loan. +type Duration = Int + + +-- | Operations on @Amount@s have to be rounded to full amount. +data RoundingType = Rounded + | Truncated + deriving (Eq, Ord, Show, Enum) + +instance PrettyShow RoundingType where + showWithLen n = showWithLen n . show + diff --git a/Haslo/CalcCalendar.hs b/Haslo/CalcCalendar.hs new file mode 100644 --- /dev/null +++ b/Haslo/CalcCalendar.hs @@ -0,0 +1,91 @@ +--------------------------------------------------------- +-- +-- Module : CalcCalendar +-- Copyright : Bartosz Wójcik (2010) +-- License : BSD3 +-- +-- Maintainer : bartek@sudety.it +-- Stability : Unstable +-- Portability : portable +-- +-- Bank calendar of Haskell Loan. +--------------------------------------------------------- +-- | Provides data types and basic functions operating on dates +-- in specific calendars. +module Haslo.CalcCalendar + (module Data.Time + ,module Data.Time.Calendar.OrdinalDate + ,CalendarType (..) + ,diffLoanCalendar + ,addMonth + ,addMonths + ,addYears + ,setDay + ,setOrdinalDay + ,Freq (..) + ,freqPerYear + ,addPeriods + ) +where + +import Data.Time +--import Data.Time.Calendar.Julian +import Data.Time.Calendar.OrdinalDate +import Text.PrettyShow + +-- | Bank calendar is usually different than real one. +data CalendarType = Y360 -- ^ year has 360 days, each month 30 days + | Y360Specific -- ^ year has 360 days, each month 30 days (specific version, + -- where diff 15.02 31.01 = 14 [not 15 as expected!]) + | RealCalendar -- ^ each month has real number of days + deriving (Eq, Show, Enum) + +-- | Number of days between two dates in different calendars +diffLoanCalendar :: Day -> Day -> CalendarType -> Int +diffLoanCalendar d1 d2 Y360 = fromIntegral (360 * (yd1 - yd2)) + 30 * (md1 - md2) + min 30 dd1 - min 30 dd2 + where (yd1,md1,dd1) = toGregorian d1 + (yd2,md2,dd2) = toGregorian d2 +diffLoanCalendar d1 d2 Y360Specific = fromIntegral (360 * (yd1 - yd2)) + 30 * (md1 - md2) + dd1 - dd2 + where (yd1,md1,dd1) = toGregorian d1 + (yd2,md2,dd2) = toGregorian d2 +diffLoanCalendar d1 d2 RealCalendar = fromIntegral $ diffDays d1 d2 +--diffLoanCalendar _ _ cal = error $ "Calendar " ++ show cal ++ " is not yet defined" + +addMonth date | m == 12 = fromGregorian (y+1) 1 d + | otherwise = fromGregorian y (m+1) d + where (y,m,d) = toGregorian date + +addMonths :: Integer -> Day -> Day +addMonths n date = fromGregorian (y + ((n+m-1) `div` 12)) (fromIntegral (n+m-1) `mod` 12 + 1) d + where (y,m',d) = toGregorian date + m = fromIntegral m' + +addYears :: Integer -> Day -> Day +addYears n date = fromGregorian (y+n) m d + where (y,m,d) = toGregorian date + +setDay n date = fromGregorian y m n + where (y,m,d) = toGregorian date + +setOrdinalDay n date = fromOrdinalDate y n + where (y,d) = toOrdinalDate date + +-- | Frequency. +data Freq = Daily + | Monthly + | Yearly + deriving (Eq, Ord, Show, Enum) + +instance PrettyShow Freq where + showWithLen n = showWithLen n . show + +freqPerYear Daily = 365 +freqPerYear Monthly = 12 +freqPerYear Yearly = 1 + +-- | Increases a date by given number of given units. +addPeriods :: Freq -> Integer -> Day -> Day +addPeriods Daily = addDays +addPeriods Monthly = addMonths +addPeriods Yearly = addYears + diff --git a/Haslo/CalcConfigurationType.hs b/Haslo/CalcConfigurationType.hs new file mode 100644 --- /dev/null +++ b/Haslo/CalcConfigurationType.hs @@ -0,0 +1,199 @@ +--------------------------------------------------------- +-- +-- Module : CalcConfigurationType +-- Copyright : Bartosz Wójcik (2010) +-- License : BSD3 +-- +-- Maintainer : bartek@sudety.it +-- Stability : Unstable +-- Portability : portable +-- +-- | This module implements data types of loan consturctors. +--------------------------------------------------------- +module Haslo.CalcConfigurationType + (module Haslo.CalcCalendar + ,InstalmentLoanData (..) + ,ClassicLoan (..) + ,Balloons (..) + ,UnfdBalloons (..) + ,Classical (..) + ,Balloon (..) + ,BalloonPlus (..) + ,UnfdBalloon (..) + ,UnfdBalloonPlus (..) + ,ReversBalloon (..) + ,Bullet (..) + ,myRound + ) + +where + +import Haslo.BasicType +import Haslo.CalcCalendar +import Haslo.ErrorHandling +import Haslo.Parameters +import Haslo.InstalmentPlan +import Text.PrettyShow + + +-- ============================== +-- Types' definitions +-- ============================== + +-- | Data type for retriving loan data of particular products directly from consturctors. +data InstalmentLoanData = InstalmentLoanData {principal :: Amount + ,duration :: Duration + ,deferrment :: Duration + ,rate :: Rate + } + deriving (Eq, Ord, Show) + +-- | Classical Loan provides a constructor function which +-- creates @Instalment Plan@ of this loan. +class ClassicLoan a where + newLoanI :: a -- ^ type of loan + -> IPPMonad InstalmentPlan + extract :: a -> InstalmentLoanData + +-- | Class of loans with specific last instalment. +class (ClassicLoan a) => Balloons a where + balloon :: a -> Amount + +-- | Class of loans with extended duration. +class (Balloons a) => UnfdBalloons a where + eXtendedDuration :: a -> Duration -- ^ Max duration of extended period. + +-- | Eeach installment is equal: +-- principal, duration in freq units, 1st instalment postponement in duration units, +-- yearly effective interest rate +data Classical = Classical !Amount -- principal + !Duration -- duration in freq units + !Duration -- 1st instalment postponement in duration units + !Rate -- yearly effective interest rate + deriving (Eq, Ord) + +-- | Last installment is given, rest are equal +-- Datatype elements: principal, duration in freq units, 1st instalment postponement in duration units, +-- yearly effective interest rate,balloon amount. +data Balloon = Balloon !Amount -- principal + !Duration -- duration in freq units + !Duration -- 1st instalment postponement in duration units + !Rate -- yearly effective interest rate + !Amount -- balloon amount + deriving (Eq, Ord) + +-- | Balloon + given amount is put on top of last installment. +-- | Last installment is given, rest are equal +-- Datatype elements: principal, duration in freq units, 1st instalment postponement in duration units, +-- yearly effective interest rate,balloon amount. +data BalloonPlus = BalloonPlus !Amount -- principal + !Duration -- duration in freq units + !Duration -- 1st instalment postponement in duration units + !Rate -- yearly effective interest rate + !Amount -- balloon amount + deriving (Eq, Ord) + +-- | 2 periods product with given duration of 1st one and +-- residual balloon amount (RBA). +-- RBA serves to calculate first period installment amount like in balloon. +-- 2nd period amount is equal to 1st one, its duration is calculated +-- based on it. Last installment may differ. +-- Datatype elements: principal, duration in freq units, 1st instalment postponement in duration units, +-- yearly effective interest rate, residual balloon amount (RBA), maximal duration of unfolded RBA. +data UnfdBalloon = UnfdBalloon !Amount -- principal + !Duration -- duration till balloon (inclusive) in freq units + !Duration -- 1st instalment postponement in duration units + !Rate -- yearly effective interest rate + !Amount -- residual balloon amount (RBA). + !Duration -- maximal duration of unfolded RBA + deriving (Eq, Ord) + +-- | Similar to UnfdBalloon. There is 1 difference: RBA maturess together with +-- last installment of 1st period (like BalloonPlus), +-- whilst in UnfdBalloon - one month later. +-- Datatype elements: principal, duration in freq units, 1st instalment postponement in duration units, +-- yearly effective interest rate, residual balloon amount (RBA), maximal duration of unfolded RBA. +data UnfdBalloonPlus = UnfdBalloonPlus !Amount -- principal + !Duration -- duration till balloon (inclusive) in freq units + !Duration -- 1st instalment postponement in duration units + !Rate -- yearly effective interest rate + !Amount -- residual balloon amount (RBA). + !Duration -- maximal duration of unfolded RBA + deriving (Eq, Ord) + +-- | Each installment is equal to given amount but the last one. +-- Datatype elements: principal, duration in freq units, 1st instalment postponement in duration units, +-- yearly effective interest rate, regular instalment amount. +data ReversBalloon = ReversBalloon !Amount -- principal + !Duration -- duration till balloon (inclusive) in freq units + !Duration -- 1st instalment postponement in duration units + !Rate -- yearly effective interest rate + !Amount -- regular instalment amount. + deriving (Eq, Ord) + +-- | Balloon, where all installments equal 0 except last one which contains full +-- capital and first one which contains interest. +-- Datatype elements: principal, duration in freq units, 1st instalment postponement in duration units, +-- yearly effective interest rate. +data Bullet = Bullet !Amount -- principal + !Duration -- duration till balloon (inclusive) in freq units + !Duration -- 1st instalment postponement in duration units + !Rate -- yearly effective interest rate + deriving (Eq, Ord) + + +instance Show Classical where + show (Classical p n d r) = showWithLen 20 "Classical" ++ + showAmtWithLen 11 p ++ + showWithLen 5 n ++ + showWithLen 3 d ++ + " " ++ show r +instance Show Balloon where + show (Balloon p n d r b) = showWithLen 20 "Balloon" ++ + showAmtWithLen 11 p ++ + showWithLen 5 n ++ + showWithLen 3 d ++ + " " ++ show r ++ " " ++ + showAmtWithLen 11 b +instance Show BalloonPlus where + show (BalloonPlus p n d r b) = showWithLen 20 "BalloonPlus" ++ + showAmtWithLen 11 p ++ + showWithLen 5 n ++ + showWithLen 3 d ++ + " " ++ show r ++ " " ++ + showAmtWithLen 11 b +instance Show UnfdBalloon where + show (UnfdBalloon p n d r b x) = showWithLen 20 "UnfoldedBalloon" ++ + showAmtWithLen 11 p ++ + showWithLen 5 n ++ + showWithLen 3 d ++ + " " ++ show r ++ " " ++ + showAmtWithLen 11 b ++ + showWithLen 5 x +instance Show UnfdBalloonPlus where + show (UnfdBalloonPlus p n d r b x) = showWithLen 20 "UnfoldedBalloonPlus" ++ + showAmtWithLen 11 p ++ + showWithLen 5 n ++ + showWithLen 3 d ++ + " " ++ show r ++ " " ++ + showAmtWithLen 11 b ++ + showWithLen 5 x +instance Show ReversBalloon where + show (ReversBalloon p n d r b) = showWithLen 20 "ReversBalloon" ++ + showAmtWithLen 11 p ++ + showWithLen 5 n ++ + showWithLen 3 d ++ + " " ++ show r ++ " " ++ + showAmtWithLen 11 b +instance Show Bullet where + show (Bullet p n d r) = showWithLen 20 "Bullet" ++ + showAmtWithLen 11 p ++ + showWithLen 5 n ++ + showWithLen 3 d ++ + " " ++ show r + +-- | Rounding function out of RoundingType. +myRound :: (RealFrac a) => RoundingType -> (a -> Amount) +myRound Rounded = round +myRound Truncated = truncate + diff --git a/Haslo/CalcConstructors.hs b/Haslo/CalcConstructors.hs new file mode 100644 --- /dev/null +++ b/Haslo/CalcConstructors.hs @@ -0,0 +1,301 @@ + --------------------------------------------------------- +-- +-- Module : CalcConstructors +-- Copyright : Bartosz Wójcik (2010) +-- License : BSD3 +-- +-- Maintainer : bartek@sudety.it +-- Stability : Unstable +-- Portability : portable +-- +-- | Convenience functions to construct different kinds of abstract loans or 'InstalmentPlan'. +-- ------------------------------------------------------- +module Haslo.CalcConstructors + (newLoanR + ,newLoanRIL + ,newInstalmentPlanLine + ,recalculateEffectiveRate + ) +where + +import Haslo.BasicType +import Haslo.CalcCalendar +import Haslo.CalcConfigurationType +import Haslo.InstalmentPlan +import Haslo.Calculator +import Haslo.ErrorHandling +import Haslo.Parameters +import Data.Maybe (fromJust) +import Control.Monad.Reader + +moduleName = "CalcConstructors" + +-- ------ Loan constructors --------------- +-- | Instalment details have some assumptions: +-- late interest accrue interest +-- installment is always in full installment duration +-- there are no gaps between instalments, though instalment amount can be = 0 +newInstalment :: Amount -- ^ capital before installment (excluded late interest) + -> Rate -- ^ rate in frequency unit + -> Amount -- ^ instalment amount; when < 0 will be forced to interest + late interest + -> Interest -- ^ late interest to be paid by the instalment + -> Instalment -- ^ full details for intalment +newInstalment c r i lateInterest + | i < 0 = I interestPaid' + 0 + interest + interestPaid' + | otherwise = I i + capitalPaid + interest + interestPaid + where interest = (fromIntegral c + lateInterest) * r + interestPaid' = round $ interest + lateInterest + interestPaid = min i $ round $ interest + lateInterest + capitalPaid = i - interestPaid + +-- | Instalment details based on next instalment details +-- Constrain: rate >= 0 +-- Late interest cannot be recognized. +prevInstalment :: Amount -- ^ capital after instalment + -> Rate -- ^ rate in frequency unit + -> Amount -- ^ instalment amount + -> Instalment +prevInstalment c r i = I i + capitalPaid + interest + interestPaid + where interest = fromIntegral (c + i) * r / (1 + r) + interestPaid = round interest + capitalPaid = i - interestPaid -- constrain for r >=0 ! + + +-- | Creates one line of instalment plan +newInstalmentPlanLine :: Amount -- ^ capital before excluded late interest + -> Interest -- ^ total late interest before instalment + -> Rate -- ^ nominal rate in frequency units + -> Amount -- ^ instalment amount + -> InstalmentPlanLine -- ^ instalment plan one row +newInstalmentPlanLine c iL r i = IPL inst + (c - iRepayment inst) + (iL + iInterest inst -- late interest can be negative + - fromIntegral (iIntPaid inst)) + r + where inst = newInstalment c r i iL + +-- | Creates one line of instalment plan +prevInstalmentPlanLine :: Amount -- ^ capital after instalment excluded late interest + -> Rate -- ^ rate in frequency units + -> Amount -- ^ instalment amount + -> InstalmentPlanLine -- ^ instalment plan one row +prevInstalmentPlanLine c r i = IPL inst + c + 0 + r + where inst = prevInstalment c r i + + + +-- | Calculates instalment plan for input where interest rate is not known. +-- Specialization of 'newLoanRIL'. +newLoanR :: Amount -- ^ principal + -> [Amount] -- ^ list of instalment amounts + -> ValidMonad InstalmentPlan +newLoanR = newLoanRIL 0 + + +-- | Calculates instalment loan details for input where interest rate is not known. +-- Checks whether InstalmentPlan amortizes properly. If not throws apropriate error. +-- Amotizes means: no deferred interest remains. Remaining capital is 0. +-- Additionaly allows to move part of interest to the begining of the loan. +-- This feature is usefull for early regulation case, first interest is paid before principal. +newLoanRIL :: Interest -- ^ late interest - amount of interest to be taken before principal. + -> Amount -- ^ capital + -> [Amount] -- ^ list of instalment amounts + -> ValidMonad InstalmentPlan +newLoanRIL iL c is = rateIrr is (c + round iL) >>= check . newLoanR' c is iL + where newLoanR' _ [] _ _ = [] + newLoanR' c (i:is') iL' r = newIPL + : newLoanR' (iplPrincipal newIPL) is' (iplIntLate newIPL) r + where newIPL = newInstalmentPlanLine c iL' r i + check ip | lastCap /= 0 && r > 0 = throwError $ NotAmortized lastCap ip + | lastCap > fromIntegral (length is) && + r == 0 = throwError $ NotAmortized lastCap ip + | abs lastDefInt > 1e-2 = throwError $ NotPaidDefferedInterest lastDefInt ip + | otherwise = return ip + where IPL _ lastCap lastDefInt r = last ip + +-- | Gives recalculated single effective interest rate of given loan. +recalculateEffectiveRate :: Freq -> InstalmentPlan -> ValidMonad Rate +recalculateEffectiveRate fr ip = liftM (cN2E fr) $ rateIrr (instList ip) (initPrincipal ip) + +-- ============================================================================= + +-- | Classical Loan: all instalments are equal. +instance ClassicLoan Classical where + newLoanI (Classical c n d rE) = + ask >>= \param -> + let r = cE2N (freq param) rE + i = myRound (rounding param) $ rawCalcInstCl (fromIntegral c) n r d + in lift $ newLoanR c $ replicate d 0 ++ replicate n i + + extract (Classical p n d r) = InstalmentLoanData p n d r + +-- | Balloon: last instalment is given, the other are equal. +instance ClassicLoan Balloon where + newLoanI (Balloon c n d rE b) = + ask >>= \param -> + let r = cE2N (freq param) rE + i = myRound (rounding param) $ rawCalcInstBal (fromIntegral c) n r d (fromIntegral b) + in lift $ newLoanR c $ replicate d 0 ++ replicate (n-1) i ++ [b] + + extract (Balloon p n d r _) = InstalmentLoanData p n d r + +-- | BalloonPlus: last instalment is equal to normal instalment + given amount. +-- The other instalments are equal. +instance ClassicLoan BalloonPlus where + newLoanI (BalloonPlus c n d rE b) = + ask >>= \param -> + let r = cE2N (freq param) rE + i = myRound (rounding param) $ rawCalcInstBalPlus (fromIntegral c) n r d + (fromIntegral b) + in lift $ newLoanR c $ replicate d 0 ++ replicate (n-1) i ++ [b + i] + + extract (BalloonPlus p n d r _) = InstalmentLoanData p n d r + +-- | UnfdBalloon: Loan type based on Balloon type. It differs from Balloon that is unfolds balloon instalment so +-- that all instalments are equal, except the last one which is less or equal. +instance ClassicLoan UnfdBalloon where + newLoanI (UnfdBalloon c n d rE b x) = + ask >>= \param -> + let r = cE2N (freq param) rE + i = myRound (rounding param) $ rawCalcInstBal (fromIntegral c) n r d (fromIntegral b) + durOfBal :: Integer + durOfBal = calcDurCl (fromIntegral $ calcCapBeforeBal b r) (fromIntegral i) r 0 truncate + durOfBal' :: Int + durOfBal' = fromIntegral durOfBal + lastInst = round $ rawCalcInstCl (fromIntegral $ capBeforeLast) 1 r 0 + capBeforeLast = calcCapAfterN c i (n - 1 + durOfBal') d r + unfoldedBalloon | durOfBal > fromIntegral x = replicate x newI + | otherwise = replicate durOfBal' i ++ [lastInst] + where newI = myRound (rounding param) $ + rawCalcInstCl (fromIntegral $ calcCapBeforeBal b r) x r 0 + in lift $ newLoanR c $ replicate d 0 ++ replicate (n-1) i ++ unfoldedBalloon + + extract (UnfdBalloon p n d r _ _) = InstalmentLoanData p n d r + +-- | Loan type based on Balloon Plus type. It differs from Balloon Plus that is unfolds balloon instalment so +-- that all instalments are equal, except the last one which is less or equal. +instance ClassicLoan UnfdBalloonPlus where + newLoanI (UnfdBalloonPlus c n d rE b x) = + ask >>= \param -> + let r = cE2N (freq param) rE + i = myRound (rounding param) $ + rawCalcInstBalPlus (fromIntegral c) n r d (fromIntegral b) + durOfBal :: Integer + durOfBal = calcDurCl (fromIntegral $ calcCapBeforeBal b r) + (fromIntegral i) r 0 truncate + durOfBal' :: Int + durOfBal' = fromIntegral durOfBal + lastInst = round $ rawCalcInstCl (fromIntegral $ capBeforeLast) 1 r 0 + capBeforeLast = calcCapAfterN c i (n + durOfBal') d r + unfoldedBalloon | durOfBal > fromIntegral x = replicate x newI + | otherwise = replicate durOfBal' i ++ [lastInst] + where newI = myRound (rounding param) $ + rawCalcInstCl (fromIntegral $ calcCapBeforeBal b r) x r 0 + in lift $ newLoanR c $ replicate d 0 ++ replicate n i ++ unfoldedBalloon + + extract (UnfdBalloonPlus p n d r _ _) = InstalmentLoanData p n d r + +-- | Loan type Balloon like. It differs from Balloon that its regural instalment +-- is given and balloon amount is to be calculated. +instance ClassicLoan ReversBalloon where + newLoanI (ReversBalloon c n d rE i) = + ask >>= \param -> + let r = cE2N (freq param) rE + b = myRound (rounding param) $ + rawCalcBalBal (fromIntegral c) n r d (fromIntegral i) + in lift $ newLoanR c (replicate d 0 ++ replicate (n-1) i ++ [b]) + + extract (ReversBalloon p n d r _) = InstalmentLoanData p n d r + +-- | Loan type Balloon like. Its all instalment equal zero except the last one which equals principal +-- and the first one which contains all interest. +instance ClassicLoan Bullet where + newLoanI (Bullet c n d rE) = + ask >>= \param -> + let r = cE2N (freq param) rE + fstInst = myRound (rounding param) $ + rawCalcMaxFstInst (fromIntegral c) n r d + in lift $ newLoanRIL (fromIntegral fstInst) c $ + replicate d 0 ++ [fstInst] ++ replicate (n-2) 0 ++ [c] + + extract (Bullet p n d r) = InstalmentLoanData p n d r + +-- =================== Additional instances ==================== + +instance Balloons Balloon where + balloon (Balloon _ _ _ _ b) = b + +instance Balloons BalloonPlus where + balloon (BalloonPlus _ _ _ _ b) = b + +instance Balloons UnfdBalloon where + balloon (UnfdBalloon _ _ _ _ b _) = b + +instance Balloons UnfdBalloonPlus where + balloon (UnfdBalloonPlus _ _ _ _ b _) = b + +instance Balloons Bullet where + balloon (Bullet p _ _ _ ) = p + +instance UnfdBalloons UnfdBalloon where + eXtendedDuration (UnfdBalloon _ _ _ _ _ x) = x + +instance UnfdBalloons UnfdBalloonPlus where + eXtendedDuration (UnfdBalloonPlus _ _ _ _ _ x) = x + +-- ======================================================================= +-- =========== Functions not yet or ever used ============================ +-- ======================================================================= + +-- | Adjusts 1st instalment of 'InstalmentPlan' by addind giving amout to +-- instalment amount and to paid late interest (the latter due to instalment balance rule). +-- There is no amount control. +adj1stInst :: Amount -- ^ Amount of late interest 1st instalment is to be adjusted by + -> InstalmentPlan + -> InstalmentPlan +adj1stInst iL ip = adjIPL iL (head ip) : tail ip + +adjIPL iL ipl = ipl { iplInst = newI } + where i = iplInst ipl + newI = i {iAmt = iAmt i + iL + ,iIntPaid = iIntPaid i + iL + } + +callLateInstalment ipl = ipl { iplInst = newI } + where newI = i {iAmt = iAmt i - iIntPaid i + ,iIntPaid = 0 + } + i = iplInst ipl + +-- | Calculates initial part of the loan - means doesn't have to finish with capital 0 at the end. +initLoan :: Amount -- ^ capital. + -> [Amount] -- ^ list of instalment amounts + -> Rate -- ^ interest rate in frequency units + -> Interest -- ^ late interest on the begining. Ignored if capital == 0 + -> InstalmentPlan +initLoan _ [] _ _ = [] +initLoan c (i:is) r iL = newIPL : initLoan (iplPrincipal newIPL) is r (iplIntLate newIPL) + where newIPL = newInstalmentPlanLine c iL r i + +-- | Calculates backwards last part of the loan. +tailLoan :: [Amount] -- ^ list of instalment amounts + -> Rate -- ^ interest rate in frequency units + -> InstalmentPlan +tailLoan is r = reverse $ tailLoan' 0 (reverse is) r + where tailLoan' _ [] _ = [] + tailLoan' c (i:is) r = newIPL : tailLoan' (iRepayment $ iplInst $ newIPL) is r + where newIPL = prevInstalmentPlanLine c r i + + diff --git a/Haslo/Calculator.hs b/Haslo/Calculator.hs new file mode 100644 --- /dev/null +++ b/Haslo/Calculator.hs @@ -0,0 +1,268 @@ +--------------------------------------------------------- +-- +-- Module : Calculator +-- Copyright : Bartosz Wójcik (2010) +-- License : BSD3 +-- +-- Maintainer : bartek@sudety.it +-- Stability : Unstable +-- Portability : portable +-- +-- | Basic loan arithmetics. +--------------------------------------------------------- +module Haslo.Calculator (cE2N + ,cN2E + ,rawCalcInstCl + ,rawCalcInstBal + ,rawCalcInstBalPlus + ,rawCalcBalBal + ,rawCalcMaxFstInst + ,rateIrr + ,calcDurCl + ,calcCapBeforeBal + ,calcCapAfterN + ,calcCapCl + ) +where + +import Haslo.BasicType +import Haslo.CalcCalendar (Freq,freqPerYear) +import Haslo.ErrorHandling + +moduleName = "Calculator" +-- ============================ +-- Set of calculation functions +-- ============================ +-- | Converse yealry Effective rate to Nominal one. +-- Nominal is in the frequency mode +cE2N :: Freq -> Rate -> Rate +cE2N fr r = (1+r)**(1/n) - 1 + where n = freqPerYear fr + +-- | Converse Nominal rate to yearly Effective one. +-- Nominal is in the frequency mode +cN2E :: Freq -> Rate -> Rate +cN2E fr r = (1+r)^n - 1 + where n = freqPerYear fr + +-- Raw installment and capital calculations for some type of loans (raw - not adjusted to Amount). +-- c-capital amount +-- i-installment amount +-- n-number of instalments +-- r-interest rate in same frequency as installment +-- d - 1st installment delay in frequency units +-- | Cacluates principal for given instalment amount, duration, interest rate and 1st instalment deferrment. +rawCalcCapCl :: Double -- ^ Instalment amount deAmounted + -> Duration -- ^ Loan duration + -> Rate -- ^ Interest rate + -> Duration -- ^ 1st instalment deferrment + -> Double +rawCalcCapCl i n 0 _ = i * (fromIntegral n) +rawCalcCapCl i n r d = i * (1-p^n) / (p^n * (1-p)) / p^d + where p = (1+r)**(1/12) + +-- | Calculates raw instalment amount -- not yet rounded or truncated. +rawCalcInstCl :: Double -- ^ Principal deAmounted + -> Duration -- ^ Loan duration + -> Rate -- ^ Interest rate + -> Duration -- ^ 1st instalment deferrment + -> Double +rawCalcInstCl _ 0 _ _ = 0 +rawCalcInstCl c n 0 _ = c / (fromIntegral n) +rawCalcInstCl c n r d = c * p^d * p^n * r / (p^n - 1) + where p = r+1 + +-- b - balloon installment amount +rawCalcCapBal b i n 0 d = i * fromIntegral (n-1) + b +rawCalcCapBal b i n r d = b/p^n + rawCalcCapCl i (n-1) r d + where p = r+1 + +-- | Cacluates instalment amount for given principal, duration, interest rate, 1st instalment deferrment and +-- balloon amount.For @Balloon@ loan constructor. +rawCalcInstBal :: Double -- ^ Principal deAmounted + -> Duration -- ^ Loan duration + -> Rate -- ^ Interest rate + -> Duration -- ^ 1st instalment deferrment + -> Double -- ^ Balloon amount deAmounted + -> Double +rawCalcInstBal _ 0 _ _ _ = 0 +rawCalcInstBal c n 0 _ b = (c - b) / (fromIntegral n - 1) +rawCalcInstBal c n r d b = (c * p^d - b/p^n) * p^m * r / (p^m - 1) + where p = r+1 + m = n-1 +--rawCalcInstBal c n r d b = (c * p^d - b*q^n)*(q-1) / (q^n - q) +-- where p = r+1 +-- q = 1/p + +-- | Cacluates ballon amount for given principal, duration, interest rate, 1st instalment deferrment and +-- instalment amount. +rawCalcBalBal :: Double -- ^ Principal deAmounted + -> Duration -- ^ Loan duration + -> Rate -- ^ Interest rate + -> Duration -- ^ 1st instalment deferrment + -> Double -- ^ Instalment amount deAmounted + -> Double +rawCalcBalBal c n 0 _ i = c - i * (fromIntegral n - 1) +rawCalcBalBal c n r d i = (c * p^d - i * (q^n - q)/(q - 1)) * p^n + where p = r+1 + q = 1/p + +-- | Balloon Plus -- balloon amount + usual amount = last instalment amount +rawCalcCapBalPlus b i n 0 d = i * fromIntegral n + b +rawCalcCapBalPlus b i n r d = b/p^n + rawCalcCapCl i n r d + where p = (1+r)**(1/12) + +-- | Cacluates instalment amount for given principal, duration, interest rate, 1st instalment deferrment and +-- balloon amount. For @BalloonPlus@ loan constructor. +rawCalcInstBalPlus :: Double -- ^ Principal deAmounted + -> Duration -- ^ Loan duration + -> Rate -- ^ Interest rate + -> Duration -- ^ 1st instalment deferrment + -> Double -- ^ Balloon amount deAmounted + -> Double +rawCalcInstBalPlus _ 0 _ _ _ = 0 +rawCalcInstBalPlus c n 0 _ b = (c - b) / fromIntegral n +rawCalcInstBalPlus c n r d b = (c*p^(n+d) - b)*r / (p^n - 1) + where p = r+1 + +rawCalcBalBalPlus c n 0 _ i = c - i * fromIntegral n +rawCalcBalBalPlus c n r d i = c*p^d - i * (1 - p^n)/(1 - p) + where p = (1+r)**(1/12) + +-- | Calculated maximum amount of first instalment: for @Bullet@ loan constructor. +rawCalcMaxFstInst :: Double -- ^ Principal deAmounted + -> Duration -- ^ Instalment duration + -> Rate -- ^ Nominal interest rate + -> Duration -- ^ 1st instalment deferrment + -> Double +rawCalcMaxFstInst _ _ 0 _ = 0 +rawCalcMaxFstInst c n r d = c * p^d * (p^n - 1)/(p^(n-1)) + where p = 1+r + +-- | Instalment amount under when k-th instalment is greater than calculated one +-- by x. +--calcInstWithKth x k c n r d = rawCalcInstCl c r n d - x * (r+1)^(n-k-1) * r / ((r+1)^n - 1) +--calcInstBalWithKth x k c n r d b = rawCalcInstBal c n r d b - x * (r+1)^(n-k-1) * r / ((r+1)^(n-1) - 1) + +-- Nominal interest rate calculation. Raphson-Newton algorithm. +-- i1-1st installment amount +-- d1-number of days between financing and 1st installment date +rateCl1stI :: (RealFloat a, Integral b) => a -> a -> a -> a -> a -> a -> a -> b -> a +rateCl1stI i i1 c n d d1 r count | abs (f / ff) < 0.000000001 = r - f / ff + | count > 30 = -1 -- error case + | otherwise = rateCl1stI i i1 c n d d1 (r - f / ff) (count + 1) + where f = i*((r+1)**(n-1)- 1)/(r+1)**n / r + i1/(r+1) - c*(r+1)**(d + d1/30 - 1) + ff = i*((n-1)*(r+1)**(n-1)*r - ((r+1)**(n-1) - 1) * (n*r+r+1)) + / (r+1)**(n+1) / r^2 + - i1/(r+1)^2 + - c*(d + d1/30 - 1) + +-- is-installment list +-- f-sum is(i)/(r+1)^i - c*... +-- ff-sum -i*is(i)/(r+1)^(i+1) - c*... +-- Important! 'r' is here first, as hoc extrapolation of nominal interest rate. Suggested value [0.001 - 0.01]. +-- If value is out of this range, result may not be calculated in foreseen 30 steps +rateIrr1stI :: [Amount] + -> Amount + -> Int + -> ValidMonad Rate +rateIrr1stI is c d1 = rateIrr1stI' (map fromIntegral is) (fromIntegral c) (length is) 0 (fromIntegral d1) 0.1 0 +rateIrr1stI' is c n d d1 r count | abs (f / ff) < 0.000000001 = return $ r - f / ff + | count > 30 = throwError $ OtherError $ + "rateIrr1stI c:" ++ + show c ++ + " d1:" ++ show d1 ++ + " is:" ++ show is + | otherwise = rateIrr1stI' is c n d d1 (r - f / ff) (count + 1) + where f = sum(map (uncurry (/)) (zip is [(1+r)^i|i <- [1..n]])) + - c*(r+1)**(d + d1 / 30 - 1) + ff = sum(map (uncurry (/)) (zip (map (uncurry (*)) (zip is [fromIntegral(-i)|i <- [1..n]])) [(1+r)^(i+1)|i <- [1..n]])) + - c*(d + d1/30 - 1) + +-- | General rate calculation. +-- Delay of 1st installment is integrated into instalment list +rateIrr :: [Amount] -- ^ list of instalment amounts + -> Amount -- ^ initial principal + -> ValidMonad Rate +rateIrr is c = case rateIrr' (map fromIntegral is) (fromIntegral c) (length is) 0.01 0 of + Right x -> Right x + Left _ -> rateIrr' (map fromIntegral is) (fromIntegral c) (length is) eps 0 + where eps = fromIntegral (sum is - c) / fromIntegral c / fromIntegral (length is) / 1000 + +rateIrr' is c n r count | epsilon < 1e-13 && result < 0 && eta > (-2) = return 0 + | epsilon < 1e-13 && result < 0 = throwError $ OtherError $ + "negative rate r=" ++ show result ++ + " is:" ++ show is + | epsilon < 1e-13 = return result + | count > 30 = throwError $ OtherError $ + "rateIrr c:" ++ + show c ++ + " is:" ++ show is + | otherwise = rateIrr' is c n (r - f / ff) (count + 1) + where f = sum(map (uncurry (/)) (zip is [(1+r)^i|i <- [1..n]])) - c + ff = sum $ map (uncurry (/)) + (zip (map (uncurry (*)) + (zip is [fromIntegral(-i)|i <- [1..n]])) + [(1+r)^(i+1)|i <- [1..n]]) + epsilon = abs (f / ff) + result = r - f / ff + eta = result * c + +rateCl :: Amount -- ^ instalment amount + -> Amount -- ^ principal + -> Duration -- ^ duraiton in freq units + -> Duration -- ^ 1st instalment postponement in freq units + -> ValidMonad Rate +rateCl i c n d = rateCl' (fromIntegral i) (fromIntegral c) (fromIntegral n) (fromIntegral d) 0.01 0 +rateCl' i c n d r count | abs (f / ff) < 1e-13 = return $ r - f / ff + | count > 30 = throwError $ OtherError $ + "rateCl c:" ++ + show i ++ + "c:" ++ show c ++ + "n:" ++ show n ++ + "d:" ++ show d + | otherwise = rateCl' i c n d (r - f / ff) (count + 1) + where f = i*((r+1)**n - 1) / (r+1)**n / r - c * (r+1)**d + ff = i*(n*(r+1)**n * r - ((r+1)**n - 1) * (n*r+r+1)) / (r+1)**(n+1) / r^2 - c * d + + +-- | Calculates duration of regural loan in the units of interest rate. +calcDurCl :: Double -- ^ Principal deAmounted + -> Double -- ^ Instalment amount deAmounted + -> Rate -- ^ Nominal interest rate + -> Duration -- ^ Instalment duration + -> (Double -> Amount) -- ^ Rounding function (truncate or round) - taken from parameters + -> Amount +calcDurCl _ 0 _ _ _ = 0 +calcDurCl c i 0 _ roundingFun = roundingFun $ c / i +calcDurCl c i r d roundingFun = roundingFun $ log (i / (i + c * p^d * (1-p))) / log p + where p = 1+r + +-- | Same calcualtions as for @rawCalcCapCl@ above but rounded to @Amount@. +calcCapCl :: Double -- ^ Deintegraled instalment amount. + -> Duration -- ^ Duration + -> Rate -- ^ Nominal interest rate + -> Duration -- ^ First instalment deferrment + -> Amount +calcCapCl i n r = round . rawCalcCapCl i n r +calcCapBal b i n r = round . rawCalcCapBal b i n r +calcCapBalPlus b i n r = round . rawCalcCapBalPlus b i n r + +-- | Calculates principal before last installment +calcCapBeforeBal :: Amount -- ^ Balloon amount + -> Rate -- ^ Nominal interest rate + -> Amount +calcCapBeforeBal b r = round $ fromIntegral b / (1+r) + +-- | calculates principal after Nth installment +calcCapAfterN :: Amount -- ^ Principal + -> Amount -- ^ Instalment amount + -> Duration -- ^ Loan duration + -> Duration -- ^ First instalment deferrment + -> Rate -- ^ Nominal interest rate + -> Amount +calcCapAfterN c i n _ 0 = c - i * fromIntegral n +calcCapAfterN c i n d r = truncate $ fromIntegral c * (1+r)^(n+d) - fromIntegral i * (rXn - 1) / r + where rXn = (1+r)^n + + diff --git a/Haslo/ErrorHandling.hs b/Haslo/ErrorHandling.hs new file mode 100644 --- /dev/null +++ b/Haslo/ErrorHandling.hs @@ -0,0 +1,128 @@ +--------------------------------------------------------- +-- +-- Module : ErrorHandling +-- Copyright : Bartosz Wójcik (2010) +-- License : BSD3 +-- +-- Maintainer : bartek@sudety.it +-- Stability : Unstable +-- Portability : portable +-- +-- Error handling data structures, functions, etc. +--------------------------------------------------------- +-- | Provides data types and basic functions allowing better and direct error handling. +module Haslo.ErrorHandling (module Control.Monad.Error + ,module Haslo.BasicType + ,ValidationError (..) + ,ValidMonad + ) +where + +import Control.Monad.Error.Class +import Control.Monad.Error +import Haslo.BasicType +import Haslo.InstalmentPlan +import Text.PrettyShow +import Data.Time (Day + ,fromGregorian) + +-- | Error handlig data type. +data ValidationError = + -- | Instalment discrepancy: + -- Instalment amount, Repayment, Interest paid + InstalmentDiscrepancy !Amount !Amount !Amount + + -- | Incorect interest: + -- Principal before, Late interest before, Interest calculated (incorectly), + -- Interest rate + | IPLInterest !Amount !Interest !Interest !Rate + + -- | Simple follow up interest mismatch (a1 + a2 - a3 /= a4): + -- Error description, a1, a2, a3, a4 + | FollowUpInterestError String !Interest !Interest !Amount !Interest + + -- | Simple follow up mismatch (a1 - a /= a2): + -- Error description, a1, a, a2 + | FollowUpError String !Amount !Amount !Amount + + -- | Simpler follow up mismatch (a /= b): + -- Error description, a, b + | SimplerFollowUpError String !Amount !Amount + + -- | Deffered interest cannot be paid. + | NotPaidDefferedInterest !Interest InstalmentPlan + + -- | Capital doesn't amortize. This is due to rounding error if happens. + | NotAmortized !Amount InstalmentPlan + + | OtherError String + + -- Any error can occur independently before and after financing. + -- Errors after financing usually are linked to date. +-- | FinancingError Day ValidationError + +-- | We make ValidationError an instance of the Error class +-- to be able to throw it as an exception. +instance Error ValidationError where + noMsg = OtherError "(!)" + strMsg s = OtherError s + +instance Show ValidationError where + show (InstalmentDiscrepancy a p iP) = "Instalment discrepancy:\ + \instalment amount /= repayment + interest paid (" + ++ (showAmtWithLen 8 a) ++ "/=" ++ + (showAmtWithLen 8 p) ++ "+" ++ + (showAmtWithLen 8 iP) ++ ")" + show (IPLInterest p iL i r) = "IPL interest discrepancy: \ + \ recalculated interest=" ++ show iR ++ + ", given interest=" ++ show i ++ + " (principal:" ++ showAmtWithLen 8 p ++ + " (late interest:" ++ showWithLenDec 11 6 iL ++ + " (interest rate:" ++ show r ++ ")" + where iR = (fromIntegral p + iL) * r + show (FollowUpInterestError msg a1 a2 a3 a4) = msg ++ + show (a1 / 100) ++ " - " ++ + show (a2 / 100) ++ " + " ++ + showAmtWithLen 8 a3 ++ " /= " ++ + show (a4 / 100) + show (FollowUpError msg a1 a a2) = msg ++ + showAmtWithLen 8 a1 ++ " - " ++ + showAmtWithLen 8 a ++ " /= " ++ + showAmtWithLen 8 a2 + show (SimplerFollowUpError msg a b) = msg ++ + showAmtWithLen 8 a ++ " /= " ++ + showAmtWithLen 8 b + show (NotPaidDefferedInterest iL ip) = "Deferred interest not paid off. Remains:" ++ + show (iL / 100) ++ + " " ++ show ip + show (NotAmortized c ip) = "Principal doesn't amortize fully. Remains:" ++ showAmtWithLen 8 c ++ + " " ++ show ip + show (OtherError msg) = msg +-- show (FinancingError d err) = show d ++ " " ++ show err + +maybeShow Nothing = "" +maybeShow (Just a) = show a ++ " " + +-- | Monad wrapping error message or correct value. Broadly used. +type ValidMonad = Either ValidationError + + +--errMsg moduleName functionName msg = throwError $ OtherError $ +-- moduleName ++ " " ++ +-- functionName ++ " " ++ +-- msg + +{-errDate :: Day -> ValidMonad a -> ValidMonad a +errDate d (Left (FollowUpError w x y z _)) = Left $ FollowUpError w x y z (Just d) +errDate d (Left (InstalmentDiscrepancy w x y z _)) = Left $ InstalmentDiscrepancy w x y z (Just d) +errDate d (Left (IPLInterest w x y z _)) = Left $ IPLInterest w x y z (Just d) +errDate _ x = x-} + +--data FinancingError = SFinancingError Day ValidationError + +-- | Allows adding date to any error of @ValidationError@ type. +--liftDate :: MonadError ValidationError m => Day +-- -> ValidationError +-- -> m a +--liftDate date err = throwError $ FinancingError date err + diff --git a/Haslo/InstalmentPlan.hs b/Haslo/InstalmentPlan.hs new file mode 100644 --- /dev/null +++ b/Haslo/InstalmentPlan.hs @@ -0,0 +1,101 @@ +--------------------------------------------------------- +-- +-- Module : InstalmentPlan +-- Copyright : Bartosz Wójcik (2010) +-- License : BSD3 +-- +-- Maintainer : bartek@sudety.it +-- Stability : Unstable +-- Portability : portable +-- +-- | This module implements 'InstalmentPlan' data type. +--------------------------------------------------------- +module Haslo.InstalmentPlan +where +import Haslo.BasicType +import Text.PrettyShow + + +-- | Single instalment details. +-- Single instalment is always balanced - see @instalmentCheck@. +data Instalment = I { iAmt :: Amount -- ^ installment amount + , iRepayment :: Amount -- ^ repayment + , iInterest :: Interest -- ^ interest calculated over the full period + , iIntPaid :: Amount -- ^ interest paid with installment + } + deriving (Eq,Ord) + +instance Show Instalment where + show (I i c int iP) = showAmtWithLen 10 i ++ "=" + ++ showAmtWithLen 10 c ++ "+" + ++ showAmtWithLen 8 iP ++ "; " + ++ show (int / 100) + + + + +-- | Single element of 'InstalmentPlan'. +-- One element of instlment plan contains following ideas: +-- - details of instalment (see above) +-- - principal after instalment has matured +-- - late not yet paid interest (which are base for interest accrual) +-- - interest rate of current instalment +data InstalmentPlanLine = IPL { iplInst :: Instalment -- ^ Instalment itself + , iplPrincipal :: Amount -- ^ Principal after + , iplIntLate :: Interest -- ^ Sum of not paid late interest after current instalment + , iplRate :: Rate -- ^ Nominal interest rate + } + deriving (Eq,Ord) + +instance Show InstalmentPlanLine where + show (IPL i c iL r) = "(" ++ show i ++ ") " + ++ showAmtWithLen 11 c ++ " " + ++ show (iL / 100) ++ " " + ++ show r + + + +-- | Plan of instalments reflects whole life of loan. Following rules are implemented: +-- +-- * All instalments are regular duration. Duration is not stored within instalment plan. +-- +-- * Each instalment can have its own interest rate which is stored within each row separately. +-- +-- * Any payments postponements like first intalment postponement are implemented as +-- usual instalment with instalment amount equal 0. +type InstalmentPlan = [InstalmentPlanLine] + + +-- | Unwraps list of instalment amounts from InstalmentPlan +instList :: InstalmentPlan -> [Amount] +instList = map (iAmt . iplInst) + +-- | Initial principal of a loan +initPrincipal :: InstalmentPlan -> Amount +initPrincipal ip = iplPrincipal ipl + (iRepayment . iplInst) ipl + where ipl = head ip + +-- | Folded instalment plan is another view of the loan. +-- It folds all instalments of same amount and interest rate into one entry of given duration. +type FoldedInstalmentPlan = [FoldedInstalmentPlanLine] + +-- | One entry of @FoldedInstalmentPlan@. +data FoldedInstalmentPlanLine = FIPL { fiplAmt :: !Amount -- ^ Instalment amount. + , fiplDur :: !Duration -- ^ Number of such instalments in this series. + , fiplRate :: !Rate -- ^ Interest rate of series. + } + deriving (Eq, Ord, Show) + + +-- | Folds @InstalmentPlan@ to @FoldedInstalmentPlan@ +foldIP :: InstalmentPlan -> FoldedInstalmentPlan +foldIP [] = [] +foldIP (ipl : ip) = foldIP' ip [iplToFipl ipl] + where iplToFipl (IPL (I a _ _ _) _ _ r) = FIPL a 1 r + incDuration (FIPL a n r) = FIPL a (n+1) r + foldIP' [] result = reverse result + foldIP' (ipl : ip) (x:xs) | a == fiplAmt x && r == fiplRate x = foldIP' ip (incDuration x : xs) + | otherwise = foldIP' ip (iplToFipl ipl : x : xs) + where a = (iAmt $ iplInst ipl) + r = (iplRate ipl) + diff --git a/Haslo/InstalmentPlanProps.hs b/Haslo/InstalmentPlanProps.hs new file mode 100644 --- /dev/null +++ b/Haslo/InstalmentPlanProps.hs @@ -0,0 +1,219 @@ +--------------------------------------------------------- +-- +-- Module : InstalmentPlanProps +-- Copyright : Bartosz Wójcik (2010) +-- License : BSD3 +-- +-- Maintainer : bartek@sudety.it +-- Stability : Unstable +-- Portability : portable +-- +-- | This module implements properities of 'InstalmentPlan'. +--------------------------------------------------------- +module Haslo.InstalmentPlanProps ( instalmentPlanCheck + ,instalmentPlanLineCheck + ,instalmentPlanCheckM + ,instalmentPlanLineCheckM + ,initIPL + ,rateCheckTruncated + ,rateCheckTruncatedM + ,rateCheckRounded + ,rateCheckRoundedM + ) +where + +import Haslo.BasicType +import Haslo.CalcCalendar +import Haslo.CalcConstructors +import Haslo.ErrorHandling +import Haslo.Parameters +import Haslo.InstalmentPlan +--import CalcConfigurationType + +-- | Condition each installment has to fulfil +instalmentCheck :: Instalment -> Bool +instalmentCheck i = iAmt i == iRepayment i + iIntPaid i + +-- | Control function with diagnostic for humans. +instalmentCheckM :: Instalment -> ValidMonad () +instalmentCheckM i | iAmt i == iRepayment i + iIntPaid i = return () + | otherwise = throwError $ InstalmentDiscrepancy + (iAmt i) + (iRepayment i) + (iIntPaid i) + +-- | For control purposes artificial initial 'InstalmentPlanLine' has to be constructed +initIPL :: Amount -> Interest -> InstalmentPlanLine +initIPL cap iL = (IPL (I 0 0 0 0) cap iL 0) + +-- | Condition, each InstalmentPlanLine fulfills before financing. +instalmentPlanLineCheck :: Amount + -> Interest + -> InstalmentPlanLine + -> Bool +instalmentPlanLineCheck capBefore lateIntBefore ipl = + abs ((fromIntegral capBefore + lateIntBefore) * iplRate ipl - (iInterest . iplInst) ipl) < 1e-4 && + abs (lateIntBefore - (fromIntegral . iIntPaid . iplInst) ipl + + (iInterest . iplInst) ipl + - iplIntLate ipl) < 1e-2 && + capBefore - (iRepayment . iplInst) ipl == iplPrincipal ipl && + (instalmentCheck . iplInst) ipl + +-- | Control function with diagnostic for humans. +instalmentPlanLineCheckM :: InstalmentPlanLine + -> InstalmentPlanLine + -> ValidMonad InstalmentPlanLine +instalmentPlanLineCheckM ipl1 ipl2 = + (instalmentCheckM . iplInst) ipl2 >> checkInterestM >> checkLateInterestM >> checkCapitalAfterM + where checkInterestM | abs (intReCalcul - intStored) < 1e-2 = return ipl2 + | otherwise = throwError $ IPLInterest capBefore + lateIntBefore + intStored + (iplRate ipl2) + checkLateInterestM | checkLateInterest = return ipl2 + | otherwise = throwError $ FollowUpInterestError errorLateInt + lateIntBefore + (iInterest $ iplInst ipl2) + (iIntPaid $ iplInst ipl2) + (iplIntLate ipl2) + checkCapitalAfterM | checkCapitalAfter = return ipl2 + | otherwise = throwError $ FollowUpError errorPrincipal + capBefore + (iRepayment $ iplInst ipl2) + (iplPrincipal ipl2) + intReCalcul = ((fromIntegral capBefore + lateIntBefore) * iplRate ipl2) + intStored = (iInterest . iplInst) ipl2 + checkLateInterest = abs (lateIntBefore - (fromIntegral . iIntPaid . iplInst) ipl2 + + (iInterest . iplInst) ipl2 + - iplIntLate ipl2) < 1e-2 + checkCapitalAfter = capBefore - (iRepayment . iplInst) ipl2 == iplPrincipal ipl2 + capBefore = iplPrincipal ipl1 + lateIntBefore = iplIntLate ipl1 + errorLateInt = "IPL discrepancy: late interest before + interest calculated -\ + \ interest paid /= late interest after" + errorPrincipal = "IPL discrepancy: principal before - principal matured /= principal after" + +-- | Checks if all lines of installment plan fulfill their +-- validation rules. +instalmentPlanCheck :: Amount -- ^ Initial principal + -> Interest -- ^ Initial late interest (usually 0) + -> InstalmentPlan -- ^ Instalment Plan to be checked + -> Bool +instalmentPlanCheck cap iL ip = (\(x,cf,iLf,i,r) -> x && -- All rows of instlment plan are OK + (cf == 0 || -- Amortizes properly to 0 + cf < fromIntegral (length ip) && r == 0) && + abs iLf < 1e-2) $ -- There is no late interest left + foldl check (True, cap, iL, I 0 0 0 0, 0) ip + where check :: (Bool,Amount,Interest,Instalment,Rate) + -> InstalmentPlanLine + -> (Bool,Amount,Interest,Instalment,Rate) + check (bool,cap,iL,_,_) ipl = (bool && instalmentPlanLineCheck cap iL ipl + ,iplPrincipal ipl + ,iplIntLate ipl + ,iplInst ipl + ,iplRate ipl) + +-- | Control function with diagnostic for humans. +instalmentPlanCheckM :: Amount -- ^ Initial principal + -> Interest -- ^ Initial late interest (usually 0) + -> InstalmentPlan -- ^ Instalment Plan to be checked + -> ValidMonad () +instalmentPlanCheckM cap iL ip = foldM instalmentPlanLineCheckM (IPL (I 0 0 0 0) cap iL 0) ip + >>= lastCheck + where lastCheck (IPL i c iL r) | abs iL > 1e-2 = throwError $ NotPaidDefferedInterest iL ip + | r > 0 && c /= 0 = throwError $ NotAmortized c ip + | r == 0 && c > fromIntegral (length ip) = throwError $ NotAmortized c ip + | otherwise = return () + +-- | Checks whether instalment plan is complete, i.e. if there is no +-- remaining principal. +isInstalmentPlanComplete :: InstalmentPlan -> Bool +isInstalmentPlanComplete ip = (iplPrincipal. last) ip <= 0 + +-- All loans with fixed interest rate have to fulfil following: +-- If Truncated: interest rate is <= that given one. +-- Add 1 to each instalment amount, recalculate interest rate and check that +-- it's greater than given one. +-- If Rounded: if interest rate > given one: subtract 1 from each instalment amount, recalculate +-- interest rate and check that it's < given one. +-- if interest rate < given one: add 1 to each instalment amount, recalculate +-- interest rate and check that it's > given one. + +-- | Checks recalculated interest rate against original one. +-- Works only for parameters where @Truncated@ is selected. +rateCheckTruncated :: Amount -- ^ Initial principal + -> Interest -- ^ Initial late interest (usually 0) + -> Rate -- ^ Initial interest rate in nominal format. + -> InstalmentPlan -- ^ Instalment Plan to be checked + -> ValidMonad Bool +rateCheckTruncated p iL r ip = liftM (iplRate . head) (newLoanRILPlus p iL 1 ip) >>= \r'' -> + (return $ r' - r <= e1 && r'' > r) + where r' = iplRate $ head ip + +e1 = 1e-9 + +-- | Checks recalculated interest rate against original one. +-- Works only for parameters where @Rounded@ is selected. +rateCheckRounded :: Amount -- ^ Initial principal + -> Interest -- ^ Initial late interest (usually 0) + -> Rate -- ^ Initial interest rate in nominal format. + -> InstalmentPlan -- ^ Instalment Plan to be checked + -> ValidMonad Bool +rateCheckRounded p iL r ip | r == 0 = return True + | r' > r = liftM (iplRate . head) (newLoanRILPlus p iL (-1) ip) >>= \r'' -> + (return $ r'' < r) + | r' < r = liftM (iplRate . head) (newLoanRILPlus p iL 1 ip) >>= \r'' -> + (return $ r'' > r) + | otherwise = return True + where r' = iplRate $ head ip + +-- | Like @rateCheckTruncated@ with diagnostics for humans +rateCheckTruncatedM :: Amount -- ^ Initial principal + -> Interest -- ^ Initial late interest (usually 0) + -> Rate -- ^ Initial interest rate in nominal format. + -> InstalmentPlan -- ^ Instalment Plan to be checked + -> ValidMonad InstalmentPlan +rateCheckTruncatedM p iL r ip = liftM (iplRate . head) (newLoanRILPlus p iL 1 ip) >>= \r'' -> + case r' - r <= e1 && r'' > r of + True -> return ip + False -> throwError $ OtherError $ "Interest rate not fits." ++ + " Original: " ++ show r ++ + " Recalculated: " ++ show r' ++ + " Of next higher loan: " ++ show r'' + where r' = iplRate $ head ip + +-- | Like @rateCheckRounded@ with diagnostics for humans +rateCheckRoundedM :: Amount -- ^ Initial principal + -> Interest -- ^ Initial late interest (usually 0) + -> Rate -- ^ Initial interest rate in nominal format. + -> InstalmentPlan -- ^ Instalment Plan to be checked + -> ValidMonad InstalmentPlan +rateCheckRoundedM p iL r ip | r == 0 = return ip + | r' > r = liftM (iplRate . head) (newLoanRILPlus p iL (-1) ip) >>= \r'' -> + case r'' < r of + True -> return ip + False -> throwError $ OtherError $ "Interest rate not fits." ++ + " Original: " ++ show r ++ + " Recalculated: " ++ show r' ++ + " Of next higher loan: " ++ show r'' + | r' < r = liftM (iplRate . head) (newLoanRILPlus p iL 1 ip) >>= \r'' -> + case r'' > r of + True -> return ip + False -> throwError $ OtherError $ "Interest rate not fits." ++ + " Original: " ++ show r ++ + " Recalculated: " ++ show r' ++ + " Of next higher loan: " ++ show r'' + | otherwise = return ip + where r' = iplRate $ head ip + + +-- | Adds given amount to each istalment and recalculates the InstalmentPlan. +newLoanRILPlus :: Amount + -> Interest + -> Amount + -> InstalmentPlan + -> ValidMonad InstalmentPlan +newLoanRILPlus p iL delta = newLoanRIL iL p . map (+| delta) . instList + where a +| b | a + b < 0 = 0 + | otherwise = a + b + diff --git a/Haslo/Parameters.hs b/Haslo/Parameters.hs new file mode 100644 --- /dev/null +++ b/Haslo/Parameters.hs @@ -0,0 +1,135 @@ +--------------------------------------------------------- +-- +-- Module : Parameters +-- Copyright : Bartosz Wójcik (2010) +-- License : BSD3 +-- +-- Maintainer : bartek@sudety.it +-- Stability : Unstable +-- Portability : portable +-- +-- Parameters hidden in the reader monad +--------------------------------------------------------- + +module Haslo.Parameters (IPPMonad + ,runWithIPP + ,InstalmentPlanParam (..) + ,paramDT + ,paramMT + ,paramYT + ,paramDR + ,paramMR + ,paramYR + ) +where + +import Control.Monad.Reader +import Haslo.ErrorHandling +import Haslo.CalcCalendar + +type ParamMonad = ReaderT Param IPPMonad + +runWithParam param loan = runReaderT loan param + +data Param = Param + {ipp :: InstalmentPlanParam + ,fin :: FinancingParameters + } + deriving Show + +-- | Parameters for loan construction. They have been separated, because they +-- usually do not change often, if at all. +data InstalmentPlanParam = IPP + {freq :: Freq + ,rounding :: RoundingType + } + deriving Show + +-- | Reader monad for IPP -- to run loan with parameters. +type IPPMonad = ReaderT InstalmentPlanParam ValidMonad + +-- | Convenience function. +runWithIPP :: InstalmentPlanParam -> IPPMonad a -> ValidMonad a +runWithIPP param loan = runReaderT loan param + +absParamMonthlyTrunc = IPP Monthly Truncated +absParamDailyTrunc = IPP Daily Truncated +absParamYearlyTrunc = IPP Yearly Truncated + +-- | Rule of 1st instalment date as function of last financing tranche's date. +data FstInstRule = FstInstDays Int -- ^ Not less than given number of days after. + | FstInstFullFreqAfter -- ^ at least one full 'instFreq' period after, less than two periods. + deriving (Eq,Show) + +instance Enum FstInstRule where + toEnum 0 = FstInstFullFreqAfter + toEnum n = FstInstDays n + + fromEnum FstInstFullFreqAfter = 0 + fromEnum (FstInstDays n) = n + +-- | Rule of calculation and maturity of interest for first period of the loan +-- from 1st tranche date till one instalment period before first instalment. +data FstIntRule = + + -- | Interest is calculated daily. + -- Mature on each instalment day. + FstIntDaily + + -- | Interest is calculated from tranche date till next instalment day, if next instalment + -- day is before first instalment date. + -- Interest matures on each instalment day. + | FstIntTillNextDue + + -- | Interest is calculated from tranche date till first instalment date. + -- Interest matures on first instalment date. + | FstIntTill1stInst + + -- | Interest is calculated from tranche date till first instalment date + -- which amount > 0. All instalments = 0 before have to be removed. Date of + -- first >0 instalment doesn't change though. + -- Interest matures on date of first >0 instalment. + | FstIntTill1stInstGT0 + + -- | Proprietary solution. + -- Interest is calculated and matures like for @FstIntTill1stInstGT0@, the difference + -- is that common nominal interest rate is re-caluclated using real number of days of + -- between tranche date and first instalment date. In this solution only one tranche is + -- alowed. + | FstIntCtlm + deriving (Eq,Show,Enum) + +-- | Rule defining what to do with late interest coming out of grace period. +data LateIntOfGracePeriodRule = + + -- | Late interest will be due on first instalment - will increase its amount. + LateIntFstInst + + -- | Late interest will be due on first significant instalment - will increase its amount. + | LateIntFstSignInst + + -- | Late interest will be due on last instalment - will increase its amount. + | LateIntLastInst + deriving (Eq,Show) + +-- | Collection of parameters customizing financing. +data FinancingParameters = FP { + instFreq :: Freq -- ^ Frequency of instalment must be >= than @intFreq@ + , intFreq :: Freq -- ^ Frequency of interest + , fin1stInstRule :: FstInstRule + , fin1stIntRule :: FstIntRule + , finCalendar :: CalendarType -- ^ calendar type + , lateIntRule :: LateIntOfGracePeriodRule + } + deriving (Eq,Show) + +paramDT = IPP Daily Truncated +-- | Monthly Truncated +paramMT :: InstalmentPlanParam +paramMT = IPP Monthly Truncated +paramYT = IPP Yearly Truncated +paramDR = IPP Daily Truncated +paramMR = IPP Monthly Rounded +-- | Yearly Rounded +paramYR :: InstalmentPlanParam +paramYR = IPP Yearly Rounded diff --git a/HasloQC.hs b/HasloQC.hs new file mode 100644 --- /dev/null +++ b/HasloQC.hs @@ -0,0 +1,72 @@ +--------------------------------------------------------- +-- +-- Module : HasloQC +-- Copyright : Bartosz Wójcik (2012) +-- License : BSD3 +-- +-- Maintainer : bartek@sudety.it +-- Stability : Unstable +-- Portability : portable +-- +-- Part of haslo. Quick Check of all necessary functions. +--------------------------------------------------------- + +module Main +where + +import Haslo +import Haslo.HasloQCTestL +import Data.IORef +import Data.List +import Data.Time +import Control.Monad.Reader +import Test.QuickCheck + + +main = do + putStrLn "Test suite run. It may take up to several minutes time." + myRun "Checking interest rate" heavyArgs propRate + myRun "Checking rate conversion" myArgs prop_cEN + myRun "Checking abstract amortization table" veryHeavyArgs propInstPlan +-- myRun "Checking AMOR T" myArgs propInstPlanM + + +myRun txt args prop = do + putStr $ txt ++ " - " ++ show (maxSize args) ++ " random tests" + putStrLn " ... " + quickCheckWith args prop + +veryHeavyArgs = Args + { replay = Nothing + , maxSuccess = 100000 + , maxDiscard = 7000 + , maxSize = 100000 + , chatty = True +-- noShrinking flag? + } + +heavyArgs = Args + { replay = Nothing + , maxSuccess = 10000 + , maxDiscard = 7000 + , maxSize = 10000 + , chatty = True +-- noShrinking flag? + } + +myArgs = Args + { replay = Nothing + , maxSuccess = 300 + , maxDiscard = 2500 + , maxSize = 300 + , chatty = True +-- noShrinking flag? + } + +patientArgs = Args + { replay = Nothing + , maxSuccess = 300 + , maxDiscard = 10000 + , maxSize = 300 + , chatty = True +} diff --git a/Sample.hs b/Sample.hs new file mode 100644 --- /dev/null +++ b/Sample.hs @@ -0,0 +1,32 @@ +--------------------------------------------------------- +-- +-- Module : Sample +-- Copyright : Bartosz Wójcik (2011) +-- License : BSD3 +-- +-- Maintainer : bartek@sudety.it +-- Stability : Unstable +-- Portability : portable +-- +-- Part of haslo. Quick Check sample test cases. +--------------------------------------------------------- + +module Main +where + +import Haslo +import Haslo.HasloQCTestL +import Data.IORef +import Data.List +import Data.Time +import Control.Monad.Reader +import Test.QuickCheck + +main = putStrLn "Product \ + \Princip. \ + \Dur \ + \De \ + \Rate \ + \(Balloon) \ + \Parameters" >> + sample (arbitrary :: Gen TestL) diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/haslo.cabal b/haslo.cabal new file mode 100644 --- /dev/null +++ b/haslo.cabal @@ -0,0 +1,38 @@ +Name: haslo +Version: 0.1 +License: BSD3 +License-file: license +Author: Bartosz Wojcik +Maintainer: Bartosz Wojcik +Copyright: Copyright (c) 2011 Bartosz Wojcik +Category: Financial +Synopsis: Loan calculator engine. +Stability: experimental +Build-type: Simple +Description: Loan calculator engine implementing rules mentioned in paper "Haskell Loan Library". + See more here: https://github.com/bartoszw/haslo/blob/master/haslo.pdf. + Acronym from Haskell Loan. + +Cabal-Version: >=1.2.3 + +library + Build-Depends: base >= 3 && < 5, old-time, wtk, mtl + Exposed-Modules: Haslo + Other-Modules: Haslo.BasicType, + Haslo.CalcCalendar, + Haslo.Parameters, + Haslo.ErrorHandling, + Haslo.InstalmentPlan, + Haslo.InstalmentPlanProps, + Haslo.CalcConfigurationType, + Haslo.CalcConstructors, + Haslo.Calculator + +Executable hasloQC + Build-Depends: old-time, QuickCheck, mtl, time, wtk + Main-Is: HasloQC.hs + +Executable hasloSample + Build-Depends: old-time, QuickCheck, mtl, time, wtk + Main-Is: Sample.hs + diff --git a/license b/license new file mode 100644 --- /dev/null +++ b/license @@ -0,0 +1,31 @@ +Copyright (c) 2012, Bartosz Wójcik + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Isaac Jones nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.