From 081d6d00507faebaafbdab8a7be58238668892a1 Mon Sep 17 00:00:00 2001 From: Matthias Muth Date: Sat, 29 Jul 2023 17:16:33 +0200 Subject: Challenge 226 solutions in Perl by Matthias Muth --- challenge-226/matthias-muth/README.md | 206 ++++++++++--------- challenge-226/matthias-muth/blog.txt | 1 + challenge-226/matthias-muth/perl/TestExtractor.pm | 226 +++++++++++++++++++++ challenge-226/matthias-muth/perl/ch-1.pl | 22 ++ challenge-226/matthias-muth/perl/ch-2.pl | 22 ++ challenge-226/matthias-muth/perl/challenge-226.txt | 53 +++++ 6 files changed, 437 insertions(+), 93 deletions(-) create mode 100644 challenge-226/matthias-muth/blog.txt create mode 100644 challenge-226/matthias-muth/perl/TestExtractor.pm create mode 100755 challenge-226/matthias-muth/perl/ch-1.pl create mode 100755 challenge-226/matthias-muth/perl/ch-2.pl create mode 100644 challenge-226/matthias-muth/perl/challenge-226.txt diff --git a/challenge-226/matthias-muth/README.md b/challenge-226/matthias-muth/README.md index 698cef7834..10e2b5a59d 100644 --- a/challenge-226/matthias-muth/README.md +++ b/challenge-226/matthias-muth/README.md @@ -1,120 +1,140 @@ -# Reduce to the max -**Challenge 225 solutions in Perl by Matthias Muth** +# The Zero Shuffle +**Challenge 226 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: Shuffle String -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.
-> A sentence is a list of words that are separated by a single space with no leading or trailing spaces.
-> Write a script to find out the maximum number of words that appear in a single sentence.
->
+> You are given a string and an array of indices of same length as string.
+> Write a script to return the string after re-arranging the indices in the correct order.
> Example 1
-> Input: @list = (qw/Perl and Raku belong to the same family./,
-> qw/I love Perl./,
-> qw/The Perl and Raku Conference./)
-> Output: 8
+>
+> Input: $string = 'lacelengh', @indices = (3,2,0,5,4,8,6,7,1)
+> Output: 'challenge'
>
> Example 2
-> Input: @list = (qw/The Weekly Challenge./,
-> qw/Python is the most popular guest language./,
-> qw/Team PWC has over 300 members./)
-> Output: 7
- -Perl in its own realm.
-So short that it probably needs some explanations... +> Input: $string = 'rulepark', @indices = (4,7,3,1,0,5,2,6)
+> Output: 'perlraku'
-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. +It took me a moment to understand +that the array of indices is not where the letters *come from*, +but where the letters *go to*.
+So we could write something like this for a `$result` string: +```perl + my $result = " " x $#{$indices}; # We need to initialize the full length. + substr( $result, $indices->[$_], 1 ) = substr( $string, $_, 1 ) + for 0..$#{$indices}; +``` +or this for a `@result` array: +```perl + my @results; + $results[ $indices->[$_] ] = substr( $string, $_, 1 ) + for 0..$#{$indices}; +``` -The number of words in each sentence is `scalar` of the list of words that we just got. +But of course there is more than one way to do it. :-)
+For example, we can switch from manipulating things one by one, +and work with whole lists instead. +Most often this results in shorter, more 'elegant' code, +because it is less cluttered with all the details needed just to do things repeatedly. +That's why very often this makes the code easier to understand. -And `max(...)` (from `List::Util`) gets us the largest one. +For making the letters from the string available as a list, +we can use the common Perl idiom +```perl + $string =~ /./g +``` +or we can use the also very common (and faster) +```perl + split //, $string +``` -Voilà! +For assigning the letters to the result array, +Perl has the wonderful array slice syntax, +that can not only retrieve selected parts of an array or list, +but also assign to selected elements of an array, even in random order. +Exactly what we need! +So actually we can +assign the letters to the given indexes +with just one assigment, +and solve the whole task with three lines of code.
```perl -use List::Util qw( max ); +use v5.36; -sub max_words { - my ( @list ) = @_; - return max( map { scalar split " ", $_ } @list ); +sub shuffle_string( $string, $indices ) { + my @results; + @results[ @$indices ] = split //, $string; + return join "", @results; } ``` +And no loop, and no typo-prone `$#{$indices}`! -## Task 2: Left Right Sum Diff - -> You are given an array of integers, @ints.
-> Write a script to return left right sum diff array as shown below:
-> @ints = (a, b, c, d, e)
-> @left = (0, a, (a+b), (a+b+c))
-> @right = ((c+d+e), (d+e), e, 0)
-> @left_right_sum_diff = ( | 0 - (c+d+e) |,
-> | a - (d+e) |,
-> | (a+b) - e |,
-> | (a+b+c) - 0 | )
+## Task 2: Zero Array + +> You are given an array of non-negative integers, @ints.
+> Write a script to return the minimum number of operations to make every element equal zero.
+> In each operation, you are required to pick a positive number less than or equal to the smallest element in the array, then subtract that from each positive element in the array.
>
> Example 1:
-> Input: @ints = (10, 4, 8, 3)
-> Output: (15, 1, 11, 22)
-> @left = (0, 10, 14, 22)
-> @right = (15, 11, 3, 0)
-> @left_right_sum_diff = ( |0-15|, |10-11|, |14-3|, |22-0|)
-> = (15, 1, 11, 22)
+> Input: @ints = (1, 5, 0, 3, 5)
+> Output: 3
+> operation 1: pick 1 => (0, 4, 0, 2, 4)
+> operation 2: pick 2 => (0, 2, 0, 0, 2)
+> operation 3: pick 2 => (0, 0, 0, 0, 0)
>
> Example 2:
-> Input: @ints = (1)
-> Output: (0)
-> @left = (0)
-> @right = (0)
-> @left_right_sum_diff = ( |0-0| ) = (0)
+> Input: @ints = (0)
+> Output: 0
>
> Example 3:
-> Input: @ints = (1, 2, 3, 4, 5)
-> Output: (14, 11, 6, 1, 19)
-> @left = (0, 1, 3, 6, 10)
-> @right = (14, 12, 9, 5, 0)
-> @left_right_sum_diff = ( |0-14|, |1-12|, |3-9|, |6-5|, |10-0|)
-> = (14, 11, 6, 1, 10)
- -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.
-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: +> Input: @ints = (2, 1, 4, 0, 3)
+> Output: 4
+> operation 1: pick 1 => (1, 0, 3, 0, 2)
+> operation 2: pick 1 => (0, 0, 2, 0, 1)
+> operation 3: pick 1 => (0, 0, 1, 0, 0)
+> operation 4: pick 1 => (0, 0, 0, 0, 0)
+ +This task can be made a lot easier by a 'transformation'.
+We transform the task itself. :-) + +I tried to visualize what actually happens when we do the subtractions +that are described in the text.
+I imagined all the numbers in a coordinate system. +The *x* axis corresponds to the indices, +and the *y* coordinate for each number is the number itself.
+Like this, for Example 1: +``` +@ints: 1 5 0 3 5 + | | | | | + 5 ................|. 5 .|..|. 5 ......... + 4 | | | + 3 ................|.....|. 3 ............ + 2 | | + 1 ............... 1 ....|................ + 0 _____________________ 0 _______________ +index: 0 1 2 3 4 +``` +Everytime we do the subtraction to all positive numbers, we kind of 'cut away' +a horizontal slice of the diagram.
+Of course, we get the minimum number of operations +when we cut only where there are numbers (at the dotted lines), not in between. -```perl -use feature 'signatures'; -no warnings 'experimental::signatures'; +In the diagram we see that we need to cut once for each unique number in the array, +and we don't need to cut on the zero line, even if there may be numbers that are zero. + +So actually, as we only need to return the *number* of operations needed, +and don't need to really execute them, our job is much easier:
+ +> You are given an array of non-negative integers, @ints.
+> Find the number of unique, non-zero numbers in the input array.
-use List::Util qw( reductions ); -use List::MoreUtils qw( pairwise ); +Oh! How easy! + +```perl +use v5.36; +use List::Util qw( uniq ); -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 +sub zero_array( @ints ) { + return scalar uniq grep $_ != 0, @ints; } ``` diff --git a/challenge-226/matthias-muth/blog.txt b/challenge-226/matthias-muth/blog.txt new file mode 100644 index 0000000000..cf8a1bb86d --- /dev/null +++ b/challenge-226/matthias-muth/blog.txt @@ -0,0 +1 @@ +https://github.com/MatthiasMuth/perlweeklychallenge-club/tree/muthm-226/challenge-226/matthias-muth#readme diff --git a/challenge-226/matthias-muth/perl/TestExtractor.pm b/challenge-226/matthias-muth/perl/TestExtractor.pm new file mode 100644 index 0000000000..4d6fa53893 --- /dev/null +++ b/challenge-226/matthias-muth/perl/TestExtractor.pm @@ -0,0 +1,226 @@ +# +# 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 np ); + +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 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/ (? $literal ) + | (? \[ \s* (?:$list)? \s* \] ) + | (? \( \s* (?:$list)? \s* \) ) + | (? $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} ? "( $_ )" : $_ ); + }; + } + + # 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-226/matthias-muth/perl/ch-1.pl b/challenge-226/matthias-muth/perl/ch-1.pl new file mode 100755 index 0000000000..07c6e772d0 --- /dev/null +++ b/challenge-226/matthias-muth/perl/ch-1.pl @@ -0,0 +1,22 @@ +#!/usr/bin/env perl +# +# The Weekly Challenge - Perl & Raku +# (https://theweeklychallenge.org) +# +# Challenge 226 Task 1: Shuffle String +# +# Perl solution by Matthias Muth. +# + +use v5.36; + +use lib '.'; +use TestExtractor; + +sub shuffle_string( $string, $indices ) { + my @results; + @results[ @$indices ] = split //, $string; + return join "", @results; +} + +run_tests; diff --git a/challenge-226/matthias-muth/perl/ch-2.pl b/challenge-226/matthias-muth/perl/ch-2.pl new file mode 100755 index 0000000000..36e5549ea1 --- /dev/null +++ b/challenge-226/matthias-muth/perl/ch-2.pl @@ -0,0 +1,22 @@ +#!/usr/bin/env perl +# +# The Weekly Challenge - Perl & Raku +# (https://theweeklychallenge.org) +# +# Challenge 226 Task 2: Zero Array +# +# Perl solution by Matthias Muth. +# + +use v5.36; + +use lib '.'; +use TestExtractor; + +use List::Util qw( uniq ); + +sub zero_array( @ints ) { + return scalar uniq grep $_ != 0, @ints; +} + +run_tests; diff --git a/challenge-226/matthias-muth/perl/challenge-226.txt b/challenge-226/matthias-muth/perl/challenge-226.txt new file mode 100644 index 0000000000..06e5b4f860 --- /dev/null +++ b/challenge-226/matthias-muth/perl/challenge-226.txt @@ -0,0 +1,53 @@ +The Weekly Challenge - 226 +Monday, Jul 17, 2023 + + +Task 1: Shuffle String +Submitted by: Mohammad S Anwar + +You are given a string and an array of indices of same length as string. +Write a script to return the string after re-arranging the indices in the correct order. +Example 1 + +Input: $string = 'lacelengh', @indices = (3,2,0,5,4,8,6,7,1) +Output: 'challenge' + +Example 2 + +Input: $string = 'rulepark', @indices = (4,7,3,1,0,5,2,6) +Output: 'perlraku' + + +Task 2: Zero Array +Submitted by: Mohammad S Anwar + +You are given an array of non-negative integers, @ints. +Write a script to return the minimum number of operations to make every element equal zero. +In each operation, you are required to pick a positive number less than or equal to the smallest element in the array, then subtract that from each positive element in the array. + +Example 1: + +Input: @ints = (1, 5, 0, 3, 5) +Output: 3 + +operation 1: pick 1 => (0, 4, 0, 2, 4) +operation 2: pick 2 => (0, 2, 0, 0, 2) +operation 3: pick 2 => (0, 0, 0, 0, 0) + +Example 2: + +Input: @ints = (0) +Output: 0 + +Example 3: + +Input: @ints = (2, 1, 4, 0, 3) +Output: 4 + +operation 1: pick 1 => (1, 0, 3, 0, 2) +operation 2: pick 1 => (0, 0, 2, 0, 1) +operation 3: pick 1 => (0, 0, 1, 0, 0) +operation 4: pick 1 => (0, 0, 0, 0, 0) + + +Last date to submit the solution 23:59 (UK Time) Sunday 23rd July 2023. -- cgit