abdfstrm.pas

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

  {flush the bit buffer to the underlying stream}
  while (FBitsUsed <> 0) do begin
    if (FBufEnd = FBufPos) then
      obsEmptyBuffer;
    FBufPos^ := AnsiChar(FBitBuffer and $FF);
    inc(FBufPos);
    FBitBuffer := FBitBuffer shr 8;
    dec(FBitsUsed, 8);
  end;

  {copy over the data to the underlying stream}
  BytesToCopy := FBufEnd - FBufPos;
  if (BytesToCopy > aCount) then
    BytesToCopy := aCount;
  Move(Buffer^, FBufPos^, BytesToCopy);
  inc(FBufPos, BytesToCopy);
  dec(aCount, BytesToCopy);
  while (aCount <> 0) do begin
    inc(Buffer, BytesToCopy);
    obsEmptyBuffer;
    BytesToCopy := FBufEnd - FBufPos;
    if (BytesToCopy > aCount) then
      BytesToCopy := aCount;
    Move(Buffer^, FBufPos^, BytesToCopy);
    inc(FBufPos, BytesToCopy);
    dec(aCount, BytesToCopy);
  end;

  {finish with a flushed buffer}
  obsEmptyBuffer;
end;
{--------}
procedure TAbDfOutBitStream.WriteMoreBits(aBits : integer; aCount : integer);
begin
  {the bit buffer is now full, so flush it}
  if ((FBufEnd - FBufPos) < sizeof(TAb32bit)) then
    obsEmptyBuffer;
  PAb32bit(FBufPos)^ := FBitBuffer;
  inc(FBufPos, sizeof(TAb32bit));

  {patch up the bit buffer and the number of bits used}
  dec(FBitsUsed, 32);
  FBitBuffer := aBits shr (aCount - FBitsUsed);
end;
{====================================================================}


{===TAbDfLZStream====================================================}
const
  {Implementation note: this stream size has been chosen so that if
   the data must be stored, a block size of about 64K will result}
  StreamSize = 160 * 1024;
type
  PWord = ^word;
{--------}
constructor TAbDfLZStream.Create(aSlideWin     : TAbDfInputWindow;
                                 aUseDeflate64 : boolean;
                                 aLog          : TAbLogger);
begin
  {create the ancestor}
  inherited Create;

  {save the sliding window and the logger}
  FSlideWin := aSlideWin;
  FUseDeflate64 := aUseDeflate64;
  FLog := aLog;

  {create the buckets}
  New(FDistBuckets);
  New(FLitBuckets);

  {create the memory stream, allocate its buffer, position at start}
  GetMem(FStream, StreamSize);
  Clear;
end;
{--------}
destructor TAbDfLZStream.Destroy;
begin
  {free the buckets}
  if (FDistBuckets <> nil) then
    Dispose(FDistBuckets);
  if (FLitBuckets <> nil) then
    Dispose(FLitBuckets);

  {free the memory stream}
  if (FStream <> nil) then
    FreeMem(FStream);

  {destroy the ancestor}
  inherited Destroy;
end;
{--------}
{$IFDEF UseLogging}
procedure AddLenDistToLog(aLog     : TAbLogger;
                          aPosn    : longint;
                          aLen     : integer;
                          aDist    : integer;
                          aOverLap : boolean);
begin
  {NOTE the reason for this separate routine is to avoid string
        allocations and try..finally blocks in the main method: an
        optimization issue}
  if aOverLap then
    aLog.WriteLine(Format('%8x Len: %-3d, Dist: %-5d  **overlap**',
                          [aPosn, aLen, aDist]))
  else
    aLog.WriteLine(Format('%8x Len: %-3d, Dist: %-5d',
                          [aPosn, aLen, aDist]));
end;
{$ENDIF}
{--------}
function TAbDfLZStream.AddLenDist(aLen : integer; aDist : integer)
                                                            : boolean;
var
  LenSymbol  : integer;
  DistSymbol : integer;
  CurPos     : PAnsiChar;
begin
  {$IFDEF UseLogging}
  {log it}
  if (FLog <> nil) then begin
    if (aLen > aDist) then
      AddLenDistToLog(FLog, FSWPos, aLen, aDist, true)
    else
      AddLenDistToLog(FLog, FSWPos, aLen, aDist, false);
    inc(FSWPos, aLen);
  end;
  {$ENDIF}

  {write a length/distance record to the stream}
  CurPos := FCurPos;
  CurPos^ := AnsiChar(false);
  inc(CurPos);
  PWord(CurPos)^ := word(aLen - 1);
  inc(CurPos, sizeof(word));
  PWord(CurPos)^ := word(aDist - 1);
  inc(CurPos, sizeof(word));
  FCurPos := CurPos;

  {increment the various counters}
  inc(FDistCount);
  inc(FStoredSize, aLen);

  {convert the length and distance to their symbols}
  {$IFOPT C+} {if Assertions are on}
  LenSymbol := AbSymbolTranslator.TranslateLength(aLen);
  DistSymbol := AbSymbolTranslator.TranslateDistance(aDist);
  {$ELSE}
  if (3 <= aLen) and (aLen <= 258) then
    LenSymbol := AbSymbolTranslator.LenSymbols[aLen-3] + 257
  else
    LenSymbol := 285;
  if (aDist <= 256) then
    DistSymbol := AbSymbolTranslator.ShortDistSymbols[aDist - 1]
  else if (aDist <= 32768) then
    DistSymbol := AbSymbolTranslator.MediumDistSymbols[((aDist - 1) div 128) - 2]
  else
    DistSymbol := AbSymbolTranslator.LongDistSymbols[((aDist - 1) div 16384) - 2];
  {$ENDIF}

  {increment the buckets}
  inc(FLitBuckets^[LenSymbol]);
  inc(FDistBuckets^[DistSymbol]);

  {return whether the stream is full and needs encoding}
  Result := lzsIsFull;
end;
{--------}
{$IFDEF UseLogging}
procedure AddLiteralToLog(aLog     : TAbLogger;
                          aPosn    : longint;
                          aCh      : AnsiChar);
begin
  {NOTE the reason for this separate routine is to avoid string
        allocations and try..finally blocks in the main method: an
        optimization issue}
  if (' ' < aCh) and (aCh <= '~') then
    aLog.WriteLine(Format('%8x Char: %3d $%2x [%s]', [aPosn, ord(aCh), ord(aCh), aCh]))
  else
    aLog.WriteLine(Format('%8x Char: %3d $%2x', [aPosn, ord(aCh), ord(aCh)]));
end;
{$ENDIF}
{--------}
function TAbDfLZStream.AddLiteral(aCh : AnsiChar) : boolean;
var
  CurPos : PAnsiChar;
begin
  {$IFDEF UseLogging}
  {log it}
  if (FLog <> nil) then begin
    AddLiteralToLog(FLog, FSWPos, aCh);
    inc(FSWPos);
  end;
  {$ENDIF}

  {write a literal to the internal stream}
  CurPos := FCurPos;
  CurPos^ := AnsiChar(true);
  inc(CurPos);
  CurPos^ := aCh;
  inc(CurPos);
  FCurPos := CurPos;

  {increment the various counters}
  inc(FLitCount);
  inc(FLitBuckets^[byte(aCh)]);
  inc(FStoredSize);

  {return whether the stream is full and needs encoding}
  Result := lzsIsFull;
end;
{--------}
procedure TAbDfLZStream.Clear;
begin
  {position the stream at the start}
  Rewind;

  {reset all variables}
  FStrmEnd := nil;
  FLitCount := 0;
  FDistCount := 0;
  FStartOfs := FSlideWin.Position;
  FStoredSize := 0;
  {$IFDEF UseLogging}
  FSWPos := FStartOfs;
  {$ENDIF}

  {reset the buckets}
  FillChar(FLitBuckets^, sizeof(FLitBuckets^), 0);
  FLitBuckets^[256] := 1; { end-of-block marker: it's always there...}
  FillChar(FDistBuckets^, sizeof(FDistBuckets^), 0);
end;
{--------}
procedure TAbDfLZStream.Encode(aBitStrm      : TAbDfOutBitStream;
                               aLitTree      : TAbDfDecodeHuffmanTree;
                               aDistTree     : TAbDfDecodeHuffmanTree;
                               aUseDeflate64 : boolean);
var
  Len       : integer;
  Dist      : integer;
  Symbol    : integer;
  CurPos    : PAnsiChar;
  StrmEnd   : PAnsiChar;
  Code      : longint;
  ExtraBits : longint;
begin
  {rewind the LZ77 stream}
  Rewind;

  {for speed use local variables}
  CurPos := FCurPos;
  StrmEnd := FStrmEnd;

  {while there are still items in the stream...}
  while (CurPos < StrmEnd) do begin

    {if the next item is a literal...}
    if boolean(PByte(CurPos)^) then begin

      {encode the literal character as a symbol}
      inc(CurPos);
      {$IFOPT C+} {if Assertions are on}
      Code := aLitTree.Encode(byte(CurPos^));
      {$ELSE}
      Code := aLitTree.Encodes^[byte(CurPos^)];
      {$ENDIF}
      inc(CurPos);

      {write the code out to the bit stream}
      {$IFOPT C+}
      aBitStrm.WriteBits(Code and $FFFF, (Code shr 16) and $FF);
      {$ELSE}
      with aBitStrm do begin
        BitBuffer := BitBuffer or ((Code and $FFFF) shl BitsUsed);
        BitsUsed := BitsUsed + ((Code shr 16) and $FF);
        if (BitsUsed >= 32) then
          WriteMoreBits(Code and $FFFF, (Code shr 16) and $FF);
      end;
      {$ENDIF}
    end

    {otherwise it's a length/distance pair}
    else begin

      {DO THE LENGTH FIRST-------------------------------------------}
      {get the length from the stream}
      inc(CurPos);
      Len := integer(PWord(CurPos)^) + 1;
      inc(CurPos, sizeof(word));

      {translate it to a symbol and convert that to a code using the
       literal/length huffman tree}
      {$IFOPT C+} {if Assertions are on}
      Symbol := AbSymbolTranslator.TranslateLength(Len);
      Code := aLitTree.Encode(Symbol);
      {$ELSE}
      if (3 <= Len) and (Len <= 258) then
        Symbol := AbSymbolTranslator.LenSymbols[Len-3] + 257
      else
        Symbol := 285;
      Code := aLitTree.Encodes^[Symbol];
      {$ENDIF}

      {output the length code}
      {$IFOPT C+}
      aBitStrm.WriteBits(Code and $FFFF, (Code shr 16) and $FF);
      {$ELSE}
      with aBitStrm do begin
        BitBuffer := BitBuffer or ((Code and $FFFF) shl BitsUsed);
        BitsUsed := BitsUsed + ((Code shr 16) and $FF);
        if (BitsUsed >= 32) then
          WriteMoreBits(Code and $FFFF, (Code shr 16) and $FF);
      end;
      {$ENDIF}

      {if the length symbol were 285, its definition changes from Deflate
       to Deflate64, so make it a special case: for Deflate there are no
       extra bits, for Deflate64 output the (length - 3) as 16 bits}
      if (Symbol = 285) then begin
        if aUseDeflate64 then begin
          {$IFOPT C+}
          aBitStrm.WriteBits(Len - 3, 16);
          {$ELSE}
          with aBitStrm do begin
            BitBuffer := BitBuffer or ((Len - 3) shl BitsUsed);
            BitsUsed := BitsUsed + 16;
            if (BitsUsed >= 32) then
              WriteMoreBits(Len - 3, 16);
          end;
          {$ENDIF}
        end;
      end

      {otherwise if there are extra bits to be output for this length,
       calculate them and output them}
      else begin
        ExtraBits := Code shr 24;
        if (ExtraBits <> 0) then begin
          {$IFOPT C+}
          aBitStrm.WriteBits((Len - dfc_LengthBase[Symbol - 257]),
                              ExtraBits);
          {$ELSE}
          with aBitStrm do begin
            BitBuffer := BitBuffer or
                  ((Len - dfc_LengthBase[Symbol - 257]) shl BitsUsed);
            BitsUsed := BitsUsed + ExtraBits;
            if (BitsUsed >= 32) then
              WriteMoreBits((Len - dfc_LengthBase[Symbol - 257]),
                            ExtraBits);
          end;
          {$ENDIF}
        end;
      end;

      {DO THE DISTANCE NEXT------------------------------------------}
      {get the distance from the stream}
      Dist := integer(PWord(CurPos)^) + 1;
      inc(CurPos, sizeof(word));

      {translate it to a symbol and convert that to a code using the
       distance huffman tree}
      {$IFOPT C+} {if Assertions are on}
      Symbol := AbSymbolTranslator.TranslateDistance(Dist);
      Assert(aUseDeflate64 or (Symbol < 30),
         'TAbDfLZStream.Encode: a Deflate64 distance symbol has been generated for Deflate');
      Code := aDistTree.Encode(Symbol);
      {$ELSE}
      if (Dist <= 256) then
        Symbol := AbSymbolTranslator.ShortDistSymbols[Dist - 1]
      else if (Dist <= 32768) then
        Symbol := AbSymbolTranslator.MediumDistSymbols[((Dist - 1) div 128) - 2]
      else
        Symbol := AbSymbolTranslator.LongDistSymbols[((Dist - 1) div 16384) - 2];
      Code := aDistTree.Encodes^[Symbol];
      {$ENDIF}

      {output the distance code}
      {$IFOPT C+}
      aBitStrm.WriteBits(Code and $FFFF, (Code shr 16) and $FF);
      {$ELSE}