RogerBW's Blog

I've been doing the Perl Weekly Challenges. This one dealt with sexy primes and LZW encoding.

Yes, of course it's a pun: they're pairs of prime numbers separated by exactly 6. I borrowed my basic sieve of Eratosthenes from a previous challenge, then mapped the list into a hash for speed of lookup.

my $cap=110;
my $limit=6;

# Sieve of Eratosthenes to give us a prime list
my %n=map {$_ => 1} (2..$cap);
foreach my $f (2..int(sqrt($cap))) {
  map {($f<$_ && $_%$f == 0)?delete $n{$_}:0} keys %n;
}
my @p=sort {$a <=> $b} (keys %n);
my %p=map {$_ => 1} @p;

foreach my $p (@p) {
  my $q=$p+6;
  if (exists $p{$q}) {
    print "$p, $q\n";
    $limit--;
    unless ($limit) {
      last;
    }
  }
}

In perl6 we have the is-prime function, so we don't need the sieve. (Which is a shame, because it's an ideal use of the Set type.)

my $limit=6;

for (2..Inf) -> $p {
  if $p.is-prime {
    my $q=$p+6;
    if $q.is-prime {
      say "$p, $q";
      $limit--;
      unless ($limit) {
        last;
      }
    }
  }
}

The second part of the challenge was to implement LZW compression. I didn't work this up in perl6, but this seems to work reasonably well in 5.

my $lzw=Local::LZW->new('A'..'Z');
my $bitstr=$lzw->encode('TOBEORNOTTOBEORTOBEORNOT');
print $lzw->decode($bitstr),"\n";

package Local::LZW;
use List::Util qw(max);

The object is initialised with the dictionary.

sub new {
  my $class=shift;
  my $self={};
  bless $self,$class;
  my $alphabet=join('',@_) or die "Specify alphabet\n";
  my @dec=split '',$alphabet;
  unshift @dec,'#STOP#'; # yes, I know this is bad
  $self->{encode}={map {$dec[$_] => $_} (0..$#dec)};
  return $self;
}

This pretty much follows the flow of the Wikipedia example.

sub encode {
  my $self=shift;
  my @inchars=split '',shift;
  push @inchars,'#STOP#';
  my @out;
  my %dict=%{$self->{encode}};
  my $l=int(log(scalar keys %dict)/log(2))+1 ;
  while (@inchars) {
    if ($inchars[0] eq '#STOP#') {
      last;
    }
    my $n=0;
    while ($#inchars > $n && exists $dict{join('',@inchars[0..$n])}) {
      $n++;
    }
    if ($n>0) {
      push @out,[$dict{join('',@inchars[0..$n-1])},$l];
    }
    my $di=scalar keys %dict;
    $l=max(int(log($di)/log(2))+1,$l);
    $dict{join('',@inchars[0..$n])}=$di;
    splice @inchars,0,$n;
  }
  push @out,[$self->{encode}{'#STOP#'},$l];

Perversely, the hardest thing to get right was the variable-length binary encoding. Well, encoding it isn't too hard…

  my $bins=join('',map {sprintf('%0'.$_->[1].'b',$_->[0])} @out);
  my $ll=length($bins)%8;
  if ($ll>0) {
    $bins .= '0' x (8-$ll);
  }
  return pack('B*',$bins);
}

But now we have to decode it, and that's a bit of a pain.

sub decode {
  my $self=shift;
  my $bitstr=shift;
  my %dict=%{$self->{encode}};
  my %decode=map {$dict{$_} => $_} keys %dict;
  my $l=int(log(scalar keys %dict)/log(2))+1 ;
  my @bins=split '',join('',map {sprintf('%08B',ord($_))} split '',$bitstr);
  my @out;
  my $conj='';
  while (@bins) {
    my @d=splice @bins,0,$l;
    while (scalar @d < 8) {
      unshift @d,'0';
    }
    my $b=pack('B*',join('',@d));
    my $code=ord($b);

From this point on it's relatively sensible. My "$conj" is the conjectured dictionary entry without the final character (which at this point is unknown).

    unless (exists $decode{$code}) {
      die "unable to decode $code\n";
    }
    if ($decode{$code} eq '#STOP#') {
      last;
    }
    push @out,$decode{$code};
    if ($conj) {
      my $nd=$conj.substr($out[-1],0,1);
      my $di=scalar keys %decode;
      $l=max(int(log($di+1)/log(2))+1,$l);
      $decode{$di}=$nd;
    }
    $conj=$out[-1];
  }
  return join('',@out);
}