Perl Weekly Challenge 71: Peak Elements and Trim Linked List

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

Task 1: Peak Elements

You are given positive integer $N (>1).

Write a script to create an array of size $N with random unique elements between 1 and 50.

In the end it should print peak elements in the array, if found.

An array element is called peak if it is bigger than it’s neighbour.

Example 1:

Array: [ 18, 45, 38, 25, 10, 7, 21, 6, 28, 48 ]
Peak: [ 48, 45, 21 ]

Example 2:

Array: [ 47, 11, 32, 8, 1, 9, 39, 14, 36, 23 ]
Peak: [ 47, 32, 39, 36 ]

The specification somewhat lacks precision, but the examples are clear enough to clarify.

Peak Elements in Raku

In Raku, the pick built-in method provides (pseudo-)random unique elements from a list or a range. It is then just a matter of comparing each item with its predecessor and its successor, and to add the first item of the list if it is larger than the second one, and the last item if it is larger than the one before the last.

use v6;

sub MAIN (Int $n where 1 < * <= 50) {
    my @nums = (1..50).pick: $n;
    say @nums;
    my @peaks = gather {
        for 1..^@nums.end -> $i {
            take @nums[$i] if @nums[$i-1] < @nums[$i] > @nums[$i+1];
        }
    }
    unshift @peaks, @nums[0] if @nums[1] < @nums[0];
    push @peaks, @nums[@nums.end] 
        if @nums[@nums.end] > @nums[@nums.end -1];
    say @peaks;
}

These are a few sample runs of this program:

$ raku peak.raku 10
[33 35 4 20 2 16 7 31 23 46]
[35 20 16 31 46]
-
$ raku peak.raku 10
[32 34 30 48 14 50 17 12 26 5]
[34 48 50 26]
-
$ raku peak.raku 10
[15 4 31 49 16 14 23 5 26 17]
[15 49 23 26]
-
$ raku peak.raku 10
[4 40 28 46 43 33 49 1 15 18]
[40 46 49 18]
-
$ raku peak.raku 40
[19 12 30 46 27 15 14 41 43 3 17 32 48 10 18 24 26 37 33 28 35 40 22 9 23 39 29 8 47 1 2 49 34 42 44 16 4 38 21 31]
[19 46 43 48 37 40 39 47 49 44 38 31]
-
$ raku peak.raku 40
[40 10 7 32 44 5 4 29 16 49 30 28 38 35 46 45 11 6 47 8 26 18 34 13 23 19 50 12 43 37 25 17 33 31 42 36 9 15 39 2]
[40 44 29 49 38 46 47 26 34 23 50 43 33 42 39]
-
$ raku peak.raku 45
[47 8 31 46 35 19 17 23 43 41 7 6 24 45 34 3 32 2 22 18 29 26 42 40 49 48 13 11 44 30 12 4 9 20 21 10 15 36 50 14 39 33 1 5 27]
[47 46 43 45 32 22 29 42 49 44 21 50 39 27]

Peak Elements in Perl

Perl doesn’t have a built-in pick function to provide random unique elements from a list or a range. The Perl rand function returns a (pseudo)-random fractional number greater than or equal to 0 and less than the value of the parameter passed to it. So, to get a random integer between 1 and 50, we need something like this:

my $element = int(rand(50) + 1);

To ensure that the random numbers are unique, we use the %unique hash which enables us to remove any duplicate from the list.

The rest of the program is essentially a port to Perl of the Raku program: we loop through the list of random integers and keep those which are larger than their predecessors and successors, and we add the first item of the list if it is larger than the second one, and the last item if it is larger than its predecessor.

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

my $n = shift;
my %unique;
my @items;
while (%unique < $n) {
    my $element = int(rand(50) + 1);
    push @items, $element unless exists $unique{$element};
    $unique{$element} = 1
}

say "Original list: @items";
my @peaks;
push @peaks, $items[0] if $items[0] > $items[1];
for my $i (1..$#items - 1) {
    push @peaks, $items[$i] if $items[$i] > $items[$i-1] 
        and $items[$i] > $items[$i+1];
}
push @peaks, $items[-1] if $items[-1] > $items[-2];
say "Peaks: @peaks";

This is the output of a few sample runs:

$ perl peak.pl 10
Original list: 14 11 23 37 17 20 40 47 29 7
Peaks: 14 37 47

$ perl peak.pl 10
Original list: 43 48 28 35 8 36 11 39 4 29
Peaks: 48 35 36 39 29

$ perl peak.pl 20
Original list: 20 4 30 25 1 2 41 39 24 17 3 44 29 49 8 34 13 28 12 38
Peaks: 20 30 41 44 49 34 28 38

$ perl peak.pl 3
Original list: 10 23 12
Peaks: 23

$ perl peak.pl 49
Original list: 13 32 24 40 28 34 39 15 43 29 42 5 6 46 9 27 12 3 33 30 2 23 11 48 17 20 10 8 50 4 45 36 26 37 1 41 21 35 31 18 16 49 44 19 14 7 47 25 38
Peaks: 32 40 39 43 42 46 27 33 23 48 20 50 45 37 41 35 49 47 38

Task 2: Trim Linked List

You are given a singly linked list and a positive integer $N (>0).

Write a script to remove the $Nth node from the end of the linked list and print the linked list.

If $N is greater than the size of the linked list then remove the first node of the list.

NOTE: Please use pure linked list implementation.

Example:

Given Linked List: 1 -> 2 -> 3 -> 4 -> 5
when $N = 1
Output: 1 -> 2 -> 3 -> 4
when $N = 2
Output: 1 -> 2 -> 3 -> 5
when $N = 3
Output: 1 -> 2 -> 4 -> 5
when $N = 4
Output: 1 -> 3 -> 4 -> 5
when $N = 5
Output: 2 -> 3 -> 4 -> 5
when $N = 6
Output: 2 -> 3 -> 4 -> 5

I don’t know why Mohammad keeps suggesting challenges with linked lists, which are essentially useless both in Perl and in Raku: both languages have dynamic arrays which offer essentially all the services offered by linked lists in lower-level languages such as C. In fact, except possibly for pedagogical purpose, I strongly object to the very idea of implementing linked lists in Perl or in Raku.

So, I’ll implement a pure linked list implementation in Raku, since this is part of the specification, using an object oriented design, but I’ll willfully cheat and use built-in arrays for the details, because this is my view the right way to remove an item from a collection.

My program implements a Node class defining a simple node structure (with a value and a link to the next node), and a Linkedlist class holding the head of the linked list and defining a make-array method to transform the linked list into an array. There is also a gist method to provide a string representation of the linked list (the overloaded gist method is used by the say routine). The code also has a build-linked-list subroutine to transform an array into a linked list. The idea of the program is to transform a linked list into an array, to remove the desired item from the array, and to convert the array back into a new linked list.

use v6;

class Node {
    has $.value is rw;
    has $.next is rw;
}
class Linkedlist {
    has Node $.head;
    method make-array () {
        my $node = $.head;
        my @array = $node.value;
        while $node.next:defined {
            $node = $node.next;
            push @array, $node.value;
        }
    return @array;
    }
  method gist () {
        my @a = | $.make-array;
        return join ' -> ', @a;
    }
}
sub build-linked-list (@values is copy) {
    my $last = @values[*-1];
    my @nodes;
    my $tail = Node.new( value => $last, next => Nil);
    @nodes[$last] = $tail;
    for @values[1..@values.end].keys.reverse -> $i {
        my $node = Node.new( value => @values[$i], 
            next => @nodes[@values[$i+1]]);
        @nodes[@values[$i]] = $node;
    }
    return Linkedlist.new( head => @nodes[@values[0]]);
}

sub MAIN (Int $n) {
    my @start_range = 1..5;
    my $linked_list = build-linked-list @start_range;
    say "Original list: ", $linked_list;
    my @a = $linked_list.make-array;
    my @new_range = @start_range;
    if $n >= @a.elems {
        shift @new_range;
    } else {
        @new_range[@new_range.end - $n +1]:delete;
    }
    @new_range = grep {.defined }, @new_range;
    my $next_linked_list = build-linked-list @new_range;
    say "New linked list: ", $next_linked_list;
}

This is the output for a few test cases:

$ raku linked_list.raku 7
Original list: 1 -> 2 -> 3 -> 4 -> 5
New linked list: 2 -> 3 -> 4 -> 5

$ raku linked_list.raku 3
Original list: 1 -> 2 -> 3 -> 4 -> 5
New linked list: 1 -> 2 -> 4 -> 5

$ raku linked_list.raku 1
Original list: 1 -> 2 -> 3 -> 4 -> 5
New linked list: 1 -> 2 -> 3 -> 4

$ raku linked_list.raku 2
Original list: 1 -> 2 -> 3 -> 4 -> 5
New linked list: 1 -> 2 -> 3 -> 5

$ raku linked_list.raku 5
Original list: 1 -> 2 -> 3 -> 4 -> 5
New linked list: 2 -> 3 -> 4 -> 5

As said earlier, I don’t think it is right to implement linked lists in Raku or Perl. I nonetheless did it in Raku to show my good will. But I still think this is a deadly wrong idea. Therefore, I will decline to answer the task in Perl (I have shown in earlier challenges that I know how to do it if needed, it is really the fact that I object to it that leads me to that decision).

Wrapping up

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

Perl Weekly Challenge 70: Character Swapping and Gray Code Sequence

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

Task 1: Character Swapping

You are given a string $S of size $N.

You are also given swap count $C and offset $O such that $C >= 1, $O >= 1, $C <= $O and $C + $O <= $N.

Write a script to perform character swapping like below:

$S[ 1 % $N ] <=> $S[ (1 + $O) % $N ]
$S[ 2 % $N ] <=> $S[ (2 + $O) % $N ]
$S[ 3 % $N ] <=> $S[ (3 + $O) % $N ]
...
...
$S[ $C % $N ] <=> $S[ ($C + $O) % $N ]

Example 1:

Input:
    $S = 'perlandraku'
    $C = 3
    $O = 4

Character Swapping:
    swap 1: e <=> n = pnrlaedraku
    swap 2: r <=> d = pndlaerraku
    swap 3: l <=> r = pndraerlaku

Output:
    pndraerlaku

Character Swapping in Raku

To access the individual characters of a string, Raku offers two basic mechanisms: the substr function, or the ability to split a string into an array of individual characters, using the split or comb built-in routines.

However, since this task is fairly easy, I thought there would be more fun to create a postcircumfix [ ] operator for indexing strings with subscripts the way it is done, for example, in C or in Python. We even built this multi operator also for slices, used with ranges, although it is not used in this program. Note that the way it is defined, it is not possible to use it on the left-hand side of an assignment (in other words you can read the character at a given position in a string, but you cannot modify a character in the string).

use v6;
subset Non0 of Int where * > 0;

# For fun, indexing strings with subscripts
multi sub postcircumfix:<[ ]> (Str $s, Int $n) {
    substr-rw $s, $n, 1;
}
# Not used here, but more fun
multi sub postcircumfix:<[ ]> (Str $s, Range $r) {
    substr-rw $s, $r;
}

sub MAIN ($s is copy, Non0 $c = 3, Non0 $o = 4) {
    my $n = $s.chars;
    die "Invalid values" if $c + $o > $n;
    for 1..$c -> $i {
        my $tmp = $s[$i % $n];
        substr-rw($s, $i % $n, 1) = $s[($i + $o) % $n];
        substr-rw($s, ($i + $o) % $n, 1) = $tmp;
    }
    say $s
}

Running it using the default values displays the following output:

$ raku char-swap.raku PerlAndRaku
PndRAerlaku

Character Swapping in Perl

With Perl, we can’t really create a new operator as in Raku . So we’ll use the substr built-in.

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

my ($s, $c, $o) = @ARGV;
my $n = length $s;
die "Invalid values" if $c < 1 or $o < 1 or $c + $o > $n;
for my $i (1..$c) {
    my $tmp = substr $s, $i % $n, 1;
    substr($s, $i % $n, 1) = substr $s, ($i + $o) % $n, 1;
    substr($s, ($i + $o) % $n, 1) = $tmp;
}
say $s;

This program displays the following output:

$ perl char-swap.pl PerlAndRaku 3 4
PndRAerlaku

Task 2: Gray Code Sequence

You are given an integer 2 <= $N <= 5.

Write a script to generate $N-bit gray code sequence.

2-bit Gray Code Sequence

[0, 1, 3, 2]

To generate the 3-bit Gray code sequence from the 2-bit Gray code sequence, follow the step below:

2-bit Gray Code sequence
[0, 1, 3, 2]

Binary form of the sequence
a) S1 = [00, 01, 11, 10]

Reverse of S1
b) S2 = [10, 11, 01, 00]

Prefix all entries of S1 with '0'
c) S1 = [000, 001, 011, 010]

Prefix all entries of S2 with '1'
d) S2 = [110, 111, 101, 100]

Concatenate S1 and S2 gives 3-bit Gray Code sequence
e) [000, 001, 011, 010, 110, 111, 101, 100]

3-bit Gray Code sequence
[0, 1, 3, 2, 6, 7, 5, 4]

Example:

Input: $N = 4

Output: [0, 1, 3, 2, 6, 7, 5, 4, 12, 13, 15, 14, 10, 11, 9, 8]

I don’t see any compelling reason to start with a two-bit Gray code sequence, we can start with a one bit sequence: [0, 1], and thus make the program slightly more general.

Gray Codes in Raku

We just follow the steps described in the task specification.

use v6;
my @gray = [0], [0, 1]; # No need to have [1, 2, 4, 3] here

sub next-gray (Int $in) {
    my $fmt = "%0" ~ $in ~ "s"; # build the formatting string
    my @s1 = map { .fmt('%b').fmt($fmt) }, | @gray[$in];
    my @s2 = reverse map { '1' ~ $_ }, @s1;
    @s1 = map { '0' ~ $_ }, @s1;
    my @gray-seq = |@s1, |@s2;
    my @result = map { .parse-base(2) },  @gray-seq;
}

sub MAIN ($n where 1 <= * <= 5) { # we can start at 1
    for 1..^$n -> $i {
        @gray[$i+1] = next-gray $i;
    }
    say @gray[$n];
    say @gray;
}

This program displays the expected result:

$ raku gray.raku 4
[0 1 3 2 6 7 5 4 12 13 15 14 10 11 9 8]

I’m late and don’t have time to do the equivalent Perl program, although it should really not be a big deal to port the above program to Perl (except possibly the mildly difficult binary to decimal conversion, but I already know how to do that, having done that before with the unpack built-in).

Wrapping up

The next week Perl Weekly Challenge will 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, August 2, 2020. And, please, also spread the word about the Perl Weekly Challenge if you can.

Perl Weekly Challenge 69: Strobogrammatic Numbers and 0/1 Strings

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

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

Task 1: Strobogrammatic Numbers

A strobogrammatic number is a number that looks the same when looked at upside down.

You are given two positive numbers $A and $B such that 1 <= $A <= $B <= 10^15.

Write a script to print all strobogrammatic numbers between the given two numbers.

Example

Input: $A = 50, $B = 100
Output: 69, 88, 96

The first question is: can the digit 1 be part of a strobogrammatic number? Some people handwrite 1 as a simple vertical bar, and some printing fonts also. In most fonts, however, 1 is more complicated than a single vertical bar, including the font used by my text editor to display a 1. So I decided against including 1. This decision does not change the algorithm I’ll use, so it would be very easy to change that and add 1 to the authorized digits..

With this decision made, a strobogrammatic number can only be composed of digits 0, 6, 8, and 9. In addition, the string containing the reversed number must have 0s and 8s in the same position as the original string, and 6s must be replaced by 9s, and conversely.

Strobogrammatic Numbers in Raku

We’ll use some form of brute force: we will loop over all numbers in the range passed to the program, filter out any number containing anything else than 0, 6, 8, and 9, and finally compare each remaining number with the number generated by flipping the input ans substituting 9 with 6 and vice-versa.

use v6;

sub MAIN (Int $i, Int $j where 1 <= $i <= $j <= 1e15) {
    for $i..$j -> $k {
        next if $k ~~ / <-[0689]> /;
        say $k if $k eq $k.flip.map({TR/69/96/});
    }
}

Let’s start by running the program with faulty arguments:

$ raku strobo.raku foo bar
Type check failed in binding to parameter '<anon>'; expected Any but got Mu (Mu)
  in block <unit> at strobo.raku line 1

$ raku strobo.raku 0 5
Type check failed in binding to parameter '<anon>'; expected Any but got Mu (Mu)
  in block <unit> at strobo.raku line 1

$ raku strobo.raku 10 1
Type check failed in binding to parameter '<anon>'; expected Any but got Mu (Mu)
  in block <unit> at strobo.raku line

The error message could be clearer, but the program fails as expected because parameter values don’t match the MAIN subroutine signature. Let’s now run it with correct arguments:

$ raku strobo.raku 1 1000
8
69
88
96
609
689
808
888
906
986

Strobogrammatic Numbers in Perl

We’ll use the same algorithm as in Raku.

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

for my $k ($ARGV[0]..$ARGV[1]) {
    next unless $k =~ /^[0689]+$/;
    my $i = reverse $k;
    $i =~ tr/69/96/;
    say $k if $i eq $k;
}

Note that input parameter validation (if needed) is very easy and is left as an exercise to the reader.

If we now run it with the same arguments as the last Raku program run, we (fortunately) get the same output:

$ perl strobo.pl 1 1000
8
69
88
96
609
689
808
888
906
986

Task 2: 0/1 Strings

A 0/1 string is a string in which every character is either 0 or 1.

Write a script to perform switch and reverse to generate S30 as described below:

switch:

Every 0 becomes 1 and every 1 becomes 0. For example, “101” becomes “010”.

reverse:

The string is reversed. For example, "001” becomes “100”.

Please follow the rule as below:

S0 = “”
S1 = “0”
S2 = “001”
S3 = “0010011”
…
SN = SN-1 + “0” + switch(reverse(SN-1))

In the original version of the task, it was requested to generate S1000, which is just impossible as the resulting number would have about 1E305 (or 10 to the 305th power) digits, because of the geometric progression (exponential) explosion of the result. That number of digits is much much larger than the number of atoms in the entire universe, so there is just no way it will be stored in the memory of any computer. (Please note that we’re not talking here about the resulting number S1000, but only about the number of digits of that number, i.e. something in the order of the decimal logarithm of S1000.) And, even assuming it were possible to store the number in question, computing S1000 would also take much much much more than the current age of the universe, so all challengers would miss the next Sunday deadline by a very very very large margin.

In fact, even generating S30 turned out to be extremely long, way too long in fact. S20 contains already more than a million digits; running it is quite OK (it runs in about two seconds), but S30 would take days (I gave up and stopped the program when reaching S26 after about a day execution, so that S30 would probably take several weeks). So, for the examples below, I’ll use much smaller input values. Unless, of course, there is a better algorithm, but I fail to figure out one at this point (more on this later).

0/1 Strings in Raku

Rather than printing only the last result (Sxx), I decided to print all intermediate results between S3 and S8, since it makes it possible to check manually the results.

use v6;

sub switch (Str $num) {
    [~] $num.comb.map({$_ eq "0" ?? 1 !! 0});
}

my $prev = '001';
for 3..8 -> $i {
    $prev = $prev ~ "0" ~ switch $prev.flip;
    say "$i $prev";
}

This produces the following output (reformatted to make it look nicer on this blog post):

3 0010011
4 001001100011011
5 0010011000110110001001110011011
6 001001100011011000100111001101100010011000110111001001110011011
7 0010011000110110001001110011011000100110001101110010011100110110
  001001100011011000100111001101110010011000110111001001110011011
8 0010011000110110001001110011011000100110001101110010011100110110
  0010011000110110001001110011011100100110001101110010011100110110
  0010011000110110001001110011011000100110001101110010011100110111
  001001100011011000100111001101110010011000110111001001110011011

We can improve performance using the tr/// operator in the switch subroutine:

sub switch (Str $num is copy) {
    $num ~~ tr/01/10/;
}

Anyway, with a program undergoing such a massive exponential explosion, such small optimizations are probably somewhat pointless.

0/1 Strings in Perl

For the Perl version, I decided to try to get rid of the switch subroutine used in Raku and to use the tr///r operator in a probably quite futile attempt to improve performance.

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

my $prev = '001';
for my $i (3..8)  {
    $prev = $prev . "0" .  reverse map { tr/01/10/r }  $prev;;
    say "$i $prev";
}

This produces the following output (reformatted to make it look nicer on this blog post):

3 0010011
4 001001100011011
5 0010011000110110001001110011011
6 001001100011011000100111001101100010011000110111001001110011011
7 0010011000110110001001110011011000100110001101110010011100110110
  001001100011011000100111001101110010011000110111001001110011011
8 0010011000110110001001110011011000100110001101110010011100110110
  0010011000110110001001110011011100100110001101110010011100110110
  0010011000110110001001110011011000100110001101110010011100110111
  001001100011011000100111001101110010011000110111001001110011011

Additional Thoughts on 0/1 Strings

If you look carefully at the output, there appears to be repeated patterns. For example, the line for S6 is repeated as the first line of S7 and S8 (not surprisingly, as this is the way the number is constructed), except for the trailing 0, but also as the third line of S8, which is somewhat unexpected. Similarly, the second line of S7 is the same as the second line of S8 (again, by construction) except for the trailing 0, and also the same as the last line of S8, for reasons that are less obvious (and also as the sixth line of S9, not shown above). There are several other repeated patterns (for example S5 is repeated at the beginning of all lines of S6, S7, and S8. Also, the 31 last digits of S6 are repeated at the end of each of the subsequent lines (lines of S7 and s8), except for the trailing digits. This may have to do with the fact that is you apply twice the switch and reverse operations on a sequence of digits, you get back the original sequence. I really don’t have time now to investigate further these patterns, but there might be a way to construct these Sxx numbers that is faster than the recursive definition given in the task specification.

Wrapping up

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

# Perl Weekly Challenge 68: Zero Matrix

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

Task 1: Zero Matrix

You are given a matrix of size M x N having only 0s and 1s.

Write a script to set the entire row and column to 0 if an element is 0.

Example 1:

Input: [1, 0, 1]
       [1, 1, 1]
       [1, 1, 1]

Output: [0, 0, 0]
        [1, 0, 1]
        [1, 0, 1]

Example 2:

Input: [1, 0, 1]
       [1, 1, 1]
       [1, 0, 1]

Output: [0, 0, 0]
        [1, 0, 1]
        [0, 0, 0]

Zero Matrix in Raku

In my first attempt, I decided to modify the matrix in place. Assuming you’re processing the matrix line by line, this means that you cannot set columns to zero when processing rows, since it would alter the result for the next rows. In other words, you have to postpone updating of columns until you’ve finished processing the rows. So, I keep the subscripts of the columns to be set to 0 in the @cols array. Similarly, I need to keep track of columns to be nullified before nullifying a row.

use v6;

sub display (@mat) {
    .say for @mat; say "";
}

my @matrix = [1, 1, 1], [1, 0, 1], [1, 1, 1], [1, 1, 1];
display @matrix;

my @cols;
for 0..@matrix.end -> $i {
  my $row = False;
    for 0..@matrix[$i].end -> $j {
        if @matrix[$i][$j] == 0 {
            $row = True;
            push @cols, $j;
        }
    }
    @matrix[$i] = [0 xx @matrix[$i].elems] if $row;
}
for @cols -> $j {
    @matrix[$_][$j] = 0 for 0..@matrix.end;
}
display @matrix;

This works as expected:

$ raku zero-matrix.raku
[1 1 1]
[1 0 1]
[1 1 1]
[1 1 1]

[1 0 1]
[0 0 0]
[1 0 1]
[1 0 1]

Overall, modifying the matrix in place feels a bit clunky. So, I decided to create a new copy of the matrix. But this:

my @matrix = [1, 1, 1], [1, 0, 1], [1, 1, 1], [1, 1, 1];
my @new-matrix = @matrix;   # Wrong
for 0..@matrix.end -> $i {
    # ...

does not work as expected, because this appears to make a shallow copy: when you modify @new-matrix, the original matrix is also changed. I was hoping that using the clone built-in would create an independent copy (the documentation says that modifications of elements in the clone are not propagated to the original), but that also doesn’t work with nested arrays and leads to the same problem (modifications are actually propagated). So, I had to use a loop to populate @new-matrix, so that changing @new-matrix does not alter the original @matrix:

sub display (@mat) {
    .say for @mat; say "";
}

my @matrix = [1, 1, 1], [1, 0, 1], [1, 1, 1], [1, 1, 1];
display @matrix;
my @new-matrix;
for 0..@matrix.end -> $i {
    @new-matrix[$i] = [1 xx @matrix[$i].elems]
}
for 0..@matrix.end -> $i {
    for 0..@matrix[$i].end -> $j {
        if @matrix[$i][$j] == 0 {
            @new-matrix[$i] = [0 xx @matrix[$i].elems];
            @new-matrix[$_][$j] = 0 for 0..@matrix.end;
        }
    }
}
display @new-matrix;

This works correctly:

$ raku zero-matrix2.raku
[1 1 1]
[1 0 1]
[1 1 1]
[1 1 1]

[1 0 1]
[0 0 0]
[1 0 1]
[1 0 1]

Zero Matrix in Perl

This a port to Perl of the second Raku implementation above:

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

sub display {
    say "@$_" for @_; say "";
}

my @matrix = ([1, 1, 1], [1, 0, 1], [1, 1, 1], [1, 1, 1]);
display @matrix;
my @new_matrix;
push @new_matrix, [ @$_ ] for @matrix; # deep copy
for my $i (0..$#matrix) {
    for my $j (0..scalar @{$matrix[$i]} - 1) {
        if ($matrix[$i][$j] == 0) {
            $new_matrix[$i] = [ (0) x scalar @{$matrix[$i]} ];
            $new_matrix[$_][$j] = 0 for 0..$#matrix;
        }
    }
}
display @new_matrix;

This works as in Raku:

$ perl zero-matrix.pl
1 1 1
1 0 1
1 1 1
1 1 1

1 0 1
0 0 0
1 0 1
1 0 1

Wrapping up

Perl Weekly Challenge 68 had another task (reorder lists), but I’m already much too late and don’t have time to complete it.

The next week Perl Weekly Challenge has already started. 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, July 19, 2020. And, please, also spread the word about the Perl Weekly Challenge if you can.

Perl Weekly Challenge 67: Number Combinations and Letter Phone

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

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

Task 1: Number Combinations

You are given two integers $m and $n. Write a script print all possible combinations of $n numbers from the list 1 2 3 … $m.

Every combination should be sorted i.e. [2,3] is valid combination but [3,2] is not.

Example:

Input: $m = 5, $n = 2

Output: [ [1,2], [1,3], [1,4], [1,5], [2,3], [2,4], [2,5], [3,4], [3,5], [4,5] ]

Note that I don’t consider the formatting of the displayed output above to be part of the task.

Number Combinations in Raku

Raku has a built-in combinations method making the task really very simple. For example:

use v6;
my $m = 5;
my $n = 2;

.say for 1..$m.combinations: $n;

This duly prints the same list as the output specified in the task:

(1 2)
(1 3)
(1 4)
(1 5)
(2 3)
(2 4)
(2 5)
(3 4)
(3 5)
(4 5)

It could be argued that the input values are hardcoded in the program and that it would better to pass them to the program. True, but implementing a MAIN subroutine to deal with paramleters passed to the program is so simple that it is left as an exercize to the reader (although an example is provided in one of the one-liners below).

The code is so simple that it can easily be converted to a Raku one-liner:

~ raku -e '.say for (1..5).combinations(2)'
(1 2)
(1 3)
(1 4)
(1 5)
(2 3)
(2 4)
(2 5)
(3 4)
(3 5)
(4 5)

Here again, the input values are hardcoded in the one-liner script, and, to me, it is perfectly OK in a one-liner, as it is very easy to launch the one-liner again with modified values, but if you really want to pass the input values as parameters to the script, here is one way to do it:

~ raku -e 'sub MAIN {.say for (1..$^a).combinations: $^b}' 5 2
(1 2)
(1 3)
(1 4)
(1 5)
(2 3)
(2 4)
(2 5)
(3 4)
(3 5)
(4 5)

Note that this script is using the ^ twigil to create self-declared formal positional parameters to the MAIN subroutine. Variables of the form $^a are a type of placeholder variable.

Number Combinations in Perl

Perl does not have a built-in combinations function, but there are several modules (for example Math::Combinatorics) providing the functionality. However, this being a coding challenge, I don’t want to use a third-party ready-made solution and prefer to show a way to do it yourself.

If we knew in advance how many items we want in each combination, nested loops might be the best solution. But if we want to be flexible about the number of items in each combination, then it is often simpler to use a recursive approach. Here, the combinations subroutine is recursive and is called once for every item wanted in the combination.

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

my $m = shift // 5;
my $num = shift // 2;
combinations([], 1..$m);

sub combinations {
    my ($out, @in) = @_;
    return unless @in;
    for my $digit (@in) {
        next if defined $out->[-1] and $digit <= $out->[-1];
        my $new_out = [ @$out, $digit ];
        say "@$new_out" and next if scalar @$new_out == $num;
        combinations($new_out, @in[1..$#in]);
    }
}

These are three sample runs:

$ perl combinations.pl
1 2
1 3
1 4
1 5
2 3
2 4
2 5
3 4
3 5
4 5

$ perl combinations.pl 6 3
1 2 3
1 2 4
1 2 5
1 2 6
1 3 4
1 3 5
1 3 6
1 4 5
1 4 6
1 5 6
2 3 4
2 3 5
2 3 6
2 4 5
2 4 6
2 5 6
3 4 5
3 4 6
3 5 6
4 5 6

$ perl combinations.pl 5 4
1 2 3 4
1 2 3 5
1 2 4 5
1 3 4 5
2 3 4 5

Task 2: Letter Phone

You are given a digit string $S. Write a script to print all possible letter combinations that the given digit string could represent.

keypad.jpg

Example:

​ Input: $S = ‘35’

​ Output: [“dj”, “dk”, “dl”, “ej”, “ek”, “el”, “fj”, “fk”, “fl”].

The first thing to notice in the above keyboard is that there is no letter or other character corresponding to the 0 key. I decided to assign a dash (-) to it, to avoid problems if the input numeric string contains a zero.

Letter Phone in Raku

I used a hash of arrays to store the letters or characters associated with digits, but, given that the digits are integers between 0 and 9, we could have used an array of arrays as well.

My first attempt was to use a recursive subroutine (take-one) to solve the problem:

use v6;

my %nums = 0 => '-', 1 => <_ , @>, 2 => <A B C>, 3 => <D E F>,
           4 => <G H I>, 5 => <J K L>, 6 => <M N O>,
           7 => <A Q R S>, 8 => <T U V>, 9 => <W X Y Z>;

my $str = @*ARGS[0] // "35";
take-one("", $str.comb);
say "";

sub take-one (Str $str, @digits is copy) {
    if @digits.elems == 0 {
        print "$str ";
        return;
    }
    my $digit = shift @digits;
    for %nums{$digit}.Seq -> $letter {
        my $new-str = $str ~ $letter;
        take-one($new-str, @digits)
    }
}

This yields the right result:

raku letter-phone.raku
DJ DK DL EJ EK EL FJ FK FL

But even before I completed the above script, I realized that this was overkill as it can be done in a much simpler way (I nonetheless completed the above recursive program for the purpose of illustration).

Raku has the X cross operator that can generate a cross product of two (or more) arrays, as shown here under the REPL:

> say <a b c> X <1 2 3>
((a 1) (a 2) (a 3) (b 1) (b 2) (b 3) (c 1) (c 2) (c 3))

It can also be used as a meta-operator together with another operator. For example, with the string concatenation operator, we generate a list of strings:

> say <a b c> X~ <1 2 3>
(a1 a2 a3 b1 b2 b3 c1 c2 c3)

Finally, using this together with the [] reduction meta-operator, we solve the problem in just one line of actual code:

my %nums = 0 => '-', 1 => <_ , @>, 2 => <A B C>, 3 => <D E F>,
           4 => <G H I>, 5 => <J K L>, 6 => <M N O>,
           7 => <A Q R S>, 8 => <T U V>, 9 => <W X Y Z>;

my $str = @*ARGS[0] // 35;
say [X~] %nums{$str.comb};

These are three example runs:

$ raku letter-phone2.raku
(DJ DK DL EJ EK EL FJ FK FL)

$ raku letter-phone2.raku 325
(DAJ DAK DAL DBJ DBK DBL DCJ DCK DCL EAJ EAK EAL EBJ EBK EBL ECJ ECK ECL FAJ FAK FAL FBJ FBK FBL FCJ FCK FCL)

$ raku letter-phone2.raku 305
(D-J D-K D-L E-J E-K E-L F-J F-K F-L)

Letter Phone in Perl

This is a port to Perl of the initial recursive approach in Raku:

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

my %nums = (0 => ['-'], 1 => ['_', ',', '@'], 2 => [qw <A B C>], 
           3 => [qw <D E F>], 4 => [qw <G H I>], 5 => [qw <J K L>], 
           6 => [qw <M N O>], 7 => [qw <A Q R S>], 
           8 => [qw <T U V>], 9 => [qw <W X Y Z>]);

my $str = shift // "35";
take_one("", split //, $str);
say "";

sub take_one {
    my ($str, @digits) = @_;
    if (@digits == 0) {
        print "$str ";
        return;
    }
    my $digit = shift @digits;
    for my $letter (@{$nums{$digit}}) {
        my $new_str = $str . $letter;
        take_one($new_str, @digits)
    }
}

These are some example outputs:

$ perl letter-phone.pl
DJ DK DL EJ EK EL FJ FK FL

$ perl letter-phone.pl 42
GA GB GC HA HB HC IA IB IC

$ perl letter-phone.pl 453
GJD GJE GJF GKD GKE GKF GLD GLE GLF HJD HJE HJF HKD HKE HKF HLD HLE HLF IJD IJE IJF IKD IKE IKF ILD ILE ILF

Wrapping up

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