unit dzlib_decompress;

//
//  RFC-1950 ZLIB Compressed Data Format Specification version 3.3
//    https://www.ietf.org/rfc/rfc1950.txt
//  RFC-1951 DEFLATE Compressed Data Format Specification version 1.3
//    https://www.ietf.org/rfc/rfc1951.txt
//  RFC-1952 GZIP file format specification version 4.3
//    https://www.ietf.org/rfc/rfc1952.txt
//

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

interface

type
PZLibHuffmanTree = ^TZLibHuffmanTree;
TZLibHuffmanTree = record
  Table: array[0 .. 16 - 1] of UInt16;
  Trans: array[0 .. 288 - 1] of UInt16;
end;

PInflateState = ^TInflateState;
TInflateState = record
      // Stores state of inflate decompression.
public type
  TState = (
    BLOCK,          // expecting next block
    TREE,           // expecting dynamic Huffman trees
    UNCOMPRESSED,   // processing uncompressed block
    COMPRESSED,     // processing compressed block
    SUCCESS,        // stream has succesfully been decoded
    FAILED          // decoding failed, see Error for error code
  );
public
  Mode: TState;
  InBeg: PByte;           // start of input (compressed) data
  InEnd: PByte;           // end of input (compressed) data
  InCur: PByte;           // cursor to next unprocessed input byte
  OutBeg: PByte;          // start of output buffer to uncompressed data
  OutEnd: PByte;          // end of output buffer
  OutCur: PByte;          // cursor to next free byte in output buffer
  Head: Cardinal;         // cached data from input buffer
  Bit: LongInt;           // bit offset in Head
  Final: Boolean;         // is current buffer final? (BFINAL)
  _Type: LongInt;         // type of current block (BTYPE)
  DictId: UInt32;         // ADLER-32 checksum of dictionary
  DictBeg: PByte;
  DictEnd: PByte;
  Error: LongInt;
  Lit: TZLibHuffmanTree;
  Dist: TZLibHuffmanTree;
end;

procedure ZLibDecompressInit(out State: TInflateState;
                             InBeg: Pointer;
                             SourceLen: SizeUInt); inline; overload;
procedure ZLibDecompressInit(out State: TInflateState;
                             InBeg: Pointer;
                             InEnd: Pointer); overload;

procedure ZLibDecompressDone(var State: TInflateState); inline;

procedure ZLibDecompressSetDest(var State: TInflateState;
                                OutBeg: Pointer;
                                DestLen: SizeUInt); inline; overload;
procedure ZLibDecompressSetDest(var State: TInflateState;
                                OutBeg: Pointer;
                                OutEnd: Pointer); overload;

procedure ZLibDecompressSetDictionary(var State: TInflateState;
                                    Dictionary: Pointer;
                                    DictionaryLen: SizeUInt); inline; overload;
procedure ZLibDecompressSetDictionary(var State: TInflateState;
                                      Dictionary: Pointer;
                                      DictionaryEnd: Pointer); overload;

function Inflate(var State: TInflateState): Boolean;

implementation

{$IFDEF ENDIAN_LITTLE}
{$ELSE}
  {$MACRO ON}
  // We do not swap bytes order on big endian machine, just reinterpret them.
  {$DEFINE SwapEndian := }
{$ENDIF}

procedure ZLibDecompressInit(out State: TInflateState;
                             InBeg: Pointer;
                             SourceLen: SizeUInt); inline;
begin
end;

procedure ZLibDecompressInit(out State: TInflateState;
                             InBeg, InEnd: Pointer);
begin
end;

procedure ZLibDecompressDone(var State: TInflateState);
begin
end;

procedure ZLibDecompressSetDest(var State: TInflateState;
                                OutBeg: Pointer;
                                DestLen: SizeUInt);
begin
  ZLibDecompressSetDest(State, OutBeg, OutBeg + DestLen);
end;

procedure ZLibDecompressSetDest(var State: TInflateState;
                                OutBeg: Pointer;
                                OutEnd: Pointer);
begin
  State.OutBeg := OutBeg;
  State.OutEnd := OutEnd;
end;

procedure ZLibDecompressSetDictionary(var State: TInflateState;
                                    Dictionary: Pointer;
                                    DictionaryLen: SizeUInt);
begin
  ZLibDecompressSetDictionary(State, Dictionary, Dictionary + DictionaryLen);
end;

procedure ZLibDecompressSetDictionary(var State: TInflateState;
                                      Dictionary: Pointer;
                                      DictionaryEnd: Pointer);
begin
  State.DictBeg := Dictionary;
  State.DictEnd := DictionaryEnd;
end;

function LoadBits(var State: TInflateState; Need: LongInt): Boolean;
begin
  Dec(Need, State.Bit);
  while Need > 0 do begin
    if State.InCur >= State.InEnd then begin
      // TODO revert state
      Exit(False);
    end;
    State.Head := State.Head or (State.InCur^ shl State.Bit);
    Inc(State.Bit, 8);
    Inc(State.InCur);
    Dec(Need, 8);
  end;
  Exit(True);
end;

function ReadBit(Head: Cardinal; var State: TInflateState): Cardinal; inline;
begin
  Result := Head and 1;
  State.Head := Head shr 1;
  Dec(State.Bit);
end;

function ReadBits(Head: Cardinal; Bits: LongInt; var State: TInflateState): Cardinal; inline;
begin
  Result := Head and (1 shl Bits - 1);
  State.Head := Head shr Bits;
  Dec(State.Bit, Bits);
end;

function ReadSym(var State: TInflateState; Tree: PZLibHuffmanTree): LongInt;
var
  Sum, Cur, Len: LongInt;
begin
  Sum := 0;
  Cur := 0;
  Len := 0;
  repeat
    LoadBits(State, 1);
    Cur := Cur * 2 + ReadBit(State.Head, State);
    Inc(Len);
    if Len >= Length(Tree^.Table) then
      Exit(-1);
    Inc(Sum, Tree^.Table[Len]);
    Dec(Cur, Tree^.Table[Len]);
  until Cur < 0;
  Inc(Sum, Cur);
  if (Sum < 0) or (Sum >= Length(Tree^.Trans)) then
    Exit(-2);
  Exit(Tree^.Trans[Sum]);
end;

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

function ReadTrees(var State: TInflateState): Boolean;
const
  CodeLengths: 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
  );
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
  if not LoadBits(State, 14) then
    Exit(False);
  Hlit := ReadBits(State.Head, 5, State) + 257;
  Hdist := ReadBits(State.Head, 5, State) + 1;
  Hclen := ReadBits(State.Head, 4, State) + 4;
  for I := 0 to 19 - 1 do
    Lengths[I] := 0;
  for I := 0 to Hclen - 1 do begin
    if not LoadBits(State, 3) then begin
      // TODO rewind
      Exit(False);
    end;
    Clen := ReadBits(State.Head, 3, State);
    Lengths[CodeLengths[I]] := Clen;
  end;
  BuildTree(@Lengths[0], 19, State.Lit);

  Hlimit := Hlit + Hdist;
  Num := 0;
  while Num < Hlimit do begin
    Sym := ReadSym(State, @State.Lit);
    FillValue := 0;
    LBits := 3;
    LBase := 3;

    if Sym < 0 then begin
      // TODO rewind
      Exit(False);
    end;

    case Sym of
    16: begin
          if Num = 0 then begin
            // TODO rewind
            Exit(False);
          end;
          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;

    if not LoadBits(State, LBits) then begin
      // TODO rewind
      Exit(False);
    end;
    Len := ReadBits(State.Head, LBits, State) + LBase;
    if Num + Len > Hlimit then begin
      // TODO rewind
      Exit(False);
    end;
    while Len > 0 do begin
      Lengths[Num] := FillValue;
      Inc(Num);
      Dec(Len);
    end;
  end;

  BuildTree(@Lengths[0], Hlit, State.Lit);
  BuildTree(@Lengths[Hlit], Hdist, State.Dist);
  Exit(True);
end;

function Inflate(var State: TInflateState): Boolean;
label
  LBLOCK, LTREE, LUNCOMPRESSED, LCOMPRESSED, LSUCCESS, LFAILED;
begin
  with State do begin
    case Mode of
      BLOCK: LBLOCK: begin
        if not LoadBits(State, 3) then begin
          Mode := FAILED;
          Exit(False);
        end;
        Final := ReadBit(Head, State) <> 0;
        _Type := ReadBits(Head, 2, State);
        if _Type = 0 then begin
          Mode := UNCOMPRESSED;
          goto LUNCOMPRESSED;
        end else if _Type = 1 then begin
          // TODO Load fixed Trees
          Mode := COMPRESSED;
          goto LCOMPRESSED;
        end else if _Type = 2 then begin
          Mode := TREE;
          goto LTREE;
        end else begin
          Mode := FAILED;
          goto LFAILED;
        end;
      end; // BLOCK
      TREE: LTREE: begin
        if not ReadTrees(State) then begin
          Mode := FAILED;
          goto LFAILED;
        end;
        Mode := COMPRESSED;
        goto LCOMPRESSED;
      end;
      UNCOMPRESSED: LUNCOMPRESSED: begin
        Exit(False);
      end;
      COMPRESSED: LCOMPRESSED: begin
        Exit(False);
      end;
      SUCCESS: LSUCCESS: begin
        Exit(False);
      end;
      FAILED: LFAILED: begin
        Exit(False);
      end;
    end;
  end;
  Exit(False); // Make compiler happy
end;

end.
