Merge pull request #2803 from jo-37/contrib

Solutions to challenge 087

2 files changed, 222 insertions, 0 deletions

diff --git a/challenge-087/jo-37/perl/ch-1.pl b/challenge-087/jo-37/perl/ch-1.pl
new file mode 100755
index 0000000000..acf4ed0550
--- /dev/null
+++ b/challenge-087/jo-37/perl/ch-1.pl
@@ -0,0 +1,46 @@
+#!/usr/bin/perl
+
+use Test2::V0;
+use List::Util qw(reduce uniqnum);
+
+# Find longest consecutive sequence in a list of integers.  An empty
+# result in boolean context gives zero as requested.
+sub lcs {
+	# Sort unique values.
+	my @sorted = uniqnum sort {$a <=> $b} @_;
+
+	# Abusing "reduce" as a sliding window implementation for two
+	# elements at a time.
+	# Transform the sorted list into sawtooth shape, where every number
+	# is shifted to zero if is not the successor of the previous.
+	my @sawtooth;
+	my $level;
+	reduce {
+			$level = $b if $b != $a + 1;
+			push @sawtooth, $b - $level;
+			$b
+		} '-inf', @sorted;
+	
+	# Find the maximum and simultanously its position in the list.
+	my $maxat = reduce {
+			$sawtooth[$b] > $a->[0] ? [$sawtooth[$b], $b] : $a
+		} ['-inf'], 0 .. $#sawtooth;
+
+	# The longest consecutive list ends at the position of the maximum
+	# and has one more element than the maximum in the sawtooth list.
+	# Extract this sublist from the ordered list.  Empty the result list
+	# if the maximum is zero, i.e.  if the lcs consists of a single
+	# number.
+	(@sorted[$maxat->[1] - $maxat->[0] .. $maxat->[1]]) x !!$maxat->[0];
+}
+
+is [lcs 100, 4, 50, 3, 2], [2, 3, 4], 'Example 1';
+is lcs(20, 30, 10, 40, 50), F(), 'Example 2';
+is [lcs 20, 19, 9, 11, 10], [9, 10, 11], 'Example 3';
+
+is [lcs 1, 2, 3, 11, 12, 13, 14, 21, 22], [11, 12, 13, 14], 'max != index';
+is [lcs 12, 3, 1, 14, 5, 2, 11, 3, 4, 13], [1, 2, 3, 4, 5], 'has duplicate';
+is [lcs 1, 2.1, 3.2, 4.3, 5.3, 6.3, 7.2, 8.1, 9], [4.3, 5.3, 6.3],
+	'works with broken numbers, too';
+
+done_testing;
diff --git a/challenge-087/jo-37/perl/ch-2.pl b/challenge-087/jo-37/perl/ch-2.pl
new file mode 100755
index 0000000000..f16b534c35
--- /dev/null
+++ b/challenge-087/jo-37/perl/ch-2.pl
@@ -0,0 +1,176 @@
+#!/usr/bin/perl
+
+use 5.012;
+use PDL;
+use Test2::V0 '!float';
+#use Digest::xxHash 'xxhash64';
+no warnings 'recursion';
+
+#BEGIN {
+#	$::seed = time;
+#}
+
+# Uncomment to enable trace output and additional examples:
+#$::verbose = 1;
+
+# Generate trace output including the recursion level and depending on
+# the verbose setting.
+our $level;
+sub trace {
+	say "$level> ", @_ if $::verbose;
+}
+
+# Recursively find a maximum submatrix consising of only non-zero
+# elements with a size larger than the given current maximum.  Extending
+# the task to any non-zero values instead of ones. 
+sub maxrect_r;
+sub maxrect_r {
+	local $level = defined $level ? $level + 1 : 0;
+
+	# Maximum to be surpassed:
+	my $max = shift;
+	# Provide a default result.
+	my $maxrect = PDL->null;
+	
+	# Matrix to be examined:
+	my $m = shift;
+	trace "in: $m";
+
+	# Hash ref containing already processed parts:
+	my $seen = shift;
+
+	# Could use a hash over the matrix' string representation for its
+	# identification.  Any "good" hashing algorithm may be used.  For
+	# the sake of convenience it is omitted here and the string
+	# representation itself is used.
+#	our $seed;
+#	my $hash = xxhash64 $m, $seed;
+	my $hash = "$m";
+
+	# Avoid reprocessing of the same data.
+	trace("seen"),
+	return $maxrect if $seen->{$hash};
+
+	# Record the given matrix as seen.
+	$seen->{$hash} = 1;
+
+	# Count non-zero elements:
+	my $nonzero = $m->where($m)->nelem;
+
+	# There cannot be a new maximum inside this matrix if there are not
+	# enough non-zeroes in it.
+	trace("cut"),
+	return $maxrect if $nonzero <= $max;
+
+	# A new maximum is found at this point if all elements of the matrix
+	# are non-zero, i.e. the count equals the product of the dimensions.
+	trace("out: max=$nonzero $m"),
+	return $m if $nonzero == prod($m->shape);
+
+	# Lists of indices for both dimensions to be used as slicing /
+	# dicing arguments.
+	my $i0 = sequence $m->dim(0);
+	my $i1 = sequence $m->dim(1);
+
+	# Get coordinates of all zeroes in $m.
+	my $zeroes = whichND(!$m);
+
+	# Get the coordinates of a zero most central in the matrix.
+	# This is not really necessary as any zero could be used here.
+	# Explanation: take the difference from the coordinates to the
+	# middle of the matrix, add the absolute values of these, find
+	# the index where a minimum is obtained and finally select the zero
+	# at the selected index.
+	my $zero = $zeroes->slice([],
+		[minimum_ind(abs($zeroes - ($m->shape-1)/2)->sumover), undef, 0]);
+
+	trace "zero at $zero";
+
+	# Obviously, a zero element is not part of any non-zero rectangle,
+	# even less of a maximum one.  Thus the matrix can be decomposed
+	# into four (possibly empty) sub matrices avoiding it: left, right,
+	# above and below of it.  (The special choice of the zero element
+	# results in a decomposition as even as possible.) Recurse into each
+	# non-empty sub matrix and take any new found maximum.  As the sub
+	# matrices overlap, already processed parts are tracked to prevent
+	# the overhead of reprocessing.
+	my $part;
+	foreach (	# slice (or rather: dice) arguments for the four sub
+				# matrices:
+			[$i0->where($i0 < $zero->at(0)), $i1],
+			[$i0->where($i0 > $zero->at(0)), $i1],
+			[$i0, $i1->where($i1 < $zero->at(1))],
+			[$i0, $i1->where($i1 > $zero->at(1))]) {
+
+		trace "part #", ++$part;
+
+		# Skip empty slices.
+		trace("empty"),
+		next if grep {$_->isempty} @$_;
+
+		# Recurse into the sub matrix.
+		my $maxsub = maxrect_r $max, $m->slice(@$_), $seen;
+		
+		# Check for a new maximum.
+		my $size = prod($maxsub->shape);
+		($maxrect, $max) = ($maxsub, $size) if $size > $max;
+	}
+	trace "out: max=$max $maxrect" unless $maxrect->isempty;
+
+	$maxrect;
+}
+
+# Convenience wrapper for maxrect_r.  Transform input data into a
+# piddle, set the current maximum to 1 to avoid invalid trivial
+# solutions and return the result as a perl array ref.
+sub maxrect {
+	maxrect_r(1, long(@_))->unpdl;
+}
+
+
+# main
+
+is maxrect([
+		[0, 0, 0, 1, 0, 0],
+		[1, 1, 1, 0, 0, 0],
+		[0, 0, 1, 0, 0, 1],
+		[1, 1, 1, 1, 1, 0],
+		[1, 1, 1, 1, 1, 0]]),
+
+		[[1, 1, 1, 1, 1],
+		 [1, 1, 1, 1, 1]], 'Example 1';
+
+is maxrect([
+		[1, 0, 1, 0, 1, 0],
+		[0, 1, 0, 1, 0, 1],
+		[1, 0, 1, 0, 1, 0],
+		[0, 1, 0, 1, 0, 1]]), [], 'Example 2';
+
+my $ex3 = [
+		[0, 0, 0, 1, 1, 1],
+		[1, 1, 1, 1, 1, 1],
+		[0, 0, 1, 0, 0, 1],
+		[0, 0, 1, 1, 1, 1],
+		[0, 0, 1, 1, 1, 1]];
+is maxrect($ex3),
+		[[1, 1, 1, 1],
+		 [1, 1, 1, 1]], 'Example 3';
+
+SKIP: {
+	skip "additional example", 2 unless $::verbose;
+	my $m = long($ex3);
+	my $ones = $m->where($m);
+	$ones .= sequence($ones->dim(0)) + 1;
+
+	# Example 3, enumerated
+	is maxrect($m),
+		[[12, 13, 14, 15],
+		 [16, 17, 18, 19]], 'Example 3, enumerated';
+
+	# Random data, 2/3 filled.
+	my $r = byte(random(9, 9) * 3);
+	$r .= ($r > 0);
+	ok maxrect($r), "random example";
+}
+
+done_testing;