Merge pull request #8050 from wlmb/challenges

Solve PWC216

3 files changed, 60 insertions, 0 deletions

diff --git a/challenge-216/wlmb/blog.txt b/challenge-216/wlmb/blog.txt
new file mode 100644
index 0000000000..79ad11afe2
--- /dev/null
+++ b/challenge-216/wlmb/blog.txt
@@ -0,0 +1,2 @@
+https://wlmb.github.io/2023/05/08/PWC216/
+
diff --git a/challenge-216/wlmb/perl/ch-1.pl b/challenge-216/wlmb/perl/ch-1.pl
new file mode 100755
index 0000000000..68aade5475
--- /dev/null
+++ b/challenge-216/wlmb/perl/ch-1.pl
@@ -0,0 +1,22 @@
+#!/usr/bin/env perl
+# Perl weekly challenge 216
+# Task 1:  Registration Number
+#
+# See https://wlmb.github.io/2023/05/08/PWC216/#task-1-registration-number
+use v5.36;
+use List::Util qw(all);
+die <<~"FIN" unless @ARGV;
+    Usage: $0 R W1 [W2...]
+    to select the words Wn that contain all the letters in the
+    registration number R.
+    FIN
+my $reg=shift;
+my @words=@ARGV;
+my @letters_reg=grep {/[a-z]/} split "", lc $reg;
+my @result=grep
+{
+    my %letters;
+    map {$letters{$_}=1} split "", lc $_;
+    all {$letters{$_}} @letters_reg
+} @words;
+say "Registration number: $reg, words: @words, output: @result";
diff --git a/challenge-216/wlmb/perl/ch-2.pl b/challenge-216/wlmb/perl/ch-2.pl
new file mode 100755
index 0000000000..34d3ad06e5
--- /dev/null
+++ b/challenge-216/wlmb/perl/ch-2.pl
@@ -0,0 +1,36 @@
+#!/usr/bin/env perl
+# Perl weekly challenge 216
+# Task 2:  Word Stickers
+#
+# See https://wlmb.github.io/2023/05/08/PWC216/#task-2-word-stickers
+use v5.36;
+use List::Util qw(min);
+die <<~"FIN" unless @ARGV;
+    Usage: $0 W S1 [S2...]
+    to find how many stickers S1 S2... are required to make the word W
+    FIN
+my ($word, @stickers)=@ARGV;
+# Map letters to stickers
+my %stickers_with_letter;
+for my $s(@stickers){
+    push @{$stickers_with_letter{$_}}, $s for split "", lc $s;
+}
+my $result=0+solve({}, [split "", lc $word]);
+say "Word: $word, stickers: @stickers, result: $result";
+
+sub solve($available, $letters){
+    my @letters=@$letters;
+    my %available=%$available;
+    my @remaining=grep {my $a=$available{$_}; $available{$_}-- if $a; !$a} @letters;
+    return 0 unless @remaining;
+    my $first=$remaining[0];
+    my @possible_results;
+    for(@{$stickers_with_letter{$first}}){
+	my %augmented=%available;
+	$augmented{$_}++ for split "", lc $_;
+	push @possible_results, solve(\%augmented, \@remaining);
+    }
+    my $min=min  grep {defined} @possible_results;
+    return 1+$min if defined $min;
+    return undef;
+}