#!/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, $maxpa
+y);
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 + optiona
+l-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_l
+oc);
    $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, backgroun
+d
#  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 giv
+en
#  for the tag, a label is created out of the font, background and for
+eground
#  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 upda
+te.
#
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); } @$ptex
+t;
    ($b_no_eol)  or map { $tbox->insert('end', "$_\n", $tag); } @$ptex
+t;
    $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 upda
+te.
#
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.  Parameter
+s 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 fol
+lowing
    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 alter
+ed,
    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 applic
+ation,
    to see how they affect the entire payment schedule.  Set the desir
+ed
    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' a
+nd
    'Base # of payments', though).

    To reset the program variables, type '^R' or press the button mark
+ed
    '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 <Escape>, or press the button marked 'Ex
+it'.
";

#
#  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 supplie
+d,
    #  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-F" . $1 . ">";
    $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 butto
+n
    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 t
+he 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 => $si
+de);
    }
    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-F" . $1 . ">";
    ($key =~ /^esc(ape)?$/i)   and $key = "<Key-Escape>";
    ($key =~ /^\^(.+)/)        and $key = "<Control-" . (lc $1) . ">";

    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=lef
+t,
#            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 '<Return>' and loss-of-focus to trigger this callback
        $e->bind('<Return>', $pcback);
        $e->bind('<FocusOut>', $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 vali
+d:
#
#               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 positi
+on
#            (<=left, |=center, >=right), side (T=top, B=bottom, L=lef
+t,
#            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 th
+an 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', '<Key-F1>', '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_pri
+ncipal ],
            [ 'Annual % interest rate',   \$rate,     'T>',   \&do_rat
+e ],
            [ 'Period (eg. 12=monthly)',  \$period,   'T>',   \&do_per
+iod ],
            [ 'Base # of years',          \$years,    'T>',   \&do_yea
+rs ],
            [ 'Base # of payments ',      \$npay,     'T>',   \&do_npa
+y  ],
            [ 'Extra payment amount',     \$extra,    'T>',   \&do_ext
+ra ],
            [ '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('<Configure>', \&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;
    }
}
[download]