Perl Weekly Challenge 47: Roman Calculator and Gapful Numbers

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

Spoiler Alert: This weekly challenge deadline is due in a couple of days (February 9, 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.

I have really very little time to complete this blog post in time for the deadline. My explanations will be minimal, sorry about that.

Roman Calculator

Write a script that accepts two roman numbers and operation. It should then perform the operation on the give roman numbers and print the result.

For example,

perl ch-1.pl V + VI

It should print

XI

There are two possible ways to solve such a task: to try to implement a Roman numerals computation algorithm, or to convert Roman numerals to our usual numbers, make the calculations and convert the result back to Roman nummerals. To me, it is quite obvious that the second solution is the simplest and best.

Most people know more or less how Roman numerals work. They use Latin letters to represent numbers:

|---------------------------------------------------|
| Symbol |  I  |  V  |  X  |  L  |  C  |  D  |  M   |
|---------------------------------------------------|
| Value  |  1  |  5  |  10 |  50 | 100 | 500 | 1000 |
|---------------------------------------------------|

In general, Roman numerals use additive notation: for example, MCLXXIII means 1000 + 100 + 50 + 20 + 3 = 1173. Or, at least, this is so when the symbols are written from left to right in decreasing value order.

If, however, a given symbol has a smaller value than a symbol placed on its right, then this is an example of subtractive notation: in that case, the smaller symbol is subtracted from the one its right. For example, IV means 1 subtracted from 5, i.e. 5 - 1 = 4. Similarly, IX and XC respectively mean 10 - 1 = 9 and 100 - 10 = 90. And MCMXLIX corresponds to 1000 + ( 1000 - 100) + (50 - 10) + (10 - 1) = 1949.

The overall problem, though, is that there is no general standard for Roman numerals. Applying the rules above makes it possible to decode more or less unambiguously any Roman numeral coded according to such aforesaid rules, but there may be several different possible ways to encode a number into a Roman numeral. For example, 99 could be encoded as XCXI or IC (or even XCVIIII or possibly LXXXXVIIII). The first transcription (XCXI) seems to be the most frequent one, so this is the one we will chose when encoding to Roman numerals. Still, IC seems to be a valid Roman numeral for 99, so we will try at least to be able to decode it if we find it.

Note that there is no Roman numeral for zero and the largest possible Roman numeral with the above rules is 3,999.

Roman Numeral Calculation in Perl

I’ll reuse the from_roman and to_roman subroutines used in Perl Weekly Challenge 10. Please refer to this post to get explanations on how this works.

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


my %rom_tab = (I => 1,  V => 5, X => 10, L => 50, C => 100, D => 500, M => 1000);

sub from_roman {
    my $roman = uc shift;
    my $numeric = 0;
    my $prev_letter = "M";
    for my $letter (split //, $roman) {
        $numeric -= 2 * $rom_tab{$prev_letter} 
            if $rom_tab{$letter} > $rom_tab{$prev_letter};
        $numeric += $rom_tab{$letter};
        $prev_letter = $letter;
    }
    return $numeric;
}

sub to_roman {
    my $arabic = shift;
    warn "$arabic out of bounds" unless $arabic > 0 and $arabic < 4000;
    my %hash = %rom_tab;
    $hash{$_->[0]} = $_->[1] for (['IV', 4], ['IX', 9], ['XL', 40], 
        ['XC', 90], ['CD', 400], ['CM', 900] );
    my $roman = "";
    for my $key (sort { $hash{$b} <=> $hash{$a} } keys %hash) {
        my $num = int ($arabic / $hash{$key});
        $roman .= $key x $num;
        $arabic -= $hash{$key} * $num; 
    }
    return $roman;
}

my @input;
for (@ARGV) {
    push @input, $_ if /[-+*\/]/;
    push @input, from_roman $_ if /[ivxlcdm]+/i;
}
die "Need at least three parameters" if @input < 3; # we need at least 1 operator and two operands
my $result = eval join ' ', @input;
say "@ARGV = ", to_roman $result;

These are a few examples of output:

$ perl  roman_calc.pl X + X
X + X = XX

$ perl  roman_calc.pl V + X
V + X = XV

$ perl  roman_calc.pl V + X + III
V + X + III = XVIII

$ perl  roman_calc.pl V + X + III + V
V + X + III + V = XXIII

Roman Numeral Calculation in Raku

I’ll reuse the from-roman and to-roman subroutines used in Perl Weekly Challenge 10. Please refer to this post to get explanations on how this works.

use v6;
use MONKEY-SEE-NO-EVAL;

subset Roman-str of Str where $_ ~~ /^<[IVXLCDMivxlcdm]>+$/;

my %rom-tab = < I 1   V 5   X 10   L 50   C 100  D 500  M 1000 
               IV 4  IX 9   XL 40  XC 90  CD 400   CM 900 >;
my @ordered_romans = reverse sort { %rom-tab{$_} }, keys %rom-tab;

sub from-roman (Roman-str $roman) {
    my $numeric = 0;
    my $prev_letter = "M";
    for $roman.uc.comb -> $letter {
        $numeric -= 2 * %rom-tab{$prev_letter} 
            if %rom-tab{$letter} > %rom-tab{$prev_letter};
        $numeric += %rom-tab{$letter};
        $prev_letter = $letter;
    }
    return $numeric;
}

sub to-roman (Int $arabic is copy where  { 0 < $_ < 4000 }) {
    my $roman = "";
    for @ordered_romans -> $key {
        my $num = ($arabic / %rom-tab{$key}).Int;
        $roman ~= $key x $num;
        $arabic -= %rom-tab{$key} * $num; 
    }
    return $roman;
}

my @input;
for @*ARGS {
    push @input, $_ if /<[-+*\/]>/;
    push @input, from-roman $_ if m:i/<[ivxlcdm]>+/;
}
die "Need at least three parameters" if @input < 3; # we need at least 1 operator and two operands
my $result = EVAL join ' ', @input;
say "@*ARGS[] = ", to-roman $result;

Some sample runs:

$ perl6 roman_calc.p6 III + V
III + V = VIII

$ perl6 roman_calc.p6 III + V + X
III + V + X = XVIII

$ perl6 roman_calc.p6 III + V + X - I
III + V + X - I = XVII

Gapful Numbers

Write a script to print first 20 Gapful Numbers greater than or equal to 100. Please check out the page for more information about Gapful Numbers.

Gapful numbers are numbers that are divisible by the number formed by their first and last digit. Numbers up to 100 trivially have this property and are excluded.

Basically, we need to check for all numbers from 100 on whether they are divisible by the number formed by the concatenation of their first and last digits, and stop the process once we have collected 20 numbers.

Gapful Numbers in Perl

There are several ways to extract the first and the last digits of a number. The first that came to my mind was a simple regex:

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

my @gapful = ();
my $current = 100;
do {
    my ($start, $end) = $current =~ /^(\d)\d+(\d)$/;
    push @gapful, $current unless $current % ($start . $end);
    $current ++;
} until $#gapful >= 19;
say "@gapful";

This program displays the following output:

$ perl gapful.pl
100 105 108 110 120 121 130 132 135 140 143 150 154 160 165 170 176 180 187 190

Although performance really doesn’t matter very much for such a simple task, using the substr built-in function might be more efficient that a regex. Here, we only show the loop, without the boilerplate code at the beginning of the program:

do {
    my $div = join '', substr ($current, 0, 1), substr ($current, -1, 1);
    push @gapful, $current unless $current % $div;
    $current ++;
} while $#gapful < 19;
say "@gapful";

This produces the same output as above.

Another way is to split each number into individual digits and to use a slice to pick up the first and last ones:

while ($#gapful < 19) {
    my $div = join '', (split //, $current)[0, -1];
    push @gapful, $current unless $current % $div;
    $current++;
};
say "@gapful";

This also produces the same output.

Gapful Numbers in Raku

In Raku, we don’t need a loop to manage the number of gapful numbers: we can just create a lazy infinite list of such numbers and get the first 20 ones:

my @gapful = grep { $_ %% .comb[0,*-1].join }, 100..*;
say @gapful[0..19];

We have again the sale output as before.

This is now so short and simple that we can boil it down to a Raku one-liner:

$ perl6 -e 'say (grep { $_ %% .comb[0,*-1].join}, 100..*)[0..19];'
(100 105 108 110 120 121 130 132 135 140 143 150 154 160 165 170 176 180 187 190)

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

Perl Weekly Challenge 46: Garbled Message and Room Open

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

Spoiler Alert: This weekly challenge deadline is due in a couple of days (February 9, 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.

Garbled Message

The communication system of an office is broken and message received are not completely reliable. To send message Hello, it ended up sending these following:

H x l 4 !
c e - l o
z e 6 l g
H W l v R
q 9 m # o

Similarly, another day we received a message repeatedly like below:

P + 2 l ! a t o
1 e 8 0 R $ 4 u
5 - r ] + a > /
P x w l b 3 k \
2 e 3 5 R 8 y u
< ! r ^ ( ) k 0

Write a script to decrypt the above repeated message (one message repeated 6 times).

HINT: Look for characters repeated in a particular position in all six messages received.

Basically, the idea is that any letter that is repeated at the same position in several transmissions is deemed to be correct. For example, in the case of the first message, the letter ‘H’ occurs twice in the first position of the message, so the message is deemed to start with ‘H.’ Similarly, in the second position, we have twice an ‘e,’ and so on to complete the word ‘Hello.’

Garbled Message in Perl

Although it could undoubtedly be done directly, I decided that the easiest way was first to perform a matrix transposition on the data and then to explore the resulting lines to find duplicate letters.

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

my $garbled = <<'END_MSG';
P + 2 l ! a t o
1 e 8 0 R $ 4 u
5 - r ] + a > /
P x w l b 3 k \
2 e 3 5 R 8 y u
< ! r ^ ( ) k 0
END_MSG

my @AoA = map { [ split /\s+/, $_] } split /[\r\n]+/, $garbled;
my @transposed;
for my $i (0 .. $#AoA) {
  $transposed[$_][$i] = $AoA[$i][$_] for 0.. scalar @{$AoA[$i]} -1;
}
my @msg = "";
for my $line_ref (@transposed) {
    my %counter;
    $counter{$_}++ for @$line_ref;
    push @msg, grep { $counter{$_} > 1 } keys %counter;
}
say @msg;

This program displays the following output:

$ perl garbled.pl
PerlRaku

Garbled Message in Raku

Just as in Perl, I first made a matrix transposition of the data and then looked for duplicate letters in each line:

use v6;

my $garbled = q:to/END_MSG/;
P + 2 l ! a t o
1 e 8 0 R $ 4 u
5 - r ] + a > /
P x w l b 3 k \
2 e 3 5 R 8 y u
< ! r ^ ( ) k 0
END_MSG

my @AoA = map { my @a = split /\s+/, $_; @a }, split /<[\r\n]>+/, $garbled;
my @transposed;
for (0 .. @AoA.end) -> $i {
    @transposed[$_][$i] = @AoA[$i][$_] for 0.. (@AoA[$i]).elems -1;
}
my @msg = "";
for @transposed -> $line {
    my BagHash $counter;
    $counter{$_}++ for @$line;
    push @msg, grep { $counter{$_} > 1 }, keys $counter;
}
say join "", @msg;

This program produces the same output:

$ perl6 garbled.p6
PerlRaku

Is the room open?

There are 500 rooms in a hotel with 500 employees having keys to all the rooms. The first employee opened main entrance door of all the rooms. The second employee then closed the doors of room numbers 2,4,6,8,10 and so on to 500. The third employee then closed the door if it was opened or opened the door if it was closed of rooms 3,6,9,12,15 and so on to 500. Similarly, the fourth employee did the same as the third but only room numbers 4,8,12,16 and so on to 500. This goes on until all employees has had a turn.

Write a script to find out all the rooms still open at the end.

There is an analytical way to solve this problem (as we’ll see later), but let’s just apply the process as described in the task formulation.

Open Rooms in Perl

Note that in the program below, we’re limiting the number of doors and employees to 50 (the MAX constant`), rather than 500, This is just to make the output shorter and easier to read.

use strict;
use warnings;
use feature "say";
use Data::Dumper;
use constant MAX => 50;

# 1 => open, 0 => closed

my @rooms = (1) x (MAX + 1); # (first employee)
my $start = 1;
for (2..MAX) {
    $start++;
    my $door = $start;
    while ($door <= MAX) {
        $rooms[$door] = $rooms[$door] ? 0 : 1;
        $door += $start;
    }
}
say join " ", @rooms[1..MAX];

This program displays the following output:

$ perl hotel.pl
1 0 0 1 0 0 0 0 1 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 1 0

There are a few interesting things to notice in the pattern of the result, but we’ll come back to that after the Raku solution.

Open Rooms in Raku

We’re also limiting the number of doors and employees to 50 (the MAX constant), rather than 500, to make the output shorter and easier to read.

use v6;
constant MAX = 50;
my @rooms = 1 xx MAX + 1; # (first employee)
my $start = 1;
for 2..MAX {
    $start++;
    my $door = $start;
    while $door <= MAX {
        @rooms[$door] = @rooms[$door] ?? 0 !! 1;
        $door += $start;
    }
  # say [+] @rooms[1..MAX];
}
say join " ", @rooms[1..MAX];

This displays the same output as the Perl program.

Further Analysis

I was originally surprised at the small number of doors open at the end of the process. I thought it would be interesting to see how the number of open doors evolves with each iteration. Reactivating the line commented out in the Raku program above makes it possible to see that (we’re now using the 500 rooms of the original task description):

250
250
293
277
276
269
243
260
248
247
244
... (Lines omitted for brevity)
28
27
26
25
24
23
22

Rather than giving out all the numbers, let’s plot them on a chart:

doors_open.jpg

The pattern is somewhat unexpected: after some relatively large oscillations at the very beginning, the number of open doors oscillates around 250 doors until about the 250th employee, and, after that, it starts to decline quite regularly done. That’s interesting, but I’m not quite sure what to make of that.

So I decided to examine something else: let’s look at which doors are open at the end of the process. For this, I changed the last line of the Raku program to:

say join " ", grep {@rooms[$_]}, 1..MAX;

This is the output of this modified program:

$ perl6 hotel.p6
1 4 9 16 25 36 49 64 81 100 121 144 169 196 225 256 289 324 361 400 441 484

Now, that’s very interesting: one can immediately see that the open doors at the end of the process are those whose room number are perfect squares.

Some tests showed that this seems to remain true for other values of the MAX constant.

The reason for it seems to be the following: at the end of the process, a door is open if it has been changed an odd number of times and closed if it has been changed an even number of times. And, during the iterations, a door is changed each time the number being examined divides evenly the room number. In addition, perfect squares are the only numbers that have an odd number of unique divisors (for example, 16 has five unique divisors: 1, 2, 4, 8 16), so they are the only ones that are changed an odd number of times and correspond to doors that are open at the end of the process. Any number that is not a perfect square, by contrast, has an even number of divisors. This might be worth a more rigorous mathematical demonstration, but I guess you get the point.

So, finally, to list the doors which are open at the end of the process, we could just use a Perl one-liner:

$ perl -E 'say join " ", map {$_**2} 1..500**.5;'
1 4 9 16 25 36 49 64 81 100 121 144 169 196 225 256 289 324 361 400 441 484

Or a Raku one-liner:

$ perl6 -e 'say join " ", map {$_**2}, 1..500**.5;'
1 4 9 16 25 36 49 64 81 100 121 144 169 196 225 256 289 324 361 400 441 484

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

Perl Weekly Challenge 45: Square Secret Code and Source Dumper

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

Task # 1: Square Secret Code

The square secret code mechanism first removes any space from the original message. Then it lays down the message in a row of 8 columns. The coded message is then obtained by reading down the columns going left to right.

For example, the message is “The quick brown fox jumps over the lazy dog”.

Then the message would be laid out as below:

thequick
brownfox
jumpsove
rthelazy
dog

The code message would be as below:

tbjrd hruto eomhg qwpe unsl ifoa covz kxey

Write a script that accepts a message from command line and prints the equivalent coded message.

Square Secret Code in Perl

Let’s do a first program implementing the task exactly as described:

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

my $msg = shift // "The quick brown fox jumps over the lazy dog";
$msg =~ s/\s+//g;
$msg =~ s/(.{8})/$1\n/g;
my @lines = split /\n/, $msg;
for my $i (0..7) {
    print map { substr  $_, $i, 1 if length $_ >= $i} @lines;
    print " ";
}

This works as expected:

$ perl square.pl "The quick brown fox jumps over the lazy dog"
Tbjrd hruto eomhg qwpe unsl ifoa covz kxey

But we don’t really need to lay out the message over rows of 8 characters and can simplify a bit the code using an array of strings as follows:

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

my $msg = shift // "The quick brown fox jumps over the lazy dog";
$msg =~ s/\s+//g;
my @letters = map { /.{1,8}/g; } $msg;
for my $i (0..7) {
    print map { substr  $_, $i, 1 if length $_ >= $i} @letters;
    print " ";
}

This produces the same output as before.

Square Secret Code in Raku

Here, we’re just porting the second Perl version above:

use v6;

my $msg = @*ARGS ?? shift @*ARGS 
    !! "The quick brown fox jumps over the lazy dog";
$msg ~~ s:g/\s+//;
my @letters = map { ~ $_}, $msg ~~ m:g/ .**1..8/;
for 0..7 -> $i {
    print " ", join "", map { substr  $_, $i, 1 if .chars >= $i}, @letters;
    #print " ";
}

This displays the following output:

$ perl6 square.p6 "The quick brown fox jumps over the lazy dog"
 Tbjrd hruto eomhg qwpe unsl ifoa covz kxey

Task # 2: Source Dumper

Write a script that dumps its own source code. For example, say, the script name is ch-2.pl then the following command should return nothing.

$ perl ch-2.pl | diff - ch-2.pl

Source Dumper in Perl

In Perl, the $0 special variable contains the name of the program. So, it is just a matter of opening the file and printing its lines:

use strict;
use warnings;

my $progr = "./$0";
open my $IN, "<", $progr or die "Unable to open $progr $!";
print while <$IN>;
close $IN;

Running the program duly prints its contents:

$ perl pgm_dump.pl
use strict;
use warnings;

my $progr = "./$0";
open my $IN, "<", $progr or die "Unable to open $progr $!";
print while <$IN>;
close $IN;

And a diff between the program output and the program code prints out nothing:

$ perl pgm_dump.pl | diff - pgm_dump.pl

Source Dumper in Raku

In Raku, the program name (and path) is contained in the $?FILE compile-time variable. So solving the task is very easy:

use v6;

my $progr = "$?FILE";
$progr.IO.slurp.say;

which duly prints:

$ perl6 pgm_dump.p6
use v6;

my $progr = "$?FILE";
$progr.IO.slurp.say;

Actually, we don’t need the intermediate $progr variable:

use v6;

$?FILE.IO.slurp.say;

which also prints the expected output:

$ perl6 pgm_dump.p6
use v6;

$?FILE.IO.slurp.say;

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

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 );
    for my $add (1..$incr) {
        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 );
    for 1..$incr -> $add {
        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.

olympic_rings-1.jpg

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
    my @added_vals;
    for my $num (NUMS) {
        while ($num <= $diff) {
            push @added_vals, $num;
            $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:

olympic_rings-2.jpg

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 2 to red ring
Added 2 to green ring,
Added 4 to green ring
Added 3 to blue ring
Added 3 to yellow ring,
Added 1 to yellow ring
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 2 to red ring
Added 2 to green ring
Added 4 to green ring
Added 3 to blue ring
Added 3 to yellow ring
Added 1 to yellow ring
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 ** 3and 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:

self_descriptive-formula.jpg

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.