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


in reply to Re: Finding longest palindrome from a string
in thread Finding longest palindrome from a string


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:
#!/usr/bin/perl use strict; use warnings; my @range = map { chr() } 32 .. 126; open (PALINDROMES, '>', 'palindromes.dat') or die "Unable to open pali +ndromes.dat for writing : $!"; for ( 1 .. 10 ) { my $string; $string .= rand() <= .3 ? gen_palindrome() : $range[ rand @range ] + for 0 .. (rand 25) + 5; print PALINDROMES $string, "\n"; } sub gen_palindrome { my $string; $string .= $range[ rand @range ] for 1 .. (rand 48) + 2; return $string . (rand() < .5 ? $range[ rand @range ] : '') . reve +rse $string; }
Here is the actually benchmark itself:
#!/usr/bin/perl use strict; use warnings; use Benchmark 'cmpthese'; use Test::More 'no_plan'; use CGI ':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, $counter) = (0,0,0); my $reverse = reverse $_[0]; my $end = length $_[0]; my $template = 'c' x $end; --$end; unshift @{ $lookup[ $_ ] }, $counter++ for unpack( $template, +$_[0] ); for ( unpack( $template, $_[0] ) ) { my $start = pop @{ $lookup[ $_ ] }; for ( @{ $lookup[ $_ ] } ) { my $length = $_ - $start + 1; last if $length <= $record; if ( substr($_[0], $start, $length) eq substr($reverse +, $end - $_, $length) ) { ($index, $record) = ($start, $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!"; }, fizbin => sub { no warnings; no strict; 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]); }, 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; while ( <DATA> ) { tr/\r\n//d; last if /## CORRECT ##/; push @input, $_; } my @correct; while ( <DATA> ) { tr/\r\n//d; push @correct, $_; } for my $user ( sort keys %contestant ) { print "Validating $user\n"; if ( $user eq 'buu' ) { print "Skipping buu : infinite loop?\n"; delete $contestant{$user}; next; } my @result = map { my $result; eval { $result = $contestant{ $user }->( $_ ) }; $@ ? 'FAILED' : $result; } @{[ @input ]}; for( 0 .. $#input ) { if ( $_ == 25 && $user eq 'jdporter' ) { is 1, 1, "$user test $_"; next; } is $result[ $_ ], $correct[ $_ ], "$user test $_"; if ( $result[ $_ ] ne $correct[ $_ ] ) { print STDERR "Disqualifying $user\n"; delete $contestant{$user}; last; } } } 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; __DATA__ HuR4H(w~kz;5&|qQu:{LmmL{:uQq|&5;zk~w(H4RuHF"lG$R]9XlW;.*ylw#34yy0FO<uF +OnTTnOFu<OF0yy43#wly*.;WlX9]R$Gl"FcSy!t4prSOo>YO0)\_-<\BM!1T%uZu_B+fK +JsZ"aMzr((rzMa"ZsJKf+B_uZu%T1!MB\<-_\)0OY>oOSrp4t!/?0/ $YKE&Rn?s#P}AdPPdA}P#s?nR&EKYPpMHv|/Rx/0Bey?Z'URS>Z=gwcgcwg=Z>SRU'Z?ye +B0/xR/|vHMp!A$9?sc}K2Oxz48YtbTZ%(Hx3y"|pwf@$J3W1>>1W3J$@fwp|"y3xH(%ZT +btY84zxO2K}cs?9$G9Q 6~I0o] U&p}itN9:RB6'1cw+00Omf>4:zgtzM+vsv+Mztgz:4 +>fmO00+wc1'6BR:9Nti}p&U ]o0I~6 QL+Ja"iri"aJ+Lq!D|UtFSq~/Lq-+EGurruGE+ +-qL/~qSFtU|D!q{I\cu1 .W1g"IW$nAb/,ruur,/bAn$WI"g1]C~f:|BHL?[C@cc[)vjff{1*Gv7:OWGN$-:>71"6yb +FE$^V^$EFby6"17>:-$NGWO:7vG*1{ffjv)[cc@C[?LHBu^4%mJcTcJm%4^]]AL78?*!? +SHHS?!*?87LA]]a S]leGx]taat]xGeej5}6M.11.M6}5jeJI4O5QcL~(8i+t6fL9.%z\ ++g22g+\z%.9Lf6t+i8(~LcQ5O4IJ$U+O#mGaAxbqw`9f}}f9`wqbxAaGm#O+F&9>aVTyy +?X>t>X?yyTVa>9&F+OB /W8~u}A:\u$hR|}tAs|j2z!RvR!z2j|sAt}|Rh$u\:A}u~CHH+P+dkl~wZz'3r{r\C9kBX +f?r]I/8/VI,AQrD0{<||<{0DrQA,IV/8/I]r?fXBk9C\r{r3'zZw~lkd+P+HHCu{8UQdf +\YP~V9On27>72nO9V~PY\fdQUb%) #oeW3:.&_M((M_&.:3Weo# -atJE ")WyByW)" E +JtK}mKzLQ7#5qIE9_Z!m"^]KrJAI>e&-/O=%'%=O/-&e>IAJrK]^"m!Z_9EIq5#7QLzKm +}.Bw k2\%C6/-0SA_JDw~_R*3=Q+-Gji^\>U3/N/3U>\^ijG-+Q=3*R_~wDJ_AS0-/6C%\2k4kr + m/;-{0#i&lp[j(6=[=6(j[pl&i#0{i_7m[$/Ma'Z0JD8:(:U[24Wr["EB{2?Ox6n|#7$ +99$7#|n6xO?2{BE"[rW42[U:(:8DJ0Z'aM/$[m7_i 1t5MqqM5tK$zSuf7fuSzW!X7Oy""yO7X!W}{3?*TIIdAd5&(1CLTtf?!!?ftTLC1(&5dAd +IIT*?3{[e&$i|YEZ~5QX-Tk?RzW(#C%> >%C#(WzR?kT-XQ5~ZEY|i$&e[wDAF her$f +=\;;\=f$reh FADw&cL<65q9'-Q=3Ht]2BOBOB2]tH3=Q-'9q56<Lc/D2!y9fA+\)(y]) +sMv5?n3kU,qq,Uk3n?5vMs)]y()\+Af9y!2Du QhKm(llYai)>gaO)zf+Ew|!0"}G~<`\PcP+(fA+P+Af(+PcP\`<~G}"0!|wE+fz)Of<VO] +]e899Ud.k<%/'5_#w(Z7bJ?W:::x\X;]hSZ\!X/BFQ"8w8"QFB/X!\ZSh];X\x:::W?Jb +7Z(w#_5'/%<k.dU998e]]OV<8x+m6!Iw%'|:MYjX8_]M+gt#v%9xdx|v/W`Z&;]Eh_mnC +nm_hE];&Z`W/v|xdx9%v#tg+M]_8XjYM:|'%wI!6m+x8XB 5&o1J,*6sd!C,C!ds6*,J1o&5EM%;U58CJd|otnl3!!3lnto|dJC85U;%Mn'O !7HJ8)<*o5m{""{m5o*<)8Jru_Z+'yz<Z5|!9s7rEXCDVi)4xmq~6,\sm.8s`JH5B7G_6? +c^JqjqJ^c?6_G7B5HJ`s8.ms\,6~qmx4)iVDCXEr7s9!|5Z<zy'+Z_CC :!LX;i]i~v>W + i5pn'<I`c{-2#5^,{5=/ u}sD^iSQQSi^Ds}u /=5{,^5#2-{c`I<'np5i W>v~i]i;X +L!:p`XRC 7M?6_FIbg3c2Z}=}Z2c3gbIF_6?M7 C)hC9JS.WRIO!G1G&-SteytXZ^8B'B +8^ZXtyetS-&G1G!OIRW.SJ9ChP`,xc*i*cx,`P)V *70l{5Zz#(jf%V>?,5Ij+IZ\gE&?V.*S6w?w6S*.V?&Eg\ZI+jI5,?>V%fj(#zZ5{l0v2a +1UDre;Rw6c`4t3V_D?&S(zP+Coz` Ip.H82y-H^'0QMnnMQ0'^H-y28H.pI `zoC+Pz(S +&?D_V3t4`c6wR;erDU1akzJ'<_?(HFCKHmK@~X2FK#Ix*p#\M*0\K\0*M\#p*xI#KF2X~ +@KmHKCFH]bd,9>`<duN[YM#GO}D~8bo1O1DCZGn)\.ilikOQ`f8@@8f`QOkili.\)nGZC +D1O1ob8~D}OG#MY[Nud<`>9,db`c!qjSvr?whfM[l~gQ\H(u(H\Qg~l[Mfhw?rvSjq!c` +fn8t;~)y7tIz9KUQ='%#DbxG'&r0-FGtgf#,n#axd0M(0t5=A"K"A=5t0(M0dxa#n,#fg +tGF-0r&'GxbD#%'=QUK9zIt7y)~;t7Dd_w^?Mm0PxP0mM?^w_dm# 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 2710327103701371111111111111111111611111111111111111111116602611111111 ## CORRECT ## !t4prSOo>YO0)\_-<\BM!1T%uZu_B+fKJsZ"aMzr((rzMa"ZsJKf+B_uZu%T1!MB\<-_\) +0OY>oOSrp4t! Q 6~I0o] U&p}itN9:RB6'1cw+00Omf>4:zgtzM+vsv+Mztgz:4>fmO00+wc1'6BR:9Nti +}p&U ]o0I~6 Q BHL?[C@cc[)vjff{1*Gv7:OWGN$-:>71"6ybFE$^V^$EFby6"17>:-$NGWO:7vG*1{ffjv +)[cc@C[?LHB CHH+P+dkl~wZz'3r{r\C9kBXf?r]I/8/VI,AQrD0{<||<{0DrQA,IV/8/I]r?fXBk9C\r{ +r3'zZw~lkd+P+HHC i_7m[$/Ma'Z0JD8:(:U[24Wr["EB{2?Ox6n|#7$99$7#|n6xO?2{BE"[rW42[U:(:8DJ0Z +'aM/$[m7_i [e&$i|YEZ~5QX-Tk?RzW(#C%> >%C#(WzR?kT-XQ5~ZEY|i$&e[ <VO]]e899Ud.k<%/'5_#w(Z7bJ?W:::x\X;]hSZ\!X/BFQ"8w8"QFB/X!\ZSh];X\x:::W +?Jb7Z(w#_5'/%<k.dU998e]]OV< M%;U58CJd|otnl3!!3lnto|dJC85U;%M _Z+'yz<Z5|!9s7rEXCDVi)4xmq~6,\sm.8s`JH5B7G_6?c^JqjqJ^c?6_G7B5HJ`s8.ms\ +,6~qmx4)iVDCXEr7s9!|5Z<zy'+Z_ t;~)y7tIz9KUQ='%#DbxG'&r0-FGtgf#,n#axd0M(0t5=A"K"A=5t0(M0dxa#n,#fgtGF- +0r&'GxbD#%'=QUK9zIt7y)~;t xmqrepfcdojyovxeyaeeayexvoyjodcfperqmx rqyovghhybqvbhvyyvhbvqbyhhgvoyqr mxfrbpdzkzryxlxtmzvvzmtxlxyrzkzdpbrfxm wsjgfphkusqlgggglqsukhpfgjsw mopumbwennjaalwwlaajnnewbmupom tvkolvipbelnbbnlebpivlokvt ymnrrnmy tworpfyheawviuvaupnnpuavuivwaehyfprowt frfbkjwtdgqqgdtwjkbfrf ltorcntkhpxpwcrvdjjdvrcwpxphktncrotl rgwtikfussufkitwgr dadad babbab 1111121111111111112111111111111111111111112111111111111211111 acababacadacababaca cascsac onmlkjihgfedcbabcdefghijklkjihgfedcbabcdefghijklmno bbabbbabb 61111111111111111111111111111111111111111111111111116 61111111111111111111111111111111111111111111111111116 abcdefghijklmnopqrstuvwxyz12345678987654321zyxwvutsrqponmlkjihgfedcba edcbabcdefedcbabcde edcbabcdefedcbabcde onmlkjihgfedcbabcdefghijklkjihgfedcbabcdefghijklmno onmlkjihgfedcbabcdefghijklkjihgfedcbabcdefghijklmno 111111111111111111161111111111111111111
And here are the results:
Rate jdporter limbic_region aristotle fizbin aristotle2
jdporter 23.4/s -- -20% -28% -41% -43%
limbic_region 29.4/s 26% -- -9% -26% -29%
aristotle 32.3/s 38% 10% -- -18% -22%
fizbin 39.5/s 69% 34% 22% -- -5%
aristotle2 41.4/s 77% 41% 28% 5% --

Cheers - L~R