diff options
Diffstat (limited to 'challenge-216/matthias-muth/perl')
| -rwxr-xr-x | challenge-216/matthias-muth/perl/TestExtractor.pm | 125 | ||||
| -rwxr-xr-x | challenge-216/matthias-muth/perl/ch-1.pl | 33 | ||||
| -rwxr-xr-x | challenge-216/matthias-muth/perl/ch-2.pl | 112 | ||||
| -rw-r--r-- | challenge-216/matthias-muth/perl/challenge-216.txt | 73 |
4 files changed, 343 insertions, 0 deletions
diff --git a/challenge-216/matthias-muth/perl/TestExtractor.pm b/challenge-216/matthias-muth/perl/TestExtractor.pm new file mode 100755 index 0000000000..f3f86fdc67 --- /dev/null +++ b/challenge-216/matthias-muth/perl/TestExtractor.pm @@ -0,0 +1,125 @@ +#!/usr/bin/env perl +# +# The Weekly Challenge - Perl & Raku +# (https://theweeklychallenge.org) +# +# The Test Data Extraction Machine (tm). +# +# Perl solution by Matthias Muth. +# + +use strict; +use warnings; +use feature 'say'; +use feature 'signatures'; +no warnings 'experimental::signatures'; + +package TestExtractor; +use Exporter 'import'; +our @EXPORT = qw( run_tests $verbose %options ); + +use Data::Dump qw( pp ); +use Getopt::Long; +use Cwd qw( abs_path ); +use File::Basename; +use Test2::V0; +no warnings 'experimental::signatures'; + +our ( $verbose, %options ); + +sub run_tests { + + $| = 1; + + GetOptions( + "v|verbose!" => \$verbose, + ) or do { say "usage!"; exit 2 }; + + my $dir = dirname abs_path $0; + my ( $challenge, $task ) = + abs_path( $0 ) =~ m{challenge-(\d+) .* (\d+)[^[/\\]*$}x; + unless ( $challenge && $task ) { + say STDERR "ERROR: ", + "Cannot determine challenge number or task number. Exiting."; + exit 1; + } + + no warnings 'once'; + my ( undef, $local_tests ) = read_tests( *::DATA ); + use warnings 'once'; + my ( $task_title, $challenge_examples ) = + read_tests( "$dir/challenge-${challenge}.txt", $task ); + my @tests = ( @$local_tests, @$challenge_examples ); + # say pp @tests; + + ( my $test_object = lc $task_title ) =~ s/\W+/_/g; + my $test_sub = \&{"::$test_object"}; + + do { + is $test_sub->( @{$_->{INPUT}} ), + @{$_->{OUTPUT}} > 1 ? @{$_->{OUTPUT}} : $_->{OUTPUT}[0], + "$_->{TEST}: $test_object( " . pp( @{$_->{INPUT}} ) . " ) == " + . pp( @{$_->{OUTPUT}} ); + } for @tests; + + done_testing; +} + +sub read_tests( $fd_or_filename, $wanted_task = undef ) { + + my $fd; + if ( ref \$fd_or_filename eq 'SCALAR' ) { + open $fd, "<", $fd_or_filename + or die "ERROR: cannot open '$fd_or_filename': $!\n"; + } + else { + # non-SCALARs, like __DATA__ GLOB. + $fd = $fd_or_filename; + } + + my @tests; + my ( $task, $task_title ) = ( -1, undef ); + while ( <$fd> ) { + chomp $_; + + /^Task (\d+):\s*(.*?)\s*$/ and do { + $task = $1; + $task_title = $2 + if $wanted_task && $task == $wanted_task; + next; + }; + + next + unless ! $wanted_task || $task == $wanted_task; + + /^((?:Example|Test).*?)\W*$/ and do { + push @tests, { TEST => $1 }; + next; + }; + + /^Input: / and do { + /\@\w+ = \(\s*(.*?)\s*[,]?\)/ and do { + my @list = map { s/'(.*?)'/$1/; $_ } split /, ?/, $1; + push @{$tests[-1]{INPUT}}, [ @list ]; + }; + /\$\w+ = (?:'(.*?)'|(\d+))/ and do { + push @{$tests[-1]{INPUT}}, $1 // $2; + }; + next; + }; + + /^Output: (.*)/ and do { + my $expected = $1; + /\(\s*(.*?)\s*[,]?\)/ and do { + my @list = map { s/'(.*?)'/$1/; $_ } split /, ?/, $1; + push @{$tests[-1]{OUTPUT}}, [ @list ]; + next; + }; + push @{$tests[-1]{OUTPUT}}, $expected; + next; + }; + } + return $task_title, \@tests; +} + +1; diff --git a/challenge-216/matthias-muth/perl/ch-1.pl b/challenge-216/matthias-muth/perl/ch-1.pl new file mode 100755 index 0000000000..39669c0059 --- /dev/null +++ b/challenge-216/matthias-muth/perl/ch-1.pl @@ -0,0 +1,33 @@ +#!/usr/bin/env perl +# +# The Weekly Challenge - Perl & Raku +# (https://theweeklychallenge.org) +# +# Challenge 216 Task 1: Registration Number +# +# Perl solution by Matthias Muth. +# + +use strict; +use warnings; +use feature 'say'; + +sub registration_number { + my ( $words, $reg ) = @_; + my @letters = $reg =~ /[a-z]/ig; + my @matches; + for my $word ( @$words ) { + push @matches, $word + unless grep $word !~ /$_/i, @letters; + } + return \@matches; +} + +use lib '.'; +use TestExtractor; +run_tests(); + +__DATA__ +Test 1: Check some own thing. +Input: @words = ('Matthias Kreis Germersheim'), $reg = 'GER-MM 76' +Output: ('Matthias Kreis Germersheim') diff --git a/challenge-216/matthias-muth/perl/ch-2.pl b/challenge-216/matthias-muth/perl/ch-2.pl new file mode 100755 index 0000000000..d267a60087 --- /dev/null +++ b/challenge-216/matthias-muth/perl/ch-2.pl @@ -0,0 +1,112 @@ +#!/usr/bin/env perl +# +# The Weekly Challenge - Perl & Raku +# (https://theweeklychallenge.org) +# +# Challenge 216 Task 2: Word Stickers +# +# Perl solution by Matthias Muth. +# + +use strict; +use warnings; +use feature 'say'; + +use Data::Dump qw( pp ); +use List::Util qw( min ); + +sub word_stickers { + my ( $stickers, $word ) = @_; + say "word_stickers( ", pp( $stickers, $word ), " )"; + + # Keep count of how many of each letter we need. + my %needed; + $needed{$_}++ + for $word =~ /./g; + + # For any letter, mark which stickers give that letter. + # If we need a certain letter, we then can check whether + # - the letter is still available from a sticker we already took + # (marked in %available, see further below), + # - get one of the stickers that give us that letter + # (marked in @{$letter_stickers{<letter>}}). + my %letter_stickers; + for my $sticker ( @$stickers ) { + # Make sure we add the sticker only once, even if the same letter + # occurs several times on the sticker. + my %sticker_letters = map { ( $_ => 1 ) } $sticker =~ /./g; + push @{$letter_stickers{$_}}, $sticker + for keys %sticker_letters; + } + say "letter stickers:\n", pp( \%letter_stickers ); + say "needed letters:\n", pp( \%needed ); + + # Keep count of how many of each letter we have available from stickers. + my %available; + my $n_stickers_used = 0; + while ( %needed ) { + my $resolved_a_letter = 0; + for my $letter ( sort keys %needed ) { + say "trying to resolve letter '$letter'"; + # Get stickers if needed. + if ( ( $available{$letter} || 0 ) < $needed{$letter} ) { + # Get stickers for this letter if there is only one sticker type + # that gives us this letter. If not , we wait with this letter. + unless ( $letter_stickers{$letter} ) { + say "no sticker for letter '$letter'"; + return 0; + } + if ( @{ $letter_stickers{$letter} // [] } == 1 ) { + my $sticker = $letter_stickers{$letter}[0]; + # Get as many stickers of this type as we need for this + # letter, adding all sticker letters to the available + # letters. + # Note that the same letter can appear several times on the + # sticker, so add stickers one by one. + do { + say "adding sticker '$sticker' to available letters"; + $available{$_}++ + for $sticker =~ /./g; + ++$n_stickers_used; + } until $available{$letter} + >= $needed{$letter}; + } + say "available letters now: ", + join " ", + map "$_:$available{$_}", + sort keys %available; + } + + if ( $available{$letter} && $available{$letter} >= $needed{$letter} ) { + # Use available letters. + say "using $needed{$letter} available letters '$letter'"; + $available{$letter} -= $needed{$letter}; + delete $available{$letter} + if $available{$letter} == 0; + delete $needed{$letter}; + $resolved_a_letter = 1; + } + } + unless ( $resolved_a_letter ) { + # For the remaining letters, we need to decide which of several + # possible stickers we want to take. + # This optimizing process is NOT YET IMPLEMENTED. + say "Giving up on this one for now."; + return 0; + } + } + return $n_stickers_used; +} + + +use lib '.'; +use TestExtractor; +run_tests(); + + +__DATA__ + +Test 1: +Input: @stickers = ('bubble', 'aaron'), $word = 'bubba' +Output: 2 +Watch out for the same letter appearing several times on the same sticker. diff --git a/challenge-216/matthias-muth/perl/challenge-216.txt b/challenge-216/matthias-muth/perl/challenge-216.txt new file mode 100644 index 0000000000..94dd58a6ed --- /dev/null +++ b/challenge-216/matthias-muth/perl/challenge-216.txt @@ -0,0 +1,73 @@ +The Weekly Challenge - 216 +Monday, May 8, 2023 + + +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') + + +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. + + +Last date to submit the solution 23:59 (UK Time) Sunday 14th May 2023. |