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
Written on April 3, 2023