diff options
| -rw-r--r-- | challenge-214/matthias-muth/README.md | 127 | ||||
| -rwxr-xr-x | challenge-214/matthias-muth/perl/ch-1.pl | 39 | ||||
| -rwxr-xr-x | challenge-214/matthias-muth/perl/ch-2.pl | 56 |
3 files changed, 99 insertions, 123 deletions
diff --git a/challenge-214/matthias-muth/README.md b/challenge-214/matthias-muth/README.md index 49233e1d01..fe15f8d3d3 100644 --- a/challenge-214/matthias-muth/README.md +++ b/challenge-214/matthias-muth/README.md @@ -1,125 +1,6 @@ -# Wow: Another oneliner! But also a complete BFS...! -*Challenge 213 solutions in Perl by Matthias Muth* - -## Task 1: Fun Sort - -> You are given a list of positive integers.<br/> -Write a script to sort the all even integers first then all odds in ascending order. - -Ok, let's see! -A typical approach would be to split up the list of integers into all even ones and all odd ones, -then sort both lists separately, and then concatenate them back together.<br/> -Absolutely ok!<br/> -But way below what Perl's `sort` can do for us! - -Why don't we use `sort` as it is supposed to be?<br/> -It is defined as -```perl -sort BLOCK LIST -``` -and `BLOCK` is a comparison that decides which of two values goes first in the result. - -For us here, we know that all even numbers go before all odd numbers.<br/> -To determine whether the number is even or odd, we can use the modulo operator, `%`. -We just check whether the number modulo 2 is 0 (even) or 1 (odd).<br/> -For determining the sort order, using Perl's *number comparison* operator `<=>` is our best choice.<br/> -Combining these two, we get the first part of our comparison for `sort`: -```perl - $a % 2 <=> $b % 2 -``` -That's all we need to make all even numbers 'go left', and all odd numbers 'go right'. - -If both numbers are even, or both are odd, the `<=>` operator returns zero. -For that case, we append the standard numeric comparison to define the order within all even (or all odd) numbers: -```perl - $a % 2 <=> $b % 2 || $a <=> $b -``` - -Thus, a quite short, but complete solution for this challenge can look like this: -```perl -sub fun_sort { - sort { $a % 2 <=> $b % 2 || $a <=> $b } @_; -} -``` -I don't think there will be a much more efficient way of solving this! - - -## Task 2: Shortest Route - -> You are given a list of bidirectional routes defining a network of nodes, as well as source and destination node numbers.<br/> -Write a script to find the route from source to destination that passes through fewest nodes. - -Finding the shortest route, ok...<br/> -So probably we need to implement a Broadth-First-Search algorithm to find our solution.<br/> -But maybe the examples are so simple that we don't need that!<br/> -Sorry, but it doesn't look like that. :-( - -Ok, then let's set it up for real! - -*Part 1: Preparing the data.* - -We have segments of roads, with numbers defining nodes on those segments.<br/> -If we ever want to follow a road from one node to the next one, we need to know which nodes are the neighbors of all nodes.<br/> -So first thing, we collect all neighbor connections.<br/> -We may have neighbors from several route sections, if sections meed at one node. So we don't need a 'left' and 'right' neighbor only, but we need to generalize to have any number of neighbors for any given node.<br/> -For me, that means that we need an array for each node, independent of any segments, in which we collect all neighbors.<br/> -We loop over all nodes in all segments, and gather the node's left and right neighbors from that segment, -checking that we do not access any non-existing neighbors beyond either end of the segment. -If a node is contained in more than one segment, its neighbors from there will be added in a later iteration, too.<br/> -```perl -sub shortest_route { - my ( $routes, $source, $destination ) = @_; - - my %neighbors; - for my $segment ( @$routes ) { - for ( 0..$#$segment ) { - push @{$neighbors{$segment->[$_]}}, - $_ > 0 ? $segment->[$_-1] : (), - $_ < $#$segment ? $segment->[$_+1] : (); - } - } -``` -As you see, instead of using multiple `if` statements, in this case -I prefer conditional expressions that evaluate to an empty list `()` if the condition does not match.<br/> - -*Part 2: The BFS.* - -Now, as for any real BFS, we need a stack. -In our case, the stack entries will contain complete paths that we will want to check for whether they solve our puzzle.<br/> -Each entry is an anonymous array with a list of nodes to travel.<br/> -We initialize the stack with a route containing the start node only. - -We also need a hash for remembering which nodes we have already visited while we keep adding more routes to test on the stack. -If not, we will find ourselves moving back and forth between nodes endlessly. - -Within the loop, we check route in the first stack entry (first in, first out, for a BFS) for whether it leads us to the destination node. -If yes, we are done.<br/> -If not, we add one stack entry for each of the last node's neighbors, adding each neighbor to the route that we just checked. -We make sure to only add neighbors if they were not visited before. And we mark those neighbors as visited, for future iterations. - -If we run out of entries on the stack without having found any route, we return the failure marker that is demanded for that case. - -So all in all, it might look like this: -```perl - my @stack = ( [ $source ] ); - my %visited = ( $source => 1 ); - while ( @stack ) { - my $path = pop @stack; - my $last_node = $path->[-1]; - return $path - if $last_node == $destination; - if ( $neighbors{$last_node} ) { - for ( @{$neighbors{$last_node}} ) { - unless ( $visited{$_} ) { - push @stack, [ @$path, $_ ]; - $visited{$_} = 1; - } - } - } - } - return -1; -} -``` -All in all, less complicated than I expected it to be in the beginning! +**Challenge 211 solutions in Perl by Matthias Muth** +<br/> +(no blog post this time...) **Thank you for the challenge!** + diff --git a/challenge-214/matthias-muth/perl/ch-1.pl b/challenge-214/matthias-muth/perl/ch-1.pl new file mode 100755 index 0000000000..7f2a610d59 --- /dev/null +++ b/challenge-214/matthias-muth/perl/ch-1.pl @@ -0,0 +1,39 @@ +#!/usr/bin/env perl +# +# The Weekly Challenge - Perl & Raku +# (https://theweeklychallenge.org) +# +# Challenge 214 Task 1: Rank Score +# +# Perl solution by Matthias Muth. +# + +use strict; +use warnings; +use feature 'say'; + +my @medals = qw( G S B ); + +sub rank_score { + my @scores = @_; + my @sorted_scores = sort { $b <=> $a } @scores; + my %ranks; + $ranks{$sorted_scores[$_]} //= $medals[$_] // $_ + 1 + for 0..$#sorted_scores; + return map $ranks{$_}, @scores; +} + +use Test::More; +use Data::Dump qw( pp ); + +do { + is_deeply [ rank_score( @{$_->{INPUT}} ) ], $_->{EXPECTED}, + "rank_score( " . pp( @{$_->{INPUT}} ) . " ) == " . pp( @{$_->{EXPECTED}} ); +} for ( + { INPUT => [ 1,2,4,3,5 ], EXPECTED => [ qw( 5 4 S B G ) ] }, + { INPUT => [ 8,5,6,7,4 ], EXPECTED => [ qw( G 4 B S 5 ) ] }, + { INPUT => [ 3,5,4,2 ], EXPECTED => [ qw( B G S 4 ) ] }, + { INPUT => [ 2,5,2,1,7,5,1 ], EXPECTED => [ qw( 4 S 4 6 G S 6 ) ] }, +); + +done_testing; diff --git a/challenge-214/matthias-muth/perl/ch-2.pl b/challenge-214/matthias-muth/perl/ch-2.pl new file mode 100755 index 0000000000..dfb159e755 --- /dev/null +++ b/challenge-214/matthias-muth/perl/ch-2.pl @@ -0,0 +1,56 @@ +#!/usr/bin/env perl +# +# The Weekly Challenge - Perl & Raku +# (https://theweeklychallenge.org) +# +# Challenge 214 Task 2: Collect Points +# +# Perl solution by Matthias Muth. +# + +use strict; +use warnings; +use feature 'say'; + +sub collect_points { + my @numbers = @_; + + # Edge cases: + # An empty list returns zero, + # and a list of one element returns one. + return scalar @numbers + if @numbers <= 1; + + # Find streaks, remove them for trial, and find the maximum + # number of points for the remaining list by recursion. + my $max = 0; + my $streak_start = 0; + for ( 0..$#numbers ) { + if ( $_ == $#numbers || $numbers[ $_ + 1 ] != $numbers[ $_ ] ) { + my $streak_end = $_; + my $points = ( $streak_end - $streak_start + 1 ) ** 2 + + collect_points( + @numbers[ 0..$streak_start - 1, + $streak_end + 1 .. $#numbers ] ); + $max = $points + if $points > $max; + $streak_start = $streak_end + 1; + } + } + return $max; +} + + +use Test::More; + +do { + is collect_points( @{$_->{INPUT}} ), $_->{EXPECTED}, + "collect_points( @{$_->{INPUT}} ) == $_->{EXPECTED}"; +} for ( + { INPUT => [ 2,4,3,3,3,4,5,4,2 ], EXPECTED => 23 }, + { INPUT => [ 1,2,2,2,2,1 ], EXPECTED => 20 }, + { INPUT => [ 1 ], EXPECTED => 1 }, + { INPUT => [ 2,2,2,1,1,2,2,2 ], EXPECTED => 40 }, +); + +done_testing; |