{-# LANGUAGE FlexibleInstances #-}
{-# OPTIONS_GHC -fno-warn-missing-methods -fno-warn-orphans #-}
import Prelude
import Data.List
import Text.Printf
import Control.Monad
-- Main
data Verbosity = Verbose | Quiet deriving Eq
main = runScenarios sampleMortgage overpaySchemes Verbose where
sampleMortgage = Mortgage (1000 Pounds) (annualRate 5) (10 Years)
overpaySchemes = [
("2 pm, 200 initial", lumpSumOf (200 Pounds) .+ monthlyPaymentsOf (2 Pounds))
, ("2 pm only", monthlyPaymentsOf (2 Pounds))
, ("200 initial", lumpSumOf (200 Pounds))
, ("400 initial", lumpSumOf (400 Pounds))
, ("200 after 2y", lumpSumOf (200 Pounds) `after` 2 Years)
, ("400 after 2y", lumpSumOf (400 Pounds) `after` 2 Years)
]
runScenarios myMortgage overpayScenarios verbosity = do
let baseline = analyze $ expandOverpayment myMortgage noPayments
printf "We are looking at %s, which has required monthly payment of %s\n" (show myMortgage) (show $ requiredRepayment myMortgage)
putStrLn $ "Baseline:\n\t" ++ show baseline
forM_ overpayScenarios $ \(name, overpayScenario) -> do
let expansion = expandOverpayment myMortgage overpayScenario
analysis = analyze expansion
putStrLn $ "Overpayment scenario \"" ++ name ++ "\":\n\t" ++ show analysis ++ "\n\tCompared to baseline: " ++ compareAnalysis baseline analysis
when (verbosity == Verbose) $ mapM_ print expansion
-- Mortgage
data Mortgage = Mortgage { loan :: Currency, loanRate :: Interest, duration :: Period }
instance Show Mortgage where
show m = printf "loan of %s at %s over %s" (show $ loan m) (show $ loanRate m) (show $ duration m)
-- Monthly expansion details
data Cycle = Cycle { month :: Integer,
balanceAtStart :: Currency,
interestAccrued :: Currency,
paymentMade :: Currency,
balanceEnd :: Currency }
instance Show Cycle where
show c = printf "For month %d, balance: %s -> %s\t(interest: %s, payment: %s)"
(month c) (show $balanceAtStart c) (show $ balanceEnd c) (show $ interestAccrued c) (show $ paymentMade c)
expand :: Mortgage -> PaymentSchedule -> [Cycle]
expand mortgage (PS payments) = iterate step initial where
initial = Cycle 0 (loan mortgage) zero zero (loan mortgage)
step before = let thisMonth = month before + 1
balStart = balanceEnd before
interest = balStart .* (toMonthly . loanRate $ mortgage)
thisPayment = payments thisMonth `min` (balStart .+ interest)
bChange = interest .- thisPayment
balEnd = balStart .+ bChange
in Cycle thisMonth balStart interest thisPayment balEnd
-- The finance stuff
compound :: Currency -> Interest -> Integer -> Currency
compound principal rate months = principal .* ((1+toMonthly rate) ^ months)
requiredRepayment :: Mortgage -> Currency
requiredRepayment (Mortgage initial rate duration) =
let mrate = toMonthly rate in
(initial .* mrate) ./ (1 - exp (-1 * fromIntegral (toMonths duration) * log (1.0 + mrate)))
expandOverpayment mortgage overpayments = takeWhile debtRemaining $ drop 1 $ expand mortgage payments
where payments = overpayments .+ monthlyPaymentsOf (requiredRepayment mortgage)
debtRemaining c = toPence (balanceAtStart c) > 0
-- Analysis of total interest and payments
data Analysis = Analysis { totalInterest :: Currency, totalPayments :: Currency, totalDuration :: Period }
instance Show Analysis where
show a = "Total interest: " ++ show (totalInterest a) ++ " Total payments: " ++ show (totalPayments a) ++ " Duration=" ++ show (totalDuration a)
analyze cycles = Analysis (sumOf interestAccrued) (sumOf paymentMade) (PMonths $ fromIntegral $ length cycles)
where sumOf proj = foldl' (.+) zero $ map proj cycles
compareAnalysis (Analysis ti tp td) (Analysis ti' tp' td') =
printf "interest=%s, payments=%s, duration=%s" (show $ ti' .- ti) (show $ tp' .- tp) (show (PMonths ((toMonths td') - (toMonths td))))
-- Common operations: addition and scaling
class Quantity q where
zero :: q
(.+) :: q -> q -> q
(.-) :: q -> q -> q
(.*) :: RealFrac k => q -> k -> q
(./) :: RealFrac k => q -> k -> q
-- Interest rates
data Interest = I Double
instance Show Interest where
show (I i) = show i ++ "%"
annualRate = I
toMonthly (I i) = i/1200
-- Currency; stored as integer number of pence
-- Multiplication/division round result down to nearest whole number of pence
data Currency = C Integer deriving (Ord,Eq)
instance Show Currency where
show (C c) = printf "£%d.%02d" pounds (abs pence)
where (pounds,pence) = quotRem c 100
pounds = C . (* 100)
toPence (C p) = p
instance Quantity Currency where
zero = C 0
(C a) .+ (C b) = C $ a + b
(C a) .* k = C $ floor $ k * fromIntegral a
c ./ k = c .* (1/k)
(C a) .- (C b) = C $ a - b
-- Durations
data Period = PMonths Integer
toMonths (PMonths n) = n
instance Show Period where
show (PMonths n) = show years ++ "y" ++ (if months == 0 then "" else " " ++ show (abs months) ++ "m")
where (years,months) = quotRem n 12
-- Payment schedules - function from month number to amount
data PaymentSchedule = PS (Integer -> Currency)
amount `every` (PMonths period) = PS $ \n -> if n `rem` period == 0 then amount else zero
instance Quantity PaymentSchedule where
zero = PS $ \n -> C 0
(PS p) .+ (PS p') = PS $ \n -> p n .+ p' n
(PS p) .- (PS p') = PS $ \n -> p n .- p' n
(PS p) .* k = PS $ \n -> p n .* k
(PS p) ./ k = PS $ \n -> (p n) .* (1/k)
noPayments = zero
monthlyPaymentsOf amount = amount `every` (1 Months)
lumpSumOf p = PS $ \n -> if n == 1 then p else zero
(PS ps) `after` (PMonths delay) = PS $ \n -> ps (n-delay)
-- Hacks
data MONEY = Pounds | Pence
instance Eq (MONEY -> Currency)
instance Show (MONEY -> Currency)
instance Num (MONEY -> Currency) where
fromInteger i Pounds = C (i * 100)
fromInteger i Pence = C i
data DURATION = Months | Month | Years | Year
instance Eq (DURATION -> Period)
instance Show (DURATION -> Period)
instance Num (DURATION -> Period) where
fromInteger i Months = PMonths i
fromInteger i Month = PMonths i
fromInteger i Years = PMonths $ i * 12
fromInteger i Year = PMonths $ i * 12