Merge pull request #8064 from MatthiasMuth/muthm-216

Challenge 216 solutions in Perl by Matthias Muth

5 files changed, 351 insertions, 123 deletions

diff --git a/challenge-216/matthias-muth/README.md b/challenge-216/matthias-muth/README.md
index 49233e1d01..d1de0dad3f 100644
--- a/challenge-216/matthias-muth/README.md
+++ b/challenge-216/matthias-muth/README.md
@@ -1,125 +1,10 @@
-# Wow: Another oneliner! But also a complete BFS...!
-*Challenge 213 solutions in Perl by Matthias Muth*
-
-## Task 1: Fun Sort
-
-> You are given a list of positive integers.<br/>
-Write a script to sort the all even integers first then all odds in ascending order.
-
-Ok, let's see!
-A typical approach would be to split up the list of integers into all even ones and all odd ones,
-then sort both lists separately, and then concatenate them back together.<br/>
-Absolutely ok!<br/>
-But way below what Perl's `sort` can do for us!
-
-Why don't we use `sort` as it is supposed to be?<br/>
-It is defined as 
-```perl
-sort BLOCK LIST
-```
-and `BLOCK` is a comparison that decides which of two values goes first in the result.
-
-For us here, we know that all even numbers go before all odd numbers.<br/>
-To determine whether the number is even or odd, we can use the modulo operator, `%`.
-We just check whether the number modulo 2 is 0 (even) or 1 (odd).<br/>
-For determining the sort order, using Perl's *number comparison* operator `<=>` is our best choice.<br/>
-Combining these two, we get the first part of our comparison for `sort`:
-```perl
-    $a % 2 <=> $b % 2
-```
-That's all we need to make all even numbers 'go left', and all odd numbers 'go right'.
-
-If both numbers are even, or both are odd, the `<=>` operator returns zero.
-For that case, we append the standard numeric comparison to define the order within all even (or all odd) numbers:
-```perl
-    $a % 2 <=> $b % 2 || $a <=> $b
-```
-
-Thus, a quite short, but complete solution for this challenge can look like this:
-```perl
-sub fun_sort {
-    sort { $a % 2 <=> $b % 2 || $a <=> $b } @_;
-}
-```
-I don't think there will be a much more efficient way of solving this!
-
-
-## Task 2: Shortest Route
-
-> You are given a list of bidirectional routes defining a network of nodes, as well as source and destination node numbers.<br/>
-Write a script to find the route from source to destination that passes through fewest nodes.
-
-Finding the shortest route, ok...<br/>
-So probably we need to implement a Broadth-First-Search algorithm to find our solution.<br/>
-But maybe the examples are so simple that we don't need that!<br/>
-Sorry, but it doesn't look like that. :-(
-
-Ok, then let's set it up for real!
-
-*Part 1: Preparing the data.*
-
-We have segments of roads, with numbers defining nodes on those segments.<br/>
-If we ever want to follow a road from one node to the next one, we need to know which nodes are the neighbors of all nodes.<br/>
-So first thing, we collect all neighbor connections.<br/>
-We may have neighbors from several route sections, if sections meed at one node. So we don't need a 'left' and 'right' neighbor only, but we need to generalize to have any number of neighbors for any given node.<br/>
-For me, that means that we need an array for each node, independent of any segments, in which we collect all neighbors.<br/>
-We loop over all nodes in all segments, and gather the node's left and right neighbors from that segment,
-checking that we do not access any non-existing neighbors beyond either end of the segment. 
-If a node is contained in more than one segment, its neighbors from there will be added in a later iteration, too.<br/>
-```perl
-sub shortest_route {
-    my ( $routes, $source, $destination ) = @_;
-
-    my %neighbors;
-    for my $segment ( @$routes ) {
-        for ( 0..$#$segment ) {
-            push @{$neighbors{$segment->[$_]}},
-                $_ > 0          ? $segment->[$_-1] : (),
-                $_ < $#$segment ? $segment->[$_+1] : ();
-        }
-    }
-```
-As you see, instead of using multiple `if` statements, in this case
-I prefer conditional expressions that evaluate to an empty list `()` if the condition does not match.<br/>
-
-*Part 2: The BFS.*
-
-Now, as for any real BFS, we need a stack.
-In our case, the stack entries will contain complete paths that we will want to check for whether they solve our puzzle.<br/>
-Each entry is an anonymous array with a list of nodes to travel.<br/>
-We initialize the stack with a route containing the start node only.
-
-We also need a hash for remembering which nodes we have already visited while we keep adding more routes to test on the stack.
-If not, we will find ourselves moving back and forth between nodes endlessly.
-
-Within the loop, we check route in the first stack entry (first in, first out, for a BFS) for whether it leads us to the destination node.
-If yes, we are done.<br/>
-If not, we add one stack entry for each of the last node's neighbors, adding each neighbor to the route that we just checked.
-We make sure to only add neighbors if they were not visited before. And we mark those neighbors as visited, for future iterations.
-
-If we run out of entries on the stack without having found any route, we return the failure marker that is demanded for that case.
-
-So all in all, it might look like this:
-```perl
-    my @stack = ( [ $source ] );
-    my %visited = ( $source => 1 );
-    while ( @stack ) {
-        my $path = pop @stack;
-        my $last_node = $path->[-1];
-        return $path
-            if $last_node == $destination;
-        if ( $neighbors{$last_node} ) {
-            for ( @{$neighbors{$last_node}} ) {
-                unless ( $visited{$_} ) {
-                    push @stack, [ @$path, $_ ];
-                    $visited{$_} = 1;
-                }
-            }
-        }
-    }
-    return -1;
-}
-```
-All in all, less complicated than I expected it to be in the beginning!
+**Challenge 216 solutions in Perl by Matthias Muth**
+<br/>
+I have created a 'TestExtractor.pm' module that extracts and runs the
+test cases from the challenge description in 'challenge.txt'.
+This makes the weekly task of setting up the enviroment for the new challenge
+much easier.
+
+(no blog post this time...)
 
 **Thank you for the challenge!**
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.