Challenge 217 solutions in Perl by Matthias Muth

6 files changed, 362 insertions, 8 deletions

diff --git a/challenge-217/matthias-muth/README.md b/challenge-217/matthias-muth/README.md
index d1de0dad3f..bf504c1bb5 100644
--- a/challenge-217/matthias-muth/README.md
+++ b/challenge-217/matthias-muth/README.md
@@ -1,10 +1,25 @@
-**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...)
+**Challenge 217 solutions in Perl by Matthias Muth**
+
+Apart from the two solutions that I have implemented this week
+I have written a script that extracts the new task descriptions
+from the
+[Weekly Challenge web site](https://theweeklychallenge.org/blog/perl-weekly-challenge-217/)
+and writes them into `challenge-<NN>/<USER>/perl/challenge-<NN>.txt`. <br/>
+(I will publish that in one of the coming weeks.)
+
+It also writes template files `perl/ch-1.pl` and `perl/ch-2-pl`, with
+the challenge number and name, task number and name,
+the subroutine name derived from the task name,
+and even the input variable names and types, derived from the test data, already filled in.
+
+I have a cron job that runs this every beginning of the week, so whenever there is a new
+challenge, I can start coding right away!
+
+The 'TestExtractor.pm' module extracts the test cases from that
+task description file, and runs the tests for me,
+without any editing of test data or test runs anymore.
+
+I am sure that the effort of automating all of this will pay off very soon,
+with every new challenge!
 
 **Thank you for the challenge!**
diff --git a/challenge-217/matthias-muth/blog.txt b/challenge-217/matthias-muth/blog.txt
new file mode 100644
index 0000000000..515c03bff2
--- /dev/null
+++ b/challenge-217/matthias-muth/blog.txt
@@ -0,0 +1 @@
+https://github.com/MatthiasMuth/perlweeklychallenge-club/tree/muthm-217/challenge-217/matthias-muth#readme
diff --git a/challenge-217/matthias-muth/perl/TestExtractor.pm b/challenge-217/matthias-muth/perl/TestExtractor.pm
new file mode 100755
index 0000000000..c9a6646db4
--- /dev/null
+++ b/challenge-217/matthias-muth/perl/TestExtractor.pm
@@ -0,0 +1,196 @@
+#!/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 vsay pp );
+
+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 vsay { say @_ if $verbose };
+
+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;
+    }
+
+    my $local_tests;
+    ( undef, $local_tests ) = read_task( *::DATA )
+	if fileno *::DATA;
+
+    my ( $task_title, $task_description ) =
+        read_task( "$dir/challenge-${challenge}.txt", $task );
+    vsay $task_title;
+
+    my @tests = (
+        $local_tests      ? extract_tests( $local_tests )      : (),
+	$task_description ? extract_tests( $task_description ) : (),
+    );
+    vsay pp( @tests );
+
+    ( my $sub_name = lc $task_title ) =~ s/\W+/_/g;
+    my $sub = \&{"::$sub_name"};
+
+    do {
+        my @input_params =
+	    @{$_->{INPUT}} == 1
+	    ? ( ref $_->{INPUT}[0] eq 'ARRAY'
+		&& ! grep( ref $_, @{$_->{INPUT}[0]} ) )
+		? @{$_->{INPUT}[0]}
+		: $_->{INPUT}[0]
+	    : @{$_->{INPUT}};
+	my $expected = $_->{OUTPUT};
+	my $description = 
+	    "$_->{TEST}: $sub_name( " . pp( @input_params ) . " ) == "
+	    . pp(
+		ref $_->{OUTPUT} eq 'ARRAY' && @{$_->{OUTPUT}} == 1
+		? @{$_->{OUTPUT}}
+		: $_->{OUTPUT} );
+	my $output =
+	    ref $_->{OUTPUT} eq 'ARRAY'
+	    ? [ $sub->( @input_params ) ]
+	    : $sub->( @input_params );
+	    
+	is $output, $expected, $description;
+
+    } for @tests;
+
+    done_testing;
+}
+
+sub read_task( $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 ( $task, $task_title, $task_text ) = ( -1, undef );
+    while ( <$fd> ) {
+        /^Task (\d+):\s*(.*?)\s*$/ and do {
+            $task = $1;
+            $task_title = $2
+                if $wanted_task && $task == $wanted_task;
+            next;
+        };
+
+        next
+            if $wanted_task && $task != $wanted_task;
+
+	$task_text .= $_;
+    }
+
+    return $task_title, $task_text;
+}
+
+sub extract_tests( $task_text ) {
+    # vsay "extract_tests( ", pp( $task_text ), " )";
+
+    # These regular expressions are used for extracting input or output
+    # test data.
+    my $var_name  = qr/ [\@\$]\w+ /x;
+    my $literal   = qr/ ".*?" | '.*?' | [+-]?\d+ /x;
+    my $bracketed = qr/ \[ [^\[]*? \] /xs;
+    my $entry     = qr/ $literal | $bracketed /x;
+    my $list      = qr/ $entry (?: \s*,\s* $entry )* /xs;
+
+    # The combination of what we expect as input or output data.
+    # Capture unparenthesized lists for special handling.
+    my $data_re = qr/ (?<lit>      $literal )
+		    | (?<list>     \[ \s* (?:$list)? \s* \] )
+		    | (?<no_paren> $list ) /x;
+
+    my @tests;
+    while ( $task_text =~
+	/^((?:Example|Test).*?)\s*:?\s*$ .*?
+	    ^Input: \s* ( .*? ) \s*
+	    ^Output: \s* ( .*? ) \s*?$ (?=(?: ^$ | \Z ))
+	/xmsg )
+    {
+	my ( $test, $input, $output) = ( $1, $2, $3 );
+
+	push @tests, { TEST => $test };
+
+	for ( $input, $output ) {
+	    # To avoid misinterpretations of '@' or '$' when the data is
+	    # 'eval'ed, we turn all double quotes into single quotes.
+	    s/"/'/g;
+
+	    # We convert 'barewords' into quoted strings.
+	    # We search for these patterns, but we just skip them without
+	    # changing them:
+	    #  * 'Input:', 'Output:' at the beginning of the string,
+	    #  * quoted strings,
+	    #  * variable names having a $ or @ sigil.
+	    # After we are sure it's none of those, we also check unquoted
+	    # 'barewords' (here: combinations of letters, digits or underscores,
+	    # starting with a letter) and enclose them in single quotes.
+	    my $bareword = qr/[a-z_][a-z0-9_]*/i;
+	    while ( / ^Input: | ^Output: | '.*?' | [\$\@]$bareword
+		    | ( $bareword ) /xg )
+	    {
+		if ( $1 ) {
+		    my $p = pos();
+		    substr $_, $p - length( $1 ), length( $1 ), "'$1'";
+		    pos = $p + 2;
+		}
+	    }
+
+	    # As all arrays will be stored as array references, so we just
+	    # convert parentheses (...) to angle brackets [...].
+	    s/\(/\[/g;
+	    s/\)/\]/g;
+
+	    # Add missing commas between literals.
+	    while ( s/($literal)\s+($literal)/$1, $2/ ) {}
+	}
+
+	while ( $input =~ / ($var_name) \s* = \s* ($data_re) /xg ) {
+	    push @{$tests[-1]{VARIABLE_NAMES}}, $1;
+	    push @{$tests[-1]{INPUT}}, eval( $+{no_paren} ? "[ $2 ]" : $2 );
+        };
+
+	while ( $output =~ /^\s* ($data_re) $/xg ) {
+	    $tests[-1]{OUTPUT} = eval( $+{no_paren} ? "[ $1 ]" : $1 );
+        };
+    }
+    return @tests;
+}
+
+1;
diff --git a/challenge-217/matthias-muth/perl/ch-1.pl b/challenge-217/matthias-muth/perl/ch-1.pl
new file mode 100755
index 0000000000..ac14aada46
--- /dev/null
+++ b/challenge-217/matthias-muth/perl/ch-1.pl
@@ -0,0 +1,23 @@
+#!/usr/bin/env perl
+#
+#       The Weekly Challenge - Perl & Raku
+#       (https://theweeklychallenge.org)
+#
+#       Challenge 217 Task 1: Sorted Matrix
+#
+#       Perl solution by Matthias Muth.
+#
+
+use strict;
+use warnings;
+use feature 'say';
+
+sub sorted_matrix {
+    my ( $matrix ) = @_;
+    my @all_values = sort { $a <=> $b } map @$_, @$matrix;
+    return $all_values[2];
+}
+
+use lib '.';
+use TestExtractor;
+run_tests();
diff --git a/challenge-217/matthias-muth/perl/ch-2.pl b/challenge-217/matthias-muth/perl/ch-2.pl
new file mode 100755
index 0000000000..5f3ee66b31
--- /dev/null
+++ b/challenge-217/matthias-muth/perl/ch-2.pl
@@ -0,0 +1,53 @@
+#!/usr/bin/env perl
+#
+#       The Weekly Challenge - Perl & Raku
+#       (https://theweeklychallenge.org)
+#
+#       Challenge 217 Task 2: Max Number
+#
+#       Perl solution by Matthias Muth.
+#
+
+use strict;
+use warnings;
+use feature 'say';
+
+use Data::Dump qw( pp );
+use List::Util qw( reduce );
+
+sub max_number {
+    my ( @list ) = @_;
+    # say "max_number( ", pp( @list ), " )";
+    return $list[0]
+        if @list == 1;
+
+    my ( $best, $max ) = ( undef, 0 );
+    for ( 0..$#list ) {
+ my @sub_list = @list;
+ splice @sub_list, $_, 1, ();
+        my $try = $list[$_] . max_number( @sub_list );
+ ( $best, $max ) = ( $_, $try )
+     if $try > $max;
+    }
+    return $max;
+}
+
+
+use lib '.';
+use TestExtractor;
+run_tests();
+
+
+__DATA__
+
+Test 1:
+Input: @list = ( 53 52 5 4 )
+Output: 553524
+
+Test 2:
+Input: @list = ( 53 52 5 1 )
+Output: 553521
+
+Test 3:
+Input: @list = ( 53 52 5 6 )
+Output: 655352
diff --git a/challenge-217/matthias-muth/perl/challenge-217.txt b/challenge-217/matthias-muth/perl/challenge-217.txt
new file mode 100644
index 0000000000..abce39f527
--- /dev/null
+++ b/challenge-217/matthias-muth/perl/challenge-217.txt
@@ -0,0 +1,66 @@
+The Weekly Challenge - 217
+Monday, May 15, 2023
+
+
+Task 1: Sorted Matrix
+Submitted by: Mohammad S Anwar
+
+You are given a n x n matrix where n >= 2.
+Write a script to find 3rd smallest element in the sorted matrix.
+Example 1
+
+Input: @matrix = ([3, 1, 2], [5, 2, 4], [0, 1, 3])
+Output: 1
+
+The sorted list of the given matrix: 0, 1, 1, 2, 2, 3, 3, 4, 5.
+The 3rd smallest of the sorted list is 1.
+
+Example 2
+
+Input: @matrix = ([2, 1], [4, 5])
+Output: 4
+
+The sorted list of the given matrix: 1, 2, 4, 5.
+The 3rd smallest of the sorted list is 4.
+
+Example 3
+
+Input: @matrix = ([1, 0, 3], [0, 0, 0], [1, 2, 1])
+Output: 0
+
+The sorted list of the given matrix: 0, 0, 0, 0, 1, 1, 1, 2, 3.
+The 3rd smallest of the sorted list is 0.
+
+
+Task 2: Max Number
+Submitted by: Mohammad S Anwar
+
+You are given a list of positive integers.
+Write a script to concatenate the integers to form the highest possible value.
+Example 1:
+
+Input: @list = (1, 23)
+Output: 231
+
+Example 2:
+
+Input: @list = (10, 3, 2)
+Output: 3210
+
+Example 3:
+
+Input: @list = (31, 2, 4, 10)
+Output: 431210
+
+Example 4:
+
+Input: @list = (5, 11, 4, 1, 2)
+Output: 542111
+
+Example 5:
+
+Input: @list = (1, 10)
+Output: 110
+
+
+Last date to submit the solution 23:59 (UK Time) Sunday 21st May 2023.