Merge pull request #4673 from wlmb/challenges

Add solutions to PWC124

4 files changed, 133 insertions, 0 deletions

diff --git a/challenge-124/wlmb/blog.txt b/challenge-124/wlmb/blog.txt
new file mode 100644
index 0000000000..f78befad49
--- /dev/null
+++ b/challenge-124/wlmb/blog.txt
@@ -0,0 +1 @@
+https://wlmb.github.io/2021/08/02/PWC124/
diff --git a/challenge-124/wlmb/perl/ch-1.pl b/challenge-124/wlmb/perl/ch-1.pl
new file mode 100755
index 0000000000..48a06e671d
--- /dev/null
+++ b/challenge-124/wlmb/perl/ch-1.pl
@@ -0,0 +1,31 @@
+#!/usr/bin/env perl
+# 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;
diff --git a/challenge-124/wlmb/perl/ch-2.pl b/challenge-124/wlmb/perl/ch-2.pl
new file mode 100755
index 0000000000..0f5efd42f5
--- /dev/null
+++ b/challenge-124/wlmb/perl/ch-2.pl
@@ -0,0 +1,59 @@
+#!/usr/bin/env perl
+# Perl weekly challenge 124
+# Task 2: Tug of war
+#
+# 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);
+}
diff --git a/challenge-124/wlmb/perl/ch-2a.pl b/challenge-124/wlmb/perl/ch-2a.pl
new file mode 100755
index 0000000000..efb983bb35
--- /dev/null
+++ b/challenge-124/wlmb/perl/ch-2a.pl
@@ -0,0 +1,42 @@
+#!/usr/bin/env perl
+# 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;