Lossless English language text compression challenge
Perl 5, 3651284



Just a simple word-based dictionary scheme. Analyzes the word frequency of
the corpus, and uses that to determine whether to use one or two bytes of
overhead per word. Uses two special symbols for the bytes \0 and \1 since
they do not appear in the corpus. There are plenty of other symbols that
could be used. This was not done. Does not do any huffman encoding or any
of that jazz.

Compression script shakespeare.pl:

use strict;
use warnings;
use bytes;

my $text = join "", &lt;&gt;;
my @words = split/([^a-zA-Z0-9]+)/, $text;


my %charfreq;
for( my $i = 0; $i&lt;length($text); ++$i ) {
    $charfreq{ substr($text, $i, 1) }++
}
for my $i ( 0..255 ) {
    my $c = chr($i);
    my $cnt = $charfreq{$c} // 0;
}



my %word_freq;
foreach my $word ( @words ) {
    $word_freq{ $word }++;
}


my $cnt = 0;
my ( @dict, %rdict );
foreach my $word ( sort { $word_freq{$b} &lt;=&gt; $word_freq{$a} || $b cmp $a } keys %word_freq ) {
    last if $word_freq{ $word } == 1; 


    my $repl_length = $cnt &lt; 127 ? 2 : 3;
    if( length( $word ) &gt; $repl_length ) {
        push @dict, $word;
        $rdict{ $word } = $cnt;
        $cnt++;
    }
}


foreach my $index ( 0..$
    print "$dict[$index]\0";
}
print "\1";


foreach my $word ( @words ) {
    my $index = $rdict{ $word };
    if ( defined $index &amp;&amp; $index &lt;= 127 ) {
        print "\0" . chr( $index );
    } elsif ( defined $index ) {
        my $byte1 = $index &amp; 127;
        my $byte2 = $index &gt;&gt; 7;
        print "\1" . chr( $byte2 ) . chr( $byte1 );
    } else {
        print $word;
    }
}


Decompression script deshakespeare.pl:

use strict;
use warnings;
use bytes;

local $/;
my $compressed = &lt;&gt;;
my $text = $compressed;
$text =~ s/^.+?\x{1}//ms;
my $dictionary = $compressed;
$dictionary =~ s/\x{1}.*$//ms;


my $cnt = 0;
my @dict;
foreach my $word ( split "\0", $dictionary ) {

    push @dict, $word;
}


my @words = split /(\x{0}.|\x{1}..)/ms, $text;
foreach my $word ( @words ) {
    if( $word =~ /^\x{0}(.)/ms ) {
        print $dict[ ord( $1 ) ];
    } elsif( $word =~ /^\x{1}(.)(.)/ms ) {
        my $byte1 = ord( $1 );
        my $byte2 = ord( $2 );
        my $index = ( $byte1 &lt;&lt; 7 ) + $byte2;
        print $dict[ $index ];
    } else {
        print $word;
    }
}


Run using:

perl shakespeare.pl &lt; pg100.txt &gt;pg100.txt.compressed
perl deshakespeare.pl &lt;pg100.txt.compressed &gt;pg100.txt.restored
diff pg100.txt pg100.txt.restored