Merge pull request #399 from PerlMonk-Athanasius/branch-for-challenge-017

Perl 5 and Perl 6 solutions to Tasks 1 & 2 of Challenge #017

4 files changed, 467 insertions, 0 deletions

diff --git a/challenge-017/athanasius/perl5/ch-1.pl b/challenge-017/athanasius/perl5/ch-1.pl
new file mode 100644
index 0000000000..797da48cd4
--- /dev/null
+++ b/challenge-017/athanasius/perl5/ch-1.pl
@@ -0,0 +1,83 @@
+#!perl
+
+################################################################################
+=comment
+
+Perl Weekly Challenge 017
+=========================
+
+Task #1
+-------
+
+Create a script to demonstrate Ackermann function. The Ackermann function is
+defined as below, m and n are positive number:
+
+  A(m, n) = n + 1                  if m = 0
+  A(m, n) = A(m - 1, 1)            if m > 0 and n = 0
+  A(m, n) = A(m - 1, A(m, n - 1))  if m > 0 and n > 0
+
+Example expansions as shown in
+[ https://en.wikipedia.org/wiki/Ackermann_function |wiki page].
+
+  A(1, 2) = A(0, A(1, 1))
+          = A(0, A(0, A(1, 0)))
+          = A(0, A(0, A(0, 1)))
+          = A(0, A(0, 2))
+          = A(0, 3)
+          = 4
+
+=cut
+################################################################################
+
+#--------------------------------------#
+# Copyright © 2019 PerlMonk Athanasius #
+#--------------------------------------#
+
+use strict;
+use warnings;
+use Const::Fast;
+use Getopt::Long;
+use Memoize;
+
+const my @DEFAULT => (1, 2);
+
+my $recs;
+
+MAIN:
+{
+        $recs   = 0;
+    my ($m, $n) = @DEFAULT;
+    my  $mem    = 0;
+
+    GetOptions
+    (
+        'm=i'    => \$m,
+        'n=i'    => \$n,
+         memoize => \$mem,
+
+    ) or die "\nError in command line arguments\n";
+
+    memoize('A') if $mem;
+
+    printf "\nA(%d, %d) = %d (recursions: %d with%s memoization)\n",
+            $m, $n, A($m, $n), $recs, $mem ? '' : 'out';
+}
+
+{
+    no warnings 'recursion';
+
+    sub A
+    {
+        my ($m, $n) = @_;
+
+        ++$recs;
+
+        return   $n + 1     if $m == 0;
+
+        return A($m - 1, 1) if $n == 0;
+
+        return A($m - 1, A($m, $n - 1));
+    }
+}
+
+################################################################################
diff --git a/challenge-017/athanasius/perl5/ch-2.pl b/challenge-017/athanasius/perl5/ch-2.pl
new file mode 100644
index 0000000000..44db92368e
--- /dev/null
+++ b/challenge-017/athanasius/perl5/ch-2.pl
@@ -0,0 +1,156 @@
+#!perl
+
+################################################################################
+=comment
+
+Perl Weekly Challenge 017
+=========================
+
+Task #2
+-------
+
+Create a script to parse URL and print the components of URL. According to
+[ https://en.wikipedia.org/wiki/URL |Wiki page], the URL syntax is as below:
+
+  scheme:[//[userinfo@]host[:port]]path[?query][#fragment]
+
+For example: jdbc://user:password@localhost:3306/pwc?profile=true#h1
+
+  scheme:   jdbc
+  userinfo: user:password
+  host:     localhost
+  port:     3306
+  path:     /pwc
+  query:    profile=true
+  fragment: h1
+
+=cut
+################################################################################
+
+#--------------------------------------#
+# Copyright © 2019 PerlMonk Athanasius #
+#--------------------------------------#
+
+use strict;
+use warnings;
+use Const::Fast;
+use Try::Tiny;
+use URI::Split qw( uri_split );
+
+const my $DEFAULT_URL =>
+         'jdbc://user:password@localhost:3306/pwc?profile=true#h1';
+
+MAIN:
+{
+    my $url = $ARGV[0] // $DEFAULT_URL;
+
+    try
+    {
+        my ($scheme, $authority, $path, $query, $fragment) = uri_split($url);
+
+        validate_scheme($scheme);
+
+        my ($userinfo, $host, $port) = parse_authority($authority);
+
+        display_url($url,  $scheme, $authority, $userinfo, $host,
+                    $port, $path,   $query,     $fragment);
+    }
+    catch
+    {
+        warn "\nError parsing URL \"$url\":\n$_";
+    }
+}
+
+# SCHEME: A non-empty scheme component followed by a colon (:), consisting of a
+# sequence of characters beginning with a letter and followed by any combination
+# of letters, digits, plus (+), period (.), or hyphen (-).
+
+sub validate_scheme
+{
+    my ($scheme) = @_;
+
+    $scheme
+        or  die "Empty scheme\n";
+
+    $scheme =~ / ^ ( [^A-Za-z] ) /x
+        and die "Invalid initial character \"$1\" in scheme \"$scheme\"\n";
+
+    $scheme =~ /   ( [^A-Za-z0-9+.-] ) /x
+        and die "Invalid character \"$1\" in scheme \"$scheme\"\n";
+}
+
+# AUTHORITY: An optional authority component preceded by two slashes (//)...
+
+sub parse_authority
+{
+    my ($authority) = @_;
+    my ($userinfo, $host, $port);
+
+    if ($authority)
+    {
+        $authority =~ s{ ^ // }{}x;
+
+        # USERINFO: An optional userinfo subcomponent that may consist of a user
+        # name and an optional password preceded by a colon (:), followed by an
+        # at symbol (@). Use of the format username:password in the userinfo
+        # subcomponent is deprecated for security reasons. Applications should
+        # not render as clear text any data after the first colon (:) found
+        # within a userinfo subcomponent unless the data after the colon is the
+        # empty string (indicating no password).
+        
+        if ($authority =~ /@/)
+        {
+            ($userinfo, $authority) = split /@/, $authority, 2;
+
+            if ($userinfo =~ /:/)
+            {
+                my ($username, $password) = split /:/, $userinfo, 2;
+
+                $userinfo = $username . ':' . '*' x length($password);
+            }
+        }
+
+        # PORT: An optional port subcomponent preceded by a colon (:).
+
+        if ($authority =~ /:/)
+        {
+            ($host, $port) = split /:/, $authority, 2;
+        }
+        else
+        {
+            $host = $authority;
+        }
+    }
+
+    return ($userinfo, $host, $port);
+}
+
+sub display_url
+{
+    my ($url,  $scheme, $authority, $userinfo, $host,
+        $port, $path,   $query,     $fragment) = @_;
+
+    $_    //= '(none)' for ($userinfo, $host, $port, $query, $fragment);
+    $path ||= '(empty)';
+
+    print "\nURL: $url\n" .
+          "\nScheme:     $scheme";
+
+    if ($authority)
+    {
+        print "\nAuthority:"            .
+              "\n  Userinfo: $userinfo" .
+              "\n  Host:     $host"     .
+              "\n  Port:     $port";
+    }
+    else
+    {
+        print "\nAuthority:  (none)";
+    }
+
+    print "\nPath:       $path"  .
+          "\nQuery:      $query" .
+          "\nFragment:   $fragment\n";
+}
+
+################################################################################
diff --git a/challenge-017/athanasius/perl6/ch-1.p6 b/challenge-017/athanasius/perl6/ch-1.p6
new file mode 100644
index 0000000000..fc9f24496a
--- /dev/null
+++ b/challenge-017/athanasius/perl6/ch-1.p6
@@ -0,0 +1,71 @@
+use v6;
+
+################################################################################
+=begin comment
+
+Perl Weekly Challenge 017
+=========================
+
+Task #1
+-------
+
+Create a script to demonstrate Ackermann function. The Ackermann function is
+defined as below, m and n are positive number:
+
+  A(m, n) = n + 1                  if m = 0
+  A(m, n) = A(m - 1, 1)            if m > 0 and n = 0
+  A(m, n) = A(m - 1, A(m, n - 1))  if m > 0 and n > 0
+
+Example expansions as shown in
+[ https://en.wikipedia.org/wiki/Ackermann_function |wiki page].
+
+  A(1, 2) = A(0, A(1, 1))
+          = A(0, A(0, A(1, 0)))
+          = A(0, A(0, A(0, 1)))
+          = A(0, A(0, 2))
+          = A(0, 3)
+          = 4
+
+=end comment
+################################################################################
+
+#--------------------------------------#
+# Copyright © 2019 PerlMonk Athanasius #
+#--------------------------------------#
+
+use Memoize;
+
+my UInt constant $DEFAULT-M  = 1;
+my UInt constant $DEFAULT-N  = 2;
+my UInt          $recursions = 0;
+
+sub MAIN
+(
+    UInt:D :$m             = $DEFAULT-M,
+    UInt:D :$n             = $DEFAULT-N,
+    Bool:D :memoize(:$mem) = False,
+)
+{
+    memoize(&ackermann) if $mem;
+
+    say "\nA($m, $n) = { ackermann($m, $n) } (recursions: $recursions with",
+         $mem ?? '' !! 'out', ' memoization)';
+}
+
+sub ackermann
+(
+    UInt:D $m,
+    UInt:D $n,
+--> UInt:D
+)
+{
+    ++$recursions;
+
+    return $n + 1               if $m == 0;
+
+    return ackermann($m - 1, 1) if $n == 0;
+
+    return ackermann($m - 1, ackermann($m, $n - 1));
+}
+
+################################################################################
diff --git a/challenge-017/athanasius/perl6/ch-2.p6 b/challenge-017/athanasius/perl6/ch-2.p6
new file mode 100644
index 0000000000..ea8e988e5a
--- /dev/null
+++ b/challenge-017/athanasius/perl6/ch-2.p6
@@ -0,0 +1,157 @@
+use v6;
+
+################################################################################
+=begin comment
+
+Perl Weekly Challenge 017
+=========================
+
+Task #2
+-------
+
+Create a script to parse URL and print the components of URL. According to
+[ https://en.wikipedia.org/wiki/URL |Wiki page], the URL syntax is as below:
+
+  scheme:[//[userinfo@]host[:port]]path[?query][#fragment]
+
+For example: jdbc://user:password@localhost:3306/pwc?profile=true#h1
+
+  scheme:   jdbc
+  userinfo: user:password
+  host:     localhost
+  port:     3306
+  path:     /pwc
+  query:    profile=true
+  fragment: h1
+
+=end comment
+################################################################################
+
+#--------------------------------------#
+# Copyright © 2019 PerlMonk Athanasius #
+#--------------------------------------#
+
+use URI::Split:from<Perl5> <uri_split>;
+
+my Sub $uri-split := &URI::Split::uri_split;
+
+my Str constant $DEFAULT-URL =
+                'jdbc://user:password@localhost:3306/pwc?profile=true#h1';
+
+sub MAIN(Str:D $url = $DEFAULT-URL)
+{
+    my ($scheme, $authority, Str $path, $query, $fragment) = $uri-split($url);
+
+    die 'Empty scheme' unless $scheme;
+    validate-scheme($scheme);
+
+    my ($userinfo, $host, $port);
+       ($userinfo, $host, $port) = parse-authority($authority) if $authority;
+
+    $authority //= '';
+    $_         //= '(none)' for $userinfo, $host, $port, $query, $fragment;
+    $path      ||= '(empty)';
+
+    display-url($url,  $scheme, $authority, $userinfo, $host,
+                $port, $path,   $query,     $fragment);
+
+    CATCH
+    {
+        default
+        {
+            $*ERR.say: "\nError parsing URL \"$url\":";
+            $*ERR.say: .message;
+        }
+    }
+}
+
+sub validate-scheme(Str:D $scheme)
+{
+    if $scheme ~~ / ^ ( <-[A..Za..z]> ) /
+    {
+        die "Invalid initial character \"$0\" in scheme \"$scheme\"";
+    }
+
+    if $scheme ~~ /   ( <-[A..Za..z0..9+.-]> ) /
+    {
+        die "Invalid character \"$0\" in scheme \"$scheme\"";
+    }
+}
+
+sub parse-authority(Str:D $authority is rw --> List)
+{
+    my ($userinfo, $host, $port);
+
+    if $authority
+    {
+        $authority ~~ s{ ^ \/\/ } = '';
+
+        # USERINFO: An optional userinfo subcomponent that may consist of a user
+        # name and an optional password preceded by a colon (:), followed by an
+        # at symbol (@). Use of the format username:password in the userinfo
+        # subcomponent is deprecated for security reasons. Applications should
+        # not render as clear text any data after the first colon (:) found
+        # within a userinfo subcomponent unless the data after the colon is the
+        # empty string (indicating no password).
+
+        if ($authority ~~ /\@/)
+        {
+            ($userinfo, $authority) = split /\@/, $authority, 2;
+
+            if ($userinfo ~~ /\:/)
+            {
+                my ($username, $password) = split /\:/, $userinfo, 2;
+
+                $userinfo = $username ~ ':' ~ '*' x $password.chars;
+            }
+        }
+
+        # PORT: An optional port subcomponent preceded by a colon (:).
+
+        if ($authority ~~ /\:/)
+        {
+            ($host, $port) = split /\:/, $authority, 2;
+        }
+        else
+        {
+            $host = $authority;
+        }
+    }
+
+    return ($userinfo, $host, $port);
+}
+
+sub display-url
+(
+    Str:D $url,
+    Str:D $scheme,
+    Str:D $authority,
+    Str:D $userinfo,
+    Str:D $host,
+    Str:D $port,
+    Str:D $path,
+    Str:D $query,
+    Str:D $fragment
+)
+{
+    say "\nURL: $url\n" ~
+        "\nScheme:     $scheme";
+
+    if ($authority)
+    {
+        say "Authority:\n"            ~
+            "  Userinfo: $userinfo\n" ~
+            "  Host:     $host\n"     ~
+            "  Port:     $port";
+    }
+    else
+    {
+        say "Authority:  (none)";
+    }
+
+    say "Path:       $path\n"  ~
+        "Query:      $query\n" ~
+        "Fragment:   $fragment";
+}
+
+################################################################################