Perl Weekly Challenge 211.
My solutions (task 1 and task 2 ) to the The Weekly Challenge - 211.
Task 1: Toeplitz Matrix
Submitted by: Mohammad S Anwar
You are given a matrix m x n.
Write a script to find out if the given matrix is Toeplitz
Matrix.
A matrix is Toeplitz if every diagonal from top-left to
bottom-right has the same elements.
Example 1
Input: @matrix = [ [4, 3, 2, 1],
[5, 4, 3, 2],
[6, 5, 4, 3],
]
Output: true
Example 2
Input: @matrix = [ [1, 2, 3],
[3, 2, 1],
]
Output: false
The k-th diagonal has elements with indices k+i,i with the constraints
0<=k+i<N, 0<=i<M, and thus, -M<k<N. I read the space separated matrix
elements from STDIN, one row at a time and then check that the
diagonals have one uniq element each. This fits a 1.5 liner.
perl -MList::Util=max,min,uniq -nE '$m[$N++]=[split " "];END {$M=@{$m[0]};$L=max($N,$M);$t=1;for $k
(-$M+1..$N-1){$t&&=1==uniq map {$m[$k+$_][$_]} max(0, -$k)..min($M-1,$N-$k-1)}say $t?"true":"false";}
' << FIN
4 3 2 1
5 4 3 2
6 5 4 3
FIN
Results:
true
Another example:
perl -MList::Util=max,min,uniq -nE '$m[$N++]=[split " "];END {$M=@{$m[0]};$L=max($N,$M);$t=1;for $k
(-$M+1..$N-1){$t&&=1==uniq map {$m[$k+$_][$_]} max(0, -$k)..min($M-1,$N-$k-1)}say $t?"true":"false";}
' << FIN
1 2 3
3 2 1
FIN
Results:
false
An alternative is to use PDL, which has facilities for selecting unique elements and for manipulating the diagonals of a matrix. However, it only works for square matrices. Thus, I can extend a rectangular matrix into a square matrix by adding BAD values and then check its diagonals.
perl -MPDL -MPDL::LinearAlgebra -E 'while(@ARGV){$m=pdl(shift);($M,$N)=$m->dims; $L=pdl($N,$M)->max;
$n=$m->copy->reshape($L,$L); $n=$n->setbadif($n->yvals>=$N |$n->xvals>=$M);
say "$m -> ", pdl(map {$n->diag($_)->uniq->nelem==1} -$L+1..$L-1)->all?"True":"False" }
' '[[4, 3, 2, 1],[5,4,3,2],[6,5,4,3]]' '[[3,2,1],[1,2,3]]'
Results:
[
[4 3 2 1]
[5 4 3 2]
[6 5 4 3]
]
-> True
[
[3 2 1]
[1 2 3]
]
-> False
However, the code is neither shorter nor clearer, so I follow the first approach for the full code.
1 # Perl weekly challenge 211
2 # Task 1: Toeplitz Matrix
3 #
4 # See https://wlmb.github.io/2023/04/03/PWC211/#task-1-toeplitz-matrix
5 use v5.36;
6 use List::Util qw(max min uniq);
7 my @matrix;
8 my $N=0; # number of rows
9 while(<>){ # read the matrix, a space separated row at a time
10 $matrix[$N++]=[split " "];
11 }
12 my $M=@{$matrix[0]}; # Number of columns
13 @{$matrix[$_]}==$M || die "Not rectangular" for(1..$N-1);
14 my $largest=max($N,$M);
15 my $toeplitz=1; # matrix is toeplitz
16 for my $diagonal(-$M+1..$N-1){
17 $toeplitz &&= # unless it is not
18 1==uniq
19 map {$matrix[$diagonal+$_][$_]}
20 max(0, -$diagonal)..min($M-1,$N-$diagonal-1);
21 }
22 say "@{$matrix[$_]}" for 0..$N-1;
23 say " -> ", $toeplitz?"true":"false";
Example:
./ch-1.pl << FIN
4 3 2 1
5 4 3 2
6 5 4 3
FIN
Results:
4 3 2 1
5 4 3 2
6 5 4 3
-> true
Other example:
./ch-1.pl << FIN
3 2 1
1 2 3
FIN
Results:
3 2 1
1 2 3
-> false
Task 2: Split Same Average
Submitted by: Mohammad S Anwar
You are given an array of integers.
Write a script to find out if the given can be split into two separate arrays whose
average are the same.
Example 1:
Input: @nums = (1, 2, 3, 4, 5, 6, 7, 8)
Output: true
(1 2 3 4 5 6 7 8)
We can split the given array into (1, 4, 5, 8) and (2, 3, 6, 7).
The average of the two arrays are the same i.e. 4.5.
Example 2:
Input: @list = (1, 3)
Output: false
Of course each average should equal the average of all given
numbers. So it is enough to find a proper subset whose average equals
the global average. The simplest approach would be to filter all
subsets until an appropriate one is found, although for large inputs
it would be very slow. I generate all subsets using
Algorithm::Combinatorics and sum them with List::Util. This
yields a two liner.
perl -MAlgorithm::Combinatorics=subsets -MList::Util=sum -E '
@a=@ARGV; $m=sum(@a)/@a; $s=subsets(\@a); $s->next; while($c=$s->next){next if @$c==0;
last if sum(@$c)==$m*@$c} say("@a -> ", @$c?"True: @$c":"False")
' 1 2 3 4 5 6 7 8
Results:
1 2 3 4 5 6 7 8 -> True: 1 2 3 6 7 8
Another example:
perl -MAlgorithm::Combinatorics=subsets -MList::Util=sum -E '
@a=@ARGV; $m=sum(@a)/@a; $s=subsets(\@a); $s->next; while($c=$s->next){next if @$c==0;
last if sum(@$c)==$m*@$c} say("@a -> ", @$c?"True: @$c":"False")
' 1 3
Results:
1 3 -> False
The full code is similar.
1 # Perl weekly challenge 211
2 # Task 2: Split Same Average
3 #
4 # See https://wlmb.github.io/2023/04/03/PWC211/#task-2-split-same-average
5 use v5.36;
6 use Algorithm::Combinatorics qw(subsets);
7 use List::Util qw(sum);
8 die <<~"FIN" unless @ARGV;
9 Usage: $0 N1 [N2...]
10 to test if the set N1 N2... may be split into two proper subsets
11 with the same average
12 FIN
13 my $avg=sum(@ARGV)/@ARGV;
14 my $subsets=subsets(\@ARGV);
15 $subsets->next; # Throw away the complete set
16 my $candidate;
17 while($candidate=$subsets->next){
18 next if @$candidate==0; # Throw away the empty set
19 last if sum(@$candidate)==$avg*@$candidate; # success
20 }
21 say("@ARGV -> ", $candidate && @$candidate? "True: @$candidate" : "False")
Example:
./ch-2.pl 1 2 3 4 5 6 7 8
./ch-2.pl 1 3
Results:
1 2 3 4 5 6 7 8 -> True: 1 2 3 6 7 8
1 3 -> False