# January 2020 Archives

## Perl Weekly Challenge 44: Only 100, Please, and Make it \$200

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

## Challenge # 1: Only 100, Please

You are given a string “123456789”. Write a script that would insert ”+” or ”-” in between digits so that when you evaluate, the result should be 100.

### Only 100, Please, in Perl

For solving this task, we first use a recursive `combine` subroutine that generates all possible strings by inserting between the digits of the “123456789” string the `+` plus addition, the `-` subtraction operator, or the `''` empty string (i.e. no operator). We then use the `evaluate` subroutine with each string to perform the various arithmetic operations and compute whether the total is 100.

``````use strict;
use warnings;
use feature "say";

sub combine {
my (\$combined, \$source) = @_;
if (\$source eq "") {
say \$combined if evaluate(\$combined) == 100;
return;
}
my \$operand = chop \$source;
for my \$op ('+', '-', '') {
combine ("\$combined\$op\$operand", \$source);
}
}

sub evaluate {
my \$expr = shift;
my \$val = 0;
\$val += \$_ for \$expr =~ /([+-]?[0-9]+)/g;
return \$val;
}

my \$source = reverse "123456789";
my \$combined = chop \$source;
combine (\$combined, \$source);
``````

This program displays the following strings evaluating to 100:

``````\$ perl only-100_1.pl
1+2+3-4+5+6+78+9
1+2+34-5+67-8+9
1+23-4+5+6+78-9
1+23-4+56+7+8+9
12+3+4+5-6-7+89
12+3-4+5+67+8+9
12-3-4+5-6+7+89
123+4-5+67-89
123+45-67+8-9
123-4-5-6-7+8-9
123-45-67+89
``````

In fact, we don’t really need the `evaluate` subroutine, since the eval built-in function (in its so-called “string eval” form) can do it for us:

``````use strict;
use warnings;
use feature "say";

sub combine {
my (\$combined, \$source) = @_;
if (\$source eq "") {
say \$combined if eval \$combined == 100;
return;
}
my \$operand = chop \$source;
for my \$op ('+', '-', '') {
combine ("\$combined\$op\$operand", \$source);
}
}
my \$source = reverse "123456789";
my \$combined = chop \$source;
combine (\$combined, \$source);
``````

This program displays the same output as before.

The glob built-in function can lead us one step further, since it can create the combinations for us. To understand how it works, consider the following one-liner copied in part from the `glob` documentation:

``````\$ perl -E 'say for glob "({apple,tomato,cherry}-{green,yellow,red})";'
(apple-green)
(apple-yellow)
(apple-red)
(tomato-green)
(tomato-yellow)
(tomato-red)
(cherry-green)
(cherry-yellow)
(cherry-red)
``````

(Don’t try to insert spaces between the words, as it would probably break everything. It is sometimes a bit difficult for me to understand how `glob` reacts, so I tend to avoid using it for such tasks. Here, I’ll do it for illustration purpose.)

We can use `glob` to generate all the combinations needed:

``````use strict;
use warnings;
use feature "say";

for my \$expr (glob join "{+,-,}", 1..9) {
say \$expr if eval \$expr == 100;
}
``````

This displays the same output as before:

``````\$ perl only-100_3.pl
1+2+3-4+5+6+78+9
1+2+34-5+67-8+9
1+23-4+5+6+78-9
1+23-4+56+7+8+9
12+3+4+5-6-7+89
12+3-4+5+67+8+9
12-3-4+5-6+7+89
123+4-5+67-89
123+45-67+8-9
123-4-5-6-7+8-9
123-45-67+89
``````

At this point, the program is so short that we can even make it a simple one-liner:

``````\$ perl -E 'say for grep { 100 == eval } glob join "{+,-,}", 1..9;'
1+2+3-4+5+6+78+9
1+2+34-5+67-8+9
1+23-4+5+6+78-9
1+23-4+56+7+8+9
12+3+4+5-6-7+89
12+3-4+5+67+8+9
12-3-4+5-6+7+89
123+4-5+67-89
123+45-67+8-9
123-4-5-6-7+8-9
123-45-67+89
``````

### Only 100, Please, in Raku

I was initially thinking that the `Z` and/or `X` operators might make it easy to generate all the digits/operators combinations, but that turned out to be more difficult that I expected for our specific task.

So, let’s try to port our first Perl implementation in Raku. Besides the usual minor differences between Perl and Raku, I encountered an unexpected difficulty: in Raku, the `chop` function returns the string with the last character chopped off, rather than, as in Perl, the character that has been removed. Rather than changing the algorithm, I decided to implement the `my-chop` subroutine to mimic the Perl `chop` behavior. Note that my very dear friend Liz Mattijsen wrote a P5chomp module that implements for Raku versions of `chomp` and `chop` with the Perl semantics. But, as usual, I don’t want to have external modules perform the work for me in the case of a programming challenge, so I wrote my own version.

``````use v6;

sub my-chop (Str \$in is rw) {
my \$char = \$in.substr(*-1);
\$in = \$in.substr(0, \$in.chars - 1);
\$char;
}

sub combine (Str \$combined, Str \$source is copy) {
if \$source eq "" {
say \$combined if evaluate(\$combined) == 100;
return;
}
my \$operand = my-chop \$source;
for '+', '-', '' -> \$op {
my \$str = "\$combined\$op\$operand";
combine(\$str, \$source);
}
}

sub evaluate (Str \$expr) {
my \$val = 0;
\$val += \$_ for \$expr ~~ m:g/(<[+-]>?\d+)/;
return \$val;
}

my \$source = "123456789".flip;
my \$combined = my-chop \$source;
combine \$combined, \$source;
``````

This program displays the following output:

``````\$ perl6 only-100.p6
1+2+3-4+5+6+78+9
1+2+34-5+67-8+9
1+23-4+5+6+78-9
1+23-4+56+7+8+9
12+3+4+5-6-7+89
12+3-4+5+67+8+9
12-3-4+5-6+7+89
123+4-5+67-89
123+45-67+8-9
123-4-5-6-7+8-9
123-45-67+89
``````

I must admit that this solution is more complicated than it ought to be. Using the `chop` function was useful in Perl because the same statement fulfilled two goals, getting one item from the list and removing it from the list. The fact that Raku doesn’t have the same behavior, which led me to write my own `my-chop` subroutine, makes this solution somewhat clunky. There are better ways to deal with this problem, but, due to some other personal commitments, I am unfortunately very late and don’t have time right now to develop them. And this situation is going to last for another 7 to 8 weeks. So, please don’t expect from me contributions to the level that I’m usually trying to achieve until about March 22 of this year. I’m sorry about that. Hopefully this will improve thereafter.

## Challenge # 2: Make it \$200

You have only \$1 left at the start of the week. You have been given an opportunity to make it \$200. The rule is simple with every move you can either double what you have or add another \$1. Write a script to help you get \$200 with the smallest number of moves.

Obviously, doubling your asset is a faster way to go high values than just adding 1. But, if you only double your asset, you get powers of 2, leading you to 128, and then you have to go all the way from 128 to 200, which is most probably not the fastest way to get to 200. In fact, if you first go to three (for example by adding 1 twice), then multiplying by 2 six times, you get to 192, which is much closer to 200. That’s 16 moves, which seems not bad at all. But there may be a yet faster way, let’s see.

### Make is \$200 in Perl

We try first to add 1 between 0 and 30 times (we don’t really need to go that far, since we’ve seen that there is a solution in 16 moves, but we don’t really go all the way to 30, since we end the loop as soon as we reach number of steps of the best solution found so far), then try to double the capital as many times as possible and then complete with new additions.

``````use strict;
use warnings;
use feature "say";
use constant { START_VAL => 1, TARGET => 200};
use constant HALF_TARGET => TARGET /2;

my \$min_ops = TARGET;
my \$best_so_far;
my %good_combinations;

for my \$incr (0..30) {
last if \$incr > \$min_ops;
my \$current_val = START_VAL;
my @steps = ( START_VAL );
push @steps, "+1";
\$current_val++;
}
while (\$current_val <= HALF_TARGET) {
push @steps, "*2";
\$current_val *= 2;
}
while (\$current_val < TARGET) {
push @steps, "+1";
\$current_val++;
}
my \$nb_steps = scalar @steps;
next if \$nb_steps >= \$min_ops;
\$min_ops = \$nb_steps;
\$best_so_far = \$incr;
\$good_combinations{\$incr} = [@steps];
}
say "Best solution: @{\$good_combinations{\$best_so_far}}";
``````

This prints out the following solution:

``````\$ perl target200.pl
Best solution: 1 +1 +1 *2 *2 *2 *2 *2 *2 +1 +1 +1 +1 +1 +1 +1 +1
``````

In theory, there could some more complex combinations, such as add 1 a number of times, multiply by 2 a few times, add again 1 a number of times, multiply again by 2 a few times, then again add 1 a few times, and so on. For some other targets, we might find a better solution this way, but for a target of 200, there isn’t going to be a better solution, since we get very quickly to 192, which is pretty close to 200.

### Make is \$200 in Raku

I don’t see any Raku feature that could make it simpler than in Perl, so I’ll simply port the Perl program to Raku:

``````use v6;

constant START-VAL = 1;
constant TARGET = 200;
constant HALF-TARGET = TARGET / 2;

my \$min-ops = TARGET;
my \$best-so-far;
my %good-combinations;

for 0..30 -> \$incr {
last if \$incr > \$min-ops;
my \$current-val = START-VAL;
my @steps = ( START-VAL );
push @steps, "+1";
\$current-val++;
}
while \$current-val <= HALF-TARGET {
push @steps, "*2";
\$current-val *= 2;
}
while \$current-val < TARGET {
push @steps, "+1";
\$current-val++;
}
my \$nb-steps = @steps.elems;
next if \$nb-steps >= \$min-ops;
\$min-ops = \$nb-steps;
\$best-so-far = \$incr;
%good-combinations{\$incr} = [@steps];
}
say "Best solution: %good-combinations{\$best-so-far}";
``````

This program prints out ther same result as before:

``````\$ perl6 target200.p6
Best solution: 1 +1 +1 *2 *2 *2 *2 *2 *2 +1 +1 +1 +1 +1 +1 +1 +1
``````

## 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, February 2. And, please, also spread the word about the Perl Weekly Challenge if you can.

## Perl Weekly Challenge 43: Olympic Rings and Self-Descripting Numbers

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

Spoiler Alert: This weekly challenge deadline is due in a couple of days (January 19, 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: Olympic Rings

There are 5 rings in the Olympic Logo as shown below. They are color coded as in Blue, Black, Red, Yellow and Green. We have allocated some numbers to these rings as below: Blue: 8 Yellow: 7 Green: 5 Red: 9

The Black ring is empty currently. You are given the numbers 1, 2, 3, 4 and 6. Write a script to place these numbers in the rings so that the sum of numbers in each ring is exactly 11.

If all five rings have a score of 11, then the total must be 55. The current total is 29, and the sum of the additional numbers is 16. So we cannot reach 55 by using each of the numbers only once, some will have to be used more than one time. So we don’t worry about using one of the additional numbers several times.

### Olympic Rings in Perl

The idea of the solution is to take each ring, compute how much is missing, i.e. the difference between the target value (11) and the current value. If that difference if one of the additional numbers, then we simply use it. If not, that we just try to fit the additional numbers, in descending order. We know that we will always find a solution, since we can always add 1 as many times as required to get to the target.

``````#!/usr/bin/perl
use strict;
use warnings;
use feature qw/say/;
use constant TARGET => 11;
use constant NUMS => (6, 4, 3, 2, 1);

my %rings = (black => 0, blue => 8, yellow => 7, green => 5, red => 9);

for my \$ring (keys %rings) {
say "Task not possible for \$ring" and next if \$rings{\$ring} >= TARGET;
my @complement = find_values(\$ring);
say "The \$ring ring starts with \t \$rings{\$ring}  and gets:  @complement."
}

sub find_values {
my \$ring = shift;
my %numbers = map {\$_ => 1} NUMS;
my \$diff = TARGET - \$rings{\$ring};
return (\$diff) if exists \$numbers{\$diff}; # not needed, for performance
for my \$num (NUMS) {
while (\$num <= \$diff) {
\$diff -= \$num;
return @added_vals if \$diff == 0;
}
}
}
``````

Running the program displays the following output:

``````\$ perl olympic.pl
The blue ring starts with        8  and gets:  3.
The green ring starts with       5  and gets:  6.
The yellow ring starts with      7  and gets:  4.
The red ring starts with         9  and gets:  2.
The black ring starts with       0  and gets:  6 4 1.
``````

### Olympic Rings in Perl, Task Revisited

After I had completed the task in Perl, written the above, and while I was completing the tests on the same task in Raku, I suddenly noticed that the figure illustrating the Olympic rings had changed, probably at some time on Wednesday, January 15. And the new drawing of the rings is now as follows: Looking at the drawing, we can now see that the task is asking us to insert the additional numbers in the ring intersections, which is something totally different.

Dear Mohammad, when you change the task after it has been posted, please send an e-mail to inform all the regular challengers. I’m pretty sure I’m not the only one to keep the challenge page loaded on a tab for several days without updating it.

The slight difficulty here is to model the geometry of the rings into some Perl data structure. Looking at the rings, it seems obvious we need to complete the red and blue rings to be able to complete unambiguously the green and yellow rings (respectively). And, once we have the green and yellow rings, we can finally complete the black one. I decided to make it as simple as possible and to use the `@ring_sequences` array of arrays (AoA) to store this information (and dealing with the black ring at the end).

``````use strict;
use warnings;
use feature qw /say/;
use constant TARGET => 11;

my %nums = map { \$_ => 1 } qw/1 2 3 4 6/;
my %rings = (
blue   => 8,
yellow => 7,
green  => 5,
red    => 9,
black  => 0
);

my @ring_sequences = ( [qw <red green>], [qw <blue yellow>] );
my @black_vals;

for my \$seq_ref (@ring_sequences) {
my \$diff = 0;
for my \$ring (@\$seq_ref) {
\$rings{\$ring} += \$diff;
say "Added \$diff to \$ring ring, " if \$diff;
\$diff = TARGET - \$rings{\$ring};
die "No way" unless exists \$nums{\$diff};
say "Added \$diff to \$ring ring";
\$rings{\$ring} += \$diff;
}
\$rings{black} += \$diff;
push @black_vals, \$diff;
}
my \$black_diff = TARGET - \$rings{black};
die "No way" unless exists \$nums{\$black_diff};
push @black_vals, \$black_diff;
\$rings{black} += \$black_diff;
say "Added @black_vals to black ring";
say "\nFinal ring values:";
say "\$_\t\$rings{\$_}" for keys %rings;
``````

This is the output generated by this program:

``````\$ perl olympic2.pl
Added 4 1 6 to black ring

Final ring values:
blue    11
yellow  11
red     11
black   11
green   11
``````

### Olympic Rings (Revisited) in Raku

I did not find any way to use specific Raku features to do it other than just porting the Perl program (except for minor changes, such as using a `Set` instead of a hash). So, this is essentially the same ported to Raku:

``````use v6;

constant target = 11;
my \$nums = Set.new(1, 2, 3, 4, 6);
my %rings =
blue   => 8,
yellow => 7,
green  => 5,
red    => 9,
black  => 0
;

my @ring-sequences = ["red", "green"], ["blue", "yellow"];
my @black-vals;

for @ring-sequences -> @seq {
my \$diff = 0;
for @seq -> \$ring {
%rings{\$ring} += \$diff;
say "Added \$diff to \$ring ring" if \$diff;
\$diff = target - %rings{\$ring};
die "No way" unless \$nums{\$diff};
say "Added \$diff to \$ring ring";
%rings{\$ring} += \$diff;
}
%rings{'black'} += \$diff;
push @black-vals, \$diff;
}
my \$black_diff = target - %rings{'black'};
die "No way" unless \$nums{\$black_diff}:exists;
push @black-vals, \$black_diff;
%rings{'black'} += \$black_diff;
say "Added @black-vals[] to black ring";
say "\nFinal ring values:";
say "\$_\t%rings{\$_}" for keys %rings;
``````

And it produces essentially the same output:

``````\$ perl6 olympic.p6
Added 4 1 6 to black ring

Final ring values:
red     11
green   11
yellow  11
blue    11
black   11
``````

## Self-Descriptive Numbers

(Contributed by Laurent Rosenfeld.)

Write a script to generate self-descriptive Numbers in a given base.

In mathematics, a self-descriptive number is an integer m that in a given base b is b digits long in which each digit d at position n (the most significant digit being at position 0 and the least significant at position b - 1) counts how many instances of digit n are in m.

For example, if the given base is 10, then script should print 6210001000. For more information, please checkout wiki page.

First, to clarify my original intention: yes, this task is derived from a mail I sent Mohammad on Jan. 1, 2020, in which, besides wishing him and his family an happy new year, I also suggested a challenge on autobiographical numbers, the reason being that this new year, 2020, happens to be an autobiographical number (the first 2 says that there are two 0, the next 0 says that there is zero 1, and next 2 says that there are twp 2, and the final 0 says that there is no 3). Note that 2020 is also a self-descriptive number, but only in base 4, not in base 10 (because self-descriptive numbers must have a number of digits equal to the base). Now, since Wikipedia covers autobiographical numbers as a part of the Wikipedia entry on self-descriptive numbers, it seems that Mohammad thought I suggested a challenge on self-descriptive numbers, which is not exactly what I meant. Finding self-descriptive numbers in base 10 is quite challenging, because we’re supposed to review all numbers between 10 billion (`1e10`) and 100 billion - 1 (`1e11 - 1`), which is bound to take many hours. It can be done, but it’s expensive. However, we’ll see that there are faster solutions.

### Self-Descriptive Numbers in Perl

Let’s start with a solution implementing directly the definition of self-descriptive numbers: in a given base `b`, we’re looking for a number that has `b` digits and in which each digit is equal the number of identical digits in the base-b representation of that number. We’ve seen the example of 2020 in base 4. There is another number matching this requirement in base 4: 1210 (equivalent to 100 in base 10). 1210 is 4 digit-long, and the 1 says that there is one 0, the 2 that there are two 1, the 1 that there is 1 2, and the 0 that there is no 3.

Note that it is known that there is no self-descriptive number for bases 2, 3, and 6.

If we are looking for self-descriptive numbers in base 4, we want to scan every number between 1000 (base 4) and 3333 (base 4), i.e. between `4 ** 3`and `4 ** 4 -1`. In decimal notation, this means each number between 64 and 255.

Then, for each number in this range, we check if it is self-descriptive.

We can start by implementing these rules as follows:

``````use strict;
use warnings;
use feature qw /say/;
use constant DIGITS => ('0'..'9', 'A'..'Z');

sub to_base_b {
my(\$dec, \$base) = @_;
my @digits;
while (\$dec) {
unshift @digits, (DIGITS)[\$dec % \$base];
\$dec = int(\$dec/\$base);
}
return join "", @digits;
}
sub check_all_cases {
my \$base = shift;;
for my \$num (\$base ** (\$base -1) .. \$base ** \$base -1) {
my \$num_in_b = to_base_b (\$num, \$base);
my @digits = split //, \$num_in_b;
my \$success = 1;
for my \$rank (0..\$base - 1) {
my \$nb_digits = \$digits[\$rank];
my \$num_occ = \$num_in_b =~ s/\$rank/\$rank/g;
if (\$num_occ != \$nb_digits) {
\$success = 0;
last;
}
}
say "Number in base \$base: \$num_in_b; decimal: \$num"
if \$success;
}
}
my \$base = shift;
check_all_cases(\$base);
``````

Now, if we run this program for values 2 to 7, we get the following results:

``````\$ perl self_descriptive.pl 2

\$ perl self_descriptive.pl 3

\$ perl self_descriptive.pl 4
Number in base 4: 1210; decimal: 100
Number in base 4: 2020; decimal: 136

\$ perl self_descriptive.pl 5
Number in base 5: 21200; decimal: 1425

\$ perl self_descriptive.pl 6

\$ perl self_descriptive.pl 7
Number in base 7: 3211000; decimal: 389305
``````

The results are correct, but this is quickly getting slow (5.4 seconds for base 7 on my computer). It will be difficult to get to base 10, and impossible to get much further.

We can try some performance optimization. The Wikipedia article states that a self-descriptive number in base `b` must be a multiple of that base (or equivalently, that the last digit of the self-descriptive number must be 0). So we can skip the check for any number whose representation in a given base doesn’t end with 0. Also, all self-descriptive numbers have digit sums equal to their base. We can filter out those that don’t match these two conditions.

Adding these two criteria leads to the following modified `check_all_cases` subroutine:

``````sub check_all_cases {
my \$base = shift;;
for my \$num (\$base ** (\$base -1) .. \$base ** \$base -1) {
my \$num_in_b = to_base_b (\$num, \$base);
next unless \$num_in_b =~ /0\$/;
my @digits = split //, \$num_in_b;
my \$sum = 0;
\$sum += \$_ for split //, \$num_in_b;
next if \$sum != \$base;
my \$success = 1;
for my \$rank (0..\$base - 1) {
my \$nb_digits = \$digits[\$rank];
my \$num_occ = \$num_in_b =~ s/\$rank/\$rank/g;
if (\$num_occ != \$nb_digits) {
\$success = 0;
last;
}
}
say "Number in base \$base: \$num_in_b; decimal: \$num"
if \$success;
}
}
``````

This helps a bit to improve performance (3.3 seconds instead of 5.4 for base 7), but not enough for larger bases.

The Wikipedia page referred to above states that, in base 7 and above, there is, if nothing else, a self-descriptive number of the form: We can simply implement this formula for bases 7 and above. Our new program implements this for bases within the range 0 to 10:

``````use strict;
use warnings;
use feature qw /say/;
use constant DIGITS => ('0'..'9', 'A'..'Z');

sub find_self_descriptive {
my \$b = shift;
return "No self-descriptive number for base \$b"
if \$b < 4 or \$b == 6;
if (\$b == 4 or \$b == 5) {
return check_all_cases (\$b);
}
my \$dec_num = (\$b - 4) * \$b ** (\$b - 1)
+ 2 * \$b ** (\$b - 2) + \$b ** (\$b - 3) + \$b ** 3;
my \$base_num = to_base_b (\$dec_num, \$b);
return "Number in base \$b: \$base_num; decimal: \$dec_num";
}

sub to_base_b {
my (\$dec, \$base) = @_;
my @digits;
while (\$dec) {
unshift @digits, (DIGITS)[\$dec % \$base];
\$dec = int(\$dec/\$base);
}
return join "", @digits;
}

sub check_all_cases {
my \$base = shift;;
for my \$num (\$base ** (\$base -1) .. \$base ** \$base -1) {
my \$num_in_b = to_base_b (\$num, \$base);
next unless \$num_in_b =~ /0\$/;
my @digits = split //, \$num_in_b;
my \$sum = 0;
\$sum += \$_ for split //, \$num_in_b;
next if \$sum != \$base;
my \$success = 1;
for my \$rank (0..\$base - 1) {
my \$nb_digits = \$digits[\$rank];
my \$num_occ = \$num_in_b =~ s/\$rank/\$rank/g;
if (\$num_occ != \$nb_digits) {
\$success = 0;
last;
}
}
return "Number in base \$base: \$num_in_b; decimal: \$num" if \$success;
}
}

say find_self_descriptive \$_ for (1 .. 10);
``````

This works fine and is very fast:

``````\$ time perl self_descriptive.pl
No self-descriptive number for base 1
No self-descriptive number for base 2
No self-descriptive number for base 3
Number in base 4: 1210; decimal: 100
Number in base 5: 21200; decimal: 1425
No self-descriptive number for base 6
Number in base 7: 3211000; decimal: 389305
Number in base 8: 42101000; decimal: 8946176
Number in base 9: 521001000; decimal: 225331713
Number in base 10: 6210001000; decimal: 6210001000

real    0m0,061s
user    0m0,000s
sys     0m0,030s
``````

### Self-Descriptive Numbers in Raku

For solving this task in Raku, we’ll just port the last Perl version to Raku. Note that we no longer need the `to_base_b` base conversion subroutine, since Raku provides a base method to convert a number to a string representation of it in a given base. Raku offers a couple of additional features making the code somewhat simpler:

``````use v6;

sub find-self-descriptive (Int \$b) {
return check-all-cases (\$b) if \$b < 7;
my \$dec-num = (\$b - 4) * \$b ** (\$b - 1) + 2 * \$b ** (\$b - 2) + \$b ** (\$b - 3) + \$b ** 3;
my \$base-num = \$dec-num.base(\$b);
return "Number in base \$b: \$base-num; decimal: \$dec-num";
}

sub check-all-cases (Int \$base) {
for \$base ** (\$base -1) .. \$base ** \$base -1 -> \$num {
my \$num-in-b = \$num.base(\$base);
next unless \$num-in-b ~~ /0\$/;
my @digits = \$num-in-b.comb;
next if \$base != [+] @digits;
my \$success = True;
for 0..\$base - 1 -> \$rank {
if (+ \$num-in-b.indices(\$rank) != @digits[\$rank]) {
\$success = False;
last;
}
}
return "Number in base \$base: \$num-in-b; decimal: \$num" if \$success;
}
return "No self-descriptive number for base \$base";
}

say .&find-self-descriptive for 1 .. 10;
``````

This program displays the following output:

``````\$ ./perl6 self_descriptive.p6
No self-descriptive number for base 1
No self-descriptive number for base 2
No self-descriptive number for base 3
Number in base 4: 1210; decimal: 100
Number in base 5: 21200; decimal: 1425
No self-descriptive number for base 6
Number in base 7: 3211000; decimal: 389305
Number in base 8: 42101000; decimal: 8946176
Number in base 9: 521001000; decimal: 225331713
Number in base 10: 6210001000; decimal: 6210001000
``````

## 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 26, 2020. And, please, also spread the word about the Perl Weekly Challenge if you can.

## Perl Weekly Challenge 42: Octal Numbers and Balanced Parentheses

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

Spoiler Alert: This weekly challenge deadline is due in a couple of days (January 12, 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: Octal Number System

Write a script to print decimal number 0 to 50 in Octal Number System.

For example:

``````Decimal 0 = Octal 0
Decimal 1 = Octal 1
Decimal 2 = Octal 2
[ ... ]
``````

### Octal Number System in Raku

Raku has a base method to convert a number into a string representation in any base between 2 and 36.

With this, it is so easy that we can use a one-liner:

``````\$ perl6 -e 'say "Decimal: \$_ \t=  Octal ", .base(8) for 0..50;'
Decimal: 0      =  Octal 0
Decimal: 1      =  Octal 1
Decimal: 2      =  Octal 2
Decimal: 3      =  Octal 3
Decimal: 4      =  Octal 4
Decimal: 5      =  Octal 5
Decimal: 6      =  Octal 6
Decimal: 7      =  Octal 7
Decimal: 8      =  Octal 10
Decimal: 9      =  Octal 11
[ ... Lines omitted for brevity ... ]
Decimal: 45     =  Octal 55
Decimal: 46     =  Octal 56
Decimal: 47     =  Octal 57
Decimal: 48     =  Octal 60
Decimal: 49     =  Octal 61
Decimal: 50     =  Octal 62
``````

### Octal Number System in Perl 5

Perl 5’s sprintf and `printf` functions actually offers the same possibility for octal and hexadecimal representations (bases 8 and 16), so that we can also do it with a one-liner:

``````\$ perl -e 'printf "Decimal: %2d  =  Octal %2o \n", \$_, \$_ for 0..50;'
Decimal:  0  =  Octal  0
Decimal:  1  =  Octal  1
Decimal:  2  =  Octal  2
Decimal:  3  =  Octal  3
Decimal:  4  =  Octal  4
Decimal:  5  =  Octal  5
Decimal:  6  =  Octal  6
Decimal:  7  =  Octal  7
Decimal:  8  =  Octal 10
Decimal:  9  =  Octal 11
Decimal: 10  =  Octal 12
[ ... Lines omitted for brevity ... ]
Decimal: 45  =  Octal 55
Decimal: 46  =  Octal 56
Decimal: 47  =  Octal 57
Decimal: 48  =  Octal 60
Decimal: 49  =  Octal 61
Decimal: 50  =  Octal 62
``````

## Challenge # 2: Balanced Brackets

Write a script to generate a string with random number of ( and ) brackets. Then make the script validate the string if it has balanced brackets.

For example:

``````() - OK
(()) - OK
)( - NOT OK
())() - NOT OK
``````

Well, I have a slight problem with this task requirement. A script generating a random number of random brackets will almost never generate balanced brackets, except when the maximal number of brackets is really small (say 2 or 4). So, I changed the task to writing a script that checks that strings passed to it have properly balanced parentheses.

### Balanced Parentheses in Raku

#### Balanced Parentheses Using a Grammar

I admit that this may be slight technological overkill, but seeing such a task leads me immediately to use grammars, which are naturally capable to manage such tasks, since their rules can easily be called recursively to parse any number of nested parentheses. So, this is my first solution:

``````use v6;

grammar Parens {
token TOP { \s* <paren-expr>+ \s* }
token paren-expr { | \s* <paren-pair> \s*
| '(' \s* <paren-expr>+ \s* ')' }
token paren-pair { [ '(' \s* ')' ]+ }
}

for "()", "(  )", "(())", "( ( ))", ")(", "())()",
"((( ( ()))))",  "()()()()", "(())(())" -> \$expr {
say "\$expr - ", Parens.parse(\$expr) ?? "OK" !! "NOT OK";
}
``````

The `TOP` token is any strictly positive number of `paren-expr`. A `paren-expr` is either a `paren-pair` or an opening parenthesis, followed by, recursively, another `paren-expr`, followed by a closing parenthesis. Note that this could most probably have been made simpler (only two tokens instead of three) if we had decided to remove all spaces of the string before parsing.

This script displays the following output:

``````\$ perl6 parens.p6
() - OK
(  ) - OK
(()) - OK
( ( )) - OK
)( - NOT OK
())() - NOT OK
((( ( ())))) - OK
()()()() - OK
(())(()) - OK
``````

#### Balanced Parentheses Using a Stack

As I said, using grammars for such a simple task might be considered over-engineering. We had recently a challenge about reverse Polish notation that led us to use a stack. Recursion and stacks are intimately related. We could use a stack to perform the same task: push to the stack if we get a `(`, and pop from the stack if we get a `)`, unless the stack is empty; and, at the end, check that the stack is empty. Some people might think that this approach is conceptually simpler than a grammar. But I tend to think this is wrong. Except for a small typo, my grammar approach worked the first time I tested it. Not only is the stack code below significantly longer, but I had to debug the stack approach below for about 15 minutes before it got right:

``````use v6;

sub check-parens (Str \$expr) {
my @stack;
my \$s = \$expr;
\$s ~~ s:g/\s+//; # remove spaces;
for \$s.comb {
when '(' { push @stack, \$_; }
when ')' {
say "\$expr: NOT OK" and return unless @stack;
pop @stack;
}
default { say \$s }
}
say "\$expr: ", @stack.elems ?? "NOT OK" !! "OK";
}
for "()", "(  )", "(())", "( ( ))", ")(", "())()",
"((( ( ()))))",  "()()()()", "(())(())" {
check-parens(\$_)
}
``````

This is the output:

``````\$ perl6 parens.p6
(): OK
(  ): OK
(()): OK
( ( )): OK
)(: NOT OK
())(): NOT OK
((( ( ())))): OK
()()()(): OK
(())(()): OK
``````

In fact, we don’t really need a stack, as we will see in the Perl 5 implementation below.

### Balanced Parentheses in Perl 5

We could in principle use one of the code parser available in Perl 5 modules. But while grammars are fully integrated into Raku, they are less easy to use in Perl 5. You usually have to generate an intermediate file and then use it for parsing the input. It can be done, but that looks a bit complicated for our case.

#### Stack Solution in Perl 5

We can port our stack solution to Perl 5:

``````#!/usr/bin/perl
use strict;
use warnings;
use feature qw/say/;

sub check_parens {
my \$expr = shift;
my @stack;
\$expr =~ s/\s+//g; # remove spaces
for (split //, \$expr) {
push @stack, \$_ if \$_ eq '(';
if (\$_ eq ')') {
return 0 if @stack == 0;
pop @stack;
}
}
return scalar @stack == 0 ? 1 : 0;
}

for ("()", "(  )", "(())", "( ( ))", ")(", "())()",
"((( ( ()))))",  "()()()()", "(())(())") {
say "\$_: ", check_parens(\$_) ? "OK" : "Not OK";
}
``````

This program displays the following output:

``````\$ perl  parens.pl
(): OK
(  ): OK
(()): OK
( ( )): OK
)(: Not OK
())(): Not OK
((( ( ())))): OK
()()()(): OK
(())(()): OK
``````

#### Using a Counter

Actually, we don’t really need a stack. We can use a simple counter starting at 0, which we increment when we get an opening parenthesis, and decrement when we get a closing parenthesis. If we get a closing parenthesis when the counter is 0, or if the counter is not 0 at the end of the parsing, then the parentheses are not properly balanced.

``````#!/usr/bin/perl
use strict;
use warnings;
use feature qw/say/;

sub check_parens {
my \$expr = shift;
\$expr =~ s/\s+//g; # remove spaces
my \$count = 0;
for (split //, \$expr) {
\$count++ if \$_ eq '(';
if (\$_ eq ')') {
return 0 if \$count == 0;
\$count--;
}
}
return \$count == 0 ? 1 : 0;
}

for ("()", "(  )", "(())", "( ( ))", ")(", "())()",
"((( ( ()))))",  "()()()()", "(())(())") {
say "\$_: ", check_parens(\$_) ? "OK" : "Not OK";
}
``````

This produces the same output as before.

## 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 the deadline for the week. And, please, also spread the word about the Perl Weekly Challenge if you can.

## Perl Weekly Challenge 41: Attractive Numbers and Leonardo Numbers

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 `Set`s, 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

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

``````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. I am the author of the "Think Perl 6" book (O'Reilly, 2017) and I blog about the Perl 5 and Raku programming languages.