diff options
| -rw-r--r-- | challenge-294/matthias-muth/README.md | 4 | ||||
| -rw-r--r-- | challenge-294/matthias-muth/blog.txt | 1 | ||||
| -rwxr-xr-x | challenge-294/matthias-muth/perl/ch-1.pl | 221 | ||||
| -rwxr-xr-x | challenge-294/matthias-muth/perl/ch-2.pl | 82 |
4 files changed, 306 insertions, 2 deletions
diff --git a/challenge-294/matthias-muth/README.md b/challenge-294/matthias-muth/README.md index 36d0c8563e..18c3c25375 100644 --- a/challenge-294/matthias-muth/README.md +++ b/challenge-294/matthias-muth/README.md @@ -1,8 +1,8 @@ ## The Weekly Challenge -## Solutions in Perl by Matthias Muth +## Week 294 solutions in Perl by Matthias Muth See -[here](https://dev.to/muthm/domino-frequencies-and-the-vectorized-boomerang-4j5a) +[here](https://dev.to/muthm/consecutive-sequences-of-permutations-anyone-pwc-294-2dbf) for a blog post describing this week's solutions. #### Thank you for the challenge! diff --git a/challenge-294/matthias-muth/blog.txt b/challenge-294/matthias-muth/blog.txt new file mode 100644 index 0000000000..43508a04dd --- /dev/null +++ b/challenge-294/matthias-muth/blog.txt @@ -0,0 +1 @@ +https://dev.to/muthm/consecutive-sequences-of-permutations-anyone-pwc-294-2dbf diff --git a/challenge-294/matthias-muth/perl/ch-1.pl b/challenge-294/matthias-muth/perl/ch-1.pl new file mode 100755 index 0000000000..a5ac0a25f8 --- /dev/null +++ b/challenge-294/matthias-muth/perl/ch-1.pl @@ -0,0 +1,221 @@ +#!/usr/bin/env perl +# +# The Weekly Challenge - Perl & Raku +# (https://theweeklychallenge.org) +# +# Challenge 294 Task 1: Consecutive Sequence +# +# Perl solution by Matthias Muth. +# + +use v5.40; +use experimental 'class'; + +use Verbose; +# $verbose = 1; + +use List::Util qw( uniq ); + +sub consecutive_sequence_using_hash( @ints ) { + my $max_streak_length = -1; + my %streaks; + for my $n ( uniq @ints ) { + vsay "processing $n"; + + # Create a new streak from this number, + # possibly merged with any existing adjacent streaks + # to the left or to the right. + my ( $left, $right ) = + ( $streaks{ $n - 1 }, $streaks{ $n + 1 } ); + vsay " merge with ", map " " . pp( $_ ), $left, $right + if $left || $right; + my ( $from, $to ) = ( + $left ? $left->{FROM} : $n, + $right ? $right->{TO} : $n, + ); + my $streak = { FROM => $from, TO => $to }; + + # Update the lookup entries: + # Remove any entries that are *inside* the merged streak, + # and add or update entries at the streak borders. + delete $streaks{ $left->{TO} } + if $left; + delete $streaks{ $right->{FROM} } + if $right; + $streaks{$from} = $streaks{$to} = $streak; + vsay " ", pp( $streak ); + vsay " ", pp( \%streaks ); + + # Update the maximum length if this is a streak + # (not just a single number). + $max_streak_length = $to - $from + 1 + if $to > $from && $to - $from + 1 > $max_streak_length; + } + return $max_streak_length; +} + +# +# consecutive_sequence using a Streak class +# +class Streak { + use Verbose; + use List::Util qw( min max ); + + field $start :param :reader; + field $end :param :reader; + + method merge( $other ) { + vprint " merging $self and $_"; + ( $start, $end ) = ( + min( $start, $other->start ), + max( $end, $other->end ), + ); + vsay " to $self"; + return $self; + } + + method as_string( @args ) { return __CLASS__ . "($start..$end)" } + use overload '""' => \&as_string; +} + +use List::Util qw( uniq ); + +sub consecutive_sequence_using_class( @ints ) { + my $max_streak_length = -1; + my %streaks; + for my $n ( uniq @ints ) { + vsay "processing $n"; + + # Create a new streak just from this number, + # and maintain the lookups. + my $streak = Streak->new( start => $n, end => $n ); + $streaks{$n} = $streak; + vsay " streak $streak"; + + # Try to merge with any existing adjacent streaks + # to the left or to the right. + + for ( $streaks{ $n - 1 }, $streaks{ $n + 1 } ) { + next unless $_; + + $streak->merge( $_ ); + + # Update the lookup entries: + # Remove both entries of the streak we merged, + # then add entries for the new one at the streak borders. + delete $streaks{$_->end}; + delete $streaks{$_->start}; + $streaks{ $streak->start } = + $streaks{ $streak->end } = $streak; + + # Update the maximum length. + $max_streak_length = $streak->end - $streak->start + 1 + if $streak->end - $streak->start + 1 > $max_streak_length; + } + } + return $max_streak_length; +} + +# +# consecutive_sequence +# using a 'SimpleStreak' class for the streak data, +# and a 'Streaks' class that maintains the streak lookups. +# +class SimpleStreak { + field $start :param :reader; + field $end :param :reader; + + method as_string( @args ) { return __CLASS__ . "($start..$end)" } + use overload '""' => \&as_string; +} + +class Streaks { + field %streaks :reader; + field $max_streak_length :reader = -1; + + method add_element( $n ) { + # Create a new streak merging this element with any existing neighbors. + my ( $left, $right ) = + ( $streaks{ $n - 1 }, $streaks{ $n + 1 } ); + my $streak = SimpleStreak->new( + start => $left ? $left->start : $n, + end => $right ? $right->end : $n, + ); + + # Update the lookup entries: + # Remove any entries that are *inside* the merged streak, + # and add or update entries at the streak borders. + delete $streaks{$left->end} + if $left; + delete $streaks{$right->start} + if $right; + $streaks{$streak->start} = $streaks{$streak->end} = $streak; + + # Update the maximum length if this is a real streak + # (not just a single number). + my $length = $streak->end - $streak->start + 1; + $max_streak_length = $length + if $length > 1 && $length > $max_streak_length; + + return $self; + } + + method as_string( @args ) { + return join "", + __CLASS__, "(\n", + ( map " $_ => $streaks{$_}\n", + sort { $a <=> $b } keys %streaks ), + ")"; + } + use overload '""' => \&as_string; +} + +use List::Util qw( uniq ); + +sub consecutive_sequence_using_classes( @ints ) { + my $streaks = Streaks->new; + $streaks->add_element( $_ ) + for uniq @ints; + return $streaks->max_streak_length; +} + +use Test2::V0 qw( -no_srand ); +use Data::Dump qw( pp ); + +my $sub_name = "consecutive_sequence"; +my @tests = ( + [ 'Example 1:', [ 10, 4, 20, 1, 3, 2 ], 4 ], + [ 'Example 2:', [ 0, 6, 1, 8, 5, 2, 4, 3, 0, 7 ], 9 ], + [ 'Example 3:', [ 10, 30, 20 ], -1 ], +); + +sub run_test( $sub, $descr, $input, $output ) { + if ( ! ref $output && $output =~ /^(?:(true)|false)$/i ) { + my $expected_true = $1; + $descr .= + " $sub( " . join( ", ", map pp( $_ ), $input->@* ) . " )" + . " is $output" + if substr( $descr, -1, 1 ) eq ":"; + no strict 'refs'; + $expected_true + ? ok $sub->( $input ), $descr + : ok ! $sub->( $input ), $descr; + } + else { + $descr .= " " . pp( $input ) . " => $output" + if substr( $descr, -1, 1 ) eq ":"; + no strict 'refs'; + my @input = ref $input ? $input->@* : ( $input ); + is $sub->( @input ), $output, $descr; + } +} + +# This runs the tests not only for the sub named "$sub_name", +# but also for all variants with any suffix ("$subname<suffix>"). +for my $sub ( sort grep /^${sub_name}/, keys %:: ) { + note "\n", "Testing $sub:\n", "\n"; + run_test( $sub, $_->@* ) + for @tests; +} + +done_testing;
\ No newline at end of file diff --git a/challenge-294/matthias-muth/perl/ch-2.pl b/challenge-294/matthias-muth/perl/ch-2.pl new file mode 100755 index 0000000000..b0ce44aafd --- /dev/null +++ b/challenge-294/matthias-muth/perl/ch-2.pl @@ -0,0 +1,82 @@ +#!/usr/bin/env perl +# +# The Weekly Challenge - Perl & Raku +# (https://theweeklychallenge.org) +# +# Challenge 294 Task 2: Next Permutation +# +# Perl solution by Matthias Muth. +# + +use v5.36; +use Verbose; +$verbose = 1; + +sub next_permutation( @ints ) { + vsay "ints: @ints"; + return @ints + if @ints <= 1; + + # Starting from the end, find the first number + # that is lower than the one following it. + my $index = $#ints; + while( $index > 0 && $ints[ --$index ] gt $ints[ $index + 1 ] ) { + # Everything is in the loop condition. + } + + # No lower number found? + # Then we are at the end of the permutations. + if ( $index == 0 ) { + vsay "index is 0"; + return reverse @ints; + } + my $value = $ints[$index]; + vsay "value to substitute: $value (at index $index)"; + + # Find the next highest value within the right part, + # for using it to replace the current value. + # (Remember that maybe not all values in the right part are higher!) + # It has to be higher than the one to substitute, but the + # lowest possible one. + my ( $index_2, $replacement ) = ( $index + 1, $ints[ $index + 1 ] ); + for ( $index_2 + 1 .. $#ints ) { + ( $index_2, $replacement ) = ( $_, $ints[$_] ) + if $value lt $ints[$_] lt $replacement; + } + vsay "substitute value: $replacement (at index $index_2)"; + + # Swap the two numbers. + @ints[ $index, $index_2 ] = @ints[ $index_2, $index ]; + + # We know that the right side is sorted, highest first. + # to have it sorted lowest first, we just need to reverse it. + @ints[ $index + 1 .. $#ints ] = + reverse @ints[ $index + 1 .. $#ints ]; + + vsay "result: @ints"; + return @ints; +} + +use Test2::V0 qw( -no_srand ); +use Data::Dump qw( pp ); + +is [ next_permutation( 1, 2, 3 ) ], [ 1, 3, 2 ], + 'Example 1: next_permutation( 1, 2, 3 ) == (1, 3, 2)'; +is [ next_permutation( 2, 1, 3 ) ], [ 2, 3, 1 ], + 'Example 2: next_permutation( 2, 1, 3 ) == (2, 3, 1)'; +is [ next_permutation( 3, 1, 2 ) ], [ 3, 2, 1 ], + 'Example 3: next_permutation( 3, 1, 2 ) == (3, 2, 1)'; +is [ next_permutation( 3, 2, 1 ) ], [ 1, 2, 3 ], + 'Extra 1: next_permutation( 3, 2, 1 ) == (1, 2, 3)'; +is [ next_permutation( qw( 1 4 5 3 2 ) ) ], [ qw( 1 5 2 3 4 ) ], + 'Extra 2: next_permutation( 1, 4, 5, 3, 2 ) == ( 1, 5, 2, 3, 4 )'; +is [ next_permutation( qw( 1 4 3 7 9 8 6 5 2 ) ) ], [ qw( 1 4 3 8 2 5 6 7 9 ) ], + 'Extra 3: next_permutation( 1 4 3 7 9 8 6 5 2 ) == ( 1 4 3 8 2 5 6 7 9 )'; +is [ next_permutation( qw( 1 4 3 7 9 10 8 6 5 2 ) ) ], [ qw( 1 4 3 7 9 2 10 5 6 8 ) ], + 'Extra 4: next_permutation( 1 4 3 7 9 10 8 6 5 2 ) == ( 1 4 3 7 9 2 10 5 6 8 )'; +is [ next_permutation( qw( 41 40 4 31 30 3 21 20 2 11 10 1 ) ) ], [ qw( 1 10 11 2 20 21 3 30 31 4 40 41 ) ], + 'Extra 4: next_permutation( 40 4 30 3 20 2 10 1 ) == ( 1 10 2 20 3 30 4 40 )'; +is [ next_permutation( 'a'..'z' ) ], [ 'a'..'x', 'z', 'y' ], + "Extra 5: next_permutation( 'a'..'z' ) == ( 'a'..'x', 'z', 'y' )"; + +done_testing; |