trees.pas

zlib pascal语言源码

                    var tree : ct_data;
                    max_code : int);
function build_bl_tree(var deflate_state) : int;
procedure send_all_trees(var deflate_state;
                         lcodes : int;
                         dcodes : int;
                         blcodes : int);
procedure compress_block(var s : deflate_state;
                         var ltree : ct_data;
                         var dtree : ct_data);
procedure set_data_type(var s : deflate_state);
function bi_reverse(value : unsigned;
                    length : int) : unsigned;
procedure bi_windup(var deflate_state);
procedure bi_flush(var deflate_state);
procedure copy_block(var deflate_state;
                     buf : pcharf;
                     len : unsigned;
                     header : int);
*)

{$ifdef GEN_TREES_H}
{local}
procedure gen_trees_header;
{$endif}

(*
{ ===========================================================================
  Output a short LSB first on the stream.
  IN assertion: there is enough room in pendingBuf. }

macro put_short(s, w)
begin
    {put_byte(s, (uch)((w) & 0xff));}
    s.pending_buf^[s.pending] := uch((w) and $ff);
    Inc(s.pending);

    {put_byte(s, (uch)((ush)(w) >> 8));}
    s.pending_buf^[s.pending] := uch(ush(w) shr 8);;
    Inc(s.pending);
end
*)

{ ===========================================================================
  Send a value on a given number of bits.
  IN assertion: length <= 16 and value fits in length bits. }

{$ifdef ORG_DEBUG}

{local}
procedure send_bits(var s : deflate_state;
                    value : int;   { value to send }
                    length : int); { number of bits }
begin
  {$ifdef DEBUG}
  Tracevv(' l '+IntToStr(length)+ ' v '+IntToStr(value));
  Assert((length > 0) and (length <= 15), 'invalid length');
  Inc(s.bits_sent, ulg(length));
  {$ENDIF}

  { If not enough room in bi_buf, use (valid) bits from bi_buf and
    (16 - bi_valid) bits from value, leaving (width - (16-bi_valid))
    unused bits in value. }
  {$IFOPT Q+} {$Q-} {$DEFINE NoOverflowCheck} {$ENDIF}
  {$IFOPT R+} {$R-} {$DEFINE NoRangeCheck} {$ENDIF}
  if (s.bi_valid > int(Buf_size) - length) then
  begin
    s.bi_buf := s.bi_buf or int(value shl s.bi_valid);
    {put_short(s, s.bi_buf);}
    s.pending_buf^[s.pending] := uch(s.bi_buf and $ff);
    Inc(s.pending);
    s.pending_buf^[s.pending] := uch(ush(s.bi_buf) shr 8);;
    Inc(s.pending);

    s.bi_buf := ush(value) shr (Buf_size - s.bi_valid);
    Inc(s.bi_valid, length - Buf_size);
  end
  else
  begin
    s.bi_buf := s.bi_buf or int(value shl s.bi_valid);
    Inc(s.bi_valid, length);
  end;
  {$IFDEF NoOverflowCheck} {$Q+} {$UNDEF NoOverflowCheck} {$ENDIF}
  {$IFDEF NoRangeCheck} {$Q+} {$UNDEF NoRangeCheck} {$ENDIF}
end;

{$else} { !DEBUG }


macro send_code(s, c, tree)
begin
  send_bits(s, tree[c].Code, tree[c].Len);
  { Send a code of the given tree. c and tree must not have side effects }
end

macro send_bits(s, value, length) \
begin int len := length;\
  if (s^.bi_valid > (int)Buf_size - len) begin\
    int val := value;\
    s^.bi_buf |= (val << s^.bi_valid);\
    {put_short(s, s.bi_buf);}
    s.pending_buf^[s.pending] := uch(s.bi_buf and $ff);
    Inc(s.pending);
    s.pending_buf^[s.pending] := uch(ush(s.bi_buf) shr 8);;
    Inc(s.pending);

    s^.bi_buf := (ush)val >> (Buf_size - s^.bi_valid);\
    s^.bi_valid += len - Buf_size;\
  end else begin\
    s^.bi_buf |= (value) << s^.bi_valid;\
    s^.bi_valid += len;\
  end\
end;
{$endif} { DEBUG }

{ ===========================================================================
  Reverse the first len bits of a code, using straightforward code (a faster
  method would use a table)
  IN assertion: 1 <= len <= 15 }

{local}
function bi_reverse(code : unsigned;         { the value to invert }
                    len : int) : unsigned;   { its bit length }

var
  res : unsigned; {register}
begin
  res := 0;
  repeat
    res := res or (code and 1);
    code := code shr 1;
    res := res shl 1;
    Dec(len);
  until (len <= 0);
  bi_reverse := res shr 1;
end;

{ ===========================================================================
  Generate the codes for a given tree and bit counts (which need not be
  optimal).
  IN assertion: the array bl_count contains the bit length statistics for
  the given tree and the field len is set for all tree elements.
  OUT assertion: the field code is set for all tree elements of non
      zero code length. }

{local}
procedure gen_codes(tree : tree_ptr;  { the tree to decorate }
                    max_code : int;   { largest code with non zero frequency }
                    var bl_count : array of ushf);  { number of codes at each bit length }

var
  next_code : array[0..MAX_BITS+1-1] of ush; { next code value for each bit length }
  code : ush;              { running code value }
  bits : int;                  { bit index }
  n : int;                     { code index }
var
  len : int;
begin
  code := 0;

  { The distribution counts are first used to generate the code values
    without bit reversal. }

  for bits := 1 to MAX_BITS do
  begin
    code := ((code + bl_count[bits-1]) shl 1);
    next_code[bits] := code;
  end;
  { Check that the bit counts in bl_count are consistent. The last code
    must be all ones. }

  {$IFDEF DEBUG}
  Assert (code + bl_count[MAX_BITS]-1 = (1 shl MAX_BITS)-1,
          'inconsistent bit counts');
  Tracev(#13'gen_codes: max_code '+IntToStr(max_code));
  {$ENDIF}

  for n := 0 to max_code do
  begin
    len := tree^[n].dl.Len;
    if (len = 0) then
      continue;
    { Now reverse the bits }
    tree^[n].fc.Code := bi_reverse(next_code[len], len);
    Inc(next_code[len]);
    {$ifdef DEBUG}
    if (n>31) and (n<128) then
      Tracecv(tree <> tree_ptr(@static_ltree),
       (^M'n #'+IntToStr(n)+' '+char(n)+' l '+IntToStr(len)+' c '+
         IntToStr(tree^[n].fc.Code)+' ('+IntToStr(next_code[len]-1)+')'))
    else
      Tracecv(tree <> tree_ptr(@static_ltree),
      (^M'n #'+IntToStr(n)+'   l '+IntToStr(len)+' c '+
         IntToStr(tree^[n].fc.Code)+' ('+IntToStr(next_code[len]-1)+')'));
    {$ENDIF}
  end;
end;

{ ===========================================================================
  Genererate the file trees.h describing the static trees. }
{$ifdef GEN_TREES_H}

macro SEPARATOR(i, last, width)
  if (i) = (last) then
    ( ^M');'^M^M
  else    \
    if (i) mod (width) = (width)-1 then
       ','^M
     else
       ', '

procedure gen_trees_header;
var
  header : system.text;
  i : int;
begin
  system.assign(header, 'trees.inc');
  {$I-}
  ReWrite(header);
  {$I+}
  Assert (IOresult <> 0, 'Can''t open trees.h');
  WriteLn(header,
    '{ header created automatically with -DGEN_TREES_H }'^M);

  WriteLn(header, 'local const ct_data static_ltree[L_CODES+2] := (');
  for i := 0 to L_CODES+2-1 do
  begin
    WriteLn(header, '((%3u),(%3u))%s', static_ltree[i].Code,
		static_ltree[i].Len, SEPARATOR(i, L_CODES+1, 5));
  end;

  WriteLn(header, 'local const ct_data static_dtree[D_CODES] := (');
  for i := 0 to D_CODES-1 do
  begin
    WriteLn(header, '((%2u),(%2u))%s', static_dtree[i].Code,
		static_dtree[i].Len, SEPARATOR(i, D_CODES-1, 5));
  end;

  WriteLn(header, 'const uch _dist_code[DIST_CODE_LEN] := (');
  for i := 0 to DIST_CODE_LEN-1 do
  begin
    WriteLn(header, '%2u%s', _dist_code[i],
		SEPARATOR(i, DIST_CODE_LEN-1, 20));
  end;

  WriteLn(header, 'const uch _length_code[MAX_MATCH-MIN_MATCH+1]= (');
  for i := 0 to MAX_MATCH-MIN_MATCH+1-1 do
  begin
    WriteLn(header, '%2u%s', _length_code[i],
		SEPARATOR(i, MAX_MATCH-MIN_MATCH, 20));
  end;

  WriteLn(header, 'local const int base_length[LENGTH_CODES] := (');
  for i := 0 to LENGTH_CODES-1 do
  begin
    WriteLn(header, '%1u%s', base_length[i],
		SEPARATOR(i, LENGTH_CODES-1, 20));
  end;

  WriteLn(header, 'local const int base_dist[D_CODES] := (');
  for i := 0 to D_CODES-1 do
  begin
    WriteLn(header, '%5u%s', base_dist[i],
		SEPARATOR(i, D_CODES-1, 10));
  end;

  close(header);
end;
{$endif} { GEN_TREES_H }


{ ===========================================================================
  Initialize the various 'constant' tables. }

{local}
procedure tr_static_init;

{$ifdef GEN_TREES_H}
const
  static_init_done : boolean = FALSE;
var
  n : int;        { iterates over tree elements }
  bits : int;     { bit counter }
  length : int;   { length value }
  code : int;     { code value }
  dist : int;     { distance index }
  bl_count : array[0..MAX_BITS+1-1] of ush;
    { number of codes at each bit length for an optimal tree }
begin
    if (static_init_done) then
      exit;

    { Initialize the mapping length (0..255) -> length code (0..28) }
    length := 0;
    for code := 0 to LENGTH_CODES-1-1 do
    begin
      base_length[code] := length;
      for n := 0 to (1 shl extra_lbits[code])-1 do
      begin
        _length_code[length] := uch(code);
        Inc(length);
      end;
    end;
    Assert (length = 256, 'tr_static_init: length <> 256');
    { Note that the length 255 (match length 258) can be represented
      in two different ways: code 284 + 5 bits or code 285, so we
      overwrite length_code[255] to use the best encoding: }

    _length_code[length-1] := uch(code);

    { Initialize the mapping dist (0..32K) -> dist code (0..29) }
    dist := 0;
    for code := 0 to 16-1 do
    begin
      base_dist[code] := dist;
      for n := 0 to (1 shl extra_dbits[code])-1 do
      begin
        _dist_code[dist] := uch(code);
        Inc(dist);
      end;
    end;
    Assert (dist = 256, 'tr_static_init: dist <> 256');
    dist := dist shr 7; { from now on, all distances are divided by 128 }
    for code := 16 to D_CODES-1 do
    begin
      base_dist[code] := dist shl 7;
      for n := 0 to (1 shl (extra_dbits[code]-7))-1 do
      begin
        _dist_code[256 + dist] := uch(code);
        Inc(dist);
      end;
    end;
    Assert (dist = 256, 'tr_static_init: 256+dist <> 512');

    { Construct the codes of the static literal tree }
    for bits := 0 to MAX_BITS do
      bl_count[bits] := 0;
    n := 0;
    while (n <= 143) do
    begin
      static_ltree[n].dl.Len := 8;
      Inc(n);
      Inc(bl_count[8]);
    end;
    while (n <= 255) do
    begin
      static_ltree[n].dl.Len := 9;
      Inc(n);
      Inc(bl_count[9]);
    end;
    while (n <= 279) do
    begin
      static_ltree[n].dl.Len := 7;
      Inc(n);
      Inc(bl_count[7]);
    end;
    while (n <= 287) do
    begin
      static_ltree[n].dl.Len := 8;
      Inc(n);
      Inc(bl_count[8]);
    end;

    { Codes 286 and 287 do not exist, but we must include them in the
      tree construction to get a canonical Huffman tree (longest code