chrislo-sourceclassifier 0.2.0

data/sources/perl/fibo.perl

@@ -0,0 +1,15 @@
+#!/usr/bin/perl
+# $Id: fibo.perl,v 1.5 2005-04-25 19:01:38 igouy-guest 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";

data/sources/perl/harmonic.perl

@@ -0,0 +1,7 @@
+#!/usr/bin/perl -w
+# The Great Computer Language Shootout
+# http://shootout.alioth.debian.org/
+# contributed by Greg Buchholz
+
+$sum += 1/$_ for 1..$ARGV[0];
+printf "%.9f\n", $sum;

data/sources/perl/hash.perl

@@ -0,0 +1,23 @@
+#!/usr/bin/perl
+# $Id: hash.perl,v 1.1.1.1 2004-05-19 18:09:55 bfulgham 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";

data/sources/perl/hash.perl-2.perl

@@ -0,0 +1,17 @@
+#!/usr/bin/perl
+use integer;
+
+$n = $ARGV[0] || 1;
+%X = ();
+$c = 0;
+keys %X=$n;
+for ($i=0; $i<$n;) {
+    $X{sprintf('%x', $i)} = ++$i;
+    $X{sprintf('%x', $i)} = ++$i;
+    $X{sprintf('%x', $i)} = ++$i;
+    $X{sprintf('%x', $i)} = ++$i;
+}
+for ($i=$n+1; $i>0;) {
+    $c+=exists($X{--$i}) + exists($X{--$i}) + exists($X{--$i}) + exists($X{--$i});
+}
+print $c,"\n";

data/sources/perl/hash.perl-3.perl

@@ -0,0 +1,24 @@
+#!/usr/bin/perl
+# $Id: hash.perl-3.perl,v 1.1 2004-11-10 06:34:44 bfulgham 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 = ();
+keys %X = $n / 3;
+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";

data/sources/perl/hash2.perl

@@ -0,0 +1,16 @@
+#!/usr/bin/perl
+# $Id: hash2.perl,v 1.1.1.1 2004-05-19 18:10:02 bfulgham 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";

data/sources/perl/heapsort.perl

@@ -0,0 +1,65 @@
+#!/usr/bin/perl 
+# $Id: heapsort.perl,v 1.1.1.1 2004-05-19 18:10:10 bfulgham 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];
+	    $ra[$ir] = $ra[1];
+	    if (--$ir == 1) {
+		$ra[1] = $rra;
+		return;
+	    }
+	}
+	$i = $l;
+	$j = $l << 1;
+	while ($j <= $ir) {
+	    $j++ if (($j < $ir) && ($ra[$j] < $ra[$j+1]));
+	    if ($rra < $ra[$j]) {
+		$ra[$i] = $ra[$j];
+		$j += ($i = $j);
+	    } else {
+		$j = $ir + 1;
+	    }
+	}
+	$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("%.10f\n", $ary[-1]);
+

data/sources/perl/hello.perl

@@ -0,0 +1,5 @@
+#!/usr/bin/perl
+# $Id: hello.perl,v 1.1.1.1 2004-05-19 18:10:16 bfulgham Exp $
+# http://www.bagley.org/~doug/shootout/
+
+print "hello world\n";

data/sources/perl/knucleotide.perl-2.perl

@@ -0,0 +1,30 @@
+#  The Computer Language Benchmarks Game
+#  http://shootout.alioth.debian.org/
+#  contributed by Karl FORNER
+# (borrowed fasta loading routine from Kjetil Skotheim, 2005-11-29)
+# Corrected again by Jesse Millikan
+# revised by Kuang-che Wu
+
+my ($sequence);
+$/ = ">";
+/^THREE/ and $sequence = uc(join "", grep !/^THREE/, split /\n+/) while <STDIN>;
+
+my ($l,%h,$sum) = (length $sequence);
+foreach my $frame (1,2) {
+  %h = ();
+  update_hash_for_frame($frame);
+  $sum = $l - $frame + 1;
+  printf "$_ %.3f\n", $h{$_}*100/$sum for sort { $h{$b} <=> $h{$a} || $a cmp $b } keys %h;
+  print "\n";
+}
+
+foreach my $s (qw(GGT GGTA GGTATT GGTATTTTAATT GGTATTTTAATTTATAGT)) {
+  update_hash_for_frame(length($s));
+  printf "%d\t$s\n", $h{$s};
+}
+
+sub update_hash_for_frame {
+  my $frame = $_[0];
+  $h{substr($sequence,$_,$frame)}++ foreach (0..($l - $frame));
+}
+

data/sources/perl/lists.perl

@@ -0,0 +1,48 @@
+#!/usr/bin/perl 
+# $Id: lists.perl,v 1.1.1.1 2004-05-19 18:10:24 bfulgham 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);
+}

data/sources/perl/mandelbrot.perl-2.perl

@@ -0,0 +1,32 @@
+# The Computer Language Shootout
+# http://shootout.alioth.debian.org/
+# implemented by Greg Buchholz
+# streamlined by Kalev Soikonen
+
+sub ITER ()	{ 50 }
+sub LIMITSQR ()	{ 2.0 ** 2 }
+
+my ($w, $h, $i);
+my ($Cr, $Ci, $Zr, $Zi, $Tr, $Ti);
+
+sub dot {
+    $Cr = 2 * $_[0] / $w - 1.5;
+    $Ci = 2 * $_[1] / $h - 1.0;
+
+    $Zr = $Zi = $Tr = $Ti = 0.0;
+    $i = ITER;
+    (
+	$Zi = 2.0 * $Zr * $Zi + $Ci,
+	$Zr = $Tr - $Ti + $Cr,
+	$Ti = $Zi * $Zi,
+	$Tr = $Zr * $Zr
+    ) until ($Tr + $Ti > LIMITSQR || !$i--);
+    return ($i == -1);
+}
+
+$w = $h = shift || 80;
+print "P4\n$w $h\n";
+for my $y (0..$h-1) {
+    print pack 'B*', pack 'C*', map dot($_, $y), 0..$w-1;
+}
+

data/sources/perl/matrix.perl

@@ -0,0 +1,59 @@
+#!/usr/bin/perl 
+# $Id: matrix.perl,v 1.1.1.1 2004-05-19 18:10:34 bfulgham 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);
+}
+
+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";
+

data/sources/perl/message.perl

@@ -0,0 +1,27 @@
+# The Computer Language Benchmarks Game
+# http://shootout.alioth.debian.org/
+# contributed by Sean O'Rourke
+
+use threads;
+use Thread::Queue;
+
+my $t = 500;
+my $n = shift;
+
+my @q : shared;
+@q = map { new Thread::Queue } 1..$t;
+
+for my $i (1..$t-1) {
+    (async {
+        while (!$done) {
+            $q[$i]->enqueue(1+$q[$i-1]->dequeue);
+        }
+    })->detach;
+}
+
+for (1..$n) {
+    $q[0]->enqueue(0);
+    $sum += $q[-1]->dequeue + 1;
+}
+
+print "$sum\n";

data/sources/perl/methcall.perl

@@ -0,0 +1,66 @@
+#!/usr/bin/perl
+# $Id: methcall.perl,v 1.1.1.1 2004-05-19 18:10:41 bfulgham 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();