This is my response to the Perl Weekly Challenge #077.
$N. Write a script to find out all possible combination
of Fibonacci Numbers required to get $N on addition.
Input: $N = 6
Output:
a) 1 + 2 + 3 = 6
b) 1 + 5 = 6
Input: $N = 9
Output:
a) 1 + 8 = 9
b) 1 + 3 + 5 = 9
This task is very similar to #076.1 Prime Sum, but easier as we do not allow duplicate values in the result list.
So this is basically a slightly simplified version of the «prime-sum-upto» program, with som minor adjustments. See Primal Words with Raku for details of that program.
File: fibonacci-sum
#! /usr/bin/env raku
subset PositiveInt of Int where * >= 1;
unit sub MAIN (PositiveInt $N, :v(:$verbose), :u(:$upto));
my $label;
my $found;
$upto
?? (1..$N).map({ fibonal-decomposition($_) })
!! fibonal-decomposition($N);
sub fibonal-decomposition($target)
{
$found = False; # [2]
$label = 'a'; # [4]
my $fibonacci := (1, 1, * + * ... Inf); # [1]
my @fibs;
for $fibonacci -> $fib { last if $fib > $target; @fibs.unshift: $fib; }
@fibs.pop; # [1a]
if $verbose
{
say ": Target: $target" if $upto;
say ": Fibonacci (reverse): { @fibs.join(", ") }";
}
recurse(0, (), @fibs, $target);
say "0" unless $found; # [2a]
say "" if $upto; # [3]
}
sub recurse ($value is copy, @values is copy, @fibonacci is copy, $input)
{
if $value < $input
{
while @fibonacci
{
my $add = @fibonacci.shift;
if $value + $add <= $input
{
my $value2 = $value + $add;
my @values2 = @values.clone.push: $add;
recurse($value2, @values2, @fibonacci, $input);
}
}
}
elsif $value == $input
{
say "{ $label++ }) { @values.join(' + ') } = $input"; # [4a]
$found = True; # [2b]
}
}
[1]
This beautifully construct sets up the Fibonacci Sequence.
The first number is 1, the second is (also) 1, and the rest of the numbers
are the sum of the two numbers before them. We need the Fibonacci numbers
up to $N (in reverse order), and the loop in [1a] does just
that. Note the use of unshift to add the element at the front
of the list. The final pop removes the last element, as
duplicate numbers are not allowed. We are thus left with one 1.
[2] Have we found any matches [2a]? If not, print «0» [2b].
[3] In «upto» mode, print a blank line between the matches.
[4] The examples numbered the output lines with a letter. So we do the same.
See
docs.raku.org/routine/unshift
for more information about unshift.
See
docs.raku.org/routine/pop
for more information about pop.
Running it:
$ ./fibonacci-sum 1
a) 1 = 1
$ ./fibonacci-sum -v 1
: Fibonacci (reverse): 1
a) 1 = 1
$ ./fibonacci-sum 2
a) 2 = 2
$ ./fibonacci-sum -v 2
: Fibonacci (reverse): 2, 1
a) 2 = 2
$ ./fibonacci-sum 3
a) 3 = 3
b) 2 + 1 = 3
$ ./fibonacci-sum -v 3
: Fibonacci (reverse): 3, 2, 1
a) 3 = 3
b) 2 + 1 = 3
And so on..
But «upto» mode is there to take care of this for us:
$ ./fibonacci-sum -u 6
a) 1 = 1
a) 2 = 2
a) 3 = 3
b) 2 + 1 = 3
a) 3 + 1 = 4
a) 5 = 5
b) 3 + 2 = 5
a) 5 + 1 = 6
b) 3 + 2 + 1 = 6
$ ./fibonacci-sum -u -v 6
: Target: 1
: Fibonacci (reverse): 1
a) 1 = 1
: Target: 2
: Fibonacci (reverse): 2, 1
a) 2 = 2
: Target: 3
: Fibonacci (reverse): 3, 2, 1
a) 3 = 3
b) 2 + 1 = 3
: Target: 4
: Fibonacci (reverse): 3, 2, 1
a) 3 + 1 = 4
: Target: 5
: Fibonacci (reverse): 5, 3, 2, 1
a) 5 = 5
b) 3 + 2 = 5
: Target: 6
: Fibonacci (reverse): 5, 3, 2, 1
a) 5 + 1 = 6
b) 3 + 2 + 1 = 6
I ran it up to 999 to see where the first number that could not be composed of Fibonacci numbers popped up, and found none. A lot of scrolling was involved though.
Here is a version that can go on until it finds the lowest non-composeable value, with the «--first» command line option:
File: fibonacci-sum-first
#! /usr/bin/env raku
subset PositiveInt of Int where * >= 1;
unit sub MAIN (PositiveInt $N, :v(:$verbose), :u(:$upto), :f(:$first));
my $label;
my $found;
my $found2 = True;
if $first
{
my $current = 1;
while ( $found2 )
{
fibonal-decomposition($current);
say ": Checking $current" if $verbose;
$current++;
}
}
else
{
$upto
?? (1..$N).map({ fibonal-decomposition($_) })
!! fibonal-decomposition($N);
}
sub fibonal-decomposition($target)
{
$found = False;
$label = 'a';
my @fibs;
my $fibonacci := (1, 1, * + * ... Inf);
for $fibonacci -> $fib { last if $fib > $target; @fibs.unshift: $fib; }
@fibs.pop;
if $verbose && ! $first
{
say ": Target: $target" if $upto;
say ": Fibonacci (reverse): { @fibs.join(", ") }";
}
recurse(0, (), @fibs, $target);
unless $first
{
say "0" unless $found;
say "" if $upto;
}
}
sub recurse ($value is copy, @values is copy, @fibonacci is copy, $input)
{
if $value < $input
{
while @fibonacci
{
my $add = @fibonacci.shift;
if $value + $add <= $input
{
my $value2 = $value + $add;
my @values2 = @values.clone.push: $add;
recurse($value2, @values2, @fibonacci, $input);
}
}
}
elsif $value == $input
{
say "{ $label++ }) { @values.join(' + ') } = $input" unless $first;
$found = True;
}
elsif $first
{
$found2 = False;
}
}
Note that we have to specify a value for $N,
even if it is ignored.
$ ./fibonacci-sum-first -f -v 1
: Checking 1
: Checking 2
: Checking 3
: Checking 4
: Checking 5
...
: Checking 30267
: Checking 30268
: Checking 30269
^C
I stopped it after about 48 hours..
The program takes longer and longer time for higher
$N values. The recursive approach is the culprit, as it adds a lot of overhead.
We can let the program show us, after some changes:
File: fibonacci-sum-first-verbose
#! /usr/bin/env raku
subset PositiveInt of Int where * >= 1;
unit sub MAIN (PositiveInt $N, :v(:$verbose), :u(:$upto), :f(:$first));
my $label;
my $found;
my $found2 = True;
my $recursion;
if $first
{
my $current = 1;
while ( $found2 )
{
$recursion = 0;
fibonal-decomposition($current);
say ": Checking $current [Recursive calls: $recursion]" if $verbose;
$current++;
}
}
else
{
$upto
?? (1..$N).map({ fibonal-decomposition($_) })
!! fibonal-decomposition($N);
}
sub fibonal-decomposition($target)
{
$found = False;
$label = 'a';
my @fibs;
my $fibonacci := (1, 1, * + * ... Inf);
for $fibonacci -> $fib { last if $fib > $target; @fibs.unshift: $fib; }
@fibs.pop;
if $verbose && ! $first
{
say ": Target: $target" if $upto;
say ": Fibonacci (reverse): { @fibs.join(", ") }";
}
recurse(0, (), @fibs, $target);
unless $first
{
say "0" unless $found;
say "" if $upto;
}
}
sub recurse ($value is copy, @values is copy, @fibonacci is copy, $input)
{
$recursion++;
if $value < $input
{
while @fibonacci
{
my $add = @fibonacci.shift;
if $value + $add <= $input
{
my $value2 = $value + $add;
my @values2 = @values.clone.push: $add;
recurse($value2, @values2, @fibonacci, $input);
}
}
}
elsif $value == $input
{
say "{ $label++ }) { @values.join(' + ') } = $input" unless $first;
$found = True;
}
elsif $first
{
$found2 = False;
}
}
Running it:
$ ./fibonacci-sum-first-verbose -f -v 1
: Checking 1 [Recursive calls: 2]
: Checking 2 [Recursive calls: 3]
: Checking 3 [Recursive calls: 5]
: Checking 4 [Recursive calls: 6]
: Checking 5 [Recursive calls: 8]
: Checking 6 [Recursive calls: 10]
: Checking 7 [Recursive calls: 11]
...
: Checking 100 [Recursive calls: 415]
...
: Checking 1000 [Recursive calls: 11069]
^C
m x n character matrix consists of O and
X only.
X surrounded by O
only. Print 0 if none found.
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.
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.
This task is very similar to #076.2 Word Search, but easier as we do not have to step further away than the neighbouring cells.
So this is basically a slightly simplified version of the «word-search» program, with som minor adjustments. See Primal Words with Raku for details of that program.
The challenge presents two matrices, and I have saved them as files:
File: matrix1.txt
O O X
X O O
X O O
O O X O
X O O O
X O O X
O X O O
#! /usr/bin/env raku
unit sub MAIN ($matrix where $matrix.IO.f && $matrix.IO.r = 'matrix1.txt',
:v(:$verbose));
my @matrix = $matrix.IO.lines.map( *.words.list );
die "Uneven grid row length" unless [==] @(@matrix)>>.elems;
die "Single characters only in the grid" if @(@matrix)>>.chars>>.max.max > 1;
my $rows = @matrix.elems;
my $cols = @matrix[0].elems;
my $is_lonely = 0;
for ^$rows -> $row # [1]
{
for ^$cols -> $col # [1a]
{
say ": [$row,$col] -> @matrix[$row][$col] { \
is_lonely(@matrix, $row, $col) ?? 'is lonely' !! '' }" if $verbose;
$is_lonely++ if is_lonely(@matrix, $row, $col); # [1b]
}
}
say $is_lonely; # [2]
sub is_lonely (@matrix, $row, $col) # [3]
{
return False if @matrix[$row][$col] eq 'O'; # [4]
for (-1, 0, 1) -> $r # [5]
{
for (-1, 0, 1) -> $c # [5a]
{
next if $r == $c == 0; # [6]
next unless @matrix[$row + $r][$col + $c].defined; # [7]
return False if @matrix[$row + $r][$col + $c] eq 'X'; # [8]
}
}
return True; # [9]
}
[1] The general idea is to iterate over all the positions in the matrix [1 and 1a], and check if the cell is lonely [1b].
[2] Print the number of lonely cells.
[3] The procedure returns True if the cell is lonely, and False
otherwise.
[4] The cell must have the value X to be applicable to the non-lonely rule.
[5] Iterate over all the neighbouring cells, rows [5] and columns [5a].
[6] Skip the cell itself.
[7] Skip cells that does not exist (that are off the edge).
[8] Return False if we find an X.
[9] If we have no reason to return False, it must be True.
Running it:
$ ./lonely-x
1
$ ./lonely-x matrix2.txt
2
With verbose mode:
$ ./lonely-x -v
: [0,0] -> O
: [0,1] -> O
: [0,2] -> X is lonely
: [1,0] -> X
: [1,1] -> O
: [1,2] -> O
: [2,0] -> X
: [2,1] -> O
: [2,2] -> O
1
$ ./lonely-x -v matrix2.txt
: [0,0] -> O
: [0,1] -> O
: [0,2] -> X is lonely
: [0,3] -> O
: [1,0] -> X
: [1,1] -> O
: [1,2] -> O
: [1,3] -> O
: [2,0] -> X
: [2,1] -> O
: [2,2] -> O
: [2,3] -> X is lonely
: [3,0] -> O
: [3,1] -> X
: [3,2] -> O
: [3,3] -> O
2
Note that I have chosen to display indices (zero based), and not row/column numbers (starting at 1) as shown in the challenge.
And that's it.