diff options
| -rwxr-xr-x | challenge-077/jo-37/perl/ch-1.pl | 106 | ||||
| -rwxr-xr-x | challenge-077/jo-37/perl/ch-2.pl | 50 |
2 files changed, 156 insertions, 0 deletions
diff --git a/challenge-077/jo-37/perl/ch-1.pl b/challenge-077/jo-37/perl/ch-1.pl new file mode 100755 index 0000000000..2f749912d5 --- /dev/null +++ b/challenge-077/jo-37/perl/ch-1.pl @@ -0,0 +1,106 @@ +#!/usr/bin/perl + +use Test2::V0; +use Algorithm::Combinatorics 'combinations'; +use List::Util 'sum'; +use List::MoreUtils qw(before bsearch); + +{ + # Caching: + + # @fib has all fibonacci numbers calculated so far. + my @fib; + + # $sa and $sb hold the starting values to continue the sequence. + my $sa = 1; + my $sb = 1; + + # @sum has the partial sums of calculated fibonacci numbers. + my @sum = (0); + + + # Check if $n is a fibonacci number. Afterwards all fibonacci + # numbers up to the smallest not less than $n are known. + sub is_fib { + my $n = shift; + + # Return result from cache if applicable for $n. + return bsearch {$_ <=> $n} @fib if $n <= $sa; + + # Otherwise continue the sequence until $n is exceeded. + for (my ($fa, $fb) = ($sa, $sb); + $fa <= $n; + ($fa, $fb) = ($fb, $fa + $fb)) { + + # Cache intermediate results. + push @fib, $fb; + + # Record next starting point. + ($sa, $sb) = ($fb, $fa + $fb); + + # Augment partial sums. + push @sum, $sum[$#sum] + $fb; + + return 1 if $fb == $n; + } + + undef; + } + + # Return the sequence of fibonacci numbers not larger than $n from + # the cache. + sub fib_seq { + my $n = shift; + die "cache limit: $sa, requested: $n" if $n > $sa; + + before {$_ > $n} @fib; + } + + # The smallest sum of l nonrepeated fibonacci numbers is the sum of + # the first l fibonacci numbers. This gives an upper limit for the + # length of combinations to add up as n. + sub lmax { + my $n = shift; + die "cache limit: $sa, requested: $n" if $n > $sa; + + my $lmax = 0; + $lmax++ while $sum[$lmax + 1] <= $n; + + $lmax; + } +} + +# Get all possible summations of $n from nonrepeated fibonacci numbers. +sub fib_sum { + my $n = shift; + + my @res; + # Fill cache for use with $n and pre-handle combinations of length 1. + push @res, [$n] if is_fib $n; + + # Get sequence from cache. + my @fib = fib_seq $n - 1; + + # Try lengths to be considered. + foreach my $l (2 .. lmax $n) { + # Try all combinations of length $l + my $it = combinations \@fib, $l; + while (my $c = $it->next) { + push @res, $c if sum(@$c) == $n; + } + } + @res; +} + +is [fib_sum(6)], [[1, 5], [1, 2, 3]], 'first example'; +is [fib_sum(9)], [[1, 8], [1, 3, 5]], 'second example'; +is [fib_sum(8)], [[8], [3, 5], [1, 2, 5]], 'fibonacci hit'; +is is_fib(90), F(), 'check 90 and fill cache up to 144'; +is [fib_seq(144)], meta {prop size => 11}, 'check cache for 144'; +eval {fib_seq(145)}; +is $@, T(), 'check cache miss'; +is lmax(18), 4, 'check lmax below sum'; +is lmax(19), 5, 'check lmax at sum'; +is lmax(20), 5, 'check lmax above sum'; + +done_testing; diff --git a/challenge-077/jo-37/perl/ch-2.pl b/challenge-077/jo-37/perl/ch-2.pl new file mode 100755 index 0000000000..27aba6afd1 --- /dev/null +++ b/challenge-077/jo-37/perl/ch-2.pl @@ -0,0 +1,50 @@ +#!/usr/bin/perl + +use 5.012; +use warnings; + +use PDL; + +# Find isolated ("lonely") ones in a piddle. Deviant from the +# challenge, numeric zeros and ones are used instead of the characters O +# and X. +# +# This is taken straight from the documentation of PDL::Threading. +# See https://metacpan.org/pod/PDL::Threading#Threaded-PDL-implementation +# for a more detailed explanation. +sub lonely_ones { + my $m = shift; + print $m; + + # Threaded calculation of "lonely ones". + my $square_count = $m + # Create 3x3 squares around each matrix element, + # having zero values outside the valid range. + ->range(ndcoords($m) - 1, 3, 'truncate') + # Move source dims to the front. + ->reorder(2, 3, 0, 1) + # Sum over rows and columns. This gives the number of ones in + # each square. + ->sumover->sumover; + + # "Lonely ones" are cells that are occupied and that have one "one" + # in the surrounding square. Multiplying the test result with the + # cell value itself gives true just for "lonely ones". Get their + # indices inside the matrix and convert these to an ordinary perl + # array (of arrays). + # Note: PDL indices are reversed. + local $" = ','; + say "lonely one at (@{[reverse @$_]})" + foreach @{whichND(($square_count == 1) * $m)->unpdl}; +} + +# A byte suffices to store one bit. +lonely_ones(byte( + [0, 0, 1], + [1, 0, 0], + [1, 0, 0])); +lonely_ones(byte( + [0, 0, 1, 0], + [1, 0, 0, 0], + [1, 0, 0, 1], + [0, 1, 0, 0])); |