Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/ECO30603.ZIP/ECO30603.LZH/ECOLIBII/ECO_LZW.PAS

Pascal/Delphi Source File | 1992-08-29 | 13.0 KB | 365 lines

unit eco_lzw;
{ lzwunit - defines the lzwobj object to compress and uncompress      }
{           files using the lzw compression algorithm                 }
{ if you would like to create a file with a copy of the string        }
{ table lzwunit used to compress the input file just define the       }
{ debugging value in the next line                                    }

{ $ D EFINE debugging}

{ ========================= } interface { =========================== }

uses dos,crt;

const
  maxtableentries = 3000;               {set size of string code table}


type
  tablebytes = (prefix,suffix,link);
  lzwobj = object
    inf,outf       : file;
    codetbl        : array[0..maxtableentries,prefix..link] of integer;
    hittbl         : array[0..maxtableentries] of integer;
    prefixcandidate: integer;
    suffixcandidate: integer;
    tablefull      : boolean;
    tabletop       : integer;
    constructor init;
    function    managetbl: integer; virtual;
    procedure   insertentry; virtual;
    function    inputuncompvalue: byte; virtual;
    function    inputcompvalue: integer; virtual;
    procedure   outputuncompvalue(b: byte); virtual;
    procedure   outputcompvalue(i: integer); virtual;
    procedure   compressfile(infile,outfile : pathstr);
    procedure   outputtable(f:pathstr); virtual;
    function    expandvalue(inputvalue : integer;
                         output     : boolean): integer; virtual;
    procedure   uncompressfile(infile,outfile : pathstr);
    destructor  compressdone;
  end;

{ ====================== } implementation { ========================= }


constructor lzwobj.init; {--------------------------------------------}
{  initializes the string code table with the atomic values           }
{    and the table management values tablefull, tabletop, hittbl[]    }
{  hittbl is an array that contains the head pointer for linked       }
{    lists (yes multiple lists) of compression code to facilitate     }
{    faster lookup of prefixcandidate-suffixcandidate pairs.          }
{  if hittbl[prefix value] = 0 then no p-s entries with the prefix    }
{    value have been added to the string table. if                    }
{    hittbl[prefix value] <> 0, it contains the entry number of the   }
{    first element in the string table with that prefix value         }
{  the codetbl[x,link] element will contain a 0 if the string table   }
{    does not have any other entries that start with the prefix in    }
{    codetbl[x,prefix], otherwise codetbl[x,link] points to the next  }
{    entry with a matching prefixcandidate value                      }
{---------------------------------------------------------------------}

var i : integer;
begin
  tablefull := false;
  tabletop := 255;
  for i := 0 to maxtableentries do begin
    hittbl[i] := 0;
    codetbl[i, link] := 0;
    if i > 255 then begin
      codetbl[i, prefix] := 0;
      codetbl[i, suffix] := 0
      end
    else begin
      codetbl[i, prefix] := -1;
      codetbl[i, suffix] := i
      end
    end
  end;


function lzwobj.managetbl: integer; {=================================}
{  managetbl searches the table for prefixcandidate-suffixcandidate   }
{    pairs of characters/codes. if the pair is not in the string      }
{    table, it adds them and updates the linked list (see init)       }
{    if the pair is found, it returns the entry number for the pair.  }
{=====================================================================}

var
  found,                {character pair found}
  endoflinks : boolean; {end of linked list found while searching list}
  curptr : integer;     {current element number in string table       }
begin

  found := false;       {initialize values}
  endoflinks := false;

  if hittbl[prefixcandidate] <> 0 then begin {entries exist for prefix}
    curptr := hittbl[prefixcandidate];  {trace list starting at head  }
    repeat
      if (codetbl[curptr,prefix] = prefixcandidate) and
         (codetbl[curptr,suffix] = suffixcandidate) then
         found := true
      else                                    {not found              }
        if codetbl[curptr,link] <> 0 then     {check if at end of list}
          curptr := codetbl[curptr,link]      {get next element to chk}
        else
          endoflinks := true                  {end of list            }
      until found or endoflinks
    end;

  if found then                               {if pair found          }
    managetbl := curptr                       {  return element #     }
  else begin                                  {otherwise, add to table}
    if not tablefull then begin
      inc(tabletop);
      insertentry;
      if hittbl[prefixcandidate] = 0 then     {adjust links           }
        hittbl[prefixcandidate] := tabletop
      else
        codetbl[curptr,link] := tabletop
      end;
    managetbl := -1;                          {not found signal       }
    end;
  end;


procedure lzwobj.insertentry; {---------------------------------------}
{ insert prefixcandidate-suffixcandidate into the next available      }
{   entry in the table                                                }
{---------------------------------------------------------------------}

begin
  codetbl[tabletop, prefix] := prefixcandidate;
  codetbl[tabletop, suffix] := suffixcandidate;
  if tabletop = maxtableentries then tablefull := true;
  end;

{---------------------------------------------------------------------}
{ the next four methods provide input and output for file i/o         }
{---------------------------------------------------------------------}

function lzwobj.inputuncompvalue: byte;
var
  b : byte;
begin
  blockread(inf, b, 1);
  inputuncompvalue := b
  end;

function lzwobj.inputcompvalue: integer;
var
  i : integer;
begin
  blockread(inf, i, 1);
  inputcompvalue := i
  end;

procedure lzwobj.outputuncompvalue(b: byte);
begin
  blockwrite(outf, b, 1)
  end;

procedure lzwobj.outputcompvalue(i: integer);
begin
  blockwrite(outf, i, 1)
  end;

procedure lzwobj.outputtable(f:pathstr); {----------------------------}
{ outputtable dumps a formatted list of the string table into the file}
{   specified in f.                                                   }
{---------------------------------------------------------------------}

var
  t : text;
  i : integer;
  j : tablebytes;
  s : string;
begin
  assign(t,f);
  rewrite(t);
  for i:= 256 to tabletop do begin
    write(t,i:4,'  ',
          codetbl[i,prefix]:4,'  ',
          codetbl[i,suffix]:4,'  ',
          codetbl[i,link]:4,'  ');
    for j := prefix to suffix do
      if (codetbl[i,j] < 255) and (codetbl[i,j] >= 32) then begin
        s := chr(byte(codetbl[i,j]));
        write(t,s,' ')
        end
      else
        write(t,'  ');
    writeln(t,' ')
    end;
  close(t)
  end;


procedure lzwobj.compressfile(infile,outfile : pathstr); {------------}
{  compressfile manages all the compression tasks                     }


{---------------------------------------------------------------------}

var
  ctr : longint;           {counter for onscreen display              }
  foundcode : integer;     {used to manage results from managetbl code}
begin

  assign(inf,infile);      {open input file as 1 byte/record file     }
  reset(inf,1);
  assign(outf,outfile);    {open output file as a 2 byte/record file  }
  rewrite(outf,2);         {  because we write out integers           }

  ctr := 0;

  prefixcandidate := inputuncompvalue;

  repeat
    inc(ctr);                          {manage counter display}
    if (ctr and 127) = 127 then begin
      gotoxy(10,10);
      write(ctr);
      end;

    suffixcandidate := inputuncompvalue;

    foundcode := managetbl;                 {search table for p-s pair}

    if foundcode >= 0 then                  {if pair found            }
      prefixcandidate := foundcode          {  go look for next pair  }
    else begin
      outputcompvalue(prefixcandidate);     {otherwise, output prefix }
      prefixcandidate := suffixcandidate    {  and reset for next pair}
      end
    until eof(inf);
  outputcompvalue(prefixcandidate);         {write last character out }

  {$IFDEF Debugging}
  outputtable('S:\COmpTbl.pas');
  {$ENDIF}

  end;


function lzwobj.expandvalue(inputvalue : integer; {-------------------}
                            output:boolean) : integer;
{  expandvalue expands compression codes. note, if the prefix value   }
{    retrieved in kprefix is another compression code, expandvalue    }
{    will recursively call itself until kprefix is an extended ascii  }
{    character.                                                       }
{                                                                     }
{  input:                                                             }
{    inputvalue is the value to expand                                }
{    output turns on/off writing of expanded characters to            }
{      file so you can retrieve (without writing) the first ascii     }
{      character at the head of the compressed character chain. this  }
{      becomes necessary when you must fill in the suffix value in    }
{      string table for adjacent prefix pointers.                     }
{  output:                                                            }
{    returns the character at the head of compressed byte chain when  }
{      you pass it a compressed byte. if you pass it an ascii         }
{      character, it returns that character. this made coding simpler }
{---------------------------------------------------------------------}

var
  kprefix, ksuffix, kreturned : integer;

 begin
  if inputvalue > 255 then begin                 {is compressed value?}
    kprefix := codetbl[inputvalue,prefix];       {yes, get table entry}
    ksuffix := codetbl[inputvalue,suffix];
    if kprefix > 255 then                        {if prefix is a      }
      kreturned := expandvalue(kprefix,output)   { compressed char    }
    else begin                                   { recursively call   }
      kreturned := kprefix;                      { expandvalue        }
      if output then outputuncompvalue(kprefix)  {otherwise, set head }
                                                 { value and output   }
                                                 { uncompressed bytes }
      end;                                       { to file if output  }
                                                 { set true           }
    if output then outputuncompvalue(ksuffix)
    end
  else
    kreturned := inputvalue; {return ascii value if passed ascii value}
  expandvalue := kreturned
  end;


procedure lzwobj.uncompressfile(infile,outfile : pathstr); {----------}
{ uncompresfile manages all aspects of uncompressing files            }
{---------------------------------------------------------------------}

var
  ctr : longint;                   {onscreen info                     }
  found : integer;                 {returned from managetbl routine   }
  dummy, suffixcopy, i :integer;

begin
  assign(inf,infile);            {open input file to read integers    }
  reset(inf,2);
  assign(outf,outfile);          {open output file to write characters}

  rewrite(outf,1);

  ctr := 0;

  prefixcandidate := inputcompvalue;

  repeat

    inc(ctr);                               {manage onscreen display  }
    if (ctr and 127) = 127 then begin
      gotoxy(10,10);
      write(ctr)
      end;

    if prefixcandidate < 256 then           {output an ascii character}
      outputuncompvalue(prefixcandidate);

    suffixcandidate := inputcompvalue;

    if suffixcandidate > 255 then begin     {compressed character?    }

      suffixcopy := suffixcandidate;   {save just in case we expand it}

      {handle special case when you need to expand an entry that you  }
      { have not yet added to table                                   }

      if tabletop + 1 = suffixcandidate then begin
        suffixcandidate := expandvalue(prefixcandidate,false);
        found := managetbl;
        suffixcandidate := suffixcopy;
        dummy := expandvalue(suffixcandidate,true);
        end
      else begin
        suffixcandidate := expandvalue(suffixcandidate,true); {normal }
        found := managetbl;                                   {expand }
        suffixcandidate := suffixcopy
        end
      end
    else
      found := managetbl;
    prefixcandidate := suffixcandidate
    until eof(inf);

  if prefixcandidate < 256 then            {output last character if  }
    outputuncompvalue(prefixcandidate);    { not a compressed code    }

  {$IFDEF Debugging}
  outputtable('S:\Ucomptbl.pas');
  {$ENDIF}
  end;


destructor lzwobj.compressdone; {-------------------------------------}
{ compressdone closes the files.                                      }
{---------------------------------------------------------------------}

begin
  close(inf);
  close(outf)
  end;
end.