Perl Weekly Challenge: Week 176

Challenge 1:

Permuted Multiples

Write a script to find the smallest positive integer x such that x, 2x, 3x, 4x, 5x and 6x are permuted multiples of each other.

For example, the integers 125874 and 251748 are permutated multiples of each other as

251784 = 2 x 125874

and also both have the same digits but in different order.

Output

142857

My first attempt at a Raku solution looked like this:

for 1 .. ∞ -> $n {

We create an infinite loop that assigns consecutive integers to $n.

    my @perms = $n.comb.permutations.map({ @_.join; });

$n is split into individual digits and the .permutations() method is used to get all the permutations of those digits. They are then recombined into numbers. So we end up with an array of numbers which are permutations of $n.

    if @perms.grep(2 * $n) &&
       @perms.grep(3 * $n) &&
       @perms.grep(4 * $n) &&
       @perms.grep(5 * $n) &&
       @perms.grep(6 * $n) {

Now we look for all the multiples of $n in the @perms array.

            say $n;
            last;

If all the multiples are found in the array, we have our number. We can print it out and exit the loop.

    }
}

This worked but it was dreadfully slow; taking almost 10 minutes on my machine. I tried searching for multiples from 6 .. 2 to see if that would help eliminate wrong numbers faster but it didn't make much difference. So I thought about it; I was using grep() on a list a lot; could that be the choke point? Perhaps a better data structure might help. This is my second attempt:

for 1 .. ∞ -> $n {
    my %perms = $n.comb.permutations.map({ @_.join; }).antipairs;

This time I am creating a hash whose keys are permutations. (.antipairs() transforms a list into this kind of hash.)

    if  (%perms{6 * $n}:exists) &&
        (%perms{5 * $n}:exists) &&
        (%perms{4 * $n}:exists) &&
        (%perms{3 * $n}:exists) &&
        (%perms{2 * $n}:exists) {
            say $n;
            last;
    }
}

Now it is just a simple matter of testing for the existence of a key in the hash which matches a multiple which if I remember my data structures class in college is O(1) which should be much better. Well it did shave off about two minutes from the running time but that's still very slow. At this point I moved on to Perl.

my $n = 1;

while(1) {
    my @perms;
    permute { push @perms, \@_; } split //, $n;
    my %perms =  map { $_ => 1 } map { join q{}, @{$_}; } @perms; 

    if  (exists $perms{6 * $n} &&
        exists $perms{5 * $n} &&
        exists $perms{4 * $n} &&
        exists $perms{3 * $n} &&
        exists $perms{2 * $n}) {
            last;
    }

    $n++;
}

say $n;

This is a port of the second Raku version. Permute is the standard function I use for these purposes, lifted from perlfaq4.

Much to my surprise, this script finished in less than 10 seconds. Now as Raku is a fairly young language, I do not expect it to be as optimized as Perl but this difference was astounding. I knew there had to be something wrong with my Raku implementation.

So again I put on my thinking cap and I had an ephipany or two actually. One, I don't actually need all the permutations. And two, as all the multiples are permutions, they all have the same digits. So this is attempt number three:

number: for 1 .. ∞ -> $n {

The main loop is the same but it has a label for reasons explained below.

    my $nn = $n.comb.sort.join;

This time I didn't bother with .permutations(). I merely split $n into digits, sorted them and joined them together again. This number is assigned to $nn because $n is immutable.

    for 2 .. 6 -> $i {
        next number unless ($i * $n).comb.sort.join == $nn;

For each multiple we do the same thing. If this number is not equal to $nn, we know this is not the number we want so we go the next iteration of the outer loop.

    }

If all the sorted multiples were the same as $nn, this is the number so we print it and break out of the loop.

    say $n;
    last;
}

Now the script gives the answer in about three seconds. I suppose if I had made the same changes to the Perl version it would have run even faster but I didn't try it.

(Full Raku code on Github.)

(Full Perl code on Github.)

Challenge 2:

Perfect Totient Numbers

Write a script to find out all Reversible Numbers below 100.

A number is said to be a reversible if sum of the number and its reverse had only odd digits.

For example,

36 is reversible number as 36 + 63 = 99 i.e. all digits are odd.
17 is not reversible as 17 + 71 = 88, none of the digits are odd.

Output

10, 12, 14, 16, 18, 21, 23, 25, 27,
30, 32, 34, 36, 41, 43, 45, 50, 52,
54, 61, 63, 70, 72, 81, 90

This was thankfully much easier and follows a well-used structure.

my @reversibles;

for 1 ..^ 100 -> $n {
    if isReversible($n) {
        @reversibles.push($n);
    }
}

@reversibles.join(q{, }).say;

The isReversible() function looks like this:

sub isReversible(Int $n) {
    return $n + $n.flip ~~ /^ <[13579]>+ $/;
}

(Full code on Github.)

It reverses the number being tested and adds it to the original. A regular expression checks that all the digits of this resulting number add odd. If they are, it returns True else False.

The Perl version works the same.

sub isReversible {
    my ($n) = @_;

    return $n + (0 + reverse $n) ~~ /^ [13579]+ $/msx;
}

my @reversibles;

for my $n (1 .. 99) {
    if (isReversible($n)) {
        push @reversibles, $n;
    }
}

say join q{, }, @reversibles;

(Full code on Github.)