Perl Weekly Challenge #43 - Rings and Self-Description

Our taskmaster, @cpan_author, will be tending to a family emergency. However the Perl Weekly Challenge shakes out while he’s away, I’m glad he’s tending to the important things, and wish him and his family the best.

CHALLENGE 1

There are 5 rings in the Olympic Logo as shown below. They are color coded as in Blue, Black, Red, Yellow and Green.

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.

First and foremost, this is a logic puzzle, solvable with thought and without computers.

Red Circle:     9 + j = 11
                j == 2
Purple Circle:  8 + k = 11
                k = 3
Green Circle:   j + 5 + l = 11
                2 + 5 * l = 11
                7 + l = 11
                l = 4
Yellow Circle:  7 + k + m = 11
                7 + 3 + m = 11
                m = 1
Black Circle:   i + l + m = 11
                i + 1 + 4 = 11
                i = 6

You don’t need to throw the number 6 in there to know the number in the black circle is 6.

However:

#!/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 $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] );    # black
    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;
}

CHALLENGE 2

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. For more information, please checkout wiki page.

#!/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;
    say STDERR qq{ ... $n} if $n =~ /0000000$/;

    # 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;
}

But…

This code will determine if a number is self-descriptive, and check against all possible numbers, and for base-n, we need to check nⁿ numbers. For smaller numbers, this is small: 2² is 4. 4⁴ is 256. 10¹⁰ is 10,000,000,000, and that’s big. After base-9, it might be better to build the numbers rather than go through all possible numbers, but I don’t immediately see how.

That could be fun.

The other problem with larger bases is representation. Hexidecimal is base 16, and that looks like 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, a, b, c, d, e, f, and so given C210000000001000, the solution for base-16, we would need to count to decimal-12 zeroes and convert that to C for the text, or conversely, pull the initial C from the number string, convert that to 12 to compare that with the number of zeroes, and so on.

Looking at base-7 and up, I am seeing a pattern.

3211000
42101000
521001000
6210001000
72100001000
821000001000
... 	... 	...
C210000000001000
... 	... 	...
W21000...0001000 (Ellipsis omits 23 zeroes)

The pattern being, if there’s a self-descriptive number in base-n, it ends with 1000, meaning that there’s zero digits that count up to n-1, zero that count up to n-2, zero that count up to -3, and one that displays n-4.

Similarly, the start with [n-4]210, meaning there’s 2 ones (being the number of twos and and the number of n-4s), and 1 two (being the number of ones).

So, mathematically, p = n - 4, expressed in appropriate notation, and the response of big_self_desc(n) is p210..01000.

So, the code:

#!/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 };

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;
}

and the output

x210000000000000000000000000000001000
w21000000000000000000000000000001000
v2100000000000000000000000000001000
u210000000000000000000000000001000
t21000000000000000000000000001000
s2100000000000000000000000001000
r210000000000000000000000001000
q21000000000000000000000001000
p2100000000000000000000001000
o210000000000000000000001000
n21000000000000000000001000
m2100000000000000000001000
l210000000000000000001000
k21000000000000000001000
j2100000000000000001000
i210000000000000001000
h21000000000000001000
g2100000000000001000
f210000000000001000
e21000000000001000
d2100000000001000
c210000000001000
b21000000001000
a2100000001000
9210000001000
821000001000
72100001000
6210001000
521001000
42101000
3211000

I could and probably should make a combined program. But not now.

CHALLENGE 1

CHALLENGE 2

If you have any questions or comments, I would be glad to hear it. Ask me on Twitter or make an issue on my blog repo.