Merge pull request #7979 from boblied/w214

W214

5 files changed, 223 insertions, 3 deletions

diff --git a/challenge-213/bob-lied/blog.txt b/challenge-213/bob-lied/blog.txt
new file mode 100644
index 0000000000..3288347232
--- /dev/null
+++ b/challenge-213/bob-lied/blog.txt
@@ -0,0 +1 @@
+https://dev.to/boblied/pwc-213-a-fun-sort-and-a-run-short-41d5
diff --git a/challenge-214/bob-lied/README b/challenge-214/bob-lied/README
index ca4d14b3b4..4f6ce65387 100644
--- a/challenge-214/bob-lied/README
+++ b/challenge-214/bob-lied/README
@@ -1,4 +1,4 @@
-Solutions to weekly challenge 213 by Bob Lied
+Solutions to weekly challenge 214 by Bob Lied
 
-https://perlweeklychallenge.org/blog/perl-weekly-challenge-213/
-https://github.com/boblied/perlweeklychallenge-club/tree/master/challenge-213/bob-lied
+https://perlweeklychallenge.org/blog/perl-weekly-challenge-214/
+https://github.com/boblied/perlweeklychallenge-club/tree/master/challenge-214/bob-lied
diff --git a/challenge-214/bob-lied/blog.txt b/challenge-214/bob-lied/blog.txt
new file mode 100644
index 0000000000..17c030c202
--- /dev/null
+++ b/challenge-214/bob-lied/blog.txt
@@ -0,0 +1 @@
+https://dev.to/boblied/pwc-214-1-rank-score-2-collect-points-3-4-profit-4adh
diff --git a/challenge-214/bob-lied/perl/ch-1.pl b/challenge-214/bob-lied/perl/ch-1.pl
new file mode 100644
index 0000000000..ef028763ac
--- /dev/null
+++ b/challenge-214/bob-lied/perl/ch-1.pl
@@ -0,0 +1,84 @@
+#!/usr/bin/env perl
+# vim:set ts=4 sw=4 sts=4 et ai wm=0 nu:
+#=============================================================================
+# ch-1.pl Perl Weekly Challenge 214 Task 1 Rank Score 
+#=============================================================================
+# Copyright (c) 2023, Bob Lied
+#=============================================================================
+# You are given a list of scores (>=1).
+# Write a script to rank each score in descending order. First three will get
+# medals i.e. G (Gold), S (Silver) and B (Bronze). Rest will just get the
+# ranking number.
+# Using the standard model of giving equal scores equal rank,
+# then advancing that number of ranks.
+# Example 1 Input: @scores = (1,2,4,3,5) Output: (5,4,S,B,G)
+# Example 2 Input: @scores = (8,5,6,7,4) Output: (G,4,B,S,5)
+# Example 3 Input: @list   = (3,5,4,2)   Output: (B,G,S,4)
+# Example 4 Input: @scores = (2,5,2,1,7,5,1) Output: (4,S,4,6,G,S,6)
+#=============================================================================
+
+use v5.36;
+
+use FindBin qw($Bin);
+use lib "$FindBin::Bin";
+
+use Getopt::Long;
+my $Verbose = 0;
+my $DoTest  = 0;
+
+GetOptions("test" => \$DoTest, "verbose" => \$Verbose);
+exit(!runTest()) if $DoTest;
+
+say "(", join(",", rankScore(@ARGV)->@*), ")";
+
+sub rankScore(@scoreList)
+{
+    return [] unless @scoreList;
+
+    # Record position of each score if it was sorted descending.
+    # Example:               [0] [1] [2] [3] [4]
+    #          @scoreList = ( 1   2   4   3   5 )
+    #      -->  @position = ( 4   3   1   2   0 )
+    my @position = sort { $scoreList[$b] <=> $scoreList[$a] } 0 .. $#scoreList;
+
+    # The colors or places that will be assigned.
+    my @rank = ( qw(G S B), 4 .. (@scoreList) );
+    my $r = 0;  # Index into @rank
+
+    # In a copy of the scores, replace each score by its medal or rank.
+    my @ranked = @scoreList;
+
+    # The first position is always gold.
+    my $place = $position[0];
+    $ranked[ $place ] = $rank[$r];
+
+    # Move through consecutive pairs of positions to see when to switch
+    # rank colors.
+    for my $index ( 1 .. $#position )
+    {
+        my $next = $position[$index];
+        if ( $scoreList[$next] < $scoreList[$place] )
+        {
+            # Lower score, so advance rank
+            $r = $index;
+        }
+        $ranked[$next] = $rank[$r];
+        $place = $next;
+    }
+    return \@ranked;
+}
+
+sub runTest
+{
+    use Test2::V0;
+
+    is( rankScore(1,2,4,3,5),     [ qw(5 4 S B G) ],     "Example 1");
+    is( rankScore(8,5,6,7,4),     [ qw(G 4 B S 5) ],     "Example 2");
+    is( rankScore(3,5,4,2),       [ qw(B G S 4) ],       "Example 3");
+    is( rankScore(2,5,2,1,7,5,1), [ qw(4 S 4 6 G S 6) ], "Example 4");
+    is( rankScore(2,7,7,1,7,5,1), [ qw(5 G G 6 G 4 6) ], "Gold only");
+    is( rankScore(3,5    ),       [ qw(S G    ) ],       "Two players");
+
+    done_testing;
+}
+
diff --git a/challenge-214/bob-lied/perl/ch-2.pl b/challenge-214/bob-lied/perl/ch-2.pl
new file mode 100644
index 0000000000..c1260bb297
--- /dev/null
+++ b/challenge-214/bob-lied/perl/ch-2.pl
@@ -0,0 +1,134 @@
+#!/usr/bin/env perl
+# vim:set ts=4 sw=4 sts=4 et ai wm=0 nu:
+#=============================================================================
+# ch-2.pl Perl Weekly Challenge 214 Task 2 Collect Points 
+#=============================================================================
+# Copyright (c) 2023, Bob Lied
+#=============================================================================
+# You are given a list of numbers.
+# You will perform a series of removal operations. For each operation, you
+# remove from the list N (one or more) equal and consecutive numbers, and add
+# to your score N × N.  Determine the maximum possible score.
+# Example 1: Input: @numbers = (2,4,3,3,3,4,5,4,2) Output: 23
+#   We see three 3's next to each other so let us remove that first and
+#   collect 3 x 3 points.  So now the list is (2,4,4,5,4,2).
+#   Let us now remove 5 so that all 4's can be next to each other and
+#   collect 1 x 1 point.  So now the list is (2,4,4,4,2).
+#   Time to remove three 4's and collect 3 x 3 points.  Now the list is (2,2).
+#   Finally remove both 2's and collect 2 x 2 points.
+#   So the total points collected is 9 + 1 + 9 + 4 => 23.
+# Example 2: Input: @numbers = (1,2,2,2,2,1) Output: 20
+#   Remove four 2's first and collect 4 x 4 points.  Now the list is (1,1).
+#   Finally remove the two 1's and collect 2 x 2 points.
+#   So the total points collected is 16 + 4 => 20.
+# Example 3: Input: @numbers = (1) Output: 1
+# Example 4: Input: @numbers = (2,2,2,1,1,2,2,2) Output: 40
+#   Remove two 1's = 2 x 2 points.  Now the list is (2,2,2,2,2,2).
+#   Then reomove six 2's = 6 x 6 points.
+#=============================================================================
+
+use v5.36;
+
+use Getopt::Long;
+my $Verbose = 0;
+my $DoTest  = 0;
+
+GetOptions("test" => \$DoTest, "verbose" => \$Verbose);
+exit(!runTest()) if $DoTest;
+
+say collectPoints(@ARGV);
+
+# Return pairs of [offset, length] for each span of equal values in list
+sub findSpan($list)
+{
+    my $listLength = @$list;
+    if    ( $listLength == 0 ) { return [] }
+    elsif ( $listLength == 1 ) { return [ [0, 1] ] }
+
+    my @span;
+
+    my $beg = my $end = 0;
+    my $len = 1;
+    while ( $end < $listLength )
+    {
+        while ( $end < $list->$#* && $list->[$end+1] == $list->[$end] )
+        {
+            $end++;
+            $len++;
+        }
+        push @span, [ $beg, $len ];
+        $beg = ++$end;
+        $len = 1;
+    }
+    return \@span;
+}
+
+# Recursive function to do depth-first searches for best score
+sub _collect($list, $scoreSoFar, $indent)
+{
+    say "$indent _collect[ $list->@* ], $scoreSoFar" if $Verbose;
+
+    my $numLen = @$list;
+    if    ( $numLen == 0 ) { return $scoreSoFar; }
+    elsif ( $numLen == 1 ) { return $scoreSoFar + 1; }
+    elsif ( $numLen == 2 )
+    {
+        return $scoreSoFar + ($list->[0] == $list->[1] ? 4 : 2 );
+    }
+
+    my $spanList = findSpan($list);
+
+    my $bestScore = 0;
+    for my $span ( @$spanList )
+    {
+        my ($beg, $length) = $span->@*;
+        my $score = $length * $length;
+
+        # Remove the span from the list and recurse
+        my @copy = $list->@*;
+        if ( $Verbose )
+        {
+            my @rmv = $list->@[$beg .. $beg+$length-1];
+            splice(@copy, $beg, $length, ('*')x$length);
+            say "$indent RMV [@rmv], copy=[@copy] score=$score";
+        }
+
+        splice(@copy, $beg, $length);
+
+        $score = _collect(\@copy, $score, "  $indent");
+        if ( $score  > $bestScore )
+        {
+            $bestScore = $score;
+            say "$indent BEST: $bestScore" if $Verbose;
+        }
+    }
+    return $scoreSoFar + $bestScore;
+}
+
+sub collectPoints(@numbers)
+{
+    return _collect(\@numbers, 0, "");
+}
+
+sub runTest
+{
+    use Test2::V0;
+
+    is( findSpan( [9]       ), [ [0,1] ],             "findSpan singleton");
+    is( findSpan( [4,5,6]   ), [ [0,1],[1,1],[2,1] ], "unique");
+    is( findSpan( [4,4,5,6] ), [ [0,2],[2,1],[3,1] ], "leading span");
+    is( findSpan( [4,5,6,6] ), [ [0,1],[1,1],[2,2] ], "trailing span");
+    is( findSpan( [4,5,5,6] ), [ [0,1],[1,2],[3,1] ], "middle span");
+
+    is( collectPoints(2), 1, "Singleton");
+    is( collectPoints(2,3), 2, "Small");
+    is( collectPoints(2,2), 4, "Pair");
+    is( collectPoints(2,2,2), 9, "Triplet");
+    is( collectPoints(2,4,3,3,3,4,5,4,2), 23, "Example 1");
+    is( collectPoints(1,2,2,2,2,1      ), 20, "Example 2");
+    is( collectPoints(1                ),  1, "Example 3");
+    is( collectPoints(2,2,2,1,1,2,2,2  ), 40, "Example 4");
+
+    done_testing;
+}
+