diff options
| -rw-r--r-- | challenge-240/matthias-muth/README.md | 102 | ||||
| -rw-r--r-- | challenge-240/matthias-muth/blog.txt | 1 | ||||
| -rw-r--r-- | challenge-240/matthias-muth/perl/TestExtractor.pm | 258 | ||||
| -rwxr-xr-x | challenge-240/matthias-muth/perl/ch-1.pl | 24 | ||||
| -rwxr-xr-x | challenge-240/matthias-muth/perl/ch-2.pl | 24 | ||||
| -rw-r--r-- | challenge-240/matthias-muth/perl/challenge-240.txt | 45 |
6 files changed, 400 insertions, 54 deletions
diff --git a/challenge-240/matthias-muth/README.md b/challenge-240/matthias-muth/README.md index b8db841f68..4d24effa06 100644 --- a/challenge-240/matthias-muth/README.md +++ b/challenge-240/matthias-muth/README.md @@ -1,85 +1,79 @@ -# Short Solutions for Short Strings +# Short Acronyms, and Short Solutions -**Challenge 239 solutions in Perl by Matthias Muth** +**Challenge 240 solutions in Perl by Matthias Muth** -## Task 1: Same String +## Task 1: Acronym -> You are given two arrays of strings.<br/> -> Write a script to find out if the word created by concatenating the array elements is the same.<br/> -> <br/> +> 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/> > Example 1<br/> -> Input: @arr1 = ("ab", "c")<br/> -> @arr2 = ("a", "bc")<br/> +> Input: @str = ("Perl", "Python", "Pascal")<br/> +> \$chk = "ppp"<br/> > Output: true<br/> -> Using @arr1, word1 => "ab" . "c" => "abc"<br/> -> Using @arr2, word2 => "a" . "bc" => "abc"<br/> > <br/> > Example 2<br/> -> Input: @arr1 = ("ab", "c")<br/> -> @arr2 = ("ac", "b")<br/> +> Input: @str = ("Perl", "Raku")<br/> +> \$chk = "rp"<br/> > Output: false<br/> -> Using @arr1, word1 => "ab" . "c" => "abc"<br/> -> Using @arr2, word2 => "ac" . "b" => "acb"<br/> > <br/> > Example 3<br/> -> Input: @arr1 = ("ab", "cd", "e")<br/> -> @arr2 = ("abcde")<br/> +> Input: @str = ("Oracle", "Awk", "C")<br/> +> \$chk = "oac"<br/> > Output: true<br/> -> Using @arr1, word1 => "ab" . "cd" . "e" => "abcde"<br/> -> Using @arr2, word2 => "abcde"<br/> -Now this is a really easy one. -All we have to do is to concatenate all elements of each array, and do a string comparison of the two resulting words: +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.) + +The task itself is quite straightforward to implement in Perl. +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. + +For extracting the first letter of each word, in a real application I would probably use ```perl -sub same_string( $arr1, $arr2 ) { - return join( "", $arr1->@* ) eq join( "", $arr2->@* ); -} + substr( $_, 0, 1 ) ``` -Happy to use the '[Postfix Dereference Syntax](https://perldoc.perl.org/perlref#Postfix-Dereference-Syntax)' +, to avoid the overhead for building and starting a regular expression, but for here, I prefer this more concise and well understood simple rexexp: ```perl - $array->@* + /^(.)/ ``` -to get all elements of the array. In my opinion is easier to write and easier to read than the 'cast'-like `@{$array}` or its short form @$array, which can only be used in simple cases. -Same as I use + +So there we have our short solution to shorten words to acronyms: ```perl - $array->[1] - $array->[2][3] +sub acronym( $str_aref, $chk ) { + return $chk eq lc join "", map /^(.)/, $str_aref->@*; +} ``` -to access elements with references to arrays or multi-dimensional arrays, respectively.<br/>But I digress. I should rather keep it 'short'. :-) -## Task 2: Consistent Strings +## Task 2: Build Array -> You are given an array of strings and allowed string having distinct characters.<br/> -> A string is consistent if all characters in the string appear in the string allowed.<br/> -> Write a script to return the number of consistent strings in the given array.<br/> -> <br/> +> 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: @str = ("ad", "bd", "aaab", "baa", "badab")<br/> -> \$allowed = "ab"<br/> -> Output: 2<br/> -> Strings "aaab" and "baa" are consistent since they only contain characters 'a' and 'b'.<br/> +> Input: @int = (0, 2, 1, 5, 3, 4)<br/> +> Output: (0, 1, 2, 4, 5, 3)<br/> > <br/> > Example 2<br/> -> Input: @str = ("a", "b", "c", "ab", "ac", "bc", "abc")<br/> -> \$allowed = "abc"<br/> -> Output: 7<br/> -> <br/> -> Example 3<br/> -> Input: @str = ("cc", "acd", "b", "ba", "bac", "bad", "ac", "d")<br/> -> \$allowed = "cad"<br/> -> Output: 4<br/ -> Strings "cc", "acd", "ac", and "d" are consistent.<br/> +> Input: @int = (5, 0, 1, 2, 3, 4)<br/> +> Output: (4, 5, 0, 1, 2, 3)<br/> + +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 ]; +``` +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: -This one, too, is a very short one if we use the right tool for the right job.<br/> -In this case, a regular expressions accepting only allowed characters can filter out the 'consistent' strings.<br/> -We can use `grep` to iterate over the strings, and in scalar context it returns -- wait a second! -- the number of matches!<br/> ```perl -sub consistent_strings( $str, $allowed ) { - return scalar grep /^[$allowed]*$/, $str->@*; +sub build_array( @int ) { + return @int[ @int ]; } ``` -Done! :-) #### **Thank you for the challenge!** diff --git a/challenge-240/matthias-muth/blog.txt b/challenge-240/matthias-muth/blog.txt new file mode 100644 index 0000000000..d2d4edf4bf --- /dev/null +++ b/challenge-240/matthias-muth/blog.txt @@ -0,0 +1 @@ +https://github.com/MatthiasMuth/perlweeklychallenge-club/tree/muthm-240/challenge-240/matthias-muth#readme diff --git a/challenge-240/matthias-muth/perl/TestExtractor.pm b/challenge-240/matthias-muth/perl/TestExtractor.pm new file mode 100644 index 0000000000..092e0539cc --- /dev/null +++ b/challenge-240/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-240/matthias-muth/perl/ch-1.pl b/challenge-240/matthias-muth/perl/ch-1.pl new file mode 100755 index 0000000000..c2ea7ee753 --- /dev/null +++ b/challenge-240/matthias-muth/perl/ch-1.pl @@ -0,0 +1,24 @@ +#!/usr/bin/env perl +# +# The Weekly Challenge - Perl & Raku +# (https://theweeklychallenge.org) +# +# Challenge 240 Task 1: Acronym +# +# Perl solution by Matthias Muth. +# + +use v5.20; +use strict; +use warnings; +use feature 'signatures'; +no warnings 'experimental::signatures'; + +use lib '.'; +use TestExtractor; + +sub acronym( $str_aref, $chk ) { + return $chk eq lc join "", map /^(.)/, $str_aref->@*; +} + +run_tests; diff --git a/challenge-240/matthias-muth/perl/ch-2.pl b/challenge-240/matthias-muth/perl/ch-2.pl new file mode 100755 index 0000000000..1f974e8896 --- /dev/null +++ b/challenge-240/matthias-muth/perl/ch-2.pl @@ -0,0 +1,24 @@ +#!/usr/bin/env perl +# +# The Weekly Challenge - Perl & Raku +# (https://theweeklychallenge.org) +# +# Challenge 240 Task 2: Build Array +# +# Perl solution by Matthias Muth. +# + +use v5.20; +use strict; +use warnings; +use feature 'signatures'; +no warnings 'experimental::signatures'; + +use lib '.'; +use TestExtractor; + +sub build_array( @int ) { + return @int[ @int ]; +} + +run_tests; diff --git a/challenge-240/matthias-muth/perl/challenge-240.txt b/challenge-240/matthias-muth/perl/challenge-240.txt new file mode 100644 index 0000000000..e6fcb64a78 --- /dev/null +++ b/challenge-240/matthias-muth/perl/challenge-240.txt @@ -0,0 +1,45 @@ +The Weekly Challenge - 240 +Monday, Oct 23, 2023 + + +Task 1: Acronym +Submitted by: Mohammad S Anwar + +You are given an array of strings and a check string. +Write a script to find out if the check string is the acronym of the words in the given array. +Example 1 + +Input: @str = ("Perl", "Python", "Pascal") + $chk = "ppp" +Output: true + +Example 2 + +Input: @str = ("Perl", "Raku") + $chk = "rp" +Output: false + +Example 3 + +Input: @str = ("Oracle", "Awk", "C") + $chk = "oac" +Output: true + + +Task 2: Build Array +Submitted by: Mohammad S Anwar + +You are given an array of integers. +Write a script to create an array such that new[i] = old[old[i]] where 0 <= i < new.length. +Example 1 + +Input: @int = (0, 2, 1, 5, 3, 4) +Output: (0, 1, 2, 4, 5, 3) + +Example 2 + +Input: @int = (5, 0, 1, 2, 3, 4) +Output: (4, 5, 0, 1, 2, 3) + + +Last date to submit the solution 23:59 (UK Time) Sunday 29th October 2023. |