Solution to task 1

2 files changed, 137 insertions, 0 deletions

diff --git a/challenge-103/jo-37/perl/ch-1.pl b/challenge-103/jo-37/perl/ch-1.pl
new file mode 100755
index 0000000000..40aac35b88
--- /dev/null
+++ b/challenge-103/jo-37/perl/ch-1.pl
@@ -0,0 +1,110 @@
+#!/usr/bin/perl -s
+
+use v5.16;
+use Test2::V0;
+use List::Util 'pairmap';
+use List::MoreUtils 'natatime';
+use experimental qw(signatures postderef);
+
+our ($tests, $examples);
+
+run_tests() if $tests || $examples;	# does not return
+
+die <<EOS unless @ARGV;
+usage: $0 [-examples] [-tests] [year]
+
+-examples
+    run the examples from the challenge
+ 
+-tests
+    run some tests
+
+year
+    print element and animal for most time of <year>
+
+EOS
+
+
+### Input and Output
+
+say "@{[ch_zod(shift)]}";
+
+
+### Implementation
+
+{
+    my (@cz, @l);
+
+    BEGIN {
+        @cz = map [map [unpack '(A2)*'], unpack '(A2/A*)*'], unpack '(A4/A*)*', 
+            '00080632658900561012041900111022001904170822141403080508170410' .
+            '04001719070134121214131004241417141418190417060314060615080606' .
+            '17001904142310190806041712170001010819120317000614131018130010' .
+            '041007141718040806140019';
+        @l = sub {map chr($_[0] + $_), $_[1] .. $_[2]}->($cz[0][0]->@*);
+    }
+
+    sub ch_zod ($y) {
+        local $" = '';
+
+        pairmap {"\u@l[$cz[$a][$b]->@*]"} 1, ($y % 10)/2, 2, $y % 12;
+    }
+}
+
+### Examples and tests
+
+sub run_tests {
+    SKIP: {
+        skip "examples" unless $examples;
+
+        is [ch_zod(2017)], [qw(Fire Rooster)], 'example 1';
+        is [ch_zod(1938)], [qw(Earth Tiger)], 'example 2';
+    }
+
+    SKIP: {
+        skip "tests" unless $tests;
+
+        # all elements and animals:
+        my $three = natatime 3,
+            1924, 'Wood',  'Rat',
+            1925, 'Wood',  'Ox',
+            1926, 'Fire',  'Tiger',
+            1927, 'Fire',  'Rabbit',
+            1928, 'Earth', 'Dragon',
+            1929, 'Earth', 'Snake',
+            1930, 'Metal', 'Horse',
+            1931, 'Metal', 'Goat',
+            1932, 'Water', 'Monkey',
+            1933, 'Water', 'Rooster',
+            1934, 'Wood',  'Dog',
+            1935, 'Wood',  'Pig';
+        while (my @t = $three->()) {
+            is [ch_zod($t[0])], [$t[1], $t[2]], "$t[0]: $t[1] $t[2]";
+        }
+	}
+
+    done_testing;
+    exit;
+}
+
+__DATA__
+
+"The string" consists of three parts of the form llllxxxx... with llll
+as the part's length and xxxx as the content.  Each part has the form
+llyyyy... with ll as the length and yyyy as the content for a variable
+number of sub parts.  Finally each sub part is split into 2-digit
+decimal numbers.
+* Part #0 has one sub part containing the decimal ASCII code for ' ' and
+  the offsets of 'a' and 'y' from ' ', thus keeping all of them at two
+  digits.
+* Part #1 has five sub parts containing the offsets of the elements'
+  characters from 'a'.
+* Part #2 has twelve sub parts containing the offsets of the animals'
+  characters from 'a'.
+Part #1 and #2 can be generated by ch-1a.pl.  A three-dimensional array
+@cz is build from these parts where the first index selects
+alphabet/element/animal and the second index the item within this
+category.  The letters of the alphabet are gathered in the array @l.
+
+The "chinese zodiac" sub assembles the year's element and animal as
+title cased array slices from the letters.
diff --git a/challenge-103/jo-37/perl/ch-1a.pl b/challenge-103/jo-37/perl/ch-1a.pl
new file mode 100755
index 0000000000..8a6a5334a3
--- /dev/null
+++ b/challenge-103/jo-37/perl/ch-1a.pl
@@ -0,0 +1,27 @@
+#!/usr/bin/perl
+
+use v5.16;
+use warnings;
+
+die <<EOS unless @ARGV;
+usage: $0 word ...
+
+word ...
+    words to encode
+
+EOS
+
+# ./ch-1a.pl metal water wood fire earth
+# ./ch-1a.pl monkey rooster dog pig rat ox tiger rabbit dragon snake horse goat
+
+use constant A => ord('a');
+
+my $buf;
+for (@ARGV) {
+    my $wbuf;
+    for (split //) {
+        $wbuf .= sprintf "%02d", ord() - A;
+    }
+    $buf .= sprintf "%02d%s", 2 * length, $wbuf;
+}
+printf "%04d%s\n", length($buf), $buf;