Perl Weekly Challenge 124.
My solutions (task 1, task 2, task 2a, and task 2b ) to the The Weekly Challenge - 124.
Task 1: Women Day
The venus symbol consists of a circle above a cross. I don’t know what are the specifications and I have seen them with different proportions. I can use PDL to compute and print an array of 0’s and 1’s, making this an almost oneliner. For example, I can draw a circle and a cross on two 21x21 arrays and glue them together with the following:
perl -MPDL -E '$r=zeroes(21,21)->rvals; $x=$r->xvals;$y=$r->yvals;' \
-E 'say +($r<=10&$r>9)->glue(1,($x>9&$x<11&$y<15)|$y>7&$y<9&$x>3&$x<18)'
Results:
[
[0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0]
[0 0 0 0 0 0 1 1 1 1 0 1 1 1 1 0 0 0 0 0 0]
[0 0 0 0 1 1 0 0 0 0 0 0 0 0 0 1 1 0 0 0 0]
[0 0 0 1 1 0 0 0 0 0 0 0 0 0 0 0 1 1 0 0 0]
[0 0 1 1 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 0 0]
[0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0]
[0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0]
[0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0]
[0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0]
[0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0]
[1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1]
[0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0]
[0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0]
[0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0]
[0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0]
[0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0]
[0 0 1 1 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 0 0]
[0 0 0 1 1 0 0 0 0 0 0 0 0 0 0 0 1 1 0 0 0]
[0 0 0 0 1 1 0 0 0 0 0 0 0 0 0 1 1 0 0 0 0]
[0 0 0 0 0 0 1 1 1 1 0 1 1 1 1 0 0 0 0 0 0]
[0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0]
[0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0]
[0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0]
[0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0]
[0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0]
[0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0]
[0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0]
[0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0]
[0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0]
[0 0 0 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0 0 0]
[0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0]
[0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0]
[0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0]
[0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0]
[0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0]
[0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0]
[0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0]
[0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0]
[0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0]
[0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0]
[0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0]
[0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0]
]
With a full program I may parametrize the size of the array, the proportions and the character used.
# Perl weekly challenge 124
# Task 1: Womans day
#
# See https://wlmb.github.io/2021/08/02/PWC124/#task-1-women-day
use warnings;
use strict;
use v5.12;
use PDL;
use utf8;
die 'Usage: ./ch-1.pl N Width Heigth LineWidth Char' unless @ARGV==5;
my ($N, $W, $H, $LW, $char)=@ARGV; # 2*$N+1 pixels, Width and Height of cross, linewidth, char
my $z=zeroes(2*$N+1, 2*$N+1);
my $r=$z->rvals; # distance to center of circle
my $x=$z->xvals-$N; #x,y coordinates with repect to top of cross
my $y=$z->yvals;
my $circle=$r<=$N&$r>=(1-$LW)*$N;
my $vertical=$y<=$H*(2*$N+1)&$x->abs<=$LW*$N/2;
my $horizontal=$x->abs<=$W*$N&($y-$H*$N)->abs<=$LW*$N/2;
my $cross=$horizontal|$vertical;
# (2N+1)x(4N+1) circle and cross, made of 1's and 0's, and some brackets
# (remove 1 row from circle for better join to cross)
my $venus=$circle->slice(':,:-2')->glue(1,$cross);
# stringify
my $venus_string=sprintf "%s", $venus;
# edit string replacing 0's, eliminating brakets and replacing 1's by desired character
$venus_string=~tr/0[]/ /d;
$venus_string=~s/1/$char/g;
say $venus_string;
Example (complementarity):
./ch-1.pl 10 .6 .6 .2 ♂
Results:
♂
♂ ♂ ♂ ♂ ♂ ♂ ♂ ♂ ♂
♂ ♂ ♂ ♂ ♂ ♂ ♂ ♂ ♂ ♂ ♂ ♂ ♂
♂ ♂ ♂ ♂ ♂ ♂ ♂ ♂
♂ ♂ ♂ ♂ ♂ ♂
♂ ♂ ♂ ♂
♂ ♂ ♂ ♂ ♂ ♂
♂ ♂ ♂ ♂
♂ ♂ ♂ ♂
♂ ♂ ♂ ♂
♂ ♂ ♂ ♂ ♂ ♂
♂ ♂ ♂ ♂
♂ ♂ ♂ ♂
♂ ♂ ♂ ♂
♂ ♂ ♂ ♂ ♂ ♂
♂ ♂ ♂ ♂
♂ ♂ ♂ ♂ ♂ ♂
♂ ♂ ♂ ♂ ♂ ♂ ♂ ♂
♂ ♂ ♂ ♂ ♂ ♂ ♂ ♂ ♂ ♂ ♂ ♂ ♂
♂ ♂ ♂ ♂ ♂ ♂ ♂ ♂ ♂
♂ ♂ ♂
♂ ♂ ♂
♂ ♂ ♂
♂ ♂ ♂
♂ ♂ ♂
♂ ♂ ♂ ♂ ♂ ♂ ♂ ♂ ♂ ♂ ♂ ♂ ♂
♂ ♂ ♂ ♂ ♂ ♂ ♂ ♂ ♂ ♂ ♂ ♂ ♂
♂ ♂ ♂ ♂ ♂ ♂ ♂ ♂ ♂ ♂ ♂ ♂ ♂
♂ ♂ ♂
♂ ♂ ♂
♂ ♂ ♂
♂ ♂ ♂
♂ ♂ ♂
Task 2: Tug of War
Submitted by: Mohammad S Anwar
You are given a set of $n integers (n1, n2, n3, ….).
Write a script to divide the set in two subsets of n/2 sizes
each so that the difference of the sum of two subsets is the
least. If $n is even then each subset must be of size $n/2
each. In case $n is odd then one subset must be ($n-1)/2 and
other must be ($n+1)/2.
Example
Input: Set = (10, 20, 30, 40, 50, 60, 70, 80, 90, 100)
Output: Subset 1 = (30, 40, 60, 70, 80)
Subset 2 = (10, 20, 50, 90, 100)
Input: Set = (10, -15, 20, 30, -25, 0, 5, 40, -5)
Subset 1 = (30, 0, 5, -5)
Subset 2 = (10, -15, 20, -25, 40)
If the set is not too large, I can do an exhaustive search. To
that end I recycle the combinator I used for the Perl
Weekly Challenge 112
climb stairs task, to generate all the
combinations of N items taken k=N/2 at a time. Then, I
record each combination, the difference of the sum of the
corresponding subsets, and choose that with the smallest
absolute value. The combinator produces a list of 1’s and 0’s,
one for each number, indicating the element belong to the set
or to its complement. To produce the list, I start with the
list 1111…1000…000. At each step I look for the leftmost
pair 10 and replace it by 01. All the elements to its left are
then of the form 000…00111..11, which is reset to the form
111..11000..00. Interpreting the 1’s and 0’s as binary
numbers, ordered from least to most significative left to
right, I generate in increasing order all binary numbers with exactly k
1’s.
# Perl weekly challenge 124
# Task 2: Tug of war. Exhaustive search.
#
# See https://wlmb.github.io/2021/08/02/PWC124/#task-2-tug-of-war
use strict;
use warnings;
use v5.12;
use List::Util qw(sum0 first);
use POSIX qw(floor);
die 'Usage: ./ch-2.pl n1 n2 n3... to balance a set of numbers' unless @ARGV;
my $N=my @set=sort {$a<=>$b} @ARGV;
my $N2=floor $N/2;
my $combinator=combinator($N, $N2);
my $best;
while(my @combination=$combinator->()){
my @set1=map {$set[$_]} grep {$combination[$_]} 0..$N-1;
my @set2=map {$set[$_]} grep {!$combination[$_]} 0..$N-1;
my ($sum1, $sum2)=map {sum0 @$_} \@set1, \@set2;
my $dif=abs($sum2-$sum1);
$best={dif=>$dif,set1=>\@set1,set2=>\@set2} unless defined $best && $best->{dif}<=$dif;
}
say "Input: ", join " ", @set;
say "Set1: ", join " ", sort@{$best->{set1}};
say "Set2: ", join " ", @{$best->{set2}};
say "Diff: ", $best->{dif};
sub combinator { # produces combinations of n taken k at a time
my ($n,$k)=@_;
my @number=((1) x $k, (0) x ($n-$k)); # binary $n-bit number as array
my $done=0;
my $iter=0;
sub {
return if $done;
return @number if $iter++==0; #first time through
@number=following(@number);
return @number if @number;
$done=1;
return;
}
}
sub following {
my @number=@_;
my $first_10=first {$number[$_]==1 && $number[$_+1]==0} (0..@number-2);
return unless defined $first_10;
@number[$first_10, $first_10+1]=(0,1);
restart (@number[0..$first_10-1]);
return @number;
}
sub restart {
return unless @_;
my $ones=sum0 @_;
@_[0..$ones-1]=(1)x$ones;
@_[$ones..@_-1]=(0)x(@_-$ones);
}
Examples:
./ch-2.pl 10 20 30 40 50 60 70 80 90 100
./ch-2.pl 10 -15 20 30 -25 0 5 40 -5
Results:
Input: 10 20 30 40 50 60 70 80 90 100
Set1: 30 40 50 70 80
Set2: 10 20 60 90 100
Diff: 10
Input: -25 -15 -5 0 5 10 20 30 40
Set1: -5 10 20 5
Set2: -25 -15 0 30 40
Diff: 0
The results are not the same as in the description of the task, but they are as good, having the same absolute difference.
For large sets, it may be better to look for approximate
solutions, maybe not optimum, but with a time that doesn’t
explode as NN, using for example, the simulated annealing I
used for the Perl Weekly Challenge 112 Traveling salesman
task. Here I start from an arbitrary partition of the given
N-element set
into a subset of k=N/2 and another of N-k
elements. Repeatedly I permute one element from one set with
another from the other set and accept the new configuration
if its energy E diminishes, or accept it with probability
exp(-E/T), where T is the temperature. I use the
absolute value of the difference of the sums over the two sets
as the energy, and I gradually decrease the temperature.
# Perl weekly challenge 124
# Task 2: Tug of war. Simulated Annealing
#
# See https://wlmb.github.io/2021/08/02/PWC124/#task-2-tug-of-war
use strict;
use warnings;
use v5.12;
use POSIX qw(floor);
use List::Util qw(sum0);
die 'Usage: ./ch-2a.pl steps low n1 n2 n3... to balance a set of numbers n1...' unless @ARGV>=2;
my ($steps, $low_frac, @set)=@ARGV; # length of sim, low to high T ratio, values.
@set=sort {$a <=> $b} @set;
my $N=@set; # number of elements
my $k=floor $N/2;
my $high=$set[-1]-$set[0]; # Max difference
my $T=$high; # starting temperature
my $low=$low_frac*$high; # ending temperature
my $factor=$low_frac**(1/$steps);
#srand(0); #seed, for tests only
my @set1=@set[0..$k-1]; # starting sets
my @set2=@set[$k..$N-1];
my ($sum1, $sum2)=map {sum0 @$_} \@set1, \@set2;
my $E=abs($sum2-$sum1); # energy
while($T>$low){
my ($i1, $i2)=(rand($k),rand($N-$k)); # random indices to swap
my ($new_sum1, $new_sum2)=($sum1-$set1[$i1]+$set2[$i2],$sum2+$set1[$i1]-$set2[$i2]);
my $newE=abs($new_sum2-$new_sum1);
my $dE=$newE-$E;
if($dE<=0 || rand(1)<exp(-$dE/$T)){ # Exchange elements
($set1[$i1],$set2[$i2])=($set2[$i2],$set1[$i1]);
($sum1,$sum2)=($new_sum1, $new_sum2);
$E=$newE;
}
$T*=$factor;
}
say "T High: $high, T Low: $low, Steps: $steps";
say "Input: ", join " ", @set;
say "Set1: ", join " ", sort {$a<=>$b} @set1;
say "Set2: ", join " ", sort {$a<=>$b} @set2;
say "Diff: ", $E;
./ch-2a.pl 30 .01 10 20 30 40 50 60 70 80 90 100
./ch-2a.pl 30 .01 10 -15 20 30 -25 0 5 40 -5
Results:
T High: 90, T Low: 0.9, Steps: 30
Input: 10 20 30 40 50 60 70 80 90 100
Set1: 10 30 50 90 100
Set2: 20 40 60 70 80
Diff: 10
T High: 65, T Low: 0.65, Steps: 30
Input: -25 -15 -5 0 5 10 20 30 40
Set1: -25 5 20 30
Set2: -15 -5 0 10 40
Diff: 0
Again, I found different solutions than above, but equally good. That I found a correct solution with so few steps is due to the abundance of equally valid solutions for the examples above.
As another example, I generate a thousand random numbers and balance them.
perl -E '$N=shift @ARGV; say rand while(--$N);' 1000 \
|xargs ./ch-2a.pl 100000 .0001
Results:
T High: 0.999556133316691, T Low: 9.99556133316691e-05, Steps: 100000
Input: 0.000363276139676572 0.00054625589149282 0.00158547511806972 0.00378148385910748...
Set1: 0.000363276139676572 0.00599820804556828 0.00647114390215719 0.00687810646286735...
Set2: 0.00054625589149282 0.00158547511806972 0.00378148385910748 0.00392547714578839...
Diff: 8.49131527047575e-06
In this case, the average distance between numbers is 0.001, so a difference of less than one part in a hundred thousand seems good. However, upon repetition I obtained numbers as large as 0.0001. Below I run the program twice on the same set of random numbers, with more Monte Carlo steps and a lower final temperature:
perl -E '$N=shift @ARGV; srand(0); say rand while(--$N);' 1000 \
|xargs ./ch-2a.pl 1e6 1e-6
perl -E '$N=shift @ARGV; srand(0); say rand while(--$N);' 1000 \
|xargs ./ch-2a.pl 1e6 1e-6
Results:
T High: 0.998265792029063, T Low: 9.98265792029063e-07, Steps: 1e6
Input: 0.00108083487480926 0.00136930248474698 0.00184582871581895 0.00297668760298464...
Set1: 0.00136930248474698 0.00297668760298464 0.00625164924678856 0.00982741667341358...
Set2: 0.00108083487480926 0.00184582871581895 0.00302121783218112 0.0136791673342671...
Diff: 7.08017211081824e-06
T High: 0.998265792029063, T Low: 9.98265792029063e-07, Steps: 1e6
Input: 0.00108083487480926 0.00136930248474698 0.00184582871581895 0.00297668760298464...
Set1: 0.00302121783218112 0.0147782380899244 0.0162424485109227 0.0207717026362104...
Set2: 0.00108083487480926 0.00136930248474698 0.00184582871581895 0.00297668760298464...
Diff: 5.43532223673537e-08
The last line above shows that the best balance in this case is better than one part in ten millions, but the result I obtained for the parameters chosen may be much higher, close to one part in a hundred thousand. In any case, a million Monte Carlo steps as above is much smaller than the 1000!/(500!)2≅10300 steps required for an exhaustive search, and 10-5 is much smaller than the expected difference ~10 between the two sums of 500 random numbers, each between 0 and 1, so it may be an acceptable sub-optimal solution. If not, more steps and a larger temperature range may be chosen for better optimization.
I make another attempt, ordering all elements and initializing them alternatingly to subsets 1 and 2. Then I iteratively run over all the indices of one set, exchanging elements with near neighbors of that index in the other subset if that lowers the energy. I repeat until no exchange of elements succeeds.
# Perl weekly challenge 124
# Task 2: Tug of war. Exchanges with neighbors
#
# See https://wlmb.github.io/2021/08/02/PWC124/#task-2-tug-of-war
use strict;
use warnings;
use v5.12;
use POSIX qw(floor);
use List::Util qw(sum0);
die 'Usage ./ch-2b.pl n1 n2 n3...' unless @ARGV>=2;
my @set=sort {$a <=> $b} @ARGV;
my $N=@set;
my $k=floor $N/2;
my @set1=map {$set[2*$_]} 0..$k-1;
push @set1, $set[-1] if $N%2; # odd number of elements
my @set2=map {$set[2*$_+1]} 0..$k-1;
my $N1=@set1;
my $N2=@set2;
my ($sum1,$sum2)=map {sum0 @$_} (\@set1,\@set2);
my $E=abs($sum2-$sum1);
my $done=0;
while(!$done){
$done=1;
foreach my $delta(-1,0,1){
foreach my $i1(0..$N1-1){
$done=0 if attempt($i1, $i1+$delta);
}
}
}
say "Input: ", join " ", @set;
say "Set1: ", join " ", sort {$a<=>$b} @set1;
say "Set2: ", join " ", sort {$a<=>$b} @set2;
say "Diff: ", $E;
sub attempt {
my ($i1, $i2)=@_;
return if $i1<0 || $i2<0 || $i1>=$N1 || $i2>=$N2;
my ($new_sum1, $new_sum2)=($sum1-$set1[$i1]+$set2[$i2], $sum2+$set1[$i1]-$set2[$i2]);
my $new_E=abs($new_sum2-$new_sum1);
return if $new_E>=$E;
($set1[$i1],$set2[$i2])=($set2[$i2],$set1[$i1]);
($sum1, $sum2)=($new_sum1,$new_sum2);
$E=$new_E;
return 1;
}
./ch-2b.pl 10 20 30 40 50 60 70 80 90 100
./ch-2b.pl 10 -15 20 30 -25 0 5 40 -5
Results:
Input: 10 20 30 40 50 60 70 80 90 100
Set1: 20 40 50 70 90
Set2: 10 30 60 80 100
Diff: 10
Input: -25 -15 -5 0 5 10 20 30 40
Set1: -25 -5 0 20 40
Set2: -15 5 10 30
Diff: 0
perl -E '$N=shift @ARGV; srand(0); say rand while(--$N);' 1000 \
|xargs ./ch-2b.pl
Results:
Input: 0.00108083487480926 0.00136930248474698 0.00184582871581895 0.00297668760298464...
Set1: 0.00108083487480926 0.00184582871581895 0.00302121783218112 0.00625164924678856...
Set2: 0.00136930248474698 0.00297668760298464 0.00982741667341358 0.0147782380899244...
Diff: 4.60989326711569e-08
In this case I obtained a better result Diff=4.6e-08 than with simulated
annealing and much faster (it took 6000 comparisons). However,
I confess I’m not completely sure this is the
optimal solution and I’m not convinced it works always. This procedure
seems to be fragile. For example, the solution above is missed if the
order of the neighbors to be examined, in the line
foreach my $delta(-1,0,1){
is reversed, as in
foreach my $delta(1,0,-1){