Merge pull request #11148 from MatthiasMuth/muthm-294

Challenge 294 Task 1 and 2 solutions in Perl by Matthias Muth

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;