kptrees.pas

dephi vcl控件

{ ********************************************************************************** }
{                                                                                    }
{ 	 COPYRIGHT 1997 Kevin Boylan                                                    }
{     Source File: Trees.pas                                                         }
{     Description: VCLZip component - native Delphi zip component.                   }
{     Date:        March 1997                                                        }
{     Author:      Kevin Boylan, CIS: boylank                                        }
{                                Internet: [e-mail]                    }
{                                                                                    }
{ ********************************************************************************** }

{ $Log:  D:\Util\GP-Version\Archives\Components\VCLZip\Component Files\kpTREES.UFV 
{
{   Rev 1.1    7/9/98 6:47:18 PM  Supervisor
{ Version 2.13
{ 
{ 1) New property ResetArchiveBitOnZip causes each file's 
{ archive bit to be turned  off after being zipped.
{ 
{ 2) New Property SkipIfArchiveBitNotSet causes files 
{ who's archive bit is not set to be skipped during zipping 
{ operations.
{ 
{ 3) A few modifications were made to allow more 
{ compatibility with BCB 1.
{ 
{ 4) Modified how directory information is used when 
{ comparing filenames to be unzipped.  Now it is always 
{ used.
}

{$P-} { turn off open parameters }
{$Q-} { turn off overflow checking }
{$R-} { turn off range checking }
{$B-} { turn off complete boolean eval } { 12/24/98  2.17 }

{* ===========================================================================
 * Initialize a new block.
 *}
procedure init_block;
var
  n:    Integer; { iterates over tree elements }
begin
    { Initialize the trees. }
    for n := 0 to L_CODES-1 do
     dyn_ltree[n].fc.freq := 0;
    for n := 0 to D_CODES-1 do
     dyn_dtree[n].fc.freq := 0;
    for n := 0 to BL_CODES-1 do
     bl_tree[n].fc.freq := 0;

    dyn_ltree[END_BLOCK].fc.freq := 1;
    opt_len := 0;
    static_len := 0;
    last_lit := 0;
    last_dist := 0;
    last_flags := 0;
    flags := 0; flag_bit := 1;
end;

{* ===========================================================================
 * Compares to subtrees, using the tree depth as tie breaker when
 * the subtrees have equal frequency. This minimizes the worst case length.
 *}
function smaller( tree: ct_dataArrayPtr; n, m: LongInt ): Boolean;
begin
   Result := (tree^[n].fc.freq < tree^[m].fc.freq) or
             ((tree^[n].fc.freq = tree^[m].fc.freq) and
             (depth[n] <= depth[m]));
end;

{ $IFDEF SKIPCODE}
procedure send_code( c: LongInt; tree: ct_dataArrayPtr );
begin
  send_bits( Integer(tree^[c].fc.code), Integer(tree^[c].dl.len) );
end;
{ $ENDIF}

function d_code( d: Integer ): Byte;
begin
  If d < 256 then
   begin
     Result := dist_code[d]
   end
  Else
   begin
     Result := dist_code[256+(d shr 7)];
   end;
end;

procedure set_file_type;
var
  n:          LongInt;
  ascii_freq: usigned;
  bin_freq:   usigned;
begin
    n := 0;
    ascii_freq := 0;
    bin_freq := 0;
    while (n < 7) do
     begin
        Inc(bin_freq,dyn_ltree[n].fc.freq);
        Inc(n);
     end;
    while (n < 128) do
     begin
        Inc(ascii_freq,dyn_ltree[n].fc.freq);
        Inc(n);
     end;
    while (n < LITERALS) do
     begin
        Inc(bin_freq,dyn_ltree[n].fc.freq);
        Inc(n);
     end;
    If (bin_freq > (ascii_freq shr 2)) then
     tmpfile_info.internal_file_attributes := BINARY
    Else
     tmpfile_info.internal_file_attributes := ASCII;
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.
 *}
procedure gen_codes (tree: ct_dataArrayPtr; max_code: Integer);{checked out 6/14}
var
    { tree = the tree to decorate }
    { max_code =  largest code with non zero frequency }
    next_code:   array [0..MAX_ZBITS] of WORD; { next code value for each bit length }
    code:        WORD;                  { running code value }
    bits:        Integer;               { bit index }
    n:           LongInt;               { code index }
    len:         Integer;
begin

    {* The distribution counts are first used to generate the code values
     * without bit reversal.
     *}
    code := 0;
    for bits := 1 to MAX_ZBITS do
     begin
        {$IFOPT R+}
          {$DEFINE RWASON}
          {$R-}
        {$ENDIF}
        code := WORD((code + bl_count[bits-1])) shl 1;
        {$IFDEF RWASON}
          {$R+}
          {$UNDEF RWASON}
        {$ENDIF}
        next_code[bits] := code;
     end;
    {* Check that the bit counts in bl_count are consistent. The last code
     * must be all ones.
     *}

    {$IFDEF ASSERTS}
    Assert (code + bl_count[MAX_ZBITS]-1 = (1 shl MAX_ZBITS)-1,
            'inconsistent bit counts-gencodes');
    {$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]);
        {Tracec(tree != static_ltree, (stderr,"\nn %3d %c l %2d c %4x (%x) ",
             n, (isgraph(n) ? n : ' '), len, tree[n].Code, next_code[len]-1));}
     end;
end;

procedure tr_static_init;
var
    n:        LongInt;     { iterates over tree elements }
    bits:     LongInt;     { bit counter }
    blength:   LongInt;     { length value }
    code:     LongInt;     { code value }
    dist:     LongInt;     { distance index }
begin
    { Initialize the mapping length (0..255) -> length code (0..28) }

    if TRInitialized then
        exit;

    blength := 0;
    for code := 0 to LENGTH_CODES-2 do
     begin
        base_length[code] := blength;
        for n := 0 to (1 shl extra_lbits[code])-1 do
         begin
            length_code[blength] := code;
            Inc(blength);
         end;
     end;

    {$IFDEF ASSERTS}
    Assert (blength = 256, 'ct_init: length <> 256');
    {$ENDIF}

    {* 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:
     *}
    code := LENGTH_CODES-1;
    length_code[blength-1] := code;

    { Initialize the mapping dist (0..32K) -> dist code (0..29) }
    dist := 0;
    for code := 0 to 15 do
     begin
        base_dist[code] := dist;
        for n := 0 to (1 shl extra_dbits[code])-1 do
         begin
            dist_code[dist] := code;
            Inc(dist);
         end;
     end;

    {$IFDEF ASSERTS}
    Assert (dist = 256, 'ct_init: dist <> 256');
    {$ENDIF}

    dist := dist shr 7; { from now on, all distances are divided by 128 }
    code := 16;
    while code < D_CODES 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] := code;
            Inc(dist);
         end;
        Inc(code);
     end;

    {$IFDEF ASSERTS}
    Assert (dist = 256, 'ct_init: 256+dist <> 512');
    {$ENDIF}

    { Construct the codes of the static literal tree }
    for bits := 0 to MAX_ZBITS 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
     * all ones)
     *}
    gen_codes(ct_dataArrayPtr(@static_ltree), L_CODES+1);  { added typecast 5/18/98  2.13 }

    { The static distance tree is trivial: }
    for n := 0 to D_CODES-1 do
     begin
        static_dtree[n].dl.len := 5;
        static_dtree[n].fc.code := bi_reverse(n, 5);
     end;
    TRInitialized := True;
end;

{* ===========================================================================
 * Allocate the match buffer, initialize the various tables and save the
 * location of the internal file attribute (ascii/binary) and method
 * (DEFLATE/STORE).
 *}
procedure ct_init;
begin
    tr_static_init;
    compressed_len := 0;
    input_len := 0;
    bi_buf := 0;
    bi_valid := 0;
    {$IFOPT D+}
    {$IFDEF KPDEBUG}
    bits_sent := 0;
    {$ENDIF}
    {$ENDIF}
    { Initialize the first block of the first file: }
    init_block;
end;  { ct_init }

function ct_tally( dist,lc: Integer ): Boolean;
var
  out_length:    LongInt;
  in_length:     LongInt;
  dcode:         Integer;
begin
  l_buf^[last_lit] := lc;
  Inc(last_lit);
  If dist = 0 then
     Inc(dyn_ltree[lc].fc.freq)
  Else
   begin
     Dec(dist);

     {$IFDEF ASSERTS}
     Assert( (dist < MAX_DIST) and (lc <= MAX_MATCH-MIN_MATCH) and
             (d_code(dist) < D_CODES), 'ct_tally: bad match' );
     {$ENDIF}

     Inc(dyn_ltree[length_code[lc]+LITERALS+1].fc.freq);
     Inc(dyn_dtree[d_code(dist)].fc.freq);
     d_buf^[last_dist] := dist;
     Inc(last_dist);
     flags := (flags or flag_bit);