Add 246: 6 out of 49 & Linear Recurrence of 2nd Order by E. Choroba

2 files changed, 143 insertions, 0 deletions

diff --git a/challenge-246/e-choroba/perl/ch-1.pl b/challenge-246/e-choroba/perl/ch-1.pl
new file mode 100755
index 0000000000..2f284d6869
--- /dev/null
+++ b/challenge-246/e-choroba/perl/ch-1.pl
@@ -0,0 +1,23 @@
+#!/usr/bin/perl
+use warnings;
+use strict;
+use experimental qw( signatures );
+
+use List::Util qw{ shuffle uniq };
+
+sub six_out_of_49() {
+    (shuffle(1 .. 49))[0 .. 5]
+}
+
+use constant TIMES => 100;
+use Test::More tests => TIMES * (2 + 2 * 6);
+
+for (1 .. TIMES) {
+    my @so49 = six_out_of_49();
+    for my $s (@so49) {
+        cmp_ok $s, '<=', 50, 'upper bound';
+        cmp_ok $s, '>=', 1, 'lower bound';
+    }
+    is scalar @so49, 6;
+    is uniq(@so49), @so49, 'unique';
+}
diff --git a/challenge-246/e-choroba/perl/ch-2.pl b/challenge-246/e-choroba/perl/ch-2.pl
new file mode 100755
index 0000000000..a78902bd6c
--- /dev/null
+++ b/challenge-246/e-choroba/perl/ch-2.pl
@@ -0,0 +1,120 @@
+#!/usr/bin/perl
+use warnings;
+use strict;
+use feature qw{ say };
+use experimental qw( signatures );
+
+sub linear_recurrence_of_2nd_order(@a) {
+    my ($p, $q);
+    if (0 == $a[0]) {
+        return [0, 0] if @a == grep 0 == $_, @a;
+        return if 0 == $a[1];
+
+        $q = $a[2] / $a[1];
+        return unless $q == int $q;
+
+        $p = ($a[1] * $a[3] - $a[2] ** 2) / $a[1] ** 2;
+
+    } elsif ($a[1] ** 2 == $a[0] * $a[2]) {
+        return unless $a[1] * $a[2] == $a[0] * $a[3];
+
+        if (0 == $a[1]) {
+            return unless 3 == grep 0 == $_, @a[2 .. 4];
+            return [0, 0]
+        }
+
+        if ($a[2] ** 2 == $a[0] * $a[1] * $a[3]) {
+            return unless $a[4] == $a[1] * $a[3];
+            return [$a[1] + $a[2], -1]
+        }
+
+        $q = ($a[0] * $a[1] * $a[4] - $a[1] * $a[2] ** 2)
+           / ($a[0] * $a[1] * $a[3] - $a[2] ** 2);
+        return unless $q == int $q;
+
+
+        $p = ($a[1] * $a[2] - $q * $a[0] * $a[2]) / ($a[0] * $a[1]);
+    } else {
+        $q = ($a[1] * $a[2] - $a[0] * $a[3]) / ($a[1] ** 2 - $a[0] * $a[2]);
+        return unless $q == int $q;
+
+        $p = ($a[2] - $q * $a[1]) / $a[0];
+    }
+    return unless $p == int $p;
+
+    return unless $a[4] == $p * $a[2] + $q * $a[3];
+
+    return [$p, $q]
+}
+
+use Test::More tests => 3 + 1 + 10;
+
+ok linear_recurrence_of_2nd_order(1, 1, 2, 3, 5), 'Example 1';
+ok ! linear_recurrence_of_2nd_order(4, 2, 4, 5, 7), 'Example 2';
+ok linear_recurrence_of_2nd_order(4, 1, 2, -3, 8), 'Example 3';
+
+# p = 0, a[0] is irrelevant.
+ok linear_recurrence_of_2nd_order(qw( 15 1 16 256 4096 ));
+
+ok linear_recurrence_of_2nd_order(qw( 2 4 8 16 32 ));
+ok linear_recurrence_of_2nd_order(qw( -13 1 0 1 13 ));
+ok linear_recurrence_of_2nd_order(qw( -12 11 -10 8 8 ));
+ok linear_recurrence_of_2nd_order(qw( 1 -2 4 -8 16));
+ok linear_recurrence_of_2nd_order(qw( 1 -1 1 -1 1 ));
+ok linear_recurrence_of_2nd_order(qw( 3 5 8 16 0 ));
+ok ! linear_recurrence_of_2nd_order(qw( 3 0 0 6 6 ));
+ok ! linear_recurrence_of_2nd_order(qw( 0 -4 0 5 0 ));
+ok ! linear_recurrence_of_2nd_order(qw( 0 8 8 6 4 ));
+ok ! linear_recurrence_of_2nd_order(qw( 1 -1 1 -1 7 ));
+
+#
+# Extended testing.
+#
+# Hash all the possible sentences generated from p, q, a0, a1 in -20 .. 20.
+# Then generate random sentences and verify that they're recognised correctly.
+# This was great for debugging the edge cases.
+
+sub generate($p, $q, $a0, $a1) {
+    my @a = ($a0, $a1);
+    $a[$_] = $p * $a[$_ - 2] + $q * $a[$_ - 1] for 2, 3, 4;
+    return @a
+}
+
+my %generated;
+my %i;
+for my $p (-20 .. 20) {
+    for my $q (-20 .. 20) {
+        for my $a0 (-20 .. 20) {
+            for my $a1 (-20 .. 20) {
+                my @a = generate($p, $q, $a0, $a1);
+                next if grep 1000 < abs, @a;
+
+                $generated{"@a"} = "$p $q";
+            }
+        }
+    }
+}
+
+my $c = 0;
+my @a;
+local $SIG{__DIE__} = sub { warn "\t@a"; exit 1 };
+while (++$c < 1e7) {
+    @a = map -19 + int rand 38, 0 .. 4;
+    print "$c: @a          \r";
+    if (exists $generated{"@a"}) {
+        my $pq = linear_recurrence_of_2nd_order(@a);
+        die "not ok @a (" . $generated{"@a"} . ')' unless $pq;
+        my @b = generate(@$pq, @a[0, 1]);
+        die "generated @a != @b (@$pq)" unless "@a" eq "@b";
+    } else {
+        my $pq = linear_recurrence_of_2nd_order(@a);
+        if ($pq) {
+            if (grep abs > 20, @$pq) {
+                my @b = generate(@$pq, @a[0, 1]);
+                die "!gen @a != @b (@$pq)" unless "@a" eq "@b";
+            } else {
+                die "not ok ! @a (@$pq)";
+            }
+        }
+    }
+}