#!/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";
}
[download]

-- Rocco Caputo - troc@pobox.com - poe.perl.org