in reply to This runs WAY too slow

Update

Many thanks to everybody for their help and comments.

The code is down to 336 lines and an 800x1600 table outputs not quite as fast as a page here.

So you can compare to the original file:

#!/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]

Next step - using CGI.pm to create the form and adding a 'print to file' and 'split file' option. (800 wide is about 3 times what Excel can handle for data crunching.) Any recommendations for a good book on CGI.pm?

Again, many thanks for the help.

Replies are listed 'Best First'.
Re^2: This runs WAY too slow
by poj (Abbot) on Jan 18, 2011 at 19:28 UTC
    You could save another few lines like this 
    #prepopulate copy error array;
sub popfilea {
  foreach my $ya ( 0 .. $gener ) {
    foreach my $xa ( 0 .. $total ) {
      $aoa[$xa][$ya] = (int rand(1+2*$copyerr)-$copyerr ) /$PCNT;
    }
  }
}

    [download]
    and here 
    sub popnum1 {
  ( $x, $y ) = @_;
  if ( ($y==0) || ($aod[$x][ $y-1 ] ne 'a') ) {
     return $initial + $aoa[$x][0];
  } else {
     return $aoa[$x][$y] + $aob[$x][ $y-1 ];
  }
}

    [download]
    moving the sprintf's to this line 
     
$coper = sprintf '%.2f', popnum1( $x, $y )

    [download]
    or consider combining the two subs into one so that you have 
     
$coper = sprintf '%.2f', popnum( $model, $x, $y )

    [download]
    hth poj
[reply]
[d/l]
[select]

      Shaved off another 15 lines. :)

      Sometimes you're just to close to a project to see the obvious (to everyone else) inefficiencies.

[reply]

In Section Seekers of Perl Wisdom