Perl Weekly Challenge 270.
My solutions (task 1 and task 2 ) to the The Weekly Challenge - 270.
Task 1: Special Positions
Submitted by: Mohammad Sajid Anwar
You are given a m x n binary matrix.
Write a script to return the number of special positions in the given binary matrix.
A position (i, j) is called special if $matrix[i][j] == 1 and all other elements in
the row i and column j are 0.
Example 1
Input: $matrix = [ [1, 0, 0],
[0, 0, 1],
[1, 0, 0],
]
Output: 1
There is only one special position (1, 2) as $matrix[1][2] == 1
and all other elements in row 1 and column 2 are 0.
Example 2
Input: $matrix = [ [1, 0, 0],
[0, 1, 0],
[0, 0, 1],
]
Output: 3
Special positions are (0,0), (1, 1) and (2,2).
On a special row the binary or of all the bits should be the number 1 (only 0’s or
1’s, at least one 1) and the sum of all the elements should also be 1
(at most one 1). The same
for a special column. The special positions have the value 1 and are
in a special row and a special column. After building a matrix with
1’s only at special positions, I just add them. Using the Perl Data
Language (PDL), this may be coded in a two liner:
Example 1:
perl -MPDL -E '
$x=pdl(shift);say "$x -> ",(($x)&(($x->borover==1)->dummy(0))&(($x->transpose->borover==1)->dummy(1))
&(($x->sumover==1)->dummy(0))&(($x->transpose->sumover==1)->dummy(1)))->sum
' "[[1 0 0][0 0 1][1 0 0]]"
Results:
[
[1 0 0]
[0 0 1]
[1 0 0]
]
-> 1
Example 2:
perl -MPDL -E '
$x=pdl(shift);say "$x -> ",(($x)&(($x->borover==1)->dummy(0))&(($x->transpose->borover==1)->dummy(1))
&(($x->sumover==1)->dummy(0))&(($x->transpose->sumover==1)->dummy(1)))->sum
' "[[1 0 0][0 1 0][0 0 1]]"
Results:
[
[1 0 0]
[0 1 0]
[0 0 1]
]
-> 3
The full code follows
1 # Perl weekly challenge 270
2 # Task 1: Special Positions
3 #
4 # See https://wlmb.github.io/2024/05/20/PWC270/#task-1-special-positions
5 use v5.36;
6 use PDL;
7 die <<~"FIN" unless @ARGV;
8 Usage: $0 M1 M2...
9 where M1, M2... are strings that represent matrices, of the form
10 "[[m11 m12...][m21 m22...]...]"
11 FIN
12 for(@ARGV){
13 my $x=pdl($_);
14 say "$x -> ",
15 (($x) # value is not zero
16 &(($x->borover==1)->dummy(0)) # only 0's and 1's in row
17 &(($x->transpose->borover==1)->dummy(1)) # only 0's and 1's in column
18 &(($x->sumover==1)->dummy(0)) # only one 1 in row
19 &(($x->transpose->sumover==1)->dummy(1)) # only one 1 in column
20 )->sum;
21 }
Examples:
./ch-1.pl "[[1 0 0][0 0 1][1 0 0]]" "[[1 0 0][0 1 0][0 0 1]]"
Results:
[
[1 0 0]
[0 0 1]
[1 0 0]
]
-> 1
[
[1 0 0]
[0 1 0]
[0 0 1]
]
-> 3
Task 2: Distribute Elements
Submitted by: Mohammad Sajid Anwar
You are give an array of integers, @ints and two integers, $x and $y.
Write a script to execute one of the two options:
Level 1:
Pick an index i of the given array and do $ints[i] += 1
Level 2:
Pick two different indices i,j and do $ints[i] +=1 and $ints[j] += 1.
You are allowed to perform as many levels as you want to make every elements
in the given array equal. There is cost attach for each level, for Level 1,
the cost is $x and $y for Level 2.
In the end return the minimum cost to get the work done.
Example 1
Input: @ints = (4, 1), $x = 3 and $y = 2
Output: 9
Level 1: i=1, so $ints[1] += 1.
@ints = (4, 2)
Level 1: i=1, so $ints[1] += 1.
@ints = (4, 3)
Level 1: i=1, so $ints[1] += 1.
@ints = (4, 4)
We perforned operation Level 1, 3 times.
So the total cost would be 3 x $x => 3 x 3 => 9
Example 2
Input: @ints = (2, 3, 3, 3, 5), $x = 2 and $y = 1
Output: 6
Level 2: i=0, j=1, so $ints[0] += 1 and $ints[1] += 1
@ints = (3, 4, 3, 3, 5)
Level 2: i=0, j=2, so $ints[0] += 1 and $ints[2] += 1
@ints = (4, 4, 4, 3, 5)
Level 2: i=0, j=3, so $ints[0] += 1 and $ints[3] += 1
@ints = (5, 4, 4, 4, 5)
Level 2: i=1, j=2, so $ints[1] += 1 and $ints[2] += 1
@ints = (5, 5, 5, 4, 5)
Level 1: i=3, so $ints[3] += 1
@ints = (5, 5, 5, 5, 5)
We perforned operation Level 1, 1 time and Level 2, 4 times.
So the total cost would be (1 x $x) + (4 x $y) => (1 x 2) + (4 x 1) => 6
(Note: I corrected a typo in the example above).
The final value of all elements is the maximum of the original
array. If a level 2 is possible, it is preferable unless it is more
expensive than two level 1 steps. I can sort the elements in
descending order, so it is safe to make a level 2 with the remaining
largest and next largest elements as many times as
necessary to make the first element as large as the maximum. It is not
necessary to perform the steps one at a time to calculate the
number of steps and their cost. Then I can shift the array and start over
again until I empty the array. If there are no further elements or if level 2 is too
expensive, I do level 1 steps. I take $x, $y and @ints from
@ARGV The result fits a two liner.
Example 1:
perl -E '
($x, $y)=(shift,shift);$t=$y<2*$x;@p=sort{$b<=>$a}@ARGV;$m=shift @p;while(@p){$s=$m-shift @p;
if($t&&@p){$p[0]+=$s;$c+=$s*$y}else{$c+=$s*$x}} say "x=$x, y=$y, ints= @ARGV -> $c"
' 3 2 4 1
Results:
x=3, y=2, ints= 4 1 -> 9
Example 2:
perl -E '
($x, $y)=(shift,shift);$t=$y<2*$x;@p=sort{$b<=>$a}@ARGV;$m=shift @p;while(@p){$s=$m-shift @p;
if($t&&@p){$p[0]+=$s;$c+=$s*$y}else{$c+=$s*$x}} say "x=$x, y=$y, ints= @ARGV -> $c"
' 2 1 2 3 3 3 5
Results:
x=2, y=1, ints= 2 3 3 3 5 -> 6
The full code is:
1 # Perl weekly challenge 270
2 # Task 2: Distribute Elements
3 #
4 # See https://wlmb.github.io/2024/05/20/PWC270/#task-2-distribute-elements
5 use v5.36;
6 die <<~"FIN" unless @ARGV >= 2;
7 Usage: $0 X Y A1 A2...
8 to find the minimum cost of maeking all elements of the array A1 A2... equal
9 by adding 1 to individual elements, with cost X or adding 1 to pairs of
10 elements with cost Y.
11 FIN
12 my ($x, $y)=(shift,shift);
13 my $prefer_two=$y<2*$x;
14 my @decreasing = sort {$b<=>$a} @ARGV;
15 my $max = shift @decreasing;
16 my $total = 0;
17 while(@decreasing){
18 my $steps = $max - shift @decreasing;
19 if($prefer_two && @decreasing){ # Can I do level 2?
20 $decreasing[0] += $steps; # Update next element
21 $total += $steps * $y; # Update total cost
22 }else{ # level 1 instead
23 $total += $steps * $x; # Update total cost
24 }
25 }
26 say "x=$x, y=$y, ints= @ARGV -> $total"
Example:
./ch-2.pl 3 2 4 1
./ch-2.pl 2 1 2 3 3 3 5
Results:
x=3, y=2, ints= 4 1 -> 9
x=2, y=1, ints= 2 3 3 3 5 -> 6
Another version.
I try a couple of tricky examples by Choroba:
./ch-2.pl 6 10 2 3 5 1 2 1 1 7
./ch-2.pl 4 1 1 2 2 2 2
Results:
x=6, y=10, ints= 2 3 5 1 2 1 1 7 -> 174
x=4, y=1, ints= 1 2 2 2 2 -> 4
I realize that my assumption that the maximum is the common value to attain is wrong. The last example could have been solved with 3 level 2 steps if the final common value were incremented to 3. It seems that the problem is that I leave the smallest value at the end, which might require some expensive level 1 steps at the end. Thus I propose a slightly more complex approach, in which I perform a level 2 step on the smallest values and retry the cost calculation, until the total cost increases. The program (below) is slightly more complex (and not very well organized nor optimized).
1 # Perl weekly challenge 270
2 # Task 2: Distribute Elements
3 #
4 # See https://wlmb.github.io/2024/05/20/PWC270/#task-2-distribute-elements
5 use v5.36;
6 die <<~"FIN" unless @ARGV >= 2;
7 Usage: $0 X Y A1 A2...
8 to find the minimum cost of maeking all elements of the array A1 A2... equal
9 by adding 1 to individual elements, with cost X or adding 1 to pairs of
10 elements with cost Y.
11 FIN
12 my ($x, $y)=(shift,shift);
13 my $prefer_two=$y<2*$x;
14 my @decreasing = sort {$b<=>$a} @ARGV;
15 my $oldtotal = my $total = cost(@decreasing);
16 my $precost=0;
17 while(1){
18 ++$decreasing[-1]; # perform level 2 on smallest elements
19 ++$decreasing[-2];
20 $precost += $y; # add cost
21 @decreasing=sort {$b<=>$a} @decreasing; # sort again :(
22 $total=$precost+cost(@decreasing);
23 last if $total > $oldtotal; # finish when there is no gain
24 $oldtotal=$total;
25 }
26 say "x=$x, y=$y, ints= @ARGV -> $oldtotal";
27
28 sub cost(@decreasing){
29 my $max =shift @decreasing;
30 my $total=0;
31 while(@decreasing){
32 my $steps = $max - shift @decreasing;
33 if($prefer_two && @decreasing){ # Can I do level 2?
34 $decreasing[0] += $steps; # Update next element
35 $total += $steps * $y; # Update total cost
36 }else{ # level 1 instead
37 $total += $steps * $x; # Update total cost
38 }
39 }
40 return $total;
41 }
./ch-2a.pl 3 2 4 1
./ch-2a.pl 2 1 2 3 3 3 5
./ch-2a.pl 6 10 2 3 5 1 2 1 1 7
./ch-2a.pl 4 1 1 2 2 2 2
Results:
x=3, y=2, ints= 4 1 -> 9
x=2, y=1, ints= 2 3 3 3 5 -> 6
x=6, y=10, ints= 2 3 5 1 2 1 1 7 -> 170
x=4, y=1, ints= 1 2 2 2 2 -> 3
Notice that I obtained better results for the last two examples than with my previous program. In this case, I believe they are optimal, though I’m not sure the new program finds always the optimal solution.
Still another version.
I try a couple of more tricky examples by Choroba:
./ch-2a.pl 6 1 2 5 5 6
./ch-2a.pl 7 3 1 4 7 7 7
Results:
x=6, y=1, ints= 2 5 5 6 -> 14
x=7, y=3, ints= 1 4 7 7 7 -> 30
The expected results are 5 and 21.
I guess the problem is that I didn’t explore enough possibilities. Thus I repeat the previous code but instead of quitting after the first solution worse than the current choice, I keep going until I’m sure that there is no solution better than the current one. To avoid a costly exhaustive search, I search for solutions in which I make level two steps for the highest elements, and retry after taking level two steps for the smallest pair of elements, i.e., I perform a level 2 step on the smallest values and retry the cost calculation, until the total cost cannot decrease.
1 # Perl weekly challenge 270
2 # Task 2: Distribute Elements
3 #
4 # See https://wlmb.github.io/2024/05/20/PWC270/#task-2-distribute-elements
5 use v5.36;
6 die <<~"FIN" unless @ARGV >= 2;
7 Usage: $0 X Y A1 A2...
8 to find the minimum cost of maeking all elements of the array A1 A2... equal
9 by adding 1 to individual elements, with cost X or adding 1 to pairs of
10 elements with cost Y.
11 FIN
12 my ($x, $y)=(shift,shift);
13 my $prefer_two=$y<2*$x;
14 my @decreasing = sort {$b<=>$a} @ARGV;
15 my $oldtotal = my $total = cost(@decreasing);
16 my $precost=0;
17 while(1){
18 ++$decreasing[-1]; # perform level 2 on smallest elements
19 ++$decreasing[-2];
20 $precost += $y; # add cost
21 last if $precost > $oldtotal;
22 @decreasing=sort {$b<=>$a} @decreasing; # sort again :(
23 $total=$precost+cost(@decreasing);
24 $oldtotal=$total if $total < $oldtotal;
25 }
26 say "x=$x, y=$y, ints= @ARGV -> $oldtotal";
27
28 sub cost(@decreasing){
29 my $max =shift @decreasing;
30 my $total=0;
31 while(@decreasing){
32 my $steps = $max - shift @decreasing;
33 if($prefer_two && @decreasing){ # Can I do level 2?
34 $decreasing[0] += $steps; # Update next element
35 $total += $steps * $y; # Update total cost
36 }else{ # level 1 instead
37 $total += $steps * $x; # Update total cost
38 }
39 }
40 return $total;
41 }
Examples, to which I add the latest tricky examples by Choroba:
./ch-2b.pl 3 2 4 1
./ch-2b.pl 2 1 2 3 3 3 5
./ch-2b.pl 6 10 2 3 5 1 2 1 1 7
./ch-2b.pl 4 1 1 2 2 2 2
./ch-2b.pl 6 1 2 5 5 6
./ch-2b.pl 7 3 1 4 7 7 7
Results:
x=3, y=2, ints= 4 1 -> 9
x=2, y=1, ints= 2 3 3 3 5 -> 6
x=6, y=10, ints= 2 3 5 1 2 1 1 7 -> 170
x=4, y=1, ints= 1 2 2 2 2 -> 3
x=6, y=1, ints= 2 5 5 6 -> 5
x=7, y=3, ints= 1 4 7 7 7 -> 21
So, the last program seems correct, so far.