Re: Re: Any news on Compress::LZW?

[rcaputo]

This is that author speaking. Thanks for the e-mail! I'd be delighted if you used my code. It would be a wonderful way to commemorate the end of an error. :)

What you found on the web is probably hideously out of date, however. Here is the latest, self-testing version.

#!/usr/bin/perl -w

# Pure-perl LZW implementation.  The implementation is Copyright 2003
# by Rocco Caputo.  Where applicable, all rights are reserved.  The
# author makes no claim of rights to the LZW algorithm, which is
# patented by UniSys, or something.
#
# This implementation is being released under the same terms as Perl
# itself.

use warnings;
use strict;

my $original_char_stream = <<'EOS';
  Intra-universe security is easy enough.  Inter-universe security
  will be hard.  I have half an idea for something involving audit
  trails that may work.  It may be necessary to backtrack and validate
  an object recorded path before executing the object.  For example,
  imagine USENET if each host in the Path header was asked to vouch
  for the object having been there.  The ratio of positive answers
  over total hosts in the trail would determine a "percent of
  certainty".  Combined with an average "percent of trustability" for
  each host, the current universe would come up with a "total
  trustability" percent to test against a threshhold.
EOS

### Shared ###########################################################
+#########

my @code_stream;

### Encoding. ########################################################
+#########

{ my %dict;
  my $next_code = 256;
  $dict{chr $_} = $_ for 0..255;
  my $code = "";

  my $c_index = 0;
  while ($c_index < length($original_char_stream)) {
    my $next_char     = substr($original_char_stream, $c_index++, 1);
    my $possible_code = $code . $next_char;

    if (exists $dict{$possible_code}) {
      $code = $possible_code;
    }
    else {
      push @code_stream, $dict{$code};
      $dict{$possible_code} = $next_code++;
      $code = $next_char;
    }
  }

  push @code_stream, $dict{$code};
}

### Decoding. ########################################################
+#########

my $decoded_char_stream = "";

{ my %dict;
  my $next_code = 256;
  $dict{$_} = chr($_) for 0..255;

  my $code_word = shift @code_stream;
  $decoded_char_stream .= $dict{$code_word};

  while (@code_stream) {
    my $previous_word = $dict{$code_word};
    $code_word = shift @code_stream;

    if (exists $dict{$code_word}) {
      my $decoded_word = $dict{$code_word};
      $decoded_char_stream .= $decoded_word;
      $dict{$next_code++} =
        $previous_word . substr($decoded_word, 0, 1);
    }
    else {
      my $decoded_word = $previous_word . substr($previous_word, 0, 1)
+;
      $decoded_char_stream .= $decoded_word;
      $dict{$next_code++} = $decoded_word;
    }
  }
}

### Final test. ######################################################
+#########

if ($original_char_stream eq $decoded_char_stream) {
  print "Compressed and decompressed strings match! :)\n";
}
else {
  print "Compressed and decompressed strings don't match! :(\n";
}

-- Rocco Caputo - [e-mail] - poe.perl.org