in reply to Re^2: This runs WAY too slow
in thread This runs WAY too slow

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.

Replies are listed 'Best First'.
Re^4: This runs WAY too slow
by Dandello (Monk) on Jan 17, 2011 at 06:55 UTC

    Of course, after posting this, I think I figured it out.

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

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

    [download]
[reply]
[d/l]
      Of course, after posting this, I think I figured it out.

      Around here that is considered a very good outcome and one of the reasons we like people to try to reproduce their problem with a small stand alone sample. Trying to isolate the problematic code very often results in an analysis of the code that otherwise is hard to achieve. In fact many monks who have been around here a while (myself included) find that the process of trying to generate a small stand alone script for posting in a SOPW gets the problem solved before the SOPW gets written.

      Please though, read ELiSHEVA's node carefully and follow as much of her advice as you can. She offers lots of very good advice that will help improve you code to make it faster and more maintainable.

      True laziness is hard work
[reply]

In Section Seekers of Perl Wisdom