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

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

4 files changed, 475 insertions, 0 deletions

diff --git a/challenge-022/athanasius/perl5/ch-1.pl b/challenge-022/athanasius/perl5/ch-1.pl
new file mode 100644
index 0000000000..ce5b40174b
--- /dev/null
+++ b/challenge-022/athanasius/perl5/ch-1.pl
@@ -0,0 +1,50 @@
+#!perl
+
+################################################################################
+=comment
+
+Perl Weekly Challenge 022
+=========================
+
+Task #1
+-------
+Write a script to print first *10 Sexy Prime Pairs*. Sexy primes are prime
+numbers that differ from each other by 6. For example, the numbers 5 and 11 are
+both sexy primes, because *11 - 5 = 6*. The term *"sexy prime"* is a pun
+stemming from the Latin word for six: sex. For more information, please checkout
+wiki [ https://en.wikipedia.org/wiki/Sexy_prime |page].
+
+=cut
+################################################################################
+
+#--------------------------------------#
+# Copyright © 2019 PerlMonk Athanasius #
+#--------------------------------------#
+
+use strict;
+use warnings;
+use feature           qw( say );
+use Const::Fast;
+use Math::Prime::Util qw( next_prime is_prime );
+
+const my $DIFFERENCE =>  6;
+const my $TARGET     => 10;
+
+MAIN:
+{
+    my @pairs;
+    my $prime = 1;
+
+    while (scalar @pairs < $TARGET)
+    {
+           $prime   = next_prime($prime);
+        my $partner = $prime + $DIFFERENCE;
+
+        push @pairs, [$prime, $partner] if is_prime($partner);
+    }
+
+    say "\nThe first $TARGET sexy prime pairs are:\n",
+         join(', ', map { sprintf '(%2d, %2d)', @$_ } @pairs);
+}
+
+################################################################################
diff --git a/challenge-022/athanasius/perl5/ch-2.pl b/challenge-022/athanasius/perl5/ch-2.pl
new file mode 100644
index 0000000000..04265f7bbc
--- /dev/null
+++ b/challenge-022/athanasius/perl5/ch-2.pl
@@ -0,0 +1,190 @@
+#!perl
+
+################################################################################
+=comment
+
+Perl Weekly Challenge 022
+=========================
+
+Task #2
+-------
+Write a script to implement *Lempel–Ziv–Welch (LZW)* compression algorithm. The
+script should have method to *encode/decode* algorithm. The wiki
+[ https://en.wikipedia.org/wiki/Lempel%E2%80%93Ziv%E2%80%93Welch |page] explains
+the compression algorithm very nicely.
+
+I must confess, it took me many years to get my head around the compression
+algorithm, I finally understood while doing research for the task. So thanks to
+*Perl Weekly Challenge*, I can proudly say that now I understand the compression
+algorithm. I hope you will enjoy this task as much as I did.
+
+=cut
+################################################################################
+
+#--------------------------------------#
+# Copyright © 2019 PerlMonk Athanasius #
+#--------------------------------------#
+
+use strict;
+use warnings;
+use Const::Fast;
+use Getopt::Long;
+
+const my $DICT_START =>    0;
+const my $DICT_END   =>  255;
+const my $USAGE      => "USAGE: perl $0 (--filename=<Str>|--string=<Str>) " .
+                        "[--max=<UInt: $DICT_END+>]\n";
+
+BEGIN
+{
+    $| = 1;
+    print "\n";
+}
+
+#===============================================================================
+MAIN:
+#===============================================================================
+{
+    my  @sizes;
+    my ($input,
+        $max_code) = init_input();
+        $sizes[0]  = length  $input;
+        $sizes[1]  = length  $sizes[0];
+    my ($lzw_aref,
+        $entries)  = encode( $input,    $max_code );
+        $sizes[2]  = scalar @$lzw_aref;
+    my  $decoded   = decode( $lzw_aref, $max_code );
+        $sizes[3]  = length  $decoded;
+
+    printf "Number of characters\n" .
+           "  Original: %d\n"       .
+           "  Encoded:  %*d\n"      .
+           "  Decoded:  %d\n", @sizes;
+
+    if ($sizes[3] == $sizes[0] && $decoded eq $input)
+    {
+        printf "\nEncoding/decoding successful\n" .
+                 "  Compression ratio:  %.1f\n"   .
+                 "  Space savings:      %.1f%%\n" .
+                 "  Dictionary entries: %d\n",
+               ($sizes[0] / $sizes[2]), (1 - ($sizes[2] / $sizes[0])) * 100,
+                $entries;
+    }
+    else
+    {
+        die "ERROR: Decoded string does not match original input\n";
+    }
+}
+
+#-------------------------------------------------------------------------------
+sub init_input
+#-------------------------------------------------------------------------------
+{
+    my ($filename, $string, $max_code);
+
+    GetOptions
+    (
+        'filename=s' => \$filename,
+        'string=s'   => \$string,
+        'max_code=i' => \$max_code,
+
+    ) or die $USAGE;
+
+    die $USAGE unless (defined $filename && $filename ne '') xor
+                      (defined $string   && $string   ne '');
+
+    die "Invalid max_code ($max_code)\n" . $USAGE
+        if defined $max_code && $max_code < $DICT_END;
+
+    if (defined $filename)
+    {
+        open my $fh, '<', $filename
+            or die "Cannot open file \"$filename\" for reading, stopped";
+
+        binmode $fh;        # Uses layer ":raw"
+        local   $/;         # Localized slurp mode
+        $string = <$fh>;
+
+        close $fh
+            or die "Cannot close file \"$filename\", stopped";
+    }
+    else
+    {
+        # Allow command-line specification of newline characters as literal "\n"
+
+        $string =~ s{ \\ n }{\r\n}gx;
+    }
+
+    return ($string, $max_code);
+}
+
+#===============================================================================
+sub encode
+#===============================================================================
+{
+    my ($input, $max) = @_;
+    my  %dictionary   = map { chr($_) => $_ } $DICT_START .. $DICT_END;
+    my  $next_code    = $DICT_END + 1;
+    my  $index        = 0;
+    my  $current      = '';
+    my  $character    = substr $input, $index++, 1;
+    my  @output;
+
+    until ($character eq '')
+    {
+        $current .= $character;
+
+        unless (exists $dictionary{$current})
+        {
+            $dictionary{$current} = $next_code++      # Add new dictionary entry
+                unless defined $max && $next_code > $max;
+
+            $current = substr $current, 0, -1;        # Remove last character
+
+            push @output, $dictionary{$current};
+
+            $current = $character;
+        }
+
+        $character = substr $input, $index++, 1;
+    }
+
+    push @output, $dictionary{$current};
+
+    return (\@output, scalar keys %dictionary);
+}
+
+#===============================================================================
+sub decode
+#===============================================================================
+{
+    my ($lzw_aref,
+        $max_code)  = @_;
+    my  @dictionary = map { chr($_) } $DICT_START .. $DICT_END;
+    my  $next_code  = $DICT_END + 1;
+    my  $previous   = '';
+    my  $output     = '';
+
+    for my $code (@$lzw_aref)
+    {
+        $dictionary[$code] = $previous . substr($previous, 0, 1)
+            if $code >= $next_code;
+
+        $output  .= $dictionary[$code];
+
+        $dictionary[$next_code++] = $previous . substr($dictionary[$code], 0, 1)
+            unless ($previous eq '') ||
+                   (defined $max_code && $next_code > $max_code);
+
+        $previous = $dictionary[$code];
+    }
+
+    return $output;
+}
+
+################################################################################
+
+__END__
+
+Reference: Mark Nelson, "LZW Data Compression Revisited" (8 Nov, 2011),
+           https://marknelson.us/posts/2011/11/08/lzw-revisited.html
diff --git a/challenge-022/athanasius/perl6/ch-1.p6 b/challenge-022/athanasius/perl6/ch-1.p6
new file mode 100644
index 0000000000..1f02f59dba
--- /dev/null
+++ b/challenge-022/athanasius/perl6/ch-1.p6
@@ -0,0 +1,47 @@
+use v6;
+
+################################################################################
+=begin comment
+
+Perl Weekly Challenge 022
+=========================
+
+Task #1
+-------
+Write a script to print first *10 Sexy Prime Pairs*. Sexy primes are prime
+numbers that differ from each other by 6. For example, the numbers 5 and 11 are
+both sexy primes, because *11 - 5 = 6*. The term *"sexy prime"* is a pun
+stemming from the Latin word for six: sex. For more information, please checkout
+wiki [ https://en.wikipedia.org/wiki/Sexy_prime |page].
+
+=end comment
+################################################################################
+
+#--------------------------------------#
+# Copyright © 2019 PerlMonk Athanasius #
+#--------------------------------------#
+
+my UInt constant $DIFFERENCE =  6;
+my UInt constant $TARGET     = 10;
+
+BEGIN say '';
+
+sub MAIN()
+{
+    my      @pairs;
+    my UInt $prime = 1;
+
+    while @pairs.elems < $TARGET
+    {
+        Nil until is-prime(++$prime);                      # Find the next prime
+
+        my UInt $partner = $prime + $DIFFERENCE;
+
+        @pairs.push( [$prime, $partner] ) if is-prime($partner);
+    }
+
+    say "The first $TARGET sexy prime pairs are:\n",
+         @pairs.map( { '(%2d, %2d)'.sprintf(@$_) } ).join(', ');
+}
+
+################################################################################
diff --git a/challenge-022/athanasius/perl6/ch-2.p6 b/challenge-022/athanasius/perl6/ch-2.p6
new file mode 100644
index 0000000000..768ccba763
--- /dev/null
+++ b/challenge-022/athanasius/perl6/ch-2.p6
@@ -0,0 +1,188 @@
+use v6;
+
+################################################################################
+=begin comment
+
+Perl Weekly Challenge 022
+=========================
+
+Task #2
+-------
+Write a script to implement *Lempel–Ziv–Welch (LZW)* compression algorithm. The
+script should have method to *encode/decode* algorithm. The wiki
+[ https://en.wikipedia.org/wiki/Lempel%E2%80%93Ziv%E2%80%93Welch |page] explains
+the compression algorithm very nicely.
+
+I must confess, it took me many years to get my head around the compression
+algorithm, I finally understood while doing research for the task. So thanks to
+*Perl Weekly Challenge*, I can proudly say that now I understand the compression
+algorithm. I hope you will enjoy this task as much as I did.
+
+=end comment
+################################################################################
+
+#--------------------------------------#
+# Copyright © 2019 PerlMonk Athanasius #
+#--------------------------------------#
+
+#
+# NB: This programme is a memory hog, and is therefore not suitable for use on
+#     large files
+#
+
+my UInt constant $DICT-START =   0;
+my UInt constant $DICT-END   = 255;
+
+BEGIN say '';
+
+#===============================================================================
+sub MAIN
+#===============================================================================
+(
+    Str  :$filename,    #= Name of file to compress
+    Str  :$string,      #= Text string to compress
+    UInt :$max-code,    #= Maximum dictionary entry value, minimum 255
+)
+{
+    my       @sizes;
+    my Str   $text     = init-input($filename, $string, $max-code);
+             @sizes[0] = $text.chars;
+             @sizes[1] = @sizes[0].chars;
+    my Array $lzw;
+    my UInt  $entries;
+      ($lzw, $entries) = encode($text, $max-code);
+             @sizes[2] = $lzw.elems;
+    my Str   $decoded  = decode($lzw,  $max-code);
+             @sizes[3] = $decoded.chars;
+
+    printf "Number of characters\n" ~
+           "  Original: %d\n"       ~
+           "  Encoded:  %*d\n"      ~
+           "  Decoded:  %d\n", @sizes;
+
+    if @sizes[3] == @sizes[0] && $decoded eq $text
+    {
+        printf "\nEncoding/decoding successful\n" ~
+                 "  Compression ratio:  %.1f\n"   ~
+                 "  Space savings:      %.1f%%\n" ~
+                 "  Dictionary entries: %d\n",
+               (@sizes[0] / @sizes[2]), (1 - (@sizes[2] / @sizes[0])) * 100,
+                $entries;
+    }
+    else
+    {
+        die "\nERROR: Decoded string does not match original input";
+    }
+
+    CATCH
+    {
+        default 
+        {
+            $*ERR.say: .message;
+        }
+    }
+}
+
+#-------------------------------------------------------------------------------
+sub init-input
+#-------------------------------------------------------------------------------
+(
+    Str   $filename,
+    Str   $string,
+    UInt  $max-code,
+--> Str:D
+)
+{
+    die $*USAGE
+        unless $filename.defined xor $string.defined;
+
+    die "Invalid max-code ($max-code)\n$*USAGE"
+        if $max-code.defined && $max-code < $DICT-END;
+
+    my Str $text;
+
+    if $filename.defined
+    {
+        $text = $filename.IO.slurp;
+    }
+    else
+    {
+        # Allow command-line specification of newline characters as literal "\n"
+
+        $text = S :g/ \\ n /\n/ given $string;
+    }
+
+    return $text;
+}
+
+#===============================================================================
+sub encode
+#===============================================================================
+(
+    Str:D  $text,
+    UInt   $max-code,
+--> List:D
+)
+{
+    my blob8 $text-buf   = $text.encode('ISO-8859-1');      # or 'ASCII'
+    my       %dictionary = ($DICT-START .. $DICT-END).map: { chr($_) => $_ }
+    my UInt  $next-code  =  $DICT-END + 1;
+    my Str   $current    = '';
+    my Array $output;
+
+    for 0 .. ($text-buf.elems - 1) -> UInt $index
+    {
+        my Str $character = $text-buf.read-uint8($index).chr;
+
+        $current ~= $character;
+
+        unless %dictionary{$current}:exists
+        {
+            %dictionary{$current} = $next-code++      # Add new dictionary entry
+                unless $max-code.defined && $next-code > $max-code;
+
+            $current = $current.chop;        # Remove last character
+
+            $output.push: %dictionary{$current};
+
+            $current = $character;
+        }
+    }
+
+    $output.push: %dictionary{$current};
+
+    return $output, %dictionary.elems;
+}
+
+#===============================================================================
+sub decode
+#===============================================================================
+(
+    Array:D $lzw,
+    UInt    $max-code,
+--> Str:D
+)
+{
+    my      @dictionary = ($DICT-START .. $DICT-END).map: { chr($_) };
+    my UInt $next-code  =  $DICT-END + 1;
+    my Str  $previous   = '';
+    my Str  $decoded    = '';
+
+    for @$lzw -> $code
+    {
+        @dictionary[$code] = $previous ~ $previous.substr(0, 1)
+            if $code >= $next-code;
+
+        $decoded ~= @dictionary[$code];
+
+        @dictionary[$next-code++] = $previous ~ @dictionary[$code].substr(0, 1)
+            unless ($previous eq '') ||
+                   ($max-code.defined && $next-code > $max-code);
+
+        $previous = @dictionary[$code];
+    }
+
+    return $decoded;
+}
+
+################################################################################