Power-Programmierung/CD1.mdf/pascal/library/dos/tug__002/dearclzw.pas

Pascal/Delphi Source File | 1988-08-08 | 13.9 KB | 669 lines

{TUG PDS CERT 1.01 (Pascal)

==========================================================================

                  TUG PUBLIC DOMAIN SOFTWARE CERTIFICATION

The Turbo User Group (TUG) is recognized by Borland International as the
official support organization for Turbo languages.  This file has been
compiled and verified by the TUG library staff.  We are reasonably certain
that the information contained in this file is public domain material, but
it is also subject to any restrictions applied by its author.

This diskette contains PROGRAMS and/or DATA determined to be in the PUBLIC
DOMAIN, provided as a service of TUG for the use of its members.  The
Turbo User Group will not be liable for any damages, including any lost
profits, lost savings or other incidental or consequential damages arising
out of the use of or inability to use the contents, even if TUG has been
advised of the possibility of such damages, or for any claim by any
other party.

To the best of our knowledge, the routines in this file compile and function
properly in accordance with the information described below.

If you discover an error in this file, we would appreciate it if you would
report it to us.  To report bugs, or to request information on membership
in TUG, please contact us at:

             Turbo User Group
             PO Box 1510
             Poulsbo, Washington USA  98370

--------------------------------------------------------------------------
                       F i l e    I n f o r m a t i o n

* DESCRIPTION
Turbo Pascal V4.0 DEARC Lempel-Ziv-Welch decompression routines (that is,
unsquashing and uncrunching).

* ASSOCIATED FILES
DEARC.PAS
DEARCABT.PAS
DEARCGLB.PAS
DEARCIO.PAS
DEARCLZW.PAS
DEARCUNP.PAS
DEARCUSQ.PAS
DEARC.TXT

* CHECKED BY
DRM 08/08/88

* KEYWORDS
TURBO PASCAL V4.0

==========================================================================
}
(**
 *
 *  Module:       dearclzw.pas
 *  Description:  DEARC Lempel-Ziv-Welch decompression routines
 *                (that is,  unsquashing and uncrunching)
 *
 *  Revision History:
 *    7-26-88: unitized for Turbo v4.0
 *
**)


unit dearclzw;

interface
uses
  dearcabt,
  dearcglb,
  dearcio,
  dearcunp;

procedure init_ucr ( i : integer );
function getc_ucr : integer;
procedure decomp ( SquashFlag : integer );

implementation

(*
 *  definitions for uncrunch / unsquash
 *)
Const
   TABSIZE   = 4096;
   TABSIZEM1 = 4095;
   NO_PRED : word  = $FFFF;
   EMPTY   : word  = $FFFF;

Type
   entry = record
              used         : boolean;
              next         : integer;
              predecessor  : integer;
              follower     : byte
           end;

Var
   stack       : array [0..TABSIZEM1] of byte;
   sp          : integer;
   string_tab  : array [0..TABSIZEM1] of entry;

Var
   code_count : integer;
   code       : integer;
   firstc     : boolean;
   oldcode    : integer;
   finchar    : integer;
   inbuf      : integer;
   outbuf     : integer;
   newhash    : boolean;

(*
 *  definitions for dynamic uncrunch
 *)
Const
  Crunch_BITS = 12;
  Squash_BITS = 13;
  HSIZE = 8192;
  INIT_BITS = 9;
  FIRST = 257;
  CLEAR = 256;
  HSIZEM1 = 8191;
  BITSM1 = 12;

  RMASK : array[0..8] of byte = ($00, $01, $03, $07, $0f, $1f, $3f, $7f, $ff);

Var
  bits,
  n_bits,
  maxcode    : integer;
  prefix     : array[0..HSIZEM1] of integer;
  suffix     : array[0..HSIZEM1] of byte;
  buf        : array[0..BITSM1]  of byte;
  clear_flg  : integer;
  stack1     : array[0..HSIZEM1] of byte;
  free_ent   : integer;
  maxcodemax : integer;
  offset,
  sizex      : integer;


(**
 *
 *  Name:         function h
 *  Description:  calculate hash value for LZW compression
 *                thanks to Bela Lubkin
 *  Parameters:   value -
 *                  pred, foll : integer - pred and follower bytes
 *  Returns:      new hash value
 *
**)
function h(pred, foll : integer) : integer;
{ pbr - removed messy real-to-int stuff - not necessary in TP4 }
var
  Local : longint;
  V     : word;
begin
  if not newhash then
    Local := (pred + foll) or $0800
  else
    Local := (pred + foll) * 15073;

  h := integer(local and $0FFF);
end;


(**
 *
 *  Name:         function eolist
 *  Description:  find end of an LZW chain
 *  Parameters:   value -
 *                  index : integer - start of chain
 *  Returns:      last entry in chain
 *
**)
function eolist(index : integer) : integer;
var temp : integer;
begin
  temp := string_tab[index].next;

  while temp <> 0 do
    begin
      index := temp;
      temp := string_tab[index].next
    end;

  eolist := index
end; (* func eolist *)


(**
 *
 *  Name:         function hash
 *  Description:  add pred/foll pair to LZW hash table
 *  Parameters:   value -
 *                  pred, foll : integer - pair to add
 *  Returns:      new pred val
 *
**)
function hash(pred, foll : integer) : integer;
var
  local     : integer;
    tempnext  : integer;
begin
  local := h(pred, foll);

  if not string_tab[local].used then
    hash := local
  else
    begin
      local := eolist(local);
      tempnext := (local + 101) and $0FFF;

      while string_tab[tempnext].used do
        begin
          tempnext := tempnext + 1;
          if tempnext = TABSIZE then
            tempnext := 0
        end;

      string_tab[local].next := tempnext;
      hash := tempnext
    end
end; (* func hash *)


(**
 *
 *  Name:         procedure upd_tab
 *  Description:  update LZW hash table entry
 *  Parameters:   value -
 *                  pred, foll : integer - pair to update
 *
**)
procedure upd_tab(pred, foll : integer);
begin
  with string_tab[hash(pred, foll)] do
    begin
      used := TRUE;
      next := 0;
      predecessor := pred;
      follower := foll
    end
end; (* proc upd_tab *)


(**
 *
 *  Name:         function gocode : integer
 *
**)
function gocode : integer;
label
  exit;
var
  localbuf  : integer;
  returnval : integer;
begin
  if inbuf = EMPTY then
    begin
      localbuf := getc_unp;

      if localbuf = -1 then
        begin
          gocode := -1;
          goto exit                       (******** was "exit" ************)
        end;

      localbuf := localbuf and $00FF;
      inbuf := getc_unp;
      if inbuf = -1 then
        begin
          gocode := -1;
          goto exit                       (******** was "exit" ************)
        end;

      inbuf := inbuf and $00FF;
      returnval := ((localbuf shl 4) and $0FF0) + ((inbuf shr 4) and $000F);
      inbuf := inbuf and $000F
    end
  else
    begin
      localbuf := getc_unp;
      if localbuf = -1 then
        begin
          gocode := -1;
          goto exit                       (******** was "exit" ************)
        end;

      localbuf := localbuf and $00FF;
      returnval := localbuf + ((inbuf shl 8) and $0F00);
      inbuf := EMPTY
    end;
  gocode := returnval;

exit:

end; (* func gocode *)


(**
 *
 *  Name:         procedure push
 *  Description:  push a char onto LZW 'pending' stack
 *  Parameters:   value -
 *                  c : integer - value to push
 *
**)
procedure push(c : integer);
begin
  stack[sp] := c;
  sp := sp + 1;

  if sp >= TABSIZE then
    abort('Stack overflow')
end; (* proc push *)


(**
 *
 *  Name:         function pop : integer
 *  Description:  pop a character from LZW 'pending' stack
 *  Parameters:   none
 *  Returns:      character popped or EMPTY
 *
**)
function pop : integer;
begin
  if sp > 0 then
    begin
      sp := sp - 1;
      pop := stack[sp]
    end
  else
    pop := EMPTY
end; (* func pop *)


(**
 *
 *  Name:         procedure init_tab
 *  Description:  initialize LZW string table
 *  Parameters:   none
 *
**)
procedure init_tab;
var
  i : integer;
begin
  FillChar(string_tab, sizeof(string_tab), 0);

  for i := 0 to 255 do
    upd_tab(NO_PRED, i);

  inbuf := EMPTY;
end; (* proc init_tab *)


(**
 *
 *  Name:         procedure init_ucr
 *  Description:  init LZW routines
 *  Parameters:   value -
 *                  i : integer - hash seed
 *
**)
procedure init_ucr(i:integer);
begin
  newhash := i = 1;
  sp := 0;
  init_tab;
  code_count := TABSIZE - 256;
  firstc := TRUE
end; (* proc init_ucr *)


(**
 *
 *  Name:         function getc_ucr : integer
 *  Description:  get next (uncompressed) LZW character
 *  Parameters:   none
 *  Returns:      next character
 *
**)
function getc_ucr : integer;
label exit;
var c       : integer;
    code    : integer;
    newcode : integer;
begin
  if firstc then
    begin
      firstc := FALSE;
      oldcode := gocode;
      finchar := string_tab[oldcode].follower;
      getc_ucr := finchar;
      goto exit                         (******** was "exit" ************)
    end;

  if sp = 0 then
    begin
      newcode := gocode;
      code := newcode;
      if code = -1 then
        begin
          getc_ucr := -1;
          goto exit                     (******** was "exit" ************)
        end;

      if not string_tab[code].used then
        begin
          code := oldcode;
          push(finchar)
        end;

      while string_tab[code].predecessor <> NO_PRED do
        with string_tab[code] do
          begin
            push(follower);
            code := predecessor
          end;

      finchar := string_tab[code].follower;
      push(finchar);

      if code_count <> 0 then
        begin
          upd_tab(oldcode, finchar);
          code_count := code_count - 1
        end;

      oldcode := newcode
    end;

  getc_ucr := pop;

exit:

end; (* func getc_ucr *)


(**
 *
 *  Name:         function getcode : integer
 *  Description:
 *  Parameters:   var -
 *
 *                value -
 *
 *  Returns:
 *
**)
function getcode : integer;
label
  next, exit;
var
  code, r_off, bitsx : integer;
  bp : byte;
begin
  if firstch then
    begin
      offset := 0;
      sizex := 0;
      firstch := false;
    end;

  bp := 0;

  if (clear_flg > 0) or (offset >= sizex) or (free_ent > maxcode) then
    begin
      if free_ent > maxcode then
        begin
          n_bits := n_bits + 1;
          if n_bits = BITS then
            maxcode := maxcodemax
          else
            maxcode := (1 shl n_bits) - 1;
        end;

      if clear_flg > 0 then
        begin
          n_bits := INIT_BITS;
          maxcode := (1 shl n_bits) - 1;
          clear_flg := 0;
        end;

      for sizex := 0 to n_bits-1 do
        begin
          code := getc_unp;
          if code = -1 then
            goto next
          else
            buf[sizex] := code;
        end;

      sizex := sizex + 1;

next:

      if sizex <= 0 then
        begin
          getcode := -1;
          goto exit;
        end;

      offset := 0;
      sizex := (sizex shl 3) - (n_bits - 1);
    end;

  r_off := offset;
  bitsx := n_bits;

  (*
   *  get first byte
   *)
  bp := bp + (r_off shr 3);
  r_off := r_off and 7;

  (*
   *  get first part (low order bits)
   *)
  code := buf[bp] shr r_off;
  bp := bp + 1;
  bitsx := bitsx - (8 - r_off);
  r_off := 8 - r_off;

  if bitsx >= 8 then
    begin
      code := code or (buf[bp] shl r_off);
      bp := bp + 1;
      r_off := r_off + 8;
      bitsx := bitsx - 8;
    end;

  code := code or ((buf[bp] and rmask[bitsx]) shl r_off);
  offset := offset + n_bits;
  getcode := code;

exit:

end;


(**
 *
 *  Name:         procedure decomp
 *  Description:  decompress a file with LZW
 *  Parameters:   value -
 *                  SquashFlag : integer - true if Squashing in effect
 *
**)
procedure decomp(SquashFlag : Integer);
label
  next,
  exit;
var
  stackp,
  finchar : integer;
  code,
  oldcode,
  incode : integer;
begin
  if SquashFlag = 0 then
    Bits := crunch_BITS
  else
    Bits := squash_BITS;

  if firstch then
    maxcodemax := 1 shl bits;

  if SquashFlag = 0 then
    begin
      code := getc_unp;
      if code <> BITS then
        begin
           Writeln( 'File packed with ', Code,
                    ' bits, I can only handle ', Bits);
           Halt(1);
        end;
    end;

  clear_flg := 0;
  n_bits := INIT_BITS;
  maxcode := (1 shl n_bits ) - 1;

  for code := 255 downto 0 do
    begin
      prefix[code] := 0;
      suffix[code] := code;
    end;

  free_ent := FIRST;
  oldcode := getcode;
  finchar := oldcode;

  if oldcode = -1 then
    goto exit;

  if SquashFlag = 0 then
    putc_ncr(finchar)
  else
    putc_unp(finchar);

  stackp := 0;

  code := getcode;
  while (code  > -1) do
    begin
      if code = CLEAR then
        begin
          for code := 255 downto 0 do
            prefix[code] := 0;
          clear_flg := 1;
          free_ent := FIRST - 1;
          code := getcode;
          if code = -1 then
            goto next;
        end;
next:
      incode := code;
      if code >= free_ent then
        begin
          stack1[stackp] := finchar;
          stackp := stackp + 1;
          code := oldcode;
        end;

      while (code >= 256) do
        begin
          stack1[stackp] := suffix[code];
          stackp := stackp + 1;
          code := prefix[code];
        end;

      finchar := suffix[code];
      stack1[stackp] := finchar;
      stackp := stackp + 1;
      repeat
        stackp := stackp - 1;
        If SquashFlag = 0 then
          putc_ncr(stack1[stackp])
        else
          putc_unp(stack1[stackp]);
      until stackp <= 0;

      code := free_ent;

      if code < maxcodemax then
        begin
          prefix[code] := oldcode;
          suffix[code] := finchar;
          free_ent := code + 1;
        end;

      oldcode := incode;
      code := getcode;
    end;

exit:

end;

end.