Perl 5 & 6 solutions to Tasks #1 & #2, and Perl 5 solution to Task #3.

On branch branch-for-challenge-023
Changes to be committed:
	new file:   challenge-023/athanasius/perl5/ch-1.pl
	new file:   challenge-023/athanasius/perl5/ch-2.pl
	new file:   challenge-023/athanasius/perl5/ch-3.pl
	new file:   challenge-023/athanasius/perl6/ch-1.p6
	new file:   challenge-023/athanasius/perl6/ch-2.p6

5 files changed, 525 insertions, 0 deletions

diff --git a/challenge-023/athanasius/perl5/ch-1.pl b/challenge-023/athanasius/perl5/ch-1.pl
new file mode 100644
index 0000000000..b86e7c37fd
--- /dev/null
+++ b/challenge-023/athanasius/perl5/ch-1.pl
@@ -0,0 +1,132 @@
+#!perl
+
+################################################################################
+=comment
+
+Perl Weekly Challenge 023
+=========================
+
+Task #1
+-------
+Create a script that prints nth order forward difference series. You should be a
+able to pass the list of numbers and order number as command line parameters.
+Let me show you with an example.
+
+  Suppose we have list (X) of numbers: 5, 9, 2, 8, 1, 6 and we would like to
+  create 1st order forward difference series (Y). So using the formula Y(i) =
+  X(i+1) - X(i), we get the following numbers: (9-5), (2-9), (8-2), (1-8),
+  (6-1). In short, the final series would be: 4, -7, 6, -7, 5. If you noticed,
+  it has one less number than the original series. Similary you can carry on 2nd
+  order forward difference series like: (-7-4), (6+7), (-7-6), (5+7) => -11, 13,
+  -13, 12.
+
+=cut
+################################################################################
+
+#--------------------------------------#
+# Copyright © 2019 PerlMonk Athanasius #
+#--------------------------------------#
+
+use strict;
+use warnings;
+use Const::Fast;
+use Getopt::Long;
+use Regexp::Common;
+
+const my $DEBUG => 0;
+const my $ORDER => 1;
+const my $USAGE => "USAGE: perl $0 [--order=<UInt> --] <Num> <Num>+\n";
+
+BEGIN
+{
+    $| = 1;
+    print "\n";
+}
+
+#===============================================================================
+MAIN:
+#===============================================================================
+{
+    my ($series, $order) = parse_command_line();
+    my  $series_string   = '(' . join(', ', @$series) . ')';
+
+    if ($DEBUG)
+    {
+        printf "%*d: %s\n", length $order, 0, $series_string;
+    }
+    else
+    {
+        printf "Original series:\n%s\n",      $series_string;
+    }
+
+    for my $o (1 .. $order)
+    {
+        my   @new_series;
+        push @new_series, $series->[$_] - $series->[$_ - 1] for 1 .. $#$series;
+
+        printf( "%*d: (%s)\n", length($order), $o, join(', ', @new_series) )
+            if $DEBUG;
+
+        $series = \@new_series;
+    }
+
+    printf "\n%s order forward difference series:\n(%s)\n", ordinal($order),
+            join(', ', @$series);
+}
+
+#-------------------------------------------------------------------------------
+sub parse_command_line
+#-------------------------------------------------------------------------------
+{
+    my $order = $ORDER;
+
+    GetOptions
+    (
+        'order=i' => \$order,
+
+    ) or die "Error in command line arguments\n$USAGE";
+
+    $order > 0
+        or die "Invalid order ($order): must be an integer > 0\n$USAGE";
+
+    my @series    = @ARGV;
+    my $elements  = scalar @series;
+    my $max_order = $elements - 1;
+
+    $elements > 1
+        or die "Invalid number of elements ($elements) in the series: must " .
+               "be at least 2\n$USAGE";
+
+    $order < $elements
+        or die "Invalid order ($order): a series of $elements elements " .
+               "cannot have an order > $max_order\n$USAGE";
+
+    for my $element (@series)
+    {
+        $element =~ /$RE{num}{real}/
+            or die "Invalid series entry: $element\n$USAGE";
+    }
+
+    return (\@series, $order);
+}
+
+#-------------------------------------------------------------------------------
+sub ordinal
+#-------------------------------------------------------------------------------
+{
+    my ($cardinal) = @_;
+    my  $suffix    = 'th';
+    my  $digit_0   = $cardinal % 10;
+    my  $digit_1   = int($cardinal / 10) % 10;
+
+    if ($digit_1 != 1)
+    {
+        $suffix = $digit_0 == 1 ? 'st' :
+                  $digit_0 == 2 ? 'nd' :
+                  $digit_0 == 3 ? 'rd' : 'th';
+    }
+
+    return $cardinal . $suffix;
+}
+
+################################################################################
diff --git a/challenge-023/athanasius/perl5/ch-2.pl b/challenge-023/athanasius/perl5/ch-2.pl
new file mode 100644
index 0000000000..678179f80b
--- /dev/null
+++ b/challenge-023/athanasius/perl5/ch-2.pl
@@ -0,0 +1,52 @@
+#!perl
+
+################################################################################
+=comment
+
+Perl Weekly Challenge 023
+=========================
+
+Task #2
+-------
+Create a script that prints *Prime Decomposition* of a given number. The prime
+decomposition of a number is defined as a list of prime numbers which when all
+multiplied together, are equal to that number. For example, the Prime decomposi-
+tion of 228 is 2,2,3,19 as 228 = 2 * 2 * 3 * 19.
+
+=cut
+################################################################################
+
+#--------------------------------------#
+# Copyright © 2019 PerlMonk Athanasius #
+#--------------------------------------#
+
+use strict;
+use warnings;
+use Const::Fast;
+use Math::Prime::Util qw( factor );
+
+const my $USAGE => "USAGE: perl $0 <UInt gt 1>\n";
+
+BEGIN
+{
+    $| = 1;
+    print "\n";
+}
+
+#===============================================================================
+MAIN:
+#===============================================================================
+{
+    scalar @ARGV == 1
+        or die $USAGE;
+
+    my $number = $ARGV[0];
+
+    $number > 1
+        or die "Invalid number ($number): must be an integer > 1\n$USAGE";
+
+    printf "The prime decomposition of %d is: %s\n", $number,
+        join ', ', factor($number);
+}
+
+################################################################################
diff --git a/challenge-023/athanasius/perl5/ch-3.pl b/challenge-023/athanasius/perl5/ch-3.pl
new file mode 100644
index 0000000000..9f88985233
--- /dev/null
+++ b/challenge-023/athanasius/perl5/ch-3.pl
@@ -0,0 +1,151 @@
+#!perl
+
+################################################################################
+=comment
+
+Perl Weekly Challenge 023
+=========================
+
+Task #3
+-------
+Write a script to use *Random Poems API*. This is the easiset API, I have come
+across so far. You don't need API key for this. They have only
+[ https://www.poemist.com/api/v1/randompoems |route] to work with (GET). The API
+task is *optional* but we would love to see your solution.
+
+=cut
+################################################################################
+
+#--------------------------------------#
+# Copyright © 2019 PerlMonk Athanasius #
+#--------------------------------------#
+
+use strict;
+use warnings;
+use feature qw( state );
+use Const::Fast;
+use JSON::XS;
+use LWP::Simple;
+use Tk;
+use Tk::ROText;
+
+const my $BUTTON_FONT => 'Ariel 8';
+const my $POEM_FONT   => 'Ariel 16';
+const my $TITLE       => 'Random Poems from Poemist';
+const my $URL         => 'https://www.poemist.com/api/v1/randompoems';
+
+#===============================================================================
+MAIN:
+#===============================================================================
+{
+    my $main = MainWindow->new(-title => $TITLE);
+       $main->optionAdd('*font', $POEM_FONT);
+
+    my $text = make_text_widget($main);
+
+    make_next_button($main, $text);
+
+    MainLoop();
+}
+
+#-------------------------------------------------------------------------------
+sub make_text_widget
+#-------------------------------------------------------------------------------
+{
+    my ($main) = @_;
+    my  $text  = $main->Scrolled
+                 (
+                     'ROText',
+                     -borderwidth =>  2,
+                     -setgrid     => 'true',
+                     -height      =>  30,
+                     -width       =>  60,
+                     -scrollbars  => 'oe',
+                     -state       => 'normal',
+                     -wrap        => 'word',
+                 )
+                 ->pack
+                 (
+                     -expand      => 'yes',
+                     -fill        => 'both',
+                 );
+        $text->insert
+                 (
+                     '0.0',
+                      get_next_poem(),
+                 );
+
+    return $text;
+}
+
+#-------------------------------------------------------------------------------
+sub make_next_button
+#-------------------------------------------------------------------------------
+{
+    my ($main, $text) = @_;
+
+    $main->Button
+           (
+               -text    => 'Next Poem',
+               -font    =>  $BUTTON_FONT,
+               -command =>  sub
+                            {
+                                $text->delete('0.0', 'end');
+                                $text->insert('0.0',  get_next_poem());
+                            },
+           )
+           ->pack
+           (
+               -side   => 'top',
+               -expand => 'yes',
+               -pady   =>  2,
+           );
+}
+
+#-------------------------------------------------------------------------------
+sub get_next_poem
+#-------------------------------------------------------------------------------
+{
+    state @poems;
+
+    @poems = get_poems() until scalar @poems;
+
+    return shift @poems;
+}
+
+#-------------------------------------------------------------------------------
+sub get_poems
+#-------------------------------------------------------------------------------
+{
+    my @poems;
+    my $json    = get($URL);
+    my @entries = decode_json($json);
+
+    scalar @entries == 1
+        or die "Wrong number of entries: " . scalar(@entries) . "\n";
+
+    for my $poem ( $entries[0]->@* )
+    {
+        my $content = $poem->{content};
+
+        if (defined $content && $content ne '')
+        {
+            my $title = $poem->{title};
+            my $poet  = $poem->{poet}{name};
+
+            for ($title, $poet)
+            {
+                s/ ^ \s+   //x;
+                s/   \s+ $ //x;
+            }
+
+            $title = '"' . $title . '"' unless substr($title, 0, 1) eq '"';
+
+            push @poems, sprintf "%s by %s\n\n%s", $title, $poet, $content;
+        }
+    }
+
+    return @poems;
+}
+
+################################################################################
diff --git a/challenge-023/athanasius/perl6/ch-1.p6 b/challenge-023/athanasius/perl6/ch-1.p6
new file mode 100644
index 0000000000..bec5457e96
--- /dev/null
+++ b/challenge-023/athanasius/perl6/ch-1.p6
@@ -0,0 +1,98 @@
+use v6;
+
+################################################################################
+=begin comment
+
+Perl Weekly Challenge 023
+=========================
+
+Task #1
+-------
+Create a script that prints nth order forward difference series. You should be a
+able to pass the list of numbers and order number as command line parameters.
+Let me show you with an example.
+
+  Suppose we have list (X) of numbers: 5, 9, 2, 8, 1, 6 and we would like to
+  create 1st order forward difference series (Y). So using the formula Y(i) =
+  X(i+1) - X(i), we get the following numbers: (9-5), (2-9), (8-2), (1-8),
+  (6-1). In short, the final series would be: 4, -7, 6, -7, 5. If you noticed,
+  it has one less number than the original series. Similary you can carry on 2nd
+  order forward difference series like: (-7-4), (6+7), (-7-6), (5+7) => -11, 13,
+  -13, 12.
+
+=end comment
+################################################################################
+
+#--------------------------------------#
+# Copyright © 2019 PerlMonk Athanasius #
+#--------------------------------------#
+
+my UInt:D constant $ORDER = 1;
+
+BEGIN say '';
+
+#===============================================================================
+sub MAIN(*@series, UInt:D :$order = $ORDER)
+#===============================================================================
+{
+    check-arguments(@series, $order);
+
+    for 1 .. $order
+    {
+        my UInt $max-index = @series.elems - 1;
+
+        my @new-series;
+           @new-series.push(@series[$_] - @series[$_ - 1]) for 1 .. $max-index;
+
+        @series = @new-series;
+    }
+
+    "%s order forward difference series:\n(%s)\n".printf:
+        ordinal($order), join(', ', @series);
+
+    CATCH
+    {
+        default 
+        {
+            $*ERR.say: .message ~ "\n" ~ $*USAGE;
+        }
+    }
+}
+
+#-------------------------------------------------------------------------------
+sub check-arguments(@series, UInt:D $order)
+#-------------------------------------------------------------------------------
+{
+    my UInt $elements = @series.elems;
+
+    $elements > 1
+        or die "Invalid number of elements ($elements) in the series: must " ~
+               "be at least 2";
+
+    $order > 0
+        or die "Invalid order ($order): must be an integer > 0";
+
+    $order < $elements
+        or die "Invalid order ($order): a series of $elements elements " ~
+               "cannot have an order > { $elements - 1 }";
+}
+
+#-------------------------------------------------------------------------------
+sub ordinal(UInt:D $cardinal)
+#-------------------------------------------------------------------------------
+{
+    my $suffix  = 'th';
+    my $digit_0 =  $cardinal % 10;
+    my $digit_1 = ($cardinal / 10).floor % 10;
+
+    if ($digit_1 != 1)
+    {
+        $suffix = $digit_0 == 1 ?? 'st' !!
+                  $digit_0 == 2 ?? 'nd' !!
+                  $digit_0 == 3 ?? 'rd' !! 'th';
+    }
+
+    return $cardinal ~ $suffix;
+}
+
+################################################################################
diff --git a/challenge-023/athanasius/perl6/ch-2.p6 b/challenge-023/athanasius/perl6/ch-2.p6
new file mode 100644
index 0000000000..24048e5626
--- /dev/null
+++ b/challenge-023/athanasius/perl6/ch-2.p6
@@ -0,0 +1,92 @@
+use v6;
+
+################################################################################
+=begin comment
+
+Perl Weekly Challenge 023
+=========================
+
+Task #2
+-------
+Create a script that prints *Prime Decomposition* of a given number. The prime
+decomposition of a number is defined as a list of prime numbers which when all
+multiplied together, are equal to that number. For example, the Prime decomposi-
+tion of 228 is 2,2,3,19 as 228 = 2 * 2 * 3 * 19.
+
+=end comment
+################################################################################
+
+#--------------------------------------#
+# Copyright © 2019 PerlMonk Athanasius #
+#--------------------------------------#
+
+BEGIN say '';
+
+#===============================================================================
+sub MAIN(UInt:D $number )                                #= Unsigned integer > 1
+#===============================================================================
+{
+    die $*USAGE if $number <= 1;
+
+    say "The prime decomposition of $number is: ", factor($number).join(', ');
+
+    CATCH
+    {
+        default 
+        {
+            $*ERR.say: .message;
+        }
+    }
+}
+
+#-------------------------------------------------------------------------------
+sub factor(UInt:D $number)
+#-------------------------------------------------------------------------------
+{
+    my UInt $remainder = $number;
+    my      @factors;
+
+    MY-OUTER:
+    for 2 .. $number -> UInt $f
+    {
+        if $f.is-prime
+        {
+            while $remainder % $f == 0
+            {
+                @factors.push:  $f;
+                $remainder div= $f;
+
+                last MY-OUTER if $remainder == 1;
+            }
+        }
+    }
+
+    die "ERROR: for number $number, remainder is $remainder"
+        unless $remainder == 1;
+
+    return @factors;
+}
+
+################################################################################
+
+=begin note
+
+The label used in sub factor() was originally "OUTER:". Here is the explanation
+of the (cryptic!) error message that resulted:
+
+From https://perl6.eu/colonoscopy.html
+
+"Upper Case letters are normally used for labels, but this will cause an error
+if you happen to choose a name that is already in use internally by Perl 6. The
+label itself isn't a problem, as the trailing colon tells the compiler that it
+is a label. The usage, where it is used as a bareword causes the problem, and
+there is no way to fix it.
+
+Some examples:
+
+OUTER, which seems perfectly logical as a label name, will give the run time
+error («Cannot resolve caller next(OUTER:U); ...»), as OUTER is a built-in
+package name and Perl 6 isn't clever enough to spot that it is used as a label
+in this case."
+
+=end note