kptrees.pas

dephi vcl控件

   end;
   {$IFOPT R+}
     {$DEFINE RWASON}
     {$R-}
   {$ENDIF}
   flag_bit := flag_bit shl 1;
   {$IFDEF RWASON}
     {$R+}
     {$UNDEF RWASON}
   {$ENDIF}
    If ((last_lit and 7) = 0) then
    begin
     flag_buf^[last_flags] := flags;
     Inc(last_flags);
     flags := 0; flag_bit := 1;
    end;
    If (FPackLevel > 2) and ((last_lit and $FFF) = 0) then
     begin
        out_length := last_lit * 8;
        in_length := strstart - block_start;
        for dcode := 0 to D_CODES-1 do
           Inc(out_length,LongInt(LongInt(dyn_dtree[dcode].fc.freq)*LongInt(5+extra_dbits[dcode])));
        out_length := out_length shr 3;
        if (last_dist < last_lit div 2) and (out_length < in_length div 2) then
         begin
           Result := True;
           exit;
         end;
     end;
    Result := (last_lit = LIT_BUFSIZE-1) or (last_dist = DIST_BUFSIZE);
end;

{* ===========================================================================
 * Restore the heap property by moving down the tree starting at node k,
 * exchanging a node with the smallest of its two sons if necessary, stopping
 * when the heap property is re-established (each father smaller than its
 * two sons).
 *}
procedure pqdownheap(tree: ct_dataArrayPtr; k: LongInt);
var
    { tree    = the tree to restore }
    { k       = node to move down }
    v:     LongInt;
    j:     LongInt;  { left son of k }
    htemp: LongInt;  { required because of bug in SASC compiler }
begin
     v := heap[k];
     j := k shl 1;
    while (j <= heap_len) do
     begin
        { Set j to the smallest of the two sons: }
        if (j < heap_len) and (smaller(tree, heap[j+1], heap[j])) then
           Inc(j);

        { Exit if v is smaller than both sons }
        htemp := heap[j];
        if (smaller(tree, v, htemp)) then
           break;

        { Exchange v with the smallest son }
        heap[k] := htemp;
        k := j;

        { And continue down the tree, setting j to the left son of k }
        j := j shl 1;
    end;
    heap[k] := v;
end;

procedure pqremove( tree: ct_dataArrayPtr; var top: LongInt);
begin
  top := heap[SMALLEST];
  heap[SMALLEST] := heap[heap_len];
  Dec(heap_len);
  pqdownheap(tree, SMALLEST);
end;

{* ===========================================================================
 * Compute the optimal bit lengths for a tree and update the total bit length
 * for the current block.
 * IN assertion: the fields freq and dad are set, heap[heap_max] and
 *    above are the tree nodes sorted by increasing frequency.
 * OUT assertions: the field len is set to the optimal bit length, the
 *     array bl_count contains the frequencies for each bit length.
 *     The length opt_len is updated; static_len is also updated if stree is
 *     not null.
 *}
procedure gen_bitlen(desc: tree_desc);  { Checked out 6/14}
var
    { desc    = the tree descriptor }
    tree:           ct_dataArrayPtr;
    extra:          IntegerArrayPtr;
    base:           LongInt;
    max_code:       LongInt;
    max_length:     LongInt;
    stree:          ct_dataArrayPtr;
    h:              LongInt;         { heap index }
    n, m:           LongInt;         { iterate over the tree elements }
    bits:           LongInt;         { bit length }
    xbits:          LongInt;         { extra bits }
    f:              WORD;            { frequency }
    overflow:       LongInt;         { number of elements with bit length too large }
begin
    tree := desc.dyn_tree;
    extra := desc.extra_bits;
    base := desc.extra_base;
    max_code := desc.max_code;
    max_length := desc.max_length;
    stree := desc.static_tree;
    overflow := 0;

    for bits := 0 to MAX_ZBITS do
     bl_count[bits] := 0;

    {* In a first pass, compute the optimal bit lengths (which may
     * overflow in the case of the bit length tree).
     *}
    tree^[heap[heap_max]].dl.len := 0; { root of the heap }

    for h := heap_max+1 to HEAP_SIZE-1 do
     begin
        n := heap[h];
        bits := tree^[tree^[n].dl.dad].dl.len + 1;
        if (bits > max_length) then
         begin
           bits := max_length;
           Inc(overflow);
         end;
        tree^[n].dl.len := bits;
        { We overwrite tree[n].Dad which is no longer needed }

        if (n > max_code) then
           continue;   { not a leaf node }

        Inc(bl_count[bits]);
        xbits := 0;
        if (n >= base) then
           xbits := extra^[n-base];
        f := tree^[n].fc.freq;
        Inc(opt_len,LongInt(LongInt(f) * LongInt((bits + xbits))));
        if (stree <> nil) then
           Inc(static_len,LongInt(LongInt(f)*LongInt((stree^[n].dl.len + xbits))));
     end;
    if (overflow = 0) then
        exit;

    {Trace((stderr,"\nbit length overflow\n"));}
    { This happens for example on obj2 and pic of the Calgary corpus }

    { Find the first bit length which could increase: }
    Repeat
        bits := max_length-1;
        while (bl_count[bits] = 0) do
           Dec(bits);
        Dec(bl_count[bits]);      { move one leaf down the tree }
        Inc(bl_count[bits+1],2);  { move one overflow item as its brother }
        Dec(bl_count[max_length]);
        {* The brother of the overflow item also moves one step up,
         * but this does not affect bl_count[max_length]
         *}
        Dec(overflow,2);
    Until overflow <= 0;

    {* Now recompute all bit lengths, scanning in increasing frequency.
     * h is still equal to HEAP_SIZE. (It is simpler to reconstruct all
     * lengths instead of fixing only the wrong ones. This idea is taken
     * from 'ar' written by Haruhiko Okumura.)
     *}
    h := HEAP_SIZE;  { To be sure }
    for bits := max_length downto 1 do
     begin
        n := bl_count[bits];
        while (n <> 0) do
         begin
            Dec(h);
            m := heap[h];
            if (m > max_code) then
              continue;
            if (tree^[m].dl.len <> WORD(bits)) then
             begin
                {Trace((stderr,"code %d bits %d->%d\n", m, tree[m].Len, bits));}
                Inc(opt_len,LongInt((LongInt(bits-tree^[m].dl.len))*LongInt(tree^[m].fc.freq)));
                tree^[m].dl.len := WORD(bits);
             end;
            Dec(n);
         end;
     end;
end;


{
 * Construct one Huffman tree and assigns the code bit strings and lengths.
 * Update the total bit length for the current block.
 * IN assertion: the field freq is set for all tree elements.
 * OUT assertions: the fields len and code are set to the optimal bit length
 *     and corresponding code. The length opt_len is updated; static_len is
 *     also updated if stree is not null. The field max_code is set.
 }
procedure build_tree(var desc: tree_desc);  {Checked out 6/14}
var
  tree:       ct_dataArrayPtr;
  stree:      ct_dataArrayPtr;
  elems:      LongInt;
  n,m:        LongInt;        { iterate over heap elements }
  max_code:   LongInt;        { largest code with non zero frequency }
  node:       LongInt;        { next internal node of the tree }
  inew:       LongInt;
begin
    tree   := desc.dyn_tree;
    stree  := desc.static_tree;
    elems  := desc.elems;
    max_code := -1;
    node := elems;
    { Construct the initial heap, with least frequent element in
     * heap[SMALLEST]. The sons of heap[n] are heap[2*n] and heap[2*n+1].
     * heap[0] is not used.
     }
    heap_len := 0; heap_max := HEAP_SIZE;
    for n := 0 to elems-1 do
     if (tree^[n].fc.freq <> 0) then
      begin
        Inc(heap_len);
        heap[heap_len] := n;
        max_code := n;
        depth[n] := 0;
      end
     Else
        tree^[n].dl.len := 0;
    { The pkzip format requires that at least one distance code exists,
     * and that at least one bit should be sent even if there is only one
     * possible code. So to avoid special checks later on we force at least
     * two codes of non zero frequency.
     }
    while (heap_len < 2) do
     begin
        Inc(heap_len);
        If max_code <2 then
         begin
           Inc(max_code);
           heap[heap_len] := max_code;
         end
        Else
          heap[heap_len] := 0;
        inew := heap[heap_len];
        tree^[inew].fc.freq := 1;
        depth[inew] := 0;
        Dec(opt_len);
        If (stree <> nil) then
           Dec(static_len,stree^[inew].dl.len);
        { new is 0 or 1 so it does not have extra bits }
     end;
    desc.max_code := max_code;
    { The elements heap[heap_len/2+1 .. heap_len] are leaves of the tree,
     * establish sub-heaps of increasing lengths:
     }
    for n := (heap_len div 2) downto 1 do
     pqdownheap( tree, n );
    { Construct the Huffman tree by repeatedly combining the least two
     * frequent nodes.
     }
    Repeat
        pqremove(tree, n);   { n = node of least frequency }
        m := heap[SMALLEST];  { m = node of next least frequency }
        Dec(heap_max);
        heap[heap_max] := n; { keep the nodes sorted by frequency }
        Dec(heap_max);
        heap[heap_max] := m;
        { Create a new node father of n and m }
        tree^[node].fc.freq := tree^[n].fc.freq + tree^[m].fc.freq;
        depth[node] := Byte( kpmax(depth[n], depth[m]) + 1);
        tree^[m].dl.dad := node;
        tree^[n].dl.dad := node;
        { and insert the new node in the heap }
        heap[SMALLEST] := node;
        Inc(node);
        pqdownheap(tree, SMALLEST);
    Until heap_len < 2;  {while (heap_len >= 2);}
    Dec(heap_max);
    heap[heap_max] := heap[SMALLEST];
    { At this point, the fields freq and dad are set. We can now
     * generate the bit lengths.
     }
    gen_bitlen(desc);
    { The field len is now set, we can generate the bit codes }
    gen_codes(tree, max_code);
end;

{* ===========================================================================
 * Scan a literal or distance tree to determine the frequencies of the codes
 * in the bit length tree. Updates opt_len to take into account the repeat
 * counts. (The contribution of the bit length codes will be added later
 * during the construction of bl_tree.)
 *}
procedure scan_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:              LongInt;       { 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;
    if (nextlen = 0) then
     begin
        max_count := 138;
        min_count := 3;
     end;
    tree^[max_code+1].dl.len := WORD(-1); { guard }

    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
            Inc(bl_tree[curlen].fc.freq,icount)
        Else if (curlen <> 0) then
         begin
            if (curlen <> prevlen) then
              Inc(bl_tree[curlen].fc.freq);
            Inc(bl_tree[REP_3_6].fc.freq);
         end
        Else if (icount <= 10) then