chrislo-sourceclassifier 0.2.0

data/sources/perl/except.perl

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

data/sources/perl/fannkuch.perl

@@ -0,0 +1,44 @@
+# The Computer Language Benchmarks Game
+# http://shootout.alioth.debian.org/
+# Initial port from C by Steve Clark
+# Rewrite by Kalev Soikonen
+# Modified by Kuang-che Wu
+
+use integer;
+
+sub fannkuch {
+    my ($n) = shift;
+    my ($iter, $flips, $maxflips, $i);
+    my (@q, @p, @count);
+
+    $iter = $maxflips = 0;
+    @p = @count = (1..$n);
+    $m = $n - 1;
+
+    TRY: while (1) {
+	if ($iter < 30) {
+	    print @p, "\n";
+	    $iter++;
+	}
+
+	if ($p[0] != 1 && $p[$m] != $n) {
+	    @q = @p;
+	    for ($flips=0; $q[0] != 1; $flips++) {
+		unshift @q, reverse splice @q, 0, $q[0];
+	    }
+	    $maxflips = $flips if ($flips > $maxflips);
+	}
+
+	for my$i(1..$m) {
+	    splice @p, $i, 0, shift @p;
+	    next TRY if (--$count[$i]);
+	    $count[$i] = $i + 1;
+	}
+	return $maxflips;
+    }
+}
+
+for (shift || 7) {
+    print "Pfannkuchen($_) = ".fannkuch($_)."\n";
+}
+

data/sources/perl/fannkuch.perl-2.perl

@@ -0,0 +1,38 @@
+# The Computer Language Shootout
+# http://shootout.alioth.debian.org/
+# Initial port from C by Steve Clark
+# Rewrite by Kalev Soikonen
+
+sub fannkuch {
+    my ($n) = shift;
+    my ($iter, $flips, $maxflips, $i);
+    my (@q, @p, @count);
+
+    $iter = $maxflips = 0;
+    @p = @count = (1..$n);
+
+    TRY: while (1) {
+	print @p, "\n" if ($iter++ < 30);
+
+#	splice @count, 0, $i, (1..$i);
+
+	$flips = 0;
+	for (@q = @p; $q[0] != 1; ) {
+	    unshift @q, reverse splice @q, 0, $q[0];
+	    $flips++;
+	}
+	$maxflips = $flips if ($flips > $maxflips);
+
+	for ($i = 1; $i < $n; $i++) {
+	    splice @p, $i, 0, shift @p;
+	    next TRY if (--$count[$i]);
+	    $count[$i] = $i + 1;
+	}
+	return $maxflips;
+    }
+}
+
+for (shift || 7) {
+    print "Pfannkuchen($_) = ".fannkuch($_)."\n";
+}
+

data/sources/perl/fasta.perl

@@ -0,0 +1,112 @@
+# The Computer Language Shootout
+# http://shootout.alioth.debian.org/
+#
+# contributed by David Pyke
+# tweaked by Danny Sauer
+# Butchered by Jesse Millikan
+
+use constant IM => 139968;
+use constant IA => 3877;
+use constant IC => 29573;
+
+use constant LINELENGTH => 60;
+
+my $LAST = 42;
+
+sub makeCumulative {
+    my($genelist) = @_;
+    my $cp = 0.0;
+
+    foreach (@$genelist){
+        $_->[1] = $cp += $_->[1];
+    }
+}
+
+sub makeRandomFasta {
+    my($id,$desc,$n,$genelist) = @_;
+
+    print ">$id $desc\n";
+    my $pick, $r;
+
+	while($n > 0){
+		$pick='';
+
+		# Get LINELENGTH chars or what's left of $n
+        CHAR: foreach (1 .. ($n > LINELENGTH ? LINELENGTH : $n)){
+    		$rand = ($LAST = ($LAST * IA + IC) % IM) / IM;
+
+			# Select gene and append it
+    		foreach (@$genelist){
+				if($rand < $_->[1]){
+					$pick .= $_->[0];
+					next CHAR;
+				}
+    		}
+        }
+
+        print "$pick\n";
+		$n -= LINELENGTH;
+    }
+}
+
+# Print $n characters of $s (repeated if nessary) with newlines every LINELENGTH
+sub makeRepeatFasta {
+    my($id,$desc,$s,$n) = @_;
+
+    print ">$id $desc\n";
+
+	my $ss;
+	while($n > 0){
+		# Overfill $ss with $s
+		$ss .= $s while length $ss < LINELENGTH;
+		# Print LINELENGTH chars or whatever's left of $n
+        print substr($ss,0,$n > LINELENGTH ? LINELENGTH : $n,""), "\n";
+		$n -= LINELENGTH;
+	}
+}
+
+my $iub = [
+    [a, 0.27],
+    [c, 0.12],
+    [g, 0.12],
+    [t, 0.27],
+    [B, 0.02],
+    [D, 0.02],
+    [H, 0.02],
+    [K, 0.02],
+    [M, 0.02],
+    [N, 0.02],
+    [R, 0.02],
+    [S, 0.02],
+    [V, 0.02],
+    [W, 0.02],
+    [Y, 0.02]
+];
+
+my $homosapiens = [
+    [a, 0.3029549426680],
+    [c, 0.1979883004921],
+    [g, 0.1975473066391],
+    [t, 0.3015094502008]
+];
+
+$alu =
+    'GGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGG' .
+    'GAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGA' .
+    'CCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAAT' .
+    'ACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCA' .
+    'GCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGG' .
+    'AGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCC' .
+    'AGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAA';
+
+#main
+
+my $n = ($ARGV[0] || 1000) ;
+
+makeCumulative $iub;
+makeCumulative $homosapiens;
+
+makeRepeatFasta ('ONE', 'Homo sapiens alu', $alu, $n*2);
+makeRandomFasta ('TWO', 'IUB ambiguity codes', $n*3, $iub);
+makeRandomFasta ('THREE', 'Homo sapiens frequency', $n*5, $homosapiens);
+

data/sources/perl/fasta.perl-2.perl

@@ -0,0 +1,135 @@
+#!/usr/bin/perl
+
+# The Great Computer Language Shootout
+# http://shootout.alioth.debian.org/
+#
+# contributed by David Pyke
+# tweaked by Danny Sauer
+
+use constant IM => 139968;
+use constant IA => 3877;
+use constant IC => 29573;
+
+use constant LINELENGTH => 60;
+
+my $LAST = 42;
+sub gen_random ($) {
+    return ( ($_[0] * ($LAST = ($LAST * IA + IC) % IM)) / IM );
+}
+
+sub makeCumulative($){
+    my($genelist) = @_;
+    $cp = 0.0;
+
+    foreach (@$genelist){
+        $_->[1] = $cp += $_->[1];
+    }
+}
+
+sub selectRandom($){
+    my($genelist) = @_;
+    $r = gen_random (1);
+
+    foreach (@$genelist){
+        if ($r < $_->[1]){ return $_->[0]; }
+    }
+}
+
+
+sub makeRandomFasta($$$$){
+#void makeRandomFasta (const char * id, const char * desc, const struct aminoacids * genelist, int count, int n) {
+    my($id,$desc,$n,$genelist) = @_;
+
+    print ">$id $desc\n";
+    $pick='';
+
+    # print whole lines
+    foreach (1 .. int($n / LINELENGTH) ){
+        foreach (1 ..  LINELENGTH ){
+            $pick .= selectRandom($genelist);
+        }
+        print "$pick\n";
+        $pick = '';
+    }
+    #print remaining line (if required)
+    if ($n % LINELENGTH){
+        foreach (1 ..  $n % LINELENGTH ){
+            $pick .= selectRandom($genelist);
+        }
+        print "$pick\n";
+    }
+}
+
+sub makeRepeatFasta($$$$){
+#void makeRepeatFasta (const char * id, const char * desc, const char * s, int n) {
+    # we want to print $n characters of $s (repeated if nessary) with newlines every LINELENGTH
+    my($id,$desc,$s,$n) = @_;
+
+    print ">$id $desc\n";
+
+    # what we need, and the extra (if any) will be discarded.
+    foreach (1 .. int($n / LINELENGTH) ){
+        while (length $ss < LINELENGTH){
+            $ss .= $s;
+        }
+        print substr($ss,0,LINELENGTH), "\n";
+        $ss = substr($ss,LINELENGTH);
+    }
+    #final_line
+    while (length $ss < LINELENGTH){
+        $ss .= $s;
+    }
+    print substr($ss, 0, ($n % LINELENGTH)), "\n";
+print STDERR "\n";
+}
+
+
+my $iub = [
+    [ 'a', 0.27 ],
+    [ 'c', 0.12 ],
+    [ 'g', 0.12 ],
+    [ 't', 0.27 ],
+    [ 'B', 0.02 ],
+    [ 'D', 0.02 ],
+    [ 'H', 0.02 ],
+    [ 'K', 0.02 ],
+    [ 'M', 0.02 ],
+    [ 'N', 0.02 ],
+    [ 'R', 0.02 ],
+    [ 'S', 0.02 ],
+    [ 'V', 0.02 ],
+    [ 'W', 0.02 ],
+    [ 'Y', 0.02 ]
+];
+
+my $homosapiens = [
+    [ 'a', 0.3029549426680 ],
+    [ 'c', 0.1979883004921 ],
+    [ 'g', 0.1975473066391 ],
+    [ 't', 0.3015094502008 ]
+];
+
+$alu =
+    'GGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGG' .
+    'GAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGA' .
+    'CCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAAT' .
+    'ACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCA' .
+    'GCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGG' .
+    'AGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCC' .
+    'AGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAA';
+
+######################################################################
+#main
+
+my $n = ($ARGV[0] || 1000) ;
+
+makeCumulative $iub;
+makeCumulative $homosapiens;
+
+makeRepeatFasta ('ONE', 'Homo sapiens alu', $alu, $n*2);
+makeRandomFasta ('TWO', 'IUB ambiguity codes', $n*3, $iub);
+makeRandomFasta ('THREE', 'Homo sapiens frequency', $n*5, $homosapiens);
+
+exit 0;
+
+#END OF FILE

data/sources/perl/fasta.perl-4.perl

@@ -0,0 +1,122 @@
+# The Computer Language Benchmarks game
+# http://shootout.alioth.debian.org/
+#
+# contributed by David Pyke
+# tweaked by Danny Sauer
+# optimized by Steffen Mueller
+# tweaked by Kuang-che Wu
+
+use strict;
+use warnings;
+use constant IM => 139968;
+use constant IA => 3877;
+use constant IC => 29573;
+
+use constant LINELENGTH => 60;
+
+my $LAST = 42;
+sub gen_random {
+    return map {( ($_[0] * ($LAST = ($LAST * IA + IC) % IM)) / IM )} 1..($_[1]||1);
+}
+
+sub makeCumulative {
+    my $genelist = shift;
+    my $cp = 0.0;
+
+    $_->[1] = $cp += $_->[1] foreach @$genelist;
+}
+
+sub selectRandom {
+    my $genelist = shift;
+    my $number = shift || 1;
+    my @r = gen_random(1, $number);
+
+    my $s;
+    foreach my $r (@r) {
+        foreach (@$genelist){
+            if ($r < $_->[1]) { $s .= $_->[0]; last; }
+        }
+    }
+
+    return $s;
+}
+
+
+sub makeRandomFasta {
+    my ($id, $desc, $n, $genelist) = @_;
+
+    print ">", $id, " ", $desc, "\n";
+
+    # print whole lines
+    foreach (1 .. int($n / LINELENGTH) ){
+        print selectRandom($genelist, LINELENGTH), "\n";
+    }
+    # print remaining line (if required)
+    if ($n % LINELENGTH){
+        print selectRandom($genelist, $n % LINELENGTH), "\n";
+    }
+}
+
+sub makeRepeatFasta {
+    my ($id, $desc, $s, $n) = @_;
+
+    print ">", $id, " ", $desc, "\n";
+
+    my $r = length $s;
+    my $ss = $s . $s . substr($s, 0, $n % $r);
+    for my $j(0..int($n / LINELENGTH)-1) {
+	my $i = $j*LINELENGTH % $r;
+	print substr($ss, $i, LINELENGTH), "\n";
+    }
+    if ($n % LINELENGTH) {
+	print substr($ss, -($n % LINELENGTH)), "\n";
+    }
+}
+
+
+my $iub = [
+    [ 'a', 0.27 ],
+    [ 'c', 0.12 ],
+    [ 'g', 0.12 ],
+    [ 't', 0.27 ],
+    [ 'B', 0.02 ],
+    [ 'D', 0.02 ],
+    [ 'H', 0.02 ],
+    [ 'K', 0.02 ],
+    [ 'M', 0.02 ],
+    [ 'N', 0.02 ],
+    [ 'R', 0.02 ],
+    [ 'S', 0.02 ],
+    [ 'V', 0.02 ],
+    [ 'W', 0.02 ],
+    [ 'Y', 0.02 ]
+];
+
+my $homosapiens = [
+    [ 'a', 0.3029549426680 ],
+    [ 'c', 0.1979883004921 ],
+    [ 'g', 0.1975473066391 ],
+    [ 't', 0.3015094502008 ]
+];
+
+my $alu =
+    'GGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGG' .
+    'GAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGA' .
+    'CCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAAT' .
+    'ACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCA' .
+    'GCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGG' .
+    'AGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCC' .
+    'AGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAA';
+
+######################################################################
+#main
+
+my $n = ($ARGV[0] || 1000) ;
+
+makeCumulative($iub);
+makeCumulative($homosapiens);
+
+makeRepeatFasta ('ONE', 'Homo sapiens alu', $alu, $n*2);
+makeRandomFasta ('TWO', 'IUB ambiguity codes', $n*3, $iub);
+makeRandomFasta ('THREE', 'Homo sapiens frequency', $n*5, $homosapiens);
+