trees.pas

zlib pascal语言源码

    begin
      WriteLn(#13'node ',node,'(',tree^[node].fc.Freq,') sons ',n,
              '(',tree^[n].fc.Freq,') ', m, '(',tree^[m].fc.Freq,')');
    end;
{$endif}
    { and insert the new node in the heap }
    s.heap[SMALLEST] := node;
    Inc(node);
    pqdownheap(s, tree^, SMALLEST);

  until (s.heap_len < 2);

  Dec(s.heap_max);
  s.heap[s.heap_max] := s.heap[SMALLEST];

  { At this point, the fields freq and dad are set. We can now
    generate the bit lengths. }

  gen_bitlen(s, desc);

  { The field len is now set, we can generate the bit codes }
  gen_codes (tree, max_code, s.bl_count);
end;

{ ===========================================================================
  Scan a literal or distance tree to determine the frequencies of the codes
  in the bit length tree. }

{local}
procedure scan_tree(var s : deflate_state;
                    var tree : array of ct_data;    { the tree to be scanned }
                    max_code : int);    { and its largest code of non zero frequency }
var
  n : int;                 { iterates over all tree elements }
  prevlen : int;           { last emitted length }
  curlen : int;            { length of current code }
  nextlen : int;           { length of next code }
  count : int;             { repeat count of the current code }
  max_count : int;         { max repeat count }
  min_count : int;         { min repeat count }
begin
  prevlen := -1;
  nextlen := tree[0].dl.Len;
  count := 0;
  max_count := 7;
  min_count := 4;

  if (nextlen = 0) then
  begin
    max_count := 138;
    min_count := 3;
  end;
  tree[max_code+1].dl.Len := ush($ffff); { guard }

  for n := 0 to max_code do
  begin
    curlen := nextlen;
    nextlen := tree[n+1].dl.Len;
    Inc(count);
    if (count < max_count) and (curlen = nextlen) then
      continue
    else
      if (count < min_count) then
        Inc(s.bl_tree[curlen].fc.Freq, count)
      else
        if (curlen <> 0) then
        begin
          if (curlen <> prevlen) then
            Inc(s.bl_tree[curlen].fc.Freq);
          Inc(s.bl_tree[REP_3_6].fc.Freq);
        end
        else
          if (count <= 10) then
            Inc(s.bl_tree[REPZ_3_10].fc.Freq)
          else
            Inc(s.bl_tree[REPZ_11_138].fc.Freq);

    count := 0;
    prevlen := curlen;
    if (nextlen = 0) then
    begin
      max_count := 138;
      min_count := 3;
    end
    else
      if (curlen = nextlen) then
      begin
        max_count := 6;
        min_count := 3;
      end
      else
      begin
        max_count := 7;
        min_count := 4;
      end;
  end;
end;

{ ===========================================================================
  Send a literal or distance tree in compressed form, using the codes in
  bl_tree. }

{local}
procedure send_tree(var s : deflate_state;
                    var tree : array of ct_data;    { the tree to be scanned }
                    max_code : int);    { and its largest code of non zero frequency }

var
  n : int;                { iterates over all tree elements }
  prevlen : int;          { last emitted length }
  curlen : int;           { length of current code }
  nextlen : int;          { length of next code }
  count : int;            { repeat count of the current code }
  max_count : int;        { max repeat count }
  min_count : int;        { min repeat count }
begin
  prevlen := -1;
  nextlen := tree[0].dl.Len;
  count := 0;
  max_count := 7;
  min_count := 4;

  { tree[max_code+1].dl.Len := -1; }  { guard already set }
  if (nextlen = 0) then
  begin
    max_count := 138;
    min_count := 3;
  end;

  for n := 0 to max_code do
  begin
    curlen := nextlen;
    nextlen := tree[n+1].dl.Len;
    Inc(count);
    if (count < max_count) and (curlen = nextlen) then
      continue
    else
      if (count < min_count) then
      begin
        repeat
          {$ifdef DEBUG}
          Tracevvv(#13'cd '+IntToStr(curlen));
          {$ENDIF}
          send_bits(s, s.bl_tree[curlen].fc.Code, s.bl_tree[curlen].dl.Len);
          Dec(count);
        until (count = 0);
      end
      else
        if (curlen <> 0) then
        begin
          if (curlen <> prevlen) then
          begin
            {$ifdef DEBUG}
            Tracevvv(#13'cd '+IntToStr(curlen));
            {$ENDIF}
            send_bits(s, s.bl_tree[curlen].fc.Code, s.bl_tree[curlen].dl.Len);
            Dec(count);
          end;
          {$IFDEF DEBUG}
          Assert((count >= 3) and (count <= 6), ' 3_6?');
          {$ENDIF}
          {$ifdef DEBUG}
          Tracevvv(#13'cd '+IntToStr(REP_3_6));
          {$ENDIF}
          send_bits(s, s.bl_tree[REP_3_6].fc.Code, s.bl_tree[REP_3_6].dl.Len);
          send_bits(s, count-3, 2);
        end
        else
          if (count <= 10) then
          begin
            {$ifdef DEBUG}
            Tracevvv(#13'cd '+IntToStr(REPZ_3_10));
            {$ENDIF}
            send_bits(s, s.bl_tree[REPZ_3_10].fc.Code, s.bl_tree[REPZ_3_10].dl.Len);
            send_bits(s, count-3, 3);
          end
          else
          begin
            {$ifdef DEBUG}
            Tracevvv(#13'cd '+IntToStr(REPZ_11_138));
            {$ENDIF}
            send_bits(s, s.bl_tree[REPZ_11_138].fc.Code, s.bl_tree[REPZ_11_138].dl.Len);
            send_bits(s, count-11, 7);
          end;
    count := 0;
    prevlen := curlen;
    if (nextlen = 0) then
    begin
      max_count := 138;
      min_count := 3;
    end
    else
      if (curlen = nextlen) then
      begin
        max_count := 6;
        min_count := 3;
      end
      else
      begin
        max_count := 7;
        min_count := 4;
      end;
  end;
end;

{ ===========================================================================
  Construct the Huffman tree for the bit lengths and return the index in
  bl_order of the last bit length code to send. }

{local}
function build_bl_tree(var s : deflate_state) : int;
var
  max_blindex : int;  { index of last bit length code of non zero freq }
begin
  { Determine the bit length frequencies for literal and distance trees }
  scan_tree(s, s.dyn_ltree, s.l_desc.max_code);
  scan_tree(s, s.dyn_dtree, s.d_desc.max_code);

  { Build the bit length tree: }
  build_tree(s, s.bl_desc);
  { opt_len now includes the length of the tree representations, except
    the lengths of the bit lengths codes and the 5+5+4 bits for the counts. }

  { Determine the number of bit length codes to send. The pkzip format
    requires that at least 4 bit length codes be sent. (appnote.txt says
    3 but the actual value used is 4.) }

  for max_blindex := BL_CODES-1 downto 3 do
  begin
    if (s.bl_tree[bl_order[max_blindex]].dl.Len <> 0) then
      break;
  end;
  { Update opt_len to include the bit length tree and counts }
  Inc(s.opt_len, 3*(max_blindex+1) + 5+5+4);
  {$ifdef DEBUG}
  Tracev(^M'dyn trees: dyn %ld, stat %ld {s.opt_len, s.static_len}');
  {$ENDIF}

  build_bl_tree := max_blindex;
end;

{ ===========================================================================
  Send the header for a block using dynamic Huffman trees: the counts, the
  lengths of the bit length codes, the literal tree and the distance tree.
  IN assertion: lcodes >= 257, dcodes >= 1, blcodes >= 4. }

{local}
procedure send_all_trees(var s : deflate_state;
                         lcodes : int;
                         dcodes : int;
                         blcodes : int); { number of codes for each tree }
var
  rank : int;                    { index in bl_order }
begin
  {$IFDEF DEBUG}
  Assert ((lcodes >= 257) and (dcodes >= 1) and (blcodes >= 4),
          'not enough codes');
  Assert ((lcodes <= L_CODES) and (dcodes <= D_CODES)
          and (blcodes <= BL_CODES), 'too many codes');
  Tracev(^M'bl counts: ');
  {$ENDIF}
  send_bits(s, lcodes-257, 5); { not +255 as stated in appnote.txt }
  send_bits(s, dcodes-1,   5);
  send_bits(s, blcodes-4,  4); { not -3 as stated in appnote.txt }
  for rank := 0 to blcodes-1 do
  begin
    {$ifdef DEBUG}
    Tracev(^M'bl code '+IntToStr(bl_order[rank]));
    {$ENDIF}
    send_bits(s, s.bl_tree[bl_order[rank]].dl.Len, 3);
  end;
  {$ifdef DEBUG}
  Tracev(^M'bl tree: sent '+IntToStr(s.bits_sent));
  {$ENDIF}

  send_tree(s, s.dyn_ltree, lcodes-1); { literal tree }
  {$ifdef DEBUG}
  Tracev(^M'lit tree: sent '+IntToStr(s.bits_sent));
  {$ENDIF}

  send_tree(s, s.dyn_dtree, dcodes-1); { distance tree }
  {$ifdef DEBUG}
  Tracev(^M'dist tree: sent '+IntToStr(s.bits_sent));
  {$ENDIF}
end;

{ ===========================================================================
  Flush the bit buffer and align the output on a byte boundary }

{local}
procedure bi_windup(var s : deflate_state);
begin
  if (s.bi_valid > 8) then
  begin
    {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);
  end
  else
    if (s.bi_valid > 0) then
    begin
      {put_byte(s, (Byte)s^.bi_buf);}
      s.pending_buf^[s.pending] := Byte(s.bi_buf);
      Inc(s.pending);
    end;
  s.bi_buf := 0;
  s.bi_valid := 0;
{$ifdef DEBUG}
  s.bits_sent := (s.bits_sent+7) and (not 7);
{$endif}
end;

{ ===========================================================================
  Copy a stored block, storing first the length and its
  one's complement if requested. }

{local}
procedure copy_block(var s : deflate_state;
                     buf : pcharf;      { the input data }
                     len : unsigned;    { its length }
                     header : boolean); { true if block header must be written }
begin
  bi_windup(s);        { align on byte boundary }
  s.last_eob_len := 8; { enough lookahead for inflate }

  if (header) then
  begin
    {put_short(s, (ush)len);}
    s.pending_buf^[s.pending] := uch(ush(len) and $ff);
    Inc(s.pending);
    s.pending_buf^[s.pending] := uch(ush(len) shr 8);;
    Inc(s.pending);
    {put_short(s, (ush)~len);}
    s.pending_buf^[s.pending] := uch(ush(not len) and $ff);
    Inc(s.pending);
    s.pending_buf^[s.pending] := uch(ush(not len) shr 8);;
    Inc(s.pending);

{$ifdef DEBUG}
    Inc(s.bits_sent, 2*16);
{$endif}
  end;
{$ifdef DEBUG}
  Inc(s.bits_sent, ulg(len shl 3));
{$endif}
  while (len <> 0) do
  begin
    Dec(len);
    {put_byte(s, *buf++);}
    s.pending_buf^[s.pending] := buf^;
    Inc(buf);
    Inc(s.pending);
  end;
end;


{ ===========================================================================
  Send a stored block }

procedure _tr_stored_block(var s : deflate_state;
                           buf