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]
/;