#!/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 <Escape>, 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-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 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-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=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 '<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 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', '<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_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('<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;
    }
}