Merge pull request #1142 from jacoby/master

Challenge 43

4 files changed, 257 insertions, 0 deletions

diff --git a/challenge-043/dave-jacoby/blog.txt b/challenge-043/dave-jacoby/blog.txt
new file mode 100644
index 0000000000..21d1b81cb4
--- /dev/null
+++ b/challenge-043/dave-jacoby/blog.txt
@@ -0,0 +1 @@
+https://jacoby.github.io/2020/01/17/perl-weekly-challenge-43-rings-and-selfdescription.html
\ No newline at end of file
diff --git a/challenge-043/dave-jacoby/perl/ch-1.pl b/challenge-043/dave-jacoby/perl/ch-1.pl
new file mode 100644
index 0000000000..49168828cf
--- /dev/null
+++ b/challenge-043/dave-jacoby/perl/ch-1.pl
@@ -0,0 +1,102 @@
+#!/usr/bin/env perl
+
+use strict;
+use warnings;
+use utf8;
+use feature qw{ postderef say signatures state switch };
+no warnings
+  qw{ experimental::postderef experimental::smartmatch experimental::signatures };
+
+use List::Util qw{sum0};
+
+my $instructions = <<'END';
+    https://perlweeklychallenge.org/blog/perl-weekly-challenge-043/
+
+    There are 5 rings in the Olympic Logo as shown below. 
+    They are color coded as in Blue, Black, Red, Yellow and Green.
+
+        Olympic Rings
+
+    We have allocated some numbers to these rings as below:
+    Blue: 8
+    Yellow: 7
+    Green: 5
+    Red: 9
+
+    The Black ring is empty currently. You are given the numbers 
+    1, 2, 3, 4 and 6. Write a script to place these numbers in 
+    the rings so that the sum of numbers in each ring is exactly 11.
+END
+
+my $commentary = <<'END';
+
+    There is one possible solution to this, so it's more a logic puzzle
+    than a math puzzle. It is suitable for brute force, however.
+
+    The tools I use here are permutations and sum0. sum returns undef when
+    given an empty list, while sum0 returns 0. This shouldn't matter, but
+    I'm using sum0.
+
+    Given the array [1,2,3], the values can be rearranged in six unique ways.
+
+        1, 2, 3
+        1, 3, 2
+        2, 1, 3
+        2, 3, 1
+        3, 1, 2
+        3, 2, 1
+
+    These are the permutations, and permute_array returns an array 
+    containing all possible variations, or permutations. 
+
+    In this, the number within both the red and green ring will 
+    be called red/green, the number that's only within the black
+    ring will be called black, and so on. 
+
+    The generated solution is this:
+
+        red/green:      2
+        black/green:    4
+        black/yellow:   1
+        purple/yellow:  3
+        black:          6
+
+END
+
+my $nums = [ 1 .. 4, 6 ];
+
+my @perms = permute_array($nums);
+
+for my $p (@perms) {
+    next unless eleven( 9, $p->[0] );             # red
+    next unless eleven( 8, $p->[3] );             # purple
+    next unless eleven( 5, $p->[0], $p->[1] );    # green
+    next unless eleven( 7, $p->[2], $p->[3] );    # green
+    next unless eleven( $p->[1], $p->[2], $p->[4] );
+    say <<"END";
+        red/green:      $p->[0]
+        black/green:    $p->[1]
+        black/yellow:   $p->[2]
+        purple/yellow:  $p->[3]
+        black:          $p->[4]
+END
+}
+
+sub eleven ( @array ) {
+    my $r = sum0 @array;
+    my $s = $r == 11 ? 1 : 0;
+    return $s;
+}
+
+sub permute_array ( $array ) {
+    return $array if scalar $array->@* == 1;
+    my @response = map {
+        my $i        = $_;
+        my $d        = $array->[$i];
+        my $copy->@* = $array->@*;
+        splice $copy->@*, $i, 1;
+        my @out = map { unshift $_->@*, $d; $_ } permute_array($copy);
+        @out
+    } 0 .. scalar $array->@* - 1;
+    return @response;
+}
diff --git a/challenge-043/dave-jacoby/perl/ch-2a.pl b/challenge-043/dave-jacoby/perl/ch-2a.pl
new file mode 100644
index 0000000000..fd1e662b35
--- /dev/null
+++ b/challenge-043/dave-jacoby/perl/ch-2a.pl
@@ -0,0 +1,89 @@
+#!/usr/bin/env perl
+
+use strict;
+use warnings;
+use utf8;
+use feature qw{ postderef say signatures state switch };
+no warnings
+  qw{ experimental::postderef experimental::smartmatch experimental::signatures };
+
+use List::Util qw{ sum0 };
+use Scalar::Util qw{ looks_like_number };
+use JSON;
+my $json = JSON->new;
+
+my $instructions = <<'END';
+    Write a script to generate Self-descriptive Numbers in a given base.
+
+    In mathematics, a self-descriptive number is an integer m 
+    that in a given base b is b digits long in which each digit d 
+    at position n (the most significant digit being at position 0 
+    and the least significant at position b - 1) counts how many 
+    instances of digit n are in m.
+
+    For example, if the given base is 10, then script should print 
+    6210001000.
+END
+
+# the canonical steps are 
+
+#   * make it work
+#   * make it right
+#   * make it fast
+
+# and I have done the first two. 
+
+# Given base 2, there are 4 possible strings to analyze
+#   00 , which is 2 zeroes and 0 ones (20) and cannot be described in base-2
+#   01 , which is 1 zero and 1 one, (11), which does not describe this number
+#   10 , which is 1 zero and 1 one, (11), which does not describe this number
+#   11 , which is 0 zeroes and 2 ones, (02) which cannot be described in base-2
+
+# so, there's no self-describing base-2 number. 
+
+# going deeper, 42101000 is a self-describing base-8 number, as it has
+# 4 zeroes
+# 2 ones
+# 1 two
+# 0 threes
+# 1 four
+# and 0 fives, sixes or sevens.
+
+# additionally, since there are n digits in a base-n self-describing
+# number, the sum of the digits should be n as well.
+
+# NOTE: this program handles bases 2-10. Going above that involves adding
+# letters for numbers, with A meaning decimal 10 in base-11 and higher.
+# it'd be a small addition of complexity to convert A to 10 and vice
+# versa, but that seems frustrating.
+
+my $base = looks_like_number $ARGV[0] ? 0 + $ARGV[0] : 10;
+$base = $base > 0 ? $base : 10;
+exit if $base > 10;
+
+my @bases = 0 .. 9;
+
+my $min = 0 x $base;
+my $max = ($base) x $base;
+
+OUTER: for my $n ( $min .. $max ) {
+    my @count;
+    my @n = split //,$n;
+    my $sum = sum0  @n;
+
+    # first, we insure count is valid
+    # then we drop out-of-range entries
+    for my $d ( @n ) { next OUTER if $d >= $base }
+    next OUTER if $sum != $base;
+ 
+    map { @count[$_] = 0 } 0 .. $base - 1;
+    for my $d ( 0 .. $base - 1 ) {
+        $count[$d] = () = $n =~ /($d)/gmix;
+        next OUTER if $count[$d] >= $base;
+    }
+    my $c = join '', @count;
+    my $match =   $n == $c ? 1 : 0;
+    say join "\t", '', $n, $c, $match if $match;
+}
+
+__DATA__
diff --git a/challenge-043/dave-jacoby/perl/ch-2b.pl b/challenge-043/dave-jacoby/perl/ch-2b.pl
new file mode 100644
index 0000000000..2aadfeb088
--- /dev/null
+++ b/challenge-043/dave-jacoby/perl/ch-2b.pl
@@ -0,0 +1,65 @@
+#!/usr/bin/env perl
+
+use strict;
+use warnings;
+use utf8;
+use feature qw{ postderef say signatures state switch };
+no warnings
+  qw{ experimental::postderef experimental::smartmatch experimental::signatures };
+
+# Instead of finding all the self-descriptive numbers in a given set,
+# we generate them, knowing that, for 7 or more, there will be
+#   * 2 uses of the number 1 
+#       + 2
+#       + n - 4
+#   * 1 use of the number 2, being the count of 1s
+#   * n - 4 uses of 0
+#       + -1 because n in base-n will always be represented as 10
+#       + -1 from 0
+#       + -1 from 1
+#       + -1 from 2
+
+# I would combine this and ch-2a, but nah.
+
+my @base      = ( 0 .. 9, 'a' ... 'z' );
+my %to_base   = map { state $c = 0; $_ => $c++ } @base;
+my %from_base = reverse %to_base;
+
+for my $n ( reverse 7 .. 37 ) {
+    my $s = get_self($n);
+    next unless check_self( $s, $n );
+    say join "\t", $n, $s;
+}
+
+sub check_self ( $s, $n ) {
+    no warnings;
+    my @s = split //, $s;
+    my $b = $s[0];
+    my @check;
+
+    for my $i ( 0 .. $n - 1 ) {
+        my $eye = $from_base{$i};
+
+        my $c = $s[$i];
+
+        my @all = grep { $_ eq $eye } @s;
+        my $all = join ',', @all;
+
+        my $j   = scalar @all;
+        my $jay = $from_base{$j};
+
+        return 0 if $c ne $jay;
+    }
+
+    return 1;
+}
+
+sub get_self( $n ) {
+    my @output = map { 0 } 1 .. $n;
+    my $b      = $n - 4;
+    $output[0]  = $from_base{$b};
+    $output[1]  = 2;
+    $output[2]  = 1;
+    $output[$b] = 1;
+    return join '', @output;
+}