Perl Weekly Challenge: Week 270
Challenge 1:
Special Positions
You are given a
m x nbinary 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).
The matrix was created from the command-line. Each argument represents a row in the matrix; a string consisting
of integers separeated by spaces. These are the columns. So we can slurp in the whole matrix with .map() and .words().
my @matrix = @args.map({ [$_.words] });
We also need to store the number of special positions found.
my $specials = 0;
The naive way to determine if a position is special is to check if the number there is 1 and if so, check that the numbers in the rest of the row and column are all 0. But then I thought of an optimization. If the number in a position is 1 it will be special if the sum of all the numbers in its row is 1 as is the sum of all the numbers in its column. This is easy to implement in code.
We go through all the rows and columns of the matrix looking for 1s.
for @matrix.keys -> $row {
for @matrix[$row].keys -> $col {
If a 1 is found...
if @matrix[$row;$col] == 1 &&
The sum of the values in the row is compared to 1 using .sum() on an "array slice."
@matrix[$row;*].sum == 1 &&
The same is done for the column.
@matrix[*;$col].sum == 1 {
If both are true, this is a special position so $specials is incremented.
$specials++;
}
}
}
Finally, we print the number of special positions found.
say $specials;
The Perl version is pretty much the same. We have to provide our own implementation of sum() but I already had
that from previous challenges.
my @matrix = map { [split /\s+/, $_] } @ARGV;
my $specials = 0;
for my $row (keys @matrix) {
for my $col (keys @{$matrix[$row]}) {
if (($matrix[$row]->[$col] == 1) &&
(sum(@{$matrix[$row]}) == 1) &&
(sum(map { $matrix[$_]->[$col] } keys @matrix) == 1)) {
$specials++;
}
}
}
say $specials;
Challenge 2:
Distribute Elements
You are give an array of integers,
@intsand two integers,$xand$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
$xand$yfor 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
It took me a long time before I figured out how to solve this one and I'm still not a 100% sure I have the optimal answer.
My thinking is as we don't have a way to decrease the value of an element, we should find
the largest value and keep adding to the others until they reach that. Furthermore we should
try and do level 2 additions as often as possible because the cost is cheaper per element than level 1.
(In hindsight this is only true if $y is less than twice %x. My code doesn't deal with this but it doesn't
matter for the examples.)
We get the input from the command-line. The first to parameters are $x and $y. The rest are @ints.
First we find the largest value in @ints and store it for later use.
my $max = @ints.max;
We make a copy of @ints because it is immutable in Raku.
my @unequals = @ints;
And a variable is created to store the cost.
my $cost = 0;
Now we loop indefinitely.
loop {
We remove any elements from @unequals which are already at the $max value.
@unequals = @unequals.grep({ $_ != $max });
We store the length of @unequals.
my $remaining = @unequals.elems;
If the length is greater than 1...
if $remaining > 1 {
...we do a level 2 operation by picking two random indices from @unequals with .pick()
and incrementing their elements. In order to increment both the picked elements in one go,
I used the "hyper" form of the ++ increment operator by placing » in front of it.
@unequals[@unequals.keys.pick(2)]»++;
The cost is increased by the value of $y.
$cost += $y;
If there is only 1 element remaining...
} elsif $remaining == 1 {
...we increment it. (I originally had .pick(1) here but realized it was redundant.)
@unequals[0]++;
The cost is increased by the value of $x.
$cost += $x;
If there are no more elements remaining we break out of the loop.
} else {
last;
}
}
Finally we print out the cost.
say $cost;
For the Perl version, I had to provide implementations of max() and pick(), I already had
them from previous challenges but I updated them a little for Perl 5.38 and above, most
notably the usage of signatures so here they are again.
sub max(@arr) {
my $highest = '-inf';
for my $i (@arr) {
if ($i > $highest) {
$highest = $i;
}
}
return $highest;
}
sub pick($count, @arr) {
my %results;
my $picked = 0;
while ($picked < $count) {
my $random = $arr[int(rand(scalar @arr))];
unless (exists $results{$random}) {
$results{$random} = 1;
$picked++;
}
}
return wantarray ? keys %results : [ keys %results ];
}
Armed with these, we can do a faithful translation of the Raku version.
my $max = max(@ints);
my @unequals = @ints;
my $cost = 0;
while(1) {
@unequals = grep { $_ != $max } @unequals;
my $remaining = scalar @unequals;
if ($remaining > 1) {
for my $pick (pick(2, keys @unequals)) {
$unequals[$pick]++;
}
$cost += $y;
} elsif ($remaining == 1) {
$unequals[0]++;
$cost += $x;
} else {
last;
}
}
say $cost;