Perl Weekly Challenge: Week 38
Challenge 1:
Date Finder
Create a script to accept a 7 digits number, where the first number can only be 1 or 2. The second and third digits can be anything 0-9. The fourth and fifth digits corresponds to the month i.e. 01,02,03...,11,12. And the last 2 digits respresents the days in the month i.e. 01,02,03....29,30,31. Your script should validate if the given number is valid as per the rule and then convert into human readable format date.
RULES
1) If 1st digit is 1, then prepend 20 otherwise 19 to the 2nd and 3rd digits to make it 4-digits year.
2) The 4th and 5th digits together should be a valid month.
3) The 6th and 7th digits together should be a valid day for the above month.
For example, the given number is 2230120, it should print 1923-01-20.
The parts of the date can be extracted with a regular expression. I used named capture groups for better readability.
if ($input =~ m{
\A
(?<century> [12])
(?<year> [0-9]{2})
(?<month> (0[1-9]) | (1[0-2]) )
(?<day> (0[1-9]) | ([1-2][0-9]) | (3[01]))
\z
}gmx) {
Getting the full year requires a little extra work.
my $year = (($+{century} == 1) ? 20 : 19) . $+{year};
While the regex goes a long way towards making a proper date it can still lead
to incorrect values such as April 31st. Additional validation is needed. This
subroutine does that. isLeap() is the routine I've used in previous challenges for
determining leap years which affect the length of February. Because Perl doesn't
have a boolean data type, if a day value is wrong for its' particular month, I
return undef which always evaluates false, or 1 which always evaluates true.
sub isValidDate {
my ($year, $month, $day) = @_;
if ($month == 2 && $day > (isLeap($year) ? 29 : 28)) {
return undef;
}
if ((grep { $month == $_ } ( 4, 6, 9, 11 )) && $day > 30) {
return undef;
}
return 1;
}
If the date checks out as valid, we can go ahead and print it in the required format.
I have the exit() in there because I have structured my code so either a failure
to be parsed by the regex or to pass isValidDate() will cause an error message
to be printed.
if (isValidDate($year, $+{month}, $+{day})) {
say join q{-}, ($year, $+{month}, $+{day});
exit;
}
For the Raku version, I decided to use a grammar. The named capture groups of
the Perl version become tokens in the grammar. year is an exception; it is a
compound of the century token and a named capture group called $shortyear. The
full regular expression is represented by the TOP token.
grammar Date {
token TOP {
^ <year> <month> <day> $
}
token year {
<century> $<shortyear> = <[0 .. 9]> ** 2
}
token century {
<[ 12 ]>
}
token month {
0 <[1 .. 9]> || 1 <[0 .. 2]>
}
token day {
0 <[1 .. 9]> || <[1 .. 2]> <[0 .. 9]> || 3 <[0 .. 1]>
}
}
Raku grammars can also make use of an "action class" with methods having the same names as tokens. When the token is matched, the corresponding method will be called with the matched text. We can do all sorts of things with this.
In year() for instance, we calculate the four digit year. We have access to the
value of century because it is itself a token and shortyear because we explicitly
named it. make() alters the text returned by a token match.
method year($/) {
make ($/<century> == 1 ?? 20 !! 19) ~ $/<shortyear>;
}
Action classes—like any other classes, can also have private methods. They
are marked with an initial !. You have to use self rather than $. to acess
them though.
method !isLeap(Int $year) {
return $year %% 4 && ($year !%% 100 || $year %% 400);
}
method !isValidDate(Int $year, Int $month, Int $day) {
if $month == 2 && $day > (self!isLeap($year) ?? 29 !! 28) {
return False;
}
if ($month == any ( 4, 6, 9, 11 )) && $day > 30 {
return False;
}
return True;
}
In TOP() we have all the parts of the date matched so we can use our !isValidDate()
method to check if the date is, uh, valid. If so make() renders it in its' final
format. If validation fails, this method will return Nil which caused a minor problem.
method TOP($/) {
if self!isValidDate($/<year>.made.Int, $/<month>.Int, $/<day>.Int) {
make ($/<year>.made, $/<month>, $/<day>).join(q{-});
}
}
If you use the grammar above to parse like this:
my $date = Date.parse($input);
You can test if it has succeeded with if $date .... However if you use the
action class as well, something like this:
my $date = Date.parse($input, actions => DateAction.new);
that won't be good enough because a failed validation is still technically a successful
parse, just one that returns Nil. So the test you will need is if $date && date.made.
made() returns the value set by make().
Actually the code in my script looks like this:
say $date && $date.made ?? $date.made !! 'Invalid date.';
Challenge 2:
Word Game
Lets assume we have tiles as listed below, with an alphabet (A..Z) printed on them. Each tile has a value, e.g. A (1 point), B (4 points) etc. You are allowed to draw 7 tiles from the lot randomly. Then try to form a word using the 7 tiles with maximum points altogether. You don’t have to use all the 7 tiles to make a word. You should try to use as many tiles as possible to get the maximum points.
For example, A (x8) means there are 8 tiles with letter A.
1 point
A (x8), G (x3), I (x5), S (x7), U (x5), X (x2), Z (x5)
2 points
E (x9), J (x3), L (x3), R (x3), V (x3), Y (x5)
3 points
F (x3), D (x3), P (x5), W (x5)
4 points
B (x5), N (x4)
5 points
T (x5), O (x3), H (x3), M (x4), C (x4)
10 points
K (x2), Q (x2)
This time I'll start with the Raku version. A number of additional functions are needed.
The makeWords() function takes a file with one word per line and converts it into
a hash we can use to lookup legitimate words to form.
sub makeWords() {
return '/usr/share/dict/words'.IO.lines
We only have a maximum 7 letters so an optimization we can make is to discard words that are 8 or more letters long or contain non-letter characters such as numbers or apostrophes etc.
.grep({ .chars < 8 && / ^ <:alpha>+ $ / })
I like .claasify() a lot. It takes a list and puts each element under the appropriate
key in a hash. In this case, we take a word from our word list, sort its letters
alphabetically and make the whole things upper case. This is to make comparisons
easier later on. The value of the key can also be transformed by the :as parameter.
In this case we make the word upper case. As an example the words TOGA and GOAT will
both be placed under the key AGOT.
.classify({ $_.comb.sort.join.uc; }, :as{ uc $_; })
Finally, we sort the whole dictionary alphabetically.
.sort;
}
For the next routine pickTiles() we start by gather up all the quantities of each
letter and concatenating them into a string. .comb() then makes that into an array
and .pick() randomly chooses 7 disctinct elements from that array.
sub pickTiles() {
return
('A' x 8 ~ 'G' x 3 ~ 'I' x 5 ~ 'S' x 7 ~ 'U' x 5 ~ 'X' x 2 ~ 'Z' x 5 ~
'E' x 9 ~ 'J' x 3 ~ 'L' x 3 ~ 'R' x 3 ~ 'V' x 3 ~ 'Y' x 5 ~ 'F' x 3 ~
'D' x 3 ~ 'P' x 5 ~ 'W' x 5 ~ 'B' x 5 ~ 'N' x 4 ~ 'T' x 5 ~ 'O' x 3 ~
'H' x 3 ~ 'M' x 4 ~ 'C' x 4 ~ 'K' x 2 ~ 'Q' x 2).comb.pick(7);
}
The last of the helper functions splits a string into its constituent letters again and
adds up the value of each letter in order to produce the final score. the [+] operator
is a really nice and concise way of summing a list of values without requiring a loop
and running total variable.
sub calculateScore(Str $string) {
my %scores = (
'A' => 1, 'G' => 1, 'I' => 1, 'S' => 1, 'U' => 1, 'X' => 1, 'Z' => 1,
'E' => 2, 'J' => 2, 'L' => 2, 'R' => 2, 'V' => 2, 'Y' => 2, 'F' => 3,
'D' => 3, 'P' => 3, 'W' => 3, 'B' => 4, 'N' => 4, 'T' => 5, 'O' => 5,
'H' => 5, 'M' => 5, 'C' => 5, 'K' => 10, 'Q' => 10 );
return [+] $string.comb.map({ %scores{$_}; });
}
Now we can employ these functions to solve the challenge. First the dictionary is created and the tiles are drawn.
my %dict = makeWords();
my @draw = pickTiles();
We will also need to keep track of the best word (i.e. the one with the best score) found so far so here are some variables for that:
my $bestScore = 0;
my $bestWord = q{};
Now we need to check each combination of tiles to see if spells a real word. We start with the 7-tile combination, then the 6-tile combinations, 5-tile combinations and so on because longer combinations are likelier to be words with higher scores. The combinations have to be sorted because the keys in our dictonary are also sorted.
for (7 ... 1) -> $length {
for @draw.sort.combinations($length).map({ .join }) -> $tiles {
If the combinations of tiles is a key in the dictonary, we calculate its' score. The way the dictionary is set up, each key represents all words which are anagrams of it. We pick the first one but we could actually pick any as they would all have the same score.
if %dict{$tiles} {
my $value = %dict{$tiles}.values[0];
my $score = calculateScore($value);
If this words' score is better than anything we've seen so far or if it is the same amount but the word is longer (remember the spec says we should use as many tiles as possible) we replace the previous best score with it and the previous best word with this word.
if ($score > $bestScore ||
($score == $bestScore && $value.chars > $bestWord.chars)) {
$bestScore = $score;
$bestWord = $value;
}
}
}
}
Finally, we have the best word and the best score so we can print them out, along with, just for reference, the tiles we picked.
say @draw.join, " = $bestWord ($bestScore)";
}
Doing the Perl version was complicated by the lack of some of the nifty methods Raku has. In some cases, I wrote my own replacements, in others I could acheive the same result but with more verbose code.
Here is my replacement for combinations(). It uses a well-known recursive algorithm
to get all the combinations of a certain length.
sub combinations {
my @list = @{$_[0]};
my $length = $_[1];
if ($length <= 1) {
return map [$_], @list;
}
my @combos;
for (my $i = 0; $i + $length <= scalar @list; $i++) {
my $val = $list[$i];
my @rest = @list[$i + 1 .. $#list];
for my $c (combinations(\@rest, $length - 1)) {
push @combos, [$val, @{$c}] ;
}
}
return @combos;
}
This is my version of pick(). It has a flaw in that it destructively removes
elements from the input array, @list. This means I would not be able to accurately
call this function twice on the same list. As I only use it once in this script,
I didn't bother fixing it.
sub pick {
my @list = @{$_[0]};
my $length = scalar @list;
my $n = $_[1] // 1;
my @picked;
while (scalar @picked != $n) {
my $pos = int(rand($length));
if (defined $list[$pos]) {
push @picked, $list[$pos];
$list[$pos] = undef;
}
}
return wantarray ? @picked : $picked[0];
}
In makeWords(), instead of using classify(), we have to do this:
my %dict;
for my $word (keys %words) {
push @{$dict{ join q{}, (sort split //, $word)}}, $word;
}
In calculateScore() instead of using [+] we have to do this:
my $total = 0;
for my $c (split //, $string) {
$total += $scores{$c};
}