Perl Weekly Challenge 192.
My solutions (task 1 and task 2 ) to the The Weekly Challenge - 192.
Task 1: Binary Flip
Submitted by: Mohammad S Anwar
You are given a positive integer, $n.
Write a script to find the binary flip.
Example 1
Input: $n = 5
Output: 2
First find the binary equivalent of the given integer, 101.
Then flip the binary digits 0 -> 1 and 1 -> 0 and we get 010.
So Binary 010 => Decimal 2.
Example 2
Input: $n = 4
Output: 3
Decimal 4 = Binary 100
Flip 0 -> 1 and 1 -> 0, we get 011.
Binary 011 = Decimal 3
Example 3
Input: $n = 6
Output: 1
Decimal 6 = Binary 110
Flip 0 -> 1 and 1 -> 0, we get 001.
Binary 001 = Decimal 1
Perl has a bit flip operator ~, but it flips all the bits. In my
laptop ~5=18446744073709551610, not quite the expected 2. The examples imply
though that we only flip significant bits, and leave leading 0 bits
alone. Thus, I build a mask with 1’s corresponding to the bits to flip
and 0’s for the bits that should be left alone and apply it through
an bitwise & operator. The code fits a one-liner.
perl -E 'for(@ARGV){$b=sprintf "%b", $_; $m=oct "0b". "1"x length $b; say "$_ -> ", ~$_ & $m; }' 5 4 6
Results:
5 -> 2
4 -> 3
6 -> 1
The full code is essentially identical.
1 # Perl weekly challenge 192
2 # Task 1: Binary Flip
3 #
4 # See https://wlmb.github.io/2022/11/21/PWC192/#task-1-binary-flip
5 use v5.36;
6 die <<"EOF" unless @ARGV;
7 Usage: $0 N1 [N2...]
8 to bit flip the significant digits of the integers N1, N2...
9 for(@ARGV){
10 my $binary = sprintf "%b", $_;
11 my $mask=oct "0b". "1"x length $binary;
12 say "$_ -> ", ~$_ & $mask;
13 }
Example:
./ch-1.pl 5 4 6
Results:
5 -> 2
4 -> 3
6 -> 1
Task 2: Equal Distribution
Submitted by: Mohammad S Anwar
You are given a list of integers greater than or equal to zero, @list.
Write a script to distribute the number so that each members are same.
If you succeed then print the total moves otherwise print -1.
Please follow the rules (as suggested by Neils van Dijke [2022-11-21 13:00])
1. You can only move a value of '1' per move
2. You are only allowed to move a value of '1' to a direct neighbor/adjacent cell
Example 1:
Input: @list = (1, 0, 5)
Output: 4
Move #1: 1, 1, 4
(2nd cell gets 1 from the 3rd cell)
Move #2: 1, 2, 3
(2nd cell gets 1 from the 3rd cell)
Move #3: 2, 1, 3
(1st cell get 1 from the 2nd cell)
Move #4: 2, 2, 2
(2nd cell gets 1 from the 3rd cell)
Example 2:
Input: @list = (0, 2, 0)
Output: -1
It is not possible to make each same.
Example 3:
Input: @list = (0, 3, 0)
Output: 2
Move #1: 1, 2, 0
(1st cell gets 1 from the 2nd cell)
Move #2: 1, 1, 1
(3rd cell gets 1 from the 2nd cell)
There is a solution only if the sum of values is a multiple of the number of values. I make a routine that searches the maximum absolute difference between consecutive values and transfers one unit among them according to the sign. I count how many times it is called before all elements are equal. Reduce the maximum difference at each step avoids taking unnecesary steps and the risk of long or infinite loops. The result fits a three-liner.
perl -MList::Util=sum,reduce -E '
@x=@ARGV;sub e{@d=map{$x[$_+1]-$x[$_]}0..@x-2; $i=reduce {abs($d[$a])<abs($d[$b])?$b:$a}0..@d-1;
$s=$d[$i]>0?-1:$d[$i]<0?1:0;@x[$i,$i+1]=map{$s=-$s;$_+$s}@x[$i,$i+1];return $s;}
if((sum @x)%@x){$c=-1}else{++$c while e()} say join " ", @ARGV, "->", $c;
' 1 0 5
perl -MList::Util=sum,reduce -E '
@x=@ARGV;sub e{@d=map{$x[$_+1]-$x[$_]}0..@x-2;$i=reduce {abs($d[$a])<abs($d[$b])?$b:$a}0..@d-1;
$s=$d[$i]>0?-1:$d[$i]<0?1:0;@x[$i,$i+1]=map{$s=-$s;$_+$s}@x[$i,$i+1];return $s;}
if((sum @x)%@x){$c=-1}else{++$c while e()} say join " ", @ARGV, "->", $c;
' 0 2 0
perl -MList::Util=sum,reduce -E '
@x=@ARGV;sub e{@d=map{$x[$_+1]-$x[$_]}0..@x-2;$i=reduce {abs($d[$a])<abs($d[$b])?$b:$a}0..@d-1;
$s=$d[$i]>0?-1:$d[$i]<0?1:0;@x[$i,$i+1]=map{$s=-$s;$_+$s}@x[$i,$i+1];return $s;}
if((sum @x)%@x){$c=-1}else{++$c while e()} say join " ", @ARGV, "->", $c;
' 0 3 0
Results:
1 0 5 -> 4
0 2 0 -> -1
0 3 0 -> 2
The full code follows.
1 # Perl weekly challenge 192
2 # Task 2: Equal Distribution
3 #
4 # See https://wlmb.github.io/2022/11/21/PWC192/#task-2-equal-distribution
5 use v5.36;
6 use List::Util qw(sum reduce all);
7 die <<"EOF" unless @ARGV;
8 Usage: $0 N1 [N2..]
9 to count how many one-unit neighbor transfers are required to distribute the values
10 in the integer array N1 N2... equally.
11 EOF
12 die "Only integers allowed" unless all {/[+-]?\d+/} @ARGV;
13 my @current=@ARGV;
14 my $result=0;
15 if((sum @current)%@current){
16 $result=-1
17 } else {
18 ++$result while transfer()
19 }
20 say join " ", @ARGV, "->", $result;
21 sub transfer{ # transfers one unit to reduce largest difference. Returns +-1 on success 0 on failure
22 return 0 if @current<=1; # nothing to do
23 my @diff=map {$current[$_+1]-$current[$_]} 0..@current-2;
24 my $index=reduce {abs($diff[$a])<abs($diff[$b])?$b:$a} 0..@diff-1; # Find max diff
25 my $sign=$diff[$index]>0?-1:$diff[$index]<0?1:0; # direction of transfer: left(-1) or right(+1))
26 @current[$index,$index+1] = map {$sign=-$sign; $_+$sign} @current[$index, $index+1]; #update
27 return $sign;a
28 }
Example:
./ch-2.pl 1 0 5
./ch-2.pl 0 2 0
./ch-2.pl 0 3 0
Results:
1 0 5 -> 4
0 2 0 -> -1
0 3 0 -> 2
Some edge cases: Example:
./ch-2.pl 2 2 2 # nothing to do
./ch-2.pl 2 # one element only
Results:
2 2 2 -> 0
2 -> 0
The code could have been optimized by updating
@diff around the position $index at each step without recalculating all
differences, but it would have been cumbersome, as the procedure would
depend on the direction of the transfer and it would change at the
boundaries. The solution above looks somewhat cleaner.
Actually, there is a much simpler solution, without trying to produce the actual steps. Simply, transfer the extra (or missing, negative) units from each element to the next, until the end of the array is reached, without worrying about unrealistic temporarily negative values, accumulating the number of transfers along the way. This yields a simple one-liner
perl -MList::Util=sum -E '@x=@ARGV; if(sum(@x)%@x){$c=-1}else{$c=0;$p=sum(@x)/@x;
for(1..@x){$m=$x[$_-1]-$p; $x[$_]+=$m; $c+=abs $m;}} say join " ", @ARGV, "->", $c;' 1 0 5
perl -MList::Util=sum -E '@x=@ARGV; if(sum(@x)%@x){$c=-1}else{$c=0;$p=sum(@x)/@x;
for(1..@x){$m=$x[$_-1]-$p; $x[$_]+=$m; $c+=abs $m;}} say join " ", @ARGV, "->", $c;' 0 2 0
perl -MList::Util=sum -E '@x=@ARGV; if(sum(@x)%@x){$c=-1}else{$c=0;$p=sum(@x)/@x;
for(1..@x){$m=$x[$_-1]-$p; $x[$_]+=$m; $c+=abs $m;}} say join " ", @ARGV, "->", $c;' 0 3 0
perl -MList::Util=sum -E '@x=@ARGV; if(sum(@x)%@x){$c=-1}else{$c=0;$p=sum(@x)/@x;
for(1..@x){$m=$x[$_-1]-$p; $x[$_]+=$m; $c+=abs $m;}} say join " ", @ARGV, "->", $c;' 2 2 2
perl -MList::Util=sum -E '@x=@ARGV; if(sum(@x)%@x){$c=-1}else{$c=0;$p=sum(@x)/@x;
for(1..@x){$m=$x[$_-1]-$p; $x[$_]+=$m; $c+=abs $m;}} say join " ", @ARGV, "->", $c;' 2
Results:
1 0 5 -> 4
0 2 0 -> -1
0 3 0 -> 2
2 2 2 -> 0
2 -> 0
For example, 1 0 5 would become 2 -1 5 after transfering -1 units from the first to the second place, and 2 2 2 after transfering -3 units from the second to the third place, yielding 4 transfers, irrespective of their sign. Similarly, 0 3 0 would become 1 2 0 after transfering -1 from the first to the second place and 1 1 1 after transfering 1 from the second to the third place, yielding 2 transfers.
The corresponding full code is:
1 # Perl weekly challenge 192
2 # Task 2: Equal Distribution. Simpler version
3 #
4 # See https://wlmb.github.io/2022/11/21/PWC192/#task-2-equal-distribution
5 use v5.36;
6 use List::Util qw(sum all);
7 die <<"EOF" unless @ARGV;
8 Usage: $0 N1 [N2..]
9 to count how many one-unit neighbor transfers are required to distribute the values
10 in the integer array N1 N2... equally.
11 EOF
12 die "Only integers allowed" unless all {/[+-]?\d+/} @ARGV;
13 my @arr=@ARGV;
14 my $result=0;
15 if((sum @arr)%@arr){
16 $result=-1
17 } else {
18 $result=0;
19 my $avg=sum(@arr)/@arr;
20 for(1..@arr){
21 my $extra=$arr[$_-1]-$avg;
22 $arr[$_]+=$extra; # $arr[$_-1]-=$extra;
23 $result+=abs $extra;
24 }
25 }
26 say join " ", @ARGV, "->", $result;
Example:
./ch-2a.pl 1 0 5
./ch-2a.pl 0 2 0
./ch-2a.pl 0 3 0
./ch-2a.pl 2 2 2
./ch-2a.pl 2