Perl Weekly Challenge: Week 361
Challenge 1:
Zeckendorf Representation
You are given a positive integer (<= 100).
Write a script to return Zeckendorf Representation of the given integer.
Every positive integer can be uniquely represented as sum of non-consecutive Fibonacci numbers.
Example 1
Input: $int = 4
Output: 3,1
4 => 3 + 1 (non-consecutive fibonacci numbers)
Example 2
Input: $int = 12
Output: 8,3,1
12 => 8 + 3 + 1
Example 3
Input: $int = 20
Output: 13,5,2
20 => 13 + 5 + 2
Example 4
Input: $int = 96
Output: 89,5,2
96 => 89 + 5 + 2
Example 5
Input: $int = 100
Output: 89,8,3
100 => 89 + 8 + 3
Looking at the examples we see that the output in each case starts from the largest
Fibonacci number smaller than $int and decreases. The spec also tells us the
Zeckendorf representation is a sum of terms so we know reversing it will involve
subtraction. This gave me some clues about how to solve this problem.
I came up with the following recursive function. subtract() takes a remainder
which is the amount of $int left to process, an array to store results, and an
index into a list of Fibonacci numbers. It will be called in MAIN() like this:
subtract($int, (), 0).join(q{,}).say;
The initial value of the remainder is $int bewcause we haven't subtracted anything
yet. The initial result value of the results array is () because, of course, we don't
have any results. The initial value of the Fibonacci index is 0.
sub subtract($remainder, @results, $i) {
I could have passed a list of Fibonacci numbers into the function or even computed them
on the fly but as there are only 11 Fibonacci numbers less than 100 (which the spec tells
us will be the size of the input) I just hard-coded them in as a state or static list.
They are sorted from largest to smallest.
state @fibs = (89, 55, 34, 21, 13, 8, 5, 3, 2, 1, 1);
Every recursive function needs a halting condition. In our case, it is reached when
$remainder becomes 0. Then we return @results which will contain the full Zeckendorf
representation.
if $remainder == 0 {
return @results;
}
Otherwise we assign the value of $i (which as a function parameter is immutable) to
$nexti and use that to iterate through the list of Fibonacci numbers, stopping when
we get to one which is smaller than the current value of $remainder.
my $nexti = $i;
while @fibs[$nexti] > $remainder {
$nexti++;
}
This number will be subtracted from $remainder in the next recursive call to subtract().
It will also added into a new list with @results to make the second parameter to the function. (It cannot simply be .push()ed because @results is immutable.) The third
parameter is $nexti + 2. Why 2? Because the spec says the Fibonacci numbers used must
be non-consecutive.
return subtract($remainder - @fibs[$nexti], (@results, @fibs[$nexti]).flat,
$nexti + 2);
}
subtract($int, (), 0).join(q{,}).say;
This is the Perl version. We don't have to worry about immutable parameters, but arrays have to be passed by reference so the complexity ends up about the same.
sub subtract($remainder, $results, $i) {
state @fibs = (89, 55, 34, 21, 13, 8, 5, 3, 2, 1, 1);
if ($remainder <= 0) {
return @{$results};
}
my $nexti = $i;
while ($fibs[$nexti] > $remainder) {
$nexti++;
}
push @{$results}, $fibs[$nexti];
return subtract($remainder - $fibs[$nexti], $results, $nexti + 2);
}
say join q{,}, subtract($int, [], 0);
Challenge 2:
Find Celebrity
You are given a binary matrix (m x n).
Write a script to find the celebrity, return -1 when none found.
A celebrity is someone, everyone knows and knows nobody.
Example 1
Input: @party = (
[0, 0, 0, 0, 1, 0], # 0 knows 4
[0, 0, 0, 0, 1, 0], # 1 knows 4
[0, 0, 0, 0, 1, 0], # 2 knows 4
[0, 0, 0, 0, 1, 0], # 3 knows 4
[0, 0, 0, 0, 0, 0], # 4 knows NOBODY
[0, 0, 0, 0, 1, 0], # 5 knows 4
);
Output: 4
Example 2
Input: @party = (
[0, 1, 0, 0], # 0 knows 1
[0, 0, 1, 0], # 1 knows 2
[0, 0, 0, 1], # 2 knows 3
[1, 0, 0, 0] # 3 knows 0
);
Output: -1
Example 3
Input: @party = (
[0, 0, 0, 0, 0], # 0 knows NOBODY
[1, 0, 0, 0, 0], # 1 knows 0
[1, 0, 0, 0, 0], # 2 knows 0
[1, 0, 0, 0, 0], # 3 knows 0
[1, 0, 0, 0, 0] # 4 knows 0
);
Output: 0
Example 4
Input: @party = (
[0, 1, 0, 1, 0, 1], # 0 knows 1, 3, 5
[1, 0, 1, 1, 0, 0], # 1 knows 0, 2, 3
[0, 0, 0, 1, 1, 0], # 2 knows 3, 4
[0, 0, 0, 0, 0, 0], # 3 knows NOBODY
[0, 1, 0, 1, 0, 0], # 4 knows 1, 3
[1, 0, 1, 1, 0, 0] # 5 knows 0, 2, 3
);
Output: 3
Example 5
Input: @party = (
[0, 1, 1, 0], # 0 knows 1 and 2
[1, 0, 1, 0], # 1 knows 0 and 2
[0, 0, 0, 0], # 2 knows NOBODY
[0, 0, 0, 0] # 3 knows NOBODY
);
Output: -1
Example 6
Input: @party = (
[0, 0, 1, 1], # 0 knows 2 and 3
[1, 0, 0, 0], # 1 knows 0
[1, 1, 0, 1], # 2 knows 0, 1 and 3
[1, 1, 0, 0] # 3 knows 0 and 1
);
Output: -1
We bring the input into the script via command-line arguments, each one representing
a row of the matrix. For instance, the input for example 6 would be 0011 1000 1101 1100.
So the first order of business is to get the input back into 2d array form.
my @party = @args.map({ $_.comb });
We need a variable to hold the result. It is initialized to -1, the value that signifies that a celebrity was not fund.
my $celebrity = -1;
Now for the index of each row in the matrix...
for @party.keys -> $row {
...if every element in the row is a 0...
if all(@party[$row]) == 0 {
...if the column corresponding to the row only has one 0 in it we know that the row
is the one we're looking for. We assign it to $celebrity and stop processing.
if @party[*;$row].grep(0) == 1 {
$celebrity = $row;
last;
}
}
}
Finally, we print $celebrity.
say $celebrity;
For the Perl version, we need replacements for some Raku functionality Perl doesn't have.
Function allEquals() takes an array reference and an element and determines if all
the other elements in the array are the same as that element.
sub allEquals($arr, $elem) {
return (scalar grep { $_ == $elem } @{$arr}) == (scalar @{$arr});
}
Getting a row from a 2d array is easy, getting a column is a little trickier. getColumn()
wraps the process into a simple function. It takes an array reference $arr and
a column index $i and returns the appropriate column from the array.
sub getColumn($arr, $i) {
return map { $_->[$i] } @{$arr};
}
With these in hand, we can translate the Raku version into Perl. It looks like this:
my @party = map { [ split // ] } @ARGV;
my $celebrity = -1;
for my $row (keys @party) {
if (allEquals($party[$row], 0)) {
if (scalar grep {$_ == 0} getColumn(\@party, $row) == 1) {
$celebrity = $row;
last;
}
}
}
say $celebrity;