RogerBW's Blog

Perl Weekly Challenge 22 24 August 2019

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);
}

Add A Comment

Your Name
Your Email
Your Comment

Your submission will be ignored if any field is left blank, but your email address will not be displayed. Comments will be processed through markdown.

Search
Archive
Tags 1920s 1930s 1940s 1950s 1960s 1970s 1980s 1990s 2000s 2010s 3d printing action aeronautics aikakirja anecdote animation anime army astronomy audio audio tech base commerce battletech beer boardgaming bookmonth chain of command children chronicle church of no redeeming virtues cold war comedy computing contemporary cornish smuggler cosmic encounter coup cycling dead of winter doctor who documentary drama driving drone ecchi economics espionage essen 2015 essen 2016 essen 2017 essen 2018 existential risk falklands war fandom fantasy film firefly first world war flash point food garmin drive gazebo geodata gin gurps gurps 101 harpoon historical history horror hugo 2014 hugo 2015 hugo 2016 hugo 2017 hugo 2018 hugo 2019 hugo-nebula reread in brief avoid instrumented life kickstarter learn to play leaving earth linux mecha men with beards museum mystery naval non-fiction one for the brow opera perl perl weekly challenge photography podcast politics powers prediction privacy project woolsack pyracantha quantum rail ranting raspberry pi reading reading boardgames social real life restaurant reviews romance rpg a day rpgs science fiction scythe second world war security shipwreck simutrans smartphone south atlantic war squaddies stationery steampunk stuarts suburbia superheroes suspense television the resistance thirsty meeples thriller tin soldier torg toys trailers travel vietnam war war wargaming weather wives and sweethearts writing about writing x-wing young adult
Special All book reviews, All film reviews
Produced by aikakirja v0.1