Merge pull request #4831 from wlmb/challenges

Add solutions to pwc128

3 files changed, 101 insertions, 0 deletions

diff --git a/challenge-128/wlmb/blog.txt b/challenge-128/wlmb/blog.txt
new file mode 100644
index 0000000000..8f3e6e43df
--- /dev/null
+++ b/challenge-128/wlmb/blog.txt
@@ -0,0 +1 @@
+https://wlmb.github.io/2021/08/30/PWC128/
diff --git a/challenge-128/wlmb/perl/ch-1.pl b/challenge-128/wlmb/perl/ch-1.pl
new file mode 100755
index 0000000000..0d07bc2aab
--- /dev/null
+++ b/challenge-128/wlmb/perl/ch-1.pl
@@ -0,0 +1,52 @@
+#!/usr/bin/env perl
+# Perl weekly challenge 128
+# Task 1:  Maximum submatrix
+#
+# See https://wlmb.github.io/2021/08/30/PWC128/#task-1-maximum-submatrix
+use warnings;
+use strict;
+use v5.12;
+use List::Util qw(reduce);
+use PDL;
+
+my $m=(rcols *STDIN,[],{EXCLUDE=>'/^\s*$/'})->transpose; #input as pdl matrix
+my ($x_max,$y_max)=map {$_-1} $m->dims;
+# For each corner $i, $j find the best submatrix
+my @sm; #array of submatrices
+# For each possible corner produce submatrices
+for my $i(0..$x_max){
+    for my $j(0..$y_max){
+	push @sm, submatrix($i,$j) if $m->at($i,$j)==0;
+    }
+}
+# Choose the largest one
+my $b=reduce {area(@{$a})>area(@{$b})?$a:$b} @sm;
+# Output the results
+say "Input: $m\nOutput: ",
+    defined $b?"matrix($b->[0]:$b->[1],$b->[2]:$b->[3])=".
+                $m->slice("$b->[0]:$b->[1],$b->[2]:$b->[3]")
+              :"None";
+
+sub area { # Calculate the area of a rectangular region given the ranges (a:b,c:d)
+    my ($a, $b, $c, $d)=@_;
+    return (1+$b-$a)*(1+$d-$c);
+}
+
+# Find the best submatrix left-and up-wards of a given corner
+sub submatrix {
+    # bottom right corner and current best upper left.
+    my ($best_l, $best_t)=my ($right, $bottom)=@_;
+    my $leftmost=-1; # Leftmost position to try
+    my $top=-1;
+    for (my $t=$bottom; $t>$top; --$t){
+	my $l;
+	for($l=$right;$l>$leftmost;--$l){
+	    last unless $m->at($l,$t)==0;
+	    ($best_l, $best_t)=($l, $t)
+		if area($l,$right,$t, $bottom)
+		> area($best_l, $right, $best_t, $bottom);
+	}
+	$leftmost=$l; # constrain next search
+    }
+    return [$best_l, $right, $best_t, $bottom] # corner coordinates
+}
diff --git a/challenge-128/wlmb/perl/ch-2.pl b/challenge-128/wlmb/perl/ch-2.pl
new file mode 100755
index 0000000000..75d7dc2739
--- /dev/null
+++ b/challenge-128/wlmb/perl/ch-2.pl
@@ -0,0 +1,48 @@
+#!/usr/bin/env perl
+# Perl weekly challenge 128
+# Task 2: Minimum platforms
+#
+# See https://wlmb.github.io/2021/08/30/PWC128/#task-2-minimum-platforms
+use warnings;
+use strict;
+use v5.12;
+use List::MoreUtils qw(pairwise);
+use PDL;
+
+my ($arrive, $depart)=@ARGV; # Assume format "hh:mm hh:mm..." for each arg.
+my @arrive=map {to_minutes($_)}  split ' ', $arrive;
+my @depart=map {to_minutes($_)}  split ' ', $depart;
+die "Expected same number of arrivals and departures" unless @arrive==@depart;
+
+# Classify departures: after or 'before' arrival
+my @DaA=map {$depart[$_]} grep {$depart[$_] > $arrive[$_]} 0..$#depart; # after
+my @DbA=map {$depart[$_]} grep {$depart[$_] <= $arrive[$_]} 0..$#depart; # before
+
+# Put all event codes  in a single chronologically ordered array.
+# If a departure and an arrival coincide, arrival goes first. Discard time after sorting.
+my @events=map {$_->{type}} sort {$a->{time}<=>$b->{time}|| $a->{type} <=> $b->{type}}
+	       map {my $t=$_; my $r=(\@arrive, \@DaA, \@DbA)[$_];
+                    map {{time=>$_, type=>$t}} @$r } 0..2;
+my $events=pdl(@events); # Ordered vector of event codes
+
+my $effects=zeroes(scalar @events, scalar @events); # effects of each event
+my @type=qw(Arrive Depart Depart(prev)); # Types of events, coded as 0,1,2
+$effects=((($events==0) & ($effects->xvals <= $effects->yvals)) # arrivals +1
+         -(($events==1) & ($effects->xvals <  $effects->yvals)) # departures -1
+         +(($events==2) & ($effects->xvals >= $effects->yvals))); # previous arrival +1
+
+my $trains=$effects->sumover; # trains at station at given events
+my $platforms=$trains->max;   # required platforms
+
+say "Arrivals: $arrive\nDepartures: $depart\nOutput: $platforms platforms";
+say "Trains at station: $trains";
+say "Events: ", map {"$type[$_] "} list($events);
+
+sub to_minutes { # convert HH:MM to minutes. Allow fractional minutes HH:MM.FFF
+    my $time=shift @_;
+    die "Wrong time format: $time" unless $time=~m/(^\d+):(\d+(\.\d*)?)$/;
+    my ($hour, $minute)=($1,$2);
+    die "Falied 0<=hour<24: $time" unless 0<=$hour<24;
+    die "Failed 0<=minute<60: $time" unless 0<=$minute<60;
+    return $hour*60+$minute;
+}