# Perl Weekly Challenge 214.

My solutions (task 1 and task 2 ) to the The Weekly Challenge - 214.

``````Submitted by: Mohammad S Anwar
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)

Score 1 is the 5th rank.
Score 2 is the 4th rank.
Score 4 is the 2nd rank i.e. Silver (S).
Score 3 is the 3rd rank i.e. Bronze (B).
Score 5 is the 1st rank i.e. Gold (G).
Example 2
Input: @scores = (8,5,6,7,4)
Output: (G,4,B,S,5)

Score 8 is the 1st rank i.e. Gold (G).
Score 4 is the 4th rank.
Score 6 is the 3rd rank i.e. Bronze (B).
Score 7 is the 2nd rank i.e. Silver (S).
Score 4 is the 5th rank.
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)
``````

I read the list of scores from `@ARGV`, order them from largest to smallest and assign each score a rank, taken from an array of possible ranks, ordered from first place (Gold) to last (`@ARGV`). I only assign a rank if the score has not been seen before. Finally, I map scores to ranks and print the result. This fits a oneliner.

Examples:

``````perl -E '
@a=@ARGV; @r=(qw(G S B), 4..@ARGV); map {\$c=\$r[\$i++]; \$s{\$_}//=\$c} sort{\$b<=>\$a}@a; say join " ", @a, "->", @s{@a}
' 1 2 4 3 5
perl -E '
@a=@ARGV; @r=(qw(G S B), 4..@ARGV); map {\$c=\$r[\$i++]; \$s{\$_}//=\$c} sort{\$b<=>\$a}@a; say join " ", @a, "->", @s{@a}
' 8 5 6 7 4
perl -E '
@a=@ARGV; @r=(qw(G S B), 4..@ARGV); map {\$c=\$r[\$i++]; \$s{\$_}//=\$c} sort{\$b<=>\$a}@a; say join " ", @a, "->", @s{@a}
' 3 5 4 2
perl -E '
@a=@ARGV; @r=(qw(G S B), 4..@ARGV); map {\$c=\$r[\$i++]; \$s{\$_}//=\$c} sort{\$b<=>\$a}@a; say join " ", @a, "->", @s{@a}
' 2 5 2 1 7 5 1
``````

Results:

``````1 2 4 3 5 -> 5 4 S B G
8 5 6 7 4 -> G 4 B S 5
3 5 4 2 -> B G S 4
2 5 2 1 7 5 1 -> 4 S 4 6 G S 6
``````

The full code is similar:

`````` 1  # Perl weekly challenge 214
2  # Task 1:  Rank Score
3  #
5  use v5.36;
6  die <<~"FIN" unless @ARGV;
7      Usage: \$0 S1 [S2..]
8      to rank the scores S1 S2...
9      FIN
10  my @scores=@ARGV;
11  my @ranks=(qw(Gold Silver Bronce), 4..@scores); # G S B 4 5 6...
12  my \$counter;
13  my %score_to_rank;
14  map {my \$current=\$ranks[\$counter++]; \$score_to_rank{\$_}//=\$current}
15      sort {\$b<=>\$a} @scores;
16  say join " ", @scores, "->", @score_to_rank{@scores}
``````

Example:

``````./ch-1.pl 1 2 4 3 5
./ch-1.pl 8 5 6 7 4
./ch-1.pl 3 5 4 2
./ch-1.pl 2 5 2 1 7 5 1
``````

Results:

``````1 2 4 3 5 -> 5 4 Silver Bronce Gold
8 5 6 7 4 -> Gold 4 Bronce Silver 5
3 5 4 2 -> Bronce Gold Silver 4
2 5 2 1 7 5 1 -> 4 Silver 4 6 Gold Silver 6
``````

``````Submitted by: Mohammad S Anwar
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.
``````

The brute force solution consists of building groups of repeated entries and removing them in all possible orders, joining neighbor groups if possible, using a recursive routine. I tried some heuristic solutions but they didn’t quite work. I first present a compact 4.5 liner solution and then expand it into a more reasonable code.

Example 1:

``````perl -E '@l=@ARGV;@c=(shift @l, 1);for(@l){push(@n, [@c]), @c=(\$_, 0) unless \$c eq \$_; \$c++;}
push @n, [@c];say "@ARGV -> ", [sort {\$b <=> \$a} map {p(\$_, \@n)} 0..@n-1]->; sub p(\$w, \$r){
my @r=@\$r; my \$p = \$r[\$w]**2; \$r[\$w-1]=[\$r[\$w-1],\$r[\$w-1]+\$r[\$w+1]], splice @r, \$w+1,1
if 0<\$w<@r-1 && \$r[\$w-1] eq \$r[\$w+1]; splice @r, \$w, 1; @p= sort {\$b <=> \$a} map {p(\$_, \@r)}
0..@r-1; \$p += shift @p if @p; \$p;}
'  2 4 3 3 3 4 5 4 2
``````

Results:

``````2 4 3 3 3 4 5 4 2 -> 23
``````

Example 2:

``````perl -E '@l=@ARGV;@c=(shift @l, 1);for(@l){push(@n, [@c]), @c=(\$_, 0) unless \$c eq \$_; \$c++;}
push @n, [@c];say "@ARGV -> ", [sort {\$b <=> \$a} map {p(\$_, \@n)} 0..@n-1]->; sub p(\$w, \$r){
my @r=@\$r; my \$p = \$r[\$w]**2; \$r[\$w-1]=[\$r[\$w-1],\$r[\$w-1]+\$r[\$w+1]], splice @r, \$w+1,1
if 0<\$w<@r-1 && \$r[\$w-1] eq \$r[\$w+1]; splice @r, \$w, 1; @p= sort {\$b <=> \$a} map {p(\$_, \@r)}
0..@r-1; \$p += shift @p if @p; \$p;}
'  1 2 2 2 2 1
``````

Results:

``````1 2 2 2 2 1 -> 20
``````

Example 3:

``````perl -E '@l=@ARGV;@c=(shift @l, 1);for(@l){push(@n, [@c]), @c=(\$_, 0) unless \$c eq \$_; \$c++;}
push @n, [@c];say "@ARGV -> ", [sort {\$b <=> \$a} map {p(\$_, \@n)} 0..@n-1]->; sub p(\$w, \$r){
my @r=@\$r; my \$p = \$r[\$w]**2; \$r[\$w-1]=[\$r[\$w-1],\$r[\$w-1]+\$r[\$w+1]], splice @r, \$w+1,1
if 0<\$w<@r-1 && \$r[\$w-1] eq \$r[\$w+1]; splice @r, \$w, 1; @p= sort {\$b <=> \$a} map {p(\$_, \@r)}
0..@r-1; \$p += shift @p if @p; \$p;}
'  1
``````

Results:

``````1 -> 1
``````

Example 4:

``````perl -E '@l=@ARGV;@c=(shift @l, 1);for(@l){push(@n, [@c]), @c=(\$_, 0) unless \$c eq \$_; \$c++;}
push @n, [@c];say "@ARGV -> ", [sort {\$b <=> \$a} map {p(\$_, \@n)} 0..@n-1]->; sub p(\$w, \$r){
my @r=@\$r; my \$p = \$r[\$w]**2; \$r[\$w-1]=[\$r[\$w-1],\$r[\$w-1]+\$r[\$w+1]], splice @r, \$w+1,1
if 0<\$w<@r-1 && \$r[\$w-1] eq \$r[\$w+1]; splice @r, \$w, 1; @p= sort {\$b <=> \$a} map {p(\$_, \@r)}
0..@r-1; \$p += shift @p if @p; \$p;}
'  2 2 2 1 1 2 2 2
``````

Results:

``````2 2 2 1 1 2 2 2 -> 40
``````

The full code, with some comments, is:

`````` 1  # Perl weekly challenge 214
2  # Task 2:  Collect Points
3  #
5  use v5.36;
6  die <<~"FIN" unless @ARGV;
7      Usage: \$0 N1 [N2...]
8      to collect all points from the list N1 N2...
9      FIN
10  # Build list of nodes, one for each group
11  my @list=@ARGV;
12  my \$first=shift @list;
13  my @current=(\$first, 1);  # nodes are of the form [value, count]
14  my @nodes;
15  for(@list){
16      push(@nodes, [@current]), @current=(\$_, 0) unless \$current eq \$_; # New node if value changes
17      \$current++;
18  }
19  push @nodes, [@current]; # array of pairs [value, count]
20  # remove all groups with different starting group and choose largest score
21  my @points = sort {\$b <=> \$a} map {remove(\$_, \@nodes)} 0..@nodes-1;
22  my \$points=\$points; # largest score
23  say "@ARGV -> \$points";
24
25  # Get max points after removing all \$remaining nodes starting from \$which
26  sub remove(\$which, \$remaining){
27      my @copy=@\$remaining;
28      my \$points = \$copy[\$which]**2;
29      # join neighbor groups if possible
30      \$copy[\$which-1]=[\$copy[\$which-1],\$copy[\$which-1]+\$copy[\$which+1]],
31  	splice @copy, \$which+1,1
32          if 0<\$which<@copy-1 && \$copy[\$which-1] eq \$copy[\$which+1];
33      splice @copy, \$which, 1;
34      my @points= sort {\$b <=> \$a} map {remove(\$_, \@copy)} 0..@copy-1;
35      \$points += \$points if @points;
36      return \$points;
37  }
38
``````

Examples:

``````./ch-2.pl 2 4 3 3 3 4 5 4 2
./ch-2.pl 1 2 2 2 2 1
./ch-2.pl 1
./ch-2.pl 2 2 2 1 1 2 2 2
``````

Results:

``````2 4 3 3 3 4 5 4 2 -> 23
1 2 2 2 2 1 -> 20
1 -> 1
2 2 2 1 1 2 2 2 -> 40
``````
Written on April 24, 2023