Beefy Boxes and Bandwidth Generously Provided by pair Networks
Clear questions and runnable code
get the best and fastest answer
 
PerlMonks  

Re: Finding longest palindrome from a string

by Limbic~Region (Chancellor)
on Aug 16, 2004 at 19:38 UTC ( #383423=note: print w/ replies, xml ) Need Help??


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; }
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
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

Cheers - L~R


Comment on Re: Finding longest palindrome from a string
Select or Download Code
Re^2: Finding longest palindrome from a string
by Aristotle (Chancellor) on Aug 17, 2004 at 08:17 UTC
    return $string . reverse $string;

    That only generates even length palindromes. I instead suggest

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

    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.

Re^2: Finding longest palindrome from a string
by BrowserUk (Pope) 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
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: Here is the actually benchmark itself: And here are the results:

    Cheers - L~R

Log In?
Username:
Password:

What's my password?
Create A New User
Node Status?
node history
Node Type: note [id://383423]
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others rifling through the Monastery: (4)
As of 2014-08-30 11:36 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    The best computer themed movie is:











    Results (293 votes), past polls