Merge pull request #2244 from jo-37/contrib

Solutions to challenge 077

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]));