Perl Weekly Challenge 298.

My solutions (task 1 and task 2 ) to the The Weekly Challenge - 298.

Task 1: Maximal Square

Submitted by: Mohammad Sajid Anwar
You are given an m x n binary matrix with 0 and 1 only.

Write a script to find the largest square containing only 1's and return it’s area.

Example 1
Input: @matrix = ([1, 0, 1, 0, 0],
                  [1, 0, 1, 1, 1],
                  [1, 1, 1, 1, 1],
                  [1, 0, 0, 1, 0])
Output: 4

Two maximal square found with same size marked as 'x':

[1, 0, 1, 0, 0]
[1, 0, x, x, 1]
[1, 1, x, x, 1]
[1, 0, 0, 1, 0]

[1, 0, 1, 0, 0]
[1, 0, 1, x, x]
[1, 1, 1, x, x]
[1, 0, 0, 1, 0]
Example 2
Input: @matrix = ([0, 1],
                  [1, 0])
Output: 1

Two maximal square found with same size marked as 'x':

[0, x]
[1, 0]


[0, 1]
[x, 0]
Example 3
Input: @matrix = ([0])
Output: 0

I can check squares one row and column at a time. For example, if I have found a 2x2 square,

[...1 1 x ...]
[...1 1 x ...]
[...y y y ...]

I might have a 3x3 square if all x’s and y’s in the picture above are ones. Thus, I can scan the array looking for the upper-left corner of a square, finding how large it is and recording the maximum obtained. If I have a square of size k and grow it to size k+1, the area grows by 2*k+1.Using PDL the code becomes a 3-liner:

perl -MPDL -MPDL::NiceSlice -E '
for(@ARGV){$a=pdl($_);$m=0;for $i(0..$a->dim(0)-1){R:for $j(0..$a->dim(1)-1){
for $k(0..$a->dim(0)-1-$i){next R if$k+$j>=$a->dim(1) ||!($a($i:$i+$k,$j+$k)->all
&& $a($i+$k,$j:$j+$k)->all);$m<=$k&&++$m;}}}say "$a -> ",$m**2;}
' "[[1 0 1 0 0][1 0 1 1 1][1 1 1 1 1][1 0 0 1 0]]" "[ [0 1][1 0] ]" "[[ 0 ]]"

Results:

[
 [1 0 1 0 0]
 [1 0 1 1 1]
 [1 1 1 1 1]
 [1 0 0 1 0]
]
 -> 4

[
 [0 1]
 [1 0]
]
 -> 1

[
 [0]
]
 -> 0

The corresponding full code is:

 1  # Perl weekly challenge 298
 2  # Task 1:  Maximal Square
 3  #
 4  # See https://wlmb.github.io/2024/12/02/PWC298/#task-1-maximal-square
 5  use v5.36;
 6  use PDL;
 7  use PDL::NiceSlice;
 8  die <<~"FIN" unless @ARGV;
 9      Usage: $0 M1 M2...
10      to find the area of the largest submatrix of ones within
11      each of the binary matrices M1 M2...
12      Mi is a string that describes a PDL ndarray, such as
13      "[[X00 X01...][X10 X11...][...]...]"
14      FIN
15  for(@ARGV){
16      my $matrix=pdl($_);
17      my ($size_x, $size_y)=$matrix->dims;
18      my $max=0;
19      my $sm=pdl[[]];
20      for my $x(0..$size_x-1){
21        ROW: for my $y(0..$size_y-1){
22            for my $size(0..$matrix->dim(0)-1-$x){
23                next ROW if $size+$y>=$matrix->dim(1)
24                    ||!($matrix($x:$x+$size,$y+$size)->all&& $matrix($x+$size,$y:$y+$size)->all);
25                ++$max, if $max<=$size;
26            }
27        }
28      }
29      say "$matrix -> ", $max**2;
30  }
31  

Examples:

./ch-1.pl "[[1 0 1 0 0][1 0 1 1 1][1 1 1 1 1][1 0 0 1 0]]" "[ [0 1][1 0] ]" "[[ 0 ]]"

Results:

[
 [1 0 1 0 0]
 [1 0 1 1 1]
 [1 1 1 1 1]
 [1 0 0 1 0]
]
 -> 4

[
 [0 1]
 [1 0]
]
 -> 1

[
 [0]
]
 -> 0

Some random examples:

for i in `seq 5`;
do
    ./ch-1.pl "$(perl -MPDL -E 'say +($i="".(random(5,5)<.7))=~s/\n//gr .$q')";
done

Results:

[
 [0 1 0 1 1]
 [1 1 1 1 0]
 [1 1 1 0 1]
 [1 1 1 1 1]
 [0 1 0 1 1]
]
 -> 9

[
 [1 0 0 0 1]
 [1 1 0 1 1]
 [1 0 0 0 1]
 [1 0 1 0 1]
 [0 1 1 0 1]
]
 -> 1

[
 [0 0 0 1 1]
 [1 1 0 1 0]
 [0 0 1 1 1]
 [1 0 0 1 1]
 [1 0 0 1 1]
]
 -> 4

[
 [0 1 0 1 1]
 [1 1 0 1 1]
 [1 1 1 1 1]
 [0 1 1 0 1]
 [1 1 1 1 0]
]
 -> 4

[
 [1 0 0 1 0]
 [0 1 1 1 0]
 [1 0 1 1 1]
 [1 1 1 1 1]
 [1 0 1 1 0]
]
 -> 4

Task 2: Right Interval

Submitted by: Mohammad Sajid Anwar
You are given an array of @intervals, where $intervals[i] = [starti, endi]
and each starti is unique.

The right interval for an interval i is an interval j such that startj >= endi
and startj is minimized. Please note that i may equal j.

Write a script to return an array of right interval indices for each interval i.
If no right interval exists for interval i, then put -1 at index i.

Example 1
Input: @intervals = ([3,4], [2,3], [1,2])
Output: (-1, 0, 1)

There is no right interval for [3,4].
The right interval for [2,3] is [3,4] since start0 = 3 is the smallest start that
is >= end1 = 3.
The right interval for [1,2] is [2,3] since start1 = 2 is the smallest start that
is >= end2 = 2.
Example 2
Input: @intervals = ([1,4], [2,3], [3,4])
Output: (-1, 2, -1)

There is no right interval for [1,4] and [3,4].
The right interval for [2,3] is [3,4] since start2 = 3 is the smallest start that
is >= end1 = 3.
Example 3
Input: @intervals = ([1,2])
Output: (-1)

There is only one interval in the collection, so it outputs -1.
Example 4
Input: @intervals = ([1,4], [2, 2], [3, 4])
Output: (-1, 1, -1)

I use PDL to read the input and manipulate the arrays. I use a Schwartzian transform to add to each interval its index, so I can remember it afterwards. I sort the intervals on their lowest bound and for each highest bound I search for the first interval whose lowest bound satisfies the statement, and I get its index. The result fits a 3-liner.

perl -MPDL -MPDL::NiceSlice -MList::AllUtils=first -E '
for(@ARGV){$p=pdl($_);@s=sort {$a((1)) <=> $b((1))} append($p->yvals->(0), $p)->dog;
say "$_ -> ", pdl([map $_((0)),sort{$a((1))<=>$b((1))}map{$x=$s[$_];$i=first
{$_((1))>=$x((2))} @s[$_..@s-1];append(defined $i?$i((0)):-1, $x)}0..@s-1])}
' "[ [3 4][2 3][1 2] ]" "[ [1 4][2 3][3 4] ]" "[ [1 2] ]" "[ [1 4][2  2][3 4] ]"

Results:

[ [3 4][2 3][1 2] ] -> [-1 0 1]
[ [1 4][2 3][3 4] ] -> [-1 2 -1]
[ [1 2] ] -> [-1]
[ [1 4][2  2][3 4] ] -> [-1 1 -1]

The full code is somewhat more readable.

 1  # Perl weekly challenge 298
 2  # Task 2:  Right Interval
 3  #
 4  # See https://wlmb.github.io/2024/12/02/PWC298/#task-2-right-interval
 5  use v5.36;
 6  use PDL;
 7  use PDL::NiceSlice;
 8  use List::AllUtils qw(first);
 9  for(@ARGV){
10      my $p=pdl($_);
11      my @list=append($p->yvals->(0), $p)->dog;
12      my @sorted=sort {$a((1)) <=> $b((1))} @list;
13      my @results =
14          map {$_((0))}
15          sort{$a((1))<=>$b((1))}
16          my @next =
17          map {
18              my $x=$sorted[$_];
19              my $i=first {$_((1))>=$x((2))} @sorted[$_..@sorted-1];
20              append(defined $i?$i((0)):-1, $x)
21          }0..@sorted-1;
22      say "$_ -> [@results]";
23  }

Example:

./ch-2.pl  "[ [3 4][2 3][1 2] ]" "[ [1 4][2 3][3 4] ]" "[ [1 2] ]" "[ [1 4][2  2][3 4] ]"

Results:

[ [3 4][2 3][1 2] ] -> [-1 0 1]
[ [1 4][2 3][3 4] ] -> [-1 2 -1]
[ [1 2] ] -> [-1]
[ [1 4][2  2][3 4] ] -> [-1 1 -1]

/;

Written on December 2, 2024