abdfenc.pas

Lazarus is a free and open source development tool for the FreePascal Compiler. The purpose of the p

(* ***** BEGIN LICENSE BLOCK *****
 * Version: MPL 1.1
 *
 * The contents of this file are subject to the Mozilla Public License Version
 * 1.1 (the "License"); you may not use this file except in compliance with
 * the License. You may obtain a copy of the License at
 * http://www.mozilla.org/MPL/
 *
 * Software distributed under the License is distributed on an "AS IS" basis,
 * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
 * for the specific language governing rights and limitations under the
 * License.
 *
 * The Original Code is TurboPower Abbrevia
 *
 * The Initial Developer of the Original Code is
 * TurboPower Software
 *
 * Portions created by the Initial Developer are Copyright (C) 1997-2002
 * the Initial Developer. All Rights Reserved.
 *
 * Contributor(s):
 *
 * ***** END LICENSE BLOCK ***** *)

{*********************************************************}
{* ABBREVIA: AbDfEnc.pas 3.05                            *}
{*********************************************************}
{* Deflate encoding unit                                 *}
{*********************************************************}

unit AbDfEnc;

{$I AbDefine.inc}

interface

uses
  SysUtils,
  Classes,
  AbDfBase;

function Deflate(aSource : TStream; aDest : TStream;
                 aHelper : TAbDeflateHelper) : longint;

implementation

uses
  AbDfInW,
  AbDfHufD,
  AbDfStrm,
  AbDfXlat,
  AbDfCryS,
  AbDfPkMg;

{====================================================================}
function CalcDynamicBitCount(aUseDeflate64: boolean;
                             aLitBuckets  : PAbDfLitBuckets;
                             aDistBuckets : PAbDfDistBuckets;
                             aCodeBuckets : PAbDfCodeLenBuckets;
                       const aCodeLens    : array of integer;
                       const aCLCodeLens  : array of integer;
                             aLitCount    : integer;
                             aDistCount   : integer;
                             aCodeCount   : integer) : longint;
var
  Symbol     : integer;
  LastSymbol : integer;
  Inx        : integer;
begin
  {note: this routine calculates the number of bits required to
         compress a given block}

  {a dynamic block starts off with 5 bits of literal symbol count, 5
   bits of distance symbol count, 4 bits of codelength symbol count,
   and then 3 bits for every codelength symbol used}
  Result := 5 + 5 + 4 +
            (aCodeCount * 3);

  {add in the bits needed to compress the literal and distance trees}
  inc(Result, aCodeBuckets^[16] * (aCLCodeLens[16] + 2));
  inc(Result, aCodeBuckets^[17] * (aCLCodeLens[16] + 3));
  inc(Result, aCodeBuckets^[18] * (aCLCodeLens[16] + 7));
  for Symbol := 3 to pred(aCodeCount) do begin
    Inx := dfc_CodeLengthIndex[Symbol];
    Assert(Inx <=15,
           'CalcDynamicBitCount: the index array of codelengths is corrupted');
    inc(Result, aCodeBuckets^[Inx] * aCLCodeLens[Inx])
  end;

  {make the literal symbol 285 a special case}
  LastSymbol := pred(aLitCount);
  if (LastSymbol = 285) then
    LastSymbol := 284;

  {add in all the bits needed to compress the literals (except 285)}
  for Symbol := 0 to LastSymbol do
    if (Symbol < dfc_LitExtraOffset) then
      inc(Result, aLitBuckets^[Symbol] * aCodeLens[Symbol])
    else
      inc(Result, aLitBuckets^[Symbol] *
                  (aCodeLens[Symbol] +
                   dfc_LitExtraBits[Symbol - dfc_LitExtraOffset]));

  {add in all the bits needed to compress the literal symbol 285}
  if (pred(aLitCount) = 285) then
    if (not aUseDeflate64) then
      inc(Result, aLitBuckets^[285] * aCodeLens[285])
    else
      inc(Result, aLitBuckets^[285] * (aCodeLens[285] + 16));

  {add in all the bits needed to compress the distances}
  for Symbol := 0 to pred(aDistCount) do
    inc(Result, aDistBuckets^[Symbol] *
                (aCodeLens[aLitCount + Symbol] +
                 dfc_DistExtraBits[Symbol]));
end;
{====================================================================}


{====================================================================}
procedure OutputEndOfBlock(aBitStrm : TAbDfOutBitStream;
                           aLitTree : TAbDfDecodeHuffmanTree);
var
  Code : longint;
begin
  {note: this routine encodes the end-of-block character (symbol 256)
         and then writes out the code to the bit stream}

  {encode the end-of-block character as a symbol}
  {$IFOPT C+} {if Assertions are on }
  Code := aLitTree.Encode(256);
  {$ELSE}
  Code := aLitTree.Encodes^[256];
  {$ENDIF}

  {write the code out to the bit stream}
  aBitStrm.WriteBits(Code and $FFFF, (Code shr 16) and $FF);
end;
{--------}
procedure EncodeLZStreamStored(aFinalBlock   : boolean;
                               aStream       : TAbDfLZStream;
                               aBitStrm      : TAbDfOutBitStream;
                               aDataSize     : integer;
                               aLog          : TAbLogger);
var
  BlockHeader : packed record
    bhSize    : word;
    bhNotSize : word;
  end;
  Buffer    : pointer;
  Code      : integer;
  BlockSize : integer;
begin
  {note: this routine writes out an incompressible block to the bit
         stream (the store algorithm)}

  {allocate the maximum buffer we can write at once}
  GetMem(Buffer, 64 * 1024);
  try

    {while there's more incompressible data to store...}
    while (aDataSize <> 0) do begin

      {calculate the block size to write this time}
      if (aDataSize > $FFFF) then begin
        BlockSize := $FFFF;
        dec(aDataSize, $FFFF);
      end
      else begin
        BlockSize := aDataSize;
        aDataSize := 0;
      end;

      {$IFDEF UseLogging}
      {log it}
      if (aLog <> nil) then begin
        aLog.WriteLine('..Writing new block...');
        aLog.WriteLine(Format('..final block? %d', [ord(aFinalBlock)]));
        aLog.WriteLine('..block type? 0');
        aLog.WriteLine(Format('..block size:  %d', [BlockSize]));
      end;
      {$ENDIF}

      {output the block information to the bit stream}
      if aFinalBlock then
        Code := 1 + (0 shl 1)
      else
        Code := 0 + (0 shl 1);
      aBitStrm.WriteBits(Code, 3);

      {align the bit stream to the nearest byte}
      aBitStrm.AlignToByte;

      {write the stored block header}
      BlockHeader.bhSize := BlockSize;
      BlockHeader.bhNotSize := not BlockHeader.bhSize;
      aBitStrm.WriteBuffer(BlockHeader, sizeof(BlockHeader));

      {get and write this block}
      aStream.ReadStoredBuffer(Buffer^, BlockSize);
      aBitStrm.WriteBuffer(Buffer^, BlockSize);
    end;
  finally
    FreeMem(Buffer);
  end;

  {clear the stream, ready for the next block}
  aStream.Clear;
end;
{--------}
procedure EncodeLZStreamStatic(aFinalBlock   : boolean;
                               aUseDeflate64 : boolean;
                               aStream       : TAbDfLZStream;
                               aBitStrm      : TAbDfOutBitStream;
                               aLog          : TAbLogger);
var
  Code : integer;
begin
  {note: this routine writes out the stream of LZ77 tokens for the
         current block to the bit stream, using the static huffman
         trees to encode the token symbols}

  {$IFDEF UseLogging}
  {log it}
  if (aLog <> nil) then begin
    aLog.WriteLine('..Writing new block...');
    aLog.WriteLine(Format('..final block? %d', [ord(aFinalBlock)]));
    aLog.WriteLine('..block type? 1');
  end;
  {$ENDIF}

  {output the block information to the bit stream}
  if aFinalBlock then
    Code := 1 + (1 shl 1)
  else
    Code := 0 + (1 shl 1);
  aBitStrm.WriteBits(Code, 3);

  {encode the LZ77 stream}
  aStream.Encode(aBitStrm,
                 AbStaticLiteralTree, AbStaticDistanceTree,
                 aUseDeflate64);

  {output the end-of-block marker to the bit stream}
  OutputEndOfBlock(aBitStrm, AbStaticLiteralTree);
  {$IFDEF UseLogging}
  if (aLog <> nil) then
    aLog.WriteLine('Char: end-of-block marker (#256)');
  {$ENDIF}
end;
{--------}
procedure EncodeLZStreamDynamic(aFinalBlock   : boolean;
                                aUseDeflate64 : boolean;
                                aUseBest      : boolean;
                                aStream       : TAbDfLZStream;
                                aBitStrm      : TAbDfOutBitStream;
                                aLog          : TAbLogger);
var
  i : integer;
  LitTree     : TAbDfDecodeHuffmanTree;
  DistTree    : TAbDfDecodeHuffmanTree;
  CodeLenTree : TAbDfDecodeHuffmanTree;
  CodeLenStream : TAbDfCodeLenStream;
  CodeLens      : array [0..285+32] of integer;
  CLCodeLens    : array [0..18] of integer;
  LitCodeCount  : integer;
  DistCodeCount : integer;
  LenCodeCount  : integer;
  BitCount      : integer;
  Code          : integer;
  StaticSize    : integer;
  StoredSize    : integer;
begin
  {note: this routine writes out the stream of LZ77 tokens for the
         current block to the bit stream, using the dynamic huffman
         trees to encode the token symbols; if the routine determines
         that the data can better be compressed using the static
         huffman trees or should be stored as is, it'll switch
         algorithms}

  {prepare for the try..finally}
  LitTree := nil;
  DistTree := nil;
  CodeLenTree := nil;
  CodeLenStream := nil;

  try

    {calculate the code lengths for the literal symbols}
    GenerateCodeLengths(15, aStream.LitBuckets^, CodeLens, 0, aLog);

    {calculate the number of the used codelengths for the literals}
    LitCodeCount := 286;
    repeat
      dec(LitCodeCount);
    until (CodeLens[LitCodeCount] <> 0);
    inc(LitCodeCount);

    {calculate the code lengths for the distance symbols}
    GenerateCodeLengths(15, aStream.DistBuckets^, CodeLens,
                                                  LitCodeCount, aLog);

    {calculate the number of the used codelengths for the distances}
    DistCodeCount := 32;
    repeat
      dec(DistCodeCount);
    until (CodeLens[DistCodeCount + LitCodeCount] <> 0);
    inc(DistCodeCount);