unit ddeflate;

//
//  RFC-1951 DEFLATE Compressed Data Format Specification version 1.3
//    https://www.ietf.org/rfc/rfc1951.txt
//

{$MODE FPC}
{$MODESWITCH OUT}
{$MODESWITCH RESULT}

interface

uses
  dbitmem_le;

const
  DEFLATE_CLCIDX: array[0 .. 19 - 1] of Byte = (
    16, 17, 18, 0, 8, 7, 9, 6,
    10, 5, 11, 4, 12, 3, 13, 2,
    14, 1, 15
  );

  DEFLATE_LENGTH_BITS: array[0 .. 29 - 1] of Byte = (
    0, 0, 0, 0, 0, 0, 0, 0,
    1, 1, 1, 1, 2, 2, 2, 2,
    3, 3, 3, 3, 4, 4, 4, 4,
    5, 5, 5, 5, 0
  );
  DEFLATE_LENGTH_BASE: array[0 .. 29 - 1] of UInt16 = (
    3, 4, 5, 6, 7, 8, 9, 10,
    11, 13, 15, 17, 19, 23, 27, 31,
    35, 43, 51, 59, 67, 83, 99, 115,
    131, 163, 195, 227, 258
  );

  DEFLATE_DISTANCE_BITS: array[0 .. 30 - 1] of Byte = (
    0, 0, 0, 0, 1, 1, 2, 2,
    3, 3, 4, 4, 5, 5, 6, 6,
    7, 7, 8, 8, 9, 9, 10, 10,
    11, 11, 12, 12, 13, 13
  );
  DEFLATE_DISTANCE_BASE: array[0 .. 30 - 1] of UInt16 = (
    1, 2, 3, 4, 5, 7, 9, 13,
    17, 25, 33, 49, 65, 97, 129, 193,
    257, 385, 513, 769, 1025, 1537, 2049, 3073,
    4097, 6145, 8193, 12289, 16385, 24577
  );

type
PHuffmanTree = ^THuffmanTree;
THuffmanTree = record
  Len: array[0 .. 16 - 1] of UInt16;
  Code: array[0 .. 288 - 1] of UInt16;
end;

procedure DeflateBuildFixedTrees(out LiteralTree: THuffmanTree;
                                 out DistanceTree: THuffmanTree);

procedure DeflateBuildTree(Lengths: PByte;
                           Count: LongInt;
                           out Tree: THuffmanTree);

function DeflateDecodeSymbol(var Data: Pointer;
                             var BitOffset: LongInt;
                             DataEnd: Pointer;
                             Tree: PHuffmanTree): LongInt;
      // Returns <0 on error.

function DeflateReadTrees(var Data: Pointer;
                          var BitOffset: LongInt;
                          DataEnd: Pointer;
                          out LiteralTree: THuffmanTree;
                          out DistanceTree: THuffmanTree): Boolean;

function DeflateReadLength(var Data: Pointer;
                           var BitOffset: LongInt;
                           DataEnd: Pointer;
                           Sym: LongInt): LongInt; inline;

function DeflateReadDistance(var Data: Pointer;
                             var BitOffset: LongInt;
                             DataEnd: Pointer;
                             Sym: LongInt): LongInt; inline;

implementation

procedure DeflateBuildFixedTrees(out LiteralTree: THuffmanTree;
                                 out DistanceTree: THuffmanTree);
var
  I: LongInt;
begin
  for I := 0 to 6 do
    LiteralTree.Len[I] := 0;
  LiteralTree.Len[7] := 24;
  LiteralTree.Len[8] := 152;
  LiteralTree.Len[9] := 112;
  for I := 0 to 23 do
    LiteralTree.Code[I] := 256 + I;
  for I := 24 to 167 do
    LiteralTree.Code[I] := I - 24;
  for I := 168 to 175 do
    LiteralTree.Code[I] := I - 168 + 280;
  for I := 176 to 287 do
    LiteralTree.Code[I] := I - 176 + 144;

  for I := 0 to 4 do
    DistanceTree.Len[I] := 0;
  DistanceTree.Len[5] := 32;
  for I := 0 to 32 - 1 do
    DistanceTree.Code[I] := I;
end;

procedure DeflateBuildTree(Lengths: PByte;
                           Count: LongInt;
                           out Tree: THuffmanTree);
var
  Offs: array[0 .. 16 - 1] of UInt16;
  I, Sum: Cardinal;
begin
  for I := 0 to 16 - 1 do
    Tree.Len[I] := 0;
  for I := 0 to Count - 1 do
    Inc(Tree.Len[Lengths[I]]);
  Tree.Len[0] := 0;
  Sum := 0;
  for I := 0 to 16 - 1 do begin
    Offs[I] := Sum;
    Inc(Sum, Tree.Len[I]);
  end;
  for I := 0 to Count - 1 do begin
    if Lengths[I] <> 0 then begin
      Tree.Code[Offs[Lengths[I]]] := I;
      Inc(Offs[Lengths[I]]);
    end;
  end;
end;

function DeflateDecodeSymbol(var Data: Pointer;
                             var BitOffset: LongInt;
                             DataEnd: Pointer;
                             Tree: PHuffmanTree): LongInt;
var
  Sum, Cur, Len: LongInt;
begin
  Sum := 0;
  Cur := 0;
  Len := 0;
  repeat
    Cur := Cur * 2 + ReadBitLE(Data, BitOffset, Data, BitOffset);
    Inc(Len);
    if Len >= Length(Tree^.Len) then
      Exit(-1);
    Inc(Sum, Tree^.Len[Len]);
    Dec(Cur, Tree^.Len[Len]);
  until Cur < 0;
  Inc(Sum, Cur);
  if (Sum < 0) or (Sum >= Length(Tree^.Code)) then
    Exit(-2);
  Exit(Tree^.Code[Sum]);
end;

function DeflateReadTrees(var Data: Pointer;
                          var BitOffset: LongInt;
                          DataEnd: Pointer;
                          out LiteralTree: THuffmanTree;
                          out DistanceTree: THuffmanTree): Boolean;
var
  Sym: LongInt;
  Lengths: array[0 .. 288 + 32 - 1] of Byte;
  Hlit, Hdist, Hclen, Hlimit: Cardinal;
  I, Num, Len: Cardinal;
  Clen: Cardinal;
  FillValue: Byte;
  LBits, LBase: LongInt;
begin
  Hlit := ReadBitsLE(Data, BitOffset, 5, Data, BitOffset) + 257;
  Hdist := ReadBitsLE(Data, BitOffset, 5, Data, BitOffset) + 1;
  Hclen := ReadBitsLE(Data, BitOffset, 4, Data, BitOffset) + 4;
  for I := 0 to 19 - 1 do
    Lengths[I] := 0;
  for I := 0 to Hclen - 1 do begin
    Clen := ReadBitsLE(Data, BitOffset, 3, Data, BitOffset) + 0;
    Lengths[DEFLATE_CLCIDX[I]] := Clen;
  end;
  DeflateBuildTree(@Lengths[0], 19, LiteralTree);

  Hlimit := Hlit + Hdist;
  Num := 0;
  while Num < Hlimit do begin
    Sym := DeflateDecodeSymbol(Data, BitOffset, DataEnd, @LiteralTree);
    FillValue := 0;
    LBits := 3;
    LBase := 3;

    if Sym < 0 then
      Exit(False); // bad sym

    case Sym of
    16: begin
          if Num = 0 then
            Exit(False); // no num
          FillValue := Lengths[Num - 1];
          LBits := 2;
          LBase := 3;
        end;
    17: begin
          FillValue := 0;
          LBits := 3;
          LBase := 3;
        end;
    18: begin
          FillValue := 0;
          LBits := 7;
          LBase := 11;
        end;
    else
      Lengths[Num] := Sym;
      Inc(Num);
      continue;
    end;

    Len := ReadBitsLE(Data, BitOffset, LBits, Data, BitOffset) + LBase;
    if Num + Len > Hlimit then
      Exit(False); // bad len
    while Len > 0 do begin
      Lengths[Num] := FillValue;
      Inc(Num);
      Dec(Len);
    end;
  end;

  DeflateBuildTree(@Lengths[0], Hlit, LiteralTree);
  DeflateBuildTree(@Lengths[Hlit], Hdist, DistanceTree);

  Exit(True);
end;

function DeflateReadLength(var Data: Pointer;
                           var BitOffset: LongInt;
                           DataEnd: Pointer;
                           Sym: LongInt): LongInt; inline;
begin
  Exit(ReadBitsLE(Data, BitOffset, DEFLATE_LENGTH_BITS[Sym], Data, BitOffset) + DEFLATE_LENGTH_BASE[Sym]);
end;

function DeflateReadDistance(var Data: Pointer;
                             var BitOffset: LongInt;
                             DataEnd: Pointer;
                             Sym: LongInt): LongInt; inline;
begin
  Exit(ReadBitsLE(Data, BitOffset, DEFLATE_DISTANCE_BITS[Sym], Data, BitOffset) + DEFLATE_DISTANCE_BASE[Sym]);
end;

end.
