diff options
Diffstat (limited to 'challenge-246')
| -rwxr-xr-x | challenge-246/e-choroba/perl/ch-1.pl | 23 | ||||
| -rwxr-xr-x | challenge-246/e-choroba/perl/ch-2.pl | 120 | ||||
| -rw-r--r-- | challenge-246/mark-anderson/raku/ch-1.raku | 3 | ||||
| -rw-r--r-- | challenge-246/mark-anderson/raku/ch-2.raku | 27 | ||||
| -rwxr-xr-x | challenge-246/peter-meszaros/perl/ch-1.pl | 34 | ||||
| -rwxr-xr-x | challenge-246/peter-meszaros/perl/ch-2.pl | 76 |
6 files changed, 283 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)"; + } + } + } +} diff --git a/challenge-246/mark-anderson/raku/ch-1.raku b/challenge-246/mark-anderson/raku/ch-1.raku new file mode 100644 index 0000000000..757c3fe00d --- /dev/null +++ b/challenge-246/mark-anderson/raku/ch-1.raku @@ -0,0 +1,3 @@ +#!/usr/bin/env raku + +.say for (1..49).pick(6).sort; diff --git a/challenge-246/mark-anderson/raku/ch-2.raku b/challenge-246/mark-anderson/raku/ch-2.raku new file mode 100644 index 0000000000..d162ab93d3 --- /dev/null +++ b/challenge-246/mark-anderson/raku/ch-2.raku @@ -0,0 +1,27 @@ +#!/usr/bin/env raku +use Math::Matrix; +use Test; + +# Disclaimer: This might be totally wrong but it seems right. + +ok task2(1,1,2,3,5); +nok task2(4,2,4,5,7); +ok task2(4,1,2,-3,8); + +sub task2(*@a) +{ + my @equations = @a.rotor(3 => -2); + + my ($p1,$q1) = p-and-q(@equations[0], @equations[1]); + my ($p2,$q2) = p-and-q(@equations[1], @equations[2]); + + return False unless ($p1,$q1,$p2,$q2)>>.narrow.all ~~ Int; + return ($p1,$q1) eqv ($p2,$q2) +} + +sub p-and-q(@a, @b) +{ + my $A = Math::Matrix.new([[@a.head(2), @b.head(2)]]); + my $B = Math::Matrix.new([[@a.tail], [@b.tail]]); + |$A.inverted.dot-product($B) +} diff --git a/challenge-246/peter-meszaros/perl/ch-1.pl b/challenge-246/peter-meszaros/perl/ch-1.pl new file mode 100755 index 0000000000..21d1ae0286 --- /dev/null +++ b/challenge-246/peter-meszaros/perl/ch-1.pl @@ -0,0 +1,34 @@ +#!/usr/bin/env perl +# +# 6 out of 49 is a German lottery. +# +# Write a script that outputs six unique random integers from the range 1 to 49. +# Output +# +# 3 +# 10 +# 11 +# 22 +# 38 +# 49 + +use strict; +use warnings; + +sub six_outof_fortynine +{ + my %h; + + while (keys %h < 6) { + $h{int(rand(48))+1}++; + } + return sort {$a <=> $b} keys %h; +} + +for my $i (1..10) { + printf "%2d %s\n", $i, join('-', map { sprintf("%2d", $_) } six_outof_fortynine()); +} + +exit 0; + + diff --git a/challenge-246/peter-meszaros/perl/ch-2.pl b/challenge-246/peter-meszaros/perl/ch-2.pl new file mode 100755 index 0000000000..ac3a0218cc --- /dev/null +++ b/challenge-246/peter-meszaros/perl/ch-2.pl @@ -0,0 +1,76 @@ +#!/usr/bin/env perl +# +# You are given an array @a of five integers. +# +# Write a script to decide whether the given integers form a linear recurrence +# of second order with integer factors. +# +# A linear recurrence of second order has the form +# +# a[n] = p * a[n-2] + q * a[n-1] with n > 1 +# +# where p and q must be integers. +# +# Example 1 +# +# Input: @a = (1, 1, 2, 3, 5) +# Output: true +# +# @a is the initial part of the Fibonacci sequence a[n] = a[n-2] + a[n-1] +# with a[0] = 1 and a[1] = 1. +# +# Example 2 +# +# Input: @a = (4, 2, 4, 5, 7) +# Output: false +# +# a[1] and a[2] are even. Any linear combination of two even numbers with +# integer factors is even, too. Because a[3] is odd, the given numbers cannot +# form a linear recurrence of second order with integer factors. +# +# Example 3 +# +# Input: @a = (4, 1, 2, -3, 8) +# Output: true +# +# a[n] = a[n-2] - 2 * a[n-1] +# + +use strict; +use warnings; +use Test::More; +use Data::Dumper; + +my $cases = [ + [1, 1, 2, 3, 5], + [4, 2, 4, 5, 7], + [4, 1, 2, -3, 8], +]; + +# a[2] = p * a[0] + q * a[1] +# a[3] = p * a[1] + q * a[2] +# a[4] = p * a[2] + q * a[3] +# -------------------------- +# p = (a[2] - q * a[1]) / a[0] +# q = (a[3] * a[0] - a[2] * a[1]) / (a[2] * a[0] - a[1] * a[1]) +# r = p * a[2] + q + a[3] +# if p is int and q is int and r == a[4] then true else false +sub linreq_of_second_order +{ + my $l = shift; + + my $q = ($l->[3]*$l->[0] - $l->[2]*$l->[1]) / + ($l->[2]*$l->[0] - $l->[1]*$l->[1]); + my $p = ($l->[2] - $q*$l->[1]) / $l->[0]; + + my $r = $p*$l->[2] + $q*$l->[3]; + + return ($p == int($p) && $q == int($q) && $l->[4] == $r) ? 1 : 0; +} + +is(linreq_of_second_order($cases->[0]), 1, '[1, 1, 2, 3, 5]'); +is(linreq_of_second_order($cases->[1]), 0, '[4, 2, 4, 5, 7]'); +is(linreq_of_second_order($cases->[2]), 1, '[4, 1, 2, -3, 8]'); +done_testing(); + +exit 0; |