diff options
| -rw-r--r-- | challenge-242/matthias-muth/README.md | 183 | ||||
| -rw-r--r-- | challenge-242/matthias-muth/blog.txt | 1 | ||||
| -rw-r--r-- | challenge-242/matthias-muth/perl/TestExtractor.pm | 258 | ||||
| -rwxr-xr-x | challenge-242/matthias-muth/perl/ch-1.pl | 31 | ||||
| -rwxr-xr-x | challenge-242/matthias-muth/perl/ch-2.pl | 24 | ||||
| -rw-r--r-- | challenge-242/matthias-muth/perl/challenge-242.txt | 63 |
6 files changed, 461 insertions, 99 deletions
diff --git a/challenge-242/matthias-muth/README.md b/challenge-242/matthias-muth/README.md index 9a687e977f..831aaebec6 100644 --- a/challenge-242/matthias-muth/README.md +++ b/challenge-242/matthias-muth/README.md @@ -1,130 +1,115 @@ -# Rewriting the Rules Can Make Things Simple -**Challenge 241 solutions in Perl by Matthias Muth** +# Checking and Flipping -## Task 1: Arithmetic Triplets +**Challenge 242 solutions in Perl by Matthias Muth** -> 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/> +## Task 1: Missing Members + +> You are given two arrays of integers.<br/> +> Write a script to find out the missing members in each other arrays.<br/> > <br/> > Example 1<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/> +> Input: @arr1 = (1, 2, 3)<br/> +> @arr2 = (2, 4, 6)<br/> +> Output: ([1, 3], [4, 6])<br/> +> (1, 2, 3) has 2 members (1, 3) missing in the array (2, 4, 6).<br/> +> (2, 4, 6) has 2 members (4, 6) missing in the array (1, 2, 3).<br/> > <br/> > Example 2<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. +> Input: @arr1 = (1, 2, 3, 3)<br/> +> @arr2 = (1, 1, 2, 2)<br/> +> Output: ([3])<br/> +> (1, 2, 3, 3) has 2 members (3, 3) missing in the array (1, 1, 2, 2). Since they are same, keep just one.<br/> +> (1, 1, 2, 2) has 0 member missing in the array (1, 2, 3, 3).<br/> -But we can restate the task in a different way and find a much simpler way to solve it:<br/> -Instead of +In [perlfaq4](https://perldoc.perl.org/perlfaq4#How-can-I-get-the-unique-keys-from-two-hashes%3F), Brian D Foy gives a recommendation for removing duplicate elements from a list or an array: -> 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/> +> Use a hash. When you think the words "unique" or "duplicated", think "hash keys". -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. +I would like to extend this good advice to +> Whenever you think "*existence of a value*", think "hash keys"! -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: +So when we need to decide whether members of one array are contained in the other, +the easiest solution is to first build two hashes from the values of the two arrays. +We create an entry containing the value 1 for each member, +using a common Perl idiom. +As we have two arrays as input to our function, +we use references to the actual arrays as parameters.<br/> +That can look like this: ```perl - my %nums = map { ( $_ => 1 ) } @nums; + my %arr1_members = map { ( $_ => 1 ) } $arr1->@*; + my %arr2_members = map { ( $_ => 1 ) } $arr2->@*; ``` -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: +Then, we can `grep` through the two arrays, with a condition of the current value *not* existing in the other array's lookup hash.<br/> +There may be duplicate values in the input arrays, but we are supposed to return only distinct values in the results. +So we could follow the above advice and create another hash to reduce multiple values into distinct ones. But, to make it easy, we can also simply leave that work to the `uniq` function from the `List::Util` core module.<br/> +We then return the results as two anonymous arrays. -```perl - return scalar grep - exists $nums{ $_ + $diff } && exists $nums{ $_ + 2 * $diff }, - @nums; -``` -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: +Which makes this my complete solution: ```perl -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; +use List::Util qw( uniq ); + +sub missing_members( $arr1, $arr2 ) { + my %arr1_members = map { ( $_ => 1 ) } $arr1->@*; + my %arr2_members = map { ( $_ => 1 ) } $arr2->@*; + return ( + [ uniq grep ! $arr2_members{$_}, $arr1->@* ], + [ uniq grep ! $arr1_members{$_}, $arr2->@* ], + ); } ``` -Good to avoid the permutations like that! - -## Task 2: Prime Order -> 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/> +## Task 2: Flip Matrix + +> You are given n x n binary matrix.<br/> +> Write a script to flip the given matrix as below.<br/> +> 1 1 0<br/> +> 0 1 1<br/> +> 0 0 1<br/> +> a) Reverse each row<br/> +> 0 1 1<br/> +> 1 1 0<br/> +> 1 0 0<br/> +> b) Invert each member<br/> +> 1 0 0<br/> +> 0 0 1<br/> +> 0 1 1<br/> > <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: +> Input: @matrix = ([1, 1, 0], [1, 0, 1], [0, 0, 0])<br/> +> Output: ([1, 0, 0], [0, 1, 0], [1, 1, 1])<br/> +> <br/> +> Example 2<br/> +> Input: @matrix = ([1, 1, 0, 0], [1, 0, 0, 1], [0, 1, 1, 1], [1, 0, 1, 0])<br/> +> Output: ([1, 1, 0, 0], [0, 1, 1, 0], [0, 0, 0, 1], [1, 0, 1, 0])<br/> + +We are a bit lucky, because the operations described here can be performed on each row independently, for each row, one by one. This makes things quite easy.<br/> +We can chain the `reverse` operation and the 'inverse' operation +(which is a binary exclusive or, `^`. with the value `1`) +using a `map` call for all values of a row. +The results go into an anonymous array, which will be the resulting row.<br/> +Assuming that the current row is represented by `$_` +containing a reference to the row's data, this does the transformation +for one row: ```perl -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; -} + [ map $_ ^ 1, reverse $_->@* ] ``` +In Perl's representation of two-dimensional arrays, +each row actually is a reference to an array containing the values of that row. +In addition, in our case, the `$matrix` parameter is a reference itself to the array of row references.<br/> +This means that in an outer `map` call, we can loop over the rows like this: -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 + map ..., $matrix->@*; +``` +Putting the pieces together, this the complete (one-line :-) ) solution: ```perl -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 - ]; +sub flip_matrix( $matrix ) { + return map [ map $_ ^ 1, reverse $_->@* ], $matrix->@*; } ``` -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-242/matthias-muth/blog.txt b/challenge-242/matthias-muth/blog.txt new file mode 100644 index 0000000000..bb7fda5594 --- /dev/null +++ b/challenge-242/matthias-muth/blog.txt @@ -0,0 +1 @@ +https://github.com/MatthiasMuth/perlweeklychallenge-club/tree/muthm-242/challenge-242/matthias-muth#readme diff --git a/challenge-242/matthias-muth/perl/TestExtractor.pm b/challenge-242/matthias-muth/perl/TestExtractor.pm new file mode 100644 index 0000000000..092e0539cc --- /dev/null +++ b/challenge-242/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-242/matthias-muth/perl/ch-1.pl b/challenge-242/matthias-muth/perl/ch-1.pl new file mode 100755 index 0000000000..cb105bd56e --- /dev/null +++ b/challenge-242/matthias-muth/perl/ch-1.pl @@ -0,0 +1,31 @@ +#!/usr/bin/env perl +# +# The Weekly Challenge - Perl & Raku +# (https://theweeklychallenge.org) +# +# Challenge 242 Task 1: Missing Members +# +# Perl solution by Matthias Muth. +# + +use v5.20; +use strict; +use warnings; +use feature 'signatures'; +no warnings 'experimental::signatures'; + +use lib '.'; +use TestExtractor; + +use List::Util qw( uniq ); + +sub missing_members( $arr1, $arr2 ) { + my %arr1_members = map { ( $_ => 1 ) } $arr1->@*; + my %arr2_members = map { ( $_ => 1 ) } $arr2->@*; + return ( + [ uniq grep ! $arr2_members{$_}, $arr1->@* ], + [ uniq grep ! $arr1_members{$_}, $arr2->@* ], + ); +} + +run_tests; diff --git a/challenge-242/matthias-muth/perl/ch-2.pl b/challenge-242/matthias-muth/perl/ch-2.pl new file mode 100755 index 0000000000..af76906811 --- /dev/null +++ b/challenge-242/matthias-muth/perl/ch-2.pl @@ -0,0 +1,24 @@ +#!/usr/bin/env perl +# +# The Weekly Challenge - Perl & Raku +# (https://theweeklychallenge.org) +# +# Challenge 242 Task 2: Flip Matrix +# +# Perl solution by Matthias Muth. +# + +use v5.20; +use strict; +use warnings; +use feature 'signatures'; +no warnings 'experimental::signatures'; + +use lib '.'; +use TestExtractor; + +sub flip_matrix( $matrix ) { + return map [ map $_ ^ 1, reverse $_->@* ], $matrix->@*; +} + +run_tests; diff --git a/challenge-242/matthias-muth/perl/challenge-242.txt b/challenge-242/matthias-muth/perl/challenge-242.txt new file mode 100644 index 0000000000..46f46d3435 --- /dev/null +++ b/challenge-242/matthias-muth/perl/challenge-242.txt @@ -0,0 +1,63 @@ +The Weekly Challenge - 242 +Monday, Nov 6, 2023 + + +Task 1: Missing Members +Submitted by: Mohammad S Anwar + +You are given two arrays of integers. +Write a script to find out the missing members in each other arrays. +Example 1 + +Input: @arr1 = (1, 2, 3) + @arr2 = (2, 4, 6) +Output: ([1, 3], [4, 6]) + +(1, 2, 3) has 2 members (1, 3) missing in the array (2, 4, 6). +(2, 4, 6) has 2 members (4, 6) missing in the array (1, 2, 3). + +Example 2 + +Input: @arr1 = (1, 2, 3, 3) + @arr2 = (1, 1, 2, 2) +Output: ([3],[]) + +(1, 2, 3, 3) has 2 members (3, 3) missing in the array (1, 1, 2, 2). Since they are same, keep just one. +(1, 1, 2, 2) has 0 member missing in the array (1, 2, 3, 3). + + +Task 2: Flip Matrix +Submitted by: Mohammad S Anwar + +You are given n x n binary matrix. +Write a script to flip the given matrix as below. + +1 1 0 +0 1 1 +0 0 1 + +a) Reverse each row + +0 1 1 +1 1 0 +1 0 0 + +b) Invert each member + +1 0 0 +0 0 1 +0 1 1 + + +Example 1 + +Input: @matrix = ([1, 1, 0], [1, 0, 1], [0, 0, 0]) +Output: ([1, 0, 0], [0, 1, 0], [1, 1, 1]) + +Example 2 + +Input: @matrix = ([1, 1, 0, 0], [1, 0, 0, 1], [0, 1, 1, 1], [1, 0, 1, 0]) +Output: ([1, 1, 0, 0], [0, 1, 1, 0], [0, 0, 0, 1], [1, 0, 1, 0]) + + +Last date to submit the solution 23:59 (UK Time) Sunday 12th November 2023. |