Merge pull request #4664 from choroba/ech124

Add solutions to 124: Happy Woman Day & Tug of War by E. Choroba

2 files changed, 99 insertions, 0 deletions

diff --git a/challenge-124/e-choroba/perl/ch-1.pl b/challenge-124/e-choroba/perl/ch-1.pl
new file mode 100755
index 0000000000..44d754a35c
--- /dev/null
+++ b/challenge-124/e-choroba/perl/ch-1.pl
@@ -0,0 +1,33 @@
+#!/usr/bin/perl
+use warnings;
+use strict;
+
+use GD;
+
+my @SHADES = ("\N{LIGHT SHADE}", "\N{MEDIUM SHADE}", "\N{DARK SHADE}");
+
+my $image = 'GD::Image'->new(20, 30);
+my $white = $image->colorAllocate(255, 255, 255);
+my $black = $image->colorAllocate(0, 0, 0);
+$image->stringFT($black,
+                 'arial',
+                 20, 0, 0, 21, "\N{FEMALE SIGN}",
+                 {charmap => 'Unicode'});
+my @grid;
+my $max = 0;
+for my $y (0 .. 27) {
+    for my $x (0 .. 20) {
+        $grid[$x][$y] = $image->getPixel($x, $y);
+        $max = $grid[$x][$y] if $grid[$x][$y] > $max;
+    }
+}
+binmode *STDOUT, ':encoding(UTF-8)';
+for my $y (0 .. 27) {
+    for my $x(0 .. 20) {
+        my $pixel = $grid[$x][$y];
+        print $pixel
+            ? $SHADES[3 * ($pixel - 1) / $max]
+            : ' ';
+    }
+    print "\n";
+}
diff --git a/challenge-124/e-choroba/perl/ch-2.pl b/challenge-124/e-choroba/perl/ch-2.pl
new file mode 100755
index 0000000000..b50bdbad8f
--- /dev/null
+++ b/challenge-124/e-choroba/perl/ch-2.pl
@@ -0,0 +1,66 @@
+#!/usr/bin/perl
+use warnings;
+use strict;
+
+use List::Util qw{ sum };
+
+# Adapted from PWC 114/2.
+sub next_same_number_of_ones {
+    my ($binary) = @_;
+
+    if (-1 != (my $pos = rindex $binary, '01')) {
+        substr $binary, $pos, 2, '10';
+        my $suffix = substr $binary, $pos + 2, length $binary, "";
+        my $ones = $suffix =~ tr/1//d;
+        $suffix .= 1 x $ones;
+        return "$binary$suffix";
+    }
+
+    my $pos = rindex $binary, '1';
+    my $zeros = substr $binary, $pos + 1, length $binary, "";
+    substr $binary, 1, 0, "0$zeros";
+    return $binary
+}
+
+sub tug_of_war {
+    my @ints = @_;
+    my $length = @ints;
+    my $size = $length / 2;
+    my $mask = "%0${length}b";
+    my $bin = sprintf $mask, 2 ** (int $size) - 1;
+    my ($diff, $best1, $best2) = sum(@ints);
+    while ($bin !~ /^1+0+$/) {
+        my ($s1, $s2) = ([], []);
+        for my $i (0 .. $length - 1) {
+            push @{ ($s1, $s2)[ substr $bin, $i, 1 ] }, $ints[$i];
+        }
+        if (abs(sum(0, @$s1) - sum(0, @$s2)) < $diff) {
+            $diff = abs(sum(0, @$s1) - sum(0, @$s2));
+            ($best1, $best2) = ([@$s1], [@$s2]);
+            last if 0 == $diff
+        }
+        $bin = next_same_number_of_ones($bin);
+    }
+    return $best1, $best2
+}
+
+use Test2::V0;
+plan 2;
+
+sub Check {
+    my ($input, $arr1, $arr2, $name) = @_;
+    is [tug_of_war(@$input)],
+        bag { item bag { item $_ for @$arr1; end };
+              item bag { item $_ for @$arr2; end };
+        }, $name;
+}
+
+Check([10, 20, 30, 40, 50, 60, 70, 80, 90, 100],
+      [30, 40, 60, 70, 80],
+      [10, 20, 50, 90, 100],
+      'Example 1');
+
+Check([10, -15, 20, 30, -25, 0, 5, 40, -5],
+      [30, 0, 5, -5],
+      [10, -15, 20, -25, 40],
+      'Example 2');