Challenge 347 Task 1 and 2 solutions in Perl by Matthias Muth

4 files changed, 370 insertions, 47 deletions

diff --git a/challenge-347/matthias-muth/README.md b/challenge-347/matthias-muth/README.md
index 74c85db605..33532eafeb 100644
--- a/challenge-347/matthias-muth/README.md
+++ b/challenge-347/matthias-muth/README.md
@@ -1,105 +1,283 @@
-# Recursive Parentheses - But no Recursive Magic
+# Leave a Date and a Number, and I'll Get Back to You
 
-**Challenge 346 solutions in Perl by Matthias Muth**
+**Challenge 347 solutions in Perl by Matthias Muth**
 
-This week, I am sorry to only have a solution for Task 1. 
+## Task 1: Format Date
 
-## Task 1: Longest Parenthesis
-
-> You are given a string containing only ( and ).<br/>
-> Write a script to find the length of the longest valid parenthesis.
+> You are given a date in the form: 10th Nov 2025.<br/>
+> Write a script to format the given date in the form: 2025-11-10 using the set below.<br/>
+> @DAYS   = ("1st", "2nd", "3rd", ....., "30th", "31st")<br/>
+> @MONTHS = ("Jan", "Feb", "Mar", ....., "Nov",  "Dec")<br/>
+> @YEARS  = (1900..2100)
 >
 > **Example 1**
 >
 > ```text
-> Input: $str = '(()())'
-> Output: 6
->
-> Valid Parenthesis: '(()())'
+> Input: $str = "1st Jan 2025"
+> Output: "2025-01-01"
 > ```
 >
 > **Example 2**
 >
 > ```text
-> Input: $str = ')()())'
-> Output: 4
->
-> Valid Parenthesis: '()()' at positions 1-4.
+> Input: $str = "22nd Feb 2025"
+> Output: "2025-02-22"
 > ```
 >
 > **Example 3**
 >
 > ```text
-> Input: $str = '((()))()(((()'
-> Output: 8
->
-> Valid Parenthesis: '((()))()' at positions 0-7.
+> Input: $str = "15th Apr 2025"
+> Output: "2025-04-15"
 > ```
 >
 > **Example 4**
 >
 > ```text
-> Input: $str = '))))((()('
-> Output: 2
->
-> Valid Parenthesis: '()' at positions 6-7.
+> Input: $str = "23rd Oct 2025"
+> Output: "2025-10-23"
 > ```
 >
 > **Example 5**
 >
 > ```text
-> Input: $str = '()(()'
-> Output: 2
->
-> Valid Parenthesis: '()' at positions 0-1 and 3-4.
+> Input: $str = "31st Dec 2025"
+> Output: "2025-12-31"
 > ```
 
-This task is a good showcase for recursive regular expressions.<br/>Recursive regular expressions are not used too often, that's why I even guess that not every Perl programmer knows about their existence. I also had to look up the details in [perldoc](https://perldoc.perl.org/perlre#(?PARNO)-(?-PARNO)-(?+PARNO)-(?R)-(?0)). 
+I have three versions:
+
+#### The Quick-and-Dirty Fair-Weather Version
 
-Constructing that regular expression, I start with a pair of parentheses. I use the `/x` modifier to be able to use whitespace within the pattern for easier reading. 
+If I am sure that all the dates that will ever be passed in are correctly formatted, this is my short solution:
 
 ```perl
-    $str =~ / \(  \) /x
+use v5.36;
+use Time::Piece;
+
+sub format_date_q_a_d( $str ) {
+    $str =~ s/st|nd|rd|th//;
+    my $t = Time::Piece->strptime( $str, "%d %b %Y" );
+    return $t->strftime( "%Y-%m-%d" );
+}
 ```
 
-Now within these parentheses,  the pattern is supposed to accept an optional other pair of parentheses, and inside that one again, which gives us the point where to insert the recursion pattern `(?R)?` . The ending `?` makes it optional to have subgroups of parentheses:
+Assuming that nothing can go wrong (but we know it will!), this is what it does:
+
+* Remove any known suffixes from the day numbers.
+* Let `strptime` from `Time::Piece` do the work of translating the date from text into a date-and-time object.
+* Then do the inverse, and format the date as we need it, using the object's `strftime` method.
+
+Very easy, very short, very readable.
+
+But what happens when the date is not recognized by `strptime`?<br/>It's really bad, but `strptime` will make our program abort!
+
+#### The 'Strict' and Safe Version
+
+Letting the program abort when there is an unrecognizable date is not acceptable.
+There need to be some checks to avoid it.
+
+Let's be really strict and accept only correctly formatted dates. These are the checks:
+
+1. The ordinal suffixes have to match the numbers, like `1st`, `2nd`, `3rd` or `4th`.<br/>
+   A date like `5st Nov 2025` is invalid.<br/>
+   The way to do that is to remove only suffixes that are preceded by the matching digit:
+
+   ```perl
+       $str =~ s/ (?<=1)st | (?<=2)nd | (?<=3)rd | (?<=\d)th //x;
+   ```
+
+2. `strptime` will abort even for correctly formatted dates in some cases, such as '31st Dec 1899'.<br/>To catch these exceptions, I use the `try`/`catch` syntax, enabled with  `use feature 'try'`:
+
+   ```perl
+       my $t = do {
+           try { Time::Piece->strptime( $str, "%d %b %Y" ) }
+           catch( $e ) { undef }
+       };
+   ```
+
+   This results in `$t` being undefined if `strptime` had any problems. Anything not properly recognized by `strptime` will be marked as an invalid date.
+
+3. `strptime` refuses dates prior to the year 1900, but accepts dates beyond the year 2100.<br/>
+   We have to check and refuse those explicitly.
+
+4. For a date of `29th Feb` in a leap year, `strptime` returns an object with the correct date.<br/>For `29th Feb` in non-leap years, however, it returns an object containing the 1st of March. Seems the checks for day numbers are not strict enough in `strptime` (a date of `30th Feb` will be refused!).<br/>So we have to check and refuse `29th Feb` in non-leap years explicitly as well.<br/>But instead of implementing a complete leap year calculation here, I take a shortcut:<br/>I reformat the object as a date string in the same format as the original string. Then I compare the two (with the ordinal suffix in the original string removed, but a `0` prepended if the day number is only one digit).
+   If they are not the same, `strptime` must have worked outside of the specification, and the date will be refused as invalid.
 
 ```perl
-    $str =~ / \( (?R)? \) /x
+sub format_date_strict( $str ) {
+    $str =~ s/ (?<=1)st | (?<=2)nd | (?<=3)rd | (?<=\d)th //x;
+    my $t = do {
+        try { Time::Piece->strptime( $str, "%d %b %Y" ) }
+        catch( $e ) { undef }
+    };
+    return
+        $t && ( 1900 <= $t->year <= 2100 )
+            && $t->strftime( "%d %b %Y" ) eq $str =~ s/^\d\s/0$&/r
+        ? $t->strftime( "%Y-%m-%d" )
+        : "<invalid date>";
+}
 ```
 
-But we also need to be able to accept a string like `'(()()())'`, which contains several parentheses groups in a row. We can do that by simply replacing the ending `?` by an ending `*`, to have zero, one or any number  of parentheses groups there:
+Much better.
+
+But now I was wondering whether it would be too complicated to build the while solution myself...
+
+#### The Home-Brewed Solution
+
+For building all the translations and boundary checks ourselves, we need some lists and lookup tables.<br/>
+We will need to look up the month number for the month's short name. Of course, using a hash is the proven solution for this. Instead of writing out all the indexes (month numbers), I let the program do that work and start with a list of month short names:
 
 ```perl
-    $str =~ / \( (?R)* \) /x
+    my @month_names = qw( Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec );
 ```
 
-Example 3 shows us that we also need to accept several groups of parentheses following each other directly on the first level, like in `'((()))()'`. So let's put what we have into a (non-capturing) group, of which we need to have at least one, but possibly many, so `(?: ... )+`:
+The lookup hash can then be generated, having in mind that an array start with index 0, but the first month has month number 1:
 
-```perl
-    $str =~ / (?: \( (?R)* \) )+ /x
+```perl 
+    my %months = map { ( $month_names[$_] => $_ + 1 ) } keys @month_names;
 ```
 
-In the end, we are supposed to return the length of the longest match. So let's add a `/g` *global* option to the regex to get all matches as a list, then use `map` and `length` to transform that list of matches into a list of their lengths, and then pass that list as parameters to the `max` function (from `List::Util`) to get the proper result:
+We also need the list of days per month (the entry at index 0 has to be there, but can be ignored.<br/>The exceptions for leap days in February will be dealt with later:
 
 ```perl
-use v5.36;
-use List::Util qw( max );
+    my @days_per_month = qw( 0 31 29 31 30 31 30 31 31 30 31 30 31 );
+```
+
+The rest of the task is very similar to the previous solution, only the call to `strptime` is replaced by a regular expression for extracting day, month short name and year, followed by a lookup of the month number.
+
+Two additional checks are brought into place:
+
+* checking the day number against the number of days in the given month,
+* and checking that we are not on `29th Feb`, or if we are, it is a valid leap year.
+
+Concluding the home-brewed solution:
 
-sub longest_parenthesis( $str ) {
-    return max( map length, $str =~ / (?: \( (?R)* \) )+ /xg );
+```perl  
+sub format_date_own( $str ) {
+    my @month_names = qw( Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec );
+    my %months = map { ( $month_names[$_] => $_ + 1 ) } keys @month_names;
+    my @days_per_month = qw( 0 31 29 31 30 31 30 31 31 30 31 30 31 );
+
+    $str =~ s/ (?<=1)st | (?<=2)nd | (?<=3)rd | (?<=\d)th //x;
+    my ( $day, $month_name, $year ) = $str =~ /^(\d{1,2}) (...) (\d{4})$/;
+    my $month = $month_name && $months{$month_name};
+    return
+        $year && ( 1900 <= $year <= 2100 )
+            && $month && $day <= $days_per_month[$month]
+            && ( $month != 2 || $day != 29
+                || ( $year % 4 == 0 && $year % 100 != 0 || $year % 1000 == 0 ) )
+        ? sprintf( "%d-%02d-%02d", $year, $month, $day )
+        : "<invalid date>";
 }
 ```
 
-That wasn't too difficult, was it?
+#### Testing Them All
+
+I have added quite a few additional test cases to the examples from the task description.
 
-## Task 2: Magic Expression
+For the Fair-Weather solution, all tests that have 'strict' in their name are run, but marked as 'To Do', to not count them as failures when they actually fail.
 
-Seems I was too ambitious to find a recursive solution for Task 2 that does not evaluate every term from scratch for all the possible combinations.<br/>
-To my own disappointment I was not able to finish it in time.
+These are all the tests. The implementation for running them (with `Test2::V0`) can be seen in the code.
 
-Sorry for having no solution for Task 2 this week.
+```perl
+my @tests = (
+    [ 'Example 1', '1st Jan 2025', '2025-01-01' ],
+    [ 'Example 2', '22nd Feb 2025', '2025-02-22' ],
+    [ 'Example 3', '15th Apr 2025', '2025-04-15' ],
+    [ 'Example 4', '23rd Oct 2025', '2025-10-23' ],
+    [ 'Example 5', '31st Dec 2025', '2025-12-31' ],
+    [ 'Strict Test 1 (boundaries)', '1st Jan 1900', '1900-01-01' ],
+    [ 'Strict Test 2 (boundaries)', '31st Dec 2100', '2100-12-31' ],
+    [ 'Strict test 3 (out of range)', '31st Dec 1899', '<invalid date>' ],
+    [ 'Strict test 4 (out of range)', '1st Jan 2101', '<invalid date>' ],
+    [ 'Strict test 5 (leap day)', '29th Feb 2000', '2000-02-29' ],
+    [ 'Strict test 6 (leap day)', '29th Feb 2004', '2004-02-29' ],
+    [ 'Strict test 7 (non-existing leap day)', '29th Feb 1900', '<invalid date>' ],
+    [ 'Strict test 8 (non-existing leap day)', '29th Feb 2001', '<invalid date>' ],
+    [ 'Strict test 9 (non-existing leap day)', '29th Feb 2100', '<invalid date>' ],
+    [ 'Strict test 10 (empty string)', '', '<invalid date>' ],
+    [ 'Strict test 11 (random non-date string', 'xxx', '<invalid date>' ],
+    [ 'Strict test 12 (invalid suffix)', '5st Dec 2025', '<invalid date>' ],
+    [ 'Strict test 13 (invalid lower case)', '1st jan 1970', '<invalid date>' ],
+    [ 'Strict test 14 (non-existing)', '35th Dec 2025', '<invalid date>' ],
+    [ 'Strict test 15 (non-existing)', '29th Feb 1900', '<invalid date>' ],
+    [ 'Strict test 16 (non-existing)', '29th Feb 2001', '<invalid date>' ],
+    [ 'Strict test 17 (non-existing)', '29th Feb 2100', '<invalid date>' ],
+);
+```
 
 
 
+## Task 2: Format Phone Number
+
+> You are given a phone number as a string containing digits, space and dash only.<br/>
+> Write a script to format the given phone number using the below rules:<br/>
+> 1. Removing all spaces and dashes<br/>
+> 2. Grouping digits into blocks of length 3 from left to right<br/>
+> 3. Handling the final digits (4 or fewer) specially:<br/>
+>    - 2 digits: one block of length 2<br/>
+>    - 3 digits: one block of length 3<br/>
+>    - 4 digits: two blocks of length 2<br/>
+> 4. Joining all blocks with dashes
+>
+> **Example 1**
+>
+> ```text
+> Input: $phone = "1-23-45-6"
+> Output: "123-456"
+> ```
+>
+> **Example 2**
+>
+> ```text
+> Input: $phone = "1234"
+> Output: "12-34"
+> ```
+>
+> **Example 3**
+>
+> ```text
+> Input: $phone = "12 345-6789"
+> Output: "123-456-789"
+> ```
+>
+> **Example 4**
+>
+> ```text
+> Input: $phone = "123 4567"
+> Output: "123-45-67"
+> ```
+>
+> **Example 5**
+>
+> ```text
+> Input: $phone = "123 456-78"
+> Output: "123-456-78"
+> ```
+
+I start with removing all non-digit characters from the string, and then I collect groups of 3 digits, but also allowing for only 2 or 1 digit when we reach the end.
+
+If the last group has 3 or 2 digits, we can leave the groups as they are. Only if the last group has only one digit we need to 'borrow' the last digit from the previous group and prepend it to the one in the last group, so that we end up with two groups of 2 digits each.
+
+It's nice that we can easily access the last group with `$groups[-1]` and the second but last with `$groups[-2]`. And it also is nice and easy that we can remove the last character of the last group with<br/>
+`substr( $groups[-1], -1, 1, "" )`<br/>
+and directly put it in front of the second but last group with<br/>`substr( $groups[-2], 0, 0, ... )`.
+
+So here we go:
+
+```perl
+use v5.36;
+
+sub format_phone_number( $phone ) {
+    for ( $phone ) {
+        s/\D//g;
+        my @groups = /(..?.?)/g;
+        substr( $groups[-1], 0, 0, substr( $groups[-2], -1, 1, "" ) )
+            if length( $groups[-1] ) == 1;
+        return join "-", @groups;
+    }
+}
+```
+
 #### **Thank you for the challenge!**
diff --git a/challenge-347/matthias-muth/blog.txt b/challenge-347/matthias-muth/blog.txt
new file mode 100644
index 0000000000..dc0ad4d4d3
--- /dev/null
+++ b/challenge-347/matthias-muth/blog.txt
@@ -0,0 +1 @@
+https://github.com/MatthiasMuth/perlweeklychallenge-club/tree/muthm-347/challenge-347/matthias-muth#readme
diff --git a/challenge-347/matthias-muth/perl/ch-1.pl b/challenge-347/matthias-muth/perl/ch-1.pl
new file mode 100755
index 0000000000..d14fd4b4fd
--- /dev/null
+++ b/challenge-347/matthias-muth/perl/ch-1.pl
@@ -0,0 +1,108 @@
+#!/usr/bin/env perl
+#
+#       The Weekly Challenge - Perl & Raku
+#       (https://theweeklychallenge.org)
+#
+#       Challenge 347 Task 1: Format Date
+#
+#       Perl solution by Matthias Muth.
+#
+
+use v5.36;
+use builtin qw( true false );
+use feature 'try';
+
+use Time::Piece;
+
+sub format_date_q_a_d( $str ) {
+    $str =~ s/st|nd|rd|th//;
+    my $t = Time::Piece->strptime( $str, "%d %b %Y" );
+    return $t->strftime( "%Y-%m-%d" );
+}
+
+sub format_date_strict( $str ) {
+    $str =~ s/ (?<=1)st | (?<=2)nd | (?<=3)rd | (?<=\d)th //x;
+    my $t = do {
+        try { Time::Piece->strptime( $str, "%d %b %Y" ) }
+        catch( $e ) { undef }
+    };
+    return
+        $t && ( 1900 <= $t->year <= 2100 )
+            && $t->strftime( "%d %b %Y" ) eq $str =~ s/^\d\s/0$&/r
+        ? $t->strftime( "%Y-%m-%d" )
+        : "<invalid date>";
+}
+
+sub format_date_own( $str ) {
+    my @month_names = qw( Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec );
+    my %months = map { ( $month_names[$_] => $_ + 1 ) } keys @month_names;
+    my @days_per_month = qw( 0 31 29 31 30 31 30 31 31 30 31 30 31 );
+
+    $str =~ s/ (?<=1)st | (?<=2)nd | (?<=3)rd | (?<=\d)th //x;
+    my ( $day, $month_name, $year ) = $str =~ /^(\d{1,2}) (...) (\d{4})$/;
+    my $month = $month_name && $months{$month_name};
+    return
+        $year && ( 1900 <= $year <= 2100 )
+            && $month && $day <= $days_per_month[$month]
+            && ( $month != 2 || $day != 29
+                || ( $year % 4 == 0 && $year % 100 != 0 || $year % 1000 == 0 ) )
+        ? sprintf( "%d-%02d-%02d", $year, $month, $day )
+        : "<invalid date>";
+}
+
+use Test2::V0 qw( -no_srand );
+
+my @tests = (
+    [ 'Example 1', '1st Jan 2025', '2025-01-01' ],
+    [ 'Example 2', '22nd Feb 2025', '2025-02-22' ],
+    [ 'Example 3', '15th Apr 2025', '2025-04-15' ],
+    [ 'Example 4', '23rd Oct 2025', '2025-10-23' ],
+    [ 'Example 5', '31st Dec 2025', '2025-12-31' ],
+    [ 'Strict Test 1 (boundaries)', '1st Jan 1900', '1900-01-01' ],
+    [ 'Strict Test 2 (boundaries)', '31st Dec 2100', '2100-12-31' ],
+    [ 'Strict test 3 (out of range)', '31st Dec 1899', '<invalid date>' ],
+    [ 'Strict test 4 (out of range)', '1st Jan 2101', '<invalid date>' ],
+    [ 'Strict test 5 (leap day)', '29th Feb 2000', '2000-02-29' ],
+    [ 'Strict test 6 (leap day)', '29th Feb 2004', '2004-02-29' ],
+    [ 'Strict test 7 (non-existing leap day)', '29th Feb 1900', '<invalid date>' ],
+    [ 'Strict test 8 (non-existing leap day)', '29th Feb 2001', '<invalid date>' ],
+    [ 'Strict test 9 (non-existing leap day)', '29th Feb 2100', '<invalid date>' ],
+    [ 'Strict test 10 (empty string)', '', '<invalid date>' ],
+    [ 'Strict test 11 (random non-date string', 'xxx', '<invalid date>' ],
+    [ 'Strict test 12 (invalid suffix)', '5st Dec 2025', '<invalid date>' ],
+    [ 'Strict test 13 (invalid lower case)', '1st jan 1970', '<invalid date>' ],
+    [ 'Strict test 14 (non-existing)', '35th Dec 2025', '<invalid date>' ],
+    [ 'Strict test 15 (non-existing)', '29th Feb 1900', '<invalid date>' ],
+    [ 'Strict test 16 (non-existing)', '29th Feb 2001', '<invalid date>' ],
+    [ 'Strict test 17 (non-existing)', '29th Feb 2100', '<invalid date>' ],
+);
+
+# Check quick and dirty version.
+my @implementations = (
+    [ \&format_date_q_a_d,  "the strptime quick-and-dirty solution", qr/strict/i ],
+    [ \&format_date_strict, "the strptime strict solution" ],
+    [ \&format_date_own,    "the own solution" ],
+);
+
+for ( @implementations ) {
+    my ( $sub, $description, $skip ) = $_->@*;
+    note "Testing $description";
+    for ( @tests ) {
+        my ( $test, $str, $expected ) = $_->@*;
+        my $todo =
+            $skip
+            && $test =~ $skip
+            && todo "strict checks";
+        try {
+            is $sub->( $str ), $expected,
+                "$test: '$str' => '$expected'";
+        }
+        catch( $e ) {
+            fail "$test: '$str' => '$expected'";
+            note "Exception (with amnesty): ", $e =~ s/ at .*? line \d+.*$//r;
+        }
+    }
+    note "";
+}
+
+done_testing;
diff --git a/challenge-347/matthias-muth/perl/ch-2.pl b/challenge-347/matthias-muth/perl/ch-2.pl
new file mode 100755
index 0000000000..d473e4e342
--- /dev/null
+++ b/challenge-347/matthias-muth/perl/ch-2.pl
@@ -0,0 +1,36 @@
+#!/usr/bin/env perl
+#
+#       The Weekly Challenge - Perl & Raku
+#       (https://theweeklychallenge.org)
+#
+#       Challenge 347 Task 2: Format Phone Number
+#
+#       Perl solution by Matthias Muth.
+#
+
+use v5.36;
+
+sub format_phone_number( $phone ) {
+    for ( $phone ) {
+        s/\D//g;
+        my @groups = /(..?.?)/g;
+        substr( $groups[-1], 0, 0, substr( $groups[-2], -1, 1, "" ) )
+            if length( $groups[-1] ) == 1;
+        return join "-", @groups;
+    }
+}
+
+use Test2::V0 qw( -no_srand );
+
+is format_phone_number( "1-23-45-6" ), "123-456",
+    'Example 1: format_phone_number( "1-23-45-6" ) == "123-456"';
+is format_phone_number( 1234 ), "12-34",
+    'Example 2: format_phone_number( 1234 ) == "12-34"';
+is format_phone_number( "12 345-6789" ), "123-456-789",
+    'Example 3: format_phone_number( "12 345-6789" ) == "123-456-789"';
+is format_phone_number( "123 4567" ), "123-45-67",
+    'Example 4: format_phone_number( "123 4567" ) == "123-45-67"';
+is format_phone_number( "123 456-78" ), "123-456-78",
+    'Example 5: format_phone_number( "123 456-78" ) == "123-456-78"';
+
+done_testing;