Merge pull request #556 from randyl/week22

Solutions for task 1 and 2 in perl5 and perl6

5 files changed, 281 insertions, 0 deletions

diff --git a/challenge-022/randy-lauen/perl5/ch-1.pl b/challenge-022/randy-lauen/perl5/ch-1.pl
new file mode 100644
index 0000000000..9bfc8234a6
--- /dev/null
+++ b/challenge-022/randy-lauen/perl5/ch-1.pl
@@ -0,0 +1,18 @@
+#!/usr/bin/env perl
+
+use v5.26;
+use strict;
+use warnings;
+
+use Math::Prime::Util qw( prime_iterator is_prime );
+
+my @matches;
+my $it = prime_iterator();
+
+while ( @matches < 10 ) {
+    my $prime = $it->();
+    my $plus_six = $prime + 6;
+    push @matches, "$prime, $plus_six" if is_prime( $plus_six );
+}
+
+say join( "\n", @matches );
diff --git a/challenge-022/randy-lauen/perl5/ch-2.pl b/challenge-022/randy-lauen/perl5/ch-2.pl
new file mode 100644
index 0000000000..1ec6533f48
--- /dev/null
+++ b/challenge-022/randy-lauen/perl5/ch-2.pl
@@ -0,0 +1,98 @@
+#!/usr/bin/env perl
+
+=head1 SYNOPSIS
+
+Task:
+Write a script to implement Lempel–Ziv–Welch (LZW) compression algorithm. 
+The script should have method to encode/decode algorithm.
+
+This is a port of LZW-B found at https://marknelson.us/posts/2011/11/08/lzw-revisited.html.
+See C<test-lzw.pl> for how to test this program.
+
+=cut
+
+use strict;
+use warnings;
+use feature 'say';
+
+use Getopt::Long;
+
+use constant MAX_CODE => 32767;
+
+my $encode;
+my $decode;
+
+GetOptions(
+    'encode' => \$encode,
+    'decode' => \$decode,
+) or die "GetOptions failed";
+
+die "Must specify either --encode or --decode" unless $encode xor $decode;
+
+encode( $ARGV[0] ) if $encode;
+decode( $ARGV[0] ) if $decode;
+
+exit 0;
+
+
+sub encode {
+    my $file = shift;
+
+    open my $fh, '<:raw', $file or die $!;
+
+    my %codes = map { chr($_) => $_ } 0 .. 255;
+    my $next_code = 256;
+    my $current_string = '';
+
+    my $char;
+    while ( read($fh, $char, 1)  ) {
+        $current_string .= $char;
+        if ( !exists $codes{ $current_string } ) {
+            if ( $next_code <= MAX_CODE ) {
+                $codes{ $current_string } = $next_code++;
+            }
+            $current_string = substr( $current_string, 0, -1 );
+            print pack( 'S', $codes{ $current_string } );
+            $current_string = $char;
+        }
+    }
+
+    if ( length $current_string ) {
+        print pack( 'S', $codes{ $current_string} );
+    }
+
+    close $fh;
+
+    return;
+}
+
+
+sub decode {
+    my $file = shift;
+
+    open my $fh, '<:raw', $file or die $!;
+
+    my %strings = map { $_ => chr($_) } 0 .. 255;
+    my $previous_string = '';
+    my $next_code = 256;
+
+    my $code;
+    while ( read($fh, $code, 2)  ) {
+        $code = unpack( 'S', $code );
+        if ( !exists $strings{ $code } ) {
+            $strings{ $code } = $previous_string . substr($previous_string, 0, 1);
+        }
+        print $strings{ $code };
+        if ( length $previous_string && $next_code <= MAX_CODE ) {
+            $strings{ $next_code++ } = $previous_string . substr( $strings{ $code }, 0, 1 );
+        }
+        $previous_string = $strings{ $code };
+    }
+
+    close $fh;
+
+    return;
+}
+
+
+
diff --git a/challenge-022/randy-lauen/perl5/test-lzw.pl b/challenge-022/randy-lauen/perl5/test-lzw.pl
new file mode 100644
index 0000000000..bbfa398ffe
--- /dev/null
+++ b/challenge-022/randy-lauen/perl5/test-lzw.pl
@@ -0,0 +1,73 @@
+#!/usr/bin/env perl
+
+=head1 SYNOPSIS
+
+To test C<ch-2.pl>, do the following:
+* Download the Canterbury corpus at http://www.corpus.canterbury.ac.nz/descriptions/.
+* Extract it to a directory.
+* Run this script with that directory as an argument.
+
+Example output:
+
+    $ perl test-lzw.pl cantrbry/
+    +--------------+---------+------------+-------+
+    | File         | Size    | Compressed | Ratio |
+    +--------------+---------+------------+-------+
+    | alice29.txt  | 152089  | 70226      | 46.2% |
+    | asyoulik.txt | 125179  | 62748      | 50.1% |
+    | cp.html      | 24603   | 14948      | 60.8% |
+    | fields.c     | 11150   | 7084       | 63.5% |
+    | grammar.lsp  | 3721    | 2818       | 75.7% |
+    | kennedy.xls  | 1029744 | 365572     | 35.5% |
+    | lcet10.txt   | 426754  | 184752     | 43.3% |
+    | plrabn12.txt | 481861  | 218914     | 45.4% |
+    | ptt5         | 513216  | 70242      | 13.7% |
+    | sum          | 38240   | 25054      | 65.5% |
+    | xargs.1      | 4227    | 3584       | 84.8% |
+    +--------------+---------+------------+-------+
+
+=cut
+
+use strict;
+use warnings;
+use feature 'say';
+
+use Carp::Assert;
+use Path::Tiny;
+use File::Compare ();
+use Text::Table::Tiny ();
+
+my $dir = $ARGV[0] // '';
+die "'$dir' must be readable directory\n" unless -r -d $dir;
+
+my @rows = ( [ 'File', 'Size', 'Compressed', 'Ratio' ] );
+
+for my $file ( sort( path($dir)->children() ) ) {
+    my $basename = $file->basename;
+    my $encoded_file = "/tmp/$basename.encoded";
+    my $decoded_file = "/tmp/$basename.decoded";
+
+    system("perl ./ch-2.pl --encode $file > $encoded_file") == 0
+        or die "encoding failed: $?";
+
+    system("perl ./ch-2.pl --decode $encoded_file > $decoded_file") == 0
+        or die "decoding failed: $?";
+
+    if ( File::Compare::compare( $file, $decoded_file ) == 0 ) {
+        push @rows, [
+            $basename,
+            -s $file,
+            -s $encoded_file,
+            sprintf( "%.1f%%", 100 * ( (-s $encoded_file) / (-s $file) ) )
+        ],
+    }
+    else {
+        die "Files differ: $file, $decoded_file";
+    }
+}
+
+say Text::Table::Tiny::generate_table( rows => \@rows, header_row => 1 );
+
+exit 0;
+
+
diff --git a/challenge-022/randy-lauen/perl6/ch-1.p6 b/challenge-022/randy-lauen/perl6/ch-1.p6
new file mode 100644
index 0000000000..a16df8844c
--- /dev/null
+++ b/challenge-022/randy-lauen/perl6/ch-1.p6
@@ -0,0 +1,5 @@
+#!/usr/bin/env perl6
+
+# Task: Write a script to print first 10 Sexy Prime Pairs. Sexy primes are prime numbers that differ from each other by 6.
+
+say (1 .. Inf).map( { $_, $_+6 } ).flat.grep( { $^a.is-prime && $^b.is-prime } ).head(10).join("\n");
diff --git a/challenge-022/randy-lauen/perl6/ch-2.p6 b/challenge-022/randy-lauen/perl6/ch-2.p6
new file mode 100644
index 0000000000..80255a29c2
--- /dev/null
+++ b/challenge-022/randy-lauen/perl6/ch-2.p6
@@ -0,0 +1,87 @@
+#!/usr/bin/env perl6
+
+=begin SYNOPSIS
+
+Task:
+Write a script to implement Lempel–Ziv–Welch (LZW) compression algorithm.
+The script should have method to encode/decode algorithm.
+
+This script is a port of my Perl5 solution, which itself was a port of LZW-B at
+https://marknelson.us/posts/2011/11/08/lzw-revisited.html.
+
+Usage:
+    $ perl6 ch-2.p6 --encode file.txt > file.txt.encoded
+    $ perl6 ch-2.p6 --decode file.txt.encoded > file.txt.decoded
+
+=end SYNOPSIS
+
+use P5pack;
+
+constant $MAX-CODE = 32767;
+
+multi MAIN( Str $file where *.IO.r, Bool :$encode! ) {
+    encode( $file );
+}
+
+multi MAIN( Str $file where *.IO.r, Bool :$decode! ) {
+    decode( $file );
+}
+
+sub encode( Str $file ) {
+    my $fh = $file.IO.open( :bin );
+
+    my %codes = (^256).map: { .chr => $_ };
+    my $next-code = 256;
+    my $current-buffer = Buf.new;
+
+    while my $buf = $fh.read( 1 ) {
+        $current-buffer.append: $buf;
+        if  %codes{ $current-buffer.decode('latin1') }:!exists {
+            if $next-code <= $MAX-CODE {
+                %codes{ $current-buffer.decode('latin1') } = $next-code++;
+            }
+            $current-buffer.pop();
+
+            my $bytes = pack( 'S', %codes{ $current-buffer.decode('latin1') } );
+            $*OUT.write( $bytes );
+            $current-buffer = $buf;
+        }
+    }
+
+    if ( $current-buffer.bytes ) {
+        my $bytes = pack( 'S', %codes{ $current-buffer.decode('latin1') } );
+        $*OUT.write( $bytes );
+    }
+
+    $fh.close;
+
+    return;
+}
+
+
+sub decode( Str $file ) {
+    my $fh = $file.IO.open( :bin );
+
+    my %strings = (^256).map: { $_ => Buf.new( $_ ) };
+    my $previous = Buf.new;
+    my $next-code = 256;
+
+    while my $buf = $fh.read( 2 ) {
+        my $code = unpack( 'S', $buf );
+
+        if %strings{ $code }:!exists {
+            %strings{ $code } = Buf.new( $previous.list.flat, $previous[0] );
+        }
+        $*OUT.write( %strings{ $code } );
+        if ( $previous.bytes && $next-code <= $MAX-CODE ) {
+            %strings{ $next-code++ } = Buf.new( $previous.list.flat, %strings{ $code }[0] );
+        }
+        $previous = Buf.new( %strings{ $code } );
+    }
+
+    $fh.close;
+
+    return;
+}
+
+