This puzzle’s connection with Pythagoras is tenuous indeed: it originally appeared in the Dutch magazine Pythagoras (see here and here)! But the puzzle is interesting. Of course, the real challenge is to work out the answer mathematically, but for those of us who are mathematically declined a Perl script is the way to go.
The first draft of my solution was tied to the 100 guests specified in the puzzle statement, but it’s easy to extend the puzzle to allow any (positive integer) number of guests. So I include the number of guests as a constant $GUESTS
and the central calculation becomes:
$piece = ($guest / $GUESTS) * $pie;
where $guest
is any number in the series 1 .. $GUESTS
and $pie
is the fraction of original pie remaining at this point in the distribution.
For my own interest I added code to display the size of each guest’s piece of pie. This code can be omitted from compilation by setting DEBUG
to a false value.
use strict;
use warnings;
use Const::Fast;
use constant DEBUG => 0;
const my $GUESTS => 100;
MAIN:
{
my $pie = 1;
my $max_guest = 1;
my $max_piece = 1 / $GUESTS;
my $sum = $max_piece if DEBUG;
$pie -= $max_piece;
printf("\nGuest %*d gets %43.40f%% of the original pie\n",
length $GUESTS, $max_guest, $max_piece * 100) if DEBUG;
for my $guest (2 .. $GUESTS)
{
my $piece = ($guest / $GUESTS) * $pie;
$pie -= $piece;
if (DEBUG)
{
printf "Guest %*d gets %43.40f%% of the original pie\n",
length $GUESTS, $guest, $piece * 100;
$sum += $piece;
}
if ($piece > $max_piece)
{
$max_piece = $piece;
$max_guest = $guest;
}
}
printf "\nGuest %d of %d gets the largest piece, which is " .
"%.2f%% of the original pie\n", $max_guest, $GUESTS,
$max_piece * 100;
printf("\nCheck: sum of pieces = %.13f%%\n", $sum * 100)
if DEBUG;
}
Same logic here as in the Perl 5 solution, but minus the DEBUG
functionality. Perl 6 supplies a round
method for Real
values, which makes a nice alternative to the use of printf
.
use v6;
my UInt constant $GUESTS = 100;
sub MAIN()
{
my Real $pie = 1;
my UInt $max-guest = 1;
my Real $max-piece = 1 / $GUESTS;
$pie -= $max-piece;
for 2 .. $GUESTS -> UInt $guest
{
my Real $piece = ($guest / $GUESTS) * $pie;
$pie -= $piece;
if ($piece > $max-piece)
{
$max-piece = $piece;
$max-guest = $guest;
}
}
my Real $max-piece-pc = $max-piece * 100;
say "\nGuest $max-guest of $GUESTS gets the largest piece, ",
"which is $max-piece-pc.round(0.01)% of the original pie";
}
The answer to the puzzle is that the 10th guest gets 6.28% of the pie, which is the largest share.
I was also interested to know who gets the smallest share. That turns out to be the last (i.e., 100th) guest, whose share is about 9.33×10-41% of the original pie. I’m still trying to get my head around that figure.
Suppose the last guest’s share is a single atom of carbon-12 (I don’t see how a “piece of the pie” can be smaller than that). Now, 1 Dalton, or atomic mass unit, has a mass of 1.66×10-27 kg, and 1 carbon-12 atom has an atomic weight of 12; so the smallest “piece” of pie has a mass of 12 × 1.66×10-27 = 1.992×10-26 kg.
Which means the original pie must weight at least 1.992×10-26 ÷ 9.33×10-41 = 2.14×1013 kg or 21.4 billion metric tonnes. That must’ve been some party!
Prior to this task I knew nothing about Bitcoin; now, I still don’t know much! But I found a useful introduction, Learn Me a Bitcoin, which explains the technology basics quite well. (But not the rationale behind the technology. I now understand what Bitcoin mining is, but not why it’s needed; and I know how the difficulty is adjusted to keep the average mining time around 10 minutes, but not why that target is important in the first place.)
From this site it appears that valid Bitcoin addresses can take 3 forms:
However, for this exercise I’ve assumed that only P2PKH and P2SH addresses are included. For the record, details of P2WPKH (or Bech32) validation can be found here.
CPAN’s Digest::SHA module has a nice OO interface and supports many SHA variants including SHA-256. For decoding Base58 using the Bitcoin alphabet, module Crypt::Misc has the function decode_b58b
. After that, it’s just a question of applied logic.
The trickiest part for me was the code to verify the checksum, which required disentangling all the different encodings. The details are given in the comments to function validate_checksum
, below.
use strict;
use warnings;
use Const::Fast;
use Crypt::Misc qw( decode_b58b );
use Digest::SHA;
const my $DEFAULT_ADDR => '1BvBMSEYstWetqTFn5Au4m4GFg7xJaNVN2';
const my %ADDR_FORMATS => (1 => 'P2PKH', 3 => 'P2SH',
bc1 => 'Bech32');
const my $INVALID_CHARS => qr{([^1-9A-HJ-NP-Za-km-z])};
const my $MAX_CHARS => 35;
const my $MIN_CHARS => 26;
const my $SHA_ALGORITHM => 256;
const my $TAB => ' ';
MAIN:
{
my $address = $ARGV[0] // $DEFAULT_ADDR;
print "\nBitcoin address: \"$address\"\n";
if (my $error = validate_format($address, \my $format))
{
print "${TAB}Format validation FAILED: $error\n";
}
elsif ($format eq 'Bech32')
{
print "${TAB}Bech32 format not currently supported\n";
}
else
{
print "${TAB}Format is \"$format\"\n";
if ($error = validate_chars($address))
{
print "${TAB}Character validation FAILED: $error\n";
}
elsif (validate_checksum($address))
{
print "${TAB}Checksum validation PASSED\n";
}
else
{
print "${TAB}Checksum validation FAILED\n";
}
}
}
sub validate_format
{
my ($address, $format) = @_;
my $error;
for my $prefix (keys %ADDR_FORMATS)
{
if ($address =~ qr/^$prefix/)
{
$$format = $ADDR_FORMATS{$prefix};
last;
}
}
unless (defined $$format)
{
my $len = substr($address, 0, 1) eq 'b' ?
substr($address, 1, 1) eq 'c' ? 3 : 2 : 1;
$error = 'invalid prefix "' . substr($address, 0, $len) .
'", unknown format';
}
return $error;
}
sub validate_chars
{
my ($address) = @_;
my $chars = length $address;
my $error;
if ($chars < $MIN_CHARS)
{
$error = "invalid length $chars (minimum is $MIN_CHARS)";
}
elsif ($chars > $MAX_CHARS)
{
$error = "invalid length $chars (maximum is $MAX_CHARS)";
}
elsif ($address =~ $INVALID_CHARS)
{
$error = "invalid character \"$1\"";
}
return $error;
}
sub validate_checksum
{
my ($address) = @_;
my $rawdata = decode_b58b($address); # Base58 to bytes
my $hexdata = unpack 'H*', $rawdata; # Bytes to hex
my $checksum1 = substr $hexdata, -8; # Checksum 1 in hex
my $payload = substr $hexdata, 0, -8; # Payload in hex
my $sha_obj = Digest::SHA->new($SHA_ALGORITHM);
$sha_obj->add(pack 'H*', $payload); # Hex to bytes
my $digest1 = $sha_obj->hexdigest; # 1st digest in hex
$sha_obj->add(pack 'H*', $digest1); # hex to bytes
my $digest2 = $sha_obj->hexdigest; # 2nd digest in hex
my $checksum2 = substr $digest2, 0, 8; # Checksum 2 in hex
return $checksum1 eq $checksum2; # Compare checksums
}
I was surprised to find that pack
and unpack
are still considered experimental in Perl 6. Fortunately, the functionality I needed was available. I found Digest::SHA256::Native as a replacement for Perl 5’s Digest::SHA
, but had to re-use the Perl 5 module Crypt::Misc
here.
Note: I created $decode_b58b
as an alias for Crypt::Misc::decode_b58b
only to keep Comma happy! This worked (it removed the error message), but I couldn’t find any way to make Comma happy with the call to pack
, which is a function only and so can’t be called as a method.
As usual, my approach to Perl 6 coding is to use functional-style method calls and explicity-declared variable types wherever possible. This is overkill for a script like this, but it helps me to learn. Blob[uint8]
was a type I hadn’t come across before. Note also the regex
rx{ ( <-[1..9A..HJ..NP..Za..km..z]> ) }
which uses a negated character class (<-[...]>
) to match any character outside the allowed Bitcoin address alphabet.
use v6;
use experimental :pack;
use Crypt::Misc:from<Perl5> <decode_b58b>;
use Digest::SHA256::Native;
my Sub $decode_b58b := &Crypt::Misc::decode_b58b;
my constant %ADDR-FORMATS =
(1 => 'P2PKH', 3 => 'P2SH', bc1 => 'Bech32');
my Str constant $DEFAULT-ADDR =
'1BvBMSEYstWetqTFn5Au4m4GFg7xJaNVN2';
my Regex constant $INVALID-CHARS =
rx{ ( <-[1..9A..HJ..NP..Za..km..z]> ) };
my UInt constant $MAX-CHARS = 35;
my UInt constant $MIN-CHARS = 26;
my Str constant $TAB = ' ';
sub MAIN(Str:D $address = $DEFAULT-ADDR)
{
print "\nBitcoin address: \"$address\"\n";
my Str:D $format = '';
if my $error = validate-format($address, $format)
{
print "{$TAB}Format validation FAILED: $error\n";
}
elsif $format eq 'Bech32'
{
print "{$TAB}Bech32 format not currently supported\n";
}
else
{
print "{$TAB}Format is \"$format\"\n";
if $error = validate-chars($address)
{
print "{$TAB}Character validation FAILED: $error\n";
}
elsif validate-checksum($address)
{
print "{$TAB}Checksum validation PASSED\n";
}
else
{
print "{$TAB}Checksum validation FAILED\n";
}
}
}
sub validate-format(Str:D $address, Str:D $format is rw)
{
my Str $error;
for keys %ADDR-FORMATS -> Str $prefix
{
if $address ~~ /^$prefix/
{
$format = %ADDR-FORMATS{$prefix};
last;
}
}
unless $format
{
my UInt $len = $address.substr(0, 1) eq 'b' ??
$address.substr(1, 1) eq 'c' ?? 3 !! 2 !! 1;
$error = 'invalid prefix "' ~ $address.substr(0, $len) ~
'", unknown format';
}
return $error;
}
sub validate-chars(Str:D $address)
{
my $chars = $address.chars;
my Str $error;
if $chars < $MIN-CHARS
{
$error = "invalid length $chars (minimum is $MIN-CHARS)";
}
elsif $chars > $MAX-CHARS
{
$error = "invalid length $chars (maximum is $MAX-CHARS)";
}
elsif $address ~~ $INVALID-CHARS
{
$error = "invalid character \"$0\"";
}
return $error;
}
sub validate-checksum(Str:D $address)
{
my Blob[uint8] $raw-data = $decode_b58b($address);
my Str $hex-data = $raw-data.unpack('H*');
my Str $hex-checksum1 = $hex-data.substr(*-8);
my Str $hex-payload = $hex-data.substr(0, *-8);
my Blob[uint8] $raw-payload = pack('H*', $hex-payload);
my Str $hex-digest1 = sha256-hex($raw-payload);
my Blob[uint8] $raw_digest1 = pack('H*', $hex-digest1);
my Str $hex-digest2 = sha256-hex($raw_digest1);
my Str $hex-checksum2 = $hex-digest2.substr(0, 8);
return $hex-checksum1 eq $hex-checksum2;
}
I signed up for a Winning Email account and received the requisite email in reply. However, when I try to confirm my email address I get this message:
Username and password combination not found or your account is inactive.
:-(]]>
I must admit I found the definition of the van Eck sequence hard to follow. The EXAMPLE at OEIS helped:
We start with a(1) = 0. 0 has not appeared before, so the rule says a(2) = 0. Now 0 HAS occurred before, at a(1), which is 1 term before, so a(3) = 1. 1 has not occurred before, so a(4) = 0. 0 appeared most recently at term a(2), which is 2 terms earlier, so a(5) = 2. 2 has not occurred before, so a(6) = 0. And so on.
Ok, so this is a recursive sequence because new elements are defined in terms of previously-occurring elements (Wikipedia). But the best algorithm for generating a recursive sequence is not always a recursive algorithm. In this case, it seems easiest to use a simple loop while maintaining two arrays, containing (i) the sequence so far, and (ii) the index of each element’s most recent occurrence in the sequence. With this data to hand, generating the next element is fairly straightforward. The only tricky part is deciding when to update the index array. In generating element n + 1, we need the distance between n and the most recent previous occurrence of the nth element. So the index data for the nth element should be recorded only after the (n + 1)th element has been generated.
Once again I use Regexp::Common to verify that the command-line input (the required sequence length) is an integer. In sub van_eck
it is simpler to by-pass the first (i.e., 0-index) element of the @seq
array, thereby treating $seq[
n]
as the nth term in the series. To accomplish this I prepend undef
to the array before calculating the series, then shift
it off before returning the completed sequence.
use strict;
use warnings;
use Const::Fast;
use Regexp::Common;
const my $LENGTH => 27;
const my $USAGE => "USAGE: perl $0 [<length>]";
$| = 1;
MAIN:
{
scalar @ARGV <= 1
or die "\n$USAGE\n";
my $length = $ARGV[0] // $LENGTH;
$length =~ /^$RE{num}{int}$/ && $length > 0
or die "\nInvalid length '$length': " .
"must be an integer > 0\n";
print "\nThe first $length terms in Van Eck's sequence are:\n",
join( ', ', van_eck($length)->@* ), "\n";
}
sub van_eck
{
my ($len) = @_;
my @seq = (undef, 0);
my %indices;
for my $n (1 .. $len - 1)
{
my $old_term = $seq[$n];
push @seq, exists $indices{$old_term} ?
$n - $indices{$old_term} : 0;
$indices{$old_term} = $n;
}
shift @seq;
return \@seq;
}
The translation from Perl 5 to Perl 6 is straightforward. Note that Perl 5’s undef
becomes Nil
, and exists
changes from a function into a subscript adverb.
use v6;
my Int constant $LENGTH = 27;
sub MAIN(Int:D $length = $LENGTH)
{
say "\nThe first $length terms in Van Eck's sequence are:\n",
van-eck($length).join(', ');
}
sub van-eck(Int:D $length --> Array)
{
my @seq = (Nil, 0);
my %indices;
for 1 .. $length - 1 -> Int $n
{
my $old_term = @seq[$n];
push @seq, %indices{$old_term}:exists ??
$n - %indices{$old_term} !! 0;
%indices{$old_term} = $n;
}
shift @seq;
return @seq;
}
For the dictionary I chose “words_alpha.txt,” a plaintext file containing 370,099 English words (one word per line), which I had previously downloaded from GitHub. The US state names, together with each state’s two-character postal abbreviation, are taken from the Wikipedia article.
First thought in a case like this is to build candidate “words” using 2-character abbreviations as building blocks; then look them up in the dictionary to determine whether they’re valid English words. But a simple calculation shows that this is impractical: 12-character words could be built in 506 = 15,625,000,000 different ways!
A better approach is to test each word in the dictionary to determine whether it can be decomposed into the given building blocks. This is still a costly operation, but it’s far more manageable. Also, it can be streamlined: (1) any word with an odd number of letters can be immediately discarded; and (2) a word can be discarded as soon as any of its constituent 2-letter sequences fails to match a building block.
(There are other potential optimisations which I haven’t investigated. For example, a candidate word could be discarded up-front if it contains any letter not present in at least one of the state abbreviations.)
For testing each 2-letter substring of a candidate word, I build $STATES_REGEX
as an alternation of all the allowable two-letter codes. Writing this by hand would involve duplication of the data already present in %STATES_POSTAL
, which would violate the DRY principle and make unnecessary work! So I use eval
together with qr//
and join
, and Perl builds the regex for me.
In two places I use global matching in an expression of the form $string =~ /../g
(in list context, of course) to decompose $string
into its constituent 2-character substrings.
Once all the solutions have been found, it’s necessary to find the longest. First, I sort the solutions in descending order of word length. This guarantees that $words->[0]
is as long as any other solution; but there might be others of the same length. (In fact, using the dictionary I’ve chosen, there is only one solution — but the script can’t know that in advance!) So I continue up the array, incrementing $index
, until array element $words->[$index]
has a length shorter than that of the first solution. The last solution is thus $words->[$index - 1]
. The set of longest solutions is returned as an array slice.
use strict;
use utf8;
use warnings;
use Const::Fast;
use constant TIMER => 1;
const my %STATES_POSTAL =>
(
AL => 'Alabama', AK => 'Alaska',
AZ => 'Arizona', AR => 'Arkansas',
CA => 'California', CO => 'Colorado',
CT => 'Connecticut', DE => 'Delaware',
FL => 'Florida', GA => 'Georgia',
HI => 'Hawaii', ID => 'Idaho',
IL => 'Illinois', IN => 'Indiana',
IA => 'Iowa', KS => 'Kansas',
KY => 'Kentucky', LA => 'Louisiana',
ME => 'Maine', MD => 'Maryland',
MA => 'Massachusetts', MI => 'Michigan',
MN => 'Minnesota', MS => 'Mississippi',
MO => 'Missouri', MT => 'Montana',
NE => 'Nebraska', NV => 'Nevada',
NH => 'New Hampshire', NJ => 'New Jersey',
NM => 'New Mexico', NY => 'New York',
NC => 'North Carolina', ND => 'North Dakota',
OH => 'Ohio', OK => 'Oklahoma',
OR => 'Oregon', PA => 'Pennsylvania',
RI => 'Rhode Island', SC => 'South Carolina',
SD => 'South Dakota', TN => 'Tennessee',
TX => 'Texas', UT => 'Utah',
VT => 'Vermont', VA => 'Virginia',
WA => 'Washington', WV => 'West Virginia',
WI => 'Wisconsin', WY => 'Wyoming',
);
# Regular expression to match (case-insensitively, but otherwise
# exactly) any one of the 50 state postal abbreviations
const my $STATES_REGEX =>
eval 'qr/^(?:' . join('|', keys %STATES_POSTAL) . ')$/i';
const my $WORDSFILE => 'words_alpha.txt';
$| = 1;
MAIN:
{
use if TIMER, 'Time::HiRes' => qw( gettimeofday tv_interval );
my $t0 = [gettimeofday] if TIMER;
my ($total, $words) = get_words();
printf "\n%d words read from file '$WORDSFILE', of which\n" .
"%6d can be formed from US state abbreviations\n",
$total, scalar @$words;
if (scalar @$words == 0)
{
print "\nNo solutions found\n";
}
else
{
my $solutions = get_solutions($words);
printf "\nThe longest of these ha%s %d letters:\n",
(scalar @$solutions == 1) ? 's' : 've',
length $solutions->[0];
for my $solution (@$solutions)
{
my @states = map { $STATES_POSTAL{uc $_} }
$solution =~ /../g;
printf "%s = %s\n", $solution, join(' + ', @states);
}
}
my $t = tv_interval($t0) if TIMER;
print "\n", $t, " seconds\n" if TIMER;
}
sub get_words
{
my $total = 0;
my @words;
open my $fh, '<', $WORDSFILE
or die "Cannot open file '$WORDSFILE' for reading, stopped";
WORD:
while (my $word = <$fh>)
{
++$total;
chomp $word;
next unless length($word) % 2 == 0;
for my $pair ($word =~ /../g)
{
next WORD unless $pair =~ $STATES_REGEX;
}
push @words, $word;
}
close $fh
or die "Cannot close file '$WORDSFILE', stopped";
return ($total, \@words);
}
sub get_solutions
{
my ($words) = @_;
@$words = sort { length $b <=> length $a } @$words; # Desc
my $index = 0;
my $max_len = length $words->[$index];
1 while length $words->[++$index] == $max_len;
return [ @$words[0 .. --$index] ];
}
To improve performance (see Timings, below) I abandoned the alternation-regex approach in favour of Perl 6’s built-in Set
functionality. So, instead of $pair ~~ $STATES_REGEX
I have:
$pair.uc ∈ $STATES;
where $STATES
is a set of strings (the 2-character postal abbreviations) and the ∈
operator tests whether the object on its LHS is an element of the set on its RHS.
In sub get-solutions
the sort on word length is accomplished with a simpler syntax: $words.sort: { .chars };
. However, I don’t yet know how to make this sort in descending order, so I had two choices:
reverse
, e.g. $words.sort( { .chars } ).reverse;
$index
.In the event, I chose the latter option, although either would work.
use v6;
my constant $TIMER = 1;
# Abbreviations according to the "USPS" (United States Postal
# Service) column of the Table in
# https://en.wikipedia.org/wiki/List_of_U.S._state_abbreviations
my constant %STATES_POSTAL =
(
:AL('Alabama'), :AK('Alaska'),
:AZ('Arizona'), :AR('Arkansas'),
:CA('California'), :CO('Colorado'),
:CT('Connecticut'), :DE('Delaware'),
:FL('Florida'), :GA('Georgia'),
:HI('Hawaii'), :ID('Idaho'),
:IL('Illinois'), :IN('Indiana'),
:IA('Iowa'), :KS('Kansas'),
:KY('Kentucky'), :LA('Louisiana'),
:ME('Maine'), :MD('Maryland'),
:MA('Massachusetts'), :MI('Michigan'),
:MN('Minnesota'), :MS('Mississippi'),
:MO('Missouri'), :MT('Montana'),
:NE('Nebraska'), :NV('Nevada'),
:NH('New Hampshire'), :NJ('New Jersey'),
:NM('New Mexico'), :NY('New York'),
:NC('North Carolina'), :ND('North Dakota'),
:OH('Ohio'), :OK('Oklahoma'),
:OR('Oregon'), :PA('Pennsylvania'),
:RI('Rhode Island'), :SC('South Carolina'),
:SD('South Dakota'), :TN('Tennessee'),
:TX('Texas'), :UT('Utah'),
:VT('Vermont'), :VA('Virginia'),
:WA('Washington'), :WV('West Virginia'),
:WI('Wisconsin'), :WY('Wyoming'),
);
my constant $STATES = Set[Str].new( %STATES_POSTAL.keys );
# Dictionary file downloaded from
# https://github.com/dwyl/english-words
my Str constant $WORDS_FILE = 'words_alpha.txt';
sub MAIN()
{
my DateTime $t0 = DateTime.now if $TIMER;
my (Int:D $total, Array:D $words) = get-words();
say "\n$total words read from file '$WORDS_FILE', of which\n",
sprintf('%*d', $total.chars, $words.elems),
' can be formed from US state abbreviations';
if ($words.elems == 0)
{
say "\nNo solutions found";
}
else
{
my (Int:D $max-len, List:D $solutions) =
get-solutions($words);
say "\nThe longest of these ha",
$solutions.elems == 1 ?? 's' !! 've',
"$max-len letters:";
for @$solutions -> Str:D $solution
{
my @states = ($solution ~~ m:g/../).map:
{ %STATES_POSTAL{.uc} };
say $solution, ' = ', @states.join(' + ');
}
}
if ($TIMER)
{
my DateTime $t = DateTime.now;
say "\nTime elapsed: { $t - $t0 } seconds";
}
}
sub get-words(--> List:D)
{
my Int $total = 0;
my @words;
WORD: for $WORDS_FILE.IO.lines -> Str $word
{
++$total;
next unless $word.chars % 2 == 0;
for $word ~~ m:g/../ -> Match $pair
{
next WORD unless $pair.uc ∈ $STATES;
}
@words.push: $word;
}
return $total, @words;
}
sub get-solutions(Array:D $words --> List:D)
{
my @words = $words.sort: { .chars };
my Int $index = @words.end;
my Int $max-len = @words[ $index ].chars;
Nil while @words[ --$index ].chars == $max-len;
return $max-len, @words[ ++$index .. * ];
}
The main problem with the Perl 6 solution, as compared with its Perl 5 counterpart, is its performance:
|
where “ch-2-REGEX.p6” is like “ch-2.p6” but uses an alternation regex similar to the one used in “ch-2.pl.” As can be seen, using Perl 6’s ∈
operator on a Set
gives a significant speedup over an alternation-regex; but even so, the Perl 6 code is an order of magnitude slower than its Perl 5 equivalent.
The output of the Perl 5 script above (with timing code added) is:
16:03 >perl ch-2.pl
370099 words read from file 'words_alpha.txt', of which
532 can be formed from US state abbreviations
The longest of these has 12 letters:
cacogalactia = California + Colorado + Georgia + Louisiana + Connecticut + Iowa
1.635201 seconds
16:04 >
For the record, cacogalactia means bad milk: either “a bad condition of the milk” (Wordnik) or “producing unhealthy milk” (Medical Dictionary).
]]>First thought was to use a module to look up the day of the week for the last day of each month in the given year, then work backwards (in each month) to get the last Friday. But — well, once the weekday of any day in the year is known, the rest can be calculated directly without a further module look-up.
Actually, no module look-up is really needed at all once the day-of-the-week of any day in any year is known. And since I know that 17th June, 2019, is a Monday, I should be able to derive the solution from first principles, as it were, by counting backwards or forwards as needed. But working out leap years is tricky! So I compromised: one look-up for each given input year.
I chose the DateTime module because it’s familiar (and also recommended in Task::Kensho::Dates). To verify user input of the desired year I used $RE{num}{int}
from Regexp::Common. As always, I make heavy use of Const::Fast to separate compile-time data from the code proper:
#!perl
use strict;
use warnings;
use Const::Fast;
use DateTime;
use Regexp::Common;
const my @DAYS_IN_MONTH =>
( 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31 );
const my $DAYS_IN_WEEK => 7;
const my $DEFAULT_YEAR => 2019;
const my $FEBRUARY_INDEX => 1;
const my @OFFSET_1ST_FRI => ( 4, 3, 2, 1, 0, 6, 5 );
const my $USAGE => "USAGE: perl $0 <year>";
$| = 1;
MAIN:
{
my $year = get_year();
my $dt = DateTime->new(year => $year, month => 1, day => 1);
my $first = 1 + $OFFSET_1ST_FRI[ $dt->day_of_week - 1 ];
my @days = @DAYS_IN_MONTH;
++$days[ $FEBRUARY_INDEX ] if $dt->is_leap_year();
print "\nLast Fridays in each month of $year:\n\n";
for my $month (0 .. 11)
{
my $days = $days[ $month ];
my $last = $first;
$last += $DAYS_IN_WEEK until $last > $days;
$first = $last - $days;
$last -= $DAYS_IN_WEEK;
printf "%4d/%02d/%02d\n", $year, ($month + 1), $last;
}
}
sub get_year
{
scalar @ARGV <= 1
or die "\n$USAGE\n";
my $year = $ARGV[0] // $DEFAULT_YEAR;
$year =~ /^$RE{num}{int}$/
or die "\nInvalid year '$year': must be an integer\n";
return $year;
}
Couldn’t find anything suitable in the Perl 6 Modules Directory under DATE, so I again used Perl 5’s DateTime via the indispensable
Inline::Perl5 module. No need to manually validate user input in Perl 6: just declare the command-line parameter as Int:D $year
and it’s taken care of (as is the Usage message, should one be needed).
use v6;
use DateTime:from<Perl5>;
my Int constant $DAYS_IN_WEEK := 7;
my Int constant $DEFAULT_YEAR := 2019;
my Int constant $FEBRUARY_INDEX := 1;
my constant @DAYS_IN_MONTH := Array[Int].new:
31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31;
my constant @OFFSET_1ST_FRI := Array[Int].new:
4, 3, 2, 1, 0, 6, 5;
sub MAIN(Int:D $year = $DEFAULT_YEAR)
{
my $dt = DateTime.new( :$year, month => 1, day => 1 );
my $first = 1 + @OFFSET_1ST_FRI[ $dt.day_of_week - 1 ];
my @days = @DAYS_IN_MONTH;
++@days[ $FEBRUARY_INDEX ] if $dt.is_leap_year;
say "\nLast Fridays in each month of $year:\n";
for 1 .. 12 -> Int $month
{
my $days = @days[ $month - 1 ];
my $last = $first;
$last += $DAYS_IN_WEEK until $last > $days;
$first = $last - $days;
$last -= $DAYS_IN_WEEK;
printf "%4d/%02d/%02d\n", $year, $month, $last;
}
}
The most interesting thing about these sequences is that “F(n) is not equal to M(n) if and only if n+1 is a Fibonacci number” (OEIS Sequence A005378).
The key to recursion is to include a base case (stopping condition) to ensure that the recursion eventually ends. After that, it’s fairly plain sailing.
Well, it is until the sequence becomes even moderately long, at which point (depending on the nature of the recursion) performance may grind almost to a halt. In which case the answer (provided memory is not at a premium) is memoization, which trades memory for speed by caching the results of recursive function calls. The best reference I know for memoization is “Chapter 3: Caching and Memoization” in Higher-Order Perl by Mark Jason Dominus.
Without memoization, the Perl 5 script below takes 51 seconds to compute Hofstadter Female and Male sequences 100 terms long. With memoization, it completes in 0.007 seconds: a speed-up of 4 orders of magnitude!
For memoization I use the Memoize module by Mark Jason Dominus himself. Subroutine seq
takes a function pointer as its first argument and calls the function repeatedly to accumulate the required number of terms in the series.
#!perl
use strict;
use utf8;
use warnings;
use Const::Fast;
use Memoize;
use Regexp::Common;
const my $DEFAULT => 21;
const my $USAGE => "perl $0 [ <series_length> ]";
$| = 1;
MAIN:
{
@ARGV <= 1
or die "\n$USAGE\n";
my $n = $ARGV[0] // $DEFAULT;
$n =~ /^$RE{num}{int}$/ && $n > 0
or die "\nInvalid series length '$n': must be an integer > 0\n";
--$n; # Convert series length to index of final term
# (series is zero-based)
memoize('F');
memoize('M');
for my $func ('F', 'M')
{
printf "\n%s(%s%d): %s\n", $func, ($n == 0 ? '' : '0..'), $n,
join( ', ', seq(\&{$func}, $n)->@* );
}
}
# Accumulate terms ( X(0) .. X(max) ), where X is either F or M
sub seq
{
my ($func, $max) = @_; # max ∊ N ∪ {0}
my @series;
push @series, $func->($_) for 0 .. $max;
return \@series;
}
sub F # Find term n in the "Female" series
{
my ($n) = @_; # n ∊ N ∪ {0}
return $n == 0 ? 1 # Base case
: $n - M( F($n - 1) ); # Mutual recursion
}
sub M # Find term n in the "Male" series
{
my ($n) = @_; # n ∊ N ∪ {0}
return $n == 0 ? 0 # Base case
: $n - F( M($n - 1) ); # Mutual recursion
}
This time there’s a choice of modules for memoization. I chose Sub::Memoized which provides is memoized
as a subroutine trait. Note also the use of subset
together with where
to achieve fine-grained validation of subroutine arguments.
(Also noteworthy, for a Perl 6 novice like me, is the use of the colon in my %funcs = (:&F, :&M);
. This is a simpler way of writing my %funcs = (F => &F, M => &M);
. See the paragraph beginning “And this other variant, to be used in routine invocation” in the Perl 6 documentation for class Pair.)
use v6;
use Sub::Memoized;
my Int constant $DEFAULT := 21;
subset Non-negative-integer of Int where * >= 0;
subset Positive-integer of Int where * > 0;
sub MAIN(Positive-integer:D $length = $DEFAULT)
{
# Convert length to index of final term
my Int $n = $length - 1;
my Str $format = "\n" ~ '%s(%s%d): %s' ~ "\n";
my Str $prefix = $n == 0 ?? '' !! '0..';
my %funcs = (:&F, :&M);
$format.printf: $_, $prefix, $n, seq(%funcs{$_}, $n).join(', ')
for < F M >;
}
# seq(): Accumulate terms X(0), X(1), .. X(max), where X is either
# F or M
sub seq(Sub:D $func, Non-negative-integer:D $max --> Array)
{
my @series;
push @series, $func($_) for 0 .. $max;
return @series;
}
# F(): Find term n in the "Female" series
sub F(Non-negative-integer:D $n --> Non-negative-integer) is memoized
{
return $n == 0 ?? 1 # Base case
!! $n - M( F($n - 1) ); # Mutual recursion
}
# M(): Find term n in the "Male" series
sub M(Non-negative-integer:D $n --> Non-negative-integer) is memoized
{
return $n == 0 ?? 0 # Base case
!! $n - F( M($n - 1) ); # Mutual recursion
}
Signed up to RapidAPI without a problem. However, WordsAPI requires a subscription, which in turn requires submission of credit card details (even though the Basic Plan is free). I won’t do this, on principle — it’s just asking for trouble.
]]>