And here's the proof (sorry it's so wide).
Note that I had to disqualify some entries for failing the tests.
The full benchmark I ran follows. Note that some entries required slight modifications in order to compile with strictures and run without warnings. I paid careful attention to keep the semantics intact, but if I disqualified your entry, please check my copy of your code for potential breakage.
use strict;
use warnings;
use Benchmark qw( cmpthese );
use Test::More qw( no_plan );
use CGI qw/ :html /;
my %contestant = (
aristotle => sub {
my $str = shift;
my $rts = reverse $str;
my $palindrome = '';
for my $rotate_count ( 0 .. length( $str ) - 1 ) {
my $mask = $str ^ $rts;
# to distinguish adjacent palindromes
substr $mask, $rotate_count, 0, "\1";
while ( $mask =~ /\0{3,}/g ) {
my $len = $+[0] - $-[0];
next if $len <= length $palindrome;
my $offs = $-[0];
--$offs if $offs > $rotate_count; # compensate for
+marker
$palindrome = substr $str, $offs, $len;
}
substr $rts, 0, 0, chop $rts;
}
return $palindrome;
},
aristotle2 => sub {
my $str = shift;
my $rts = reverse $str;
my $palindrome = '';
my $minlen = 3;
for my $rotate_count ( 0 .. length( $str ) - 1 ) {
my $mask = $str ^ $rts;
# to distinguish adjacent palindromes
substr $mask, $rotate_count, 0, "\1";
while ( $mask =~ /\0{$minlen,}/g ) {
my $offs = $-[0];
--$offs if $offs > $rotate_count; # compensate for
+marker
$palindrome = substr $str, $offs, $+[0] - $-[0];
$minlen = 1 + length $palindrome;
}
substr $rts, 0, 0, chop $rts;
}
return $palindrome;
},
buu => sub {
my @p;
my $arg = shift;
my $p = '';
while ( $arg =~ /((.).?\2)/g ) {
my $m = $1;
while ( $arg =~ /((.)$m\2)/ ) {
$m = $1;
}
if ( length( $m ) > length( $p ) ) {
$p = $m;
}
}
return $p;
},
ccn => sub {
local $_ = shift;
my @n;
for ( my $i = 0 ; $i < length ; pos = $i++ ) {
$n[ length $& ] = $& if /\G(.+).?(??{reverse $1})/;
}
return @n ? $n[-1] : '';
},
ccn2 => sub {
local $_ = shift;
my $s = '';
for ( my $i = 0 ; $i < length ; pos = $i++ ) {
$s = $&
if /\G(.+).?(??{reverse $1})/
and length( $s ) < length( $& );
}
return $s;
},
tune => sub {
my $l = '';
map { $l = $_ if ( $_ eq reverse $_ ) && ( length $l < length
+$_ ) }
split /\s+/, $_[0];
return $l;
},
random_walk => sub {
my ( $left, $right, $pal, $i ) = ( "", "", "", 1 );
my $test = join " ", @ARGV;
for ( ; $i < ( ( length $test ) / 2 ) + 2 ; $i++ ) {
$left .= "(.)";
$right = "(\\$i)" . $right;
if ( $test =~ /$left.?$right/ ) { $pal = $&; next }
return $pal;
}
},
clive => sub {
my $rev = reverse $_[0];
my $len = 0;
my $d;
for ( 0 .. length( $_[0] ) - 1 ) {
my $c = join '',
map { substr( $rev, $_, 1 ) eq substr( $_[0], $_, 1 )
+? 1 : 0 }
0 .. length( $_[0] ) - 1;
my $match =
( sort { length( $a ) <=> length( $b ) } $c =~ /(1+)/g
+ )[-1];
$match > $len and $len = $match and $d = $c;
$rev = substr( $rev, 1 ) . substr( $rev, 0, 1 );
}
$d =~ s/(.*)($len).*/substr($_[0],length($1),length($len))/e;
return $d;
},
murugu => sub {
my $x = shift;
my $prev = 0;
my $max;
while ( $x =~ /(([a-z0-9]+)[a-z0-9]?(??{reverse $2}))/gi ) {
$max = $1 if ( length( $1 ) > $prev );
$prev = length $max;
}
$max;
},
jasper => sub {
$_ = pop;
s/\s//sg;
my @a;
do {
push @a, $1 if /((.*).?(??{reverse$2}))/i;
} while s/.//;
( sort { length( $b ) <=> length $a } @a )[0];
},
deibyz => sub {
my $match = '';
while ( /.*?(.+)(.?)((??{reverse$1})).*?/g ) {
$match = $1 . $2 . $3 if length( $1 . $2 . $3 ) > length(
+$match );
}
$match;
},
limbic_region => sub {
my %lookup;
my ( $index, $record ) = ( -1, 0 );
push @{ $lookup{ substr( $_[0], $_, 1 ) } }, $_
for 0 .. ( length $_[0] ) - 1;
LETTER: for my $letter ( keys %lookup ) {
my $last = $#{ $lookup{ $letter } };
for my $start ( 0 .. $last - 1 ) {
for my $end ( reverse( $start + 1 .. $last ) ) {
my $pos = $lookup{ $letter }[$start];
my $length = $lookup{ $letter }[$end] - $pos + 1;
next LETTER if $length <= $record;
my $palindrome = substr( $_[0], $pos, $length );
if ( $palindrome eq reverse $palindrome ) {
( $index, $record ) = ( $pos, $length );
last;
}
}
}
}
return substr( $_[0], $index, $record );
},
bgreenlee => sub {
my $str = shift;
my $longest = '';
while ( $str =~ /(?=(.*)(.?)((??{reverse $1})))/g ) {
$longest = "$1$2$3" if length( "$1$2$3" ) > length( $longe
+st );
}
return $longest;
},
browseruk => sub {
my $string = shift;
my @pals;
while ( $string =~ m[(.) (?=( (?:\1) | (?:.\1) ) ) ]gx ) {
my ( $left, $right ) = ( $-[0], $+[-1] );
while ( $left
and $right < length( $string )
and substr( $string, $left, 1 ) eq substr( $string, $r
+ight, 1 )
)
{
$left--;
$right++;
}
my $pal = substr( $string, $left, $right - $left );
if ( !@pals or length( $pals[-1] ) < length( $pal ) ) {
@pals = $pal;
}
else {
push @pals, $pal unless @pals;
}
}
return wantarray ? $pals[0] : @pals;
},
jdporter => sub {
local $_ = shift;
my $pal;
for my $i ( 0 .. length( $_ ) ) {
last if defined( $pal ) && length( $_ ) - $i < length( $pa
+l );
my $j = rindex $_, substr( $_, $i, 1 );
while ( $j > $i ) {
my $s = substr $_, $i, $j - $i + 1;
if ( $s eq reverse $s ) # it's a palindrome
{ # but is it the longest yet
+ found?
$pal = $s
unless defined $pal && length( $pal ) > length
+( $s );
}
$j--;
$j = rindex $_, substr( $_, $i, 1 ), $j;
}
}
$pal;
},
elgon => sub {
use POSIX qw(ceil);
my $string = shift;
my %char_hash = map { $_ => 1 } split //, $string;
foreach my $key ( keys %char_hash ) {
my @appearances;
for ( my $i = 0 ; $i < length( $string ) ; $i++ ) {
push( @appearances, $i ) if substr( $string, $i, 1 ) e
+q $key;
}
foreach my $start ( @appearances ) {
foreach my $finish ( reverse @appearances ) {
next if $start >= $finish;
my $half_length = ceil( ( $finish - $start + 1 ) /
+ 2 );
return
substr( $string, ( $start ), ( $finish - $star
+t + 1 ) )
if substr( $string, $start, $half_length ) eq
reverse substr( $string, ( $finish - $half_len
+gth + 1 ),
$half_length );
}
}
}
return "FAILED!";
},
japhy => sub {
our$P="";pop=~m{(.+).?(??{reverse$1})
(?{length$P<length$&and$P=$&})^}xs;$P
},
japhy2 => sub {
our@P="";pop=~m{(.+).?(??{reverse$
1})(?{$P[length$&]=$&})^}xs;$P[-1]
},
);
my @input = (
'27103271037013711111111111111111116111111111111111111111166026111
+11111'
. '1111111111111111111111111111111111111111111611111111111111111',
'abcdefghijklmnopqrstuvwxyz12345678987654321zyxwvutsrqponmlkjihgfe
+dcba',
'ababcbabcdcbabcdedcbabcdefedcbabcdefgfedcbababcbabcdcbabcdedcbabc
+defedcbabcdefgfedcba',
'abcdedcbabcdefgfedcbabcdefghijklmnonmlkjihgfedcbabcdefghijklkjihg
+fedcbabcdefghijklmnoponmlkjihgfedcba',
);
my @correct = (
'61111111111111111111111111111111111111111111111111116',
'abcdefghijklmnopqrstuvwxyz12345678987654321zyxwvutsrqponmlkjihgfe
+dcba',
'edcbabcdefedcbabcde',
'onmlkjihgfedcbabcdefghijklkjihgfedcbabcdefghijklmno',
);
for my $user ( sort keys %contestant ) {
my @result = map $contestant{ $user }->( $_ ), @{[ @input ]};
for( 0 .. $#input ) {
is $result[ $_ ], $correct[ $_ ], "$user test $_";
}
}
print "\nRunning benchmark\n";
my $result = cmpthese( 0, { map +( $_ => do {
my $user = $_;
sub { $contestant{ $user }->( $_ ) for @{[ @input ]} };
} ), keys %contestant }, "none" );
print map Tr( td( $_ ) )."\n", @$result;
