#!/usr/local/bin/perl
# $Id: ackermann.perl,v 1.9 2001/05/04 01:21:38 doug Exp $
# http://www.bagley.org/~doug/shootout/
use strict;
use integer;

# It's prettier but slower to do this
#sub Ack {
#    my($M, $N) = @_;
#    return( $N + 1 )         if ($M == 0);
#    return( Ack($M - 1, 1) ) if ($N == 0);
#    Ack($M - 1, Ack($M, $N - 1));
#}

# in our quest for speed, we must get ugly:
# it helps reduce stack frame size a little bit
# from Leif Stensson
sub Ack {
    return $_[0] ? ($_[1] ? Ack($_[0]-1, Ack($_[0], $_[1]-1))
            : Ack($_[0]-1, 1))
    : $_[1]+1;
}

my $NUM = $ARGV[0];
$NUM = 1 if ($NUM < 1);
my $ack = Ack(3, $NUM);
print "Ack(3,$NUM): $ack\n";

#!/usr/local/bin/perl
# $Id: ary3.perl,v 1.1 2001/05/31 02:27:48 doug Exp $
# http://www.bagley.org/~doug/shootout/

# this program is modified from:
#   http://cm.bell-labs.com/cm/cs/who/bwk/interps/pap.html
# Timing Trials, or, the Trials of Timing: Experiments with Scripting
# and User-Interface Languages</a> by Brian W. Kernighan and
# Christopher J. Van Wyk.

my $n = @ARGV[0] || 1;
my @X;
my @Y;

my $last = $n - 1;
for my $i (0..$last) {
    $X[$i] = $i + 1;
}
for my $k (0..999) {
    for my $i (reverse 0..$last) {
    $Y[$i] += $X[$i];
    }
}

print "$Y[0] $Y[$last]\n";

#!/usr/local/bin/perl
# $Id: wc.perl,v 1.2 2001/05/16 19:59:52 doug Exp $
# http://www.bagley.org/~doug/shootout/

# this program is modified from:
#   http://cm.bell-labs.com/cm/cs/who/bwk/interps/pap.html
# Timing Trials, or, the Trials of Timing: Experiments with Scripting
# and User-Interface Languages</a> by Brian W. Kernighan and
# Christopher J. Van Wyk.

use strict;

my($nl, $nw, $nc);

while(<STDIN>) {
    $nc += length;
    $nw += scalar(split);
    $nl += 1;
    # print "$nl $nw $nc\n";
}
print "$nl $nw $nc\n";
exit(0);
while (read(STDIN, $_, 4095)) {
    $_ .= <STDIN>;
    $nl += scalar(split(/\n/));
    $nc += length;
    $nw += scalar(split);
}
print "$nl $nw $nc\n";

#!/usr/local/bin/perl
# $Id: echo.perl,v 1.6 2001/05/27 16:44:24 doug Exp $
# http://www.bagley.org/~doug/shootout/

use Socket;

my $DATA = "Hello there sailor\n";

sub server_sock {
    local *SS;
    socket(SS, PF_INET, SOCK_STREAM, 0) or
    die "server/socket ($!)";
    setsockopt(SS, SOL_SOCKET, SO_REUSEADDR, pack("l", 1)) or
    die "server/setsockopt ($!)";
    bind(SS, sockaddr_in(0, INADDR_LOOPBACK)) or
    die "server/bind ($!)";
    listen(SS, 2);
    return(*SS);
}

sub get_port {
    local *SK = shift;
    (sockaddr_in(getsockname(SK)))[0];
}

sub client_sock {
    my $port = shift;
    local *CS;
    socket(CS, PF_INET, SOCK_STREAM, getprotobyname('tcp')) or
    die "client/socket ($!)";
    connect(CS, sockaddr_in($port, INADDR_LOOPBACK)) or
    die "client/connect ($!)";
    return(*CS);
}

sub echo_client {
    my($N, $port) = @_;
    local *SOCK = client_sock($port);
    select(SOCK);
    $| = 1;
    for my $i (0..($N-1)) {
    print $DATA;
    my $ans = <SOCK>;
    ($ans eq $DATA) or die qq{client: "$DATA" ne "$ans"};
    }
    close SOCK;
}

sub echo_server {
    my($N) = @_;
    local *SSOCK = server_sock();
    my $port = get_port(*SSOCK);
    my $pid = fork;
    defined $pid or die "server/fork ($!)";
    if ($pid) {
    # parent is server
    local *CSOCK;
    accept(CSOCK, SSOCK) or die "server/accept ($!)";
    select(CSOCK);
    $| = 1;
    my $n = 0;
    while (<CSOCK>) {
        print $_;
        $n += length($_);
    }
    select(STDOUT);
    print "server processed $n bytes\n";
    } else {
    # child is client
    echo_client($N, $port);
    }
    wait();
}

sub main {
    my $N = $ARGV[0] || 1;
    echo_server($N);
    exit(0);
}

main();

#!/usr/local/bin/perl
# $Id: except.perl,v 1.5 2001/05/27 00:23:52 doug Exp $
# http://www.bagley.org/~doug/shootout/

use integer;

my $HI = 0;
my $LO = 0;
my $NUM = $ARGV[0];
$NUM = 1 if ($NUM < 1);

package Lo_Exception;

sub new {
    bless({Val => shift}, __PACKAGE__);
}

package Hi_Exception;

sub new {
    bless({Val => shift}, __PACKAGE__);
}

package main;

sub some_function {
    my $num = shift;
    eval {
    &hi_function($num);
    };
    if ($@) {
    die "We shouldn't get here ($@)";
    }
}

sub hi_function {
    my $num = shift;
    eval {
    &lo_function($num);
    };
    if (ref($@) eq "Hi_Exception") {
    $HI++;        # handle
    } elsif ($@) {
    die $@;        # rethrow
    }
}

sub lo_function {
    my $num = shift;
    eval {
    &blowup($num);
    };
    if (ref($@) eq "Lo_Exception") {
    $LO++;        # handle
    } elsif ($@) {
    die $@;        # rethrow
    }
}

sub blowup {
    my $num = shift;
    if ($num % 2) {
    die Lo_Exception->new(Num => $num);
    } else {
    die Hi_Exception->new(Num => $num);
    }
}

$NUM = $ARGV[0];
while ($NUM--) {
    &some_function($NUM);
}
print "Exceptions: HI=$HI / LO=$LO\n";

#!/usr/local/bin/perl
# $Id: fibo.perl,v 1.4 2001/02/20 02:12:08 doug Exp $
# http://www.bagley.org/~doug/shootout/

use strict;
use integer;

# from Leif Stensson
sub fib {
    return $_[0] < 2 ? 1 : fib($_[0]-2) + fib($_[0]-1);
}

my $N = ($ARGV[0] < 1) ? 1 : $ARGV[0];
my $fib = fib($N);
print "$fib\n";

#!/usr/local/bin/perl
# $Id: hash.perl,v 1.3 2001/05/16 16:11:41 doug Exp $
# http://www.bagley.org/~doug/shootout/

# this program is modified from:
#   http:#cm.bell-labs.com/cm/cs/who/bwk/interps/pap.html
# Timing Trials, or, the Trials of Timing: Experiments with Scripting
# and User-Interface Languages</a> by Brian W. Kernighan and
# Christopher J. Van Wyk.

use strict;

my $n = $ARGV[0] || 1;
my %X = ();
my $c = 0;

for my $i (1..$n) {
    $X{sprintf('%x', $i)} = $i;
}
for my $i (reverse 1..$n) {
    ++$c if exists $X{$i};
}
print "$c\n";

#!/usr/local/bin/perl
# $Id: hash2.perl,v 1.3 2001/01/18 23:38:26 doug Exp $
# http://www.bagley.org/~doug/shootout/
# with help from Steve Fink

use strict;

my $n = ($ARGV[0] > 0) ? $ARGV[0] : 1;
my %hash1 = ();
$hash1{"foo_$_"} = $_ for 0..9999;
my %hash2 = ();
my($k, $v);
for (1..$n) {
    $hash2{$_} += $hash1{$_} while (defined ($_ = each %hash1));
}
print "$hash1{foo_1} $hash1{foo_9999} $hash2{foo_1} $hash2{foo_9999}\n";

#!/usr/local/bin/perl 
# $Id: heapsort.perl,v 1.11 2001/05/08 02:46:59 doug Exp $
# http://www.bagley.org/~doug/shootout/
# Matt Harris suggested passing the array via typeglob

use strict;

use constant IM => 139968;
use constant IA =>   3877;
use constant IC =>  29573;

use vars qw(@ra);

my $LAST = 42;
sub gen_random { ($_[0] * ($LAST = ($LAST * IA + IC) % IM)) / IM }

sub heapsort ($\@) {
    my $n = shift;
    # use typeglob ra to refer to array.
    local *ra = shift;

    my($rra, $i, $j);

    my $l = ($n >> 1) + 1;
    my $ir = $n;
    while (1) {
        if ($l > 1) {
            $rra = $ra[--$l];
        } else {
            $rra = $ra[$ir];
            # print('ir=1  ', $ir, ' <- ', 1, ' (', sprintf("%.10g", $ra[1]), ')', "\n" );    
            $ra[$ir] = $ra[1];
            if (--$ir == 1) {
                # print('1=rra ', 1, ' <- ', sprintf("%.10g", $rra), "\n" );    
                $ra[1] = $rra;
                return;
            }
        }
        $i = $l;
        $j = $l << 1;
        # print "      l=$l i=$i j=$j ir=$ir\n";
        while ($j <= $ir) {
            $j++ if (($j < $ir) && ($ra[$j] < $ra[$j+1]));
            # print("      in2while, j=$j rra=", sprintf("%.10g", $rra), ' ra(j)=', sprintf("%.10g", $ra[$j]), "\n");
            if ($rra < $ra[$j]) {
                # print('i=j   ', $i, ' <- ', $j, ' (', sprintf("%.10g", $ra[$j]), ')', "\n" );    
                $ra[$i] = $ra[$j];
                $j += ($i = $j);
            } else {
                $j = $ir + 1;
            }
        }
        # print('i=rra ', $i, ' <- ', sprintf("%.10g", $rra), "\n" );    
        $ra[$i] = $rra;
    }
}


my $N = $ARGV[0];
$N = 1 if ($N < 1);

# create an array of N random doubles
my @ary = ();
for (my $i=1; $i<=$N; $i++) {
    $ary[$i] = gen_random(1.0);
}

heapsort($N, @ary);

printf("%.10g\n", $ary[-1]);

#!/usr/local/bin/perl
# $Id: hello.perl,v 1.1 2001/06/17 22:00:34 doug Exp $
# http://www.bagley.org/~doug/shootout/

print "hello world\n";

#!/usr/local/bin/perl 
# $Id: lists.perl,v 1.3 2001/05/06 15:50:16 doug Exp $
use strict;

my $SIZE = 10000;

my $ITER = $ARGV[0];
$ITER = 1 if ($ITER < 1);

my $result = 0;
while ($ITER--) {
    $result = &test_lists();
}
print "$result\n";

sub test_lists {
    # create a list of integers (Li1) from 1 to SIZE
    my @Li1 = (1..$SIZE);
    # copy the list to Li2 (not by individual items)
    my @Li2 = @Li1;
    my @Li3 = ();
    # remove each individual item from left side of Li2 and
    # append to right side of Li3 (preserving order)
    push(@Li3, shift @Li2) while (@Li2);
    # Li2 must now be empty
    # remove each individual item from right side of Li3 and
    # append to right side of Li2 (reversing list)
    push(@Li2, pop @Li3) while (@Li3);
    # Li3 must now be empty
    # reverse Li1 in place
    @Li1 = reverse @Li1;
    # check that first item is now SIZE
    return(0) if $Li1[0] != $SIZE;
    # compare Li1 and Li2 for equality
    my $len1 = scalar(@Li1);
    my $len2 = scalar(@Li2);
    my $lists_equal = ($len1 == $len2);
    return(0) if not $lists_equal;
    for my $i (0..($len1-1)) {
    if ($Li1[$i] != $Li2[$i]) {
        $lists_equal = 0;
        last;
    }
    }
    return(0) if not $lists_equal;
    # return the length of the list
    return($len1);
}

#!/usr/local/bin/perl 
# $Id: matrix.perl,v 1.1 2000/12/29 06:10:10 doug Exp $
# http://www.bagley.org/~doug/shootout/

# This program based on the original from:
# "The What, Why, Who, and Where of Python" By Aaron R. Watters
# http://www.networkcomputing.com/unixworld/tutorial/005/005.html

# modified to pass rows and cols, and avoid matrix size checks
# I've sped up the original quite a bit by removing some loop
# invariants and declaring "use integer"

use strict;
use integer;

my $size = 30;

sub mkmatrix {
    my($rows, $cols) = @_;
    --$rows; --$cols;
    my $count = 1;
    my @mx = ();
    foreach (0 .. $rows) {
    my @row = ();
    $row[$_] = $count++ foreach (0 .. $cols);
    push(@mx, \@row);
    }
    return(\@mx);
}

# mmult contributed by Tony Bowden

sub mmult {
    my ($rows, $cols, $m1, $m2) = @_;
    my $m3 = [];
    --$rows; --$cols;
    for my $i (0 .. $rows) {
        for my $j (0 .. $cols) {
            $m3->[$i][$j] += $m1->[$i][$_] * $m2->[$_][$j] for 0..$cols;
        }
    }
    return $m3;
}

#sub mmult {
#    my ($rows, $cols, $m1, $m2) = @_;
#    my @m3 = ();
#    --$rows; --$cols;
#    for my $i (0 .. $rows) {
#    my @row = ();
#    my $m1i = $m1->[$i];
#    for my $j (0 .. $cols) {
#        my $val = 0;
#        for my $k (0 .. $cols) {
#        $val += $m1i->[$k] * $m2->[$k]->[$j];
#        }
#        push(@row, $val);
#    }
#    push(@m3, \@row);
#    }
#    return(\@m3);
#}

my $N = $ARGV[0] || 1;

my $m1 = mkmatrix($size, $size);
my $m2 = mkmatrix($size, $size);
my $mm;
while ($N--) {
    $mm = mmult($size, $size, $m1, $m2);
}
print "$mm->[0]->[0] $mm->[2]->[3] $mm->[3]->[2] $mm->[4]->[4]\n";

#!/usr/local/bin/perl
# $Id: methcall.perl,v 1.5 2001/05/27 16:44:24 doug Exp $
# http://www.bagley.org/~doug/shootout/
# with help from Ben Tilly

package Toggle;

sub new {
    my($class, $start_state) = @_;
    bless( { Bool => $start_state }, $class );
}

sub value {
    (shift)->{Bool};
}

sub activate {
    my $self = shift;
    $self->{Bool} ^= 1;
    return($self);
}


package NthToggle;
our @ISA = qw(Toggle);

sub new {
    my($class, $start_state, $max_counter) = @_;
    my $self = $class->SUPER::new($start_state);
    $self->{CountMax} = $max_counter;
    $self->{Counter} = 0;
    return($self);
}

sub activate {
    my $self = shift;
    if (++$self->{Counter} >= $self->{CountMax}) {
    $self->{Bool} ^= 1;
    $self->{Counter} = 0;
    }
    return($self);
}


package main;

sub main {
    my $NUM = $ARGV[0];
    $NUM = 1 if ($NUM < 1);

    my $val = 1;
    my $toggle = Toggle->new($val);
    for (1..$NUM) {
    $val = $toggle->activate->value;
    }
    print (($val) ? "true\n" : "false\n");

    $val = 1;
    my $ntoggle = NthToggle->new($val, 3);
    for (1..$NUM) {
    $val = $ntoggle->activate->value;
    }
    print (($val) ? "true\n" : "false\n");
}

main();

#!/usr/local/bin/perl
# $Id: nestedloop.perl,v 1.2 2000/12/30 21:42:57 doug Exp $
# http://www.bagley.org/~doug/shootout/

use strict;

my $n = ($ARGV[0] > 0) ? $ARGV[0] : 1;
my $x = 0;
my $a = $n;
while ($a--) {
    my $b = $n;
    while ($b--) {
    my $c = $n;
    while ($c--) {
        my $d = $n;
        while ($d--) {
        my $e = $n;
        while ($e--) {
            my $f = $n;
            while ($f--) {
            $x++;
            }
        }
        }
    }
    }
}
print "$x\n";

#!/usr/local/bin/perl 
# $Id: objinst.perl,v 1.6 2001/06/29 23:12:37 doug Exp $
# http://www.bagley.org/~doug/shootout/

use strict;


package Toggle;

sub new {
    my($class, $start_state) = @_;
    bless( { Bool => $start_state }, $class );
}

sub value {
    my $self = shift;
    return($self->{Bool});
}

sub activate {
    my $self = shift;
    $self->{Bool} ^= 1;
    return($self);
}


package NthToggle;
@NthToggle::ISA = qw(Toggle);

sub new {
    my($class, $start_state, $max_counter) = @_;
    my $self = $class->SUPER::new($start_state);
    $self->{CountMax} = $max_counter;
    $self->{Counter} = 0;
    return($self);
}

sub activate {
    my $self = shift;
    if (++$self->{Counter} >= $self->{CountMax}) {
    $self->{Bool} ^= 1;
    $self->{Counter} = 0;
    }
    return($self);
}


package main;

sub main {
    my $NUM = ($ARGV[0] > 0) ? $ARGV[0] : 1;

    my $toggle = Toggle->new(1);
    for (1..5) {
    print (($toggle->activate->value) ? "true\n" : "false\n");
    }
    for (1..$NUM) {
    $toggle = Toggle->new(1);
    }

    print "\n";

    my $ntoggle = NthToggle->new(1, 3);
    for (1..8) {
    print (($ntoggle->activate->value) ? "true\n" : "false\n");
    }
    for (1..$NUM) {
    $ntoggle = NthToggle->new(1, 3);
    }
}

main();

#!/usr/local/test/bin/perl
# $Id: prodcons.perl,v 1.2 2001/01/19 04:29:45 doug Exp $
# http://www.bagley.org/~doug/shootout/

use strict;
use Thread qw(cond_wait cond_signal);

my $count = 0;
my $data = 0;
my $produced = 0;
my $consumed = 0;

sub consumer {
    my $n = shift;
    while (1) {
    lock($count);
    cond_wait($count) while ($count == 0);
    my $i = $data;
    $count = 0;
    $consumed++;
    last if ($i == $n);
    cond_signal($count);
    }
}

sub producer {
    my $n = shift;
    for (my $i=1; $i<=$n; $i++) {
    lock($count);
    cond_wait($count) while ($count == 1);
    $data = $i;
    $count = 1;
    $produced++;
    cond_signal($count);
    }
}

sub main {
    my $n = ($ARGV[0] < 1) ? 1 : $ARGV[0];
    my $p = Thread->new(\&producer, $n);
    my $c = Thread->new(\&consumer, $n);
    $p->join;
    $c->join;
    print "$produced $consumed\n";
}

&main();

#!/usr/local/bin/perl 
# $Id: random.perl,v 1.13 2001/05/08 01:51:39 doug Exp $
# http://www.bagley.org/~doug/shootout/

use strict;

use constant IM => 139968;
use constant IA => 3877;
use constant IC => 29573;

my $LAST = 42;
sub gen_random { ($_[0] * ($LAST = ($LAST * IA + IC) % IM)) / IM }

my $result = 0;
my $N = $ARGV[0] || 1;
while ($N--) {
    $result = &gen_random(100);
}
printf "%.9f\n", $result;

#!/usr/local/bin/perl 
# $Id: regexmatch.perl,v 1.5 2000/10/07 08:41:43 doug Exp $
# http://www.bagley.org/~doug/shootout/

use strict;

my $re = qr{
    (?: ^ | [^\d\(])        # must be preceeded by non-digit
    ( \( )?            # match 1: possible initial left paren
    (\d\d\d)            # match 2: area code is 3 digits
    (?(1) \) )            # if match1 then match right paren
    [ ]                # area code followed by one space
    (\d\d\d)            # match 3: prefix of 3 digits
    [ -]            # separator is either space or dash
    (\d\d\d\d)            # match 4: last 4 digits
    \D                # must be followed by a non-digit
}x;

my $NUM = $ARGV[0];
$NUM = 1 if ($NUM < 1);

my @phones = <STDIN>;
my $count = 0;
my $num;
while ($NUM--) {
    foreach (@phones) {
    if (/$re/o) {
        $num = "($2) $3-$4";
        if (0 == $NUM) {
        $count++;
        print "$count: $num\n";
        }
    }
    }
}

#!/usr/local/bin/perl
# $Id: reversefile.perl,v 1.4 2001/05/14 01:03:20 doug Exp $
# http://www.bagley.org/~doug/shootout/

undef($/);
print join("\n", reverse split(/\n/, <STDIN>)),"\n";

#!/usr/local/bin/perl 
# $Id: sieve.perl,v 1.10 2001/05/06 04:37:45 doug Exp $
# http://www.bagley.org/~doug/shootout/

use strict;
use integer;

# Tony Bowden suggested using 0..8192 to create the array
# and to test for defined instead of the value.

my $NUM = $ARGV[0];
$NUM = 1 if ($NUM < 1);
my $count;
my @flags = ();
while ($NUM--) {
    $count = 0; 
    my @flags = (0 .. 8192);
    for my $i (2 .. 8192 ) {
        next unless defined $flags[$i];
        # remove all multiples of prime: i
        for (my $k=$i+$i; $k <= 8192; $k+=$i) {
            undef $flags[$k];
        }
        $count++;
    }
}
print "Count: $count\n";

#!/usr/local/bin/perl
# $Id: spellcheck.perl,v 1.4 2001/01/23 01:30:42 doug Exp $
# http://www.bagley.org/~doug/shootout/

use strict;

# read dictionary
my %dict = ();
open(DICT, "<Usr.Dict.Words") or
    die "Error, unable to open Usr.Dict.Words\n";
while (<DICT>) {
    chomp;
    $dict{$_} = 1;
}
close(DICT);

while (<STDIN>) {
    chomp;
    print "$_\n" if (!$dict{$_});
}

#!/usr/local/bin/perl
# $Id: moments.perl,v 1.5 2001/01/05 22:36:44 doug Exp $
# http://www.bagley.org/~doug/shootout/

use strict;

my @nums = <STDIN>;
my $sum = 0;
foreach (@nums) { $sum += $_ }
my $n = scalar(@nums);
my $mean = $sum/$n;
my $average_deviation = 0;
my $standard_deviation = 0;
my $variance = 0;
my $skew = 0;
my $kurtosis = 0;
foreach (@nums) {
    my $deviation = $_ - $mean;
    $average_deviation += abs($deviation);
    $variance += $deviation**2;
    $skew += $deviation**3;
    $kurtosis += $deviation**4;
}
$average_deviation /= $n;
$variance /= ($n - 1);
$standard_deviation = sqrt($variance);

if ($variance) {
    $skew /= ($n * $variance * $standard_deviation);
    $kurtosis = $kurtosis/($n * $variance * $variance) - 3.0;
}

@nums = sort { $a <=> $b } @nums;
my $mid = int($n/2);
my $median = ($n % 2) ? $nums[$mid] : ($nums[$mid] + $nums[$mid-1])/2;

printf("n:                  %d\n", $n);
printf("median:             %f\n", $median);
printf("mean:               %f\n", $mean);
printf("average_deviation:  %f\n", $average_deviation);
printf("standard_deviation: %f\n", $standard_deviation);
printf("variance:           %f\n", $variance);
printf("skew:               %f\n", $skew);
printf("kurtosis:           %f\n", $kurtosis);

#!/usr/local/bin/perl 
# $Id: strcat.perl,v 1.4 2001/04/29 06:13:05 doug Exp $
# http://www.bagley.org/~doug/shootout/

use strict;

my $NUM = $ARGV[0];
$NUM = 1 if ($NUM < 1);

my $str = "";
$str .= "hello\n" foreach (1..$NUM);
print length($str),"\n";

#!/usr/local/bin/perl
# $Id: sumcol.perl,v 1.4 2000/10/07 08:41:44 doug Exp $
# http://www.bagley.org/~doug/shootout/

use integer;
shift;
while (<>) { $tot += $_ }
print "$tot\n";

#!/usr/local/bin/perl
# $Id: wordfreq.perl,v 1.13 2001/05/16 23:46:40 doug Exp $
# http://www.bagley.org/~doug/shootout/

# Tony Bowden suggested using tr versus lc and split(/[^a-z]/)

use strict;

my %count = ();
while (read(STDIN, $_, 4095) and $_ .= <STDIN>) {
    tr/A-Za-z/ /cs;
    ++$count{$_} foreach split(' ', lc $_);
}

my @lines = ();
my ($w, $c);
push(@lines, sprintf("%7d\t%s\n", $c, $w)) while (($w, $c) = each(%count));
print sort { $b cmp $a } @lines;