Perl Weekly Challenge 216.
My solutions (task 1 and task 2 ) to the The Weekly Challenge - 216.
Task 1: Registration Number
Submitted by: Mohammad S Anwar
You are given a list of words and a random registration number.
Write a script to find all the words in the given list that has
every letter in the given registration number.
Example 1
Input: @words = ('abc', 'abcd', 'bcd'), $reg = 'AB1 2CD'
Output: ('abcd')
The only word that matches every alphabets in the given registration
number is 'abcd'.
Example 2
Input: @words = ('job', 'james', 'bjorg'), $reg = '007 JB'
Output: ('job', 'bjorg')
Example 3
Input: @words = ('crack', 'road', 'rac'), $reg = 'C7 RA2'
Output: ('crack', 'rac')
To solve this problem I first extract the letters from the
registration. Then I build a hash for each word to test if it
contains any given letter. Finally, I check that all the letters in
the registration are contained in the word, and use that within a
grep. The code fits a noe-and-a-half-liner:
Example 1:
perl -MList::Util=all -E '@r=grep {/[a-z]/} split "", lc shift; @a=grep {
my %l; map {$l{$_}=1} split "", lc $_; all{$l{$_}}@r} @ARGV; say "@a";
' 'AB1 2CD' abc abcd bcd
Results:
abcd
Example 2:
perl -MList::Util=all -E '@r=grep {/[a-z]/} split "", lc shift; @a=grep {
my %l; map {$l{$_}=1} split "", lc $_; all{$l{$_}}@r} @ARGV; say "@a";
' '007 JB' job james bjorg
Results:
job bjorg
Example 3:
perl -MList::Util=all -E '@r=grep {/[a-z]/} split "", lc shift; @a=grep {
my %l; map {$l{$_}=1} split "", lc $_; all{$l{$_}}@r} @ARGV; say "@a";
' 'C7 RA2' crack road rac
Results:
crack rac
The full code is similar.
1 # Perl weekly challenge 216
2 # Task 1: Registration Number
3 #
4 # See https://wlmb.github.io/2023/05/08/PWC216/#task-1-registration-number
5 use v5.36;
6 use List::Util qw(all);
7 die <<~"FIN" unless @ARGV;
8 Usage: $0 R W1 [W2...]
9 to select the words Wn that contain all the letters in the
10 registration number R.
11 FIN
12 my $reg=shift;
13 my @words=@ARGV;
14 my @letters_reg=grep {/[a-z]/} split "", lc $reg;
15 my @result=grep
16 {
17 my %letters;
18 map {$letters{$_}=1} split "", lc $_;
19 all {$letters{$_}} @letters_reg
20 } @words;
21 say "Registration number: $reg, words: @words, output: @result";
Example:
./ch-1.pl 'AB1 2CD' abc abcd bcd
./ch-1.pl '007 JB' job james bjorg
./ch-1.pl 'C7 RA2' crack road rac
Results:
Registration number: AB1 2CD, words: abc abcd bcd, output: abcd
Registration number: 007 JB, words: job james bjorg, output: job bjorg
Registration number: C7 RA2, words: crack road rac, output: crack rac
#+endsrc
Task 2: Word Stickers
Submitted by: Mohammad S Anwar
You are given a list of word stickers and a target word.
Write a script to find out how many word stickers is needed to make up
the given target word.
Example 1:
Input: @stickers = ('perl','raku','python'), $word = 'peon'
Output: 2
We just need 2 stickers i.e. 'perl' and 'python'.
'pe' from 'perl' and
'on' from 'python' to get the target word.
Example 2:
Input: @stickers = ('love','hate','angry'), $word = 'goat'
Output: 3
We need 3 stickers i.e. 'angry', 'love' and 'hate'.
'g' from 'angry'
'o' from 'love' and
'at' from 'hate' to get the target word.
Example 3:
Input: @stickers = ('come','nation','delta'), $word = 'accommodation'
Output: 4
We just need 2 stickers of 'come' and one each of 'nation' & 'delta'.
'a' from 'delta'
'ccommo' from 2 stickers 'come'
'd' from the same sticker 'delta' and
'ation' from 'nation' to get the target word.
Example 4:
Input: @stickers = ('come','country','delta'), $word = 'accommodation'
Output: 0
as there's no "i" in the inputs.
To solve this task, I first map each letter to the stickers which may
provide them. Then I call a recursive subroutine to find all possible
solutions and choose the best. This subroutine has as inputs the
currently available letters (none at the beginning), from stickers that have been already
used, and the letters we still have to find from the given word. I
provide as many letters as possible from the available letters.
If they are insufficient, I choose in turn each of the stickers that
provide a missing letter and recurse. The result is the number of
stickers that are used or undef if there is no solution. From all the possible choices, I
choose the best. The code fits an incomprehensible three liner and a
better written full code below.
Example 1:
perl -MList::Util=min -E '
($w,@s)=@ARGV; for $s(@s){push @{$s{$_}}, $s for split "", lc $s}; say 0+r({},[split "", lc $w]);
sub r($a,$l){@l=@$l;%a=%$a;my @r=grep{$c=$a{$_};$c&&$a{$_}--;!$c}@l;@r||return 0;my @p;for(@{$s{$r[0]}})
{ %g=%a;$g{$_}++ for split "", lc $_;push @p, r(\%g,\@r)}$m=min grep{defined} @p;return 1+$m if defined $m;undef}
' peon perl raku python
Results:
2
Example 2:
perl -MList::Util=min -E '
($w,@s)=@ARGV; for $s(@s){push @{$s{$_}}, $s for split "", lc $s}; say 0+r({},[split "", lc $w]);
sub r($a,$l){@l=@$l;%a=%$a;my @r=grep{$c=$a{$_};$c&&$a{$_}--;!$c}@l;@r||return 0;my @p;for(@{$s{$r[0]}})
{ %g=%a;$g{$_}++ for split "", lc $_;push @p, r(\%g,\@r)}$m=min grep{defined} @p;return 1+$m if defined $m;undef}
' goat love hate angry
Results:
3
Example 3:
perl -MList::Util=min -E '
($w,@s)=@ARGV; for $s(@s){push @{$s{$_}}, $s for split "", lc $s}; say 0+r({},[split "", lc $w]);
sub r($a,$l){@l=@$l;%a=%$a;my @r=grep{$c=$a{$_};$c&&$a{$_}--;!$c}@l;@r||return 0;my @p;for(@{$s{$r[0]}})
{ %g=%a;$g{$_}++ for split "", lc $_;push @p, r(\%g,\@r)}$m=min grep{defined} @p;return 1+$m if defined $m;undef}
' accommodation come nation delta
Results:
4
Example 4:
perl -MList::Util=min -E '
($w,@s)=@ARGV; for $s(@s){push @{$s{$_}}, $s for split "", lc $s}; say 0+r({},[split "", lc $w]);
sub r($a,$l){@l=@$l;%a=%$a;my @r=grep{$c=$a{$_};$c&&$a{$_}--;!$c}@l;@r||return 0;my @p;for(@{$s{$r[0]}})
{ %g=%a;$g{$_}++ for split "", lc $_;push @p, r(\%g,\@r)}$m=min grep{defined} @p;return 1+$m if defined $m;undef}
' accommodation come country delta
Results:
0
Below is the commented full code:
1 # Perl weekly challenge 216
2 # Task 2: Word Stickers
3 #
4 # See https://wlmb.github.io/2023/05/08/PWC216/#task-2-word-stickers
5 use v5.36;
6 use List::Util qw(min);
7 die <<~"FIN" unless @ARGV;
8 Usage: $0 W S1 [S2...]
9 to find how many stickers S1 S2... are required to make the word W
10 FIN
11 my ($word, @stickers)=@ARGV;
12 # Map letters to stickers
13 my %stickers_with_letter;
14 for my $s(@stickers){
15 push @{$stickers_with_letter{$_}}, $s for split "", lc $s;
16 }
17 # At first there are no available letters and I have to provide all letters in word
18 my $result=0+solve({}, [split "", lc $word]);
19 # Print result
20 say "Word: $word, stickers: @stickers, result: $result";
21
22 sub solve($available, $letters){
23 my @letters=@$letters;
24 my %available=%$available;
25 # Use as many available letters as possible to provide required letters
26 my @remaining=grep {my $a=$available{$_}; $available{$_}-- if $a; !$a} @letters;
27 # Done?
28 return 0 unless @remaining;
29 my $first=$remaining[0];
30 my @possible_results;
31 # Iterate over all possible stickers that provide the first remaining letter
32 for(@{$stickers_with_letter{$first}}){
33 # Add sticker's letters to available set
34 my %augmented=%available;
35 $augmented{$_}++ for split "", lc $_;
36 # solve recursively for the remaining letters
37 push @possible_results, solve(\%augmented, \@remaining);
38 }
39 # Choose best solution
40 my $best=min grep {defined} @possible_results;
41 # Add the sticker used and return, if there is solution
42 return 1+$best if defined $min;
43 return undef;
44 }
45
Examples:
./ch-2.pl peon perl raku python
./ch-2.pl goat love hate angry
./ch-2.pl accommodation come nation delta
./ch-2.pl accommodation come country delta
Results:
Word: peon, stickers: perl raku python, result: 2
Word: goat, stickers: love hate angry, result: 3
Word: accommodation, stickers: come nation delta, result: 4
Word: accommodation, stickers: come country delta, result: 0
Written on May 8, 2023