TASK2: https://theweeklychallenge.org/blog/perl-weekly-challenge-350/#TASK2
Looks like the consensus on how to approach this would be to "split, sort, join" to generate keys for finding pair pals. Further, as smarter guys explained, using modulo arithmetic voodoo, a lot of unfriendly numbers (which can't have any pals anyway) should simply be skipped; and, of those that remain, it's pointless to ask some of the witnesses about, i.e skip these witnesses, too. So, my subroutine to solve the problem is:
sub pwc { my ( $from, $to, $target ) = @_; use integer; my @witnesses = ([ 4, 7 ], [ 2 .. 9 ]); my ( %pairs, $j ); for ( my $i = ( $from + 2 ) / 3 * 3; $i <= $to; $i += 3 ) { my $i_key = join '', sort split '', $i; my $k = $i % 9 ? 0 : 1; for ( @{ $witnesses[ $k ]}) { last if length( $j = $i * $_ ) != length( $i ); $pairs{ $i }{ $j } = $_ unless $i_key ne join '', sort split '', $j } for ( @{ $witnesses[ $k ]}) { last if length( $j = $i / $_ ) != length( $i ); $pairs{ $i }{ $j } = -$_ unless $i % $_ || exists $pairs{ $j } && exists $pairs{ $j }{ $i } || $i_key ne join '', sort split '', $j } } return scalar grep { %$_ >= $target } values %pairs }
However, even though some solutions mention "speed", I haven't seen optimizations which follow. First, if using CPAN modules is OK (and why not), almost exactly twice as fast is to sort in-place instead:
use Sort::Packed 'sort_packed'; sub pwc_p { my ( $from, $to, $target ) = @_; use integer; my @witnesses = ([ 4, 7 ], [ 2 .. 9 ]); my ( %pairs, $j ); for ( my $i = ( $from + 2 ) / 3 * 3; $i <= $to; $i += 3 ) { sort_packed C => my $i_key = $i; my $k = $i % 9 ? 0 : 1; for ( @{ $witnesses[ $k ]}) { last if length( $j = $i * $_ ) != length( $i ); sort_packed C => my $j_key = $j; $pairs{ $i }{ $j } = $_ unless $i_key ne $j_key } for ( @{ $witnesses[ $k ]}) { last if length( $j = $i / $_ ) != length( $i ); next if $i % $_; sort_packed C => my $j_key = $j; $pairs{ $i }{ $j } = -$_ unless exists $pairs{ $j } && exists $pairs{ $j }{ $i } || $i_key ne $j_key } } return scalar grep { %$_ >= $target } values %pairs }
Secondly, in theory (as far as I can pretend to know it), sorting is O(NlogN), but histogramming should, I guess, be O(N); but, seriously, more important in practice, the latter can be aborted as soon as mismatch is detected:
sub ugly { my ( $from, $to, $target ) = @_; use integer; my @witnesses = ([ 4, 7 ], [ 2 .. 9 ]); my ( %pairs, $j ); for ( my $i = ( $from + 2 ) / 3 * 3; $i <= $to; $i += 3 ) { my $k = $i % 9 ? 0 : 1; for ( @{ $witnesses[ $k ]}) { last if length( $j = $i * $_ ) != length( $i ); $pairs{ $i }{ $j } = $_ unless $i =~ tr/12// != $j =~ tr/12// || $i =~ tr/34// != $j =~ tr/34// || $i =~ tr/56// != $j =~ tr/56// || $i =~ tr/78// != $j =~ tr/78// || $i =~ tr/9// != $j =~ tr/9// || $i =~ tr/2// != $j =~ tr/2// || $i =~ tr/4// != $j =~ tr/4// || $i =~ tr/6// != $j =~ tr/6// || $i =~ tr/8// != $j =~ tr/8// } for ( @{ $witnesses[ $k ]}) { last if length( $j = $i / $_ ) != length( $i ); $pairs{ $i }{ $j } = -$_ unless $i % $_ || exists $pairs{ $j } && exists $pairs{ $j }{ $i } || $i =~ tr/12// != $j =~ tr/12// || $i =~ tr/34// != $j =~ tr/34// || $i =~ tr/56// != $j =~ tr/56// || $i =~ tr/78// != $j =~ tr/78// || $i =~ tr/9// != $j =~ tr/9// || $i =~ tr/2// != $j =~ tr/2// || $i =~ tr/4// != $j =~ tr/4// || $i =~ tr/6// != $j =~ tr/6// || $i =~ tr/8// != $j =~ tr/8// } } return scalar grep { %$_ >= $target } values %pairs }
Let's see:
say "$^V / $Config{ archname } / $Config{ gccversion }"; cmpthese -3, { pwc => sub { pwc( 1500, 2500, 1 )}, pwc_p => sub { pwc_p( 1500, 2500, 1 )}, ugly => sub { ugly( 1500, 2500, 1 )}, }; # v5.32.1 / MSWin32-x64-multi-thread / 8.3.0 # Rate pwc pwc_p ugly # pwc 737/s -- -48% -77% # pwc_p 1424/s 93% -- -56% # ugly 3251/s 341% 128% --
Well, considering that many PWC solutions don't skip neither numbers nor witnesses (i.e. check them all), and, e.g., some of them sort (for, remember, split-sort-join procedure) numerically (which is noticeably slower), etc. -- i.e. most are already, ehm, not as fast as the "pwc" subroutine above -- then the speed of "ugly" has "order-of-magnitude-class" advantage which is quite astonishing, I think.
-------
Maybe it's curious, but hex numbers can have pals too, of course. E.g., going from 0x1DEA to 0xC0DE encounters 89 shuffle-prone numbers, among them 2 more gregarious hexadecimals with exactly 2 pals each:
"2490" => { 4920 => 2, 9240 => 4 }, "3b10" => { "13b0" => -3, "b130" => 3 },
(extracted from output of Data::Dump::dd( \%pairs );.) Modulo voodoo logic, i.e. significant speed-up, by which to skip numbers and whether to call in witnesses for those which remain, is the same:
sub pwc_px { my ( $from, $to, $target ) = @_; use integer; # 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 my @adjust = qw/ 0 2 1 0 1 0 0 2 1 0 0 1 0 2 1 /; $from += $adjust[ $from % 15 ]; my @witnesses = ([ 6, 11 ], [ 4, 7, 10, 13 ], [ 2 .. 15 ]); my ( %pairs, $jx ); for my $i ( $from .. $to ) { next if $i % 3 and $i % 5; my $k = $i % 15 ? $i % 5 ? 0 : 1 : 2; my $ix = sprintf '%x', $i; sort_packed C => my $i_key = $ix; for ( @{ $witnesses[ $k ]}) { $jx = sprintf '%x', $i * $_; last if length( $jx ) != length( $ix ); sort_packed C => my $j_key = $jx; $pairs{ $ix }{ $jx } = $_ unless $i_key ne $j_key } for ( @{ $witnesses[ $k ]}) { $jx = sprintf '%x', $i / $_; last if length( $jx ) != length( $ix ); next if $i % $_; sort_packed C => my $j_key = $jx; $pairs{ $ix }{ $jx } = -$_ unless exists $pairs{ $jx } && exists $pairs{ $jx }{ $ix } || $i_key ne $j_key } } return scalar grep { %$_ >= $target } values %pairs } sub ugly_x { my ( $from, $to, $target ) = @_; use integer; # 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 my @adjust = qw/ 0 2 1 0 1 0 0 2 1 0 0 1 0 2 1 /; $from += $adjust[ $from % 15 ]; my @witnesses = ([ 6, 11 ], [ 4, 7, 10, 13 ], [ 2 .. 15 ]); my ( %pairs, $jx ); for my $i ( $from .. $to ) { next if $i % 3 and $i % 5; my $k = $i % 15 ? $i % 5 ? 0 : 1 : 2; my $ix = sprintf '%x', $i; for ( @{ $witnesses[ $k ]}) { $jx = sprintf '%x', $i * $_; last if length( $jx ) != length( $ix ); $pairs{ $ix }{ $jx } = $_ unless $ix =~ tr/1// != $jx =~ tr/1// || $ix =~ tr/2// != $jx =~ tr/2// || $ix =~ tr/3// != $jx =~ tr/3// || $ix =~ tr/4// != $jx =~ tr/4// || $ix =~ tr/5// != $jx =~ tr/5// || $ix =~ tr/6// != $jx =~ tr/6// || $ix =~ tr/7// != $jx =~ tr/7// || $ix =~ tr/8// != $jx =~ tr/8// || $ix =~ tr/9// != $jx =~ tr/9// || $ix =~ tr/a// != $jx =~ tr/a// || $ix =~ tr/b// != $jx =~ tr/b// || $ix =~ tr/c// != $jx =~ tr/c// || $ix =~ tr/d// != $jx =~ tr/d// || $ix =~ tr/e// != $jx =~ tr/e// || $ix =~ tr/f// != $jx =~ tr/f// } for ( @{ $witnesses[ $k ]}) { $jx = sprintf '%x', $i / $_; last if length( $jx ) != length( $ix ); $pairs{ $ix }{ $jx } = -$_ unless $i % $_ || exists $pairs{ $jx } && exists $pairs{ $jx }{ $ix } || $ix =~ tr/1// != $jx =~ tr/1// || $ix =~ tr/2// != $jx =~ tr/2// || $ix =~ tr/3// != $jx =~ tr/3// || $ix =~ tr/4// != $jx =~ tr/4// || $ix =~ tr/5// != $jx =~ tr/5// || $ix =~ tr/6// != $jx =~ tr/6// || $ix =~ tr/7// != $jx =~ tr/7// || $ix =~ tr/8// != $jx =~ tr/8// || $ix =~ tr/9// != $jx =~ tr/9// || $ix =~ tr/a// != $jx =~ tr/a// || $ix =~ tr/b// != $jx =~ tr/b// || $ix =~ tr/c// != $jx =~ tr/c// || $ix =~ tr/d// != $jx =~ tr/d// || $ix =~ tr/e// != $jx =~ tr/e// || $ix =~ tr/f// != $jx =~ tr/f// } } return scalar grep { %$_ >= $target } values %pairs } cmpthese -3, { pwc_px => sub { pwc_px( 0x1DEA, 0xC0DE, 2 )}, ugly_x => sub { ugly_x( 0x1DEA, 0xC0DE, 2 )}, }; # Rate pwc_px ugly_x # pwc_px 23.1/s -- -38% # ugly_x 37.2/s 61% --
Heh, ugly solution with lots of copy-n-paste'd lines is faster. And, I guess I'd better not publish even uglier code with not 15, but 35 such lines -- to avoid offending someone because of, actually, duplicating the above with very obvious changes -- moving to base 36 and ntheory::todigitstring( $i, 36 ) instead of sprintf( '%x', $i ), and:
@witnesses = ([ 8, 15, 22, 29 ], [ 6, 11, 16, 21, 26, 31 ], [ 2 .. 35 +]);
E.g., going from 36#idea to 36#perl finds 17 pairs, all through division this time, interestingly (did I mention negatives are to indicate division?). And an "interesting" fat witness, too (10#19 i.e. 36#j):
{ j376 => { "36j7" => -6 }, j736 => { "376j" => -6 }, k03c => { "3c0k" => -6 }, k12c => { "1c2k" => -15 }, k3c0 => { "3ck0" => -6 }, lm3o => { "3lom" => -6 }, m3lo => { "3olm" => -6 }, n174 => { "17n4" => -19 }, n840 => { "4n80" => -5 }, nbco => { bnoc => -2 }, o029 => { "2o09" => -9 }, o290 => { "2o90" => -9 }, o4dt => { "4tod" => -5 }, onbc => { cbno => -2 }, p046 => { "460p" => -6 }, p460 => { "46p0" => -6 }, pb6s => { "6bsp" => -4 }, } *** Rate pwc_p36 ugly_36 pwc_p36 2.02/s -- -14% ugly_36 2.36/s 17% --
with the ugly thing still faster
In reply to Faster (but uglier) PWC 350-2 solutions by Anonymous Monk
| For: | Use: | ||
| & | & | ||
| < | < | ||
| > | > | ||
| [ | [ | ||
| ] | ] |