{-# 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