Merge pull request #3850 from jo-37/contrib

Solutions to challenge 107

3 files changed, 224 insertions, 0 deletions

diff --git a/challenge-107/jo-37/perl/Calc.pm b/challenge-107/jo-37/perl/Calc.pm
new file mode 100644
index 0000000000..4123090fde
--- /dev/null
+++ b/challenge-107/jo-37/perl/Calc.pm
@@ -0,0 +1,11 @@
+package Calc;
+
+use strict;
+use warnings;
+
+sub new { bless {}, shift; }
+sub add { }
+sub mul { }
+sub div { }
+
+1;
diff --git a/challenge-107/jo-37/perl/ch-1.pl b/challenge-107/jo-37/perl/ch-1.pl
new file mode 100755
index 0000000000..8ef8f2b098
--- /dev/null
+++ b/challenge-107/jo-37/perl/ch-1.pl
@@ -0,0 +1,96 @@
+#!/usr/bin/perl -s
+
+use v5.16;
+use Test2::V0;
+use Math::Prime::Util qw(fromdigits todigitstring forcomp);
+use List::Util 'all';
+use List::MoreUtils 'frequency';
+use experimental 'signatures';
+
+our ($tests, $examples, $verbose);
+
+run_tests() if $tests || $examples;	# does not return
+
+die <<EOS unless @ARGV;
+usage: $0 [-examples] [-tests] [-verbose] [base...]
+
+-examples
+    run the examples from the challenge
+ 
+-tests
+    run some tests
+
+-verbose
+    include the decimal representation in the output
+
+base...
+    find self-descriptive numbers for given base(s)
+    Call "$0 4 5" for the task's solution.
+
+EOS
+
+
+### Input and Output
+
+for my $base (@ARGV) {
+    say todigitstring($_, $base), " ($base) = $_ (10)" x !!$verbose
+        for @{self_descriptive($base)};
+}
+
+
+### Implementation
+
+# A self-descriptive number has (besides its self-descriptiveness) two
+# basic properties: In the given base the sum of its digits equals the
+# base and the least significant digit is zero.  These properties may be
+# used to select candidates.  There are utility subroutines that iterate
+# over compositions, i.e. all the (ordered) summands for a given sum.
+# However, the smallest value for a summand in a composition is one.  If
+# we add one to our digits, they are in the range 1 .. base and give a
+# sum of 2*base.  Furthermore, the last summand becomes one (instead of
+# zero) and so the (restricted) compositions consist of base - 1
+# remaining summands with a sum of 2*base - 1.  Such a composition
+# iteration is provided by Math::Prime::Util::forcomp.
+# A candidate is self-descriptive, if it resembles its digit
+# frequencies, which can be easily calculated using
+# List::MoreUtils::frequency.
+# Finally, assemble the digits into a number.  This extra step assures
+# the correct processing of bases larger than 10.
+#
+sub self_descriptive ($base) {
+    my @sd;
+    forcomp {
+        # Get the true digits in the range 0 .. $base - 1.
+        my @digit = map $_ - 1, @_, 1;
+        my %freq = frequency @digit;
+        push @sd, fromdigits(\@digit, $base) if all {
+            $digit[$_] ?
+                $freq{$_} && $digit[$_] == $freq{$_} :
+                !$freq{$_}
+        } 0 .. $#digit;
+    } 2 * $base - 1, {n => $base - 1, amax => $base};
+
+    \@sd;
+}
+
+
+### Examples and tests
+
+sub run_tests {
+    SKIP: {
+        skip "examples" unless $examples;
+
+        is self_descriptive(4), [100, 136], 'first two';
+        is self_descriptive(5), [1425], 'third';
+    }
+
+    SKIP: {
+        skip "tests" unless $tests;
+        is self_descriptive(6), [], 'base 6';
+        is self_descriptive(7), [389305], 'base 7';
+        is self_descriptive(8), [8946176], 'base 8';
+	}
+
+    done_testing;
+    exit;
+}
diff --git a/challenge-107/jo-37/perl/ch-2.pl b/challenge-107/jo-37/perl/ch-2.pl
new file mode 100755
index 0000000000..1818f306f4
--- /dev/null
+++ b/challenge-107/jo-37/perl/ch-2.pl
@@ -0,0 +1,117 @@
+#!/usr/bin/perl -s -T
+
+use v5.16;
+use Test2::V0;
+use lib '.';
+
+our ($tests, $examples);
+
+run_tests() if $tests || $examples;	# does not return
+
+die <<EOS unless @ARGV;
+usage: $0 [-examples] [-tests] [package...]
+
+-examples
+    run the examples from the challenge
+ 
+-tests
+    run some tests
+
+package...
+    "require"s <package> and lists the subs therein.
+    Call "$0 Calc" for the task's example.
+
+EOS
+
+
+### Input and Output
+
+for (@ARGV) {
+    # Untaint input.  Allow "::" and "'" as package separators.
+    next unless /^( (?&PKG) (?: (?: :: | ' ) (?&PKG) )* )$
+        (?(DEFINE) (?<PKG> [_[:alpha:]] [[:word:]]*))/x;
+    my $package = $1;
+
+    eval "require $package";
+    die $@ if $@;
+
+    say "\n$package:";
+    say for sort @{list_methods($package)};
+}
+
+
+### Implementation
+
+# Not a solution, but an approximation:
+#
+# Inspecting the package's symbol table to solve the task, though this
+# approach cannot lead to a proper solution.  The five specially named
+# code blocks "BEGIN" etc. have an empty CODE slot in their symbol
+# table's entry.  This makes them indistinguishable from any other entry
+# *not* referencing a sub.  Specifically, an undefined but used
+# package-global scalar-only variable looks exactly the same.  See
+# example "Foo".
+# For the sake of simplicity assuming the existence of a special block
+# if there is a symbol table entry with such a name.  This may lead to
+# false positives if a variable or a format with the name of a special
+# block is in use.  Heuristics based on the content of other slots would
+# make things even worse: In addition to the inevitable false positives
+# this would produce false negatives.
+#
+sub list_methods {
+    # Get a reference to the package's symbol table.  Using a symbolic
+    # ref to simplify matters.
+    my $symtab = do {no strict 'refs'; *{shift . '::'}{HASH}};
+
+    [grep {
+        *{$symtab->{$_}}{CODE} || /^(?:BEGIN|UNITCHECK|CHECK|INIT|END)$/;
+    } keys %{$symtab}];
+}
+
+
+### Examples and tests
+
+sub run_tests {
+    SKIP: {
+        skip "examples" unless $examples;
+
+        require Calc;
+        is list_methods('Calc'), bag {item 'BEGIN'; item 'mul';
+            item 'div'; item 'new'; item 'add'; end},
+            'example';
+    }
+
+    SKIP: {
+        skip "tests" unless $tests;
+
+        is list_methods('Foo::Bar'),
+            bag {item 'foo_bar'; item 'INIT'; end},
+            'every possible slot is in use';
+
+        is list_methods('Foo'), bag {item 'foo'; item 'BEGIN'; end},
+            'false positive';
+	}
+
+    done_testing;
+    exit;
+}
+
+
+package Foo::Bar;
+
+sub foo_bar {}
+our @array;
+our %hash;
+INIT {
+    our $scalar = 1;
+    *FH = *STDIN{IO};
+}
+() = *FH;
+format FORMAT =
+. 
+
+
+package Foo;
+
+sub foo {}
+our $BEGIN;