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
[ ... ]

For this task, I’ll start with Raku, because it is so easy in Raku.

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 Sets, since the union operator does that for us. This is the output of the program:

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

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

Challenge # 2: Leonardo Numbers

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

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

and so on.

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

Leonardo Numbers in Perl 5

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

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

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

This script prints out the following output:

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

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

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

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

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

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

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

Leonardo Numbers in Raku

We start with the iterative plain-vanilla approach:

use v6

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

which duly prints:

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

And the memoized recursive approach is not much more complicated:

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

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

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

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

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

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

Wrapping up

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

Perl Weekly Challenge 40: Multiple Arrays Content and Sublist Sorting

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

Spoiler Alert: This weekly challenge deadline is due in a couple of days (December 29, 2019). 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: Multiple Arrays Content

You are given two or more arrays. Write a script to display values of each list at a given index.

For example:

Array 1: [ I L O V E Y O U ]
Array 2: [ 2 4 0 3 2 0 1 9 ]
Array 3: [ ! ? £ $ % ^ & * ]

We expect the following output:

I 2 !
L 4 ?
O 0 £
V 3 $
E 2 %
Y 0 ^
O 1 &
U 9 *

Multiple Arrays Content in Perl 5

Since this task seems fairly simple and does not require too much typing, I’ll suggest several solutions, with added features each time.

Considering the example provided with the task, we can see that all three arrays have the same number of items and that each item is just one character long. With such input data, the solution may be as simple as this:

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

my @a1 = qw /I L O V E Y O U/;
my @a2 = qw /2 4 0 3 2 0 1 9/;
my @a3 = qw /! ? £ $ % ^ & */;

say "$a1[$_] $a2[$_] $a3[$_]" for 0..$#a1;

Running this script produces the following output:

$ perl mult_arrays.pl
I 2 !
L 4 ?
O 0 £
V 3 $
E 2 %
Y 0 ^
O 1 &
U 9 *

So job done in just one real code line, it seems, without any attempt at golfing, just normal relatively concise code.

But what if the arrays don’t have the same size? What if we don’t have 3 arrays but, for example, 2 or 4? What if the array’s items don’t have the same length? Of course, in any of these situations, our code may very well break.

Items With Different Sizes

Let’s start with items not having the same size. If we assume that the items all have less than seven characters, we can just use tabulations instead of spaces:

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

my @a1 = qw /I L OOO V E Y O U/;
my @a2 = qw /244 42 0 1233 222 0 11 90/;
my @a3 = qw /! ???? £ $ %% ^ & */;

say "$a1[$_]\t$a2[$_]\t$a3[$_]" for 0..$#a1;

Running the script displays this:

$ perl mult_arrays.pl
I       244     !
L       42      ????
OOO     0       £
V       1233    $
E       222     %%
Y       0       ^
O       11      &
U       90      *

If any item can have a size greater than or equal to 7, then using tabulations is not sufficient. In this case, we can use formatted printing (with printf or sprintf). This is a boring exercise, and therefore best left as an exercise to the reader. (Just kidding, of course. If you want this feature and don’t know how to do it, please refer to the end of the Raku section below, where an example on how to do it is provided.)

Varying Number of Sublists

For going further, we probably want to change our data structure. Rather than having three hard-coded arrays, we will use an array of arrays (AoA), where the number of sub-arrays can be anything.

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

my @a = ( [ qw /I L O V E Y O U/ ], 
          [ qw /244 42 0 1233 222 0 11 90/ ],
          [ qw /! ???? £ $ %% ^ & */ ],
          [ qw /a b c d e f g f/ ] 
        );

my $sub_array_size = scalar @{$a[0]};
for my $i (0..$sub_array_size -1) {
    for (0..$#a) {
        print "$a[$_][$i]\t";
    }
    say "";
}

This works:

$ perl mult_arrays.pl
I       244     !       a
L       42      ????    b
O       0       £       c
V       1233    $       d
E       222     %%      e
Y       0       ^       f
O       11      &       g
U       90      *       f

but this starts to be somewhat unwieldy.

Matrix Transposition

At this point, we may want to transpose lines and columns of the @a array, store the transposed version into a @b array, and then simply print line by line the sub-arrays of @b:

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

my @a = ( [ qw /I L O V E Y O U/ ], 
          [ qw /244 42 0 1233 222 0 11 90/ ],
          [ qw /! ???? £ $ %% ^ & */ ],
          [ qw /a b c d e f g f/ ] 
        );
my @b;
my $sub_array_size = scalar @{$a[0]};
for my $i (0..$sub_array_size -1) {
    push @b, [ map { $a[$_][$i]} 0 .. @a - 1];
}
say join "\t", @$_ for @b;

This displays the same as before:

$ perl  mult_arrays.pl
I       244     !       a
L       42      ????    b
O       0       £       c
V       1233    $       d
E       222     %%      e
Y       0       ^       f
O       11      &       g
U       90      *       f

Sublists of Different Sizes

This line-column transposition makes the program only moderately simpler, but it will make the next (and last) step easier. The next step is to handle the case where the sub-arrays don’t have the same number of elements. To handle this case, we first need to loop over the input array to find out the size of largest sub-array (the last one in the example below) and change the range of the main for loop header accordingly. The only additional change required is to handle empty slots in the last code line that prints out the result:

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

my @a = ( [ qw /I L O V E Y O U / ], 
          [ qw /244 42 0 1233 222 0 / ],
          [ qw /! ???? £ $ %% ^ / ],
          [ qw /a b c d e f g h i j k/ ] 
        );
my $max_size = 0;
for (@a) {
    $max_size = scalar @$_ if @$_ > $max_size;
}
my @b;
for my $i (0..$max_size - 1) {
    push @b, [ map { $a[$_][$i]} 0 .. @a - 1];
}
say join "\t", map {$_ // "" } @$_ for @b;

Our final version displays the following output:

$ perl  mult_arrays.pl
I       244     !       a
L       42      ????    b
O       0       £       c
V       1233    $       d
E       222     %%      e
Y       0       ^       f
O                       g
U                       h
                        i
                        j
                        k

Multiple Arrays Content in Raku (formerly known as Perl 6)

We don’t need to try to solve the problem step by step in the Raku programming language, as the Z Zip operator, used together with the [] reduction metaoperator to act on several sub-arrays, gives us a very easy way to transpose lines and columns of a 2-D array:

use v6;

my @a = < I L O V E Y O U >, 
        < 244 42 0 1233 222 0 11 90 >,
        < ! ???? £ $ %% ^ & * >,
        < a b c d e f g f >;

my @b = [Z] @a;  # performs transposition
say join "\t", map {$_ // "" }, @$_ for @b;

This displays the following output:

$ perl6 mult_arrays.p6
I       244     !       a
L       42      ????    b
O       0       £       c
V       1233    $       d
E       222     %%      e
Y       0       ^       f
O       11      &       g
U       90      *       f

Sublists of Different Sizes

But that doesn’t work if the sub-arrays don’t have the same size, since the Z Zip operator will stop if one of the operands runs out of elements prematurely.

One possibility to solve the problem is to add dummy items (for example empty strings) to the smaller sublists. This means we now need to iterate twice over the input array, once to figure out the longest sublist, and a second time to add the dummy items. For some reason, I wasn’t able to modify the sublists (they appear to be immutable), so I had to create a copy of the @a input array.

use v6;

my @a = < I L O V E Y O U >, 
        < 244 42 0 1233 222 0 11 >,
        < ! ???? £ $ %% ^ & * >,
        < a b c d e f g f i j>;

my $max = max map { .elems }, @a;
my @b = map { (| $_, "" xx $max - .elems).flat }, @a;
my @c = [Z] @b;
say join "\t", map {$_ // "" }, @$_ for @c;

This produces the following output:

$ perl6 mult_arrays.p6
I       244     !       a
L       42      ????    b
O       0       £       c
V       1233    $       d
E       222     %%      e
Y       0       ^       f
O       11      &       g
U               *       f
                        i
                        j

Another way to do it is to use a for loop to copy the array elements one by one. In most programming languages, you would normally need two nested loops, but we can avoid that thanks to Raku’s X Cross operator used over the indices of the array of arrays:

use v6;

my @a = < I L O V E Y O U >, 
        < 244 42 0 1233 222 0 11 >,
        < ! ???? £ $ %% ^ & * >,
        < a b c d e f g f i j>;

my $max = max map { .elems }, @a;
my @b;
for ^$max X ^@a.elems -> ($i, $j) {
    @b[$i][$j] = @a[$j][$i] // "";
}
say join "\t", @$_ for @b;

This produces the same output as the previous implementation immediately above.

Item Lengths Exceeding the Tabulation Size

Now, what if some of the array items have a length exceeding the tabulation size (7 or more character)? Using tabulations is no longer sufficient. We can construct dynamically a formatting string to be used by the sprinf, printf, or fmt built-in functions:

use v6;

my @a = < I L O V E Y O U >, 
        < 244 42 0 123344556677 222 0 11 >,
        < ! ?????? £ $ %% ^ & * >,
        < a b c d e f g f i j>;

my $max = max map { .elems }, @a;
my @max-lengths = map { .map({.chars}).max  }, @a;
my $fmt = [~] map {"%-" ~ @max-lengths[$_] + 2 ~ "s"}, keys @max-lengths;
say "Format: ", $fmt;  # Displaying the resulting formatting string
my @b;
for ^$max X ^@a.elems -> ($i, $j) {
    @b[$i][$j] = @a[$j][$i] // "";
}
printf "$fmt\n", @$_ for @b;

This displays the following output:

$ perl6 mult_arrays.p6
Format: %-3s%-14s%-8s%-3s
I  244           !       a
L  42            ??????  b
O  0             £       c
V  123344556677  $       d
E  222           %%      e
Y  0             ^       f
O  11            &       g
U                *       f
                         i
                         j

Challenge # 2: Sort Sublists

You are given a list of numbers and set of indices belong to the list. Write a script to sort the values belongs to the indices.

For example,

List: [ 10, 4, 1, 8, 12, 3 ]
Indices: 0,2,5

We would sort the values at indices 0, 2 and 5 i.e. 10, 1 and 3.

Final List would look like below:

List: [ 1, 4, 3, 8, 12, 10 ]

Sorting Sublists in Perl 5

This is the perfect example for using array slices, which was the subject of a challenge a few weeks ago. We’ll use slices twice: one to extract from the list the values to be sorted, and once again for inserting the sorted values back into the array at their proper position. And we end up with a single line of code doing all the real work:

#!/usr/bin/perl
use strict;
use warnings;
use feature qw/say/;
use Data::Dumper;

my @numbers = (10, 4, 1, 8, 12, 3);
my @indices = (0, 2, 5);

@numbers[@indices] = sort { $a <=> $b } @numbers[@indices];
say "@numbers";

This is the output displayed by the program:

$ perl  sublists.pl
1 4 3 8 12 10

Sorting Sublists in Raku

As in Perl 5, we can use array slices to make things really simple. The program is even simpler in Raku, since we don’t need the { $a <=> $b } code block used in Perl 5 to obtain numeric sort: Raku’s sort procedure is clever enough to discover that it should perform numeric sort when it sees numbers (well, more accurately, it is the default cmp operator used by sort which is smart enough to compare strings with string semantics and numbers with number semantics).

use v6;

my @numbers = 10, 4, 1, 8, 12, 3;
my @indices = 0, 2, 5;

@numbers[@indices] = sort @numbers[@indices];
say @numbers;

This program displays the following output:

$ perl6 sublists.p6
[1 4 3 8 12 10]

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

Perl Weekly Challenge # 39: Guest House and Reverse Polish Notation

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

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

Task # 1: Guest House

A guest house had a policy that the light remain ON as long as the at least one guest is in the house. There is guest book which tracks all guest in/out time. Write a script to find out how long in minutes the light were ON.

The guest book looks as follows:

1) Alex    IN: 09:10 OUT: 09:45
2) Arnold  IN: 09:15 OUT: 09:33
3) Bob     IN: 09:22 OUT: 09:55
4) Charlie IN: 09:25 OUT: 10:05
5) Steve   IN: 09:33 OUT: 10:01
6) Roger   IN: 09:44 OUT: 10:12
7) David   IN: 09:57 OUT: 10:23
8) Neil    IN: 10:01 OUT: 10:19
9) Chris   IN: 10:10 OUT: 11:00

First, although the input data provided with the task spans over only 2 hours, I’ll make the computation over a full day, from 00:00 to 23:59. One of the reasons for doing so is that I wanted to add a guest staying over more than two hours, in order to test the case where someone is in the guest house for more than two adjacent hours. Also, I did not want the guests to be male only. So, I added one female guest:

10) Liz    IN: 12:07 OUT: 17:05

I can think of several ways to solve this task. I decided to create a hash of arrays covering every minute in the 00:00-23:59 range. It could have been an array of arrays, but I started with 09:00-11:00 range provided in the task, and that led to an array with empty slots, which I did not like too much because this is likely to generate warnings or require some special care to avoid such warnings (or runtime errors). The program then parses the input data and sets each minute in the presence ranges with 1. Populating the whole range with zeros before starting isn’t strictly necessary, but it makes other things easier, as it is possible at the end to just add values without having to first check for definedness.

We don’t care about the guests’ names, so when reading the input data, we only look at the time intervals.

Note that there is a slight ambiguity in the task description. If one guest arrives at 10:10 and leaves at 10:11, I consider that the light has to be on for 2 minutes, even though it may be argued that, by a simple subtraction, the guest staid only 1 minute.

Guest House in Perl 5

In Perl 5, we just put the input data in the DATAsection.

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

my %hm;
for my $hour (0..23) {
    $hm{$hour}[$_] = 0 for 0..59;
}
while (<DATA>) {
    next unless /\S/;
    my ($in_h, $in_m, $out_h, $out_m) = /(\d\d):(\d\d)\D+(\d\d):(\d\d)/;
    if ($out_h eq $in_h) {
        $hm{0+$in_h}[$_] = 1 for $in_m..$out_m;
    } else {
        $hm{0+$in_h}[$_]  = 1 for $in_m..59; # end the first hour
        for my $hour ($in_h + 1 .. $out_h -1) {
            $hm{$hour}[$_] = 1 for 0..59;    # If several hours
        }
        $hm{0+$out_h}[$_] = 1 for 0..$out_m; # Complete last hour
    }
}
my $total_on = 0;
for my $hour (keys %hm) {
        $total_on += $hm{$hour}[$_] for 0..59;
}
say "Total time on: $total_on minutes.";

__DATA__
1) Alex    IN: 09:10 OUT: 09:45
2) Arnold  IN: 09:15 OUT: 09:33
3) Bob     IN: 09:22 OUT: 09:55
4) Charlie IN: 09:25 OUT: 10:05
5) Steve   IN: 09:33 OUT: 10:01
6) Roger   IN: 09:44 OUT: 10:12
7) David   IN: 09:57 OUT: 10:23
8) Neil    IN: 10:01 OUT: 10:19
9) Chris   IN: 10:10 OUT: 11:00
10) Liz    IN: 12:07 OUT: 17:05

With the original input data set, the result was 111 seconds. With my modified data set, I obtain the following output:

$ perl  guesthouse.pl
Total time on: 410 minutes.

Guest House in Raku (formerly known as Perl 6)

There is no DATA section in Raku. Raku should have much more feature-rich capabilities using pod (plain old documentation) sections, but these are not implemented yet. We could use the heredocs feature, but since TIMTOWTDI, we will simply use a multi-line string variable within standard double quote marks.

use v6;

my $input = 
   "1) Alex    IN: 09:10 OUT: 09:45
    2) Arnold  IN: 09:15 OUT: 09:33
    3) Bob     IN: 09:22 OUT: 09:55
    4) Charlie IN: 09:25 OUT: 10:05
    5) Steve   IN: 09:33 OUT: 10:01
    6) Roger   IN: 09:44 OUT: 10:12
    7) David   IN: 09:57 OUT: 10:23
    8) Neil    IN: 10:01 OUT: 10:19
    9) Chris   IN: 10:10 OUT: 11:00
    10) Liz    IN: 12:07 OUT: 17:05";

my %hm;
for 0..23 -> $hour {
    %hm{$hour}[$_] = 0 for 0..59;
}
for $input.lines {
    next unless /\S/;
    my ($in_h, $in_m, $out_h, $out_m) = map { +$_}, $/[0..3] if /(\d\d)':'(\d\d)\D+(\d\d)':'(\d\d)/;
    if ($out_h == $in_h) {
        %hm{$in_h}[$_] = 1 for $in_m..$out_m;
    } else {
        %hm{$in_h}[$_]  = 1 for $in_m..59; # end the first hour
        for $in_h + 1 .. $out_h -1 -> $hour {
            %hm{$hour}[$_] = 1 for 0..59; # If several hours
        }
        %hm{$out_h}[$_] = 1 for 0..$out_m; # Complete last hour
    }
}

my $total_on = 0;
for keys %hm -> $hour {
    $total_on += sum %hm{$hour};
}
say "Total time on: $total_on minutes.";

This program produces the same result as the P5 program:

$ perl6 guesthouse.p6
Total time on: 410 minutes.

Task # 2: Reverse Polish Notation

Write a script to demonstrate Reverse Polish notation (RPN). Checkout the wiki page for more information about RPN.

This task reminds me of the Hewlett-Packard pocket calculators during my teen years in the 1970’s. To tell the truth, I had bought at the time a Texas Instruments programmable calculator using standard infix notation, but a friend of mine has a much more powerful HP hand-held calculator. The most important difference was that my friend’s HP calculator could save programs for later use, while my more basic (and much cheaper) TI calculator would lose everything when switched off. So we worked quite a bit on his calculator for studying assignments and, although I never became as fluent as my friend with RPN, I understood quite well at the time how to use it.

Anyway, the point about RPN, which is also known as postfix notation, is that you first state the operands and then only the operators. If it is a binary operator (the most common case), you just pick up the last two previous operands. For example, to add numbers 7 and 11, instead of typing something like 7 + 11, you would type 7, 11 +. RPN is a bit counter-intuitive at first, but it is quite efficient because it avoids using parentheses for specifying operation precedence. As a result, RPN supposedly requires less typing than usual infix notation. The following Wikipedia example shows the difference. The following inxix notation expression:

((15 ÷ (7 − (1 + 1))) × 3) − (2 + (1 + 1))

can be written as follows in RPN:

15 7 1 1 + − ÷ 3 × 2 1 1 + + − =

The essential idea for processing RPN notation is a stack (a last-in first-out data or LIFO structure): when you read an operand, you just push it onto a stack. And when you read a binary operator, you just pop two values from the stack, apply the operator to them and push the result back onto the stack. We need to be cautious about something for operators which are not commutative such as subtraction or division: the first operand that we pop from the stack has to be the second operand in the operation, and the second popped operand will be the the first one in the operation.

The code for the operations is stored in a dispatch table, i.e. a hash where the keys are the operators and the values are code references to short subroutines performing the arithmetic operations. Note that I encountered unexpected difficulties because some of the RPN expressions that I copied from the Wikipedia page contain special Unicode characters for subtraction, multiplication and division. This was especially tricky for the subtraction operator, since the common ASCII dash or hyphen and the Unicode minus sign really look similar. To fix this, I only needed to add entries with those special characters in the dispatch table (and the use utf8; pragma).

Reverse Polish Notation in Perl 5

I have included five test cases using the Test::More module. For a real life program, we would probably want more tests

#!/usr/bin/perl
use strict;
use warnings;
use utf8;
use Test::More tests => 5;

my %operations = (
    '+' => sub { return $_[0] + $_[1]; },
    '-' => sub { return $_[0] - $_[1]; }, # hyphen
    '−' => sub { return $_[0] - $_[1]; }, # minus
    'x' => sub { return $_[0] * $_[1]; },
    '*' => sub { return $_[0] * $_[1]; },
    '×' => sub { return $_[0] * $_[1]; },
    '/' => sub { return $_[0] / $_[1]; },
    '÷' => sub { return $_[0] / $_[1]; },
);

sub parse_operation {
    my @stack;
    for my $token (split /\s+/, shift) {
        if ($token =~ /^\d+$/) {
            push @stack, $token ;
        } elsif (exists $operations{$token}) {
            return "Invalid RPN expression" if @stack < 2;
            my $op2 = pop @stack;
            my $op1 = pop @stack;
            push @stack, $operations{$token}->($op1, $op2);
        } else {
            die "Invalid token $token.";
        }
    }
    return $stack[0]
}
is parse_operation("1 2 +"), 3, "2 operands";
is parse_operation("1 2 + 4 ×"), 12, "3 operands, a Unicode multiplication operator";
is parse_operation("1 2 + 4 * 5 + 3 -"), 14, "5 operands";
is parse_operation("3 4 5 x -"), -17, "Start with 3 operands and then two operators";
is parse_operation("15 7 1 1 + − ÷ 3 × 2 1 1 + + −"), 5, "8 operands, 4 Unicode operators";

Running the program shows that all tests pass correctly:

$ perl rpn.pl
1..5
ok 1 - 2 operands
ok 2 - 3 operands, unicode multiplication operator
ok 3 - 5 operands
ok 4 - Start with 3 operands and then two operators
ok 5 - 8 operands, 4 Unicode operators

Note that this program does only minimal RPN validity check (only that we get valid tokens and that the stack has at least two values when we want to process an operator). Otherwise, we basically assume the RPN expression is correct. In a real-life program, more validity checks would probably be necessary (for example that the stack has only one value left at the end of the parsing).

Reverse Polish Notation in Raku

Although I have been thinking of various ways of doing it in Raku, notably using a grammar, I think the simplest is to use a stack as in Perl 5. Only a few minor changes are required to have a working Raku program:

use v6;
use Test;

my %operations = (
    '+' => { $^a + $^b; },
    '-' => { $^a - $^b; }, # hyphen
    '−' => { $^a - $^b; }, # dash
    'x' => { $^a * $^b; },
    '*' => { $^a * $^b; },
    '×' => { $^a * $^b; },
    '/' => { $^a / $^b; },
    '÷' => { $^a / $^b; },
);

sub parse_operation (Str $expr) {
    my @stack;
    for $expr.split(/\s+/) -> $token {
        if $token ~~ /^ \d+ $/ {
            push @stack, $token ;
        } elsif (%operations{$token}:exists) {
            return "Invalid RPN expression" if @stack.elems < 2;
            my $op2 = pop @stack;
            my $op1 = pop @stack;
            push @stack, %operations{$token}($op1, $op2);
        } else {
            die "Invalid token $token.";
        }
    }
    return @stack[0]
}
plan 5;
is parse_operation("1 2 +"), 3, "2 operands";
is parse_operation("1 2 + 4 ×"), 12, "3 operands, a Unicode multiplication operator";
is parse_operation("1 2 + 4 * 5 + 3 -"), 14, "5 operands";
is parse_operation("3 4 5 x -"), -17, "Start with 3 operands and then two operators";
is parse_operation("15 7 1 1 + − ÷ 3 × 2 1 1 + + −"), 5, "8 operands, 4 Unicode operators";

Running this program produces the same output as the P5 program:

$ perl6 rpn.p6
1..5
ok 1 - 2 operands
ok 2 - 3 operands, a Unicode multiplication operator
ok 3 - 5 operands
ok 4 - Start with 3 operands and then two operators
ok 5 - 8 operands, 4 Unicode operators

Using the when “switch” statement provided by Raku, we can get rid of the dispatch table and make our code slightly more concise as follows:

use v6;
use Test;

sub perform-op (&op) {
    push @*stack, @*stack.pop R[&op] @*stack.pop;
}
sub parse_operation (Str $expr) {
    my @*stack;
    for $expr.split(/\s+/) {
        when /^ \d+ $/       { @*stack.push($_)}
        when '+'             { perform-op &[+] }
        when '*' | 'x' | '×' { perform-op &[*] }
        when '/' | '÷'       { perform-op &[/] }
        when '-' | '−'       { perform-op &[-] }
        default { die "Invalid token $_."; }
    }
    return @*stack[0]
}
plan 5;
is parse_operation("1 2 +"), 3, "2 operands";
is parse_operation("1 2 + 4 ×"), 12, "3 operands, a Unicode multiplication operator";
is parse_operation("1 2 + 4 * 5 + 3 -"), 14, "5 operands";
is parse_operation("3 4 5 x -"), -17, "Start with 3 operands and then two operators";
is parse_operation("15 7 1 1 + − ÷ 3 × 2 1 1 + + −"), 5, "8 operands, 4 Unicode operators";

This passes all the tests correctly 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 23:59 BST (British summer time) on Sunday, December 29. And, please, also spread the word about the Perl Weekly Challenge if you can.

Perl Weekly Challenge 38: Date Finder and Word Game

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

Challenge # 1: Date Finder

Create a script to accept a 7 digits number, where the first number can only be 1 or 2. The second and third digits can be anything 0-9. The fourth and fifth digits corresponds to the month i.e. 01,02,03…,11,12. And the last 2 digits represents the days in the month i.e. 01,02,03….29,30,31. Your script should validate if the given number is valid as per the rule and then convert into human readable format date.

Rules:

1) If 1st digit is 1, then prepend 20 otherwise 19 to the 2nd and 3rd digits to make it 4-digits year.

2) The 4th and 5th digits together should be a valid month.

3) The 6th and 7th digits together should be a valid day for the above month.

For example, the given number is 2230120, it should print 1923-01-20.

Task 1: Date Finder in Perl 5

This time, rather than concentrating on a test suite, I decided to focus on trying to provide useful warnings and error messages when the input value is not valid, which led me to test the input data piece by piece:

#!/usr/bin/perl
use strict;
use warnings;
use feature qw/say/;
use Time::Local;

my $in = shift // '2230120';
die "Input should be seven digits\n" unless $in =~ /^\d{7}$/;

my ($y1, $y2, $m, $d) = $in =~ /^(\d)(\d\d)(\d\d)(\d\d)/;
die "First digit should be 1 or 2\n" if $y1 !~ /[12]/;
my $year = $y1 == 1 ? "20$y2" : "19$y2";
die "Digits 4 and 5 should be a valid month number\n" unless $m =~ /(0\d)|(1[012])/;
die "Digits 6 and 7 should be a valid day in month\n" unless $d =~ /([012]\d)|(3[01])/;
my $test = eval { timelocal 0, 0, 0, $d, $m-1, $year - 1900 };
warn $@ if $@;
die "$in is equivalent to $year-$m-$d, which is an invalid date\n" unless defined $test;
say "$in is equivalent to $year-$m-$d.";

Note that, in the final section, I’m using the Time::Local module to validate a date. I have shown previously (see for example my blog post on the week day task of PWC # 37) how to figure out the number of days in any month of any year, taking into account leap years, without the help of any module.

These are a few examples of tests with various input data:

$ perl date_finder.pl 223022
Input should be seven digits

$ perl date_finder.pl
2230120 is equivalent to 1923-01-20.

$ perl date_finder.pl 2230120
2230120 is equivalent to 1923-01-20.

$ perl date_finder.pl 2230431
Day '31' out of range 1..30 at date_finder.pl line 15.
2230431 is equivalent to 1923-04-31, which is an invalid date

$ perl date_finder.pl 2230229
Day '29' out of range 1..28 at date_finder.pl line 15.
2230229 is equivalent to 1923-02-29, which is an invalid date

$ perl date_finder.pl 1960229
1960229 is equivalent to 2096-02-29.

When something goes wrong with the date, we have two messages (a warning and an error). Of course, we don’t need both, one would be sufficient, but this illustrates two different ways of reporting an invalid date.

Task 1: Date Finder in Raku (formerly known as Perl 6)

Let’s start with a simple port of the P5 program to Raku:

use v6;

sub MAIN ($in where * ~~ /^\d ** 7$/ = '2230120') {
    my ($y1, $y2, $m, $d) = ($in ~~ /^(\d)(\d\d)(\d\d)(\d\d)/)[0..3];
    die "First digit should be 1 or 2\n" if $y1 !~~ /<[12]>/;
    my $year = $y1 == 1 ?? "20$y2" !! "19$y2";
    die "Digits 4 and 5 should be a valid month number\n" unless $m ~~ /(0\d) | (1<[012]>)/;
    die "Digits 6 and 7 should be a valid day in month\n" unless $d ~~ /(<[012]>\d) | (3<[01]>)/;

    try { 
        my $test = Date.new($year, $m, $d);
    }
    die "$in is equivalent to $year-$m-$d, which is an invalid date\n" if $!;
    say "$in is equivalent to $year-$m-$d.";
}

Besides the minor syntax changes between the two languages, the only significant change is that the program attempts to create a Date object within a try block. This program produces essentially the same output as the P5 program.

Another way to do it would be to use a grammar, for example:

use v6;

grammar My-custom-date {
    token TOP { <y1> <y2> <m> <d> }
    token y1  { <[12]> }
    token y2  { \d ** 2}
    token m   { 0\d | 1<[012]> }
    token d   { <[012]> \d | 3<[01]> } 
}

sub MAIN ($in where * ~~ /^\d ** 7$/ = '2230120') {
    my $matched  = so My-custom-date.parse($in);
    say "Invalid input value $in" and exit unless $matched;
    my $year = $<y1> == 1 ?? "20$<y2>" !! "19$<y2>";
    try { 
        my $test = Date.new($year, $<m>, $<d>);
    }
    say "ERROR: $in is equivalent to $year-$<m>-$<d>, which is an invalid date\n" and exit if $!;
    say "$in is equivalent to $year-$<m>-$<d>.";
}

But, in this case, the advantage of using a grammar is not obvious, except for the fact the parsing is possibly slightly clearer. It might even be argued that using a grammar for such a simple case is sort of a technological overkill.

These are some sample runs:

$ perl6 date_finder.p6
2230120 is equivalent to 1923-01-20.

$ perl6 date_finder.p6 2230228
2230228 is equivalent to 1923-02-28.

$ perl6 date_finder.p6 2230229
Use of Nil in string context
ERROR: 2230229 is equivalent to 1923--, which is an invalid date

  in block  at date_finder.p6 line 17
Use of Nil in string context
  in block  at date_finder.p6 line 17

Task2: Word Game

Lets assume we have tiles as listed below, with an alphabet (A..Z) printed on them. Each tile has a value, e.g. A (1 point), B (4 points) etc. You are allowed to draw 7 tiles from the lot randomly. Then try to form a word using the 7 tiles with maximum points altogether. You don’t have to use all the 7 tiles to make a word. You should try to use as many tiles as possible to get the maximum points.

For example, A (x8) means there are 8 tiles with letter A.

1 point

    A (x8), G (x3), I (x5), S (x7), U (x5), X (x2), Z (x5)

2 points

    E (x9), J (x3), L (x3), R (x3), V (x3), Y (x5)

3 points

    F (x3), D (x3), P (x5), W (x5)

4 points

    B (x5), N (x4)

5 points

    T (x5), O (x3), H (x3), M (x4), C (x4)

10 points

    K (x2), Q (x2)

So, the game is essentially similar to Scrabble, except that there is no game board.

I don’t see any way to solve correctly this task without a brute-force approach, i.e. trying all possibilities to find the best score.

Just as for some previous challenges, I will use a words.txt file containing 113,809 lower-case English words usually accepted for crossword puzzles and other word games. The words.txt file can be found on my Github repository. The original list was contributed to the public domain by Internet activist Grady Ward in the context of the Moby Project. This word list is also mirrored at Project Gutenberg.

For the purpose of testing the programs below, the words.txt file is located in my current directory. Obviously, when we will be reading the list, we will need to keep only the words having the same length as the two input words. The word.txt input file only contains words with only lowercase alphabetical ASCII characters.

Word Game in Raku

Given that I had a very busy week and weekend for various personal reasons, it is now late on Sunday, and I’m not sure I’ll be able do solve this Scrabble-like in both Perl 5 and Raku in time for the deadline. So I decided to start with Raku, which has some functionalities that are useful for this task and not existing in Perl 5.

The solution is essentially as follows: read the file of authorized words, normalize the words by putting their letters in alphabetical order and store in a %word-list hash the normalized versions as a key, and the original word as a value.

Store the available letter tiles in a Bag. Then pick seven tiles (or any other number) from the bag, use the combinations method to produce all time combinations from the drawn letters, sort each combination alphabetically and look up for the result in the hash. If the result is found, compute its score and retain the word with the highest score so far. At the end, print the word with the highest score.

use v6;

constant %tile-values =  
    A => 1, B => 4, C => 5, D => 3, E => 2, 
    F => 3, G => 1, H => 5, I => 1, J => 2, 
    K => 10, L => 2, M => 5, N => 4, O => 5, 
    P => 3, Q => 10, R => 2, S => 1, T => 5, 
    U => 1, V => 2, W => 3, X => 1, Y => 2, Z => 1;

constant %tile-count =
    A => 8, B => 5, C => 4, D => 3, E => 9, 
    F => 3, G => 3, H => 3, I => 5, J => 3, 
    K => 2, L => 3, M => 4, N => 4, O => 3, 
    P => 5, Q => 2, R => 3, S => 7, T => 5, 
    U => 5, V => 3, W => 5, X => 2, Y => 5, Z => 5;

my $tile-bag = (map {$_ xx %tile-count{$_}}, keys %tile-count).Bag;

sub MAIN (Int $count = 7) {
    my %word-list;
    for "words.txt".IO.lines -> $line {
        next if $line.chars > $count;
        my $ordered = $line.uc.comb.sort.join("");
        my $line-value = [+] $ordered.comb.map({%tile-values{$_}});
        %word-list{$ordered}<word> = $line;
        # Note we will keep only one word for anagrams, but 
        # that's OK since anagrams have the same value
        %word-list{$ordered}<value> = $line-value;
    }
    for 1..10 {
        my @picked-tiles = $tile-bag.pick($count);
        my $max-combination = "";
        my $max-value = 0;
        for @picked-tiles.combinations -> $candidate {
            my $ordered = $candidate.sort.join("");
            next unless %word-list{$ordered}:exists;
            if %word-list{$ordered}<value> > $max-value {
                $max-value = %word-list{$ordered}<value>;
                $max-combination = $ordered;
            }
        }
        say "The best candidate for list ", @picked-tiles.join(""), " is:"; 
        say "    No word found!" and next unless $max-value;
        say "    %word-list{$max-combination}<word> (score: $max-value)";
    }
}

Note that the program is not very fast (2 to 3 seconds for 7 tiles), but that’s mainly due to time required to read the 113k-word list and store the words into a hash. Once the hash is populated, finding the best solution is quite fast. This is the reason for which I decided to run the solution-finding part ten times once the hash is populated. If I were going to make a real-life solution for the challenge, I would store the hash in a file, as I have shown previously, notably on the word ladder challenge in May of this year.

This is an example run:

$ time perl6  scrabble.p6 7
The best candidate for list MESWAAG is:
    wames (score: 12)
The best candidate for list XPSPBAG is:
    paps (score: 8)
The best candidate for list KISCPAC is:
    spick (score: 20)
The best candidate for list BMRPSPU is:
    bumps (score: 14)
The best candidate for list LZRYVBY is:
    byrl (score: 10)
The best candidate for list KHEBLZP is:
    kelp (score: 17)
The best candidate for list FHIOUHI is:
    foh (score: 13)
The best candidate for list VXAWSJH is:
    wash (score: 10)
The best candidate for list LIXMPGZ is:
    limp (score: 11)
The best candidate for list AJSFBOF is:
    boffs (score: 16)

real    0m2,751s
user    0m0,000s
sys     0m0,031s

I know that some words found above may seem funny or uncommon, but they belong to the words.txt file that is one of the official source of words for word games.

I’m sorry, I just don’t have enough time right now to finish the Perl 5 version of this task for the deadline (although I’ve almost completed it).

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