I was frustrated that my original idea, which was elegant and fast, had a major logic flaw and fixing it made ugly inefficient code. I came up with the following instead:
Of course I wanted to see how it stacked up against all the other solutions, so I created a program to generate strings that contained palindromes as well as added in the examples used elsewhere in the thread.
I then created a benchmark script that would not only yield performance results, but accuracy as well. You have to look at the *.results files as I got lazy.
#!/usr/bin/perl
use POSIX qw(ceil);
use Benchmark 'cmpthese';
my %methods = (
LR => \&LR_Palindrome,
BUU => \&BUU_Palindrome,
CCN1 => \&CCN1_Palindrome,
CCN2 => \&CCN2_Palindrome,
RW => \&RW_Palindrome,
CLIVE => \&cLive_Palindrome,
MURUGU => \&murugu_Palindrome,
JASPER => \&jasper_Palindrome,
DEIBYZ => \&deibyz_Palindrome,
BGREENLEE => \&bgreenlee_Palindrome,
BUK => \&buk_Palindrome,
FIZBIN => \&fizbin_Palindrome,
ARISTOTLE1 => \&aristotle1_Palindrome,
ARISTOTLE2 => \&aristotle2_Palindrome,
JDP => \&JDP_Palindrome,
ELGON => \&elgon_Palindrome,
JAPHY1 => \&japhy1_Palindrome,
JAPHY2 => \&japhy2_Palindrome,
WGD => \&WGD_Palindrome,
);
for my $method ( keys %methods ) {
open (DATA, '<', 'palindromes.dat') or die "Unable to open data fi
+le for reading : $!";
open (OUT, '>', "$method.results") or die "Unable to open $method.
+results for writing : $!";
while ( <DATA> ) {
chomp;
print OUT $methods{$method}->( $_ ), "\n";
}
}
cmpthese -10, {
'L~R' => sub {
open (DATA, '<', 'palindromes.dat') or die "Unable to open dat
+a file for reading : $!";
while ( <DATA> ) {
chomp;
LR_Palindrome( $_ );
}
},
'BUU' => sub {
open (DATA, '<', 'palindromes.dat') or die "Unable to open dat
+a file for reading : $!";
while ( <DATA> ) {
chomp;
BUU_Palindrome( $_ );
}
},
'CCN1' => sub {
open (DATA, '<', 'palindromes.dat') or die "Unable to open dat
+a file for reading : $!";
while ( <DATA> ) {
chomp;
CCN1_Palindrome( $_ );
}
},
'CCN2' => sub {
open (DATA, '<', 'palindromes.dat') or die "Unable to open dat
+a file for reading : $!";
while ( <DATA> ) {
chomp;
CCN2_Palindrome( $_ );
}
},
'RW' => sub {
open (DATA, '<', 'palindromes.dat') or die "Unable to open dat
+a file for reading : $!";
while ( <DATA> ) {
chomp;
RW_Palindrome( $_ );
}
},
'cLive' => sub {
open (DATA, '<', 'palindromes.dat') or die "Unable to open dat
+a file for reading : $!";
while ( <DATA> ) {
chomp;
cLive_Palindrome( $_ );
}
},
'murugu' => sub {
open (DATA, '<', 'palindromes.dat') or die "Unable to open dat
+a file for reading : $!";
while ( <DATA> ) {
chomp;
murugu_Palindrome( $_ );
}
},
'jasper' => sub {
open (DATA, '<', 'palindromes.dat') or die "Unable to open dat
+a file for reading : $!";
while ( <DATA> ) {
chomp;
jasper_Palindrome( $_ );
}
},
'deibyz' => sub {
open (DATA, '<', 'palindromes.dat') or die "Unable to open dat
+a file for reading : $!";
while ( <DATA> ) {
chomp;
deibyz_Palindrome( $_ );
}
},
'bgreenlee' => sub {
open (DATA, '<', 'palindromes.dat') or die "Unable to open dat
+a file for reading : $!";
while ( <DATA> ) {
chomp;
bgreenlee_Palindrome( $_ );
}
},
'buk' => sub {
open (DATA, '<', 'palindromes.dat') or die "Unable to open dat
+a file for reading : $!";
while ( <DATA> ) {
chomp;
buk_Palindrome( $_ );
}
},
'fizbin' => sub {
open (DATA, '<', 'palindromes.dat') or die "Unable to open dat
+a file for reading : $!";
while ( <DATA> ) {
chomp;
fizbin_Palindrome( $_ );
}
},
'aristotle1' => sub {
open (DATA, '<', 'palindromes.dat') or die "Unable to open dat
+a file for reading : $!";
while ( <DATA> ) {
chomp;
aristotle1_Palindrome( $_ );
}
},
'aristotle2' => sub {
open (DATA, '<', 'palindromes.dat') or die "Unable to open dat
+a file for reading : $!";
while ( <DATA> ) {
chomp;
aristotle2_Palindrome( $_ );
}
},
'JDP' => sub {
open (DATA, '<', 'palindromes.dat') or die "Unable to open dat
+a file for reading : $!";
while ( <DATA> ) {
chomp;
JDP_Palindrome( $_ );
}
},
'elgon' => sub {
open (DATA, '<', 'palindromes.dat') or die "Unable to open dat
+a file for reading : $!";
while ( <DATA> ) {
chomp;
elgon_Palindrome( $_ );
}
},
'japhy1' => sub {
open (DATA, '<', 'palindromes.dat') or die "Unable to open dat
+a file for reading : $!";
while ( <DATA> ) {
chomp;
japhy1_Palindrome( $_ );
}
},
'japhy2' => sub {
open (DATA, '<', 'palindromes.dat') or die "Unable to open dat
+a file for reading : $!";
while ( <DATA> ) {
chomp;
japhy2_Palindrome( $_ );
}
},
'WGD' => sub {
open (DATA, '<', 'palindromes.dat') or die "Unable to open dat
+a file for reading : $!";
while ( <DATA> ) {
chomp;
WGD_Palindrome( $_ );
}
},
};
sub LR_Palindrome {
my $forward = shift;
my $reverse = reverse $forward;
return $forward if $forward eq $reverse;
my ($max, $pos, $length, $palindrome, $test) = (0);
for $pos ( 0 .. (length $forward) - 1 ) {
for $length ( $max + 1 .. (length $forward) - $pos ) {
$test = substr( $forward, $pos, $length );
if ( index($reverse, $test) != -1 ) {
$max = length $test;
$palindrome = $test;
}
}
}
return $palindrome;
}
sub BUU_Palindrome {
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;
}
sub CCN1_Palindrome {
local $_ = shift;
my @n;
for (my $i = 0; $i < length; pos = $i++) {
$n[length $&] = $& if /\G(.+).?(??{reverse $1})/;
}
return @n ? $n[-1] : '';
}
sub CCN2_Palindrome {
local ($_, $s) = shift;
for (my $i = 0; $i < length; pos = $i++) {
$s = $& if /\G(.+).?(??{reverse $1})/ and length($s) < length
+($&);
}
return $s;
}
sub RW_Palindrome {
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;
}
}
sub cLive_Palindrome {
my $rev = reverse $_[0];
my $len='';
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;
}
sub murugu_Palindrome {
my $x=shift;
my $prev=0;
while ($x=~/(([a-z0-9]+)[a-z0-9]?(??{reverse $2}))/gi) {
$max=$1 if (length($1)>$prev);
$prev=length $max;
}
$max;
}
sub jasper_Palindrome {
$_ = pop;
s/\s//sg;
do {
push@a,$1 if /((.*).?(??{reverse$2}))/i;
} while s/.//;
(sort{length($b)<=>length$a}@a)[0]
}
sub deibyz_Palindrome {
my $match;
while(/.*?(.+)(.?)((??{reverse$1})).*?/g){
$match = $1.$2.$3 if length($1.$2.$3)>length($match);
}
$match;
}
sub bgreenlee_Palindrome {
my $str = shift;
my $longest = '';
while ($str =~ /(?=(.*)(.?)((??{reverse $1})))/g) {
$longest = "$1$2$3" if length("$1$2$3") > length($longest);
}
return $longest;
}
sub buk_Palindrome {
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, $right, 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;
}
sub fizbin_Palindrome {
return $_[0] unless ($_[0] and length($_[0]) > 1);
my @string = (300, unpack("U*", $_[0]), 301);
my $palstart, $palend;
my ($bestlen, $beststart, $bestend) = (-1,-1,-1);
for ($palmid = 1; $palmid < $#string; $palmid++)
{
if ($string[$palmid] == $string[$palmid+1])
{ # try even-length palindrome
($palstart, $palend) = ($palmid, $palmid+1);
while ($string[$palend+1] == $string[$palstart-1])
{
$palend++; $palstart--;
}
if ($bestlen < $palend - $palstart)
{
($bestlen, $bestend, $beststart) =
($palend - $palstart, $palend, $palstart);
}
}
# try odd-length palindrome
($palstart, $palend) = ($palmid, $palmid);
while ($string[$palend+1] == $string[$palstart-1])
{
$palend++; $palstart--;
}
if ($bestlen < $palend - $palstart)
{
($bestlen, $bestend, $beststart) =
($palend - $palstart, $palend, $palstart);
}
}
pack("U*", @string[$beststart..$bestend]);
}
sub aristotle1_Palindrome {
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;
}
sub JDP_Palindrome {
my $pal;
for my $i ( 0 .. length($_) )
{
last if defined($pal) && length($_)-$i < length($pal);
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
}
sub elgon_Palindrome {
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) eq
+$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 - $sta
+rt + 1) ) if substr($string, $start, $half_length) eq reverse substr
+($string, ($finish - $half_length + 1), $half_length);
}
}
}
return "FAILED!";
}
sub japhy1_Palindrome { # 74
our$P="";pop=~m{(.+).?(??{reverse$1})
(?{length$P<length$&and$P=$&})^}xs;$P
}
sub japhy2_Palindrome { # 68
our@P="";pop=~m{(.+).?(??{reverse$
1})(?{$P[length$&]=$&})^}xs;$P[-1]
}
sub aristotle2_Palindrome {
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 mark
+er
$palindrome = substr $str, $offs, $+[0] - $-[0];
$minlen = 1 + length $palindrome;
}
substr $rts, 0, 0, chop $rts;
}
return $palindrome;
}
sub WGD_Palindrome {
my $longest_palindrome = '';
# look for two occurrences of the same character back to back or w
+ith another
# character in-between them to find palindromes:
while ($input =~ /((.).?\2)/g)
{
my $match_position = pos($input);
# get the positions of the two matching characters:
my $left_pos = $match_position - length $1;
my $right_pos = $match_position - 1;
# now go looking to the left and right of each matching charac
+ter
# for more matching characters:
while (nextCharactersMatch($input, $left_pos, $right_pos))
{
$left_pos--;
$right_pos++;
}
# extract the palindrome:
my $offset = ($right_pos - $left_pos) + 1;
my $palindrome = substr($input, $left_pos, $offset);
$longest_palindrome = $palindrome
if (length $palindrome > length $longest_palindrome);
# backtrack, to find palindromes within this palindrome:
pos($input) -= (length($1) - 1);
}
}
sub nextCharactersMatch {
my ($input, $left_pos, $right_pos) = @_;
return 1 if (substr($input, $left_pos - 1, 1)
eq substr($input, $right_pos + 1, 1));
}
I made no attempt to fix the results, so I gigged any solution that didn't have a proper .results file