Amortization Calculator
This is an amortization calculator I wrote using Perl/Tk.
s''(q.S:$/9=(T1';s;(..)(..);$..=substr+crypt($1,$2),2,3;eg;print$..$/
You can use it to calculate, for example, the principal and interest payments you would have to make on a mortgage for a house.
The program has 3 basic sections: The upper left shows program variables, the upper right is a graph of the interest/principal paid over the life of the loan, and the bottom is the full payment schedule, which may be saved to disk.
Here is the program itself:
#!/usr/bin/perl -w
#
# Amortization (loan) calculation program
#
# 060806 by liverpole
#
###############
### Strict ###
###############
use strict;
use warnings;
####################
### User-defined ###
####################
my $title = "Mortgage Calculator V4.0 (060806) liverpole";
my $schedout = "mortgage.txt";
my @gcolors = qw( red gold magenta );
# Limiting values
my $min_years = 1; # Minimum number of years
my $max_years = 100; # Maximum number of years
my $min_rate = 0.01; # Minimum interest rate
my $max_rate = 100.0; # Maximum interest rate
#################
### Libraries ###
#################
use FileHandle;
use File::Basename;
use Tk;
use Tk::DialogBox;
###############
### Globals ###
###############
my ($loan, $rate, $period, $years, $npay, $extra, $newyear, $newpay);
my ($o_loan, $o_rate, $o_period, $o_years, $o_npay);
my ($o_extra, $o_newyear, $o_newpay);
my ($payment, $total, $tot_paid, $tot_prin, $tot_int, $pct_int, $maxpay);
my $payments = [ ];
my @glist;
my $use_defaults = 0;
my $iam = basename($0);
#######################
### Package textbox ###
#######################
package textbox;
our $AUTOLOAD;
my $ptags = {
'-1' => 'debug',
'0' => 'default',
'1' => 'warning',
'2' => 'error',
};
my $plevels = {
'-1' => '[debug]',
'0' => ' [info]',
'1' => ' [warn]',
'2' => '[error]',
};
###############################################################################
# new(): textbox constructor. Parameters are:
#
# $1 ... The textbox object
# $2 ... The parent window
# $3 ... The textbox width
# $4 ... The textbox height
# $5 ... The textbox color
# $6 ... The textbox default font
# $7 ... A flag which, if nonzero, disables the textbox
# $8 ... Scrollbar location (defaults to optional-south + optional-east)
#
# Return value: The textbox object
###############################################################################
sub new {
my ($obj, $win, $width, $height, $bg, $font, $b_dis, $sb_loc) = @_;
$win or return;
my $mw = $win->toplevel();
$width ||= 0;
$height ||= 0;
$bg ||= 'white';
$font ||= 0;
$b_dis ||= 0;
$sb_loc ||= "osoe";
my $tbox = $win->Scrolled('Text', -bg => $bg, -scrollbars => $sb_loc);
$tbox->configure(-wrap => 'none', -takefocus => 0);
$width && $tbox->configure(-width => $width);
$height && $tbox->configure(-height => $height);
my $state = ($b_dis)? 'disabled': 'normal';
$tbox->configure(-state => $state);
$tbox->pack(-side => 'left', -expand => '1', -fill => 'both');
my $this = {
'mw' => $mw, # Toplevel window
'win' => $win, # Parent window
'widget' => $tbox, # The textbox widget
'font' => $font, # The textbox font
'bg' => $bg, # The textbox background color
'tags' => { }, # The defined tags
'state' => $state, # The state (disabled or normal)
};
# Bless the object
bless $this, $obj;
# Create the default fonts
$this->create_tag('debug', $font, 'grey', 'black');
$this->create_tag('default', $font, $bg, 'black');
$this->create_tag('error', $font, 'red3', 'white');
$this->create_tag('warning', $font, 'sandybrown', 'black');
return $this;
}
###############################################################################
# DESTROY(): textbox destructor. Parameters are:
#
# $1 ... The textbox object
###############################################################################
sub DESTROY {
my ($this) = @_;
my $tbox = $this->{'widget'};
$tbox and $tbox->packForget();
}
###############################################################################
# AUTOLOAD: this simply calls the given subroutine on the underlying
# widget, and passes on the passed arguments. For example, this lets you
# do the following:
#
# my $tb = new textbox($db, 80, 40, 'gray', 0, 1);
# $tb->configure(-state => 'normal');
# $tb->insert('end', 'Hello world!');
# $tb->configure(-state => 'disabled');
# $tb->yview('1.0');
#
# $1 ... The textbox object
###############################################################################
sub AUTOLOAD {
my ($this, @params) = @_;
my $name = $AUTOLOAD;
$name =~ s/.*:://;
$this->{'widget'}->$name(@params);
};
#########################
### Other subroutines ###
#########################
#
# create_tag: creates the given tag with a specified font, background
# color, and foreground color, for use with the textbox. The tag is not
# created if it already exists for the object. If a label is not given
# for the tag, a label is created out of the font, background and foreground
# color names. Parameters are:
#
# $1 ... The textbox object
# $2 ... The label for the font
# $3 ... The name of the font (optional)
# $4 ... The background color (optional)
# $5 ... The foreground color (optional)
#
sub create_tag {
my ($this, $label, $font, $bg, $fg) = @_;
$label or $label = "${font}_${bg}_${fg}";
return if defined($this->{'tags'}->{$label});
$this->{'tags'}->{$label} = 1;
my $tbox = $this->{'widget'};
$font ||= $this->{'font'};
$bg ||= 0;
$fg ||= 0;
$font and $tbox->tagConfigure($label, -font => $font);
$bg and $tbox->tagConfigure($label, -background => $bg);
$fg and $tbox->tagConfigure($label, -foreground => $fg);
};
#
# out: writes the given text to the text box. Parameters are:
#
# $1 ... The textbox object
# $2 ... The text to write (or list of lines of text)
# $3 ... The tag to use (if different from the default)
# $4 ... The level if no tag given (-1=debug, 0=info, 1=warning, 2=error)
# $5 ... An EOL flag which, if nonzero, suppresses the end-of-line
# $6 ... An update flag which, if nonzero, suppresses the gui update.
#
sub out {
my ($this, $ptext, $tag, $level, $b_no_eol, $b_no_update) = @_;
$level ||= 0;
$b_no_eol ||= 0;
$b_no_update ||= 0;
(ref $ptext eq 'ARRAY') or $ptext = [ $ptext ];
if (!$tag) {
$tag = $ptags->{$level} || 'default';
}
my $tbox = $this->{'widget'};
$tbox->configure(-state => 'normal');
(@$ptext > 0) or return;
($b_no_eol) and map { $tbox->insert('end', "$_", $tag); } @$ptext;
($b_no_eol) or map { $tbox->insert('end', "$_\n", $tag); } @$ptext;
$tbox->configure(-state => $this->{'state'});
$tbox->yview('end');
$b_no_update or $this->{'mw'}->update();
return 0;
};
#
# log: similar to out(), except that the current time and level name are
# displayed as part of the message, and no tag is passed.
#
# $1 ... The textbox object
# $2 ... The text to write (or list of lines of text)
# $3 ... The tag to use (if different from the default)
# $4 ... The level if no tag given (-1=debug, 0=info, 1=warning, 2=error)
# $5 ... An EOL flag which, if nonzero, suppresses the end-of-line
# $6 ... An update flag which, if nonzero, suppresses the gui update.
#
sub log {
my ($this, $ptext, $level, $b_no_eol, $b_no_update) = @_;
my $ctime = localtime(time);
$ctime =~ s/\S+\s+(... .. \d+:\d+:\d+).+/$1/;
my $tag = $ptags->{$level} || 'default';
my $ltext = $plevels->{$level} || $plevels->{0};
my $p = [ ];
if (ref $ptext eq 'ARRAY') {
map { push @$p, "$ctime $_" } @$ptext;
} else {
$p = [ "$ctime $ltext $ptext" ];
}
return $this->out($p, $tag, $level, $b_no_eol, $b_no_update);
};
#
# get: gets the text in the text box. Parameters are:
#
# $1 ... The textbox object
#
sub get {
my ($this) = @_;
my $tbox = $this->{'widget'};
my $ptext = $tbox->get('1.0', 'end');
chomp $ptext;
return $ptext;
};
#
# clear: clears the text box. Parameters are:
#
# $1 ... The textbox object
#
sub clear {
my ($this) = @_;
my $tbox = $this->{'widget'};
my $mw = $this->{'mw'};
$tbox->configure(-state => 'normal');
$tbox->delete('1.0', 'end');
$tbox->configure(-state => $this->{'state'});
$mw->update();
};
#
# bind: simply binds the given key to the textbox widget. Parameters are:
#
# $1 ... The textbox object
# $2 ... The key to bind
# $3 ... The subroutine to invoke
#
sub bind {
my ($this, $key, $psub) = @_;
my $tbox = $this->{'widget'};
$tbox->bind($key, $psub);
};
# End of package "textbox"
####################
### Package help ###
####################
package help;
my $help = "
OVERVIEW
This program calculates an amortization schedule, based on the following
user-supplied variables:
(loan) L = original loan amount
(rate) R = yearly interest rate (as a percentage)
(period) P = periods per year (eg. 12 = monthly)
(years) Y = number of years
(extra) X = extra amount paid to reduce the mortgage
and the following program-calculated variables:
F = factor loan grows by each period = 1 + (R / P)
N = number of payments = Y * P
A = amount of periodic payment (see formula for 'A' below)
T = total amount paid = A * N
M = monthly interest paid
I = total amount of interest paid
The program also calculates how the number of periods can be altered,
depending on an extra amount X paid each period.
The basic formula for calculating A (the amount owed each period) is:
A = L(F^N)(F-1) / (F^N - 1)
The monthly interest M is:
M = L * (R / P) (which is: new_balance - previous_balance)
The total amount paid will be:
T = (A * N) + X * (N - S)
of which the total interest paid will be:
I = T - L
Try changing any of the values in the upper-left box of the application,
to see how they affect the entire payment schedule. Set the desired
values for:
Loan Amount
Annual % interest rate
Period (12 = each month)
Base # of years
Base # of payments
Extra payment amount
and observe the corresponding changes to the values for:
Payment Amount
Total interest payments
Total principal payments
Total amount paid
Interest as % of total
You can change the 'Extra payment amount' to see how much earlier the
loan would be paid off when making additional payments each period (the
new values cannot be larger than the values of 'Base # of years' and
'Base # of payments', though).
To reset the program variables, type '^R' or press the button marked
'Reset Variables'.
To save the payment schedule to a file (eg. for printing), type '^S' or
press the button marked 'Save Schedule'.
To exit the program, type , or press the button marked 'Exit'.
";
#
# new -- help constructor. Parameters are:
#
# $1 ... The help object
# $2 ... The parent window
# $3 ... The button text (0 = no button)
# $4 ... The button color (0 = default)
# $5 ... The button pack style
# $6 ... The help message title
# $7 ... The help message text
# $8 ... The help message width (defaults to 40)
# $9 ... The help message height (defaults to 80)
#
# Return value: The help object
#
sub new {
my ($obj, $win, $btext, $bcolor, $pack, $key, $title, $msg, $w, $h) = @_;
my $mw = $win->toplevel();
$w ||= 80;
$h ||= 40;
my $this = {
'mw' => $mw, # Toplevel window
'win' => $win, # Parent window
'key' => $key, # The accelerator key
'title' => $title, # The help title
'msg' => $msg, # The help message
'width' => $w, # The help message width
'height' => $h, # The help message height
};
#
# Create an anonymous subroutine to display the help dialog box.
# Create a button to call the function if button text was supplied,
# and create an accelerator key to call it if a key was supplied.
#
my $pfunc = sub { $this->give_help() };
$btext and &main::button($win, $btext, $bcolor, $pfunc, 0, $pack);
($key =~ /^[fF]([0-9]+)$/) and $key = "";
$key and $mw->bind($key, $pfunc);
# Bless the object
bless $this, 'help';
return $this;
}
#
# give_help: displays the actual help message in a dialog box for
# the user to peruse.
#
sub give_help {
(@_ > 1) and shift; # Throw away event, if triggered by a button
my ($this) = @_;
my $mw = $this->{'mw'};
my $title = $this->{'title'};
my $width = $this->{'width'};
my $height = $this->{'height'};
my $db = $mw->DialogBox(-title => $title, -buttons => [ "OK" ]);
my $tb = new textbox($db, $width, $height, 'gray', 0, 1);
$tb->configure(-state => 'normal');
$tb->insert('end', $this->{'msg'});
$tb->configure(-state => 'disabled');
$tb->yview('1.0');
$db->Show();
$mw->update();
}
# End of package "help"
####################
### Main program ###
####################
package main;
reset_values();
gui_mode();
###################
### Subroutines ###
###################
sub reset_values {
$o_loan = $loan = 100000;
$o_rate = $rate = 5.0;
$o_period = $period = 12;
$o_years = $years = 30;
$o_npay = $npay = $years * $period;
$o_extra = $extra = 0;
$o_newyear = $newyear = $years;
$o_newpay = $newpay = $npay;
find_payment();
}
sub summary {
my ($extra, $np, $P) = @_;
my $years = (0 == $P)? 0: ($np / $P);
printf "\nExtra payment[\$%.2f]: Nperiods = %d (%3.1f years)\n\n",
$extra, $np, $years;
}
sub calc_payment {
my ($L, $R, $P, $N) = @_;
my $F = 1 + ($R / 100.0 / $P);
my $A = $L * ($F ** $N) * ($F - 1) / ($F ** $N - 1);
my $result = sprintf "%.2f", $A;
return $result;
}
sub commas {
my ($val) = @_;
$val =~ s/,//g;
$val = sprintf "%.2f", $val;
$val =~ s/(?<=\d)(\d{3})(?=(,\d{3}|\.))/,$1/g;
return $val;
}
sub schedule_header {
my ($rate) = @_;
my $text = sprintf "Year ";
$text .= sprintf "Period ";
$text .= sprintf "Starting ";
$text .= sprintf "+ %6.4f%% ", $rate;
$text .= sprintf "Payment ";
$text .= sprintf "Extra ";
$text .= sprintf "Ending ";
$text .= sprintf "Interest ";
$text .= sprintf "Total int";
return $text;
}
sub enforce_limits {
my ($pvar, $min, $max) = @_;
if ($$pvar < $min) {
$$pvar = $min;
} elsif ($$pvar > $max) {
$$pvar = $max;
}
}
sub schedule {
my ($out, $L, $R, $P, $N, $X) = @_;
my $F = 1 + ($R / 100.0 / $P);
my $start = $L;
my $b_is_fh = (ref($out) =~ /FileHandle/);
my $pout = sub {
my ($msg) = @_;
$b_is_fh and print $out "$msg\n";
$b_is_fh or $out->out($msg);
};
if ($b_is_fh) {
my $shdr = schedule_header($R);
$pout->($shdr);
}
my ($i, $text);
my $fmt = "%4s %6d %13s %13s %13s %13s %13s %13s %13s\n";
my ($int, $A) = (0, 0);
$tot_int = 0;
$tot_paid = 0;
$payments = [ ];
for ($i = $maxpay = 0; $start > 0; $i++, $N--) {
my $nyear = int($i / $period);
my $extra = $X;
my $w_int = sprintf "%.2f", ($start * $F);
my $end = $w_int;
$int = $w_int - $start; # Interest payment
$tot_int += $int;
(!$A || $extra <= 0) and $A = calc_payment($start, $R, $P, $N);
$end -= $extra;
($end <= $A) and $A = $end;
$end -= $A;
$tot_paid += ($A + $extra);
# Save payment information
$payments->[$nyear]->[0] += $int;
$payments->[$nyear]->[1] += $A - $int;
$payments->[$nyear]->[2] += $extra;
my $totpay = $payments->[$nyear]->[0] +
$payments->[$nyear]->[1] +
$payments->[$nyear]->[2];
($totpay > $maxpay) and $maxpay = $totpay;
$text .= sprintf $fmt,
(0 == ($i % $P)? ($i / $P): " "), $i+1,
commas($start), commas($w_int), commas($A),
commas($extra), commas($end), commas($int),
commas($tot_int);
$start = $end;
}
$pct_int = sprintf "%8.3f%%", (100.0 * $tot_int / $tot_paid);
$tot_prin = $tot_paid - $tot_int;
# Make these values 'pretty', as they aren't directly changed by the user
dollar_amount(\$tot_prin, 1);
dollar_amount(\$tot_paid, 1);
dollar_amount(\$tot_int, 1);
if ($out && 0 == ($i % $P)) {
$text .= sprintf "%4s %s\n", ($i / $P), ('-' x 3);
}
$pout->($text);
return $i;
}
sub configure_relief {
my ($widget, $rel) = @_;
if ($rel) {
($rel eq 'n') and $rel = 'none';
($rel eq 'f') and $rel = 'flat';
($rel eq 'g') and $rel = 'groove';
($rel eq 'r') and $rel = 'raised';
($rel eq 'R') and $rel = 'ridge';
($rel eq 's') and $rel = 'solid';
($rel eq 'S') and $rel = 'sunken';
$widget->configure(-relief => $rel);
}
}
sub configure_packing {
my ($widget, $pack) = @_;
if ($pack =~ s/([<|>])//) {
my $just = $1;
if ($widget =~ /Entry/) {
($just eq '<') and $widget->configure(-justify => 'left');
($just eq '|') and $widget->configure(-justify => 'center');
($just eq '>') and $widget->configure(-justify => 'right');
}
}
if ($pack) {
my $fill = ($pack =~ /([bxyn])/)? $1: 'n';
my $expand = ($pack =~ /([01])/)? $1: '0';
my $side = ($pack =~ /([TBLR])/)? $1: 'top';
($fill eq 'b') and $fill = 'both';
($fill eq 'n') and $fill = 'none';
($side eq 'T') and $side = 'top';
($side eq 'B') and $side = 'bottom';
($side eq 'L') and $side = 'left';
($side eq 'R') and $side = 'right';
$widget->pack(-expand => $expand, -fill => $fill, -side => $side);
}
return $widget;
}
#
# frame: Creates a Tk Frame widget
#
# $1 ... The parent window
# $2 ... The frame background color
# $3 ... The frame relief
# $4 ... The frame border width
# $5 ... The frame pack style, which may include the side (T=top,
# B=bottom, L=left, R=right), the fill flag (n=none, x, y,
# or b=both) and/or the expand flag (0 or 1).
#
sub frame {
my ($w, $bg, $rel, $bw, $pack) = @_;
$bg ||= 0;
$rel ||= 0;
$bw ||= 5;
$pack ||= 'T';
my $f = $w->Frame(-borderwidth => $bw);
$bg and $f->configure(-bg => $bg);
configure_relief($f, $rel);
return configure_packing($f, $pack);
}
#
# button: Creates a Tk Button widget
#
# $1 ... The parent window
# $2 ... The button text
# $3 ... The button background color
# $4 ... The associated command
# $5 ... The width of the button
# $6 ... Where/how to place the button. If it contains one
# of [TBLR], packs it (top, bottom, left or right).
# If it contains the format "r,c", grids it at the
# given row, column. If it contains 'd', disables the
# button.
# $7 ... An optional key to bind to this button from the main
# window. If the key is in the format 'F[0-9]*', it
# is converted to the appropriate function key name.
#
sub button {
my ($win, $txt, $bg, $pcmd, $width, $where, $key) = @_;
$txt ||= '';
$bg ||= 'green';
$pcmd ||= 0;
$width ||= 0;
$where ||= 0;
$key ||= 0;
($key =~ /^[fF]([0-9]+)$/) and $key = "";
($key =~ /^esc(ape)?$/i) and $key = "";
($key =~ /^\^(.+)/) and $key = "";
my $mw = $win->toplevel();
my $b = $win->Button(-text => $txt, -bg => $bg);
$pcmd and $b->configure(-command => $pcmd);
$width and $b->configure(-width => $width);
($where =~ /d/) and $b->configure(-state => 'disabled');
$key and $mw->bind($key, sub { $b->invoke(); });
if ($where) {
my $anch = ($where =~ s/([<|>])//)? $1: 0;
($anch eq '<') and $b->configure(-anchor => 'w');
($anch eq '|') and $b->configure(-anchor => 'center');
($anch eq '>') and $b->configure(-anchor => 'e');
if ($where =~ /(\d+),(\d+)/) {
my ($row, $col) = ($1, $2);
$b->grid(-row => $row, -col => $col);
} elsif ($where =~ /[TBLR]/) {
my $side = 'L';
($where =~ /T/) and $side = 'top';
($where =~ /B/) and $side = 'bottom';
($where =~ /L/) and $side = 'left';
($where =~ /R/) and $side = 'right';
$b->pack(-side => $side);
}
}
return $b;
}
#
# entry: Creates a Tk Entry widget:
#
# $1 ... The parent window
# $2 ... The entry background color
# $3 ... The entry width
# $4 ... The entry relief
# $5 ... The associated scalar variable
# $6 ... Special flags. If it contains 'd', disables the widget
# from input. If it contains '*', hides text.
# $7 ... The entry pack style, which may include the justification
# (<=left, |=center, >=right), side (T=top, B=bottom, L=left,
# R=right), the fill flag (n=none, x, y, or b=both) and/or
# the expand flag (0 or 1).
# $8 ... Callback routine when text is entered in the Enter widget.
#
sub entry {
my ($w, $bg, $width, $rel, $pvar, $flags, $pack, $pcback) = @_;
$bg ||= 'white';
$width ||= 0;
$rel ||= 0;
$pvar ||= 0;
$flags ||= 0;
$pack ||= 0;
$pcback ||= 0;
my $e = $w->Entry();
$bg and $e->configure(-bg => $bg);
$width and $e->configure(-width => $width);
$pvar and $e->configure(-textvar => $pvar);
if ($flags) {
($flags =~ /d/) and $e->configure(-state => 'disabled');
($flags =~ /\*/) and $e->configure(-show => '*');
}
configure_relief($e, $rel);
if ($pcback) {
# Allow '' and loss-of-focus to trigger this callback
$e->bind('', $pcback);
$e->bind('', $pcback);
}
return configure_packing($e, $pack);
}
#
# labent: Creates a Tk Label/Entry widget:
#
# $1 ... The parent window
# $2 ... The label background color
# $3 ... The label width
# $4 ... The label relief
# $5 ... The text (or text variable) of the label
# $6 ... The entry background color
# $7 ... The entry width
# $8 ... Various flags, in which the following characters are valid:
#
# Flags Meaning
# d ..... The widget is disabled
# * ..... The text appears as '*' (eg. for passwords)
#
# Anchors Meaning
# < ..... The widget is anchored left
# | ..... The widget is anchored middle
# > ..... The widget is anchored right
#
# Pack Meaning
# T ..... Pack the widget to the top
# B ..... Pack the widget to the bottom
# L ..... Pack the widget to the left
# R ..... Pack the widget to the right
#
# Fill Meaning
# N ..... No fill
# X ..... Fill in the X-direction
# Y ..... Fill in the Y-direction
# B ..... Fill in both the X and Y directions
# 0 ..... Do NOT expand
# 1 ..... Expand
#
# $9 ... Callback routine when text is entered in the Enter widget.
#
sub labent {
my ($w, $label, $bg1, $w1, $pvar, $bg2, $w2, $flags, $pvalid) = @_;
$label ||= '';
$bg1 ||= 'gray';
$w1 ||= '10';
$pvar ||= 0;
$bg2 ||= 'white';
$w2 ||= 10;
$flags ||= 0;
$pvalid ||= 0;
my $lpack = 'Lb1';
my $epack = 'Lb1';
($flags =~ /([<|>])/) and $epack .= $1;
my $fr_bg = $w->cget(-bg);
my $f = frame($w, $fr_bg, 'g', 3, 0);
my $l = label($f, $bg1, $w1, 0, $label, $lpack);
my $e = entry($f, $bg2, $w2, 0, $pvar, $flags, $epack, $pvalid);
return [ $l, $e ];
}
#
# label: Creates a Tk Label widget
#
# $1 ... The parent window
# $2 ... The label background color
# $3 ... The label width
# $4 ... The label relief
# $5 ... The text (or text variable) of the label
# $6 ... The entry pack style, which may include the anchor position
# (<=left, |=center, >=right), side (T=top, B=bottom, L=left,
# R=right), the fill flag (n=none, x, y, or b=both) and/or
# the expand flag (0 or 1).
#
sub label {
my ($w, $bg, $width, $rel, $pvar, $pack) = @_;
$bg ||= 0;
$width ||= 0;
$rel ||= 0;
$pvar ||= 0;
$pack ||= 0;
my $l = $w->Label();
$bg and $l->configure(-bg => $bg);
$width and $l->configure(-width => $width);
if ($pvar) {
if (ref $pvar eq '') {
$l->configure(-text => $pvar);
} else {
$l->configure(-textvar => $pvar);
}
}
configure_relief($l, $rel);
return configure_packing($l, $pack);
}
GUI: {
my $mw;
my $te;
my $tb = 0;
my $graph = 0;
my ($f1, $f2, $f3, $f4, $f5, $f6, $f7, $f8, $f9);
my ($le1, $le2, $le3, $le4, $le5, $le6, $le7);
my $bg1 = 'peachpuff'; # Label/Entry color
sub exit_gui {
$mw->exit;
}
sub make_float {
my ($pval) = @_;
$$pval =~ s/[^\d\.]//g;
$$pval =~ s/(\..*)\./$1/g;
}
sub dollar_amount {
my ($pval, $pretty) = @_;
$pretty ||= 0;
make_float($pval);
$$pval = sprintf "%.2f", $$pval;
$pretty and $$pval = '$' . commas($$pval);
return $$pval;
}
sub adjust_for_extra {
my ($np) = @_;
$o_newpay = $newpay = int($np);
$o_newyear = $newyear = sprintf "%.3f", ($newpay / $period);
show_graph();
}
sub find_payment {
$payment = calc_payment($loan, $rate, $period, $npay);
dollar_amount(\$payment, 1);
return unless $tb;
$tb->clear();
my $np = schedule($tb, $loan, $rate, $period, $npay, $extra);
adjust_for_extra($np);
}
sub do_principal {
return if ($loan eq $o_loan);
dollar_amount(\$loan);
find_payment();
$o_loan = $loan;
}
sub do_rate {
return if ($rate eq $o_rate);
enforce_limits(\$rate, $min_rate, $max_rate);
($rate < 0.1) and $rate = 0.1;
make_float(\$rate);
find_payment();
create_schedule_header();
$o_rate = $rate;
}
sub do_period {
return if ($period eq $o_period);
make_float(\$period);
($period < 1) and $period = 12;
$period = int($period);
find_payment();
$o_period = $period;
}
sub do_years {
return if ($years eq $o_years);
enforce_limits(\$years, $min_years, $max_years);
make_float(\$years);
$npay = int($years * $period);
do_npay();
$o_years = $years;
}
sub do_npay {
return if ($npay eq $o_npay);
$npay = int($npay);
$years = sprintf "%.3f", ($npay / $period);
find_payment();
$o_npay = $npay;
}
sub do_extra {
return if ($extra eq $o_extra);
dollar_amount(\$extra);
find_payment();
$o_extra = $extra;
}
sub clear_graph {
while (my $id = shift @glist) {
$graph->delete($id);
}
}
sub save_schedule {
my $dir = $ENV{'USERPROFILE'};
defined($dir) and $dir .= "\\Desktop";
$dir ||= ".";
my @opts = (
-title => "Save Mortgage Information",
-defaultextension => 'txt',
-initialdir => $dir,
-initialfile => $schedout,
);
my $fname = $mw->getSaveFile(@opts);
$fname or return;
my $fh = new FileHandle;
open($fh, ">", $fname) or return;
schedule($fh, $loan, $rate, $period, $npay, $extra);
close $fh;
}
sub plot_points {
my ($x, $xinc, $y, $yext, $p) = @_;
my $x0 = $x;
my $x1 = $x + $xinc;
my $y0 = $y;
for (my $i = 0; $i < @$p; $i++) {
my $pay = $p->[$i] / $maxpay;
my $y1 = $y0 - ($pay * $yext);
my $bg = $gcolors[$i];
my $id = $graph->createRectangle($x0, $y0, $x1, $y1, -fill => $bg);
push @glist, $id;
$y0 = $y1;
}
return $x1;
}
sub show_graph {
return unless $graph;
# Clear the previous graph
clear_graph();
# Get the number of payments saved (and make sure it's more than 1)
my $n = @$payments;
return if ($n < 1);
# Get the absolute pixel width and height of the canvas
my $width = $graph->Width();
my $height = $graph->Height();
# Draw the graph
my ($xmargin, $ymargin) = (5, 5);
my $xinc = ($width - 2 * $xmargin) / $n;
my $yext = ($height - 2 * $ymargin);
my $x = $xmargin;
my $y = $height - $ymargin;
for (my $i = 0; $i < @$payments; $i++) {
$x = plot_points($x, $xinc, $y, $yext, $payments->[$i]);
}
}
sub create_schedule_header {
my $shdr = schedule_header($rate);
$te and $te->packForget();
$te = $f8->Text(-height => 1);
$te->pack(-expand => 0, -fill => 'x');
$te->insert('end', "$shdr");
$te->configure(-state => 'disabled', -takefocus => 0);
}
sub gui_mode {
$mw = new MainWindow(-title => $title);
$mw->fontCreate('vals', -family => 'arial', -size => 12);
my $top = frame($mw, 0, 0, 0, 'Tb1');
$f1 = frame($top, 'pink', 'g', 0, 'x0');
button($f1, "Exit (Esc)", 0, \&exit_gui, 0, 'R', 'esc');
new help($f1, 'Help (F1)', 0, 'L', '', 'Program Help', $help);
button($f1, 'Reset Variables (^R)', 0, \&reset_values, 0, 'L', '^R');
button($f1, "Save Schedule (^S)", 0, \&save_schedule, 0, 'L', '^S');
$f2 = frame($top, 0, 'g', 0, 'Tx0');
$f3 = frame($f2, 'cyan', 0, 0, 'Ln0'); # Variables frame
$f4 = frame($f2, 0, 'g', 0, 'Lb1'); # Graph frame
$f5 = frame($top, 'cyan', 'g', 0, 'Tb1'); # Schedule frame
my $labents = [
[ 'Loan Amount', \$loan, 'T>', \&do_principal ],
[ 'Annual % interest rate', \$rate, 'T>', \&do_rate ],
[ 'Period (eg. 12=monthly)', \$period, 'T>', \&do_period ],
[ 'Base # of years', \$years, 'T>', \&do_years ],
[ 'Base # of payments ', \$npay, 'T>', \&do_npay ],
[ 'Extra payment amount', \$extra, 'T>', \&do_extra ],
[ 'Payment Amount', \$payment, 'T>d', 0 ],
[ 'Total interest payments', \$tot_int, 'T>d', 0 ],
[ 'Total principal payments', \$tot_prin, 'T>d', 0 ],
[ 'Total amount paid', \$tot_paid, 'T>d', 0 ],
[ 'Interest as % of total', \$pct_int, 'T>d', 0 ],
];
foreach my $p (@$labents) {
my $p = labent($f3, $p->[0], $bg1, 24, $p->[1],
0, 12, $p->[2], $p->[3]);
$p->[1]->configure(-font => 'vals');
}
# Graph frame
$f6 = frame($f4, 0, 'g', 0, 'Tx0');
$f7 = frame($f4, 0, 'g', 0, 'Tb1');
label($f6, 'white', 0, 'g', ' Key ', 'L');
label($f6, $gcolors[0], 0, 'g', ' Interest payments ', 'L');
label($f6, $gcolors[1], 0, 'g', ' Basic principal payments ', 'L');
label($f6, $gcolors[2], 0, 'g', ' Extra principal payments ', 'L');
$graph = $f7->Canvas(-bg => 'gray');
$graph->pack(-expand => 1, -fill => 'both');
$f7->bind('', \&show_graph);
# Schedule frame
$f8 = frame($f5, 'gold', 0, 0, 'Tx0');
$f9 = frame($f5, 'gold', 0, 0, 'Tb1');
create_schedule_header();
$tb = new textbox($f9, 115, 16, 0, 0, 0, "e");
$mw->after(100, \&find_payment);
MainLoop;
}
}
s''(q.S:$/9=(T1';s;(..)(..);$..=substr+crypt($1,$2),2,3;eg;print$..$/
Re: Amortization Calculator
created: 2006-08-06 23:57:12
heh... very cool. As you know, my wife and I have recently taken out a mortgage to purchase an apartment here in Singapore. I just tried plugging our figures in to see how much interest we'll be paying - ouch!
My wife will love this - nice one ++ :)
Re: Amortization Calculator
created: 2006-08-07 06:44:57
Great job! ++
I have been thinking about getting a new place, this should come in very handy!
I have been thinking about getting a new place, this should come in very handy!
s&&VALKYRIE &&& print $_^q|!4 =+;' *|
Re: Amortization Calculator
created: 2006-08-07 22:19:04
I have a question about a section of your code. :-)
538 my $b_is_fh = (ref($out) =~ /FileHandle/);
539 my $pout = sub {
540 my ($msg) = @_;
541 $b_is_fh and print $out "$msg\n";
542 $b_is_fh or $out->out($msg);
543 };
Re: Amortization Calculator
created: 2006-08-08 05:47:02
Very nice.
An additional function I'd find handy is for part repayment part interest only loans.
eg in our case we've borrowed £n thousand of which 62.5% is interest only
Simplified it means at the end of the loan period we would still owe some monies, these will be covered by an endowment. Ideally add a feature to add up endowment contribs and give a total repaid.