Merge pull request #9004 from MatthiasMuth/muthm-241

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

5 files changed, 473 insertions, 49 deletions

diff --git a/challenge-241/matthias-muth/README.md b/challenge-241/matthias-muth/README.md
index 4d24effa06..9a687e977f 100644
--- a/challenge-241/matthias-muth/README.md
+++ b/challenge-241/matthias-muth/README.md
@@ -1,79 +1,130 @@
-# Short Acronyms, and Short Solutions
+# Rewriting the Rules Can Make Things Simple
+**Challenge 241 solutions in Perl by Matthias Muth**
 
-**Challenge 240 solutions in Perl by Matthias Muth**
+## Task 1: Arithmetic Triplets
 
-## Task 1: Acronym
-
-> You are given two arrays of strings and a check string.<br/>
-> Write a script to find out if the check string is the acronym of the words in the given array.<br/>
+> You are given an array (3 or more members) of integers in increasing order and a positive integer.<br/>
+> Write a script to find out the number of unique Arithmetic Triplets satisfying the following rules:<br/>
+> a) i < j < k<br/>
+> b) nums[j] - nums[i] == diff<br/>
+> c) nums[k] - nums[j] == diff<br/>
+> <br/>
 > Example 1<br/>
-> Input: @str = ("Perl", "Python", "Pascal")<br/>
->        \$chk = "ppp"<br/>
-> Output: true<br/>
+> Input: @nums = (0, 1, 4, 6, 7, 10)<br/>
+>     \$diff = 3<br/>
+> Output: 2<br/>
+> Index (1, 2, 4) is an arithmetic triplet because both  7 - 4 == 3 and 4 - 1 == 3.<br/>
+> Index (2, 4, 5) is an arithmetic triplet because both 10 - 7 == 3 and 7 - 4 == 3.<br/>
 > <br/>
 > Example 2<br/>
-> Input: @str = ("Perl", "Raku")<br/>
->        \$chk = "rp"<br/>
-> Output: false<br/>
-> <br/>
-> Example 3<br/>
-> Input: @str = ("Oracle", "Awk", "C")<br/>
->        \$chk = "oac"<br/>
-> Output: true<br/>
+> Input: @nums = (4, 5, 6, 7, 8, 9)<br/>
+>     \$diff = 2<br/>
+> Output: 2<br/>
+> (0, 2, 4) is an arithmetic triplet because both 8 - 6 == 2 and 6 - 4 == 2.<br/>
+> (1, 3, 5) is an arithmetic triplet because both 9 - 7 == 2 and 7 - 5 == 2.<br/>
+
+The way the task description is written might lead us to a solution where we create all  possible triplets, and then check for each of them whether the three numbers fulfill  the 'diff' criteria. So actually we would need to solve a permutation task, with all its typical caveats, like the number of permutations running away too easily, and the high order of complexity in general. 
+
+But we can restate the task in a different way and find a much simpler way to solve it:<br/>
+Instead of 
 
-The first parameter to a perl `sub` can only be an `@array` variable *if it is the only parameter*. As we have two parameters in this task, the `@str` parameter from the description has to be passed in as an array reference, for which I chose `$str_aref` as a name. ( And no, I am not a fan of the so-called Hungarian Notation that codes the variable type into a variable's names. If I was, I probably wouldn't be a fan of Perl. Or vice versa. Or whatever.) 
+> Write a script to find out the number of unique Arithmetic Triplets satisfying the following rules:<br/>
+> a) i < j < k<br/>
+> b) nums[j] - nums[i] == diff<br/>
+> c) nums[k] - nums[j] == diff<br/>
 
-The task itself is quite straightforward to implement in Perl.
+we formulate:
+> Write a script to find out how many numbers nums[i] exist in the array where<br/>
+> a) nums[i] + diff also exists in the array,<br/>
+> b) nums[i] + 2 * diff also exists in the array.
 
-We walk through the `@str` array (using the said `$str_aref` variable), and extract each first character into a list.
-In the same flow, we concatenate that list of letters into a word (the acronym), and lower-case it. Then we can compare it to the other parameter, `$chk`, and return the comparison result. 
+That sounds much better!
+
+What we need to do is to create a hash lookup for checking the existence of the values in the array.
+Here we go:
 
-For extracting the first letter of each word, in a real application I would probably use
 ```perl
-    substr( $_, 0, 1 )
+    my %nums = map { ( $_ => 1 ) } @nums;
 ```
-, to avoid the overhead for building and starting a regular expression, but for here, I prefer this more concise and well understood simple rexexp:
+Using this lookup, it's easy to filter out those numbers of the array
+for which the '+ diff' and '+ 2 * diff' values also exist.
+We use `grep` for that.
+And it's also easy to get the number of hits instead of the hits themselves by just using `grep` in a scalar context:
+
 ```perl
-   /^(.)/
+    return scalar grep
+        exists $nums{ $_ + $diff } && exists $nums{ $_ + 2 * $diff },
+        @nums;
 ```
-
-So there we have our short solution to shorten words to acronyms:
+As we have more than one parameter to call the function with (the `@nums` array and the `$diff` scalar value),
+we pass in the `@nums` array as an array reference. We create a real array immediately after entering our subroutine (only for easier reading!).<br/>
+This makes my  final solution look like this:
 
 ```perl
-sub acronym( $str_aref, $chk ) {
-    return $chk eq lc join "", map /^(.)/, $str_aref->@*;
+sub arithmetic_triplets( $nums_aref, $diff ) {
+    # Copy the array ref into a local array (only for easier reading).
+    my @nums = $nums_aref->@*;
+    # Create a lookup for all numbers.
+    my %nums = map { ( $_ => 1 ) } @nums;
+    # Return the number of numbers fulfilling the criteria.
+    return scalar grep
+        exists $nums{ $_ + $diff } && exists $nums{ $_ + 2 * $diff },
+        @nums;
 }
 ```
+Good to avoid the permutations like that!
 
-## Task 2: Build Array
+## Task 2: Prime Order
 
-> You are given an array of integers.<br/>
-> Write a script to create an array such that $$new[i] = old[old[i]]$$ where $$0 <= i < new.length$$.<br/>
-> Example 1<br/>
-> Input: @int = (0, 2, 1, 5, 3, 4)<br/>
-> Output: (0, 1, 2, 4, 5, 3)<br/>
+> You are given an array of unique positive integers greater than 2.<br/>
+> Write a script to sort them in ascending order of the count of their prime factors, tie-breaking by ascending value.<br/>
 > <br/>
-> Example 2<br/>
-> Input: @int = (5, 0, 1, 2, 3, 4)<br/>
-> Output: (4, 5, 0, 1, 2, 3)<br/>
+> Example 1<br/>
+> Input: @int = (11, 8, 27, 4)<br/>
+> Output: (11, 4, 8, 27))<br/>
+> Prime factors of 11 => 11<br/>
+> Prime factors of  4 => 2, 2<br/>
+> Prime factors of  8 => 2, 2, 2<br/>
+> Prime factors of 27 => 3, 3, 3<br/>
+
+In a first step, we create an array that contains the number of prime factors for each number in `@int` at the same index.
+This will make it easier for sorting the numbers later on.
+
+I separated out the computation of the number of prime factors for a given number `$n`  into an own function.
+It walks through the possible factors for `$n` (not overly optimized; actually it tries every number, wheras trying only prime numbers would be enough). If the number is divisible by that factor without rest, it divides that factor away, increases the number of factors, and tries the same factor again before moving on.<br/>
+Like this:     
 
-Using the name of the parameter `@int` instead of the specification's $$old$$, we can translate the specification $$new[i] = old[old[i]]$$ directly to
-```perl
-my @new = map $int[ $int[$_] ]
-    for 0..$#old;
-```
-As we use all elements of the `int` array, one by one, in the inner bracket, we might as well insert the whole array in one step instead, using Perl's *array slice* syntax. We then even don't need the `map`  call any more, because an array slice already gives us a list:<br/>
 ```perl
-my @new = @int[ @int ];
+sub n_prime_factors( $n ) {
+    my $n_prime_factors = 0;
+    for ( my $i = 2; $i <= $n; ++$i ) {
+        if ( $n % $i == 0 ) {
+            $n /= $i;
+            ++$n_prime_factors;
+            redo;
+        }
+    }
+    return $n_prime_factors;
+}
 ```
-And actually we don't even need the `@new` variable, because we immediately return the list of values as the result.
 
-Which makes this probably the shortest solution to a *PWC* task that I have ever written:
+The complete solution first generates the number of prime factors for all numbers in the `@int` array,
+using the function just described. 
+
+It then returns the `@int` numbers in the order determined by `sort` with a code block. Instead of using a temporary array and sorting it, the sorted numbers are returned directly from the original array, using Perl's array slice syntax. This works well with the `sort` code block that uses the same array indexes to access the number of prime factors as well as the numbers themselves in case of a tie. 
 
 ```perl
-sub build_array( @int ) {
-    return @int[ @int ];
+sub prime_order( @int ) {
+    my @n_prime_factors = map n_prime_factors( $_ ), @int;
+    return @int[
+        sort {
+            $n_prime_factors[$a] <=> $n_prime_factors[$b]
+                || $int[$a] <=> $int[$b]
+        } 0..$#int
+    ];
 }
 ```
 
+I think Perl helps a lot to keep these solutions short and fun, but still readable.  
+
 #### **Thank you for the challenge!**
diff --git a/challenge-241/matthias-muth/perl/TestExtractor.pm b/challenge-241/matthias-muth/perl/TestExtractor.pm
new file mode 100644
index 0000000000..092e0539cc
--- /dev/null
+++ b/challenge-241/matthias-muth/perl/TestExtractor.pm
@@ -0,0 +1,258 @@
+#
+#       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 vprint vsay pp np carp croak );
+
+use Data::Dump qw( pp );
+use Data::Printer;
+use Getopt::Long;
+use Cwd qw( abs_path );
+use File::Basename;
+use List::Util qw( any );
+use Carp;
+use Test2::V0 qw( -no_srand );
+use Carp;
+no warnings 'experimental::signatures';
+
+our ( $verbose, %options );
+sub vprint { print @_ if $verbose };
+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*
+	    ^Out?put: \s* ( .*? ) \s*? (?=(?: ^$ | ^\S | \Z ))
+	/xmsg )
+    {
+	my ( $test, $input, $output) = ( $1, $2, $3 );
+	# vsay pp $test, $input, $output;
+
+	push @tests, { TEST => $test };
+
+	# Check whether the Input: part contains any variable sigils.
+	# If not, we try to convert '<Sequence of Words> = ...'
+	# into '$sequence_of_words = ...'.
+	# This is for specification like
+	# Input: Year = 2024, Month = 4, Weekday of month = 3, day of week = 2
+	unless ( $input =~ /[\$\@]\w+/ ) {
+	    $input =~ s{(\w+?(?: \w+?)*?)(\s*=)}{
+		my ( $var_name, $equals ) = ( $1, $2 );
+		'$' . lc ( $var_name =~ s/ /_/gr ) . $equals;
+	    }eg;
+	    # vsay "changed \$input to '$input'";
+	}
+
+	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, 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-241/matthias-muth/perl/ch-1.pl b/challenge-241/matthias-muth/perl/ch-1.pl
new file mode 100644
index 0000000000..7d7ca4545b
--- /dev/null
+++ b/challenge-241/matthias-muth/perl/ch-1.pl
@@ -0,0 +1,31 @@
+#!/usr/bin/env perl
+#
+#       The Weekly Challenge - Perl & Raku
+#       (https://theweeklychallenge.org)
+#
+#       Challenge 241 Task 1: Arithmetic Triplets
+#
+#       Perl solution by Matthias Muth.
+#
+
+use v5.20;
+use strict;
+use warnings;
+use feature 'signatures';
+no warnings 'experimental::signatures';
+
+use lib '.';
+use TestExtractor;
+
+sub arithmetic_triplets( $nums_aref, $diff ) {
+    # Copy the array ref into a local array (only for easier reading).
+    my @nums = $nums_aref->@*;
+    # Create a lookup for all numbers.
+    my %nums = map { ( $_ => 1 ) } @nums;
+    # Return the number of numbers fulfilling the criteria.
+    return scalar grep
+        exists $nums{ $_ + $diff } && exists $nums{ $_ + 2 * $diff },
+        @nums;
+}
+
+run_tests;
diff --git a/challenge-241/matthias-muth/perl/ch-2.pl b/challenge-241/matthias-muth/perl/ch-2.pl
new file mode 100644
index 0000000000..3327053f54
--- /dev/null
+++ b/challenge-241/matthias-muth/perl/ch-2.pl
@@ -0,0 +1,42 @@
+#!/usr/bin/env perl
+#
+#       The Weekly Challenge - Perl & Raku
+#       (https://theweeklychallenge.org)
+#
+#       Challenge 241 Task 2: Prime Order
+#
+#       Perl solution by Matthias Muth.
+#
+
+use v5.20;
+use strict;
+use warnings;
+use feature 'signatures';
+no warnings 'experimental::signatures';
+
+use lib '.';
+use TestExtractor;
+
+sub n_prime_factors( $n ) {
+    my $n_prime_factors = 0;
+    for ( my $i = 2; $i <= $n; ++$i ) {
+        if ( $n % $i == 0 ) {
+            $n /= $i;
+            ++$n_prime_factors;
+            redo;
+        }
+    }
+    return $n_prime_factors;
+}
+
+sub prime_order( @int ) {
+    my @n_prime_factors = map n_prime_factors( $_ ), @int;
+    return @int[
+        sort {
+            $n_prime_factors[$a] <=> $n_prime_factors[$b]
+                || $int[$a] <=> $int[$b]
+        } 0..$#int
+    ];
+}
+
+run_tests;
diff --git a/challenge-241/matthias-muth/perl/challenge-241.txt b/challenge-241/matthias-muth/perl/challenge-241.txt
new file mode 100644
index 0000000000..d2d0f8d39a
--- /dev/null
+++ b/challenge-241/matthias-muth/perl/challenge-241.txt
@@ -0,0 +1,42 @@
+The Weekly Challenge - 241

+Monday, Oct 30, 2023| Tags: Perl, Raku

+Task 1: Arithmetic Triplets

+Submitted by: Mohammad S Anwar

+You are given an array (3 or more members) of integers in increasing order and a positive integer.

+

+Write a script to find out the number of unique Arithmetic Triplets satisfying the following rules:

+

+a) i < j < k

+b) nums[j] - nums[i] == diff

+c) nums[k] - nums[j] == diff

+Example 1

+Input: @nums = (0, 1, 4, 6, 7, 10)

+       $diff = 3

+Output: 2

+

+Index (1, 2, 4) is an arithmetic triplet because both  7 - 4 == 3 and 4 - 1 == 3.

+Index (2, 4, 5) is an arithmetic triplet because both 10 - 7 == 3 and 7 - 4 == 3.

+Example 2

+Input: @nums = (4, 5, 6, 7, 8, 9)

+       $diff = 2

+Output: 2

+

+(0, 2, 4) is an arithmetic triplet because both 8 - 6 == 2 and 6 - 4 == 2.

+(1, 3, 5) is an arithmetic triplet because both 9 - 7 == 2 and 7 - 5 == 2.

+

+Task 2: Prime Order

+Submitted by: Mohammad S Anwar

+You are given an array of unique positive integers greater than 2.

+

+Write a script to sort them in ascending order of the count of their prime factors, tie-breaking by ascending value.

+

+Example 1

+Input: @int = (11, 8, 27, 4)

+Output: (11, 4, 8, 27)

+

+Prime factors of 11 => 11

+Prime factors of  4 => 2, 2

+Prime factors of  8 => 2, 2, 2

+Prime factors of 27 => 3, 3, 3

+

+Last date to submit the solution 23:59 (UK Time) Sunday 5th November 2023.