Sorry

#!/usr/bin/perl
# $Id: popnew $
# $Date: 12.31.10 $
# $HeadURL: dandello.net $
# $Revision: 2011 $
# $Source: /popnew.pl $
######################################################################
+############
use strict;

#use warnings;
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 'rand';
use List::Util qw(shuffle);

our $VERSION = 3.15;

my (
    %FORM,      $buffer,    @pairs,     $chntot,    $coper,     $copye
+rr,
    $countgen,  $dlp,       $dp0,       $dp1,       $dr0,       $dr1,
    $dr2,       $dr3,       $dr4,       $dr5,       $drp,       $errch
+k,
    $ercount,   $gener,     $grand,     $grand1,    $grand2,    $grand
+3,
    $grand4,    $incrs,     $incrsdel,  $initial,   $model,     $mpe0,
    $mpe0a,     $mpe1,      $mpe1a,     $mpe1b,     $mpe2,      $mpe2a
+,
    $mpe2b,     $mpe3,      $mpe3a,     $mpe3b,     $mpe4,      $mpe4a
+,
    $mpe4b,     $mpe5,      $mpe5a,     $mpe5b,     $mpy0a,     $mpy1,
    $mpy1a,     $mpy1b,     $mpy2,      $mpy2a,     $mpy2b,     $mpy3,
    $mpy3a,     $mpy3b,     $mpy4,      $mpy4a,     $mpy4b,     $mpy5,
    $mpy5a,     $mpy5b,     $name,      $popbyyer0, $popbyyer1, $popby
+yer2,
    $popbyyer3, $popbyyer4, $popbyyer5, $total,     $total2,    $tot2e
+rror,
    $value,     $x,         $xb,        $y,         $yb,        @aoa,
    @aob,       @aod,       @dlarray,
);
srand 10;
Readonly my $PCNT => 100;
Readonly my $C3   => 3;
Readonly my $C4   => 4;
Readonly my $C5   => 5;

# data from form;
    $model = 1;
    $initial = 10;
    $copyerr = 3;
    $mpe0 = 10;
    $mpe1 = 20;
    $mpe2 = 30;
    $mpe3 = 25;
    $mpe4 = 30;
    $mpe5 = 35;
    $mpy1 = 2;
    $mpy2 = 4;
    $mpy3 = 6;
    $mpy4 = 8;
    $mpy5 = 10;

datafilla();

#build data table;
my @tablem = (
    [ 0,          $mpy1a + 1, $mpy2a + 1, $mpy3a + 1, $mpy4a + 1, ],
    [ $mpy1a,     $mpy2a,     $mpy3a,     $mpy4a,     $mpy5a, ],
    [ $mpe0a,     $mpe1a,     $mpe2a,     $mpe3a,     $mpe4a, ],
    [ 0,          $mpy1a,     $mpy2a,     $mpy3a,     $mpy4a, ],
    [ $popbyyer1, $popbyyer2, $popbyyer3, $popbyyer4, $popbyyer5, ],
    [ 0,          $grand1,    $grand2,    $grand3,    $grand4, ],
);
popfileb();

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';

#check that 'd' cell ammount matches;
my $errorcheck = $ercount - $grand;
if ( $errorcheck != 0 ) {
    $errchk =
      qq{Oops, you propably want to reload this page - off by $errorch
+eck};
}
else {
    $errchk = 'Okay';
}

#html title, confirm data;
print qq{<title>Model $model</title>\n} or croak 'cannot print title';
print
qq{</head>\n<body>\n<h1>Model $model</h1>\n<p>Initial# $initial<br />C
+opy Error +- $copyerr&#37;</p>\n<p>Year 0 - $mpe0a<br />Year $mpy1 - 
+$mpe1a<br />Year $mpy2a - $mpe2a<br />Year $mpy3a - $mpe3a<br />Year 
+$mpy4a - $mpe4a<br />Year $mpy5a - $mpe5a</p>\n<p>Error check: $errch
+k</p>\n}
  or croak 'cannot print title2';

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

#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 $drp ( 0 .. $C4 ) {
    $dp0 = $tablem[0]->[$drp];
    $dp1 = $tablem[1]->[$drp];

    foreach my $y ( $dp0 .. $dp1 ) {
        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;</t
+d>}
                  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 td';
            }

            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';

sub datafilla {
    $mpy0a = 0;
    $mpy1a = $mpy1 || 1;
    $mpy2a = $mpy2 || 1;
    $mpy3a = $mpy3 || 1;
    $mpy4a = $mpy4 || 1;
    $mpy5a = $mpy5 || 1;
    $mpy1b = $mpy1 || 1;
    $mpy2b = $mpy2 - $mpy1 || 1;
    $mpy3b = $mpy3 - $mpy2 || 1;
    $mpy4b = $mpy4 - $mpy3 || 1;
    $mpy5b = $mpy5 - $mpy4 || 1;
    $mpe0a = $mpe0 || 0;
    $mpe1a = $mpe1 || 0;
    $mpe2a = $mpe2 || 0;
    $mpe3a = $mpe3 || 0;
    $mpe4a = $mpe4 || 0;
    $mpe5a = $mpe5 || 0;

    if ( $mpe1a - $mpe0a < 0 ) {
        $mpe1b = abs $mpe1a - $mpe0a;
    }
    else { $mpe1b = 0; }
    if ( $mpe2a - $mpe1a < 0 ) {
        $mpe2b = abs $mpe2a - $mpe1a;
    }
    else { $mpe2b = 0; }
    if ( $mpe3a - $mpe2a < 0 ) {
        $mpe3b = abs $mpe3a - $mpe2a;
    }
    else { $mpe3b = 0; }
    if ( $mpe4a - $mpe3a < 0 ) {
        $mpe4b = abs $mpe4a - $mpe3a;
    }
    else { $mpe4b = 0; }
    if ( $mpe5a - $mpe4a < 0 ) {
        $mpe5b = abs $mpe5a - $mpe4a;
    }
    else { $mpe5b = 0; }

    $grand1 = $mpe1b;
    $grand2 = $mpe1b + $mpe2b;
    $grand3 = $mpe1b + $mpe2b + $mpe3b;
    $grand4 = $mpe1b + $mpe2b + $mpe3b + $mpe4b;
    $grand  = $mpe1b + $mpe2b + $mpe3b + $mpe4b + $mpe5b;

    $popbyyer0 = $mpe0a;
    $popbyyer1 = ( $mpe1a - $mpe0a ) / $mpy1b;
    $popbyyer2 = ( $mpe2a - $mpe1a ) / $mpy2b;
    $popbyyer3 = ( $mpe3a - $mpe2a ) / $mpy3b;
    $popbyyer4 = ( $mpe4a - $mpe3a ) / $mpy4b;
    $popbyyer5 = ( $mpe5a - $mpe4a ) / $mpy5b;

    #max years for table;
    my @years = ( $mpy0a, $mpy1a, $mpy2a, $mpy3a, $mpy4a, $mpy5a );
    my @yearsa = reverse sort { $a <=> $b } @years;
    $gener = $yearsa[0];

    #max population for table;
    my @popul = ( $mpe0a, $mpe1a, $mpe2a, $mpe3a, $mpe4a, $mpe5a );
    my @totpop = reverse sort { $a <=> $b } @popul;
    $total = $totpop[0] + $grand - 1;

    return;
}

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

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

#increase - decrease array;
sub popfileb {
    my $countgen0 = 0;

    foreach my $dlp ( 0 .. $C4 ) {
        $dr0 = $tablem[0]->[$dlp];
        $dr1 = $tablem[1]->[$dlp];
        $dr2 = $tablem[2]->[$dlp];
        $dr3 = $tablem[$C3]->[$dlp];
        $dr4 = $tablem[$C4]->[$dlp];
        $dr5 = $tablem[$C5]->[$dlp];

        foreach my $yb ( $dr0 .. $dr1 ) {
            $countgen = $countgen0++ - $dr3;
            my $change = $countgen * $dr4;
            $incrs    = int( $dr2 + $change );
            $incrsdel = int( $dr5 + abs $change );
            $chntot   = $incrsdel + $incrs;

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

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

                #set increasing rows;
                elsif ( $dr4 >= 0 ) {
                    if ( $xb < $dr5 + $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 < 0 ) {

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

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

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

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

    foreach my $xa ( 0 .. $total ) {
        for my $ya (0) {
            $aob[$xa][0] = sprintf '%.2f', $initial + $aoa[$xa][0];
        }
        foreach my $ya ( 1 .. $gener ) {
            if ( $aod[$xa][ $ya - 1 ] eq 'n' ) {
                $aob[$xa][$ya] = sprintf '%.2f', $initial + $aoa[$xa][
+0];
            }
            else {
                $aob[$xa][$ya] = sprintf '%.2f',
                  $aoa[$xa][$ya] + $aob[$xa][ $ya - 1 ];
            }
        }
    }

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

#model 2;
sub popnum2 {
    ( $x, $y ) = @_;
    popfilea();

    foreach my $xa ( 0 .. $total ) {
        for my $ya (0) {
            $aob[$xa][0] = sprintf '%.2f', $initial + $aoa[$xa][0];
        }
        foreach my $ya ( 1 .. $gener ) {
            if ( $aod[$xa][ $ya - 1 ] eq 'n' ) {
                my $xx = int rand $xa;
                $aob[$xa][$ya] = sprintf '%.2f',
                  $aoa[$xa][$ya] + $aob[$xx][ $ya - 1 ];
            }
            else {
                $aob[$xa][$ya] = sprintf '%.2f',
                  $aoa[$xa][$ya] + $aob[$xa][ $ya - 1 ];
            }
        }
    }

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

exit;

[download]

A test version is at Model 1

It's supposed to have only two or three cells grayed out on row 5 and the the other two or three grayed out on 6 (for a total of five) with the grayed out cells extending down to the end of the table. Like this: Model 2 However, Model 2 doesn't use the 'while' statement and occasionally picks out a few too few to gray out.

In reply to Re^3: This runs WAY too slow by Dandello
in thread This runs WAY too slow by Dandello

Title:
Use:  <p> text here (a paragraph) </p>
and:  <code> code here </code>
to format your post, it's "PerlMonks-approved HTML":


  • Posts are HTML formatted. Put <p> </p> tags around your paragraphs. Put <code> </code> tags around your code and data!
  • Titles consisting of a single word are discouraged, and in most cases are disallowed outright.
  • Read Where should I post X? if you're not absolutely sure you're posting in the right place.
  • Please read these before you post! —
  • Posts may use any of the Perl Monks Approved HTML tags:
    a, abbr, b, big, blockquote, br, caption, center, col, colgroup, dd, del, details, div, dl, dt, em, font, h1, h2, h3, h4, h5, h6, hr, i, ins, li, ol, p, pre, readmore, small, span, spoiler, strike, strong, sub, summary, sup, table, tbody, td, tfoot, th, thead, tr, tt, u, ul, wbr
  • You may need to use entities for some characters, as follows. (Exception: Within code tags, you can put the characters literally.)
            For:     Use:
    & &amp;
    < &lt;
    > &gt;
    [ &#91;
    ] &#93;
  • Link using PerlMonks shortcuts! What shortcuts can I use for linking?
  • See Writeup Formatting Tips and other pages linked from there for more info.