home *** CD-ROM | disk | FTP | other *** search
/ NetNews Usenet Archive 1992 #19 / NN_1992_19.iso / spool / comp / lang / pascal / 5049 < prev    next >
Encoding:
Internet Message Format  |  1992-08-25  |  7.6 KB

  1. Path: sparky!uunet!dtix!darwin.sura.net!jvnc.net!rutgers!cmcl2!psinntp!psinntp!bepcp!jnicholson
  2. From: jnicholson@bowker.com (Jim Nicholson)
  3. Newsgroups: comp.lang.pascal
  4. Subject: Compression routines
  5. Message-ID: <D6e3PB1w164w@bowker.com>
  6. Date: 25 Aug 92 13:54:24 GMT
  7. Organization: Bowker Electronic Publishing, New Providence NJ
  8. Lines: 214
  9.  
  10. These were originally posted in the Fidonet PASCAL echo conference; I'm not
  11. sure of the legal status, but the conference moderator tells me that any code
  12. posted is considered in the PD . ..
  13.  
  14. (Uncompress is in the next message)
  15.  
  16. {*********************************************************************
  17. * LZW2.PAS This program performs LZW compression on the input file   *
  18. *   and writes the compressed data to the output file. It uses a     *
  19. *   more efficient coding scheme than LZW.PAS from the Oct/Nov 1991  *
  20. *   issue of ITP.                                                    *
  21. * To run: LZW2 <infile> <outfile>                                    *
  22. * Author  : David Reid, The Cobb Group                               *
  23. * Last Revised : 12-31-91                                            *
  24. *********************************************************************}
  25.  
  26. USES Dos,Crt;
  27.  
  28. CONST
  29.                              {* This defines the string table size. *}
  30.   LZWENTRIES = 8192;         {* You can change LZWENTRIES to 512,   *}
  31.                              {* 1024, 2048, or 4096 as you see fit. *}
  32.   MAXENTRIES = 256+LZWENTRIES;
  33.   XOutMask : Word = $0080;        {* Points to next bit in xbitbuff *}
  34.   XBitBuff : Word = 0;            {* Holds residual output bits     *}
  35.   OutLength: Longint = 0;         {* Counter for bytes output       *}
  36.   InLength : Longint = 0;         {* Counter for bytes input        *}
  37.   EXIT_FAILURE = 1;               {* Error level return value       *}
  38.  
  39. {*----TYPE DEFINITIONS----------------------------------------------*}
  40.  
  41. TYPE
  42.   RULEtag = RECORD           {* This structure holds one LZW string *}
  43.                              {* table entry. It contains the prefix *}
  44.     Prefix : Integer;        {* character, the suffix character,    *}
  45.     Suffix : Integer;        {* and the linked-list pointer to the  *}
  46.     Next   : Integer;        {* next table entry that starts with   *}
  47.     END;                     {* the same prefix as this one does.   *}
  48.  
  49. {*----GLOBAL VARIABLES----------------------------------------------*}
  50.  
  51. VAR
  52.   RULE    : RULEtag;
  53.   Rules   : ARRAY[0..MAXENTRIES-1] OF RULEtag; {* The string table  *}
  54.   Bitmask : Integer;         {* Controls size of input characters   *}
  55.   Entries : Integer;         {* Number of entries in string table   *}
  56.   InFile  : FILE;            {* Input file                          *}
  57.   OutFile : FILE;            {* Output file                         *}
  58.  
  59. PROCEDURE FlushOutput; FORWARD;
  60.  
  61. { Init - Checks command-line arguments, opens files, and displays an }
  62. { informational prompt.                                            }
  63.  
  64. PROCEDURE Init; BEGIN
  65.   IF (ParamCount <>  2 ) THEN BEGIN
  66.     WriteLn('syntax: LZW2 <infile> <outfile>');
  67.     Halt(EXIT_FAILURE)
  68.     END;
  69.   {$I-}
  70.   Assign(InFile, ParamStr(1));
  71.   Reset(InFile,1);
  72.   {$I+}
  73.   IF IOResult <> 0 THEN BEGIN
  74.     WriteLn('Error opening input file ', ParamStr(1));
  75.     Halt(EXIT_FAILURE)
  76.     END;
  77.   {$I-}
  78.   Assign(OutFile, ParamStr(2));
  79.   Rewrite(OutFile,1);
  80.   {$I+}
  81.   IF IOResult <> 0 THEN BEGIN
  82.     WriteLn('Error opening output file ', ParamStr(2));
  83.     Halt(EXIT_FAILURE)
  84.     END;
  85.   WriteLn('Compressing ...') END;
  86.  
  87. { Term - Flushes any residual bits out to the output file, closes    }
  88. {   the files, and displays the file sizes and compression percent.  }
  89.  
  90. PROCEDURE Term; BEGIN
  91.   FlushOutput;
  92.   Close(InFile);
  93.   Close(OutFile);
  94.   WriteLn('Input file length : ',InLength:7,'  ',
  95.           'Output file length: ',OutLength:7);
  96.   WriteLn('Compressed: ',(100 - 100 * outlength/inlength):3:2); END;
  97.  
  98.  
  99. { Input - Reads one character from the input file and increments the }
  100. { global counter inlength.                                         }
  101.  
  102. FUNCTION Input: Integer; VAR
  103.   Rval: Byte; BEGIN
  104.   IF NOT Eof(InFile) THEN BEGIN
  105.     BlockRead(InFile,Rval,1);
  106.     Inc(InLength);
  107.     Input := Rval
  108.     END
  109.   ELSE
  110.     Input := -1 END;
  111.  
  112. { Output - Writes a 9, 10, 11, 12, or 13 bit code to the output file.}
  113. { Stores any residual bits in the global variable xbitbuff. The    }
  114. {   global variable xoutmask keeps track of the residual bits. The   }
  115. {   local variable xinmask walks down the bits in newbits and helps  }
  116. {   transfer them to xbitbuff. The starting value for xinmask comes  }
  117. {   from the global variable Bitmask.                                }
  118.  
  119. PROCEDURE Output(NewBits: Integer); VAR
  120.   XinMask : Word; BEGIN
  121.   IF NewBits > 255 THEN BEGIN
  122.     XinMask := Bitmask;
  123.     NewBits := 255 - NewBits;
  124.     END
  125.   ELSE
  126.     XinMask := $0100;
  127.   WHILE XinMask <> 0 DO BEGIN
  128.     IF (NewBits AND XinMask) <> 0 THEN
  129.       XBitBuff := XBitBuff OR XOutMask;
  130.     XinMask := XinMask SHR 1;
  131.     XOutMask := XOutMask SHR 1;
  132.     IF XOutMask = 0 THEN BEGIN
  133.       BlockWrite(OutFile,XBitBuff,1);
  134.       XBitBuff := 0;
  135.       XOutMask := $0080;
  136.       Inc(OutLength)
  137.       END
  138.     END END;
  139.  
  140. { FlushOut - Forces all residual bits in xbitbuff to be written to   }
  141. {   the output file.                                                 }
  142.  
  143. PROCEDURE FlushOutput; BEGIN
  144.   IF XOutMask < $0080 THEN BEGIN
  145.     BlockWrite(OutFile,XBitBuff,1);
  146.     Inc(OutLength)
  147.     END;
  148.   XBitBuff := 0;
  149.   XOutMask := $0080 END;
  150.  
  151. { InitTable - Initializes the first 256 string table entries and     }
  152. {   sets the globals Bitmask and Entries to their starting values.   }
  153.  
  154. PROCEDURE InitTable; BEGIN
  155.   FOR Entries := 0 TO 255 DO BEGIN
  156.     Rules[Entries].Prefix := -1;
  157.     Rules[Entries].Suffix := Entries;
  158.     Rules[Entries].Next := -1
  159.     END;
  160.   asm mov Bitmask, 2;
  161.   mov Entries, 256; end; END;
  162.  
  163. { IsInTable - Searches for the specified Prefix-Suffix pair in the   }
  164. { string table. If found, the pair's position in the table is      }
  165. {   assigned to RuleNum. Returns TRUE if the pair is found or FALSE  }
  166. {   if it isn't found.                                               }
  167.  
  168. FUNCTION IsInTable(Prefix,Suffix:Integer; VAR RuleNum:Integer): Boolean; VAR
  169.   I : Integer; BEGIN
  170.   I := Prefix;
  171.   WHILE I <> -1 DO
  172.     IF (Rules[I].Prefix = Prefix) AND (Rules[I].Suffix = Suffix) THEN
  173.       BEGIN
  174.         RuleNum := I;
  175.         IsInTable := TRUE;
  176.         Exit
  177.       END
  178.     ELSE
  179.       I := Rules[I].Next;
  180.   IsInTable := FALSE END;
  181.  
  182. { AddEntry - Adds a Prefix-Suffix pair to the table. Shifts Bitmask  }
  183. {   left one bit if necessitated by number of entries.               }
  184.  
  185. PROCEDURE AddEntry(Prefix,Suffix: Integer); BEGIN
  186.   {*----Add Prefix/Suffix pair to the table----------------------*}
  187.   Rules[Entries].Prefix := Prefix;
  188.   Rules[Entries].Suffix := Suffix;
  189.   {*----Update the table's linked list---------------------------*}
  190.   Rules[Entries].Next := Rules[Prefix].Next;
  191.   Rules[Prefix].Next := Entries;
  192.   {*----Check for time to shift bitmask--------------------------*}
  193.   Inc(Entries);
  194.   IF Entries - 255 > Bitmask THEN
  195.       Bitmask := Bitmask SHL 1 END;
  196.  
  197. { Compress - Compresses the file. The outer while loop repeats each  }
  198. {   time the table fills up (adaptive reset). The inner while loop   }
  199. {   repeats for each character in the input file.                    }
  200.  
  201. PROCEDURE Compress; VAR
  202.   Prefix    : Integer;
  203.   Suffix    : Integer;
  204.   NewPrefix : Integer; BEGIN
  205.   Prefix := Input;
  206.   WHILE Prefix <> -1 DO BEGIN
  207.     InitTable;
  208.     WHILE (Entries < MAXENTRIES) AND (Prefix <> -1) DO BEGIN
  209.       Suffix := Input;
  210.       IF IsInTable(Prefix, Suffix, NewPrefix) THEN
  211.           Prefix := NewPrefix
  212.       ELSE BEGIN
  213.         Output(Prefix);
  214.         AddEntry(Prefix, Suffix);
  215.         Prefix := Suffix
  216.         END
  217.     END
  218.   END END;
  219.  
  220. BEGIN
  221.   Init;
  222.   Compress;
  223.   Term END.
  224.