From: jnicholson@bowker.com (Jim Nicholson)
Newsgroups: comp.lang.pascal
Subject: Compression routines
Date: 25 Aug 92 13:54:24 GMT
Organization: Bowker Electronic Publishing, New Providence NJ

These were originally posted in the Fidonet PASCAL echo conference; I'm not
sure of the legal status, but the conference moderator tells me that any code
posted is considered in the PD . ..

(Uncompress is in the next message)

{*********************************************************************
* LZW2.PAS This program performs LZW compression on the input file   *
*   and writes the compressed data to the output file. It uses a     *
*   more efficient coding scheme than LZW.PAS from the Oct/Nov 1991  *
*   issue of ITP.                                                    *
* To run: LZW2 <infile> <outfile>                                    *
* Author  : David Reid, The Cobb Group                               *
* Last Revised : 12-31-91                                            *
*********************************************************************}

USES Dos,Crt;

CONST
                             {* This defines the string table size. *}
  LZWENTRIES = 8192;         {* You can change LZWENTRIES to 512,   *}
                             {* 1024, 2048, or 4096 as you see fit. *}
  MAXENTRIES = 256+LZWENTRIES;
  XOutMask : Word = $0080;        {* Points to next bit in xbitbuff *}
  XBitBuff : Word = 0;            {* Holds residual output bits     *}
  OutLength: Longint = 0;         {* Counter for bytes output       *}
  InLength : Longint = 0;         {* Counter for bytes input        *}
  EXIT_FAILURE = 1;               {* Error level return value       *}

{*----TYPE DEFINITIONS----------------------------------------------*}

TYPE
  RULEtag = RECORD           {* This structure holds one LZW string *}
                             {* table entry. It contains the prefix *}
    Prefix : Integer;        {* character, the suffix character,    *}
    Suffix : Integer;        {* and the linked-list pointer to the  *}
    Next   : Integer;        {* next table entry that starts with   *}
    END;                     {* the same prefix as this one does.   *}

{*----GLOBAL VARIABLES----------------------------------------------*}

VAR
  RULE    : RULEtag;
  Rules   : ARRAY[0..MAXENTRIES-1] OF RULEtag; {* The string table  *}
  Bitmask : Integer;         {* Controls size of input characters   *}
  Entries : Integer;         {* Number of entries in string table   *}
  InFile  : FILE;            {* Input file                          *}
  OutFile : FILE;            {* Output file                         *}

PROCEDURE FlushOutput; FORWARD;

{ Init - Checks command-line arguments, opens files, and displays an }
{ informational prompt.                                            }

PROCEDURE Init; BEGIN
  IF (ParamCount <>  2 ) THEN BEGIN
    WriteLn('syntax: LZW2 <infile> <outfile>');
    Halt(EXIT_FAILURE)
    END;
  {$I-}
  Assign(InFile, ParamStr(1));
  Reset(InFile,1);
  {$I+}
  IF IOResult <> 0 THEN BEGIN
    WriteLn('Error opening input file ', ParamStr(1));
    Halt(EXIT_FAILURE)
    END;
  {$I-}
  Assign(OutFile, ParamStr(2));
  Rewrite(OutFile,1);
  {$I+}
  IF IOResult <> 0 THEN BEGIN
    WriteLn('Error opening output file ', ParamStr(2));
    Halt(EXIT_FAILURE)
    END;
  WriteLn('Compressing ...') END;

{ Term - Flushes any residual bits out to the output file, closes    }
{   the files, and displays the file sizes and compression percent.  }

PROCEDURE Term; BEGIN
  FlushOutput;
  Close(InFile);
  Close(OutFile);
  WriteLn('Input file length : ',InLength:7,'  ',
          'Output file length: ',OutLength:7);
  WriteLn('Compressed: ',(100 - 100 * outlength/inlength):3:2); END;


{ Input - Reads one character from the input file and increments the }
{ global counter inlength.                                         }

FUNCTION Input: Integer; VAR
  Rval: Byte; BEGIN
  IF NOT Eof(InFile) THEN BEGIN
    BlockRead(InFile,Rval,1);
    Inc(InLength);
    Input := Rval
    END
  ELSE
    Input := -1 END;

{ Output - Writes a 9, 10, 11, 12, or 13 bit code to the output file.}
{ Stores any residual bits in the global variable xbitbuff. The    }
{   global variable xoutmask keeps track of the residual bits. The   }
{   local variable xinmask walks down the bits in newbits and helps  }
{   transfer them to xbitbuff. The starting value for xinmask comes  }
{   from the global variable Bitmask.                                }

PROCEDURE Output(NewBits: Integer); VAR
  XinMask : Word; BEGIN
  IF NewBits > 255 THEN BEGIN
    XinMask := Bitmask;
    NewBits := 255 - NewBits;
    END
  ELSE
    XinMask := $0100;
  WHILE XinMask <> 0 DO BEGIN
    IF (NewBits AND XinMask) <> 0 THEN
      XBitBuff := XBitBuff OR XOutMask;
    XinMask := XinMask SHR 1;
    XOutMask := XOutMask SHR 1;
    IF XOutMask = 0 THEN BEGIN
      BlockWrite(OutFile,XBitBuff,1);
      XBitBuff := 0;
      XOutMask := $0080;
      Inc(OutLength)
      END
    END END;

{ FlushOut - Forces all residual bits in xbitbuff to be written to   }
{   the output file.                                                 }

PROCEDURE FlushOutput; BEGIN
  IF XOutMask < $0080 THEN BEGIN
    BlockWrite(OutFile,XBitBuff,1);
    Inc(OutLength)
    END;
  XBitBuff := 0;
  XOutMask := $0080 END;

{ InitTable - Initializes the first 256 string table entries and     }
{   sets the globals Bitmask and Entries to their starting values.   }

PROCEDURE InitTable; BEGIN
  FOR Entries := 0 TO 255 DO BEGIN
    Rules[Entries].Prefix := -1;
    Rules[Entries].Suffix := Entries;
    Rules[Entries].Next := -1
    END;
  asm mov Bitmask, 2;
  mov Entries, 256; end; END;

{ IsInTable - Searches for the specified Prefix-Suffix pair in the   }
{ string table. If found, the pair's position in the table is      }
{   assigned to RuleNum. Returns TRUE if the pair is found or FALSE  }
{   if it isn't found.                                               }

FUNCTION IsInTable(Prefix,Suffix:Integer; VAR RuleNum:Integer): Boolean; VAR
  I : Integer; BEGIN
  I := Prefix;
  WHILE I <> -1 DO
    IF (Rules[I].Prefix = Prefix) AND (Rules[I].Suffix = Suffix) THEN
      BEGIN
        RuleNum := I;
        IsInTable := TRUE;
        Exit
      END
    ELSE
      I := Rules[I].Next;
  IsInTable := FALSE END;

{ AddEntry - Adds a Prefix-Suffix pair to the table. Shifts Bitmask  }
{   left one bit if necessitated by number of entries.               }

PROCEDURE AddEntry(Prefix,Suffix: Integer); BEGIN
  {*----Add Prefix/Suffix pair to the table----------------------*}
  Rules[Entries].Prefix := Prefix;
  Rules[Entries].Suffix := Suffix;
  {*----Update the table's linked list---------------------------*}
  Rules[Entries].Next := Rules[Prefix].Next;
  Rules[Prefix].Next := Entries;
  {*----Check for time to shift bitmask--------------------------*}
  Inc(Entries);
  IF Entries - 255 > Bitmask THEN
      Bitmask := Bitmask SHL 1 END;

{ Compress - Compresses the file. The outer while loop repeats each  }
{   time the table fills up (adaptive reset). The inner while loop   }
{   repeats for each character in the input file.                    }

PROCEDURE Compress; VAR
  Prefix    : Integer;
  Suffix    : Integer;
  NewPrefix : Integer; BEGIN
  Prefix := Input;
  WHILE Prefix <> -1 DO BEGIN
    InitTable;
    WHILE (Entries < MAXENTRIES) AND (Prefix <> -1) DO BEGIN
      Suffix := Input;
      IF IsInTable(Prefix, Suffix, NewPrefix) THEN
          Prefix := NewPrefix
      ELSE BEGIN
        Output(Prefix);
        AddEntry(Prefix, Suffix);
        Prefix := Suffix
        END
    END
  END END;

BEGIN
  Init;
  Compress;
  Term END.
Newsgroups: comp.lang.pascal