« Perl Weekly Challenge 244. Advent of code 2023 »

Perl Weekly Challenge 245.

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

Task 1: Sort Language

Submitted by: Mohammad S Anwar
You are given two array of languages and its popularity.

Write a script to sort the language based on popularity.

Example 1
Input: @lang = ('perl', 'c', 'python')
       @popularity = (2, 1, 3)
Output: ('c', 'perl', 'python')
Example 2
Input: @lang = ('c++', 'haskell', 'java')
       @popularity = (1, 3, 2)
Output: ('c++', 'java', 'haskell')

The problem may be solved by simply using sort on the indices of both arrays. I assume both arrays are input as space separated strings in @ARGV. This yields a 2-liner. Example 1:

perl -E '
$l[$_]=[split " ", $ARGV[$_]] for 0,1; @s=map {$l[0][$_]} sort {$l[1][$a]<=>$l[1][$b]}
0..@{$l[0]}-1; say "languages: @{$l[0]}\npopularity: @{$l[1]}\nsorted: @s";
' "perl c python" "2 1 3"

Results:

languages: perl c python
popularity: 2 1 3
sorted: c perl python

Example 2:

perl -E '
$l[$_]=[split " ", $ARGV[$_]] for 0,1; @s=map {$l[0][$_]} sort {$l[1][$a]<=>$l[1][$b]} 0..@{$l[0]}-1;
say "languages: @{$l[0]}\npopularity: @{$l[1]}\nsorted: @s";
' "c++ haskell java" "1 3 2"

Results:

languages: c++ haskell java
popularity: 1 3 2
sorted: c++ java haskell

I can also do a Schwartzian transform for sorting:

perl -MList::MoreUtils=pairwise -E '
$l[$_]=[split " ", $ARGV[$_]]for 0,1;say "languages: @{$l[0]}\npopularity: @{$l[1]}\nsorted: ",
join " ", map {$_->[0]} sort {$a->[1] <=> $b->[1]} pairwise {[$a,$b]} @{$l[0]}, @{$l[1]};
' "perl c python" "2 1 3"

Results:

languages: perl c python
popularity: 2 1 3
sorted: c perl python

However, in this simple case the resulting code is not simpler.

The full code corresponds to the first solution

# Perl weekly challenge 245
# Task 1:  Sort Language
#
# See https://wlmb.github.io/2023/11/27/PWC245/#task-1-sort-language
use v5.36;
die <<~"FIN" unless @ARGV && @ARGV%2==0;
    Usage: $0 L1 P1 [L2 P2...]
    to sort the space separated list of languages Ln
    according to their popularity Pn
    FIN
while(@ARGV){
    my @language=split " ", shift;
    my @popularity=split " ", shift;
    warn("Number of elements should coincide: languages: @language vs. popularities @popularity\n"),
	next unless @language==@popularity;
    my @sorted=map {$language[$_]} sort {$popularity[$a]<=>$popularity[$b]} 0..@language-1;
    say "languages: @language\npopularities: @popularity\nsorted: @sorted\n";
}

Example:

./ch-1.pl "perl c python" "2 1 3" "c++ haskell java" "1 3 2"

Results:

languages: perl c python
popularities: 2 1 3
sorted: c perl python

languages: c++ haskell java
popularities: 1 3 2
sorted: c++ java haskell

Task 2: Largest of Three

Submitted by: Mohammad S Anwar
You are given an array of integers >= 0.

Write a script to return the largest number formed by concatenating some
of the given integers in any order which is also multiple of 3.
Return -1 if none found.


Example 1
Input: @ints = (8, 1, 9)
Output: 981

981 % 3 == 0
Example 2
Input: @ints = (8, 6, 7, 1, 0)
Output: 8760
Example 3
Input: @ints = (1)
Output: -1

As 10 is congruent to 1 modulo 3, a number is divisible by three if the sum of its decimal digits is divisible by three. Thus, rearrangement of the digits does not affect divisibility by three. Call N=N_K … N₂ N₁ N₀ the concatenation of all sorted inputs. Choosing N₀ N₁<=N₁ N0, N₁ N₂<=N₂ N1… then N would be the largest number that can be obtained by concatenating the inputs (I am grateful to choroba for pointing out a mistake in a pervious solution). Set r=N%3. If r==0 we are done. If r==1, then we can remove from N the smallest N_k such that N_k%3==1, or the two smallest N_l and N_m such that N_l%3==N_m%3==2, as 2+2 is congruent to 1 modulo 3. Similarly, if r==2, then we can remove from N the smallest N_k such that N_k%3==2, or remove the smallest N_l and N_m such that N_l%3=N_m%3==1. If necessary, we can choose between removing the single number N_k or the two numbers N_l and N_m by comparing N_k and the concatenation of N_l and N_m (assuming l>m) and choosing the smallest. The resulting number would then be the largest number that can be formed by concatenating integers from a list and that is divisible by three. The code seems too complex for a few-liner, so I first jump to the full code, and then the compact solution:

# Perl weekly challenge 245
# Task 2:  Largest of Three
#
# See https://wlmb.github.io/2023/11/27/PWC245/#task-2-largest-of-three
use v5.36;
use List::Util qw(all);
die <<~"FIN" unless @ARGV;
    Usage: $0 N1 [N2...]
    to find the largest concatenation of numbers N_i which yield a
    multiple of 3.
    FIN
die "Only non-negative numbers allowed" unless all {/\d+/} @ARGV;
my $index=0;
my $total;
my @one;
my @two;
my @sorted= sort{"$a$b"<=>"$b$a"}@ARGV; # increasing order
for(@sorted){
    my $residue=$_%3;
    push @one, $index  if $residue==1;
    push @two, $index  if $residue==2;
    $total+=$residue;
    ++$index;
}
$total%=3;
my @candidates; # if neccesary to remove numbers
if($total==1){
    # remove the smallest number that leaves a residue one
    push @candidates, [$one[0]] if(@one);
    # remove the two smallest numbers that leaves a residue two
    push @candidates, [@two[1,0]] if(@two>=2);
}
if($total==2){
    # remove the two smallest numbers that leaves a residue one
    push @candidates, [@one[1,0]] if(@one>=2);
    # or the smallest numbers that leaves a residue two
    push @candidates, [$two[0]] if(@two);
}
if(@candidates){ # find smallest candidates
    my @to_remove=map {join "", @sorted[@$_]} @candidates;
    my $index_to_remove=@candidates == 2 && $to_remove[1]<$to_remove[0]?1:0;
    splice @sorted, $_, 1 for @{$candidates[$index_to_remove]}; # remove one or two numbers
}
my $result=join "", reverse @sorted;
$result=-1 if $result eq ""; # removed all
$result=0 if $result==0; # 0000...=0 is divisible;
say "@ARGV -> $result";

Examples:

./ch-2.pl 8 1 9
./ch-2.pl 8 6 7 1 0
./ch-2.pl 1
./ch-2.pl 0 0 0

Results:

1 9 -> 981
6 7 1 0 -> 8760
-> -1
0 0 -> 0
85 0 -> 8850

Examples by E-Choroba:

./ch-2.pl 4 8 911 # 9114
./ch-2.pl 8 85 0  # 8850
./ch-2.pl 8 89 2  # 8982
./ch-2.pl 8 76 0  # 8760
./ch-2.pl 8 94 0  # 9480

Results:

8 911 -> 9114
85 0 -> 8850
89 2 -> 8982
76 0 -> 8760
94 0 -> 9480

After a few simplifications, I could compact the code into a 3.5-liner.

Examples:

perl -E '
$i=0;@s=sort{"$a$b"<=>"$b$a"}@ARGV;for(@s){$t+=($r=$_%3);push @{$r[$r]},$i++;}$t%=3;if($t){
push @c, [$r[$t][0]] if $r[$t];push @c, [@{$r[3-$t]}[1,0]] if $r[3-$t];}if(@c){
@t=map {join "", @s[@$_]} @c;$i=@c==2&&$t[1]<$t[0]?1:0;splice @s, $_, 1 for @{$c[$i]};}
$r=join "", reverse @s;$r=-1 if $r eq "";say "@ARGV -> $r";
' 8 1 9
perl -E '
$i=0;@s=sort{"$a$b"<=>"$b$a"}@ARGV;for(@s){$t+=($r=$_%3);push @{$r[$r]},$i++;}$t%=3;if($t){
push @c, [$r[$t][0]] if $r[$t];push @c, [@{$r[3-$t]}[1,0]] if $r[3-$t];}if(@c){
@t=map {join "", @s[@$_]} @c;$i=@c==2&&$t[1]<$t[0]?1:0;splice @s, $_, 1 for @{$c[$i]};}
$r=join "", reverse @s;$r=-1 if $r eq "";say "@ARGV -> $r";
' 8 6 7 1 0
perl -E '
$i=0;@s=sort{"$a$b"<=>"$b$a"}@ARGV;for(@s){$t+=($r=$_%3);push @{$r[$r]},$i++;}$t%=3;if($t){
push @c, [$r[$t][0]] if $r[$t];push @c, [@{$r[3-$t]}[1,0]] if $r[3-$t];}if(@c){
@t=map {join "", @s[@$_]} @c;$i=@c==2&&$t[1]<$t[0]?1:0;splice @s, $_, 1 for @{$c[$i]};}
$r=join "", reverse @s;$r=-1 if $r eq "";say "@ARGV -> $r";
' 1
perl -E '
$i=0;@s=sort{"$a$b"<=>"$b$a"}@ARGV;for(@s){$t+=($r=$_%3);push @{$r[$r]},$i++;}$t%=3;if($t){
push @c, [$r[$t][0]] if $r[$t];push @c, [@{$r[3-$t]}[1,0]] if $r[3-$t];}if(@c){
@t=map {join "", @s[@$_]} @c;$i=@c==2&&$t[1]<$t[0]?1:0;splice @s, $_, 1 for @{$c[$i]};}
$r=join "", reverse @s;$r=-1 if $r eq "";say "@ARGV -> $r";
' 8 85 0

Additional examples:

perl -E '
$i=0;@s=sort{"$a$b"<=>"$b$a"}@ARGV;for(@s){$t+=($r=$_%3);push @{$r[$r]},$i++;}$t%=3;if($t){
push @c, [$r[$t][0]] if $r[$t];push @c, [@{$r[3-$t]}[1,0]] if $r[3-$t];}if(@c){
@t=map {join "", @s[@$_]} @c;$i=@c==2&&$t[1]<$t[0]?1:0;splice @s, $_, 1 for @{$c[$i]};}
$r=join "", reverse @s;$r=-1 if $r eq "";say "@ARGV -> $r";
' 4 8 911 # 9114
perl -E '
$i=0;@s=sort{"$a$b"<=>"$b$a"}@ARGV;for(@s){$t+=($r=$_%3);push @{$r[$r]},$i++;}$t%=3;if($t){
push @c, [$r[$t][0]] if $r[$t];push @c, [@{$r[3-$t]}[1,0]] if $r[3-$t];}if(@c){
@t=map {join "", @s[@$_]} @c;$i=@c==2&&$t[1]<$t[0]?1:0;splice @s, $_, 1 for @{$c[$i]};}
$r=join "", reverse @s;$r=-1 if $r eq "";say "@ARGV -> $r";
' 8 85 0  # 8850
perl -E '
$i=0;@s=sort{"$a$b"<=>"$b$a"}@ARGV;for(@s){$t+=($r=$_%3);push @{$r[$r]},$i++;}$t%=3;if($t){
push @c, [$r[$t][0]] if $r[$t];push @c, [@{$r[3-$t]}[1,0]] if $r[3-$t];}if(@c){
@t=map {join "", @s[@$_]} @c;$i=@c==2&&$t[1]<$t[0]?1:0;splice @s, $_, 1 for @{$c[$i]};}
$r=join "", reverse @s;$r=-1 if $r eq "";say "@ARGV -> $r";
' 8 89 2  # 8982
perl -E '
$i=0;@s=sort{"$a$b"<=>"$b$a"}@ARGV;for(@s){$t+=($r=$_%3);push @{$r[$r]},$i++;}$t%=3;if($t){
push @c, [$r[$t][0]] if $r[$t];push @c, [@{$r[3-$t]}[1,0]] if $r[3-$t];}if(@c){
@t=map {join "", @s[@$_]} @c;$i=@c==2&&$t[1]<$t[0]?1:0;splice @s, $_, 1 for @{$c[$i]};}
$r=join "", reverse @s;$r=-1 if $r eq "";say "@ARGV -> $r";
' 8 76 0  # 8760
perl -E '
$i=0;@s=sort{"$a$b"<=>"$b$a"}@ARGV;for(@s){$t+=($r=$_%3);push @{$r[$r]},$i++;}$t%=3;if($t){
push @c, [$r[$t][0]] if $r[$t];push @c, [@{$r[3-$t]}[1,0]] if $r[3-$t];}if(@c){
@t=map {join "", @s[@$_]} @c;$i=@c==2&&$t[1]<$t[0]?1:0;splice @s, $_, 1 for @{$c[$i]};}
$r=join "", reverse @s;$r=-1 if $r eq "";say "@ARGV -> $r";
' 8 94 0  # 9480

Results:

8 911 -> 9114
85 0 -> 8850
89 2 -> 8982
76 0 -> 8760
94 0 -> 9480

Written on November 27, 2023