« Perl Weekly Challenge 213. Perl Weekly Challenge 215. »

Perl Weekly Challenge 214.

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

Task 1: Rank Score

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:

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

The full code is similar:

# Perl weekly challenge 214
# Task 1:  Rank Score
#
# See https://wlmb.github.io/2023/04/24/PWC214/#task-1-rank-score
use v5.36;
die <<~"FIN" unless @ARGV;
    Usage: $0 S1 [S2..]
    to rank the scores S1 S2...
    FIN
my @scores=@ARGV;
my @ranks=(qw(Gold Silver Bronce), 4..@scores); # G S B 4 5 6...
my $counter;
my %score_to_rank;
map {my $current=$ranks[$counter++]; $score_to_rank{$_}//=$current}
    sort {$b<=>$a} @scores;
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:

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

Task 2: Collect Points

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[0] eq $_; $c[1]++;}
push @n, [@c];say "@ARGV -> ", [sort {$b <=> $a} map {p($_, \@n)} 0..@n-1]->[0]; sub p($w, $r){
my @r=@$r; my $p = $r[$w][1]**2; $r[$w-1]=[$r[$w-1][0],$r[$w-1][1]+$r[$w+1][1]], splice @r, $w+1,1
if 0<$w<@r-1 && $r[$w-1][0] eq $r[$w+1][0]; 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[0] eq $_; $c[1]++;}
push @n, [@c];say "@ARGV -> ", [sort {$b <=> $a} map {p($_, \@n)} 0..@n-1]->[0]; sub p($w, $r){
my @r=@$r; my $p = $r[$w][1]**2; $r[$w-1]=[$r[$w-1][0],$r[$w-1][1]+$r[$w+1][1]], splice @r, $w+1,1
if 0<$w<@r-1 && $r[$w-1][0] eq $r[$w+1][0]; 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[0] eq $_; $c[1]++;}
push @n, [@c];say "@ARGV -> ", [sort {$b <=> $a} map {p($_, \@n)} 0..@n-1]->[0]; sub p($w, $r){
my @r=@$r; my $p = $r[$w][1]**2; $r[$w-1]=[$r[$w-1][0],$r[$w-1][1]+$r[$w+1][1]], splice @r, $w+1,1
if 0<$w<@r-1 && $r[$w-1][0] eq $r[$w+1][0]; 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[0] eq $_; $c[1]++;}
push @n, [@c];say "@ARGV -> ", [sort {$b <=> $a} map {p($_, \@n)} 0..@n-1]->[0]; sub p($w, $r){
my @r=@$r; my $p = $r[$w][1]**2; $r[$w-1]=[$r[$w-1][0],$r[$w-1][1]+$r[$w+1][1]], splice @r, $w+1,1
if 0<$w<@r-1 && $r[$w-1][0] eq $r[$w+1][0]; 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:

# Perl weekly challenge 214
# Task 2:  Collect Points
#
# See https://wlmb.github.io/2023/04/24/PWC214/#task-2-collect-points
use v5.36;
die <<~"FIN" unless @ARGV;
    Usage: $0 N1 [N2...]
    to collect all points from the list N1 N2...
    FIN
# Build list of nodes, one for each group
my @list=@ARGV;
my $first=shift @list;
my @current=($first, 1);  # nodes are of the form [value, count]
my @nodes;
for(@list){
    push(@nodes, [@current]), @current=($_, 0) unless $current[0] eq $_; # New node if value changes
    $current[1]++;
}
push @nodes, [@current]; # array of pairs [value, count]
# remove all groups with different starting group and choose largest score
my @points = sort {$b <=> $a} map {remove($_, \@nodes)} 0..@nodes-1;
my $points=$points[0]; # largest score
say "@ARGV -> $points";
24
# Get max points after removing all $remaining nodes starting from $which
sub remove($which, $remaining){
    my @copy=@$remaining;
    my $points = $copy[$which][1]**2;
    # join neighbor groups if possible
    $copy[$which-1]=[$copy[$which-1][0],$copy[$which-1][1]+$copy[$which+1][1]],
	splice @copy, $which+1,1
        if 0<$which<@copy-1 && $copy[$which-1][0] eq $copy[$which+1][0];
    splice @copy, $which, 1;
    my @points= sort {$b <=> $a} map {remove($_, \@copy)} 0..@copy-1;
    $points += $points[0] if @points;
    return $points;
}
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:

4 3 3 3 4 5 4 2 -> 23
2 2 2 2 1 -> 20
-> 1
2 2 1 1 2 2 2 -> 40

Written on April 24, 2023