#!/usr/bin/perl
# $Id: popnew $
# $Date: 12.31.10 $
# $HeadURL: adamant.net $
# $Revision: 2011 $
# $Source: /popnew.pl $
######################################################################
+############
use strict;
#use warnings;
use CGI qw(:standard);
use CGI::Carp qw(fatalsToBrowser);
use CGI::Fast;
use lib '/home/XXXXXX/public_html/cgi-bin/lib',
  'D://websites/savant/cgi-bin/lib';
use Readonly;
use Math::Random::MT::Auto qw(rand);
use List::Util qw(shuffle);

our $VERSION = 3.24;

my (
    $chntot,   $coper,  $countgen,  $errchk, $ercount, $incrs,
    $incrsdel, $total2, $tot2error, $x,      $xb,      $y,
    $yb,       @aoa,    @aob,       @aod,
);

Readonly my $PCNT => 100;
Readonly my $C3   => 3;
Readonly my $C4   => 4;
Readonly my $C5   => 5;
Readonly my $NEG  => -1;

my $q       = CGI->new( \*STDIN );
my $copyerr = $q->param('copyerr');
my $model   = $q->param('model');
my $initial = $q->param('initial');
my $LST     = $q->param('LST');

my @mpy = ();    # year
my @mpe = ();    # population estimate
foreach ( 0 .. $LST ) {
    $mpe[$_] = $q->param( 'mpe' . $_ ) || 0;
    $mpy[$_] = $q->param( 'mpy' . $_ ) || 1;
}
$mpy[0] = 0;

# CALCS
my @grand    = (0);
my @popbyyer = ( $mpe[0] );

for my $y ( 1 .. $LST ) {
    my $y_diff = ( $mpy[$y] - $mpy[ $y - 1 ] ) || 1;
    my $e_diff = ( $mpe[$y] - $mpe[ $y - 1 ] );
    $popbyyer[$y] = $e_diff / $y_diff;
    $grand[$y] = $grand[ $y - 1 ] + ( ( $e_diff < 0 ) ? abs($e_diff) :
+ 0 );
}

my $gener = ( sort { $a <=> $b } @mpy )[$NEG];
my $total = ( sort { $a <=> $b } @mpe )[$NEG] + $grand[$NEG] - 1;

#build data table;
my @dr0 = ();
my @dr1 = ();
my @dr2 = ();
my @dr3 = ();
my @dr4 = ();
my @dr5 = ();
$dr0[0] = 0;
$dr3[0] = 0;
$dr5[0] = 0;
foreach my $tablem ( 1 .. $LST - 1 ) {
    $dr0[$tablem] = $mpy[$tablem] + 1;
    $dr3[$tablem] = $mpy[$tablem];
    $dr5[$tablem] = $grand[$tablem];
}
foreach my $tablen ( 0 .. $LST - 1 ) {
    $dr1[$tablen] = $mpy[ $tablen + 1 ];
    $dr2[$tablen] = $mpe[$tablen];
    $dr4[$tablen] = $popbyyer[ $tablen + 1 ];
}

popfileb();

#check that 'd' cell ammount matches;
my $errorcheck = $ercount - $grand[$NEG];
if ( $errorcheck != 0 ) {
    $errchk =
qq{<p>Error check: Oops, you propably want to reload this page - off b
+y $errorcheck.</p>\n};
}
else {
    $errchk = q{};
}

popfilea();

table1();
table2();

#prepopulate copy error array;
sub popfilea {
    foreach my $ya ( 0 .. $gener ) {
        foreach my $xa ( 0 .. $total ) {
            my $copycop  = int rand( 1 + 2 * $copyerr ) - $copyerr;
            my $copycopa = $copycop / $PCNT;

            $aoa[$xa][$ya] = $copycopa;
        }
    }
    return;
}

#increase - decrease array;
sub popfileb {
    my $countgen0 = 0;
    foreach my $dlp ( 0 .. $LST - 1 ) {
        foreach my $yb ( $dr0[$dlp] .. $dr1[$dlp] ) {
            $countgen = $countgen0++ - $dr3[$dlp];
            my $change = $countgen * $dr4[$dlp];
            $incrs    = int( $dr2[$dlp] + $change );
            $incrsdel = int( $dr5[$dlp] + abs $change );
            $chntot   = $incrsdel + $incrs;

            foreach my $xb ( 0 .. $total ) {

                #set first row;
                if ( $yb == 0 ) {
                    if ( $xb < $dr2[$dlp] ) {
                        $aod[$xb][0] = 'a';
                    }
                    else {
                        $aod[$xb][0] = 'n';
                    }
                }

                #set increasing rows;
                elsif ( $dr4[$dlp] >= 0 ) {
                    if ( $xb < $dr5[$dlp] + $incrs ) {
                        if ( $aod[$xb][ $yb - 1 ] eq 'd' ) {
                            $aod[$xb][$yb] = 'd';
                        }
                        else {
                            $aod[$xb][$yb] = 'a';
                        }
                    }
                    else {
                        $aod[$xb][$yb] = 'n';
                    }
                }

                #set decreasing rows;
                else {
                    if ( $xb <= $chntot ) {
                        if ( $aod[$xb][ $yb - 1 ] eq 'd' ) {
                            $aod[$xb][$yb] = 'd';
                        }
                        elsif ( $aod[$xb][ $yb - 1 ] eq 'a' ) {
                            $aod[$xb][$yb] = 'a';
                        }
                        else {
                            $aod[$xb][$yb] = 'n';
                        }
                    }
                    else {
                        $aod[$xb][$yb] = 'n';
                    }
                }
            }

            #set random decreased cell;
            if ( $dr4[$dlp] < 0 ) {

                #pre-populate deletion array;
                my @delarray = ( 0 .. $chntot );
                my @dlarray  = shuffle @delarray;

                my $cndiea = 0;
                foreach my $del ( 0 .. $chntot ) {
                    if ( defined $aod[$del][$yb] && $aod[$del][$yb] eq
+ 'd' ) {
                        $cndiea++;
                    }
                }
                my $cnr = $cndiea;
                for my $xd ( 0 .. $chntot ) {
                    my $xda = $dlarray[$xd];
                    if ( defined $aod[$xda][$yb] && $aod[$xda][$yb] eq
+ 'a' && $cnr < $incrsdel ) {
                        $aod[$xda][$yb] = 'd';
                        $cnr++;
                    }
                }
            }
        }
    }
    my $error = 0;
    foreach my $mycheck ( 0 .. $total ) {
        if ( $aod[$mycheck][ $mpy[$NEG] ] eq 'd' ) {
            $error++;
        }
        $ercount = $error;
    }

    my $toterror = 0;
    foreach my $mycheck2 ( 0 .. $total ) {
        if ( $aod[$mycheck2][ $mpy[$NEG] ] eq 'n' ) {
            $toterror++;
        }
        $tot2error = $toterror;
    }
    return;
}

#model 1;
sub popnum1 {
    ( $x, $y ) = @_;

    if ( $y == 0 ) {
        $aob[$x][0] = sprintf '%.2f', $initial + $aoa[$x][0];
    }
    else {
        if ( $aod[$x][ $y - 1 ] ne 'a' ) {
            $aob[$x][$y] = sprintf '%.2f', $initial + $aoa[$x][0];
        }
        else {
            $aob[$x][$y] = sprintf '%.2f', $aoa[$x][$y] + $aob[$x][ $y
+ - 1 ];
        }
    }

    return $aob[$x][$y];
}

#model 2;
sub popnum2 {
    ( $x, $y ) = @_;
    my @delarray = ( 0 .. $total );
    my @dlarray  = shuffle @delarray;

    if ( $y == 0 ) {
        $aob[$x][0] = sprintf '%.2f', $initial + $aoa[$x][0];
    }
    elsif ( $aod[$x][ $y - 1 ] eq 'n' ) {
        my $cnr = 0;
        for my $xd ( 0 .. $total ) {
            my $xda = $dlarray[$xd];
            if ( $cnr < 2 && $aob[$xda][ $y - 1 ] ne q{} ) {
                $aob[$x][$y] = sprintf '%.2f',
                  $aoa[$x][$y] + $aob[$xda][ $y - 1 ];
                $cnr++;
            }
        }
    }
    else {
        $aob[$x][$y] = sprintf '%.2f', $aoa[$x][$y] + $aob[$x][ $y - 1
+ ];
    }

    return $aob[$x][$y];
}

sub table1 {

    #table width;
    $total2 = $total - $tot2error;
    my $th = $total2 + 2;

    print "Content-type: text/html\n\n" or croak 'cannot print line1';

    #html header;
    my $head = <<'HEAD';
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN"
       "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
<html xmlns='http://www.w3.org/1999/xhtml' xml:lang='en' lang='en'>
<head><meta http-equiv='Content-Type' content='text/html; charset=iso-
+8859-1' />
<meta http-equiv='Content-Style-Type' content='text/css' />
<style type='text/css'>
td {padding: .5em; min-width:2.5em; }
</style>
HEAD
    print $head or croak 'cannot print head';

    #html title, confirm data;
    print qq{<title>Model $model</title>\n} or croak 'cannot print tit
+le';
    print
qq{</head>\n<body>\n<h1>Model $model</h1>\n<p>Initial# $initial<br />C
+opy Error +- $copyerr&#37;</p>\n<p>}
      or croak 'cannot print end head';

    #tabletop header row;
    print qq{<table border='1'><tr><th colspan='$th'>Population</th></
+tr><tr>}
      or croak 'cannot print tabletop';

    #build first table row;
    foreach my $tble ( 0 .. $total2 + 1 ) {
        print qq{<td><b>$tble</b></td>} or croak 'cannot print td2';
    }
    print q{</tr>} or croak 'cannot print tr';
    foreach my $chk ( 0 .. $LST ) {
        print qq {Year $mpy[$chk] - $mpe[$chk]<br />}
          or croak 'cannot print check';
    }
    print qq{</p>\n$errchk}
      or croak 'cannot print title2';
    return;
}

sub table2 {
    foreach my $drp ( 0 .. $LST - 1 ) {

        foreach my $y ( $dr0[$drp] .. $dr1[$drp] ) {
            print qq{<tr><td><b>$y</b></td>} or croak 'cannot print td
+';
            for my $x ( 0 .. $total2 ) {
                if ( $aod[$x][$y] eq 'd' ) {
                    print q{<td style='background-color:#cccccc'>&nbsp
+;</td>}
                      or croak 'cannot print td';
                }
                elsif ( $aod[$x][$y] eq 'a' ) {
                    if ( $model == 1 ) {
                        $coper = popnum1( $x, $y );
                    }
                    else {
                        $coper = popnum2( $x, $y );
                    }
                    print qq{<td>$coper</td>} or croak 'cannot print t
+d';
                }

                else {
                    print q{<td>&nbsp;</td>} or croak 'cannot print td
+';
                }
            }
            print q{</tr>} or croak 'cannot print tr';
        }
    }
    print qq{</table><p>Program Ver: $VERSION</p></body></html>}
      or croak 'cannot print foot';
    return;
}

exit;
[download]