{$IFDEF FPC}
{$DEFINE NOT_USE_KOL_ERR}
{$MODE Delphi}
{$ASMMODE intel}
{$GOTO ON}
{$ENDIF}

{$IFDEF NO_GIF_OPTIMIZE}
  {$UNDEF ASM_GIF}
  {$UNDEF GIF_MMX}
{$ELSE}
  {$DEFINE ASM_GIF}
  {$DEFINE GIF_MMX}
{$ENDIF}

//{$DEFINE GIF_SAFE} // to check array boundaries while LZW decoding GIF
                     // (this prevents Access Violation exceptions and other
                     // possible errors)

//{$IFDEF GIF_SAFE}
//  {$DEFINE NO_GIF_MMX}
//{$ENDIF}

{$IFDEF NO_GIF_MMX}
  {$UNDEF GIF_MMX}
{$ENDIF}

{$IFNDEF GIF_LOG}
{$O+}
{$ENDIF GIF_LOG}
{$W-}

unit KOLGraphicCompression;

// This file is part of the image library GraphicEx (www.lischke-online.de/Graphics.html).
//
// GraphicCompression contains various encoder/decoder classes used to handle compressed
// data in the various image classes.
//
// Currently supported methods are:
// - LZW (Lempel-Ziff-Welch)
//   + TIF
//   + GIF
// - RLE (run length encoding)
//   + TGA,
//   + PCX,
//   + packbits
//   + SGI
//   + CUT
//   + RLA
//   + PSP
// - CCITT
//   + raw G3 (fax T.4)
//   + modified G3 (CCITT RLE)
//   + modified G3 w/ word alignment (CCITT RLEW)
// - LZ77
// - Thunderscan
// - JPEG
// - PCD Huffmann encoding (photo CD)
//
// (c) Copyright 1999, 2000  Dipl. Ing. Mike Lischke (public@lischke-online.de). All rights reserved.
//
// This package is freeware for non-commercial use only.
// Contact author for licenses (shareware@lischke-online.de) and see License.txt which comes with the package.

//////////////////////////////////////////////////
// Converted to KOL by Dimaxx (dimaxx@atnet.ru) //
//////////////////////////////////////////////////

interface

{$ALIGN OFF}
{$I KOLDEF.INC}

uses Windows, KOL, {$IFDEF NOT_USE_KOL_ERR}sysutils {$ELSE}Err {$ENDIF}, Errors,
  MZLib {$IFDEF GIF_MMX}, Mmx {$ENDIF}; // general inflate/deflate and LZ77 compression support

type
  // abstract decoder class to define the base functionality of an encoder/decoder
  PDecoder = ^TDecoder;
  TDecoder = {$IFDEF NOCLASSES} object(TObj) {$ELSE} class {$ENDIF}
  public
    procedure Decode(var Source,Dest: pointer; PackedSize,UnpackedSize: integer); virtual; abstract;
    procedure DecodeEnd; virtual;
    procedure DecodeInit; virtual;
  end;

  // generally, there should be no need to cover the decoder classes by conditional symbols
  // because the image classes which use the decoder classes are already covered and if they
  // aren't compiled then the decoders are also not compiled (more precisely: not linked)
  PTargaRLEDecoder = ^TTargaRLEDecoder;
  TTargaRLEDecoder = {$IFDEF NOCLASSES} object(TDecoder) {$ELSE} class(TDecoder) {$ENDIF}
  private
    FColorDepth: cardinal;
  public
    constructor Create(ColorDepth: cardinal);
    procedure Decode(var Source,Dest: pointer; PackedSize,UnpackedSize: integer);
      {$IFDEF NOCLASSES} virtual; {$ELSE} override; {$ENDIF}
  end;

  // Lempel-Ziff-Welch encoder/decoder class
  // TIFF LZW compression / decompression is a bit different to the common LZW code
  PTiffLzwDecoder = ^TTIFFLZWDecoder;
  TTIFFLZWDecoder = {$IFDEF NOCLASSES} object(TDecoder) {$ELSE} class(TDecoder) {$ENDIF}
  public
    procedure Decode(var Source,Dest: pointer; PackedSize,UnpackedSize: integer);
      {$IFDEF NOCLASSES} virtual; {$ELSE} override; {$ENDIF}
  end;

  PPackBitsRLEDecoder = ^TPackbitsRLEDecoder;
  TPackbitsRLEDecoder = {$IFDEF NOCLASSES} object(TDecoder) {$ELSE} class(TDecoder) {$ENDIF}
  public
    procedure Decode(var Source,Dest: pointer; PackedSize,UnpackedSize: integer);
      {$IFDEF NOCLASSES} virtual; {$ELSE} override; {$ENDIF}
  end;

  PPcxRLEDecoder = ^TPCXRLEDecoder;
  TPCXRLEDecoder = {$IFDEF NOCLASSES} object(TDecoder) {$ELSE} class(TDecoder) {$ENDIF}
  public
    procedure Decode(var Source,Dest: pointer; PackedSize,UnpackedSize: integer);
      {$IFDEF NOCLASSES} virtual; {$ELSE} override; {$ENDIF}
  end;

  PSGIRLEDecoder = ^TSGIRLEDecoder;
  TSGIRLEDecoder = {$IFDEF NOCLASSES} object(TDecoder) {$ELSE} class(TDecoder) {$ENDIF}
  private
    FSampleSize: byte; // 8 or 16 bits
  public
    constructor Create(SampleSize: byte);
    procedure Decode(var Source,Dest: pointer; PackedSize,UnpackedSize: integer);
      {$IFDEF NOCLASSES} virtual; {$ELSE} override; {$ENDIF}
  end;

  PCUTRLEDecoder = ^TCUTRLEDecoder;
  TCUTRLEDecoder = {$IFDEF NOCLASSES} object(TDecoder) {$ELSE} class(TDecoder) {$ENDIF}
  public
    procedure Decode(var Source,Dest: pointer; PackedSize,UnpackedSize: integer);
      {$IFDEF NOCLASSES} virtual; {$ELSE} override; {$ENDIF}
  end;

  PPSPRLEDecoder = ^TPSPRLEDecoder;
  TPSPRLEDecoder = {$IFDEF NOCLASSES} object(TDecoder) {$ELSE} class(TDecoder) {$ENDIF}
  public
    procedure Decode(var Source,Dest: pointer; PackedSize,UnpackedSize: integer);
      {$IFDEF NOCLASSES} virtual; {$ELSE} override; {$ENDIF}
  end;

  // Note: We need a different LZW decoder class for GIF because the bit order is reversed compared to that
  //       of TIFF and the code size increment is handled slightly different.
  PGIFLZWDecoder = ^TGIFLZWDecoder;
  TGIFLZWDecoder = {$IFDEF NOCLASSES} object(TDecoder) {$ELSE} class(TDecoder) {$ENDIF}
  private
    FInitialCodeSize: byte;
    FLineWidth: Integer;
    FCorrupted: Boolean;
  public
    constructor Create(InitialCodeSize: byte; linewidth: Integer);
    procedure Decode(var Source,Dest: pointer; PackedSize,UnpackedSize: integer);
      {$IFDEF NOCLASSES} virtual; {$ELSE} override; {$ENDIF}
    procedure CxDecode( var Source, Dest: PByte; PackedSize,UnpackedSize: Integer );
    property GIFCorrupted: Boolean read FCorrupted;
  end;

  PRLADecoder = ^TRLADecoder;
  TRLADecoder = {$IFDEF NOCLASSES} object(TDecoder) {$ELSE} class(TDecoder) {$ENDIF}
  public
    procedure Decode(var Source,Dest: pointer; PackedSize,UnpackedSize: integer);
      {$IFDEF NOCLASSES} virtual; {$ELSE} override; {$ENDIF}
  end;

  TStateEntry = packed record
    NewState: array[Boolean] of cardinal;
    RunLength: integer;
  end;
  TStateArray = array of TStateEntry;

  TCCITTDecoder = {$IFDEF NOCLASSES} object(TDecoder) {$ELSE} class(TDecoder) {$ENDIF}
  private
    FOptions: integer;  // determines some options how to proceed
                        // Bit 0: if set then two-dimensional encoding was used, otherwise one-dimensional
                        // Bit 1: if set then data is uncompressed
                        // Bit 2: if set then fill bits are used before EOL codes so that EOL codes always end at
                        //        at a byte boundary (not used in this context)
    FIsWhite,           // alternating flag used while coding
    FSwapBits: boolean; // True if the order of all bits in a byte must be swapped
    FWhiteStates,
    FBlackStates: TStateArray;
    FWidth: cardinal;   // need to know how line length for modified huffman encoding
                        // coding/encoding variables
    FBitsLeft,FMask,FBits: byte;
    FPackedSize,FRestWidth: cardinal;
    FSource,FTarget: PByte;
    FFreeTargetBits: byte;
    FWordAligned: boolean;
    procedure MakeStates;
  protected
    function FillRun(RunLength: cardinal): boolean;
    function FindBlackCode: integer;
    function FindWhiteCode: integer;
    function NextBit: boolean;
  public
    constructor Create(Options: integer; SwapBits,WordAligned: boolean; Width: cardinal);
  end;

  PCCITTFax3Decoder = ^TCCITTFax3Decoder;
  TCCITTFax3Decoder = {$IFDEF NOCLASSES} object(TCCITTDecoder)
                      {$ELSE} class(TCCITTDecoder) {$ENDIF}
  public
    procedure Decode(var Source,Dest: pointer; PackedSize,UnpackedSize: integer);
      {$IFDEF NOCLASSES} virtual; {$ELSE} override; {$ENDIF}
  end;

  PCCITTFax4Decoder = ^TCCITTFax4Decoder;
  TCCITTFax4Decoder = {$IFDEF NOCLASSES} object(TCCITTDecoder)
                      {$ELSE} class(TCCITTDecoder) {$ENDIF}
  public
    procedure Decode(var Source,Dest: pointer; PackedSize,UnpackedSize: integer);
      {$IFDEF NOCLASSES} virtual; {$ELSE} override; {$ENDIF}
  end;

  PCCITTMHDecoder = ^TCCITTMHDecoder;
  TCCITTMHDecoder = {$IFDEF NOCLASSES} object(TCCITTDecoder)
                      {$ELSE} class(TCCITTDecoder) {$ENDIF} // modified Huffman RLE
  public
    procedure Decode(var Source,Dest: pointer; PackedSize,UnpackedSize: integer);
      {$IFDEF NOCLASSES} virtual; {$ELSE} override; {$ENDIF}
  end;

  PLZ77Decoder = ^TLZ77Decoder;
  TLZ77Decoder = {$IFDEF NOCLASSES} object(TDecoder) {$ELSE} class(TDecoder) {$ENDIF}
  private
    FStream: TZState;
    FZLibResult,         // contains the return code of the last ZLib operation
    FFlushMode: integer; // one of flush constants declard in ZLib.pas
                         // this is usually Z_FINISH for PSP and Z_PARTIAL_FLUSH for PNG
    FAutoReset: boolean; // TIF, PSP and PNG share this decoder, TIF needs a reset for each
                         // decoder run
    function GetAvailableInput: integer;
    function GetAvailableOutput: integer;
  public
    constructor Create(FlushMode: integer; AutoReset: boolean);
    procedure Decode(var Source,Dest: pointer; PackedSize,UnpackedSize: integer);
      {$IFDEF NOCLASSES} virtual; {$ELSE} override; {$ENDIF}
    procedure DecodeEnd;
      {$IFDEF NOCLASSES} virtual; {$ELSE} override; {$ENDIF}
    procedure DecodeInit;
      {$IFDEF NOCLASSES} virtual; {$ELSE} override; {$ENDIF}
    property AvailableInput: integer read GetAvailableInput;
    property AvailableOutput: integer read GetAvailableOutput;
    property ZLibResult: integer read FZLibResult;
  end;

  TThunderDecoder = {$IFDEF NOCLASSES} object(TDecoder) {$ELSE} class(TDecoder) {$ENDIF}
  private
    FWidth: cardinal; // width of a scanline in pixels
  public
    constructor Create(Width: cardinal);
    procedure Decode(var Source,Dest: pointer; PackedSize,UnpackedSize: integer);
      {$IFDEF NOCLASSES} virtual; {$ELSE} override; {$ENDIF}
  end;

  PPCDDecoder = ^TPCDDecoder;
  TPCDDecoder = {$IFDEF NOCLASSES} object(TDecoder) {$ELSE} class(TDecoder) {$ENDIF}
  private
    FStream: PStream;  // decoder must read some data
  public
    constructor Create(Stream: PStream);
    procedure Decode(var Source,Dest: pointer; PackedSize,UnpackedSize: integer);
      {$IFDEF NOCLASSES} virtual; {$ELSE} override; {$ENDIF}
  end;

//----------------------------------------------------------------------------------------------------------------------

implementation

uses {$IFDEF NOT_USE_KOL_ERR}math, {$ELSE}KOLMath, {$ENDIF} KOLGraphicEx, KOLGraphicColor;

const GIFBufSize = {$IFDEF GIF_SAFE} 16384 {$ELSE} 4096 {$ENDIF};
const // LZW encoding and decoding support
  NoLZWCode = 4096;

{$IFDEF GIF_MMX}
var mmxSupported: Boolean;
{$ENDIF}

//----------------------------------------------------------------------------------------------------------------------

{$IFDEF NOT_USE_KOL_ERR}
procedure CompressionError(Code: integer);
var E: Exception;
begin
  E:=Exception.Create(int2str(Code));
  //E.ErrorCode:=Code;
  raise E;
end;
{$ELSE}
procedure CompressionError(Code: integer);
var E: Exception;
begin
  E:=Exception.Create(e_Custom,ErrorMsg[Code]);
  E.ErrorCode:=Code;
  raise E;
end;
{$ENDIF}

//----------------- TDecoder (generic decoder class) -------------------------------------------------------------------

procedure TDecoder.DecodeEnd;
// called after all decompression has been done
begin
end;

//----------------------------------------------------------------------------------------------------------------------

procedure TDecoder.DecodeInit;
// called before any decompression can start
begin
end;

//----------------- TTargaRLEDecoder -----------------------------------------------------------------------------------

constructor TTargaRLEDecoder.Create(ColorDepth: cardinal);
begin
  FColorDepth:=ColorDepth;
end;

//----------------------------------------------------------------------------------------------------------------------

procedure TTargaRLEDecoder.Decode(var Source,Dest: pointer; PackedSize,UnpackedSize: integer);
type
  PCardinalArray = ^TCardinalArray;
  TCardinalArray = array[0..MaxInt div 4-1] of Cardinal;
var I: integer;
    SourcePtr,TargetPtr: PByte;
    RunLength,Sourcecardinal: cardinal;
begin
  TargetPtr:=Dest;
  SourcePtr:=Source;
  // unrolled decoder loop to speed up process
  case FColorDepth of
    8: while UnpackedSize>0 do
         begin
           RunLength:=1+(SourcePtr^ and $7F);
           if SourcePtr^>$7F then
             begin
               Inc(SourcePtr);
               FillChar(TargetPtr^,RunLength,SourcePtr^);
               Inc(TargetPtr,RunLength);
               Inc(SourcePtr);
             end
           else
             begin
               Inc(SourcePtr);
               Move(SourcePtr^,TargetPtr^,RunLength);
               Inc(SourcePtr,RunLength);
               Inc(TargetPtr,RunLength);
             end;
           Dec(UnpackedSize, RunLength);
         end;
    15,
    16: while UnpackedSize>0 do
          begin
            RunLength:=1+(SourcePtr^ and $7F);
            if SourcePtr^>$7F then
              begin
                Inc(SourcePtr);
                for I:=0 to RunLength-1 do
                  begin
                    TargetPtr^:=SourcePtr^;
                    Inc(SourcePtr);
                    Inc(TargetPtr);
                    TargetPtr^:=SourcePtr^;
                    Dec(SourcePtr);
                    Inc(TargetPtr);
                  end;
                Inc(SourcePtr,2);
              end
            else
              begin
                Inc(SourcePtr);
                Move(SourcePtr^,TargetPtr^,2*RunLength);
                Inc(SourcePtr,2*RunLength);
                Inc(TargetPtr,2*RunLength);
              end;
            Dec(UnpackedSize,RunLength);
          end;
    24: while UnpackedSize>0 do
          begin
            RunLength:=1+(SourcePtr^ and $7F);
            if SourcePtr^>$7F then
              begin
                Inc(SourcePtr);
                for I:=0 to RunLength-1 do
                  begin
                    TargetPtr^:=SourcePtr^;
                    Inc(SourcePtr);
                    Inc(TargetPtr);
                    TargetPtr^:=SourcePtr^;
                    Inc(SourcePtr);
                    Inc(TargetPtr);
                    TargetPtr^:=SourcePtr^;
                    Dec(SourcePtr,2);
                    Inc(TargetPtr);
                  end;
                Inc(SourcePtr,3);
              end
            else
              begin
                Inc(SourcePtr);
                Move(SourcePtr^,TargetPtr^,3*RunLength);
                Inc(SourcePtr,3*RunLength);
                Inc(TargetPtr,3*RunLength);
              end;
            Dec(UnpackedSize, RunLength);
          end;
    32: while UnpackedSize>0 do
          begin
            RunLength:=1+(SourcePtr^ and $7F);
            if SourcePtr^>$7F then
              begin
                Inc(SourcePtr);
                SourceCardinal:=PCardinalArray(SourcePtr)[0];
                for I:=0 to RunLength-1 do
                PCardinalArray(TargetPtr)[I]:=SourceCardinal;
                Inc(TargetPtr,4*RunLength);
                Inc(SourcePtr,4);
              end
            else
              begin
                Inc(SourcePtr);
                Move(SourcePtr^,TargetPtr^,4*RunLength);
                Inc(SourcePtr,4*RunLength);
                Inc(TargetPtr,4*RunLength);
              end;
            Dec(UnpackedSize,RunLength);
          end;
  end;
  Source:=SourcePtr;
end;

//----------------- TTIFFLZWDecoder ------------------------------------------------------------------------------------

procedure TTIFFLZWDecoder.Decode(var Source, Dest: pointer; PackedSize, UnpackedSize: integer);
var I: integer;
    Data,                               // current data
    Bits,                               // counter for bit management
    Code: cardinal;                     // current code value
    SourcePtr: PByte;
    InCode: cardinal;                   // Buffer for passed code
    CodeSize,CodeMask,FreeCode,OldCode: cardinal;
    Prefix: array[0..4095] of cardinal; // LZW prefix
    Suffix,                             // LZW suffix
    Stack: array[0..4095] of byte;      // stack
    Stackpointer,Target: PByte;
    FirstChar: byte;                    // Buffer for decoded byte
    ClearCode,EOICode: word;
begin
  Target:=Dest;
  SourcePtr:=Source;
  // initialize parameter
  ClearCode:=1 shl 8;
  EOICode:=ClearCode+1;
  FreeCode:=ClearCode+2;
  OldCode:=NoLZWCode;
  CodeSize:=9;
  CodeMask:=(1 shl CodeSize)-1;
  // init code table
  for I:=0 to ClearCode-1 do
    begin
      Prefix[I]:=NoLZWCode;
      Suffix[I]:=I;
    end;
  // initialize stack
  Stackpointer:=@Stack;
  FirstChar:=0;
  Data:=0;
  Bits:=0;
  while (PackedSize>0) and (UnpackedSize>0) do
    begin
      // read code from bit stream
      Inc(Data,cardinal(SourcePtr^) shl (24-Bits));
      Inc(Bits,8);
      while Bits>=CodeSize do
        begin
          // current code
          Code:=(Data and ($FFFFFFFF-CodeMask)) shr (32-CodeSize);
          // mask it
          Data:=Data shl CodeSize;
          Dec(Bits,CodeSize);
          if Code=EOICode then Exit;
          // handling of clear codes
          if Code=ClearCode then
            begin
              // reset of all variables
              CodeSize:=9;
              CodeMask:=(1 shl CodeSize)-1;
              FreeCode:=ClearCode+2;
              OldCode:=NoLZWCode;
              Continue;
            end;
          // check whether it is a valid, already registered code
          if Code>FreeCode then Break;
          // handling for the first LZW code: print and keep it
          if OldCode=NoLZWCode then
            begin
              FirstChar:=Suffix[Code];
              Target^:=FirstChar;
              Inc(Target);
              Dec(UnpackedSize);
              OldCode:=Code;
              Continue;
            end;
          // keep the passed LZW code
          InCode:=Code;
          // the first LZW code is always smaller than FFirstCode
          if Code=FreeCode then
            begin
              Stackpointer^:=FirstChar;
              Inc(StackPointer);
              Code:=OldCode;
            end;
          // loop to put decoded bytes onto the stack
          while Code>ClearCode do
            begin
              Stackpointer^:=Suffix[Code];
              Inc(StackPointer);
              Code:=Prefix[Code];
            end;
          // place new code into code table
          FirstChar:=Suffix[Code];
          Stackpointer^:=FirstChar;
          Inc(StackPointer);
          Prefix[FreeCode]:=OldCode;
          Suffix[FreeCode]:=FirstChar;
          if FreeCode<4096 then Inc(FreeCode);
          // increase code size if necessary
          if (FreeCode=CodeMask) and (CodeSize<12) then
            begin
              Inc(CodeSize);
              CodeMask:=(1 shl CodeSize)-1;
            end;
          // put decoded bytes (from the stack) into the target Buffer
          OldCode:=InCode;
          repeat
            Dec(StackPointer);
            Target^:=StackPointer^;
            Inc(Target);
            Dec(UnpackedSize);
          until cardinal(Stackpointer)<=cardinal(@Stack);
        end;
    Inc(SourcePtr);
    Dec(PackedSize);
  end;
end;

//----------------- TPackbitsRLEDecoder --------------------------------------------------------------------------------

procedure TPackbitsRLEDecoder.Decode(var Source,Dest: pointer; PackedSize,UnpackedSize: integer);
// decodes a simple run-length encoded strip of size PackedSize
var SourcePtr,TargetPtr: PByte;
    N: integer;
begin
  TargetPtr:=Dest;
  SourcePtr:=Source;
  while (UnpackedSize>0) and (PackedSize>0) do
    begin
      N:=ShortInt(SourcePtr^);
      Inc(SourcePtr);
      Dec(PackedSize);
      if N<0 then // replicate next Byte -N+1 times
        begin
          if N=-128 then Continue; // nop
          N:=-N+1;
          if N>UnpackedSize then N:=UnpackedSize;
          FillChar(TargetPtr^,N,SourcePtr^);
          Inc(SourcePtr);
          Dec(PackedSize);
          Inc(TargetPtr,N);
          Dec(UnpackedSize,N);
        end
      else
        begin // copy next N+1 bytes literally
          Inc(N);
          if N>UnpackedSize then N:=UnpackedSize;
          if N>PackedSize then N:=PackedSize;
          Move(SourcePtr^,TargetPtr^,N);
          Inc(TargetPtr,N);
          Inc(SourcePtr,N);
          Dec(PackedSize,N);
          Dec(UnpackedSize,N);
        end;
    end;
end;

//----------------- TPCXRLEDecoder -------------------------------------------------------------------------------------

procedure TPCXRLEDecoder.Decode(var Source,Dest: pointer; PackedSize,UnpackedSize: integer);
var Count: integer;
    SourcePtr,TargetPtr: PByte;
begin
  SourcePtr:=Source;
  TargetPtr:=Dest;
  while UnpackedSize>0 do
    begin
      if (SourcePtr^ and $C0)=$C0 then
        begin
          // RLE-Code
          Count:=SourcePtr^ and $3F;
          Inc(SourcePtr);
          if UnpackedSize<Count then Count:=UnpackedSize;
          FillChar(TargetPtr^,Count,SourcePtr^);
          Inc(SourcePtr);
          Inc(TargetPtr,Count);
          Dec(UnpackedSize,Count);
        end
      else
        begin
          // not compressed
          TargetPtr^:=SourcePtr^;
          Inc(SourcePtr);
          Inc(TargetPtr);
          Dec(UnpackedSize);
        end;
    end;
end;

//----------------- TSGIRLEDecoder -------------------------------------------------------------------------------------

constructor TSGIRLEDecoder.Create(SampleSize: byte);
begin
  FSampleSize:=SampleSize;
end;

//----------------------------------------------------------------------------------------------------------------------

procedure TSGIRLEDecoder.Decode(var Source,Dest: pointer; PackedSize,UnpackedSize: integer);
var Source8,Target8: PByte;
    Source16,Target16: PWord;
    Pixel: byte;
    Pixel16: word;
    RunLength: cardinal;
begin
  if FSampleSize=8 then
    begin
      Source8:=Source;
      Target8:=Dest;
      while True do
        begin
          Pixel:=Source8^;
          Inc(Source8);
          RunLength:=Pixel and $7F;
          if RunLength=0 then Break;
          if (Pixel and $80)<>0 then
            begin
              Move(Source8^,Target8^,RunLength);
              Inc(Target8,RunLength);
              Inc(Source8,RunLength);
            end
          else
            begin
              Pixel:=Source8^;
              Inc(Source8);
              FillChar(Target8^,RunLength,Pixel);
              Inc(Target8,RunLength);
            end;
        end;
    end
  else
    begin
      // 16 bits per sample
      Source16:=Source;
      Target16:=Dest;
      while True do
        begin
          // SGI images are stored in big endian style, swap this one repeater value for it
          Pixel16:=System.Swap(Source16^);
          Inc(Source16);
          RunLength:=Pixel16 and $7F;
          if RunLength=0 then Break;
          if (Pixel16 and $80)<>0 then
            begin
              Move(Source16^,Target16^,2*RunLength);
              Inc(Source16^,RunLength);
              Inc(Target16^,RunLength);
            end
          else
            begin
              Pixel16:=Source16^;
              Inc(Source16);
              while RunLength>0 do
                begin
                  Target16^:=Pixel16;
                  Inc(Target16);
                  Dec(RunLength);
                end;
            end;
        end;
    end;
end;

//----------------- TCUTRLE --------------------------------------------------------------------------------------------

procedure TCUTRLEDecoder.Decode(var Source,Dest: pointer; PackedSize,UnpackedSize: integer);
var TargetPtr: PByte;
    Pixel: byte;
    RunLength: cardinal;
begin
  TargetPtr:=Dest;
  // skip first two bytes per row (I don't know their meaning)
  Inc(PByte(Source),2);
  while True do
    begin
      Pixel:=PByte(Source)^;
      Inc(PByte(Source));
      if Pixel=0 then Break;
      RunLength:=Pixel and $7F;
      if (Pixel and $80)=0 then
        begin
          Move(Source^,TargetPtr^,RunLength);
          Inc(TargetPtr,RunLength);
          Inc(PByte(Source),RunLength);
        end
      else
        begin
          Pixel:=PByte(Source)^;
          Inc(PByte(Source));
          FillChar(TargetPtr^,RunLength,Pixel);
          Inc(TargetPtr,RunLength);
        end;
    end;
end;

//----------------- TPSPRLEDecoder -------------------------------------------------------------------------------------

procedure TPSPRLEDecoder.Decode(var Source,Dest: pointer; PackedSize,UnpackedSize: integer);
var SourcePtr,TargetPtr: PByte;
    RunLength: cardinal;
begin
  SourcePtr:=Source;
  TargetPtr:=Dest;
  while PackedSize>0 do
    begin
      RunLength:=SourcePtr^;
      Inc(SourcePtr);
      Dec(PackedSize);
      if RunLength<128 then
        begin
          Move(SourcePtr^,TargetPtr^,RunLength);
          Inc(TargetPtr,RunLength);
          Inc(SourcePtr,RunLength);
          Dec(PackedSize,RunLength);
        end
      else
        begin
          Dec(RunLength,128);
          FillChar(TargetPtr^,RunLength,SourcePtr^);
          Inc(SourcePtr);
          Inc(TargetPtr,RunLength);
          Dec(PackedSize);
        end;
    end;
end;

//----------------- TGIFLZWDecoder -------------------------------------------------------------------------------------

constructor TGIFLZWDecoder.Create(InitialCodeSize: byte; linewidth: Integer);
begin
  FInitialCodeSize:=InitialCodeSize;
  FLineWidth := linewidth;
end;
//----------------------------------------------------------------------------------------------------------------------

procedure doGifLog( usz, psz, data: Integer );
begin
  LogFileOutput( GetStartDir + 'gif_log.txt',
    Int2Str( usz ) + ' '#9 + Int2Str( psz ) + ' '#9 + Int2Str( data ) );
end;

procedure doGifLog2( data: Byte );
begin
  LogFileOutput( GetStartDir + 'gif_log.txt',
    '<= ' + Int2Str( data ) );
end;

{
  Converted from C++ library CxImage (conversion by Vladimir Kladov)
}
{$O-}
procedure TGIFLZWDecoder.CxDecode(var Source, Dest: PByte; PackedSize,UnpackedSize: integer);
type short = SmallInt;
const MAX_CODES = 4095;
      code_mask: array[0..16] of word =
        ( $0000, $0001, $0003, $0007,
          $000F, $001F, $003F, $007F,
          $00FF, $01FF, $03FF, $07FF,
          $0FFF, $1FFF, $3FFF, $7FFF, $FFFF );
var sp, bufptr: PByte;
    buf: PByte;
    code, fc, oc, bufcnt: short;
    c, size: short;
    ret: Integer;
    bad_code_count: Integer;

    curr_size, top_slot, clear, ending,
    slot, newcodes: short;
    {navail_bytes,} nbits_left: short;

    stack, suffix: array[ 0..MAX_CODES ] of Byte;
    prefix: array[ 0..MAX_CODES ] of WORD;

    src, dst: PByte;
    b1: Byte;

    function out_line( from: PByte; count: Integer ): Integer;
    begin
      Result := UnpackedSize - count;
      if Result < 0 then count := UnpackedSize;
      move( from^, dst^, count );
      inc( dst, count );
      dec( UnpackedSize, count );
    end;

    function get_next_code: short;
    var	ret: DWORD;
    begin
	if (nbits_left = 0) then
        begin
		b1 := src^; inc( src ); dec( PackedSize );
		nbits_left := 8;
        end;

	if (PackedSize<0) then
        begin
          Result := ending; // prevent deadlocks (thanks to Mike Melnikov)
          Exit;
        end;

	ret := b1 shr (8 - nbits_left);

	while (curr_size > nbits_left) do
        begin
		b1 := src^; inc( src ); dec( PackedSize );
		ret := ret or ( b1 shl nbits_left );
		inc( nbits_left, 8 );
        end;

	nbits_left := nbits_left - curr_size;
	ret := ret and code_mask[curr_size];
        Result := ret;
    end;

begin
  FillChar( Dest^, UnpackedSize, 0 );

  //* Initialize for decoding a new image... */
  bad_code_count := 0;
  size := FInitialCodeSize;
  if (size < 2) or (9 < size) then
  begin
    //return(BAD_CODE_SIZE);
    FCorrupted := TRUE;
    Exit;
  end;
  // out_line = outline;
  //init_exp(size);
  curr_size := size + 1;
  top_slot  := 1 shl curr_size;
  clear     := 1 shl size;
  ending    := clear + 1;
  slot      := ending + 1;
  newcodes  := slot;
  //navail_bytes := 0;
  nbits_left   := 0;

  FillChar( stack, SizeOf( stack ), 0 );
  FillChar( prefix, SizeOf( prefix ), 0 );
  FillChar( suffix, SizeOf( suffix ), 0 );

  (* Initialize in case they forgot to put in a clear code.
   * (This shouldn't happen, but we'll try and decode it anyway...)
   *)
  oc := 0;
  fc := 0;

  //* Allocate space for the decode buffer */
  buf := AllocMem( FLinewidth + 1 );
  if (buf = nil) then
  begin
    //return(OUT_OF_MEMORY);
    Exit;
  end;

  //* Set up the stack pointer and decode buffer pointer */
  sp := @ stack[ 0 ];
  bufptr := buf;
  bufcnt := FLinewidth;

  (* This is the main loop.  For each code we get we pass through the
   * linked list of prefix codes, pushing the corresponding "character" for
   * each code onto the stack.  When the list reaches a single "character"
   * we push that on the stack too, and then start unstacking each
   * character for output in the correct order.  Special handling is
   * included for the clear code, and the whole thing ends when we get
   * an ending code.
   *)
  src := Source;
  dst := Dest;
  while TRUE do
  begin
    c := get_next_code;
    if c = ending then break;

    //* If the code is a clear code, reinitialize all necessary items.*/
    if (c = clear) then
    begin
            curr_size := size + 1;
            slot      := newcodes;
            top_slot  := 1 shl curr_size;

            (* Continue reading codes until we get a non-clear code
            * (Another unlikely, but possible case...)
            *)
            REPEAT
               c := get_next_code;
            UNTIL c <> clear;

            (* If we get an ending code immediately after a clear code
            * (Yet another unlikely case), then break out of the loop.
            *)
            if c = ending then break;

            (* Finally, if the code is beyond the range of already set codes,
            * (This one had better NOT happen...  I have no idea what will
            * result from this, but I doubt it will look good...) then set it
            * to color zero.
            *)
            if (c >= slot) then c := 0;
            fc := c;
            oc := fc;

            (* And let us not forget to put the char into the buffer... And
            * if, on the off chance, we were exactly one pixel from the end
            * of the line, we have to send the buffer to the out_line()
            * routine...
            *)
            bufptr^ := c; inc( bufptr );
            dec( bufcnt );
            if (bufcnt = 0) then
            begin
              ret := out_line( buf, FLinewidth );
              if (ret <= 0) then
              begin
                FreeMem( buf );
                Exit;
              end;
              bufptr := buf;
              bufcnt := FLinewidth;
            end;
    end
      else
    begin
            (* In this case, it's not a clear code or an ending code, so
            * it must be a code code...  So we can now decode the code into
            * a stack of character codes. (Clear as mud, right?)
            *)
            code := c;

            (* Here we go again with one of those off chances...  If, on the
            * off chance, the code we got is beyond the range of those already
            * set up (Another thing which had better NOT happen...) we trick
            * the decoder into thinking it actually got the last code read.
            * (Hmmn... I'm not sure why this works...  But it does...)
            *)
            if (code >= slot) then
            begin
              if (code > slot) then
                inc( bad_code_count );
              code := oc;
              sp^ := fc; inc( sp );
            end;

            (* Here we scan back along the linked list of prefixes, pushing
            * helpless characters (ie. suffixes) onto the stack as we do so.
            *)
            while code >= newcodes do
            begin
              sp^ := suffix[ code ]; inc( sp );
              code := prefix[ code ];
            end;

            (* Push the last character on the stack, and set up the new
            * prefix and suffix, and if the required slot number is greater
            * than that allowed by the current bit size, increase the bit
            * size.  (NOTE - If we are all full, we *don't* save the new
            * suffix and prefix...  I'm not certain if this is correct...
            * it might be more proper to overwrite the last code...
            *)
            sp^ := code; inc( sp );
            if (slot < top_slot) then
            begin
                    fc := code;
                    suffix[slot] := fc;
                    prefix[slot] := oc; inc( slot );
                    oc := c;
            end;
            if (slot >= top_slot) then
            begin
                    if (curr_size < 12) then
                    begin
                            top_slot := top_slot shl 1;
                            inc( curr_size );
                    end;
            end;

            (* Now that we've pushed the decoded string (in reverse order)
            * onto the stack, lets pop it off and put it into our decode
            * buffer...  And when the decode buffer is full, write another
            * line...
            *)
            while (sp <> @ stack[ 0 ]) do
            begin
                    dec( sp );
                    bufptr^ := sp^; inc( bufptr );
                    dec( bufcnt );
                    if bufcnt = 0 then
                    begin
                            ret := out_line( buf, FLinewidth );
                            if ret <= 0 then
                            begin
                              FreeMem( buf );
                              Exit;
                            end;
                            bufptr := buf;
                            bufcnt := FLinewidth;
                    end;
            end;

    end;

  end;

  if (bufcnt <> FLinewidth) then
    {ret :=} out_line( buf, FLinewidth - bufcnt );
  FreeMem( buf );

  if bad_code_count > 0 then
    FCorrupted := TRUE;

end;

procedure TGIFLZWDecoder.Decode(var Source, Dest: pointer; PackedSize,UnpackedSize: integer);
var I: integer;
    Data,                               // current data
    Bits                               // counter for bit management
    {$IFNDEF ASM_GIF}
    ,Code{$ENDIF}: cardinal;                     // current code value

    SourcePtr: PByte;
    InCode: cardinal;                   // Buffer for passed code
    CodeSize,CodeMask,FreeCode,OldCode: cardinal;
    Prefix: array[0..GIFBufSize-1] of cardinal; // LZW prefix
    Suffix,                             // LZW suffix
    Stack: array[0..GIFBufSize-1] of byte;      // stack
    StackPointer,Target: PByte;
    FirstChar: byte;                    // Buffer for decoded byte
    ClearCode,EOICode: {$IFDEF ASM_GIF} cardinal {$ELSE} word {$ENDIF};
    {$IFDEF ASM_GIF}
    initial_code_size: Byte;
    {$ENDIF}
    {$IFDEF GIF_SAFE}
    Bad: Boolean;
    {$ENDIF}
begin
  {$IFDEF GIF_SAFE}
  Bad := FALSE;
  {$ENDIF}
  Target:=Dest; if Target <> nil then;
  SourcePtr:=Source;
  // initialize parameter
  CodeSize:=FInitialCodeSize+1;
  ClearCode:=1 shl FInitialCodeSize;
  EOICode:=ClearCode+1;
  FreeCode:=ClearCode+2;
  OldCode:=NoLZWCode;
  CodeMask:=(1 shl CodeSize)-1;
  // init code table
  {$IFDEF GIF_SAFE}
  FillChar( Suffix, SizeOf( Suffix ), 0 );
  FillChar( Prefix, SizeOf( Prefix ), 0 );
  //FillChar( Stack, SizeOf( Stack ), 0 );
  {$ENDIF}
  for I:=0 to ClearCode-1 do
    begin
      Prefix[I]:=NoLZWCode;
      Suffix[I]:=I;
    end;
  // initialize stack
  StackPointer:=@Stack; if StackPointer <> nil then;
  FirstChar:=0;
  Data:=0;
  Bits:=0;
  {$IFDEF ASM_GIF}
      initial_code_size := FInitialCodeSize;
      {$IFDEF GIF_MMX}
      if mmxSupported then
        {$I GIF_MMX.inc}
        else
      {$ENDIF} /////////////////////////////////////////////////////////////////////
        {$I GIF_ASM.inc}
      {$IFDEF GIF_SAFE}
        if Bad then FCorrupted := TRUE;
        {$IFDEF GIF_TRY_CX}
        if Bad then
          CxDecode( PByte( Source ), PByte( Dest ), PackedSize, UnpackedSize );
        {$ENDIF}
      {$ENDIF}
  {$ELSE}
  while (UnpackedSize>0) and (PackedSize>0) do
    begin
      {$IFDEF GIF_LOG}
      doGifLog( UnpackedSize, PackedSize, Data );
      {$ENDIF}
      // read code from bit stream
      Inc(Data,SourcePtr^ shl Bits);
      Inc(Bits,8);
      while Bits>=CodeSize do
        begin
          // current code
          Code:=Data and CodeMask;
          // prepare next run
          Data:=Data shr CodeSize;
          Dec(Bits,CodeSize);
          // decoding finished?
          if Code=EOICode then Break;
          // handling of clear codes
          if Code=ClearCode then
            begin
              // reset of all variables
              CodeSize:=FInitialCodeSize+1;
              CodeMask:=(1 shl CodeSize)-1;
              FreeCode:=ClearCode+2;
              OldCode:=NoLZWCode;
              Continue;
            end;
          // check whether it is a valid, already registered code
          if Code>FreeCode then Break;
          // handling for the first LZW code: print and keep it
          if OldCode=NoLZWCode then
            begin
              FirstChar:=Suffix[Code];
              {$IFDEF GIF_LOG}
              doGifLog2( FirstChar );
              {$ENDIF}
              Target^:=FirstChar;
              Inc(Target);
              Dec(UnpackedSize);
              OldCode:=Code;
              Continue;
            end;
          // keep the passed LZW code
          InCode:=Code;
          // the first LZW code is always smaller than FFirstCode
          if Code=FreeCode then
            begin
              StackPointer^:=FirstChar;
              Inc(StackPointer);
              Code:=OldCode;
            end;
          // loop to put decoded bytes onto the stack
          while Code>ClearCode do
            begin
              StackPointer^:=Suffix[Code];
              Inc(StackPointer);
              Code:=Prefix[Code];
            end;
          // place new code into code table
          FirstChar:=Suffix[Code];
          Stackpointer^:=FirstChar;
          Inc(Stackpointer);
          Prefix[FreeCode]:=OldCode;
          Suffix[FreeCode]:=FirstChar;
          // increase code size if necessary
          if (FreeCode=CodeMask) and (CodeSize<12) then
            begin
              Inc(CodeSize);
              CodeMask:=(1 shl CodeSize)-1;
            end;
          if FreeCode<4095 then Inc(FreeCode);
          // put decoded bytes (from the stack) into the target Buffer
          OldCode:=InCode;
          repeat
            Dec(StackPointer);
            {$IFDEF GIF_LOG}
            doGifLog2( StackPointer^ );
            {$ENDIF}
            Target^:=StackPointer^;
            Inc(Target);
            Dec(UnpackedSize);
          until StackPointer=@Stack;
        end;
      Inc(SourcePtr);
      Dec(PackedSize);
    end;
  {$ENDIF}
end;

//----------------- TRLADecoder ----------------------------------------------------------------------------------------

procedure TRLADecoder.Decode(var Source,Dest: pointer; PackedSize,UnpackedSize: integer);
// decodes a simple run-length encoded strip of size PackedSize
// this is very similar to TPackbitsRLEDecoder
var SourcePtr,TargetPtr: PByte;
    N: smallint;
begin
  TargetPtr:=Dest;
  SourcePtr:=Source;
  while PackedSize>0 do
    begin
      N:=ShortInt(SourcePtr^);
      Inc(SourcePtr);
      Dec(PackedSize);
      if N>=0 then // replicate next Byte N+1 times
        begin
          FillChar(TargetPtr^,N+1,SourcePtr^);
          Inc(TargetPtr,N+1);
          Inc(SourcePtr);
          Dec(PackedSize);
        end
      else
        begin // copy next -N bytes literally
          Move(SourcePtr^,TargetPtr^,-N);
          Inc(TargetPtr,-N);
          Inc(SourcePtr,-N);
          Inc(PackedSize,N);
        end;
      end;
end;

//----------------- TCCITTDecoder --------------------------------------------------------------------------------------

constructor TCCITTDecoder.Create(Options: integer; SwapBits,WordAligned: boolean; Width: cardinal);
begin
  FOptions:=Options;
  FSwapBits:=SwapBits;
  FWidth:=Width;
  FWordAligned:=WordAligned;
  MakeStates;
end;

//----------------------------------------------------------------------------------------------------------------------

const
  // 256 bytes to make bit reversing easy,
  // this is actually not much more than writing bit manipulation code, but much faster
  ReverseTable: array[0..255] of byte = (
    $00,$80,$40,$C0,$20,$A0,$60,$E0,$10,$90,$50,$D0,$30,$B0,$70,$F0,
    $08,$88,$48,$C8,$28,$A8,$68,$E8,$18,$98,$58,$D8,$38,$B8,$78,$F8,
    $04,$84,$44,$C4,$24,$A4,$64,$E4,$14,$94,$54,$D4,$34,$B4,$74,$F4,
    $0C,$8C,$4C,$CC,$2C,$AC,$6C,$EC,$1C,$9C,$5C,$DC,$3C,$BC,$7C,$FC,
    $02,$82,$42,$C2,$22,$A2,$62,$E2,$12,$92,$52,$D2,$32,$B2,$72,$F2,
    $0A,$8A,$4A,$CA,$2A,$AA,$6A,$EA,$1A,$9A,$5A,$DA,$3A,$BA,$7A,$FA,
    $06,$86,$46,$C6,$26,$A6,$66,$E6,$16,$96,$56,$D6,$36,$B6,$76,$F6,
    $0E,$8E,$4E,$CE,$2E,$AE,$6E,$EE,$1E,$9E,$5E,$DE,$3E,$BE,$7E,$FE,
    $01,$81,$41,$C1,$21,$A1,$61,$E1,$11,$91,$51,$D1,$31,$B1,$71,$F1,
    $09,$89,$49,$C9,$29,$A9,$69,$E9,$19,$99,$59,$D9,$39,$B9,$79,$F9,
    $05,$85,$45,$C5,$25,$A5,$65,$E5,$15,$95,$55,$D5,$35,$B5,$75,$F5,
    $0D,$8D,$4D,$CD,$2D,$AD,$6D,$ED,$1D,$9D,$5D,$DD,$3D,$BD,$7D,$FD,
    $03,$83,$43,$C3,$23,$A3,$63,$E3,$13,$93,$53,$D3,$33,$B3,$73,$F3,
    $0B,$8B,$4B,$CB,$2B,$AB,$6B,$EB,$1B,$9B,$5B,$DB,$3B,$BB,$7B,$FB,
    $07,$87,$47,$C7,$27,$A7,$67,$E7,$17,$97,$57,$D7,$37,$B7,$77,$F7,
    $0F,$8F,$4F,$CF,$2F,$AF,$6F,$EF,$1F,$9F,$5F,$DF,$3F,$BF,$7F,$FF);

  G3_EOL     = -1;
  G3_INVALID = -2;

//----------------------------------------------------------------------------------------------------------------------

function TCCITTDecoder.FillRun(RunLength: cardinal): boolean;
// fills a number of bits with 1s (for black, white only increments pointers),
// returns True if the line has been filled entirely, otherwise False
var Run: cardinal;
begin
  Run:=KOL.Min(FFreeTargetBits,RunLength);
  // fill remaining bits in the current byte
  if Run in [1..7] then
    begin
      Dec(FFreeTargetBits,Run);
      if not FIsWhite then FTarget^:=FTarget^ or (((1 shl Run)-1) shl FFreeTargetBits);
      if FFreeTargetBits=0 then
        begin
          Inc(FTarget);
          FFreeTargetBits:=8;
        end;
      Run:=RunLength-Run;
    end
  else Run:=RunLength;
  // fill entire bytes whenever possible
  if Run>0 then
    begin
      if not FIsWhite then FillChar(FTarget^,Run div 8,$FF);
      Inc(FTarget,Run div 8);
      Run:=Run mod 8;
    end;
  // finally fill remaining bits
  if Run>0 then
    begin
      FFreeTargetBits:=8-Run;
      if not FIsWhite then FTarget^:=((1 shl Run)-1) shl FFreeTargetBits;
    end;
  // this will throw an exception if the sum of the run lengths for a row is not
  // exactly the row size (the documentation speaks of an unrecoverable error)
  if cardinal(RunLength)>FRestWidth then RunLength:=FRestWidth;
  Dec(FRestWidth,RunLength);
  Result:=FRestWidth=0;
end;

//----------------------------------------------------------------------------------------------------------------------

function TCCITTDecoder.FindBlackCode: integer;
// Executes the state machine to find the run length for the next bit combination.
// Returns the run length of the found code.
var State,NewState: cardinal;
    Bit: boolean;
begin
  State:=0;
  Result:=0;
  repeat
    // advance to next byte in the input Buffer if necessary
    if FBitsLeft=0 then
      begin
        if FPackedSize=0 then Break;
        FBits:=FSource^;
        Inc(FSource);
        Dec(FPackedSize);
        FMask:=$80;
        FBitsLeft:=8;
      end;
    Bit:=(FBits and FMask)<>0;
    // advance the state machine
    NewState:=FBlackStates[State].NewState[Bit];
    if NewState=0 then
      begin
        Inc(Result,FBlackStates[State].RunLength);
        if FBlackStates[State].RunLength<64 then Break else NewState:=FBlackStates[0].NewState[Bit];
      end;
    State:=NewState;
    // address next bit
    FMask:=FMask shr 1;
    if FBitsLeft>0 then Dec(FBitsLeft);
  until False;
end;

//----------------------------------------------------------------------------------------------------------------------

function TCCITTDecoder.FindWhiteCode: integer;
// Executes the state machine to find the run length for the next bit combination.
// Returns the run length of the found code.
var State,NewState: cardinal;
    Bit: boolean;
begin
  State:=0;
  Result:=0;
  repeat
    // advance to next byte in the input Buffer if necessary
    if FBitsLeft=0 then
      begin
        if FPackedSize=0 then Break;
        FBits:=FSource^;
        Inc(FSource);
        Dec(FPackedSize);
        FMask:=$80;
        FBitsLeft:=8;
      end;
    Bit:=(FBits and FMask)<>0;
    // advance the state machine
    NewState:=FWhiteStates[State].NewState[Bit];
    if NewState=0 then
      begin
        // a code has been found
        Inc(Result,FWhiteStates[State].RunLength);
        // if we found a terminating code then exit loop, otherwise continue
        if FWhiteStates[State].RunLength<64 then Break else
          begin
            // found a make up code, continue state machine with current bit (rather than reading the next one)
            NewState:=FWhiteStates[0].NewState[Bit];
          end;
      end;
    State:=NewState;
    // address next bit
    FMask:=FMask shr 1;
    if FBitsLeft>0 then Dec(FBitsLeft);
  until False;
end;

//----------------------------------------------------------------------------------------------------------------------

function TCCITTDecoder.NextBit: boolean;
// Reads the current bit and returns True if it is set, otherwise False.
// This method is only used in the process to synchronize the bit stream in descentants.
begin
  // advance to next byte in the input Buffer if necessary
  if (FBitsLeft=0) and (FPackedSize>0) then
    begin
      FBits:=FSource^;
      Inc(FSource);
      Dec(FPackedSize);
      FMask:=$80;
      FBitsLeft:=8;
    end;
  Result:=(FBits and FMask)<>0;
  // address next bit
  FMask:=FMask shr 1;
  if FBitsLeft>0 then Dec(FBitsLeft);
end;

//----------------------------------------------------------------------------------------------------------------------

type
  TCodeEntry = packed record
    Code,Len: cardinal;
  end;

const // CCITT code tables
  WhiteCodes: array[0..103] of TCodeEntry = (
    (Code: $0035; Len: 8),(Code: $0007; Len: 6),(Code: $0007; Len: 4),
    (Code: $0008; Len: 4),(Code: $000B; Len: 4),(Code: $000C; Len: 4),
    (Code: $000E; Len: 4),(Code: $000F; Len: 4),(Code: $0013; Len: 5),
    (Code: $0014; Len: 5),(Code: $0007; Len: 5),(Code: $0008; Len: 5),
    (Code: $0008; Len: 6),(Code: $0003; Len: 6),(Code: $0034; Len: 6),
    (Code: $0035; Len: 6),(Code: $002A; Len: 6),(Code: $002B; Len: 6),
    (Code: $0027; Len: 7),(Code: $000C; Len: 7),(Code: $0008; Len: 7),
    (Code: $0017; Len: 7),(Code: $0003; Len: 7),(Code: $0004; Len: 7),
    (Code: $0028; Len: 7),(Code: $002B; Len: 7),(Code: $0013; Len: 7),
    (Code: $0024; Len: 7),(Code: $0018; Len: 7),(Code: $0002; Len: 8),
    (Code: $0003; Len: 8),(Code: $001A; Len: 8),(Code: $001B; Len: 8),
    (Code: $0012; Len: 8),(Code: $0013; Len: 8),(Code: $0014; Len: 8),
    (Code: $0015; Len: 8),(Code: $0016; Len: 8),(Code: $0017; Len: 8),
    (Code: $0028; Len: 8),(Code: $0029; Len: 8),(Code: $002A; Len: 8),
    (Code: $002B; Len: 8),(Code: $002C; Len: 8),(Code: $002D; Len: 8),
    (Code: $0004; Len: 8),(Code: $0005; Len: 8),(Code: $000A; Len: 8),
    (Code: $000B; Len: 8),(Code: $0052; Len: 8),(Code: $0053; Len: 8),
    (Code: $0054; Len: 8),(Code: $0055; Len: 8),(Code: $0024; Len: 8),
    (Code: $0025; Len: 8),(Code: $0058; Len: 8),(Code: $0059; Len: 8),
    (Code: $005A; Len: 8),(Code: $005B; Len: 8),(Code: $004A; Len: 8),
    (Code: $004B; Len: 8),(Code: $0032; Len: 8),(Code: $0033; Len: 8),
    (Code: $0034; Len: 8),(Code: $001B; Len: 5),(Code: $0012; Len: 5),
    (Code: $0017; Len: 6),(Code: $0037; Len: 7),(Code: $0036; Len: 8),
    (Code: $0037; Len: 8),(Code: $0064; Len: 8),(Code: $0065; Len: 8),
    (Code: $0068; Len: 8),(Code: $0067; Len: 8),(Code: $00CC; Len: 9),
    (Code: $00CD; Len: 9),(Code: $00D2; Len: 9),(Code: $00D3; Len: 9),
    (Code: $00D4; Len: 9),(Code: $00D5; Len: 9),(Code: $00D6; Len: 9),
    (Code: $00D7; Len: 9),(Code: $00D8; Len: 9),(Code: $00D9; Len: 9),
    (Code: $00DA; Len: 9),(Code: $00DB; Len: 9),(Code: $0098; Len: 9),
    (Code: $0099; Len: 9),(Code: $009A; Len: 9),(Code: $0018; Len: 6),
    (Code: $009B; Len: 9),(Code: $0008; Len: 11),(Code: $000C; Len: 11),
    (Code: $000D; Len: 11),(Code: $0012; Len: 12),(Code: $0013; Len: 12),
    (Code: $0014; Len: 12),(Code: $0015; Len: 12),(Code: $0016; Len: 12),
    (Code: $0017; Len: 12),(Code: $001C; Len: 12),(Code: $001D; Len: 12),
    (Code: $001E; Len: 12),(Code: $001F; Len: 12));
    // EOL codes are added "manually"

  BlackCodes: array[0..103] of TCodeEntry = (
    (Code: $0037; Len: 10),(Code: $0002; Len: 3),(Code: $0003; Len: 2),
    (Code: $0002; Len: 2),(Code: $0003; Len: 3),(Code: $0003; Len: 4),
    (Code: $0002; Len: 4),(Code: $0003; Len: 5),(Code: $0005; Len: 6),
    (Code: $0004; Len: 6),(Code: $0004; Len: 7),(Code: $0005; Len: 7),
    (Code: $0007; Len: 7),(Code: $0004; Len: 8),(Code: $0007; Len: 8),
    (Code: $0018; Len: 9),(Code: $0017; Len: 10),(Code: $0018; Len: 10),
    (Code: $0008; Len: 10),(Code: $0067; Len: 11),(Code: $0068; Len: 11),
    (Code: $006C; Len: 11),(Code: $0037; Len: 11),(Code: $0028; Len: 11),
    (Code: $0017; Len: 11),(Code: $0018; Len: 11),(Code: $00CA; Len: 12),
    (Code: $00CB; Len: 12),(Code: $00CC; Len: 12),(Code: $00CD; Len: 12),
    (Code: $0068; Len: 12),(Code: $0069; Len: 12),(Code: $006A; Len: 12),
    (Code: $006B; Len: 12),(Code: $00D2; Len: 12),(Code: $00D3; Len: 12),
    (Code: $00D4; Len: 12),(Code: $00D5; Len: 12),(Code: $00D6; Len: 12),
    (Code: $00D7; Len: 12),(Code: $006C; Len: 12),(Code: $006D; Len: 12),
    (Code: $00DA; Len: 12),(Code: $00DB; Len: 12),(Code: $0054; Len: 12),
    (Code: $0055; Len: 12),(Code: $0056; Len: 12),(Code: $0057; Len: 12),
    (Code: $0064; Len: 12),(Code: $0065; Len: 12),(Code: $0052; Len: 12),
    (Code: $0053; Len: 12),(Code: $0024; Len: 12),(Code: $0037; Len: 12),
    (Code: $0038; Len: 12),(Code: $0027; Len: 12),(Code: $0028; Len: 12),
    (Code: $0058; Len: 12),(Code: $0059; Len: 12),(Code: $002B; Len: 12),
    (Code: $002C; Len: 12),(Code: $005A; Len: 12),(Code: $0066; Len: 12),
    (Code: $0067; Len: 12),(Code: $000F; Len: 10),(Code: $00C8; Len: 12),
    (Code: $00C9; Len: 12),(Code: $005B; Len: 12),(Code: $0033; Len: 12),
    (Code: $0034; Len: 12),(Code: $0035; Len: 12),(Code: $006C; Len: 13),
    (Code: $006D; Len: 13),(Code: $004A; Len: 13),(Code: $004B; Len: 13),
    (Code: $004C; Len: 13),(Code: $004D; Len: 13),(Code: $0072; Len: 13),
    (Code: $0073; Len: 13),(Code: $0074; Len: 13),(Code: $0075; Len: 13),
    (Code: $0076; Len: 13),(Code: $0077; Len: 13),(Code: $0052; Len: 13),
    (Code: $0053; Len: 13),(Code: $0054; Len: 13),(Code: $0055; Len: 13),
    (Code: $005A; Len: 13),(Code: $005B; Len: 13),(Code: $0064; Len: 13),
    (Code: $0065; Len: 13),(Code: $0008; Len: 11),(Code: $000C; Len: 11),
    (Code: $000D; Len: 11),(Code: $0012; Len: 12),(Code: $0013; Len: 12),
    (Code: $0014; Len: 12),(Code: $0015; Len: 12),(Code: $0016; Len: 12),
    (Code: $0017; Len: 12),(Code: $001C; Len: 12),(Code: $001D; Len: 12),
    (Code: $001E; Len: 12),(Code: $001F; Len: 12));
    // EOL codes are added "manually"

procedure TCCITTDecoder.MakeStates;
// creates state arrays for white and black codes
// These state arrays are so designed that they have at each state (starting with state 0) a new state index
// into the same array according to the bit for which the state is current.

  //--------------- local functions -------------------------------------------
  procedure AddCode(var Target: TStateArray; Bits: cardinal; BitLen,RL: integer);
  // interprets the given string as a sequence of bits and makes a state chain from it
  var State,NewState: integer;
      Bit: boolean;
  begin
    // start state
    State:=0;
    // prepare bit combination (bits are given right align, but must be scanned from left)
    Bits:=Bits shl (32-BitLen);
    while BitLen>0 do
      begin
        // determine next state according to the bit string
        asm
          SHL  [Bits],1
          SETC [Bit]
        end;
        NewState:=Target[State].NewState[Bit];
        // Is it a not yet assigned state?
        if NewState=0 then
          begin
            // if yes then create a new state at the end of the array
            NewState:=Length(Target);
            Target[State].NewState[Bit]:=NewState;
            SetLength(Target,Length(Target)+1);
          end;
        State:=NewState;
        Dec(BitLen);
      end;
    // at this point State indicates the final state where we must store the run length for the
    // particular bit combination
    Target[State].RunLength:=RL;
  end;
  //--------------- end local functions ---------------------------------------
var I: integer;
begin
  // set an initial entry in each state array
  SetLength(FWhiteStates,1);
  SetLength(FBlackStates,1);
  // with codes
  for I:=0 to 63 do with WhiteCodes[I] do AddCode(FWhiteStates,Code,Len,I);
  for I:=64 to 103 do with WhiteCodes[I] do AddCode(FWhiteStates,Code,Len,(I-63)*64);
  AddCode(FWhiteStates,1,12,G3_EOL);
  AddCode(FWhiteStates,1,9,G3_INVALID);
  AddCode(FWhiteStates,1,10,G3_INVALID);
  AddCode(FWhiteStates,1,11,G3_INVALID);
  AddCode(FWhiteStates,0,12,G3_INVALID);
  // black codes
  for I:=0 to 63 do with BlackCodes[I] do AddCode(FBlackStates,Code,Len,I);
  for I:=64 to 103 do with BlackCodes[I] do AddCode(FBlackStates,Code,Len,(I-63)*64);
  AddCode(FBlackStates,1,12,G3_EOL);
  AddCode(FBlackStates,1,9,G3_INVALID);
  AddCode(FBlackStates,1,10,G3_INVALID);
  AddCode(FBlackStates,1,11,G3_INVALID);
  AddCode(FBlackStates,0,12,G3_INVALID);
end;

//----------------- TCCITTFax3Decoder ----------------------------------------------------------------------------------

procedure TCCITTFax3Decoder.Decode(var Source,Dest: pointer; PackedSize,UnpackedSize: integer);
var
  RunLength: integer;
  EOLCount: integer;
  //--------------- local functions -------------------------------------------
  procedure SynchBOL;
  // synch bit stream to next line start
  var Count: integer;
  begin
    // if no EOL codes have been read so far then do it now
    if EOLCount=0 then
      begin
        // advance until 11 consecutive 0 bits have been found
        Count:=0;
        while (Count<11) and (FPackedSize>0) do
          begin
            if NextBit then Count:=0 else Inc(Count);
          end;
      end;
    // read 8 bit until at least one set bit is found
    repeat
      Count:=0;
      while (Count<8) and (FPackedSize>0) do
        begin
          if NextBit then Count:=9 else Inc(Count);
        end;
    until (Count>8) or (FPackedSize=0);
    // here we are already beyond the set bit and can restart scanning
    EOLCount:=0;
  end;
  //---------------------------------------------------------------------------
  procedure AdjustEOL;
  begin
    FIsWhite:=False;
    if FFreeTargetBits in [1..7] then Inc(FTarget);
    FFreeTargetBits:=8;
    FRestWidth:=FWidth;
  end;
  //--------------- end local functions ---------------------------------------
begin
  // make all bits white
  FillChar(Dest^,UnpackedSize,0);
  // swap all bits here, in order to avoid frequent tests in the main loop
  if FSwapBits then
    asm
           PUSH EBX
           LEA  EBX,ReverseTable
           MOV  ECX,[PackedSize]
           MOV  EDX,[Source]
           MOV  EDX,[EDX]
      @@1:
           MOV  AL,[EDX]
           XLATB //<<<XLAT
           MOV  [EDX],AL
           INC  EDX
           DEC  ECX
           JNZ  @@1
           POP  EBX
    end;
  // setup initial states
  // a row always starts with a (possibly zero-length) white run
  FSource:=Source;
  FBitsLeft:=0;
  FPackedSize:=PackedSize;
  // target preparation
  FTarget:=Dest;
  FRestWidth:=FWidth;
  FFreeTargetBits:=8;
  EOLCount:=0;
  // main loop
  repeat
    // synchronize to start of next line
    SynchBOL;
    // a line always starts with a white run
    FIsWhite:=True;
    // decode one line
    repeat
      if FIsWhite then RunLength:=FindWhiteCode else RunLength:=FindBlackCode;
      if RunLength>=0 then
        begin
          if FillRun(RunLength) then Break;
          FIsWhite:=not FIsWhite;
        end
      else
        if RunLength=G3_EOL then Inc(EOLCount) else Break;
    until (RunLength=G3_EOL) or (FPackedSize=0);
    AdjustEOL;
  {$IFDEF FPC}
  until (FPackedSize=0) or (PChar(FTarget)-PChar(Dest)>=UnpackedSize);
  {$ELSE}
  until (FPackedSize=0) or (FTarget-PChar(Dest)>=UnpackedSize);
  {$ENDIF}
end;

//----------------- TCCITTFax4Decoder ----------------------------------------------------------------------------------

procedure TCCITTFax4Decoder.Decode(var Source,Dest: pointer; PackedSize,UnpackedSize: integer);
var
  RunLength: integer;
  EOLCount: integer;
  //--------------- local functions -------------------------------------------
  procedure SynchBOL;
  // synch bit stream to next line start
  var Count: integer;
  begin
    // if no EOL codes have been read so far then do it now
    if EOLCount=0 then
      begin
        // advance until 11 consecutive 0 bits have been found
        Count:=0;
        while (Count<11) and (FPackedSize>0) do
          begin
            if NextBit then Count:=0 else Inc(Count);
          end;
      end;
    // read 8 bit until at least one set bit is found
    repeat
      Count:=0;
      while (Count<8) and (FPackedSize>0) do
        begin
          if NextBit then Count:=9 else Inc(Count);
        end;
    until (Count>8) or (FPackedSize=0);
    // here we are already beyond the set bit and can restart scanning
    EOLCount:=0;
  end;
  //---------------------------------------------------------------------------
  procedure AdjustEOL;
  begin
    FIsWhite:=False;
    if FFreeTargetBits in [1..7] then Inc(FTarget);
    FFreeTargetBits:=8;
    FRestWidth:=FWidth;
  end;
  //--------------- end local functions ---------------------------------------
begin
  // make all bits white
  FillChar(Dest^,UnpackedSize,0);
  // swap all bits here, in order to avoid frequent tests in the main loop
  if FSwapBits then
    asm
           PUSH EBX
           LEA  EBX,ReverseTable
           MOV  ECX,[PackedSize]
           MOV  EDX,[Source]
           MOV  EDX,[EDX]
      @@1:
           MOV  AL,[EDX]
           XLATB //<<<XLAT
           MOV  [EDX],AL
           INC  EDX
           DEC  ECX
           JNZ  @@1
           POP  EBX
    end;
  // setup initial states
  // a row always starts with a (possibly zero-length) white run
  FSource:=Source;
  FBitsLeft:=0;
  FPackedSize:=PackedSize;
  // target preparation
  FTarget:=Dest;
  FRestWidth:=FWidth;
  FFreeTargetBits:=8;
  EOLCount:=0;
  // main loop
  repeat
    // synchronize to start of next line
    SynchBOL;
    // a line always starts with a white run
    FIsWhite:=True;
    // decode one line
    repeat
      if FIsWhite then RunLength:=FindWhiteCode else RunLength:=FindBlackCode;
      if RunLength>=0 then
        begin
          if FillRun(RunLength) then Break;
          FIsWhite:=not FIsWhite;
        end
      else
        if RunLength=G3_EOL then Inc(EOLCount) else Break;
    until (RunLength=G3_EOL) or (FPackedSize=0);
    AdjustEOL;
  {$IFDEF FPC}
  until (FPackedSize=0) or (PChar(FTarget)-PChar(Dest)>=UnpackedSize);
  {$ELSE}
  until (FPackedSize=0) or (FTarget-PChar(Dest)>=UnpackedSize);
  {$ENDIF}
end;

//----------------- TCCITTMHDecoder ------------------------------------------------------------------------------------

procedure TCCITTMHDecoder.Decode(var Source,Dest: pointer; PackedSize,UnpackedSize: integer);
var RunLength: integer;
  //--------------- local functions -------------------------------------------
  procedure AdjustEOL;
  begin
    FIsWhite:=False;
    if FFreeTargetBits in [1..7] then Inc(FTarget);
    FFreeTargetBits:=8;
    FRestWidth:=FWidth;
    if FBitsLeft<8 then FBitsLeft:=0; // discard remaining bits
    if FWordAligned and Odd(cardinal(FTarget)) then Inc(FTarget);
  end;
  //--------------- end local functions ---------------------------------------
begin
  // make all bits white
  FillChar(Dest^, UnpackedSize,0);
  // swap all bits here, in order to avoid frequent tests in the main loop
  if FSwapBits then
    asm
           PUSH EBX
           LEA  EBX,ReverseTable
           MOV  ECX,[PackedSize]
           MOV  EDX,[Source]
           MOV  EDX,[EDX]
      @@1:
           MOV  AL,[EDX]
           XLATB //<<<XLATB
           MOV  [EDX],AL
           INC  EDX
           DEC  ECX
           JNZ  @@1
           POP  EBX
    end;

  // setup initial states
  // a row always starts with a (possibly zero-length) white run
  FIsWhite:=True;
  FSource:=Source;
  FBitsLeft:=0;
  FPackedSize:=PackedSize;
  // target preparation
  FTarget:=Dest;
  FRestWidth:=FWidth;
  FFreeTargetBits:=8;
  // main loop
  repeat
    if FIsWhite then RunLength:=FindWhiteCode else RunLength:=FindBlackCode;
    if RunLength>0 then
      if FillRun(RunLength) then AdjustEOL;
    FIsWhite:=not FIsWhite;
  until FPackedSize=0;
end;

//----------------- TLZ77Decoder ---------------------------------------------------------------------------------------

constructor TLZ77Decoder.Create(FlushMode: integer; AutoReset: boolean);
begin
  FillChar(FStream,sizeof(FStream),0);
  FFlushMode:=FlushMode;
  FAutoReset:=AutoReset;
end;

//----------------------------------------------------------------------------------------------------------------------

procedure TLZ77Decoder.Decode(var Source,Dest: pointer; PackedSize,UnpackedSize: integer);
begin
  FStream.NextInput:=Source;
  FStream.AvailableInput:=PackedSize;
  if FAutoReset then FZLibResult:=InflateReset(FStream);
  if FZLibResult=Z_OK then
    begin
      FStream.NextOutput:=Dest;
      FStream.AvailableOutput:=UnpackedSize;
      FZLibResult:=Inflate(FStream,FFlushMode);
      // advance pointers so used input can be calculated
      Source:=FStream.NextInput;
      Dest:=FStream.NextOutput;
    end;
end;

//----------------------------------------------------------------------------------------------------------------------

procedure TLZ77Decoder.DecodeEnd;
begin
  if InflateEnd(FStream)<0 then CompressionError(20{gesLZ77Error});
end;

//----------------------------------------------------------------------------------------------------------------------

procedure TLZ77Decoder.DecodeInit;
begin
  if InflateInit(FStream)<0 then CompressionError(20{gesLZ77Error});
end;

//----------------------------------------------------------------------------------------------------------------------

function TLZ77Decoder.GetAvailableInput: integer;
begin
  Result:=FStream.AvailableInput;
end;

//----------------------------------------------------------------------------------------------------------------------

function TLZ77Decoder.GetAvailableOutput: integer;
begin
  Result:=FStream.AvailableOutput;
end;

//----------------- TThunderDecoder ------------------------------------------------------------------------------------

// ThunderScan uses an encoding scheme designed for 4-bit pixel values.  Data is encoded in bytes, with
// each byte split into a 2-bit code word and a 6-bit data value.  The encoding gives raw data, runs of
// pixels, or pixel values encoded as a delta from the previous pixel value.  For the latter, either 2-bit
// or 3-bit delta values are used, with the deltas packed into a single byte.

const
  THUNDER_DATA       = $3F;   // mask for 6-bit data
  THUNDER_CODE       = $C0;   // mask for 2-bit code word
  // code values
  THUNDER_RUN        = 0;     // run of pixels w/ encoded count
  THUNDER_2BITDELTAS = $40;   // 3 pixels w/ encoded 2-bit deltas
  DELTA2_SKIP        = 2;     // skip code for 2-bit deltas
  THUNDER_3BITDELTAS = $80;   // 2 pixels w/ encoded 3-bit deltas
  DELTA3_SKIP        = 4;     // skip code for 3-bit deltas
  THUNDER_RAW        = $C0;   // raw data encoded

  TwoBitDeltas: array[0..3] of integer = (0,1,0,-1);
  ThreeBitDeltas: array[0..7] of integer = (0,1,2,3,0,-3,-2,-1);

constructor TThunderDecoder.Create(Width: cardinal);
begin
  FWidth:=Width;
end;

//----------------------------------------------------------------------------------------------------------------------

procedure TThunderDecoder.Decode(var Source,Dest: pointer; PackedSize,UnpackedSize: integer);
var SourcePtr,TargetPtr: PByte;
    LastPixel,N,Delta: integer;
    NPixels: cardinal;
    //--------------- local function --------------------------------------------
    procedure SetPixel(Delta: integer);
    begin
      Lastpixel:=Delta and $0F;
      if Odd(NPixels) then
        begin
          TargetPtr^:=TargetPtr^ or LastPixel;
          Inc(TargetPtr);
        end
      else TargetPtr^:=LastPixel shl 4;
      Inc(NPixels);
    end;
    //--------------- end local function ----------------------------------------
begin
  SourcePtr:=Source;
  TargetPtr:=Dest;
  while UnpackedSize>0 do
    begin
      LastPixel:=0;
      NPixels:=0;
      // Usually Width represents the byte number of a strip, but the thunder
      // algo is only defined for 4 bits per pixel formats where 2 pixels take up
      // one byte.
      while (PackedSize>0) and (NPixels<2*FWidth) do
        begin
          N:=SourcePtr^;
          Inc(SourcePtr);
          Dec(PackedSize);
          case N and THUNDER_CODE of
            THUNDER_RUN:
              // pixel run, replicate the last pixel n times, where n is the lower-order 6 bits
              begin
                if Odd(NPixels) then
                  begin
                    TargetPtr^:=TargetPtr^ or Lastpixel;
                    Lastpixel:=TargetPtr^;
                    Inc(TargetPtr);
                    Inc(NPixels);
                    Dec(N);
                  end
                else LastPixel:=LastPixel or LastPixel shl 4;
                Inc(NPixels, N);
                while N>0 do
                  begin
                    TargetPtr^:=LastPixel;
                    Inc(TargetPtr);
                    Dec(N, 2);
                  end;
                if N = -1 then
                  begin
                    Dec(TargetPtr);
                    TargetPtr^:=TargetPtr^ and $F0;
                  end;
                LastPixel:=LastPixel and $0F;
              end;
            THUNDER_2BITDELTAS: // 2-bit deltas
              begin
                Delta:=(N shr 4) and 3;
                if Delta<>DELTA2_SKIP then SetPixel(LastPixel+TwoBitDeltas[Delta]);
                Delta:=(N shr 2) and 3;
                if Delta<>DELTA2_SKIP then SetPixel(LastPixel+TwoBitDeltas[Delta]);
                Delta:=N and 3;
                if Delta<>DELTA2_SKIP then SetPixel(LastPixel+TwoBitDeltas[Delta]);
              end;
            THUNDER_3BITDELTAS: // 3-bit deltas
              begin
                Delta:=(N shr 3) and 7;
                if Delta<>DELTA3_SKIP then SetPixel(LastPixel+ThreeBitDeltas[Delta]);
                Delta:=N and 7;
                if Delta<>DELTA3_SKIP then SetPixel(LastPixel+ThreeBitDeltas[Delta]);
              end;
            THUNDER_RAW: // raw data
              SetPixel(N);
          end;
        end;
      Dec(UnpackedSize,FWidth);
    end;
end;

//----------------- TPCDDecoder ----------------------------------------------------------------------------------------

constructor TPCDDecoder.Create(Stream: PStream);
begin
  FStream:=Stream;
end;

//----------------------------------------------------------------------------------------------------------------------

procedure TPCDDecoder.Decode(var Source,Dest: pointer; PackedSize,UnpackedSize: integer);
// recovers the Huffman encoded luminance and chrominance deltas
// Note: This decoder leaves a bit the way like the other decoders work.
//       Source points to an array of 3 pointers, one for luminance (Y, Luma), one for blue
//       chrominance (Cb, Chroma1) and one for red chrominance (Cr, Chroma2). These pointers
//       point to source and target at the same time (in place decoding).
//       PackedSize contains the width of the current subimage and UnpackedSize its height.
//       Dest is not used and can be nil.
type
  PPointerArray = ^TPointerArray;
  TPointerArray = array[0..2] of pointer;
  PPCDTable = ^TPCDTable;
  TPCDTable = packed record
    Length: byte;
    Sequence: cardinal;
    Key: byte;
    Mask: integer;
  end;
  PQuantumArray = ^TQuantumArray;
  TQuantumArray = array[0..3*256-1] of byte;
var
  Luma,Chroma1,Chroma2: PChar; // hold the actual pointers, PChar to easy pointer maths
  Width,Height: cardinal;
  PCDTable: array[0..2] of PPCDTable;
  I,J,K: cardinal;
  R: PPCDTable;
  RangeLimit: PQuantumArray;
  P,Q,Buffer: PChar;
  Accumulator,Bits,Length,Plane,Row: cardinal;
  PCDLength: array[0..2] of cardinal;

  //--------------- local function --------------------------------------------
  procedure PCDGetBits(N: cardinal);
  begin
    Accumulator:=Accumulator shl N;
    Dec(Bits,N);
    while Bits<=24 do
      begin
        if P>=(Buffer+$800) then
          begin
            FStream.Read(Buffer^,$800);
            P:=Buffer;
          end;
        Accumulator:=Accumulator or (cardinal(P^) shl (24-Bits));
        Inc(Bits,8);
        Inc(P);
      end;
  end;
  //--------------- end local function ----------------------------------------
var Limit: cardinal;
begin
  // place the used source values into local variables with proper names to make
  // their usage clearer
  Luma:=PPointerArray(Source)[0];
  Chroma1:=PPointerArray(Source)[1];
  Chroma2:=PPointerArray(Source)[2];
  Width:=PackedSize;
  Height:=UnpackedSize;
  // initialize Huffman tables
  ZeroMemory(@PCDTable,sizeof(PCDTable));
  GetMem(Buffer,$800);
  try
    Accumulator:=0;
    Bits:=32;
    P:=Buffer+$800;
    Limit:=1;
    if Width>1536 then Limit:=3;
    for I:=0 to Limit-1 do
      begin
        PCDGetBits(8);
        Length:=(Accumulator and $FF)+1;
        GetMem(PCDTable[I],Length*sizeof(TPCDTable));
        R:=PCDTable[I];
        for J:=0 to Length-1 do
          begin
            PCDGetBits(8);
            R.Length:=(Accumulator and $FF)+1;
            if R.Length>16 then
              begin
                if Assigned(Buffer) then FreeMem(Buffer);
                for K:=0 to 2 do
                if Assigned(PCDTable[K]) then FreeMem(PCDTable[K]);
                Exit;
              end;
            PCDGetBits(16);
            R.Sequence:=(Accumulator and $FFFF) shl 16;
            PCDGetBits(8);
            R.Key:=Accumulator and $FF;
            asm
              // R.Mask:=not ((1 shl (32-R.Length))-1);
              // asm implementation to avoid overflow errors and for faster execution
              MOV EDX,[R]
              MOV CL,32
              SUB CL,[EDX].TPCDTable.Length
              MOV EAX,1
              SHL EAX,CL
              DEC EAX
              NOT EAX
              MOV [EDX].TPCDTable.Mask,EAX
            end;
            Inc(R);
          end;
        PCDLength[I]:=Length;
      end;
    // initialize range limits
    GetMem(RangeLimit,3*256);
    try
      for I:=0 to 255 do
        begin
          RangeLimit[I]:=0;
          RangeLimit[I+256]:=I;
          RangeLimit[I+2*256]:=255;
        end;
      Inc(PByte(RangeLimit),255);
      // search for sync byte
      PCDGetBits(16);
      PCDGetBits(16);
      while (Accumulator and $00FFF000)<>$00FFF000 do PCDGetBits(8);
      while (Accumulator and $FFFFFF00)<>$FFFFFE00 do PCDGetBits(1);
      // recover the Huffman encoded luminance and chrominance deltas
      Length:=0;
      Plane:=0;
      Q:=Luma;
      repeat
        if (Accumulator and $FFFFFF00)=$FFFFFE00 then
          begin
            // determine plane and row number
            PCDGetBits(16);
            Row:=(Accumulator shr 9) and $1FFF;
            if Row=Height then Break;
            PCDGetBits(8);
            Plane:=Accumulator shr 30;
            PCDGetBits(16);
            case Plane of
              0: Q:=Luma+Row*Width;
              2: begin
                   Q:=Chroma1+(Row shr 1)*Width;
                   Dec(Plane);
                 end;
              3: begin
                   Q:=Chroma2+(Row shr 1)*Width;
                   Dec(Plane);
                 end;
            else Abort; // invalid/corrupt image
            end;
            Length:=PCDLength[Plane];
            Continue;
          end;
        // decode luminance or chrominance deltas
        R:=PCDTable[Plane];
        I:=0;
        while (I<Length) and ((Accumulator and R.Mask)<>R.Sequence) do
          begin
            Inc(I);
            Inc(R);
          end;
        if R=nil then
          begin
            // corrupt PCD image, skipping to sync byte
            while (Accumulator and $00FFF000)<>$00FFF000 do PCDGetBits(8);
            while (Accumulator and $FFFFFF00)<>$FFFFFE00 do PCDGetBits(1);
            Continue;
          end;
        if R.Key<128 then Q^:=Char(RangeLimit[ClampByte(Byte(Q^)+R.Key)]) else Q^:=Char(RangeLimit[ClampByte(Byte(Q^)+R.Key-256)]);
        Inc(Q);
        PCDGetBits(R.Length);
      until False;
    finally
      for I:=0 to 2 do if Assigned(PCDTable[I]) then FreeMem(PCDTable[I]);
      Dec(PByte(RangeLimit), 255);
      if Assigned(RangeLimit) then FreeMem(RangeLimit);
    end;
  finally
    if Assigned(Buffer) then FreeMem(Buffer);
  end;
end;

{$IFDEF GIF_MMX}
initialization
  mmxSupported := GetCPUType >= [ cpuMMX ];
{$ENDIF}

end.