And here's the proof (sorry it's so wide).
| Rate | bgreenlee | japhy2 | japhy | ccn2 | ccn | jasper | deibyz | murugu | clive | buu | jdporter | aristotle | limbic_region | elgon | browseruk | aristotle2 | random_walk | tune | |
| bgreenlee | 1.59/s | -- | -44% | -44% | -49% | -49% | -50% | -90% | -90% | -91% | -97% | -98% | -99% | -100% | -100% | -100% | -100% | -100% | -100% |
| japhy2 | 2.82/s | 77% | -- | -1% | -10% | -10% | -11% | -82% | -82% | -84% | -94% | -97% | -98% | -99% | -99% | -99% | -99% | -100% | -100% |
| japhy | 2.85/s | 79% | 1% | -- | -9% | -9% | -10% | -82% | -82% | -84% | -94% | -97% | -98% | -99% | -99% | -99% | -99% | -100% | -100% |
| ccn2 | 3.14/s | 97% | 11% | 10% | -- | 0% | -1% | -80% | -80% | -82% | -94% | -96% | -98% | -99% | -99% | -99% | -99% | -100% | -100% |
| ccn | 3.14/s | 97% | 11% | 10% | 0% | -- | -1% | -80% | -80% | -82% | -94% | -96% | -98% | -99% | -99% | -99% | -99% | -100% | -100% |
| jasper | 3.16/s | 99% | 12% | 11% | 1% | 1% | -- | -80% | -80% | -82% | -94% | -96% | -98% | -99% | -99% | -99% | -99% | -100% | -100% |
| 15.6/s | 880% | 453% | 448% | 396% | 396% | 393% | -- | -1% | -10% | -68% | -82% | -91% | -96% | -97% | -97% | -97% | -100% | -100% | |
| 15.8/s | 891% | 459% | 454% | 402% | 402% | 398% | 1% | -- | -9% | -68% | -82% | -91% | -96% | -96% | -97% | -97% | -100% | -100% | |
| clive | 17.3/s | 984% | 512% | 506% | 449% | 449% | 446% | 11% | 9% | -- | -65% | -81% | -90% | -95% | -96% | -96% | -97% | -100% | -100% |
| buu | 49.1/s | 2981% | 1639% | 1623% | 1460% | 1460% | 1450% | 214% | 211% | 184% | -- | -45% | -72% | -87% | -89% | -90% | -91% | -100% | -100% |
| jdporter | 89.1/s | 5493% | 3057% | 3027% | 2732% | 2732% | 2714% | 471% | 465% | 416% | 82% | -- | -50% | -76% | -80% | -81% | -83% | -100% | -100% |
| aristotle | 178/s | 11060% | 6199% | 6139% | 5551% | 5551% | 5516% | 1039% | 1027% | 929% | 262% | 100% | -- | -51% | -60% | -63% | -67% | -99% | -100% |
| 364/s | 22756% | 12800% | 12679% | 11474% | 11474% | 11401% | 2232% | 2207% | 2008% | 642% | 309% | 105% | -- | -19% | -24% | -32% | -99% | -99% | |
| 448/s | 28063% | 15795% | 15646% | 14161% | 14161% | 14071% | 2774% | 2743% | 2498% | 814% | 404% | 152% | 23% | -- | -7% | -16% | -99% | -99% | |
| 481/s | 30111% | 16951% | 16791% | 15198% | 15198% | 15102% | 2983% | 2950% | 2687% | 881% | 440% | 171% | 32% | 7% | -- | -10% | -99% | -99% | |
| aristotle2 | 532/s | 33288% | 18744% | 18567% | 16807% | 16807% | 16701% | 3307% | 3271% | 2980% | 984% | 497% | 199% | 46% | 19% | 11% | -- | -98% | -99% |
| 35318/s | 2217869% | 1251726% | 1239954% | 1123012% | 1123012% | 1115948% | 226223% | 223816% | 204478% | 71886% | 39555% | 19774% | 9604% | 7775% | 7242% | 6543% | -- | -31% | |
| 51210/s | 3215868% | 1814999% | 1797929% | 1628368% | 1628368% | 1618126% | 328060% | 324569% | 296530% | 104276% | 57399% | 28717% | 13971% | 11319% | 10545% | 9532% | 45% | -- |
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;
Makeshifts last the longest.
In reply to Re^2: Finding longest palindrome from a string
by Aristotle
in thread Finding longest palindrome from a string
by BUU
| For: | Use: | ||
| & | & | ||
| < | < | ||
| > | > | ||
| [ | [ | ||
| ] | ] |