Perl Weekly Challenge 209.
My solutions (task 1 and task 2 ) to the The Weekly Challenge - 209.
Task 1: Special Bit Characters
Submitted by: Mohammad S Anwar
You are given an array of binary bits that ends with 0.
Valid sequences in the bit string are:
[0] -decodes-to-> "a"
[1, 0] -> "b"
[1, 1] -> "c"
Write a script to print 1 if the last character is an “a” otherwise print 0.
Example 1
Input: @bits = (1, 0, 0)
Output: 1
The given array bits can be decoded as 2-bits character (10) followed by 1-bit
character (0).
Example 2
Input: @bits = (1, 1, 1, 0)
Output: 0
Possible decode can be 2-bits character (11) followed by 2-bits character (10) i.e.
the last character is not 1-bit character.
I guess an anchored regular expression might do the job:
perl -E 'say " $_ ->", /^(1(1|0)|0)*0$/?1:0 for(@ARGV)' 100 1110
Results:
100 ->1
1110 ->0
With slightly more work I can also decode the string:
perl -E '
@p{qw(0 10 11)}=qw(a b c);say " $_ -> ", (map {$x=$p{$_}} grep {length $_} split /(1.|0)/), " -> ",
$x eq "a"?1:0 for(@ARGV)' 100 1110
Results:
100 -> ba -> 1
1110 -> cb -> 0
Here I first build a hash of patterns to translate bit sequences to
characters. Then, I split the input on the expected sequences 1.
or 0,
capturing the separators (I could have used /(1.)/ above).
I throw away with grep the empty strings produced by split between separators. Then I
convert the patterns to their corresponding characters, print them, and check the last
one, saved in a variable, is an “a”.
The full code adds a couple of checks.
1 # Perl weekly challenge 209
2 # Task 1: Special Bit Characters
3 #
4 # See https://wlmb.github.io/2023/03/20/PWC209/#task-1-special-bit-characters
5 use v5.36;
6 my %patterns;
7 die <<~"EOF" unless @ARGV;
8 Usage: $0 S1 [S2...]
9 to decode the binary sequences S1 S2
10 using the code 0->a, 10->b 11->c
11 EOF
12
13 @patterns{qw(0 10 11)}=qw(a b c);
14 for(@ARGV){
15 my $last;
16 die "Not a binary pattern: $_\n" unless /^(0|1)+/; #Check input
17 say " $_ -> ",
18 (
19 map {$last=$patterns{$_}}
20 grep {length $_}
21 split /(1.|0)/
22 ),
23 " -> ",
24 $last eq "a"?1:0;
25 }
Example:
./ch-1.pl 100 1110
Results:
100 -> ba -> 1
1110 -> cb -> 0
Task 2: Merge Account
Submitted by: Mohammad S Anwar
You are given an array of accounts i.e. name with list of email addresses.
Write a script to merge the accounts where possible. The accounts can only
be merged if they have at least one email address in common.
Example 1:
Input: @accounts = [ ["A", "a1@a.com", "a2@a.com"],
["B", "b1@b.com"],
["A", "a3@a.com", "a1@a.com"] ]
]
Output: [ ["A", "a1@a.com", "a2@a.com", "a3@a.com"],
["B", "b1@b.com"] ]
Example 2:
Input: @accounts = [ ["A", "a1@a.com", "a2@a.com"],
["B", "b1@b.com"],
["A", "a3@a.com"],
["B" "b2@b.com", "b1@b.com"] ]
Output: [ ["A", "a1@a.com", "a2@a.com"],
["A", "a3@a.com"],
["B", "b1@b.com", "b2@b.com"] ]
It is not clear what to do if two accounts share an email but do share name. I will merge anyway. I will assume the array of accounts is given in an input file, one space separated row per account in the format
name address1 address2...
I made several attempts to solve this task, and all worked well with the given examples, but I found other examples where they failed. A solution that finally seems to work is to map each address to the merged line number and to map each line number to its corresponding addresses as the input is read line by line. If any address has already been assigned a line number, all its addresses are added to the current line and the previous line is deleted. At the end print the resulting lines. The result fits a two and a half liner.
perl -MList::Util=uniq -nE 'chomp; ($n[$.],@a)=split " "; @m=grep {defined $_} map {$l{$_}} @a;
push @a, map {@{$a{$_}}} @m; @a=uniq @a; delete $a{$_} for @m;@l{@a}=($.)x@a; $a{$.}=[@a];
END {say "$n[$_] @{$a{$_}}" for keys %a;}' <<EOF
A a1@a.com a2@a.com
B b1@b.com
A a3@a.com a1@a.com
EOF
Results:
A a3@a.com a1@a.com a2@a.com
B b1@b.com
Other example:
perl -MList::Util=uniq -nE 'chomp; ($n[$.],@a)=split " "; @m=grep {defined $_} map {$l{$_}} @a;
push @a, map {@{$a{$_}}} @m; @a=uniq @a; delete $a{$_} for @m;@l{@a}=($.)x@a; $a{$.}=[@a];
END {say "$n[$_] @{$a{$_}}" for keys %a;}' <<EOF
A a1@a.com a2@a.com
B b1@b.com
A a3@a.com a1@a.com
EOF
Results:
A a3@a.com a1@a.com a2@a.com
B b1@b.com
Results:
A a1@a.com a3@a.com a2@a.com
B b1@b.com
Yet another example:
perl -MList::Util=uniq -nE 'chomp; ($n[$.],@a)=split " "; @m=grep {defined $_} map {$l{$_}} @a;
push @a, map {@{$a{$_}}} @m; @a=uniq @a; delete $a{$_} for @m;@l{@a}=($.)x@a; $a{$.}=[@a];
END {say "$n[$_] @{$a{$_}}" for keys %a;}' <<EOF
A a1@a.com a2@a.com
B b1@b.com
A a3@a.com
B b2@b.com b1@b.com
EOF
Results:
A a1@a.com a2@a.com
A a3@a.com
B b2@b.com b1@b.com
Last example:
perl -MList::Util=uniq -nE 'chomp; ($n[$.],@a)=split " "; @m=grep {defined $_} map {$l{$_}} @a;
push @a, map {@{$a{$_}}} @m; @a=uniq @a; delete $a{$_} for @m;@l{@a}=($.)x@a; $a{$.}=[@a];
END {say "$n[$_] @{$a{$_}}" for keys %a;}' <<EOF
A a@a.com
B b@b.com
C c@c.com
D b@b.com a@a.com c@c.com
EOF
Results:
D b@b.com a@a.com c@c.com
The full code is similar:
1 # Perl weekly challenge 209
2 # Task 2: Merge Account
3 #
4 # See https://wlmb.github.io/2023/03/20/PWC209/#task-2-merge-account
5 use v5.36;
6 use English;
7 use List::Util qw(uniq);
8 my %line_of;
9 my %addresses_of;
10 my @names;
11 while(<>){
12 chomp;
13 # Assume input is of the form: name address1 address2...
14 my ($name, @addresses)=split ' ';
15 next unless $name; # skip empty lines
16 $names[$INPUT_LINE_NUMBER]=$name;
17 my @merged=grep {defined $_} map {$line_of{$_}} @addresses; # lines to merge with current
18 push @addresses, map {@{$addresses_of{$_}}} @merged; # add their addresses
19 @addresses=uniq @addresses; # avoid repetitions
20 delete $addresses_of{$_} for @merged; # delete merged lines
21 @line_of{@addresses}=($INPUT_LINE_NUMBER) x @addresses; # map addresses to line
22 $addresses_of{$INPUT_LINE_NUMBER}=[@addresses]; # map line to addresses
23 }
24 # Output. Sort by account name and line number, and sort addresses
25 say "$names[$_] ($_): ", join " ",
26 sort {$a cmp $b} @{$addresses_of{$_}}
27 for sort {$names[$a] cmp $names[$b] || $a <=>$b} keys %addresses_of;
Example:
./ch-2.pl <<EOF
A a1@a.com a2@a.com
B b1@b.com
A a3@a.com a1@a.com
EOF
Results:
A (3): a1@a.com a2@a.com a3@a.com
B (2): b1@b.com
Another example:
./ch-2.pl <<EOF
A a1@a.com a2@a.com
B b1@b.com
A a3@a.com
B b2@b.com b1@b.com
EOF
Results:
A (1): a1@a.com a2@a.com
A (3): a3@a.com
B (4): b1@b.com b2@b.com
I added line numbers to the output, to distinguish different accounts with the same name.
A more complicated example:
./ch-2.pl <<EOF
A a@a.com
B b@b.com
C c@c.com
D b@b.com c@c.com a@a.com
EOF
Results:
D (4): a@a.com b@b.com c@c.com
Last example:
./ch-2.pl <<EOF
A a@a.com
B b@b.com c@c.com
C a@a.com c@c.com
EOF
Results:
C (3): a@a.com b@b.com c@c.com
Additional tests, suggested by E. Choroba
Taken from his github page: Solve 209…
perl -MList::Util=uniq -nE 'chomp; ($n[$.],@a)=split " "; @m=grep {defined $_} map {$l{$_}} @a;
push @a, map {@{$a{$_}}} @m; @a=uniq @a; delete $a{$_} for @m;@l{@a}=($.)x@a; $a{$.}=[@a];
END {say "$n[$_] @{$a{$_}}" for keys %a;}' <<EOF
A a1@a.com a2@a.com
A b1@b.com a1@a.com
A a3@a.com b1@b.com
EOF
./ch-2.pl <<EOF
A a1@a.com a2@a.com
A b1@b.com a1@a.com
A a3@a.com b1@b.com
EOF
perl -MList::Util=uniq -nE 'chomp; ($n[$.],@a)=split " "; @m=grep {defined $_} map {$l{$_}} @a;
push @a, map {@{$a{$_}}} @m; @a=uniq @a; delete $a{$_} for @m;@l{@a}=($.)x@a; $a{$.}=[@a];
END {say "$n[$_] @{$a{$_}}" for keys %a;}' <<EOF
A a1@a.com a2@a.com
A b1@b.com a1@a.com
A a3@a.com b1@b.com
A a3@a.com b2@b.com
EOF
./ch-2.pl <<EOF
A a1@a.com a2@a.com
A b1@b.com a1@a.com
A a3@a.com b1@b.com
A a3@a.com b2@b.com
EOF
Both the two liner and the full code passed!