laurent_r

These are some answers to the Week 77 of the Perl Weekly Challenge organized by Mohammad S. Anwar.

Spoiler Alert: This weekly challenge deadline is due in a couple of days (September 13, 2020). This blog post offers some solutions to this challenge, please don’t read on if you intend to complete the challenge on your own.

Task 1: Fibonacci Sum

You are given a positive integer $N.

Write a script to find out the smallest combination of Fibonacci Numbers required to get $N on addition.

You are NOT allowed to repeat a number. Print 0 if none found.

Example 1:

Input: $N = 6
Output:
    1 + 5 = 6

Example 2:

Input: $N = 9
Output:
    1 + 8 = 9

My first comment is that we will never have to print 0: any strictly positive integer can be expressed as a sum of some Fibonacci numbers with no duplicates. This can be proven rigorously, but since this a not a math challenge, I will only give a gist of a demonstration with a numeric example. Consider any input integer, say 30, and all Fibonacci numbers less than 30:

1 2 3 5 8 13 21

We can subtract the largest Fibonacci number less than or equal to 30, i.e. 21, and get 9. We can repeat the operation with the new number, 9, subtract 8 from it and get 1. We repeat once more and get 0. Thus, 30 is the sum of the following Fibonacci numbers: [21 8 1]. Since the ratio between two consecutive Fibonacci numbers tends toward 1.618 (more precisely towards the golden mean, whose precise value is square root of 5 + 1 divided by 2), the iterative process will either stop early when the difference found is a Fibonacci number, or will converge very rapidly toward the smallest Fibonacci numbers. It can easily be shown that, with such a process, it is never possible to get a duplicate Fibonacci numbers. It is also not difficult to see that, since we always pick with the largest possible Fibonacci number, this process is bound to lead the smallest collection of Fibonacci numbers whose sum is equal to the input target.

Note: The task was changed after having been published and now requires “to find out all possible combination of Fibonacci Numbers required to get $N on addition.” I discovered this change after having completed the task in both Raku and Perl. That’s too late, I will show solutions to the original task, especially in view of the fact that the modified task is in my humble opinion less interesting, as finding all combinations of a list of items matching a certain condition is very similar to a number of tasks of previous challenges.

Fibonacci Sum in Raku (Original Task)

Rather than just finding a sum of Fibonacci numbers for a single input target integer, I’ve decided to illustrate the fact that it always possible to find a sum of Fibonacci numbers to obtain a target input integer, I’ll do it for every integer between 1 and 1,000.

So, we first generate an array of Fibonacci numbers less than 1000 in descending order. Then we simply iterate over this array and subtract the value found in the array if it is less than or equal to the current value, until we reach 0.

use v6;
# Original task!

my @fib = (1, 2, -> $a, $b { $a + $b } ...^ * > 1000).reverse;
for 1..1000 -> $n {
    my $curr = $n;
    my @result;
    for @fib -> $i {
        next if $i > $curr;
        push @result, $i;
        last if $i == $curr;
        $curr -= $i;
    }
    say "$n -> ", @result;
}

This is an excerpt of the output:

1 -> [1]
2 -> [2]
3 -> [3]
4 -> [3 1]
5 -> [5]
6 -> [5 1]
7 -> [5 2]
8 -> [8]
9 -> [8 1]
10 -> [8 2]
11 -> [8 3]
12 -> [8 3 1]
13 -> [13]
14 -> [13 1]
15 -> [13 2]
16 -> [13 3]
17 -> [13 3 1]
[ Lines omitted for brevity ]
984 -> [610 233 89 34 13 5]
985 -> [610 233 89 34 13 5 1]
986 -> [610 233 89 34 13 5 2]
987 -> [987]
988 -> [987 1]
989 -> [987 2]
990 -> [987 3]
991 -> [987 3 1]
992 -> [987 5]
993 -> [987 5 1]
994 -> [987 5 2]
995 -> [987 8]
996 -> [987 8 1]
997 -> [987 8 2]
998 -> [987 8 3]
999 -> [987 8 3 1]
1000 -> [987 13]

Fibonacci Sum in Raku (Modified Task)

I said before that I originally did not intend to provide solutions to the modified task, but it is so simple in Raku that I changed my mind and will nonetheless provide a solution:

# (Modified task)
my $n = @*ARGS[0]:exists ?? @*ARGS[0] !! 30;
my @fib = 1, 2, * + *  ... ^ * >= $n;
for @fib.combinations -> $s {
    say $s if $n == [+] $s;
}

Output:

(1 8 21)
(1 3 5 21)
(1 3 5 8 13)

This can be made more concise:

my $n = @*ARGS[0]:exists ?? @*ARGS[0] !! 30;
.say if $n == $_.sum for (1, 2, * + *  ... ^ * >= $n).combinations;

This script displays the same output.

Fibonacci Sum in Perl (Original Task)

This program uses the same algorithm as the Raku program (see above), but handles only one input value instead of a full range. The only other significant difference is that the array of Fibonacci numbers is built in a while loop.

use strict;
use warnings;
use feature "say";

# Original task

my $target = shift // 100;
my @fib = (1, 2);
while (1) {
    my $new_fib = $fib[-1] + $fib[-2];
    last if $new_fib >= $target;
    push @fib, $new_fib;
}
my $curr = $target;
my @result;
for my $i (reverse @fib) {
    next if $i > $curr;
    push @result, $i;
    last if $i == $curr;
    $curr -= $i;
}
say "$target ->  @result";

Running this script using the default value:

$ perl fib.pl
100 ->  89 8 3

And using a relatively large input value:

$ perl fib.pl 100000
100000 ->  75025 17711 6765 377 89 21 8 3 1

Task 2: Lonely X

You are given m x n character matrix consists of O and X only.

Write a script to count the total number of X surrounded by O only. Print 0 if none found.

Example 1:

Input: [ O O X ]
       [ X O O ]
       [ X O O ]

Output: 1 as there is only one X at the first row last column surrounded by only O.

Example 2:

Input: [ O O X O ]
       [ X O O O ]
       [ X O O X ]
       [ O X O O ]

Output: 2

    a) First  X found at Row 1 Col 3.

    b) Second X found at Row 3 Col 4.

Lonely X in Raku

We traverse the matrix and call the check subroutine when the visited item is a 'X'. The check subroutine verifies whether any neighbor of the visited item is a 'X'. The only slight difficulty is the special cases where some of the neighbors might not be defined.

use v6;

my @matrix = [ <O O X O> ],
             [ <X O O O> ],
             [ <X O O X> ],
             [ <O X O O> ];

# @matrix = [ 0, 0, 'X'], [ 'X', 0, 0], [ 'X', 0, 0 ];

# @matrix = [<X X X>], [0, 0, 0];

sub check (Int $m, Int $k) {
    for -1, 0, 1 -> $i {
        for -1, 0, 1 ->$j {
            next if $i == 0 and $j == 0;  # the item being verified, bound to be an 'X'
            next if $m+$i < 0 or $k+$j < 0; # out of the matrix
            next unless defined @matrix[$m+$i] and defined @matrix[$m+$i][$k+$j];
            return False if @matrix[$m+$i][$k+$j] eq 'X';
        }
    }
    return True;
}

my @result;
for 0..@matrix[0].end -> $j {
    for 0..@matrix.end -> $i {
        next unless @matrix[$i][$j] eq 'X';
        push @result, [$i, $j] if check $i, $j;
    }
}
say @result.elems > 0 ?? @result !! 0;

Output:

$ raku lonely.raku
[[0 2] [2 3]]

Lonely X in Perl

This is essentially a port to Perl of the above Raku program:

use strict;
use warnings;
use feature "say";

my @matrix = ([ 0, 0, 'X'], [ 'X', 0, 0], [ 'X', 0, 0 ]);

@matrix = ([ qw<O O X O> ],
          [ qw<X O O O> ],
          [ qw<X O O X> ],
          [ qw<O X O O> ]);

# @matrix = ([qw <X X X>], [0, 0, 0]);

sub check {
    my ($m, $k) = @_;
    for my $i (-1, 0, 1) {
        for my $j (-1, 0, 1) {
            next if $i == 0 and $j == 0;
            next if $m+$i < 0 or $k+$j < 0;
            next unless exists $matrix[$m+$i] and exists $matrix[$m+$i][$k+$j];
            return 0 if $matrix[$m+$i][$k+$j] eq 'X';
        }
    }
    return 1;
}

my @result;
for my $i (0..$#{$matrix[0]}) {
    for my $j (0..$#matrix) {
        next unless $matrix[$j][$i] eq 'X';
        push @result, [$j, $i] if check $j, $i;
    }
}
say "@$_" for  @result;
say 0 unless @result;

Output:

$ perl lonely.pl
0 2
2 3

Wrapping up

The next week Perl Weekly Challenge will start soon. If you want to participate in this challenge, please check https://perlweeklychallenge.org/ and make sure you answer the challenge before 23:59 BST (British summer time) on Sunday, September 20, 2020. And, please, also spread the word about the Perl Weekly Challenge if you can.