Solutions to challenge 132

4 files changed, 195 insertions, 0 deletions

diff --git a/challenge-132/jo-37/perl/ch-1.pl b/challenge-132/jo-37/perl/ch-1.pl
new file mode 100755
index 0000000000..de70e37828
--- /dev/null
+++ b/challenge-132/jo-37/perl/ch-1.pl
@@ -0,0 +1,72 @@
+#!/usr/bin/perl -s
+
+use v5.16;
+use Test2::V0;
+use DateTime::Format::Strptime;
+use experimental 'signatures';
+
+our ($examples, $today);
+
+run_tests() if $examples;	# does not return
+
+die <<EOS unless @ARGV == 1;
+usage: $0 [-examples] [-today=yyyy/mm/dd] [yyyy/mm/dd]
+
+-examples
+    run the examples from the challenge
+ 
+-today=yyyy/mm/dd
+    use given date as today
+
+yyyy/mm/dd
+    day of birth
+
+EOS
+
+
+### Input and Output
+
+{
+    local $, = ', ';
+    say mirror_date(pop, $today);
+}
+
+
+### Implementation
+
+# How should we calculate the age of a person and how should "mirroring"
+# be performed?  A year is not a well defined time span due to leap
+# days.  Neither is a month.  The best we can do is take the age as the
+# number of days ignoring the time part.  Using DateTime math in the
+# 'floating' time zone and based on day deltas seems to be
+# (double-)safe.  At least this approach is consistent with the
+# examples.  For meaningful results the day of birth must not lie ahead.
+sub mirror_date ($dob, $today) {
+    state $fmt = DateTime::Format::Strptime->new(
+        pattern => '%Y/%m/%d', time_zone => 'floating');
+
+    my $dob_dt = $fmt->parse_datetime($dob);
+    my $today_dt = $today ? $fmt->parse_datetime($today) :
+        DateTime->today(time_zone => 'floating');
+    my $age = $today_dt->delta_days($dob_dt);
+
+    ($fmt->format_datetime($dob_dt - $age),
+        $fmt->format_datetime($today_dt + $age));
+}
+
+
+### Examples and tests
+
+sub run_tests {
+    my $today = '2021/09/22';
+
+    is [mirror_date('2021/09/18', $today)],
+        [qw(2021/09/14 2021/09/26)], 'example 1';
+    is [mirror_date('1975/10/10', $today)],
+        [qw(1929/10/27 2067/09/05)], 'example 2';
+    is [mirror_date('1967/02/14', $today)],
+        [qw(1912/07/08 2076/04/30)], 'example 3';
+
+    done_testing;
+    exit;
+}
diff --git a/challenge-132/jo-37/perl/ch-2-ages.csv b/challenge-132/jo-37/perl/ch-2-ages.csv
new file mode 100644
index 0000000000..c83fe341e7
--- /dev/null
+++ b/challenge-132/jo-37/perl/ch-2-ages.csv
@@ -0,0 +1,6 @@
+20,Alex
+28,Joe
+38,Mike
+18,Alex
+25,David
+18,Simon
diff --git a/challenge-132/jo-37/perl/ch-2-names.csv b/challenge-132/jo-37/perl/ch-2-names.csv
new file mode 100644
index 0000000000..3dda4223af
--- /dev/null
+++ b/challenge-132/jo-37/perl/ch-2-names.csv
@@ -0,0 +1,6 @@
+Alex,Stewart
+Joe,Root
+Mike,Gatting
+Joe,Blog
+Alex,Jones
+Simon,Duane
diff --git a/challenge-132/jo-37/perl/ch-2.pl b/challenge-132/jo-37/perl/ch-2.pl
new file mode 100755
index 0000000000..c2f4a8f11c
--- /dev/null
+++ b/challenge-132/jo-37/perl/ch-2.pl
@@ -0,0 +1,111 @@
+#!/usr/bin/perl -s
+
+use v5.16;
+use Test2::V0;
+use Text::CSV 'csv';
+use experimental qw(signatures postderef);
+
+our ($tests, $examples);
+
+run_tests() if $tests || $examples;	# does not return
+
+die <<EOS unless @ARGV == 4;
+usage: $0 [-examples] [-tests] [table1 index1 table2 index2]
+
+-examples
+    run the examples from the challenge
+
+-tests
+    run some tests
+
+table1 index1 table2 index2
+    tableN is the name of a csv file holding data of table N
+    indexN is the position of the join column in table N
+
+call
+    $0 ch-2-ages.csv 1 ch-2-names.csv 0
+for the given example.
+
+EOS
+
+
+### Input and Output
+
+say join ', ', @$_
+    for @{join_arrays(csv(in => shift), shift, csv(in => shift), shift)};
+
+
+### Implementation
+
+
+# I didn't look at the linked wikipedia implementation in detail.  The
+# task - as I understand it - is to join two "tables" on a non-unique
+# index.  The plan is: create two hashes with the indices as the keys
+# and an array holding the corresponding records without their key as
+# values.  Then join the the hashes as a "set product" of the values for
+# corresponding keys, with the joining key inbetween.  The order of the
+# resulting records will be random.
+#
+# The parameters are: two array refs with the corresponding index
+# position.
+sub join_arrays ($t1, $i1, $t2, $i2) {
+    my (%h1, %h2);
+    push $h1{splice @$_, $i1, 1}->@*, $_ for @$t1;
+    push $h2{splice @$_, $i2, 1}->@*, $_ for @$t2;
+
+    [map {
+        my $key = $_;
+        map {
+            my $rec = $_;
+            map [@$rec, $key, @$_], $h2{$key}->@*;
+        } $h1{$key}->@*;
+    } keys %h1];
+}
+
+
+### Examples and tests
+
+sub run_tests {
+    SKIP: {
+        skip "examples" unless $examples;
+
+        my @player_ages = (
+            [20, "Alex"],
+            [28, "Joe"],
+            [38, "Mike"],
+            [18, "Alex"],
+            [25, "David"],
+            [18, "Simon"]);
+
+        my @player_names = (
+            ["Alex", "Stewart"],
+            ["Joe",  "Root"],
+            ["Mike", "Gatting"],
+            ["Joe", "Blog"],
+            ["Alex", "Jones"],
+            ["Simon","Duane"]);
+
+        like join_arrays(\@player_ages, 1, \@player_names, 0),
+            bag {
+                item [20, "Alex",  "Stewart"];
+                item [20, "Alex",  "Jones"];
+                item [18, "Alex",  "Stewart"];
+                item [18, "Alex",  "Jones"];
+                item [28, "Joe",   "Root"];
+                item [28, "Joe",   "Blog"];
+                item [38, "Mike",  "Gatting"];
+                item [18, "Simon", "Duane"];
+                end;
+            }, 'example';
+
+    }
+    SKIP: {
+        skip "tests" unless $tests;
+
+        is join_arrays([[1, 'a'], [2, 'b']], 0, [[2, 'B'], [3, 'C']], 0),
+            [['b', 2, 'B']], 'nonmatching keys';
+	}
+
+    done_testing;
+    exit;
+}