Merge pull request #8466 from MatthiasMuth/muthm-227

Challenge 227 solutions in Perl by Matthias Muth

6 files changed, 458 insertions, 105 deletions

diff --git a/challenge-227/matthias-muth/README.md b/challenge-227/matthias-muth/README.md
index 698cef7834..3cf35f627b 100644
--- a/challenge-227/matthias-muth/README.md
+++ b/challenge-227/matthias-muth/README.md
@@ -1,120 +1,121 @@
-# Reduce to the max
-**Challenge 225 solutions in Perl by Matthias Muth**
+# Friday XIII
+**Challenge 227 solutions in Perl by Matthias Muth**
 
-The tasks of this challenge are good ones,
-in the sense that the solutions can be short, nice, well-arranged, clear -- perly!
+## Task 1: Friday 13th
 
-However the second task took me some time to understand what really is happening
-in the task description and in the examples.
-
-But let's start with the first one:
-
-## Task 1: Max Words
-
-> You are given a list of sentences, @list.<br/>
-> A sentence is a list of words that are separated by a single space with no leading or trailing spaces.<br/>
-> Write a script to find out the maximum number of words that appear in a single sentence.<br/>
+> You are given a year number in the range 1753 to 9999.<br/>
+> Write a script to find out how many dates in the year are Friday 13th, assume that the current Gregorian calendar applies.<br/>
 > <br/>
-> Example 1<br/>
-> Input: @list = (qw/Perl and Raku belong to the same family./,<br/>
->                 qw/I love Perl./,<br/>
->                 qw/The Perl and Raku Conference./)<br/>
-> Output: 8<br/>
-> <br/>
-> Example 2<br/>
-> Input: @list = (qw/The Weekly Challenge./,<br/>
->                 qw/Python is the most popular guest language./,<br/>
->                 qw/Team PWC has over 300 members./)<br/>
-> Output: 7<br/>
-
-Perl in its own realm.<br/>
-So short that it probably needs some explanations...
-
-We get a list of strings, each one containing one sentence.
-
-So let's split up each sentence into 'words' using `split " ", $_`,
-getting our `$_` from using `map` walking us through the list of sentences.
-
-The number of words in each sentence is `scalar` of the list of words that we just got.
-
-And `max(...)` (from `List::Util`) gets us the largest one.
-
-Voilà!
+> Example<br/>
+> Input: $year = 2023<br/>
+> Output: 2<br/>
+> Since there are only 2 Friday 13th in the given year 2023 i.e. 13th Jan and 13th Oct.<br/>
+
+Looking for an easy way to get the weekday for a given date,
+the `Time::Piece` core module is an obvious choice.
+
+`Time::Piece`'s typical usage is for dealing with 'current' times,
+which are returned by the `localtime` and `gmtime` subroutines when called without parameter.
+If we want to supply a different date with them,
+we need to compute Unix epoch time value to do so.
+We will look into that later.
+
+But there is also the `Time::Piece->strptime(STRING, FORMAT)` subroutine that works as a constructor
+for `Time::Piece` objects.
+We hand in a date string like `"2023-07-13"`, and a format of `'%Y-%m-%d'`,
+and there we have our time object.
+
+So everything in one statement (but not on one line, to make it more readable!):
+- month numbers from 1 to 12,
+- use a `grep` code block to create the `Time::Piece` objects on the fly,
+and select those who return a day_of_week of 5 (Friday),
+-  use `scalar` to put `grep` into a scalar context
+so it returns the number of elements found instead of the list.
 
 ```perl
-use List::Util qw( max );
+use v5.36;
+use Time::Piece;
+sub friday_13th( $year ) {
+    return scalar grep {
+        Time::Piece->strptime( "$year-$_-13", "%Y-%m-%d" )->day_of_week == 5
+    } 1..12;
+}
+```
 
-sub max_words {
-    my ( @list ) = @_;
-    return max( map { scalar split " ", $_ } @list );
+Now maybe `strptime` is not the fastest solution, 
+and we could use `timegm` from `Time::Local` to create our dates
+without the need of parsing a string with a format.
+But using `strptime` like above looks much clearer to me than
+converting month numbers from 1..12 to 0..11 and years to be offsets from 1900,
+which would be necessary if we used `timegm`:
+```perl
+use v5.36;
+use Time::Local;
+use Time::Piece;
+sub friday_13th( $year ) {
+    return scalar grep {
+        gmtime( timegm( 0, 0, 0, 13, $_ - 1, $year - 1900 ) )->day_of_week == 5
+     } 1..12;
 }
 ```
+It's also that we would be jumping between domains
+(`localtime`/`gmtime` needing that 6-element list, returning an epoch time value,
+then we create a Time::Piece object from that),
+which does not really make it obvious what is going on.<br/>
+I prefer the first version! :-)
 
-## Task 2: Left Right Sum Diff
-
-> You are given an array of integers, @ints.<br/>
-> Write a script to return left right sum diff array as shown below:<br/>
-> @ints = (a, b, c, d, e)<br/>
-> @left  = (0, a, (a+b), (a+b+c))<br/>
-> @right = ((c+d+e), (d+e), e, 0)<br/>
-> @left_right_sum_diff = ( | 0 - (c+d+e) |,<br/>
->                          | a - (d+e)   |,<br/>
->                          | (a+b) - e   |,<br/>
->                          | (a+b+c) - 0 | )<br/>
-> <br/>
-> Example 1:<br/>
-> Input: @ints = (10, 4, 8, 3)<br/>
-> Output: (15, 1, 11, 22)<br/>
-> @left  = (0, 10, 14, 22)<br/>
-> @right = (15, 11, 3, 0)<br/>
-> @left_right_sum_diff = ( |0-15|, |10-11|, |14-3|, |22-0|)<br/>
->                      = (15, 1, 11, 22)<br/>
-> <br/>
-> Example 2:<br/>
-> Input: @ints = (1)<br/>
-> Output: (0)<br/>
-> @left  = (0)<br/>
-> @right = (0)<br/>
-> @left_right_sum_diff = ( |0-0| ) = (0)<br/>
+## Task 2: Roman Maths
+
+> Write a script to handle a 2-term arithmetic operation expressed in Roman numeral.<br/>
 > <br/>
-> Example 3:<br/>
-> Input: @ints = (1, 2, 3, 4, 5)<br/>
-> Output: (14, 11, 6, 1, 19)<br/>
-> @left  = (0, 1, 3, 6, 10)<br/>
-> @right = (14, 12, 9, 5, 0)<br/>
-> @left_right_sum_diff = ( |0-14|, |1-12|, |3-9|, |6-5|, |10-0|)<br/>
->                      = (14, 11, 6, 1, 10)<br/>
-
-Maybe I don't fully understand the definition,
-but for me, there seems to be a little inconsistency between the definition and the examples.
-In the definiton we have 5 elements as input, but only 4 elements in the left and right sums,
-whereas all the examples are explained using arrays of left and right sums
-that have the same number of elements as the input array.<br/>
-I decided in favor of the examples. :-)
-
-For this task, I completely avoided writing any for loops,
-and based my solution on list-processing functions:
-* `reductions` from `List::Util` does the summing up of the 'left' sum,
-starting with a 0 and going through all input elements except the last one (to get the correct number of elements),
-* `reductions` from `List::Util` also does the summing up of the 'right' sum,
-starting with a 0 and going through the input elements *in reverse order*,
-leaving out the first element, and then doing another `reverse` to have the 0 at the end of the list,
-* `pairwise` from the `List::MoreUtils` module from CPAN then builds the list of differences
-between corresponding elements of the 'left' and 'right' arrays.
- 
-So actually the task can be solved using three lines of actual code:
+> Example<br/>
+> IV + V     => IX<br/>
+> M - I      => CMXCIX<br/>
+> X / II     => V<br/>
+> XI * VI    => LXVI<br/>
+> VII ** III => CCCXLIII<br/>
+> V - V      => nulla (they knew about zero but didn't have a symbol)<br/>
+> V / II     => non potest (they didn't do fractions)<br/>
+> MMM + M    => non potest (they only went up to 3999)<br/>
+> V - X      => non potest (they didn't do negative numbers)<br/>
+
+I'm sure it's an interesting exercise to convert Roman numerals to arabic (common) numbers
+and vice versa, but here, I am not going to reinvent the wheel.<br/>
+The `Roman` module from CPAN is my friend in this case.
+
+The more interesting aspect is how to implement the arithmetic operations
+in a more elegant way than a nested if-then-else statement.
+
+I chose a hash lookup to return an anonymous subroutine that implements
+the respective operation.
+
+The rest looks quite self-explanatory to me.<br/>
+Or is it only in my eyes???
 
 ```perl
-use feature 'signatures';
-no warnings 'experimental::signatures';
-
-use List::Util qw( reductions );
-use List::MoreUtils qw( pairwise );
-
-sub left_right_sum_diff( @ints ) {
-    my @left  = reductions { $a + $b } 0, @ints[ 0 .. $#ints - 1 ];
-    my @right = reverse reductions { $a + $b } 0, reverse @ints[ 1 .. $#ints ];
-    return pairwise { abs( $a - $b ) } @left, @right
+use v5.36;
+use Roman;
+
+my %ops = (
+    '+'  => sub { $_[0] + $_[1] },
+    '-'  => sub { $_[0] - $_[1] },
+    '*'  => sub { $_[0] * $_[1] },
+    '/'  => sub { $_[0] / $_[1] },
+    '**' => sub { $_[0] ** $_[1] },
+);
+
+sub roman_maths( @input ) {
+    my $result = $ops{$input[1]}->( arabic( $input[0] ), arabic( $input[2] ) );
+    return
+        $result == 0
+            ? "nulla (they knew about zero but didn't have a symbol)" :
+        $result != int( $result )
+            ? "non potest (they didn't do fractions)" :
+        $result > 3999
+            ? "non potest (they only went up to 3999)" :
+        $result < 0
+            ? "non potest (they didn't do negative numbers)" :
+        Roman( $result );
 }
 ```
 
diff --git a/challenge-227/matthias-muth/blog.txt b/challenge-227/matthias-muth/blog.txt
new file mode 100644
index 0000000000..31fc9183e7
--- /dev/null
+++ b/challenge-227/matthias-muth/blog.txt
@@ -0,0 +1 @@
+https://github.com/MatthiasMuth/perlweeklychallenge-club/tree/muthm-227/challenge-227/matthias-muth#readme
diff --git a/challenge-227/matthias-muth/perl/TestExtractor.pm b/challenge-227/matthias-muth/perl/TestExtractor.pm
new file mode 100644
index 0000000000..b4669074db
--- /dev/null
+++ b/challenge-227/matthias-muth/perl/TestExtractor.pm
@@ -0,0 +1,240 @@
+#
+#       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 List::Util qw( any );
+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 $diag =
+	    "$sub_name( " . pp( @input_params ) . " ) "
+	    . ( ( @$expected == 1 && $expected->[0] =~ /^(?:(true)|false)/ )
+	        ? "is $expected->[0]"
+		: ( "== " . pp( @{$_->{OUTPUT}} ) ) );
+
+	my $name = "$_->{TEST}";
+	$name .= ": $diag"
+	    if $_->{TEST} =~ /^(Test|Example)(?:\s+\d+)?$/;
+	$diag = "test: $diag";
+
+	my @output = $sub->( @input_params );
+
+	if ( @$expected == 1 && $expected->[0] =~ /^(?:(true)|false)/ ) {
+	    ok $1 ? $output[0] : ! $output[0], $name, $diag // ();
+	}
+	else {
+	    is \@output, $expected, $name, $diag // ();
+	}
+
+        # vsay "";
+
+    } 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+ | undef /x;
+    my $bracketed     = qr/ \[ [^\[]*? \] /xs;
+    my $parenthesized = qr/ \( [^\[]*? \) /xs;
+    my $entry         = qr/ $literal | $bracketed | $parenthesized /x;
+    my $list          = qr/ $entry (?: \s*,\s* $entry )* \s*,? /xs;
+
+    # The combination of what we expect as input or output data.
+    # Capture unparenthesized lists for special handling.
+    my $data_re = qr/ (?<lit>      $literal )
+		    | (?<br_list>     \[ \s* (?:$list)? \s* \] )
+		    | (?<par_list>    \( \s* (?:$list)? \s* \) )
+		    | (?<no_paren> $list ) /x;
+
+    my @tests;
+    while ( $task_text =~
+	/^((?:Example|Test).*?)\s*:?\s*$ .*?
+	    ^Input: \s* ( .*? ) \s*
+	    ^Output: \s* ( .*? ) \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/ \b (?!undef) [a-z_][a-z0-9_]* \b /ix;
+	    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} || $+{par_list} ) ? "[ $2 ]" : $2 );
+        };
+
+	while ( $output =~ /^\s* ($data_re) $/xg ) {
+	    local $_ = $1;
+	    # vsay "\$_: <$_>";
+	    # Special case:  (1,2),(3,4),(5,6)
+	    # should become: [1,2],[3,4],[5,6] ]
+	    if ( $+{no_paren} && /$parenthesized/ ) {
+		# vsay "found special case <$_>";
+		s/\(/\[/g;
+		s/\)/\]/g;
+	    }
+	    push @{$tests[-1]{OUTPUT}},
+		eval( $+{no_paren} ? "( $_ )" : $_ );
+        };
+    }
+
+    unless ( @tests ) {
+	# Try an alternative description format:
+	# <input...> => <output...>
+	my $n_examples = 0;
+	while ( $task_text =~ /^( .*? ) \s* => \s* ( .* )$/xmg ) {
+	    # vsay pp @{^CAPTURE};
+	    push @tests, {
+	        TEST => "Example " . ++$n_examples,
+		INPUT => [ split " ", $1 ],
+		OUTPUT => [ $2 ],
+		VARIABLE_NAMES => [ '@input' ],
+	    }
+	}
+    }
+
+    # Use array refs for all OUTPUT lists if at least one of tests does.
+    if ( any { ref $_->{OUTPUT}[0] } @tests ) {
+	$_->{OUTPUT} = [ $_->{OUTPUT} ]
+	    for grep { ! ref $_->{OUTPUT}[0] } @tests;
+    }
+
+    return @tests;
+}
+
+1;
diff --git a/challenge-227/matthias-muth/perl/ch-1.pl b/challenge-227/matthias-muth/perl/ch-1.pl
new file mode 100755
index 0000000000..4d16a46b67
--- /dev/null
+++ b/challenge-227/matthias-muth/perl/ch-1.pl
@@ -0,0 +1,36 @@
+#!/usr/bin/env perl
+#
+#       The Weekly Challenge - Perl & Raku
+#       (https://theweeklychallenge.org)
+#
+#       Challenge 227 Task 1: Friday 13th
+#
+#       Perl solution by Matthias Muth.
+#
+
+use v5.36;
+
+use lib '.';
+use TestExtractor;
+
+use Time::Local;
+use Time::Piece;
+
+sub friday_13th_a( $year ) {
+    return scalar grep {
+        Time::Piece->strptime( "$year-$_-13", "%Y-%m-%d" )->day_of_week == 5
+    } 1..12;
+}
+
+sub friday_13th_d( $year ) {
+    return scalar grep {
+	gmtime( timegm( 0, 0, 0, 13, $_ - 1, $year - 1900 ) )->day_of_week == 5
+    } 1..12;
+}
+
+sub friday_13th( $year ) {
+    return friday_13th_a( $year );
+    # return friday_13th_b( $year );
+}
+
+run_tests;
diff --git a/challenge-227/matthias-muth/perl/ch-2.pl b/challenge-227/matthias-muth/perl/ch-2.pl
new file mode 100755
index 0000000000..cabeebfbf9
--- /dev/null
+++ b/challenge-227/matthias-muth/perl/ch-2.pl
@@ -0,0 +1,40 @@
+#!/usr/bin/env perl
+#
+#       The Weekly Challenge - Perl & Raku
+#       (https://theweeklychallenge.org)
+#
+#       Challenge 227 Task 2: Roman Maths
+#
+#       Perl solution by Matthias Muth.
+#
+
+use v5.36;
+
+use lib '.';
+use TestExtractor;
+
+use Roman;
+
+my %ops = (
+    '+'  => sub { $_[0] + $_[1] },
+    '-'  => sub { $_[0] - $_[1] },
+    '*'  => sub { $_[0] * $_[1] },
+    '/'  => sub { $_[0] / $_[1] },
+    '**' => sub { $_[0] ** $_[1] },
+);
+
+sub roman_maths( @input ) {
+    my $result = $ops{$input[1]}->( arabic( $input[0] ), arabic( $input[2] ) );
+    return 
+        $result == 0
+	    ? "nulla (they knew about zero but didn't have a symbol)" :
+	$result != int( $result )
+	    ? "non potest (they didn't do fractions)" :
+	$result > 3999
+	    ? "non potest (they only went up to 3999)" :
+	$result < 0
+	    ? "non potest (they didn't do negative numbers)" :
+	Roman( $result );
+}
+
+run_tests;
diff --git a/challenge-227/matthias-muth/perl/challenge-227.txt b/challenge-227/matthias-muth/perl/challenge-227.txt
new file mode 100644
index 0000000000..73057cdb7b
--- /dev/null
+++ b/challenge-227/matthias-muth/perl/challenge-227.txt
@@ -0,0 +1,35 @@
+The Weekly Challenge - 227
+Monday, Jul 24, 2023
+
+
+Task 1: Friday 13th
+Submitted by: Peter Campbell Smith
+
+You are given a year number in the range 1753 to 9999.
+Write a script to find out how many dates in the year are Friday 13th, assume that the current Gregorian calendar applies.
+Example
+
+Input: $year = 2023
+Output: 2
+
+Since there are only 2 Friday 13th in the given year 2023 i.e. 13th Jan and 13th Oct.
+
+
+Task 2: Roman Maths
+Submitted by: Peter Campbell Smith
+
+Write a script to handle a 2-term arithmetic operation expressed in Roman numeral.
+Example
+
+IV + V     => IX
+M - I      => CMXCIX
+X / II     => V
+XI * VI    => LXVI
+VII ** III => CCCXLIII
+V - V      => nulla (they knew about zero but didn't have a symbol)
+V / II     => non potest (they didn't do fractions)
+MMM + M    => non potest (they only went up to 3999)
+V - X      => non potest (they didn't do negative numbers)
+
+
+Last date to submit the solution 23:59 (UK Time) Sunday 30th July 2023.