kptrees.pas

dephi vcl控件

            Inc(bl_tree[REPZ_3_10].fc.freq)
        Else
            Inc(bl_tree[REPZ_11_138].fc.freq);

        icount := 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.
 *}
function build_bl_tree: LongInt;
{var}
  {max_blindex:   LongInt;}  { index of last bit length code of non zero freq }
begin
   { Determine the bit length frequencies for literal and distance trees }
    scan_tree(ct_dataArrayPtr(@dyn_ltree), l_desc.max_code);  { added typecast 5/18/98  2.13 }
    scan_tree(ct_dataArrayPtr(@dyn_dtree), d_desc.max_code);  { added typecast 5/18/98  2.13 }

    { Build the bit length tree: }
    build_tree(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.)
     *}
    Result := BL_CODES-1;
    while (Result >= 3) do
     begin
        if (bl_tree[bl_order[Result]].dl.len <> 0) then
           break;
        Dec(Result);
     end;
    { Update opt_len to include the bit length tree and counts }
    Inc(opt_len,3*(Result+1)+5+5+4);
    {Tracev((stderr, "\ndyn trees: dyn %ld, stat %ld", opt_len, static_len));}

    {Result := max_blindex;}
end;

{* ===========================================================================
 * Send the block data compressed using the given Huffman trees
 *}
procedure compress_block(ltree, dtree: ct_dataArrayPtr);
var
    { ltree      = literal tree }
    { dtree      = distance tree }
    dist:     usigned;            { distance of matched string }
    lc:       LongInt;             { match length or unmatched char (if dist == 0) }
    lx:       usigned;            { running index in l_buf }
    dx:       usigned;            { running index in d_buf }
    fx:       usigned;            { running index in flag_buf }
    flag:     Byte;                { current flags }
    code:     usigned;            { the code to send }
    extra:    LongInt;             { number of extra bits to send }
begin
    lx := 0;
    dx := 0;
    fx := 0;
    flag := 0;
    if (last_lit <> 0) then
     Repeat
        if ((lx and 7) = 0) then
         begin
           flag := flag_buf^[fx];
           Inc(fx);
         end;
        lc := l_buf^[lx];
        Inc(lx);
        if ((flag and 1) = 0) then
         begin
            send_code(lc, ltree); { send a literal byte }
            {send_bits( Integer(ltree^[lc].fc.code), Integer(ltree^[lc].dl.len) );}
            {Tracecv(isgraph(lc), (stderr," '%c' ", lc));}
         end
        Else
         begin
            { Here, lc is the match length - MIN_MATCH }
            code := length_code[lc];
            send_code(code+LITERALS+1, ltree); { send the length code }
            {send_bits( Integer(ltree^[code+LITERALS+1].fc.code), Integer(ltree^[code+LITERALS+1].dl.len) );}
            extra := extra_lbits[code];
            if (extra <> 0) then
             begin
                Dec(lc,base_length[code]);
                send_bits(lc, extra);        { send the extra length bits }
             end;
            dist := d_buf^[dx];
            Inc(dx);
            { Here, dist is the match distance - 1 }
            code := d_code(dist);

            {$IFDEF ASSERTS}
            Assert (code < D_CODES, 'bad d_code-compress_block');
            {$ENDIF}

            send_code(code, dtree);       { send the distance code }
            {send_bits( Integer(dtree^[code].fc.code), Integer(dtree^[code].dl.len) );}
            extra := extra_dbits[code];
            if (extra <> 0) then
             begin
                Dec(dist,base_dist[code]);
                send_bits(dist, extra);   { send the extra distance bits }
             end;
         end; { literal or match pair ? }
        flag := flag shr 1;
     Until lx >= last_lit;  {while (lx < last_lit)}

    send_code(END_BLOCK, ltree);
    {send_bits( Integer(ltree^[END_BLOCK].fc.code), Integer(ltree^[END_BLOCK].dl.len) );}
end;

{* ===========================================================================
 * Send a literal or distance tree in compressed form, using the codes in
 * bl_tree.
 *}
procedure send_tree (tree: ct_dataArrayPtr; max_code: LongInt);
var
    { tree       = the tree to be scanned }
    { max_code   = and its largest code of non zero frequency }
    n: Integer;                       { iterates over all tree elements }
    prevlen: LongInt;                 { last emitted length }
    curlen:  LongInt;                 { length of current code }
    nextlen: LongInt;                 { length of next code }
    icount:   LongInt;                 { repeat count of the current code }
    max_count:  LongInt;              { max repeat count }
    min_count:  LongInt;              { min repeat count }
begin
    prevlen := -1;
    nextlen := tree^[0].dl.len;
    icount := 0;
    max_count := 7;
    min_count := 4;
    { tree[max_code+1].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(icount);
        if (icount < max_count) and (curlen = nextlen) then
            continue
        Else if (icount < min_count) then
           Repeat
            If (bl_tree[curlen].dl.len > 0) and (bl_tree[curlen].dl.len < 16) then
              send_code(curlen, ct_dataArrayPtr(@bl_tree));   { added typecast 5/18/98  2.13 }
              {send_bits( Integer(ct_dataArrayPtr(@bl_tree)^[curlen].fc.code),}
              {           Integer(ct_dataArrayPtr(@bl_tree)^[curlen].dl.len) );}
            {else
              ShowMessage('Length out of range! - ' + IFileName);}
            Dec(icount);
           Until icount = 0
        Else if (curlen <> 0) then
           begin
            if (curlen <> prevlen) then
             begin
                send_code(curlen, ct_dataArrayPtr(@bl_tree));  { added typecast 5/18/98 2.13 }
                {send_bits( Integer(ct_dataArrayPtr(@bl_tree)^[curlen].fc.code),}
                {           Integer(ct_dataArrayPtr(@bl_tree)^[curlen].dl.len) );}
                Dec(icount);
             end;

            {$IFDEF ASSERTS}
            Assert((icount >= 3) and (icount <= 6), ' 3_6? - send_tree');
            {$ENDIF}

            If (bl_tree[REP_3_6].dl.len > 0) and (bl_tree[REP_3_6].dl.len < 16) then
              send_code(REP_3_6, ct_dataArrayPtr(@bl_tree));   { added typecast 5/18/98  2.13 }
              {send_bits( Integer(ct_dataArrayPtr(@bl_tree)^[REP_3_6].fc.code), }
              {           Integer(ct_dataArrayPtr(@bl_tree)^[REP_3_6].dl.len) ); }
            {else
              ShowMessage('Length out of range! -' + IFileName);}
            send_bits(icount-3, 2);
           end
        Else if (icount <= 10) then
           begin
            send_code(REPZ_3_10, ct_dataArrayPtr(@bl_tree));  { added typecast 5/18/98  2.13 }
            {send_bits( Integer(ct_dataArrayPtr(@bl_tree)^[REPZ_3_10].fc.code), }
            {             Integer(ct_dataArrayPtr(@bl_tree)^[REPZ_3_10].dl.len) ); }
            send_bits(icount-3, 3);
           end
        Else
           begin
            send_code(REPZ_11_138, ct_dataArrayPtr(@bl_tree)); { added typecast 5/18/98  2.13 }
            {send_bits( Integer(ct_dataArrayPtr(@bl_tree)^[REPZ_11_138].fc.code), }
            {            Integer(ct_dataArrayPtr(@bl_tree)^[REPZ_11_138].dl.len) ); }
            send_bits(icount-11, 7);
           end;

        icount := 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 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.
 *}
procedure send_all_trees(lcodes, dcodes, blcodes: LongInt);
var
  { lcodes, dcodes, blcodes  = number of codes for each tree }
  rank:    LongInt;   { index in bl_order }
begin
    {$IFDEF ASSERTS}
    Assert ((lcodes >= 257) and (dcodes >= 1) and (blcodes >= 4),
              'not enough codes-send_all_trees');
    Assert ((lcodes <= L_CODES) and (dcodes <= D_CODES) and (blcodes <= BL_CODES),
            'too many codes-send_all_trees');
    {$ENDIF} 

    send_bits(lcodes-257, 5);
    { not +255 as stated in appnote.txt 1.93a or -256 in 2.04c }
    send_bits(dcodes-1,   5);
    send_bits(blcodes-4,  4); { not -3 as stated in appnote.txt }
    for rank := 0 to blcodes-1 do
     begin
        {Tracev((stderr, "\nbl code %2d ", bl_order[rank]));}
        send_bits(bl_tree[bl_order[rank]].dl.len, 3);
     end;
    {Tracev((stderr, "\nbl tree: sent %ld", bits_sent));}

    send_tree(ct_dataArrayPtr(@dyn_ltree), lcodes-1); { send the literal tree } { added typecast 5/18/98  2.13 }
    {Tracev((stderr, "\nlit tree: sent %ld", bits_sent));}

    send_tree(ct_dataArrayPtr(@dyn_dtree), dcodes-1); { send the distance tree } { added typecast 5/18/98  2.13 }
    {Tracev((stderr, "\ndist tree: sent %ld", bits_sent));}
end;

function flush_the_block( buf: BytePtr; stored_len: LongInt; eofblock: Integer ): LongInt;
var
  opt_lenb, static_lenb:  LongInt;
  max_blindex:            LongInt;
begin
  flag_buf^[last_flags] := flags;
  If ( tmpfile_info.internal_file_attributes = UNKNOWN ) then
     set_file_type;

  build_tree( l_desc );
  build_tree( d_desc );

  max_blindex := build_bl_tree;

  opt_lenb := (opt_len+3+7) shr 3;
  static_lenb := (static_len+3+7) shr 3;
  Inc(input_len,stored_len);

  If (static_lenb <= opt_lenb) then
     opt_lenb := static_lenb;

  If (stored_len <= opt_lenb) and (eofblock <> 0) and (compressed_len = 0) then
   begin
     copy_block( buf, stored_len, 0 );
     compressed_len := stored_len shl 3;
     tmpfile_info.compression_method := STORE;
   end
  Else If (stored_len+4 <= opt_lenb) and (buf <> nil) then
   begin
     { The test buf <> nil is only necessary if LIT_BUFSIZE > WSIZE.
     * Otherwise we can't have processed more than WSIZE input bytes since
     * the last block flush, because compression would have been
     * successful. If LIT_BUFSIZE <= WSIZE, it is never too late to
     * transform a block into a stored block. }
     send_bits((STORED_BLOCK shl 1) + eofblock, 3);  { send block type }
     compressed_len := (compressed_len + 3 + 7) and (not LongInt(7));
     Inc(compressed_len,(stored_len + 4) shl 3);
     copy_block(buf, stored_len, 1); { with header }
   end
  Else If (static_lenb = opt_lenb) then
   begin
     send_bits((STATIC_TREES shl 1) + eofblock, 3);
     compress_block(ct_dataArrayPtr(@static_ltree), ct_dataArrayPtr(@static_dtree));   { added typecast 5/18/98  2.13 }
     Inc(compressed_len,3 + static_len);
   end
  Else
   begin
     send_bits((DYN_TREES shl 1)+eofblock, 3);
     send_all_trees(l_desc.max_code+1, d_desc.max_code+1, max_blindex+1);
     compress_block(ct_dataArrayPtr(@dyn_ltree), ct_dataArrayPtr(@dyn_dtree));  { added typecast 5/18/98  2.13 }
     Inc(compressed_len,3 + opt_len);
   end;
  init_block;
  if (eofblock <> 0) then
   begin
     ZeroMemory(@window^[0], 2*WSIZE-1);
     bi_windup;
     Inc(compressed_len,7);  { align on byte boundary }
   end;
  Result := compressed_len shr 3;
end;