laurent_r

These are some answers to the Week 41 of the Perl Weekly Challenge organized by Mohammad S. Anwar.

Spoiler Alert: This weekly challenge deadline is due in a couple of days (January 5, 2020). This blog post offers some solutions to this challenge, please don’t read on if you intend to complete the challenge on your own.

Challenge # 1: Attractive Numbers

Write a script to display attractive number between 1 and 50.

A number is an attractive number if the number of its prime factors is also prime number.

The number 20 is an attractive number, whose prime factors are 2, 2 and 5. The total prime factors is 3 which is also a prime number.

First comment: we’re obviously interested only with proper prime factors, i.e. prime factors of a number other than 1 and the number itself.

Next, since we’re interested with only the range between 1 and 50, the largest possible number of prime factors is 5 (the smallest number with 6 prime factors is 2 ** 6 = 64). So, we could solve the task by gathering the numbers in the range which are not prime and whose number of proper prime factors is not 4.

Attractive Numbers in Perl 5

We could use the general prime factorization technique described in my blog post about Perl Weekly Challenge # 23, but we can simplify it in the context of this task with the following observation: any non prime number in the range between 1 and 50 will be evenly divided by one of the first four primes: 2, 3, 5, and 7. After we have divided the input number by those four primes as many times as possible, the remaining number will either be 1 or will be a prime that can be added to the list of factors (unless it is the input number itself). So we will simply hard-code the list of the four first primes and test them against the input number.

#!/usr/bin/perl
use strict;
use warnings;
use feature qw/say/;
use constant PRIMES => (2, 3, 5, 7);

sub prime_factors {
    my $num = shift;
    my $origin_num = $num;
    my @factors;
    for my $div (PRIMES) {
        while ($num % $div == 0) {
            push @factors, $div;
            $num /= $div;
        }
        return @factors if $num == 1;
    }
    push @factors, $num unless $num == $origin_num;
    return @factors;
}

my %primes = map { $_ => 1 } PRIMES;
say "$_: ", join " ", prime_factors($_) for 
    grep exists $primes{scalar prime_factors($_)}, 1..50;

This produces the following output:

$ perl  attractive_numbers.pl
4: 2 2
6: 2 3
8: 2 2 2
9: 3 3
10: 2 5
12: 2 2 3
14: 2 7
15: 3 5
18: 2 3 3
20: 2 2 5
21: 3 7
22: 2 11
25: 5 5
26: 2 13
27: 3 3 3
28: 2 2 7
30: 2 3 5
32: 2 2 2 2 2
33: 3 11
34: 2 17
35: 5 7
38: 2 19
39: 3 13
42: 2 3 7
44: 2 2 11
45: 3 3 5
46: 2 23
48: 2 2 2 2 3
49: 7 7
50: 2 5 5

Note that the last statement in the program calls the prime_factors subroutine twice, which is admittedly not very efficient, but it is only because I added the display of the prime factors at last moment: since I was a bit surprised by the number of attractive numbers (higher than what I originally expected), I decided to add the display of the prime factors to visually check that the number of prime factors was prime. Displaying those prime factors was not a requirement of the task, so I could have removed that (and, together with it, the additional call to the prime_factors subroutine), but I kept it to enable the reader to make the same check.

Attractive Numbers in Raku

The Raku programming language has a fast is-prime built-in routine that we can use to build a lazy infinite list of prime numbers, so that we don’t need to hard-code a (small) list of primes as we did in Perl 5.

Using Prime Factorization

Otherwise, the algorithm is essentially the same:

use v6;

my @primes = grep {.is-prime}, 1..*;

sub prime-factors (UInt $num-in) {
    my @factors;
    my $num = $num-in;
    for @primes -> $div {
        while ($num %% $div) {
            push @factors, $div;
            $num div= $div;
        }
        return @factors if $num == 1;
    }
    push @factors, $num unless $num == $num-in;
    return @factors;
}
say "$_: ", prime-factors($_).join(" ") for 
    grep {prime-factors($_).elems.is-prime}, 1..50;

This prints out the same result as in P5:

$ perl6 attractive_numbers.p6
4: 2 2
6: 2 3
8: 2 2 2
9: 3 3
10: 2 5
12: 2 2 3
14: 2 7
15: 3 5
18: 2 3 3
20: 2 2 5
21: 3 7
22: 2 11
25: 5 5
26: 2 13
27: 3 3 3
28: 2 2 7
30: 2 3 5
32: 2 2 2 2 2
33: 3 11
34: 2 17
35: 5 7
38: 2 19
39: 3 13
42: 2 3 7
44: 2 2 11
45: 3 3 5
46: 2 23
48: 2 2 2 2 3
49: 7 7
50: 2 5 5

Using Fun

The next solution isn’t very efficient in terms of performance, but is quite fun and leads to much shorter code.

We have seen that we’re looking for numbers that are products of two, three, or five prime factors. The idea here is to use combinations of two, three or five prime numbers, multiply the members of each such combination and keep those which are less than or equal to 50.

The Raku combinations function returns combinations of the invocant list, as shown here under the REPL:

> say (0..2).combinations;
(() (0) (1) (2) (0 1) (0 2) (1 2) (0 1 2))

You can specify an additional parameter, a number or a range, to indicate the number of items in each combination:

> say (0..3).combinations: 3;
((0 1 2) (0 1 3) (0 2 3) (1 2 3))
> say (0..3).combinations: 2..3;
((0 1) (0 2) (0 3) (1 2) (1 3) (2 3) (0 1 2) (0 1 3) (0 2 3) (1 2 3))

The problem, though, is that we want combinations where each item of the input list can be used one or several times. We can use the xx operator to do this:

> say (<a b c> xx 3).flat.combinations: 2
((a b) (a c) (a a) (a b) (a c) (a a) (a b) (a c) (b c) (b a) (b b) (b c) (b a) (b b) (b c) (c a) (c b) (c c) (c a) (c b) (c c) (a b) (a c) (a a) (a b) (a c) (b c) (b a) (b b) (b c) (c a) (c b) (c c) (a b) (a c) (b c))
> say ((<a b> xx 2).flat.combinations(2..3));
((a b) (a a) (a b) (b a) (b b) (a b) (a b a) (a b b) (a a b) (b a b))

The first problem with this solution is that we have duplicates in our list. Using Sets will help solve these two problems:

> say (map { [~] $_ }, (<a b> xx 2).flat.combinations(2..3)).Set;
set(aa aab ab aba abb ba bab bb)

Sets, together with the ∪ union operator, will solve the other problem, namely that we can provide a single number or range as a parameter to combinations, but we can’t specify three numbers such as 2, 3, 5.

Of course, we also need the [*] meta-operator to generate the product and a grep to filter out products that are larger than 50.

With all this, we can now write our program:

use v6;

my @primes = grep {.is-prime}, 1..25;
my $set = (grep {$_ <= 50}, map {[*] $_}, (@primes xx 3).flat.combinations: 2..3)
    ∪ (grep {$_ <= 50}, map {[*] $_}, (@primes[0..4] xx 5).flat.combinations: 5);
say $set.keys.sort

Note that we don’t need to explicitly coerce the two sequences into Sets, since the ∪ union operator does that for us. This is the output of the program:

$  perl6 attractive_numbers_2.p6
(4 6 8 9 10 12 14 15 18 20 21 22 25 26 27 28 30 32 33 34 35 38 39 42 44 45 46 48 49 50)

Note that this program runs in about 1.3 sec., where as the previous implementation ran in about 0.3 second. Clearly, this is less efficient, and this was to be expected, because we’re generating a large number of combinations, most of which turn out to be useless and are then removed from the output either because they are duplicates or because the obtained value exceeds 50. The performance is a bit bad, but it was quite a bit of fun generating a solution holding in much less code lines.

Challenge # 2: Leonardo Numbers

Write a script to display first 20 Leonardo Numbers. Please checkout wiki page for more information.

For example: L(0) = 1 L(1) = 1 L(2) = L(0) + L(1) + 1 = 3 L(3) = L(1) + L(2) + 1 = 5

and so on.

So, basically, Leonardo numbers are very similar to Fibonacci numbers, except that 1 gets added to the sum each time we go from one step to the next.

Leonardo Numbers in Perl 5

This is quite simple. Let’s start with a plain vanilla iterative approach:

use strict; 
use warnings;
use feature qw /say/;

my @leonardo = (1, 1);
for my $i (1..18) {
    push @leonardo, $leonardo[-1] + $leonardo[-2] + 1;
}
say "@leonardo";

This script prints out the following output:

1 1 3 5 9 15 25 41 67 109 177 287 465 753 1219 1973 3193 5167 8361 13529

Or we could use a recursive approach. But Leonardo numbers have the same problem as Fibonacci numbers with a recursive approach when the searched number becomes relatively large (e.g. 40 or 45): computing them becomes extremely slow (this is not really a problem here, since we’ve been requested to compute the first 20 Leonardo numbers, but let’s try to make a program that scales well to higher values). To avoid that problem with large input values, we memoize or cache manually our recursion, using the @leonardo array (for inputs larger than what is requested by the task):

use strict; 
use warnings;
use feature qw /say/;

my @leonardo = (1, 1);
sub leonardo {
    my $in = shift;
    return $leonardo[$in] if defined $leonardo[$in];
    $leonardo[$in] = 1 + leonardo($in - 1) + leonardo($in -2);
}
my $target = leonardo(shift);
say "@leonardo";

Using it with an input parameter of 90 provides instantly the following result:

1 1 3 5 9 15 25 41 67 109 177 287 465 753 1219 1973 3193 5167 8361 13529 21891 35421 57313 92735 150049 242785 392835 635621 1028457 1664079 2692537 4356617 7049155 11405773 18454929 29860703 48315633 78176337 126491971 204668309 331160281 535828591 866988873 1402817465 2269806339 3672623805 5942430145 9615053951 15557484097 25172538049 40730022147 65902560197 106632582345 172535142543 279167724889 451702867433 730870592323 1182573459757 1913444052081 3096017511839 5009461563921 8105479075761 13114940639683 21220419715445 34335360355129 55555780070575 89891140425705 145446920496281 235338060921987 380784981418269 616123042340257 996908023758527 1613031066098785 2609939089857313 4222970155956099 6832909245813413 11055879401769513 17888788647582927 28944668049352441 46833456696935369 75778124746287811 122611581443223181 198389706189510993 321001287632734175 519390993822245169 840392281454979345 1359783275277224515 2200175556732203861 3559958832009428377 5760134388741632239 9320093220751060617

The program ran in about 0.065 second. Without memoization, it would probably take close to about a million years to get the above results (except, of course, that the program would die long before that because of a number of other reasons, including, but not limited to, memory shortage, CPU breakdown, power outages, planned obsolescence, and quite possibly global warming or thermonuclear Armageddon).

Leonardo Numbers in Raku

We start with the iterative plain-vanilla approach:

use v6

my @leo = 1, 1;
push @leo, @leo[*-1] + @leo[*-2] + 1 for 1..18;
say @leo;

which duly prints:

[1 1 3 5 9 15 25 41 67 109 177 287 465 753 1219 1973 3193 5167 8361 13529]

And the memoized recursive approach is not much more complicated:

use v6;
my @leo = 1, 1;
sub leonardo (Int $in) {
    return @leo[$in] if defined @leo[$in];
    @leo[$in] = [+] 1, leonardo($in - 1), leonardo($in -2);
}
sub MAIN (Int $input = 19) {
    leonardo $input;
    say @leo;
}

If we run the program without providing a parameter (i.e. with a default value of 19) we get the same list as before:

[1 1 3 5 9 15 25 41 67 109 177 287 465 753 1219 1973 3193 5167 8361 13529]

And if we run it with a parameter of 98, we obtain the following output:

[1 1 3 5 9 15 25 41 67 109 177 287 465 753 1219 1973 3193 5167 8361 13529 21891 35421 57313 92735 150049 242785 392835 635621 1028457 1664079 2692537 4356617 7049155 11405773 18454929 29860703 48315633 78176337 126491971 204668309 331160281 535828591 866988873 1402817465 2269806339 3672623805 5942430145 9615053951 15557484097 25172538049 40730022147 65902560197 106632582345 172535142543 279167724889 451702867433 730870592323 1182573459757 1913444052081 3096017511839 5009461563921 8105479075761 13114940639683 21220419715445 34335360355129 55555780070575 89891140425705 145446920496281 235338060921987 380784981418269 616123042340257 996908023758527 1613031066098785 2609939089857313 4222970155956099 6832909245813413 11055879401769513 17888788647582927 28944668049352441 46833456696935369 75778124746287811 122611581443223181 198389706189510993 321001287632734175 519390993822245169 840392281454979345 1359783275277224515 2200175556732203861 3559958832009428377 5760134388741632239 9320093220751060617 15080227609492692857 24400320830243753475 39480548439736446333 63880869269980199809 103361417709716646143 167242286979696845953 270603704689413492097 437845991669110338051]

Again, without memoization, the expected execution time would be several millions years (except, of course, that it would die long before that for the same reasons as above).

Wrapping up

The next week Perl Weekly Challenge is due to start soon. If you want to participate in this challenge, please check https://perlweeklychallenge.org/ and make sure you answer the challenge before 23:59 BST (British summer time) on Sunday, January 12, 2020. And, please, also spread the word about the Perl Weekly Challenge if you can.