http://qs321.pair.com?node_id=383423


in reply to Finding longest palindrome from a string

BUU,
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: 
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;
}

[download]
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. 
#!/usr/bin/perl
use strict;
use warnings;

my @letters = 'a'..'z';
open (PALINDROMES, '>', 'palindromes.dat') or die "Unable to open pali
+ndromes.dat for writing : $!";

for ( 0 .. 10 ) {
    my $string;
    $string .= rand() <= .3 ? gen_palindrome() : $letters[ rand @lette
+rs ] for 0 .. (rand 25) + 2;
    print PALINDROMES $string, "\n";
}

sub gen_palindrome {
    my $string;
    $string .= $letters[ rand @letters ] for 1 .. (rand 18) + 2;
    return $string . reverse $string;
}
__END__
leostddtsoelirknmxrhwfuzoozufwhrjnwytnybfrrrrfbyntywnfxmqrepfcdojyovxe
+yaeeayexvoyjodcfperqmx
xrurqyovghhybqvbhvyyvhbvqbyhhgvoyqrrrppmycvoovcympprr
zrrpmmlygeyeqrttinhklxfccfxlkhnittrqeyegylryovaaavduooudvaaavoyttugqci
+hjrnmnmiywwyimnmnrjhicqgutdijvmpofmppmfopmvjimuccqieaeixkgzlpddplzgkx
+ieaeiqccumkagegqqgegakyuplcymxfrbpdzkzryxlxtmzvvzmtxlxyrzkzdpbrfxm
kreguugerfumcvzzvcmujtfjgwsjgfphkusqlgggglqsukhpfgjswsfmujzzjumfs
dhmopumbwennjaalwwlaajnnewbmupomwbyzrryoynrrokdiidkorrnyoyrrzllssllioy
+llrsnmffmnsrllvsttfeymdjjxbccbxjjdmxlwaiqjkyvsgzppzgsvykjqiawbgeingpa
+ywctdaadtcwyapgnie
mzvnytslsnqadhcsccschdaqnsxvuhrhcnrrnchrhuvxswetuutewdctvkolvipbelnbbn
+lebpivlokvt
cwxfymnrrnmyqiu
lamhzzcwlwoowlwczzzqeeavmfqvfsywwysfvqfmvaeequmycckptworpfyheawviuvaup
+nnpuavuivwaehyfprowt
frfbkjwtdgqqgdtwjkbfrfhiloxilguyqbssmbllbmssbqyucxjfjhjwkciuzjjzuickwj
+to
cvynpiipnyvcjybdltorcntkhpxpwcrvdjjdvrcwpxphktncrotlirekrmokbqkqaaqkqb
+komrkerigxknxhekcdmuecceumdckehxneqzxkqryadbfzxvwwvxzfbdayrqkxzqe
heucfmybrgwtikfussufkitwgrktxt
dsdadadcccasdasd
ababbab
1111111121111111111112111111111111111111111112111111111111211111
ababacababacadacababacadaeadacabaz
sacascascsacascascascadvgkgjsflfjgfk
abcdedcbabcdefgfedcbabcdefghijklmnonmlkjihgfedcbabcdefghijklkjihgfedcb
+abcdefghijklmnoponmlkjihgfedcba
bbabbbabbb
2710327103701371111111111111111111611111111111111111111116602611111111
+1111111111111111111111111111111111111111111611111111111111111
61111111111111111111111111111111111111111111111111116
abcdefghijklmnopqrstuvwxyz12345678987654321zyxwvutsrqponmlkjihgfedcba
ababcbabcdcbabcdedcbabcdefedcbabcdefgfedcbababcbabcdcbabcdedcbabcdefed
+cbabcdefgfedcba
edcbabcdefedcbabcde
abcdedcbabcdefgfedcbabcdefghijklmnonmlkjihgfedcbabcdefghijklkjihgfedcb
+abcdefghijklmnoponmlkjihgfedcba
onmlkjihgfedcbabcdefghijklkjihgfedcbabcdefghijklmno

[download]
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));
}

[download]
I made no attempt to fix the results, so I gigged any solution that didn't have a proper .results file

Cheers - L~R

Replies are listed 'Best First'.
Re^2: Finding longest palindrome from a string
by Limbic~Region (Chancellor) on Aug 17, 2004 at 14:22 UTC

    I took some advice and rebuilt the benchmark. I disqualified anyone who didn't get accurate results, so be sure you didn't get disqualified due to my error in your code. Here is the code that I used to generate the new palindromes:
    Read more... (998 Bytes)
    Here is the actually benchmark itself:
    Read more... (22 kB)
    And here are the results:
    Read more... (704 Bytes)

    Cheers - L~R

[reply]
[d/l]
[select]
Re^2: Finding longest palindrome from a string
by Aristotle (Chancellor) on Aug 17, 2004 at 08:17 UTC 
    return $string . reverse $string;

    [download]

    That only generates even length palindromes. I instead suggest

    return (
    $string
    . ( rand < .5 ? $letters[ rand @letters ] : '' )
    . reverse $string
);

    [download]

    Also, Don't Repeat Yourself. That's far too much copy-paste code there. Look at the benchmark script I wrote: much less code, and it tells you exactly which input strings each solution failed on and what it produced instead.

    Makeshifts last the longest.

[reply]
[d/l]
[select]
Re^2: Finding longest palindrome from a string
by BrowserUk (Patriarch) on Aug 17, 2004 at 11:16 UTC

    You might want to add some non-alphanumeric characters into the mix as allowed by the original challenge.

    Examine what is said, not who speaks.
    "Efficiency is intelligent laziness." -David Dunham
    "Think for yourself!" - Abigail
    "Memory, processor, disk in that order on the hardware side. Algorithm, algorithm, algorithm on the code side." - tachyon
[reply]
[d/l]

In Section Seekers of Perl Wisdom