PERL WEEKLY CHALLENGE – 043

This is my 13th week participating into the weekly challenge.


Easy Challenge

Olympic Rings

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.


Edit: I misread the problem, and entered an incorrect solution not realizing that the numbers are subsets of multiple rings, I’ve fixed the problem now.

In perl 5 and Raku we can brute force this by calculating the possible permutations then validating the answers of the permutations.

Perl 5 solution

#!/usr/bin/perl
# Test: ./ch1.pl
use strict;
use warnings;
use feature qw /say/;
use Algorithm::Combinatorics qw(permutations);

my @numbers = (1, 2, 3, 4, 6);
my $rings = {
	blue   => 8,	yellow => 7,
	green  => 5,	red    => 9,
};

my $iter = permutations(\@numbers);
while (my $p = $iter->next) {
	my $slots = {
		redgreen     => $p->[0],
		greenblack   => $p->[1],
		black        => $p->[2],
		blackyellow  => $p->[3],
		yellowblue   => $p->[4]
	};

	if (validate_answer($rings, $slots)) {
		for my $key (keys %$slots) {
			say 'Slot: ' . $key .
			    ' value: ' . $slots->{$key};
		}
	}
}

sub validate_answer {
	my ($r, $s) = @_; # rings and slots

	return
	( $s->{redgreen} + $r->{red} == 11 &&
	  $s->{redgreen} + $r->{green} + $s->{greenblack} == 11 &&
	  $s->{greenblack} + $s->{black} + $s->{blackyellow} == 11 &&
	  $s->{blackyellow} + $r->{yellow} + $s->{yellowblue} == 11 &&
	  $r->{blue} + $s->{yellowblue} == 11 );
}

Output

Slot: greenblack value: 4
Slot: black value: 6
Slot: yellowblue value: 3
Slot: redgreen value: 2
Slot: blackyellow value: 1

Raku solution

# Test: perl6 ch1.p6
use v6.d;

my @numbers = (1, 2, 3, 4, 6);
my %rings = (
	blue   => 8, yellow => 7,
	green  => 5, red    => 9,
);

sub MAIN() {
	my @perms = @numbers.permutations;

	for @perms -> $perm {
		my %slots = (
			redgreen     => $perm[0],
			greenblack   => $perm[1],
			black        => $perm[2],
			blackyellow  => $perm[3],
			yellowblue   => $perm[4]
		);

		if (validate-answer(%rings, %slots)) {
			for (%slots.keys) -> $key {
				say 'Slot: ' ~ $key ~
				    ' value: ' ~ %slots.{$key};
			}
		}
	}
}


sub validate-answer(%r, %s) { # rings and slots

	return
	( %s.<redgreen> + %r.<red> == 11 &&
	  %s.<redgreen> + %r.<green> + %s.<greenblack> == 11 &&
	  %s.<greenblack> + %s.<black> + %s.<blackyellow> == 11 &&
	  %s.<blackyellow> + %r.<yellow> + %s.<yellowblue> == 11 &&
	  %r.<blue> + %s.<yellowblue> == 11 );
}

Output

Slot: redgreen value: 2
Slot: blackyellow value: 1
Slot: greenblack value: 4
Slot: yellowblue value: 3
Slot: black value: 6

Hard Challenge

Self-descriptive Numbers
Contributed by Laurent Rosenfeld

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.


There were two parts to this solution one is to displace the self-descriptive number in its base form and the other is to display it in base 10.

Displaying the numbers in the base form is just a matter of analyzing the string pattern which I approximated using this perl code

$NUMS[($b – 4)] . ‘2’ . 1 . 0 x ($b – 7) . ‘1000’;

where NUMS is just a lookup array so we can display numbers over 10 with 1 character. (It’s only populate with 36 numbers which was enough to show base 1 – 36)

Displaying the numbers in base 10 was just a matter of following this formula

(b-4)b^{b-1}+2b^{b-2}+b^{b-3}+b^{3}


Perl 5 solution

#!/usr/bin/perl
# test: ./ch2.pl
use strict;
use warnings;
use feature qw /say/;
use bignum;

our @NUMS = (0..9,'A' .. 'Z');

for my $i (1..36) {
	say $i . ': ' .
		self_descriptive_x($i) . ' - ' .
		self_descriptive_10($i);
}

sub self_descriptive_x {
	my $b = shift;

	return 'no solution' if
		( $b == 1 || $b == 2 ||
		  $b == 3 || $b == 6);

	return 1210 if ($b == 4);
	return 21200 if ($b == 5);

	return
		$NUMS[($b - 4)] . '2' . 1 . 0 x ($b - 7) . '1000';
}

sub self_descriptive_10 {
	my $b = shift;

	return 'no solution' if
		( $b == 1 || $b == 2 ||
		  $b == 3 || $b == 6);

	return 100 if ($b == 4);
	return 1425 if ($b == 5);

	return
		($b - 4) * $b ** ($b - 1) +
		2 * $b ** ($b - 2) +
		$b ** ($b - 3) +
		$b ** 3;
}

Output

1: no solution – no solution
2: no solution – no solution
3: no solution – no solution
4: 1210 – 100
5: 21200 – 1425
6: no solution – no solution
7: 3211000 – 389305
8: 42101000 – 8946176
9: 521001000 – 225331713
10: 6210001000 – 6210001000
11: 72100001000 – 186492227801
12: 821000001000 – 6073061476032
13: 9210000001000 – 213404945384449
14: A2100000001000 – 8054585122464440
15: B21000000001000 – 325144322753909625
16: C210000000001000 – 13983676842985394176
17: D2100000000001000 – 638488718313248327681
18: E21000000000001000 – 30852387539151417415368
19: F210000000000001000 – 1573159469597805848539033
20: G2100000000000001000 – 84423475200000000000008000
21: H21000000000000001000 – 4756841174671235094613299201
22: I210000000000000001000 – 280793005454401827960409041304
23: J2100000000000000001000 – 17329741584816652890845493751865
24: K21000000000000000001000 – 1116173987440750653627851819988480
25: L210000000000000000001000 – 74896888691000640392303466796890625
26: M2100000000000000000001000 – 5227587888859343585778354788027614376
27: N21000000000000000000001000 – 378972737144966791955974967549425386585
28: O210000000000000000000001000 – 28496513197723712818027291377812964922816
29: P2100000000000000000000001000 – 2219734095422156527988092421968458895869953
30: Q21000000000000000000000001000 – 178904142595280007000000000000000000000027000
31: R210000000000000000000000001000 – 14902796788966847950168266428983007512494526201
32: S2100000000000000000000000001000 – 1281713029540349034436623872002191929194718461952
33: T21000000000000000000000000001000 – 113701047630505078583859757780901667383168967385089
34: U210000000000000000000000000001000 – 10394144242892683639849044394210094269474324837603720
35: V2100000000000000000000000000001000 – 978332368989572974604820213309628888964653015136761625
36: W21000000000000000000000000000001000 – 94732999538876093602890439603390793851493346239336986176

Raku solution

# Test: perl6 ./ch2.p6
use v6.d;

# Don't know how to do this in Raku :(
our @NUMS =
<0 1 2 3 4 5 6 7 8 9 A B C D E F G H
 I J K L M N O P Q R S T U V W X Y Z>;

sub MAIN () {
	say @NUMS;
	for (1..36) -> $i {
		say $i ~ ': ' ~
			self-descriptive-x($i) ~ ' - ' ~
			self-descriptive($i);
	}
}

sub self-descriptive-x(Int $b) {
	return 'no solution' if
		( $b == 1 || $b == 2 ||
		  $b == 3 || $b == 6);

	return 1210 if ($b == 4);
	return 21200 if ($b == 5);

	return
		@NUMS[($b - 4)] ~ '2' ~ 1 ~ 0 x ($b - 7) ~ '1000';
}

sub self-descriptive(Int $b) {
	return 'no solution' if
		( $b == 1 || $b == 2 ||
		  $b == 3 || $b == 6);

	return 100 if ($b == 4);
	return 1425 if ($b == 5);

	return
		($b - 4) * $b ** ($b - 1) +
		2 * $b ** ($b - 2) +
		$b ** ($b - 3) +
		$b ** 3;
}

Output

1: no solution – no solution
2: no solution – no solution
3: no solution – no solution
4: 1210 – 100
5: 21200 – 1425
6: no solution – no solution
7: 3211000 – 389305
8: 42101000 – 8946176
9: 521001000 – 225331713
10: 6210001000 – 6210001000
11: 72100001000 – 186492227801
12: 821000001000 – 6073061476032
13: 9210000001000 – 213404945384449
14: A2100000001000 – 8054585122464440
15: B21000000001000 – 325144322753909625
16: C210000000001000 – 13983676842985394176
17: D2100000000001000 – 638488718313248327681
18: E21000000000001000 – 30852387539151417415368
19: F210000000000001000 – 1573159469597805848539033
20: G2100000000000001000 – 84423475200000000000008000
21: H21000000000000001000 – 4756841174671235094613299201
22: I210000000000000001000 – 280793005454401827960409041304
23: J2100000000000000001000 – 17329741584816652890845493751865
24: K21000000000000000001000 – 1116173987440750653627851819988480
25: L210000000000000000001000 – 74896888691000640392303466796890625
26: M2100000000000000000001000 – 5227587888859343585778354788027614376
27: N21000000000000000000001000 – 378972737144966791955974967549425386585
28: O210000000000000000000001000 – 28496513197723712818027291377812964922816
29: P2100000000000000000000001000 – 2219734095422156527988092421968458895869953
30: Q21000000000000000000000001000 – 178904142595280007000000000000000000000027000
31: R210000000000000000000000001000 – 14902796788966847950168266428983007512494526201
32: S2100000000000000000000000001000 – 1281713029540349034436623872002191929194718461952
33: T21000000000000000000000000001000 – 113701047630505078583859757780901667383168967385089
34: U210000000000000000000000000001000 – 10394144242892683639849044394210094269474324837603720
35: V2100000000000000000000000000001000 – 978332368989572974604820213309628888964653015136761625
36: W21000000000000000000000000000001000 – 94732999538876093602890439603390793851493346239336986176

3 thoughts on “PERL WEEKLY CHALLENGE – 043

Leave a Reply

Fill in your details below or click an icon to log in:

WordPress.com Logo

You are commenting using your WordPress.com account. Log Out /  Change )

Google photo

You are commenting using your Google account. Log Out /  Change )

Twitter picture

You are commenting using your Twitter account. Log Out /  Change )

Facebook photo

You are commenting using your Facebook account. Log Out /  Change )

Connecting to %s