Perl Weekly Challenge 88: Array of Products and Spiral Matrices

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

Spoiler Alert: This weekly challenge deadline is due in a couple of days (November 29, 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: Array of Products

You are given an array of positive integers @N.

Write a script to return an array @M where $M[i] is the product of all elements of @N except the index $N[i].

Example 1:

Input:
    @N = (5, 2, 1, 4, 3)
Output:
    @M = (24, 60, 120, 30, 40)

    $M[0] = 2 x 1 x 4 x 3 = 24
    $M[1] = 5 x 1 x 4 x 3 = 60
    $M[2] = 5 x 2 x 4 x 3 = 120
    $M[3] = 5 x 2 x 1 x 3 = 30
    $M[4] = 5 x 2 x 1 x 4 = 40

Example 2:

Input:
    @N = (2, 1, 4, 3)
Output:
    @M = (12, 24, 6, 8)

    $M[0] = 1 x 4 x 3 = 12
    $M[1] = 2 x 4 x 3 = 24
    $M[2] = 2 x 1 x 3 = 6
    $M[3] = 2 x 1 x 4 = 8

Array of Products in Raku

I immediately thought about two methods to solve this problem. Although I thought the second method was probably better, let me show first the first one.

The first way to do it is to traverse the input array and, for each item, multiply all items before with all items after and store the product in the equivalent position of the result array. Here we use the reduction metaoperator with multiplication, [*], to compute the chained multiplication. And we use array slices to pick the relevant items to be multiplied. For some reason, array slice did not work properly for the first element of the array, so I computed it separately before entering the for loop.

use v6;

my @tests = [5, 2, 1, 4, 3], [2, 1, 4, 3];
for @tests -> @array {
    my @result; 
    @result[0] = [*] @array[1..@array.end];
    for 1..@array.end -> $i {
        @result[$i] = ([*] @array[0..$i-1]) * [*] (@array[$i+1..@array.end]);
    }
    say "Input array: ", @array;
    say "Result: ", @result;
}

This script produces the following output:

$ raku array-of_products.raku
Input array: [5 2 1 4 3]
Result: [24 60 120 30 40]
Input array: [2 1 4 3]
Result: [12 24 6 8]

There may be a better way to handle the special case of the first item of the list, but, rather than trying to improve it, I preferred to implement the second method. Here, the idea is to compute only once the product of all elements of the input array. Then, for each position in the array, we divide the overall product by the item in the current position. The code becomes slightly simpler, and the performance is also likely to be better, since we’re performing much less arithmetical operations overall (especially if the input array is somewhat large).

my @tests = [5, 2, 1, 4, 3], [2, 1, 4, 3];
for @tests -> @array {
    my $product = [*] @array;
    my @result = map { $product / $_ }, @array;
    say "Input array: ", @array;
    say "Result: ", @result;
}

This script produces the same result as before:

Input array: [5 2 1 4 3]
Result: [24 60 120 30 40]
Input array: [2 1 4 3]
Result: [12 24 6 8]

Array of Products in Perl

This is a port to Perl of the method used in the second Rakudo script above: we compute the product of all elements of the input array. Then, for each position in the array, we divide the overall product by the item in the current position.

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

my @tests = ([5, 2, 1, 4, 3], [2, 1, 4, 3]);
for my $array_ref (@tests) {
    my $product = 1;
    $product *= $_ for @$array_ref;
    my @result = map $product / $_, @$array_ref;
    say "Input: @$array_ref";
    say "Result: @result";
}

This displays the following output:

$ perl array-of-products.pl
Input: 5 2 1 4 3
Result: 24 60 120 30 40
Input: 2 1 4 3
Result: 12 24 6 8

Task 2: Spiral Matrix

You are given m x n matrix of positive integers.

Write a script to print spiral matrix as list.

Example 1:

Input:
    [ 1, 2, 3 ]
    [ 4, 5, 6 ]
    [ 7, 8, 9 ]
Ouput:
    [ 1, 2, 3, 6, 9, 8, 7, 4, 5 ]

Example 2:

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

Spiral Matrix in Raku

For this task, we’ll use a @tests array of five rectangular matrices. The print-matrix subroutine is a helper function to pretty print the input matrix. Note that, when applied to a list, the fmt method applies the formatting string to each element of the list (contrary to sprintf), so that there is no need to add a map to process each item of a matrix line. For example:

say <1 2 3 4>.fmt("%04i");

will print:

0001 0002 0003 0004

The main loop reads the values of the matrix (in accordance to the rules explained just after) and stores them into the @result array. It processes first the first matrix line (left to right); it then processes the last column, i.e. the last item of each line, from top to bottom, and deletes it at the same time; it then processes (right to left) the last line of the matrix and also deletes this line; and it processes the first column (bottom to top) of the matrix. It then assign to @matrix a version of the original matrix with all values on the four edges removed. And the loop is restarted with the new smaller matrix if it is not empty.

Note that the :delete adverb removes entirely the last item of an array, but it leaves a “hole” when applied to any other element of the array.

use v6;

my @tests =
    [ [ |(0..3) ], [ |(4..7)  ],  [ |(8..11)  ], [ |(12..15) ] ],
    [ [ |(0..4) ], [ |(5..9)  ],  [ |(10..14) ], [ |(15..19) ] ],
    [ [ |(0..5) ], [ |(6..11) ], [ |(12..17)  ], [ |(18..23) ] ],
    [ [ |(0..5) ], [ |(6..11) ], [ |(12..17)  ] ],
    [ [ |(0..2) ], [ |(4..6)  ],  [ |(8..10)  ], [ |(12..14) ] ];

sub print-matrix (@matrix) {
        say "[ {$_.fmt("% 3i")} ]" for @matrix;
        say "";
}

for @tests -> @matrix {
    my @result;
    print-matrix @matrix;
    loop {
        push @result, |@matrix[0];
        push @result, @matrix[$_][*-1]:delete for 1..@matrix.end;
        push @result, |(reverse @matrix[@matrix.end]:delete);
        last if @matrix.elems == 1;
        push @result, @matrix[$_][0]:delete for reverse 1..@matrix.end;
        @matrix = map { [$_[|(1..$_.end)]] }, @matrix[|(1..@matrix.end)];
        # print-matrix @matrix;
        last unless @matrix;
    }
    say @result, "\n";
}

This program displays the following output:

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

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

[   0   1   2   3   4 ]
[   5   6   7   8   9 ]
[  10  11  12  13  14 ]
[  15  16  17  18  19 ]

[0 1 2 3 4 9 14 19 18 17 16 15 10 5 6 7 8 13 12 11]

[   0   1   2   3   4   5 ]
[   6   7   8   9  10  11 ]
[  12  13  14  15  16  17 ]
[  18  19  20  21  22  23 ]

[0 1 2 3 4 5 11 17 23 22 21 20 19 18 12 6 7 8 9 10 16 15 14 13]

[   0   1   2   3   4   5 ]
[   6   7   8   9  10  11 ]
[  12  13  14  15  16  17 ]

[0 1 2 3 4 5 11 17 16 15 14 13 12 6 7 8 9 10]

[   0   1   2 ]
[   4   5   6 ]
[   8   9  10 ]
[  12  13  14 ]

[0 1 2 6 10 14 13 12 8 4 5 9]

We can make it slightly simpler by stripping out the used matrix edges as we go, using the pop and shift methods each time we use some values, so that we don’t have to reassign the @matrix at each iteration. This also simplifies the handling of array subscripts. In the code below, the only changes are in the loop block:

use v6;

my @tests =
    [ [ |(0..3) ], [ |(4..7)  ],  [ |(8..11)  ], [ |(12..15) ] ],
    [ [ |(0..4) ], [ |(5..9)  ],  [ |(10..14) ], [ |(15..19) ] ],
    [ [ |(0..5) ], [ |(6..11) ], [ |(12..17)  ], [ |(18..23) ] ],
    [ [ |(0..5) ], [ |(6..11) ], [ |(12..17)  ] ],
    [ [ |(0..2) ], [ |(4..6)  ],  [ |(8..10)  ], [ |(12..14) ] ];

sub print-matrix (@matrix) {
        say "[ {$_.fmt("% 3i")} ]" for @matrix;
        say "";
}
for @tests -> @matrix {
    my @result;
    print-matrix @matrix;
    loop {
        push @result, |@matrix.shift;
        push @result, @matrix[$_].pop for 0..@matrix.end;
        last unless @matrix.elems;
        push @result, |(reverse @matrix.pop);
        push @result, @matrix[$_].shift for reverse 0..@matrix.end;
        last unless @matrix;
    }
    say @result, "\n";
}

This produces the same output as before:

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

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

[   0   1   2   3   4 ]
[   5   6   7   8   9 ]
[  10  11  12  13  14 ]
[  15  16  17  18  19 ]

[0 1 2 3 4 9 14 19 18 17 16 15 10 5 6 7 8 13 12 11]

[   0   1   2   3   4   5 ]
[   6   7   8   9  10  11 ]
[  12  13  14  15  16  17 ]
[  18  19  20  21  22  23 ]

[0 1 2 3 4 5 11 17 23 22 21 20 19 18 12 6 7 8 9 10 16 15 14 13]

[   0   1   2   3   4   5 ]
[   6   7   8   9  10  11 ]
[  12  13  14  15  16  17 ]

[0 1 2 3 4 5 11 17 16 15 14 13 12 6 7 8 9 10]

[   0   1   2 ]
[   4   5   6 ]
[   8   9  10 ]
[  12  13  14 ]

[0 1 2 6 10 14 13 12 8 4 5 9]

Spiral Matrix in Perl

For this task, we’ll use a @tests array of five rectangular matrices. The print_matrix subroutine is a helper function to pretty print the input matrix.

The main while loop reads the values of the matrix (in accordance to the rules explained just after) and stores them into the @result array. It processes first the first matrix line (left to right) and removes it from the matrix; it then processes the last column, i.e. the last item of each line, from top to bottom, and deletes it at the same time; it then processes (right to left) the last line of the matrix and also deletes this line; and finally it processes the first column (bottom to top) of the matrix and removes it. After one iteration, the original matrix is stripped of all its edge items. And the loop is restarted with the new smaller matrix if it is not empty.

use strict;
use warnings;
use feature "say";
use Data::Dumper;


my @tests = ( [ [ 0..3 ], [ (4..7) ],  [ (8..11) ],  [ (12..15) ] ],
              [ [ 0..4 ], [ (5..9) ],  [ (10..14) ], [ (15..19) ] ],
              [ [ 0..5 ], [ (6..11) ], [ (12..17) ], [ (18..23) ] ],
              [ [ 0..5 ], [ (6..11) ], [ (12..17) ] ],
              [ [ 0..2 ], [ (4..6) ],  [ (8..10) ],  [ (12..14) ] ]
            );

# @tests = ( [ [ 0..3 ], [ (4..7) ],  [ (8..11) ],  [ (12..15) ] ] );

sub print_matrix {
    my @matrix = @{$_[0]};
    say "";
    say "[ ", (map { sprintf "% 3i", $_ } @$_), " ]" for @matrix;
    say "";
}

for my $m_ref (@tests) {
    print_matrix($m_ref);
    my @result;
    my @matrix = @$m_ref;
    while (1) {
        push @result, @{shift @matrix};
        last if scalar @matrix == 0;
        push @result, pop @{$matrix[$_]} for 0..$#matrix;
        push @result, reverse @{pop @matrix};
        push @result, shift @{$matrix[$_]} for reverse 0..$#matrix;
        last if @matrix == 0;
    }
    say join " ", @result;    
}

This displays the following output:

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

0 1 2 3 7 11 15 14 13 12 8 4 5 6 10 9

[   0  1  2  3  4 ]
[   5  6  7  8  9 ]
[  10 11 12 13 14 ]
[  15 16 17 18 19 ]

0 1 2 3 4 9 14 19 18 17 16 15 10 5 6 7 8 13 12 11

[   0  1  2  3  4  5 ]
[   6  7  8  9 10 11 ]
[  12 13 14 15 16 17 ]
[  18 19 20 21 22 23 ]

0 1 2 3 4 5 11 17 23 22 21 20 19 18 12 6 7 8 9 10 16 15 14 13

[   0  1  2  3  4  5 ]
[   6  7  8  9 10 11 ]
[  12 13 14 15 16 17 ]

0 1 2 3 4 5 11 17 16 15 14 13 12 6 7 8 9 10

[   0  1  2 ]
[   4  5  6 ]
[   8  9 10 ]
[  12 13 14 ]

0 1 2 6 10 14 13 12 8 4 5 9

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

Perl Weekly Challenge 87: Longest Consecutive Sequences and Largest Rectangle

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

Spoiler Alert: This weekly challenge deadline is due in a few days (November 22, 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: Longest Consecutive Sequences

You are given an unsorted array of integers @N.

Write a script to find the longest consecutive sequence. Print 0 if none sequence found.

Example 1:

Input: @N = (100, 4, 50, 3, 2)
Output: (2, 3, 4)

Example 2:

Input: @N = (20, 30, 10, 40, 50)
Output: 0

Example 3:

Input: @N = (20, 19, 9, 11, 10)
Output: (9, 10, 11)

We’re given an unsorted array, but there is nothing preventing us from starting by sorting the array. Once the input is sorted, the solution is quite easy. Note that, if Raku or Perl did not have a built-in sort function, the first thing I would do is probably to implement a sort subroutine. I have shown elsewhere that a quick sort or merge sort subroutine can be written in about half a dozen code lines, both in Raku and in Perl, with a functional programming approach. For example, this is a quick sort implementation in Raku:

sub quicksort (@input) {
    return @input if @input.elems <= 1;
    my $pivot = @input[@input.elems div 2];
    return flat quicksort(grep {$_ < $pivot}, @input), 
        (grep {$_ == $pivot}, @input), 
        quicksort(grep {$_ > $pivot}, @input);
}

Longest Consecutive Sequences in Raku

We use three input arrays for our tests. For each test case, we simply sort the input array and scan the sorted results for consecutive sequences. Consecutive sequences are stored in the @sequences array of arrays and we finally display the longest sequence:

use v6;

my @tests = [ 100, 4, 50, 3, 2 ],
            [ 20, 30, 10, 40, 50 ],
            [ 20, 19, 9, 11, 10 ];

for @tests -> @t {
    my @in = sort @t;
    my $last = @in[0];
    my @sequences;
    my $index = 0;
    push @sequences[$index], $last;
    for 1..@in.end -> $i {
        my $current = @in[$i];
        $index++ if $current != $last + 1;
        push @sequences[$index], $current;
        $last = $current;
    }
    my @sorted_seq = sort { $^b.elems <=> $^a.elems }, @sequence;
    if @sorted_seq[0] > 1 {
        say @sorted_seq[0];
    } else {
        say 0;
    }
}

This displays the following output:

[2 3 4]
0
[9 10 11]

Longest Consecutive Sequences in Perl

In this Perl version, we also use three input arrays for our tests. For each test case, we simply sort the input array and scan the sorted results for consecutive sequences. Consecutive sequences are stored in the @sequences array of arrays and we simply output the longest sequence:

use strict;
use warnings;
use feature "say";
use Data::Dumper;

my @tests = ( [ 100, 4, 50, 3, 2 ],
              [ 20, 30, 10, 40, 50 ],
              [ 20, 19, 9, 11, 10 ]
            );

for my $t_ref (@tests) {
    my @in = sort { $a <=> $b } @$t_ref;
    my $last = $in[0];
    my @sequences;
    my $index = 0;
    push @{$sequences[$index]}, $last;
    for my $i (1..$#in) {
        my $current = $in[$i];
        $index++ if $current != $last + 1;
        push @{$sequences[$index]}, $current;
        $last = $current;
    }
    my @sorted_seq = sort { scalar @$b <=> scalar @$a } @sequences;
    if (scalar @{$sorted_seq[0]} > 1) {
        say "@{$sorted_seq[0]}";
    } else {
        say 0;
    }
}

This is the output displayed by this script:

$ perl longest-seq.pl
2 3 4
0
9 10 11

Task 2: Largest Rectangle

You are given matrix m x n with 0 and 1.

Write a script to find the largest rectangle containing only 1. Print 0 if none found.

Example 1:

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

Output:
    [ 1 1 1 1 1 ]
    [ 1 1 1 1 1 ]

Example 2:

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

Output: 0

Example 3:

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

Output:
    [ 1 1 1 1 ]
    [ 1 1 1 1 ]

At first glance, this seemed to be a fairly easy task. It turned out to be much more complicated than I expected.

My initial idea was to scan the matrix from top left to bottom right, and, for any 1 found, to try to expand this position into a region toward the right and toward the bottom. When starting to think about the implementation, I found that this approach was going to be complicated, painful, and probably quite clumsy.

So, I decided to proceed in a different way: generate all rectangles toward the right and the bottom of any position with a 1, then eliminate those containing at least one zero, and find the largest remaining rectangle. In both the Raku and the Perl programs below, a rectangle consists of at least two contiguous 1s, and is uniquely defined by its top left and bottom right corners.

As both the Raku and the Perl programs described below are a bit complicated, I will avoid abusing the expressive power of the programming language ans will describe separately the main steps of the algorithm before providing the full program.

Largest Rectangle in Raku

For this program, we’ll use six matrices as test cases:

my @matrices = 
    [ [ <0 1 0 1> ], [ <0 0 1 0> ], [ <1 1 0 1> ], [ <1 1 0 1> ] ], 
    [ [ <1 1 0 1> ], [ <1 1 0 0> ], [ <0 1 1 1> ], [ <1 0 1 1> ] ],
    [ [ <0 1 0 1> ], [ <1 0 1 0> ], [ <0 1 0 0> ], [ <1 0 0 1> ] ],

    [ [ <1 1 0 1 1 1> ], [ <1 1 1 0 1 0> ], 
        [ <1 1 0 1 0 1> ], [ <1 1 1 0 0 1> ] 
    ],

    [ [ <0 0 0 1 0 0> ], [ <1 1 1 0 0 0> ], 
      [ <0 0 1 0 0 1> ], [ <1 1 1 1 1 0> ], [ <1 1 1 1 1 0>],
    ],

    [ [ <0 0 0 1 1 1> ], [ <1 1 1 1 1 1> ], 
      [ <0 0 1 0 0 1> ], [ <0 0 1 1 1 1> ], 
      [ <0 0 1 1 1 1> ],
    ];

The first step will be to iterate over the six test cases and for each test matrix, to call the print-matrix subroutine (which pretty-prints the input matrix) and the find-rect subroutine, which does most of the work and will be described in greater detail below.

for @matrices -> @m {
    print-matrix @m;
    find-rect @m;
}

The print-matrix reads the input matrix line by line and prints a formated version of all such lines:

sub print-matrix (@matrix) {
    say "[ $_ ]" for @matrix;
    say "";
}

For our first test matrix:

[ [ <0 1 0 1> ], [ <0 0 1 0> ], [ <1 1 0 1> ], [ <1 1 0 1> ] ]

this subroutine prints this:

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

As said before, the find-rect does the bulk of the work.

First, we make a @positions array of all positions (defined by their coordinates) in the matrix that contain a value equal to 1. For this, we use the X infix cross operator to generate a Cartesian product of all positions and filter out positions whose value in the matrix is not equal to 1:

my $max-h = @m.end;
my $max-w = @m[0].end;
my @positions =  ((0..$max-h) X  (0..$max-w))
    .grep({@m[$_[0]][$_[1]] == 1});

For the first test matrix, the list of valid positions is this:

[(0 1) (0 3) (1 2) (2 0) (2 1) (2 3) (3 0) (3 1) (3 3)]

The next step is to create a @pairs list of pairs of positions (which will represent the top left and bottom right corners of each rectangle). For this, we use the combinations built-in routine of Raku:

    my @pairs = @positions.combinations: 2;

For our first test matrix, this generates a data structure like so (slightly reformatted for clarity):

[((0 1) (0 3))  ((0 1) (1 2))  ((0 1) (2 0))  ((0 1) (2 1)) 
 ((0 1) (2 3))  ((0 1) (3 0))  ((0 1) (3 1))  ((0 1) (3 3)) 
 [content omitted for brevity]
 ((2 1) (3 1))  ((2 1) (3 3))  ((2 3) (3 0))  ((2 3) (3 1)) 
 ((2 3) (3 3))  ((3 0) (3 1))  ((3 0) (3 3))  ((3 1) (3 3))]

Note that, at this point, the rectangles represented by those point pairs may contain some 0s (we only know that the point pairs themselves are 1s). For example, the first point pair above:

((0 1) (0 3))

corresponds to the following rectangle in the input matrix:

1 0 1

As it can be seen, the bounds are 1s, but the middle item if 0. This is not a valid rectangle candidate.

In addition, the ((0 1) (3 0)) pair in the second line doesn’t define a valid rectangle because the second coordinate of the first pair (1) is larger than its counterpart in second pair, and we said that the first pair must represent the top left and the second pair the bottom right points of the rectangle. Here, the second point is to the left of the first. We need to eliminate these malformed rectangles.

The next step is therefore to keep only valid rectangles rectangles and store them into the @eligible array:

my @eligible = gather {
    for @pairs -> $p {
        # Remove malformed rectangles
        next if $p[0][0] > $p[1][0] or $p[0][1] > $p[1][1];
        # remove rectangles containing 0s.
        next if @m[$p[0][0]..$p[1][0];$p[0][1]..$p[1][1]].any == 0; 
        take $p;
    }
}

Note that the following expression (using a semi-colon to separate the coordinate ranges) : @m[$p[0][0]..$p[1][0];$p[0][1]..$p[1][1]]

flattens the input rectangle into a flat list, so that we can use a simple any junction to detect any 0 item.

If the @eligible array is empty, then we did not find any suitable rectangle. In such a case, we print 0 and exit the subroutine.

say "0\n" and return unless @eligible;

In the case of our first test matrix, there are six eligible rectangles:

[((2 0) (2 1))  ((2 0) (3 0))  ((2 0) (3 1))  
 ((2 1) (3 1))  ((2 3) (3 3))  ((3 0) (3 1))
]

We now need to pick the largest rectangle. For this, we simply sort in descending order according to their area size. In Raku, when the code object passed as the first parameter to the sort subroutine takes only one parameter, then it is not a comparison code block, but a code object implementing the transformation to be applied to all items before applying the default cmpcomparison subroutine. Here, we use this code block:

{($_[1][0] - $_[0][0] + 1) * ($_[1][1] - $_[0][1] + 1)}

in order to compute the area of the rectangle and use it for the comparison. So the sort block looks like this:

my $rect = (reverse sort { 
        ($_[1][0] - $_[0][0] + 1) * ($_[1][1] - $_[0][1] + 1) 
        }, @eligible)[0];

Now, we’re done, we have the largest rectangle, we only need to display the result.

This is the full code of the program:

use v6;

my @matrices = 
    [ [ <0 1 0 1> ], [ <0 0 1 0> ], [ <1 1 0 1> ], [ <1 1 0 1> ] ], 
    [ [ <1 1 0 1> ], [ <1 1 0 0> ], [ <0 1 1 1> ], [ <1 0 1 1> ] ],
    [ [ <0 1 0 1> ], [ <1 0 1 0> ], [ <0 1 0 0> ], [ <1 0 0 1> ] ],

    [ [ <1 1 0 1 1 1> ], [ <1 1 1 0 1 0> ], 
        [ <1 1 0 1 0 1> ], [ <1 1 1 0 0 1> ] 
    ],

    [ [ <0 0 0 1 0 0> ], [ <1 1 1 0 0 0> ], 
      [ <0 0 1 0 0 1> ], [ <1 1 1 1 1 0> ], [ <1 1 1 1 1 0>],
    ],

    [ [ <0 0 0 1 1 1> ], [ <1 1 1 1 1 1> ], 
      [ <0 0 1 0 0 1> ], [ <0 0 1 1 1 1> ], 
      [ <0 0 1 1 1 1> ],
    ];

for @matrices -> @m {
    print-matrix @m;
    find-rect @m;
}
sub print-matrix (@matrix) {
    say "[ $_ ]" for @matrix;
    say "";
}

sub find-rect (@m) {
    my $max-h = @m.end;
    my $max-w = @m[0].end;
    my @positions =  ((0..$max-h) X  (0..$max-w))
        .grep({@m[$_[0]][$_[1]] == 1});
    # say @positions;
    my @pairs = @positions.combinations: 2;
    # say @pairs;
    my @eligible = gather {
        for @pairs -> $p {
            next if $p[0][0] > $p[1][0] or $p[0][1] > $p[1][1];
            next if @m[$p[0][0]..$p[1][0];$p[0][1]..$p[1][1]].any == 0; 
            take $p;
        }
    }
    say "0\n" and return unless @eligible;
    my $rect = (reverse sort { 
            ($_[1][0] - $_[0][0] + 1) * ($_[1][1] - $_[0][1] + 1) 
            }, @eligible)[0];
    say  "Rectangle corners: ", $rect;
    for $rect[0][0]..$rect[1][0] -> $row {
        say @m[$row][$rect[0][1]..$rect[1][1]];
    }
    say "";
}

This program displays the following output:

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

Rectangle corners: ((2 0) (3 1))
(1 1)
(1 1)

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

Rectangle corners: ((2 2) (3 3))
(1 1)
(1 1)

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

0

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

Rectangle corners: ((0 0) (3 1))
(1 1)
(1 1)
(1 1)
(1 1)

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

Rectangle corners: ((3 0) (4 4))
(1 1 1 1 1)
(1 1 1 1 1)

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

Rectangle corners: ((3 2) (4 5))
(1 1 1 1)
(1 1 1 1)

Largest Rectangle in Perl

For this program, we’ll use seven matrices for our test cases:

my @matrices = 
    ( [ [ qw <0 1 0 1> ], [ qw <0 0 1 0> ], 
        [ qw <1 1 0 1> ], [ qw <1 1 0 1> ] 
      ], 

      [ [ qw <1 1 0 1> ], [ qw <1 1 0 0> ], 
        [ qw <0 1 1 1> ], [ qw <1 0 1 1> ] 
      ],

      [ [ qw <0 1 0 1> ], [ qw <1 0 1 0> ], 
        [ qw <0 1 0 0> ], [ qw <1 0 0 1> ] 
      ],

      [ [ qw <1 1 0 1 1 1> ], [ qw <1 1 1 0 1 0> ], 
          [ qw <1 1 0 1 0 1> ], [ qw <1 1 1 0 0 1> ] 
      ],

      [ [ qw <0 0 0 1 0 0> ], [ qw <1 1 1 0 0 0> ], 
          [ qw <0 0 1 0 0 1> ], [ qw <1 1 1 1 1 0> ], 
          [ qw <1 1 1 1 1 0>],
      ],
      [ [ qw <1 0 1 0 1 0> ], [ qw <0 1 0 1 0 1> ], 
          [ qw <1 0 1 0 1 0> ], [ qw <0 1 0 1 0 1> ],
      ],
      [ [ qw <0 0 0 1 1 1> ], [ qw <1 1 1 1 1 1> ], 
          [ qw <0 0 1 0 0 1> ], [ qw <0 0 1 1 1 1> ], 
          [ qw <0 0 1 1 1 1> ],
      ],
    );

The first step will be to iterate over the seven test cases and for each test matrix, to call the print_matrix subroutine (which pretty-prints the input matrix) and the find_rect subroutine, which does most of the work and will be described in detail below.

for my $m_ref (@matrices) {
    print_matrix($m_ref);
    find_rect($m_ref);
}

sub print_matrix {
    my @matrix = @{$_[0]};
    say "";
    say "[ @$_ ]" for @matrix;
    say "";
}

For our first sample matrix:

             [ [ qw <0 1 0 1> ], [ qw <0 0 1 0> ], 
               [ qw <1 1 0 1> ], [ qw <1 1 0 1> ] 
             ],

the print_matrix subroutine displays this:

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

As said before, the find-rect does the bulk of the work.

First, we make a @positions array of all positions (defined by their coordinates) in the matrix that contain a value equal to 1. For this, we use a nested for loop:

my @positions;
for my $i (0..$#m) {
    for my $j (0..$#{$m[0]}) {
        push @positions, [$i, $j] unless $m[$i][$j] == 0;
    }
}

For the first test matrix, we obtain the following non-zero positions:

(0 1) (0 3) (1 2) (2 0) (2 1) (2 3) (3 0) (3 1) (3 3)

Then we use another nested for loop to find all the point pairs:

my @pairs;
for my $k (0..$#positions) {
    for my $n ($k+1..$#positions) {
        push @pairs, [ [@{$positions[$k]}], [@{$positions[$n]}] ];
    }
}

Note that, at this point, the rectangles represented by those point pairs may contain some 0s (we only know that the point pairs themselves are 1s). For example, the first point pair generated:

((0 1) (0 3))

corresponds to the following rectangle in the matrix:

1 0 1

As it can be seen, the bounds are 1s, but the middle item is 0. This is not a valid rectangle candidate.

In addition, we obtain pairs such as ((0 1) (3 0)) , which doesn’t define a valid rectangle because the second coordinate of the first pair (1) is larger than its counterpart in second pair, and we said earlier that the first pair must represent the top left point and the second pair the bottom right point of the rectangle. Here, the second point is to the left of the first. We need to eliminate these malformed rectangles.

The code below eliminates invalid rectangles and stores the others in the @eligible array:

my @eligible;
for my $p_ref (@pairs) {
    my @p = @$p_ref;
    # Remove malformed rectangles
    next if $p[0][0] > $p[1][0] or $p[0][1] > $p[1][1];
    # Remove rectangles containing 0s
    my $only_ones = 1;
    for my $i ($p[0][0].. $p[1][0]) {
        for my $j ($p[0][1]..$p[1][1]) {
            if ($m[$i][$j] == 0) {
                $only_ones = 0;
                next;
            }
        }
    }
     push @eligible, $p_ref if $only_ones;
}

If the @eligible array is empty, then we did not find any suitable rectangle. So, we print out 0 and exit the subroutine.

say "0\n" and return unless @eligible;

In the case of our first test matrix, there are six eligible rectangles left:

((2 0) (2 1))  ((2 0) (3 0))  ((2 0) (3 1))  ((2 1) (3 1))  ((2 3) (3 3))  ((3 0) (3 1))

We now need to find the largest rectangle. For this, we sort the eligible rectangles in descending order according to their area size and pick the first one in the sorted list. Since the comparison routine computing the rectangle area is somewhat complicated, we use a Schwartzian Transform for the sort:

my @sorted = map { $_->[0] } 
             sort { $b->[1] <=> $a->[1] }
             map { [$_, ($_->[1][0] - $_->[0][0] + 1) 
                   * ($_->[1][1] - $_->[0][1] + 1)] } 
                   @eligible;
my $rect = $sorted[0];

Now that we have found the largest rectangle, we only need to display the result.

This is the full code of the program:

use strict;
use warnings;
use feature "say";
use Data::Dumper;

my @matrices = 
    ( [ [ qw <0 1 0 1> ], [ qw <0 0 1 0> ], 
        [ qw <1 1 0 1> ], [ qw <1 1 0 1> ] 
      ], 

      [ [ qw <1 1 0 1> ], [ qw <1 1 0 0> ], 
        [ qw <0 1 1 1> ], [ qw <1 0 1 1> ] 
      ],

      [ [ qw <0 1 0 1> ], [ qw <1 0 1 0> ], 
        [ qw <0 1 0 0> ], [ qw <1 0 0 1> ] 
      ],

      [ [ qw <1 1 0 1 1 1> ], [ qw <1 1 1 0 1 0> ], 
          [ qw <1 1 0 1 0 1> ], [ qw <1 1 1 0 0 1> ] 
      ],

      [ [ qw <0 0 0 1 0 0> ], [ qw <1 1 1 0 0 0> ], 
          [ qw <0 0 1 0 0 1> ], [ qw <1 1 1 1 1 0> ], 
          [ qw <1 1 1 1 1 0>],
      ],
      [ [ qw <1 0 1 0 1 0> ], [ qw <0 1 0 1 0 1> ], 
          [ qw <1 0 1 0 1 0> ], [ qw <0 1 0 1 0 1> ],
      ],
      [ [ qw <0 0 0 1 1 1> ], [ qw <1 1 1 1 1 1> ], 
          [ qw <0 0 1 0 0 1> ], [ qw <0 0 1 1 1 1> ], 
          [ qw <0 0 1 1 1 1> ],
      ],
    );

for my $m_ref (@matrices) {
    print_matrix($m_ref);
    find_rect($m_ref);
}

sub print_matrix {
    my @matrix = @{$_[0]};
    say "";
    say "[ @$_ ]" for @matrix;
    say "";
}

sub find_rect {
    my @m = @{$_[0]};
    my $max_h = scalar @m;
    my $max_w = scalar @{$m[0]};
    my @positions;
    for my $i (0..$#m) {
        for my $j (0..$#{$m[0]}) {
            push @positions, [$i, $j] unless $m[$i][$j] == 0;
        }
    }
    my @pairs;
    for my $k (0..$#positions) {
        for my $n ($k+1..$#positions) {
            push @pairs, [ [@{$positions[$k]}], [@{$positions[$n]}] ];
        }
    }

    my @eligible;
    for my $p_ref (@pairs) {
        my @p = @$p_ref;
        next if $p[0][0] > $p[1][0] or $p[0][1] > $p[1][1];
        my $only_ones = 1;
        for my $i ($p[0][0].. $p[1][0]) {
            for my $j ($p[0][1]..$p[1][1]) {
                if ($m[$i][$j] == 0) {
                    $only_ones = 0;
                    next;
                }
            }
        }
         push @eligible, $p_ref if $only_ones;
    } 

    say 0 and return unless @eligible;

my @sorted = map { $_->[0] } 
             sort { $b->[1] <=> $a->[1] }
             map { [$_, ($_->[1][0] - $_->[0][0] + 1) 
                   * ($_->[1][1] - $_->[0][1] + 1)] } 
                   @eligible;
    my $rect = $sorted[0];
    say "Rectangle corners: ";
    say "@$_" for @$rect; 
    say "\nRectangle:";

    for my $row ($rect->[0][0]..$rect->[1][0]) {
        say "@{$m[$row]}[$rect->[0][1]..$rect->[1][1]]";
    }
    say "";
}

This script displays the following output:

$ perl  rectangular-matrix.pl

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

Rectangle corners:
2 0
3 1

Rectangle:
1 1
1 1


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

Rectangle corners:
0 0
1 1

Rectangle:
1 1
1 1


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

0

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

Rectangle corners:
0 0
3 1

Rectangle:
1 1
1 1
1 1
1 1


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

Rectangle corners:
3 0
4 4

Rectangle:
1 1 1 1 1
1 1 1 1 1


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

0

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

Rectangle corners:
3 2
4 5

Rectangle:
1 1 1 1
1 1 1 1

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

Perl Weekly Challenge 86: Pair Differences and Sudoku Puzzles

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

Spoiler Alert: This weekly challenge deadline is due in a day or so (November 15, 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: Pair Differences

You are given an array of integers @N and an integer $A.

Write a script to find find if there exists a pair of elements in the array whose difference is $A.

Print 1 if exists otherwise 0.

Example 1:

Input: @N = (10, 8, 12, 15, 5) and $A = 7
Output: 1 as 15 - 8 = 7

Example 2:

Input: @N = (1, 5, 2, 9, 7) and $A = 6
Output: 1 as 7 - 1 = 6

Example 3:

Input: @N = (10, 30, 20, 50, 40) and $A = 15
Output: 0

I’ll print not only 1 or 0, but also the first pair found (if any), as it makes it easier to check that the program is correct.

Pair Differences in Raku

For this, we use the combinations method to generate all (unordered) pairs from the input array of integers. Then, we compare the absolute value of the difference between the two integers of the pair with the target, and print out the pair if there is a match. Then we print 1 if we found such pair, and 0 otherwise.

use v6;

my @tests = [ 7, [10, 8, 12, 15, 5]],
            [ 6, [1, 5, 2, 9, 7]], 
            [15, [10, 30, 20, 50, 40]],
            [9, [7, 20, 15, 11, 12]];
for @tests -> @R {
    my $found = False;
    my $target = @R[0];
    say "Testing: target: $target and @R[1]";
    for @R[1].combinations(2) -> $candidate {
        $found = True and say $candidate and last 
            if abs($candidate[0] - $candidate[1]) == $target;
    }
    say +$found;
}

Note that there may be several solutions, but we only print the first one since we are requested to check whether such a pair exists. My initial program found two pairs ((8 15) and (12 5)) for the first test case, but I changed it to print only the first pair.

Output:

Testing: target: 7 and 10 8 12 15 5  # Note: 2 solutions: 8 15 and 12 5
(8 15)
1
Testing: target: 6 and 1 5 2 9 7
(1 7)
1
Testing: target: 15 and 10 30 20 50 40
0
Testing: target: 9 and 7 20 15 11 12
(20 11)
1

Pair Differences in Perl

This is basically a port to Perl of the Raku program above. Please refer to the explanations above if needed. The only significant difference is that Perl doesn’t have a built-in combinations function, so we use two nested forloops to generate all the integer pairs.

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

my @tests = ( [ 7, [10, 8, 12, 15, 5]],
              [ 6, [1, 5, 2, 9, 7]], 
              [ 15, [10, 30, 20, 50, 40]],
              [ 9, [7, 20, 15, 11, 12]],
            );
for my $R (@tests) {
    my ($target, $test_ref) = @$R;
    my @test = @$test_ref;
    my $found = 0;
    say "Testing: target: $target and @test";
    OUT: for my $i (0..$#test) {
        for my $j ($i..$#test) {
            if (abs($test[$i] - $test[$j]) == $target) {
                $found = 1;
                say +$found, " ($test[$i] $test[$j])" if $found;
                last OUT;
            }

        }

    }
    say "0" unless $found;
}

This is the output generated by this script:

$ perl pair_difference.pl
Testing: target: 7 and 10 8 12 15 5
1 (8 15)
Testing: target: 6 and 1 5 2 9 7
1 (1 7)
Testing: target: 15 and 10 30 20 50 40
0
Testing: target: 9 and 7 20 15 11 12
1 (20 11)

Task 2: Sudoku Puzzles

You are given Sudoku puzzle (9x9).

Write a script to complete the puzzle and must respect the following rules: a) Each row must have the numbers 1-9 occuring just once. b) Each column must have the numbers 1-9 occuring just once. c) The numbers 1-9 must occur just once in each of the 9 sub-boxes (3x3) of the grid.

Example:

[ _ _ _ 2 6 _ 7 _ 1 ]
[ 6 8 _ _ 7 _ _ 9 _ ]
[ 1 9 _ _ _ 4 5 _ _ ]
[ 8 2 _ 1 _ _ _ 4 _ ]
[ _ _ 4 6 _ 2 9 _ _ ]
[ _ 5 _ _ _ 3 _ 2 8 ]
[ _ _ 9 3 _ _ _ 7 4 ]
[ _ 4 _ _ 5 _ _ 3 6 ]
[ 7 _ 3 _ 1 8 _ _ _ ]

Output:

[ 4 3 5 2 6 9 7 8 1 ]
[ 6 8 2 5 7 1 4 9 3 ]
[ 1 9 7 8 3 4 5 6 2 ]
[ 8 2 6 1 9 5 3 4 7 ]
[ 3 7 4 6 8 2 9 1 5 ]
[ 9 5 1 7 4 3 6 2 8 ]
[ 5 1 9 3 2 6 8 7 4 ]
[ 2 4 8 9 5 7 1 3 6 ]
[ 7 6 3 4 1 8 2 5 9 ]

I have been a great fan of sudoku puzzles ever since they started to become popular in newspapers around 2005. At the time, after having solved manually sudoku puzzles for a few weeks, I wrote a Perl program to solve sudoku puzzles. I unfortunately no longer have this program (I guess I forgot to copy it when I changed computer). This program had a number of features. It could check if a grid was a valid sudoku puzzle (a valid puzzle should have one and only one solution). It implemented five or six different deductive strategies, but I quickly found that some relatively rare grids resisted all deductive approaches (even combined together and repeated). So I had to implement a backtracking brute force algorithm testing out all possibilities for such cases (this is less efficient than deductive approaches in most cases, but it still runs fairly fast). The program could also generate new puzzles.

Here, I’ll employ only one deductive approach (for each hole, check whether there is one and only one possible integer), and loop again until the puzzle is solved or until we can no longer fill a hole with this approach. In the latter case, we employ backtracking brute force. We’ll assume that the input grid a valid sudoku puzzle.

Note that both my Raku and Perl programs start with a grid similar to the example provided in the task description, with underscores to indicate the holes, but the first thing I do is to replace underscores by 0s, because it makes it possible to use numeric comparison operators in the rest of the program.

Sudoku Puzzles in Raku

The most important subroutine is perhaps is-allowed-digit, which, for a given position in the grid and an integer candidate checks that it is a valid candidate, i.e. the row, column and sub-grid don’t contain this candidate.

The next important thing is the while loop. It scans the whole grid and, for each empty position, calls is-allowed-digit for every integer between 1 and 9. If only one integer is allowed, the hole is filled with that candidate. One it has completed this scan, it does it again until there is no hole left (we have the solution) or until one such scan did not find any hole to be filled. In the latter case, the program calls the recursive brute-force-find subroutine, which tries out all possibilities for the remaining holes and backtracks whenever it reaches a dead end.

use v6;

constant MAX = 8;
my @grid =
    [ < _ _ _ 2 6 _ 7 _ 1 > ],
    [ < 6 8 _ _ 7 _ _ 9 _ > ],
    [ < 1 9 _ _ _ 4 5 _ _ > ],
    [ < 8 2 _ 1 _ _ _ 4 _ > ],
    [ < _ _ 4 6 _ 2 9 _ _ > ],
    [ < _ 5 _ _ _ 3 _ 2 8 > ],
    [ < _ _ 9 3 2 _ _ 7 4 > ],
    [ < _ 4 _ _ 5 _ _ 3 6 > ],
    [ < 7 _ 3 _ 1 8 _ _ _ > ];

# Replaces _ with 0 and numify values
for @grid <-> $line {
    for @$line <-> $item {
        $item = $item eq '_' ?? 0 !! +$item;
    }
}
.say for @grid; say "";
my %square;
for 0..MAX {
    when 0..2 { %square{$_} = |(0..2)}
    when 3..5 { %square{$_} = |(3..5)}
    when 6..8 { %square{$_} = |(6..8)}
}

sub is-allowed-digit (@grid, Int $k, $position) {
    my ($i, $j) = $position[0, 1];
    return False if $k == @grid[$i].any;         # line
    for 0..MAX -> $n {                           # column
        return False if $k == @grid[$n][$j];
    }
    for %square{$i} -> $m {                      # Square
        return False if $k == (@grid[$m][|%square{$j}]).any;
    } 
    True; 
}

my $solution-found = False;
my $continue = True;
while $continue {
    my $one-change-made = False;
    my $no-hole-left = True;;
    for 0..MAX -> $row {
        for 0..MAX -> $col {
            next if @grid[$row][$col];
            # $no-hole-left = False;
            my @candidates = gather {
                for 1..9 -> $candidate {
                    take $candidate if 
                        is-allowed-digit @grid, $candidate, [$row, $col];
                }
            }
            if @candidates.elems == 1 {
                @grid[$row][$col] = @candidates[0];
                $one-change-made = True;
            } else {
                $no-hole-left = False;
            }
        }
    }
    # .say for @grid;  say ""; # uncomment to see the progress on each iteration
    $solution-found = $no-hole-left;
    $continue = (! $no-hole-left) && $one-change-made;
}
if $solution-found {
say "Solution:";
    .say for @grid;
} else {
    brute-force-find(@grid, 0);
}

sub brute-force-find (@grid is copy, Int $row-id) {
     for 0..MAX -> $i {
        my $hole = (grep {@grid[$i][$_] == 0}, 0..8)[0];
        unless defined $hole {
            if $i == MAX {
                # We've found a solution (no hole, last row)
                .say for @grid;
                return;
            } else {
                next; # No hole, process next row
            }
        }
        my $found_candidate = False;
        for 1..9 -> $k {
            if is-allowed-digit(@grid, $k, [$i, $hole]) {
                @grid[$i][$hole] = $k;
                $found_candidate = True;
                brute-force-find(@grid, $i);
            }
        }
        # we are in a deadend if we did not find any suitable candidate 
        # for the hole. Backtracking needed
        return unless $found_candidate;
    }
}

The program displays the initial grid (after having replaced the underscores with 0s) and the solution:

$ raku sudoku.raku
[0 0 0 2 6 0 7 0 1]
[6 8 0 0 7 0 0 9 0]
[1 9 0 0 0 4 5 0 0]
[8 2 0 1 0 0 0 4 0]
[0 0 4 6 0 2 9 0 0]
[0 5 0 0 0 3 0 2 8]
[0 0 9 3 2 0 0 7 4]
[0 4 0 0 5 0 0 3 6]
[7 0 3 0 1 8 0 0 0]

Solution:
[4 3 5 2 6 9 7 8 1]
[6 8 2 5 7 1 4 9 3]
[1 9 7 8 3 4 5 6 2]
[8 2 6 1 9 5 3 4 7]
[3 7 4 6 8 2 9 1 5]
[9 5 1 7 4 3 6 2 8]
[5 1 9 3 2 6 8 7 4]
[2 4 8 9 5 7 1 3 6]
[7 6 3 4 1 8 2 5 9]

You may uncomment this code line:

# .say for @grid;  say "";

to see the progress on each iteration of the while loop. Note that this sudoku grid was solved after two iterations of the while loop and therefore did not require any call to the brute force subroutine (and I believe that most sudoku grids don’t need it, only a small proportion of them do).

Sudoku Puzzles in Perl

This is a direct port to Perl of the Raku program above. Please refer to the explanations above if needed.

use strict;
use warnings;
use feature "say";
use constant MAX => 8;

my @grid =
    ( [ qw < _ _ _ 2 6 _ 7 _ 1 > ],
      [ qw < 6 8 _ _ 7 _ _ 9 _ > ],
      [ qw < 1 9 _ _ _ 4 5 _ _ > ],
      [ qw < 8 2 _ 1 _ _ _ 4 _ > ],
      [ qw < _ _ 4 6 _ 2 9 _ _ > ],
      [ qw < _ 5 _ _ _ 3 _ 2 8 > ],
      [ qw < _ _ 9 3 2 _ _ 7 4 > ],
      [ qw < _ 4 _ _ 5 _ _ 3 6 > ],
      [ qw < 7 _ 3 _ 1 8 _ _ _ > ]
    );

# Replaces _ with 0 and numify values
for my $line (@grid) {
    for my $item (@$line) {
        $item = $item eq '_' ? 0 : +$item;
    }
}
say "[ @$_ ]" for @grid; say "";

my %square;
for my $i (0..MAX) {
    $square{$i} = $i <= 2 ? [0..2] :
                  $i >= 6 ? [6..8] :
                  [3..5]; 
}

sub is_allowed_digit {
    my ($grid_ref, $k, $position_ref) = @_;
    my @grid = @$grid_ref;
    my ($i, $j) = @$position_ref;
    return 0 if grep $_ == $k, @{$grid[$i]};       # line
    for my $n (0..MAX) {                           # column
        return 0 if $k == $grid[$n][$j];
    }
    for my $m (@{$square{$i}}) {                   # Square
        return 0 if grep { $k == $grid[$m][$_] } @{$square{$j}};
    } 
    return 1; 
}

my $solution_found = 0;
my $continue = 1;
while ($continue) {
    my $one_change_made = 0;
    my $no_hole_left = 1;
    for my $row (0..MAX) {
        for my $col (0..MAX) {
            next if $grid[$row][$col];
            my @candidates; 
            for my $candidate (1..9) {
                push @candidates, $candidate if 
                    is_allowed_digit(\@grid, $candidate, [$row, $col]);
            }
            if (@candidates == 1) {
                $grid[$row][$col] = $candidates[0];
                $one_change_made = 1;
            } else {
                $no_hole_left = 0;
            }
        }
    }
    # say "[ @$_ ]" for @grid;  say "";
    $solution_found = $no_hole_left;
    $continue = (! $no_hole_left) && $one_change_made;
}
if ($solution_found) {
say "Solution:";
    say "[ @$_ ]" for @grid;
} else {
    brute_force_find(@grid, 0);
}   

sub brute_force_find {
    my @grid = @$_[0];
    my $row_id = $_[1];
    for my $i (0..MAX) {
        my $hole = (grep {$grid[$i][$_] == 0} 0..8)[0];
        unless (defined $hole) {
            if ($i == MAX) {
                # We've found a solution (no hole, last row)
                say "[ @$_ ]" for @grid;
                return;
            } else {
                next; # No hole, process next row
            }
        }
        my $found_candidate = 0;
        for my $k (1..9) {
            if (is_allowed_digit(@grid, $k, [$i, $hole])) {
                $grid[$i][$hole] = $k;
                $found_candidate = 1;
                brute_force_find(@grid, $i);
            }
        }
        # we are in a deadend if we did not find any suitable candidate 
        # for the hole. Backtracking is needed.
        return unless $found_candidate;
    }
}

Output:

$ perl  sudoku.pl
[ 0 0 0 2 6 0 7 0 1 ]
[ 6 8 0 0 7 0 0 9 0 ]
[ 1 9 0 0 0 4 5 0 0 ]
[ 8 2 0 1 0 0 0 4 0 ]
[ 0 0 4 6 0 2 9 0 0 ]
[ 0 5 0 0 0 3 0 2 8 ]
[ 0 0 9 3 2 0 0 7 4 ]
[ 0 4 0 0 5 0 0 3 6 ]
[ 7 0 3 0 1 8 0 0 0 ]

Solution:
[ 4 3 5 2 6 9 7 8 1 ]
[ 6 8 2 5 7 1 4 9 3 ]
[ 1 9 7 8 3 4 5 6 2 ]
[ 8 2 6 1 9 5 3 4 7 ]
[ 3 7 4 6 8 2 9 1 5 ]
[ 9 5 1 7 4 3 6 2 8 ]
[ 5 1 9 3 2 6 8 7 4 ]
[ 2 4 8 9 5 7 1 3 6 ]
[ 7 6 3 4 1 8 2 5 9 ]

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

Perl Weekly Challenge 85: Triplet Sum and Power of Two Integers

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

Spoiler Alert: This weekly challenge deadline is due in a day or so (November 8, 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: Triplet Sum

You are given an array of real numbers greater than zero.

Write a script to find if there exists a triplet (a,b,c) such that 1 < a+b+c < 2. Print 1 if you succeed otherwise 0.

Example 1:

Input: @R = (1.2, 0.4, 0.1, 2.5)
Output: 1 as 1 < 1.2 + 0.4 + 0.1 < 2

Example 2:

Input: @R = (0.2, 1.5, 0.9, 1.1)
Output: 0

Example 3:

Input: @R = (0.5, 1.1, 0.3, 0.7)
Output: 1 as 1 < 0.5 + 1.1 + 0.3 < 2

Triplet Sum in Raku

We basically need to find from the input array a combination of 3 numbers whose sum is larger than 1 and less than 2. Raku has a built-in combinations routine to generate a Seq of all combinations of three (or any other number of) items from an input list. Then, for each triplet generated from each input array, we set a Boolean flag ($found) to False, compute the sum, and, if the sum matches the range criteria, we print the triplet (this is not requested in the task specification, but it helps checking the result) and set the $Found flag to True. At the end, we print a numified version of the Boolean flag.

use v6;

my @tests = [1.2, 0.4, 0.1, 2.5],
            [0.2, 1.5, 0.9, 1.1], 
            [0.5, 1.1, 0.3, 0.7],
            [0.7, 4.3, -0.1, 1.1];
for @tests -> @R {
    my $found = False;
    say "Testing: @R[]";
    for @R.combinations(3) -> $candidate {
        $found = True and say $candidate 
      if 1 < $candidate.sum < 2;
    }
    say +$found;
}

This script produces the following output:

$ raku triplet-sum.raku
Testing: 1.2 0.4 0.1 2.5
(1.2 0.4 0.1)
1
Testing: 0.2 1.5 0.9 1.1
0
Testing: 0.5 1.1 0.3 0.7
(0.5 1.1 0.3)
(0.5 0.3 0.7)
1
Testing: 0.7 4.3 -0.1 1.1
(0.7 -0.1 1.1)
1

Triplet Sum in Perl

Perl doesn’t have a built-in combinations function. There are some CPAN modules providing this feature, and I would use one of them in a real life problem, but, as I have said a number of times before, I eschew using modules in a coding challenge and prefer to detail a pure-Perl algorithm. When I want to generate combinations from an input list, I often like to use a recursive implementation to do so. However, since we’re interested here only with triplets, I decided rather to use three nested for loops to generate all possible triplets. The upside is that we can exit the loops as soon as we find a triplet matching the range condition.

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

my @tests = ([1.2, 0.4, 0.1, 2.5],
             [0.2, 1.5, 0.9, 1.1], 
             [0.5, 1.1, 0.3, 0.7],
             [0.7, 4.3, -4.1, 1.1]
            );
for my $R (@tests) {
    say "Testing: @$R";
    say test_candidates(@$R);
}
sub test_candidates {
    my @in = @_;
    for my $i (0..$#in) {
        for my $j ($i+1..$#in) {
            for my $k ($j+1..$#in) {
                my $sum = $in[$i] + $in[$j] + $in[$k];
                next if $sum < 1 or $sum > 2;
                say "@in[$i, $j, $k]";
                return 1;
            }
        }
    }
    return 0;
}

This script displays the following output:

$ perl  triplet-sum.pl
Testing: 1.2 0.4 0.1 2.5
1.2 0.4 0.1
1
Testing: 0.2 1.5 0.9 1.1
0
Testing: 0.5 1.1 0.3 0.7
0.5 1.1 0.3
1
Testing: 0.7 4.3 -4.1 1.1
4.3 -4.1 1.1
1

Task 2: Power of Two Integers

You are given a positive integer $N.

Write a script to find if it can be expressed as a ** b where a > 0 and b > 1. Print 1 if you succeed otherwise 0.

Example 1:

Input: 8
Output: 1 as 8 = 2 ** 3

Example 2:

Input: 15
Output: 0

Example 3:

Input: 125
Output: 1 as 125 = 5 ** 3

One small comment: although this is not explicitly stated in the task specification, a and b have to be integers. If either of the two numbers is not an integer, then there is no way a ** b can be an integer (except for the trivial edge case where b is 0 and $N is 1, but we’re told that b > 1).

I can see at least two approaches (with some possible variations).

One is trying all combinations of a and b where a ** b doesn’t become larger than the target integer. Although this is a brute force solution with a combinatorial explosion, it is likely to be relatively fast (except possibly for very large input integers), because powers grow so fast that the number of possibilities to be tested tends to remain quite small.

The other approach is to factorize the input value (i.e. to perform prime factor decomposition) and to find out from the list of factors and their respective exponents whether the input value can be a perfect square, cube or other power of some integer. To find whether an integer can be expressed as an integer power of an integer, we don’t really care about the factors themselves (which we know to be prime), but are interested with their relative exponents. Suppose we have a list of exponents, @exponents. It is quite clear that if any exponent is equal to 1, there will be no solution. If all exponents are equal (and larger than 1), then there is an obvious solution (a is the product of the individual prime factors, and b is the common exponent. This can be expressed in Raku as follows:

return 0 if @exponent.any == 1;
return 1 if [==] @exponents;

But if the factors of $N are, for example: a ** 2 and b ** 6, then $N can be expressed as a perfect square: (a * b ** 3) ** 2. For example, if a = 3 and b = 2 (and $Z = 576), we have: $Z = (3 * 2 * 3) * 2 = (3 * 8) * 2 = 24 * 2 = 576. How do we generalize that to more prime factors with various exponents. It is quite easy to see that, irrespective of the prime factor values, the problem will have a solution if the greatest common divisor (GCD) of the exponents is larger that 1. In Raku or Perl pseudo-code:

return 1 if GCD(@exponents) > 1;

This condition is sufficient and we no longer need the first two conditions: if any of the exponents is 1, then the GCD will be 1; and if all exponents are equal (and larger than 1), then the GCD will be the value of any of the exponents.

Power of Two Integers in Raku

We will implement both approaches detailed above.

Brute Force Approach

The first one is a brute force approach trying all valid combinations:

use v6;

my $n = @*ARGS[0].Int // 15;
say find-power $n;

sub find-power (Int $n) {
    return 1 if $n == 1; # trivial solution: 1 ** 2
    OUTERLOOP: for 2..$n.sqrt.Int -> $base {
        my $exp = 2;
        loop {
            my $power = $base ** $exp;
            return 1 if $power == $n;
            next OUTERLOOP if $power > $n;
            $exp++;
        }
    }
    return 0;
}

This works as expected:

$ raku perfect-power-int2.raku 144
1

$ raku perfect-power-int2.raku 145
0

$ raku perfect-power-int2.raku 1451
0

$ raku perfect-power-int2.raku 1
1

Prime Factor Decomposition Approach

The other approach it to perform a factorization of the input integer and to use the GCD of the factors’ exponents:

use v6;

my $n = @*ARGS[0] // 15;
sub find-factors ($n is copy) {
    my %factors;
    my $max = ($n/2).Int;
    for 2..$max -> $i {
        while  $n %% $i {
            %factors{$i}++;
            $n /= $i;
        }
    }
    say %factors;
    return 1 if 1 < [gcd] %factors.values;
    return 0;
}
say find-factors $n;

Some sample runs:

$ raku perfect-power-int.raku 144
{2 => 4, 3 => 2}
1

$ raku perfect-power-int.raku 72
{2 => 3, 3 => 2}
0

$ raku perfect-power-int.raku 12
{2 => 2, 3 => 1}
0

$ raku perfect-power-int.raku 40000
{2 => 6, 5 => 4}
1

Although the second approach is intellectually more satisfactory, the first approach is both simpler and probably more efficient most of the time.

Power of Two Integers in Perl

This is the second approach (using the GCD) described above implemented in Perl:

use strict;
use warnings;
use feature "say";
use Data::Dumper;

sub gcd2 {
    my ($i, $j) = sort { $a <=> $b } @_;
    while ($j) {
        ($i, $j) = sort { $b <=> $a } ($j, $i % $j);
    }
    return $i;
}
sub gcd_all {
    my @nums = sort {$a <=> $b } @_;
    return $nums[0] if @nums == 1;
    my $i = shift @nums;
    my $gcd;
    for my $j (@nums) {
        $gcd = gcd2 ($i, $j);
        $i = $gcd;
    }
    return $gcd;
}
sub find_factors {
    my $n = shift;
    my %factors;
    my $max = int $n/2;
    for my $i (2..$max) {
        while ($n % $i == 0) {
            $factors{$i}++;
            $n /= $i;
        }
    }
    say Dumper \%factors;
    return 1 if gcd_all (values %factors) > 1;
    return 0;
}
my $n = shift // 8;
say find_factors $n;

This script displays the following output:

$ perl perfect-power-int.pl 8
$VAR1 = {
          '2' => 3
        };

1

$ perl perfect-power-int.pl 24
$VAR1 = {
          '2' => 3,
          '3' => 1
        };

0

$ perl perfect-power-int.pl 144
$VAR1 = {
          '2' => 4,
          '3' => 2
        };

1

$ perl perfect-power-int.pl 10000
$VAR1 = {
          '2' => 4,
          '5' => 4
        };

1

$ perl perfect-power-int.pl 2500
$VAR1 = {
          '2' => 2,
          '5' => 4
        };

1

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

Perl Weekly Challenge 84: Reverse Integer and Find Square Matrices

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

Spoiler Alert: This weekly challenge deadline is due in a few days (November 1, 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: Reverse Integer

You are given an integer $N.

Write a script to reverse the given integer and print the result. Print 0 if the result doesn’t fit in 32-bit signed integer.

The number 2,147,483,647 is the maximum positive value for a 32-bit signed binary integer in computing.

Example 1:

Input: 1234
Output: 4321

Example 2:

Input: -1234
Output: -4321

Example 3:

Input: 1231230512
Output: 0

Note that the minimal value for signed negative integers is - 2 ** 31, i.e. - 2,147,483,648.

Reverse Integer in Raku

We first check if the input integer is negative and, if so, we take its absolute value and record the fact that the input was negative. Then, we just flip the digits. We set the result to 0 if the result exceeds the 32-bit limit for signed integers. We turn the result to a negative integer if the input integer was negative (and, by the way, numify the result to get rid of leading 0’s if any.

use v6;

constant $max = 2 ** 31 - 1; # i.e. 2_147_483_647

my $input = @*ARGS[0] // 1234;
my $positive = True;
if $input < 0 {
    $positive = False;
    $input = -$input;
}
my $output = $input.flip;
$output = 0 if $positive and $output >= $max;
$output = 0 if $output >= $max + 1; # 32-bit negative numbers can go up to 2 ** 31
# No specification for inputs ending with 0
# We numify $output and negate it if needed
$output = $positive ?? +$output !! -$output;
say $output;

Sample output for a few input values:

$ raku reverse-int.raku
4321

$ raku reverse-int.raku -1234
-4321

$ raku reverse-int.raku 1231230512
0

$ raku reverse-int.raku 1231230500
50321321

$ raku reverse-int.raku -1231230500
-50321321

Reverse Integer in Perl

This is simply a port to Perl of the Raku program above, please refer to the explanations above if needed.

use strict;
use warnings;
use feature "say";
use constant MAX => 2 ** 31 - 1; # i.e. 2_147_483_647

my $input = shift  // 1234;
my $positive = 1;
if ($input < 0) {
    $positive = 0;
    $input = -$input;
}
my $output = reverse $input;
$output = 0 if $positive and $output > MAX;
$output = 0 if $output > MAX + 1;
# No specification for inputs ending with 0
# We numify $output and negate it if needed
$output = $positive ? $output + 0 : -$output;
say $output;

Output for a few sample input values:

$ perl reverse-int.pl
4321

$ perl reverse-int.pl -1234
-4321

$ perl reverse-int.pl 1231230512
0

$ perl reverse-int.pl 1231230500
50321321

$ perl reverse-int.pl -1231230500
-50321321

Task 2: Find Square Matrices

You are given matrix of size m x n with only 1 and 0.

Write a script to find the count of squares having all four corners set as 1.

Example 1:

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

Output: 1

Explanation:
There is one square (3x3) in the given matrix with four corners as 1 starts at r=1;c=2.

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

Example 2:

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

Output: 4

Explanation:
There is one square (4x4) in the given matrix with four corners as 1 starts at r=1;c=1.
There is one square (3x3) in the given matrix with four corners as 1 starts at r=1;c=2.
There are two squares (2x2) in the given matrix with four corners as 1. First starts at r=1;c=1 and second starts at r=3;c=3.

Example 3:

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

Output: 0

Find Square Matrices in Raku

We first define an array of arrays of arrays representing an array of four matrices for our tests. We define a simple print-matrix subroutine to display any matrix in a human-eye friendly format. All the work is done in the find-squares subroutine, which contains three nested for loops: we loop on the possible square matrix sizes (between 2 and the smaller dimension of the input matrix), and then, for each possible size, we loop on each matrix item to see if that item can be the top left corner of a square matrix of the relevant size with each corner set to 1. If any of the four corners is 0, we move to the next item or to the next possible size once we have visited all relevant items with one size. Note that we print much more than what is requested in the task specification because we want to check the results (it would be very easy to remove these extra printed lines by commenting out the say statement near the end of the find-squares subroutine).

my @mat = [ [ [<0 1 0 1>], [<0 0 1 0>], [<1 1 0 1>], [<1 0 0 1>] ], 
            [ [<1 1 0 1>], [<1 1 0 0>], [<0 1 1 1>], [<1 0 1 1>] ],
            [ [<0 1 0 1>], [<1 0 1 0>], [<0 1 0 0>], [<1 0 0 1>] ],
            [ [<1 1 0 1 1 1>], [<1 1 1 0 1 0>], [<1 1 0 1 0 1>], 
                [<1 1 1 0 0 1>] ],
          ];

for @mat -> @m {
    print-matrix @m;
    say "Number of matrices: ", find-squares(@m), "\n";
}
sub print-matrix (@matrix) {
    for @matrix -> @row {
        say '[ ', @row.join(" "), ' ]';
    }
    say " ";
}

sub find-squares (@matrix) {
    my $nb_lines = @matrix.elems;
    my $nb_col = @matrix[0].elems;
    my $nb_squares = 0;
    my $max_square_size = min $nb_lines, $nb_col;
    for 2..$max_square_size -> $square_size {
        for 0..$nb_col - $square_size -> $j {
            for 0..$nb_lines - $square_size -> $i {
                next if @matrix[$i][$j] == 0;
                next if @matrix[$i][$j+$square_size-1] == 0;
                next if @matrix[$i+$square_size-1][$j] == 0;
                next if @matrix[$i+$square_size-1][$j+$square_size-1] == 0;
                say "Value in position $i, $j is the top left corner of a square of size $square_size";
                $nb_squares++;
            }
        }
    }
    return $nb_squares;
}

With the four sample input matrices, the program displays the following results:

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

Value in position 0, 1 is the top left corner of a square of size 3
Number of matrices: 1

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

Value in position 0, 0 is the top left corner of a square of size 2
Value in position 2, 2 is the top left corner of a square of size 2
Value in position 0, 1 is the top left corner of a square of size 3
Value in position 0, 0 is the top left corner of a square of size 4
Number of matrices: 4

[ 0 1 0 1 ]
[ 1 0 1 0 ]
[ 0 1 0 0 ]
[ 1 0 0 1 ]  
Number of matrices: 0

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

Value in position 0, 0 is the top left corner of a square of size 2
Value in position 1, 0 is the top left corner of a square of size 2
Value in position 2, 0 is the top left corner of a square of size 2
Value in position 1, 0 is the top left corner of a square of size 3
Value in position 0, 1 is the top left corner of a square of size 3
Value in position 0, 3 is the top left corner of a square of size 3
Number of matrices: 6

Find Square Matrices in Perl

This is a port to Perl of the Raku program immediately above, please refer to the explanations above if needed.

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

my @mat = ( [ [ qw<0 1 0 1> ], [ qw<0 0 1 0> ], [ qw<1 1 0 1> ], 
              [ qw<1 0 0 1> ] ], 
            [ [ qw<1 1 0 1> ], [ qw<1 1 0 0> ], [ qw<0 1 1 1> ], 
              [ qw<1 0 1 1> ] ],
            [ [ qw<0 1 0 1> ], [ qw<1 0 1 0> ], [ qw<0 1 0 0> ], 
              [ qw<1 0 0 1> ] ],
            [ [ qw<1 1 0 1 0 1> ], [ qw<1 0 1 0 1 1> ], 
              [ qw<1 1 0 0 1 0> ], [ qw<1 1 0 1 1 1> ] ],
          );

for my $m_ref (@mat) {
    print_matrix($m_ref);
    say "Number of matrices: ", find_squares($m_ref);
}
sub print_matrix {
    my @matrix = @{$_[0]};
    say "";
    for my $row (@matrix) {
        say '[ ', join (" ", @$row), ' ]';
    }
    say " ";
}

sub find_squares {
    my @matrix = @{$_[0]};
    my $nb_lines = scalar @matrix;
    my $nb_col = scalar @{$matrix[0]};
    my $nb_squares = 0;
    my $max_square_size = $nb_lines > $nb_col ? $nb_col : $nb_lines;
    for my $square_size (2..$max_square_size) {
        for my $j (0..$nb_col - $square_size) {
            for my $i (0..$nb_lines - $square_size) {
                next if $matrix[$i][$j] == 0;
                next if $matrix[$i][$j+$square_size-1] == 0;
                next if $matrix[$i+$square_size-1][$j] == 0;
                next if $matrix[$i+$square_size-1][$j+$square_size-1] == 0;
                say "Value in position $i, $j is the top left corner of a square of size $square_size";
                $nb_squares++;
            }
        }
    }
    return $nb_squares;
}

With the four sample input matrices, the program displays the following results:

$ perl square-matrix.pl

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

Value in position 0, 1 is the top left corner of a square of size 3
Number of matrices: 1

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

Value in position 0, 0 is the top left corner of a square of size 2
Value in position 2, 2 is the top left corner of a square of size 2
Value in position 0, 1 is the top left corner of a square of size 3
Value in position 0, 0 is the top left corner of a square of size 4
Number of matrices: 4

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

Number of matrices: 0

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

Value in position 2, 0 is the top left corner of a square of size 2
Value in position 0, 0 is the top left corner of a square of size 4
Number of matrices: 2

Note that the last example input matrix is not the same as the one in the Raku program, this is the reason why the result is different.

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