graphiccompression.pas

graphicex 增加对各种图形格式的支持

unit GraphicCompression;

// 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 ([e-mail]). All rights reserved.
//
// This package is freeware for non-commercial use only.
// Contact author for licenses ([e-mail]) and see License.txt which comes with the package.

interface

{$I GraphicConfiguration.inc}

uses                                                
  Windows, Classes, SysUtils, Graphics,  
  JPG,   // JPEG compression support
  MZLib;  // general inflate/deflate and LZ77 compression support
     
type
  // abstract decoder class to define the base functionality of an encoder/decoder
  TDecoder = class
  public
    procedure Decode(var Source, Dest: Pointer; PackedSize, UnpackedSize: Integer); virtual; abstract;
    procedure DecodeEnd; virtual;
    procedure DecodeInit; virtual;
    procedure Encode(Source, Dest: Pointer; Count: Cardinal; var BytesStored: Cardinal); virtual; abstract;
    procedure EncodeInit; virtual;
    procedure EncodeEnd; 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)
  TTargaRLEDecoder = class(TDecoder)
  private
    FColorDepth: Cardinal;
  public
    constructor Create(ColorDepth: Cardinal); 
    
    procedure Decode(var Source, Dest: Pointer; PackedSize, UnpackedSize: Integer); override;
    procedure Encode(Source, Dest: Pointer; Count: Cardinal; var BytesStored: Cardinal); override;
  end;

  {$ifdef UseLZW}
  // Lempel-Ziff-Welch encoder/decoder class
  // TIFF LZW compression / decompression is a bit different to the common LZW code
  TTIFFLZWDecoder = class(TDecoder)
  public
    procedure Decode(var Source, Dest: Pointer; PackedSize, UnpackedSize: Integer); override;
    procedure Encode(Source, Dest: Pointer; Count: Cardinal; var BytesStored: Cardinal); override;
  end;
  {$endif} // UseLZW

  TPackbitsRLEDecoder = class(TDecoder)
  public
    procedure Decode(var Source, Dest: Pointer; PackedSize, UnpackedSize: Integer); override;
    procedure Encode(Source, Dest: Pointer; Count: Cardinal; var BytesStored: Cardinal); override;
  end;

  TPCXRLEDecoder = class(TDecoder)
  public
    procedure Decode(var Source, Dest: Pointer; PackedSize, UnpackedSize: Integer); override;
    procedure Encode(Source, Dest: Pointer; Count: Cardinal; var BytesStored: Cardinal); override;
  end;

  TSGIRLEDecoder = class(TDecoder)
  private
    FSampleSize: Byte; // 8 or 16 bits
  public
    constructor Create(SampleSize: Byte);

    procedure Decode(var Source, Dest: Pointer; PackedSize, UnpackedSize: Integer); override;
    procedure Encode(Source, Dest: Pointer; Count: Cardinal; var BytesStored: Cardinal); override;
  end;

  TCUTRLEDecoder = class(TDecoder)
  public
    procedure Decode(var Source, Dest: Pointer; PackedSize, UnpackedSize: Integer); override;
    procedure Encode(Source, Dest: Pointer; Count: Cardinal; var BytesStored: Cardinal); override;
  end;

  TPSPRLEDecoder = class(TDecoder)
  public
    procedure Decode(var Source, Dest: Pointer; PackedSize, UnpackedSize: Integer); override;
    procedure Encode(Source, Dest: Pointer; Count: Cardinal; var BytesStored: Cardinal); override;
  end;

  {$ifdef UseLZW}
  // 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.
  TGIFLZWDecoder = class(TDecoder)
  private
    FInitialCodeSize: Byte;
  public
    constructor Create(InitialCodeSize: Byte);

    procedure Decode(var Source, Dest: Pointer; PackedSize, UnpackedSize: Integer); override;
    procedure Encode(Source, Dest: Pointer; Count: Cardinal; var BytesStored: Cardinal); override;
  end;
  {$endif} // UseLZW

  TRLADecoder = class(TDecoder)
  public
    procedure Decode(var Source, Dest: Pointer; PackedSize, UnpackedSize: Integer); override;
    procedure Encode(Source, Dest: Pointer; Count: Cardinal; var BytesStored: Cardinal); override;
  end;

  TStateEntry = record
    NewState: array[Boolean] of Cardinal;
    RunLength: Integer;
  end;
  TStateArray = array of TStateEntry;

  TCCITTDecoder = class(TDecoder)
  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;

  TCCITTFax3Decoder = class(TCCITTDecoder)
  public
    procedure Decode(var Source, Dest: Pointer; PackedSize, UnpackedSize: Integer); override;
    procedure Encode(Source, Dest: Pointer; Count: Cardinal; var BytesStored: Cardinal); override;
  end;

  TCCITTMHDecoder = class(TCCITTDecoder) // modified Huffman RLE
  public
    procedure Decode(var Source, Dest: Pointer; PackedSize, UnpackedSize: Integer); override;
    procedure Encode(Source, Dest: Pointer; Count: Cardinal; var BytesStored: Cardinal); override;
  end;

  TLZ77Decoder = class(TDecoder)
  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); override;
    procedure DecodeEnd; override;
    procedure DecodeInit; override;
    procedure Encode(Source, Dest: Pointer; Count: Cardinal; var BytesStored: Cardinal); override;

    property AvailableInput: Integer read GetAvailableInput;
    property AvailableOutput: Integer read GetAvailableOutput;
    property ZLibResult: Integer read FZLibResult;
  end;

  TTIFFJPEGDecoder = class;
        
  TJPEGGeneral = packed record
    case byte of
      0: (common: jpeg_common_struct);
      1: (d: jpeg_decompress_struct);
      2: (c: jpeg_compress_struct);
  end;

  PJPEGState = ^TJPEGState;
  TJPEGState = record
    General: TJPEGGeneral;                    // must be the first member here because we pass TJPEGState as
                                              // compress, decompress or common struct around to be able
                                              // to access our internal data
    Error: jpeg_error_mgr;                    // libjpeg error manager
    DestinationManager: jpeg_destination_mgr; // data dest for compression
    SourceManager: jpeg_source_mgr;           // data source for decompression
    HSampling,	                              // luminance sampling factors
    VSampling: Word;
    BytesPerLine: Cardinal;                   // decompressed bytes per scanline
    RawBuffer: Pointer;                       // source data
    RawBufferSize: Cardinal;
    // pointers to intermediate buffers when processing downsampled data
    DownSampleBuffer: array[0..MAX_COMPONENTS - 1] of JSAMPARRAY;
    ScanCount,	                              // number of 'scanlines' accumulated
    SamplesPerClump: Integer;
    JPEGTables: Pointer;                      // JPEGTables tag value, or nil
    JTLength: Cardinal;                       // number of bytes JPEGTables
    JPEGQuality,                              // compression quality level
    JPEGTablesMode: Integer;                  // what to put in JPEGTables
  end;

  TTIFFJPEGDecoder = class(TDecoder)
  private
		FState: TJPEGState;
    FImageProperties: Pointer; // anonymously declared because I cannot take GraphicEx.pas in the uses clause above
  public
    constructor Create(Properties: Pointer);

    procedure Decode(var Source, Dest: Pointer; PackedSize, UnpackedSize: Integer); override;
    procedure DecodeInit; override;
    procedure DecodeEnd; override;
    procedure Encode(Source, Dest: Pointer; Count: Cardinal; var BytesStored: Cardinal); override;
  end;

  TThunderDecoder = class(TDecoder)
  private
    FWidth: Cardinal; // width of a scanline in pixels
  public
    constructor Create(Width: Cardinal);

    procedure Decode(var Source, Dest: Pointer; PackedSize, UnpackedSize: Integer); override;
    procedure Encode(Source, Dest: Pointer; Count: Cardinal; var BytesStored: Cardinal); override;
  end;

  TPCDDecoder = class(TDecoder)
  private
    FStream: TStream;  // decoder must read some data
  public
    constructor Create(Stream: TStream);

    procedure Decode(var Source, Dest: Pointer; PackedSize, UnpackedSize: Integer); override;
    procedure Encode(Source, Dest: Pointer; Count: Cardinal; var BytesStored: Cardinal); override;
  end;

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

implementation

uses
  Math,
  GraphicEx,
  GraphicStrings,
  GraphicColor;

const // LZW encoding and decoding support
  NoLZWCode = 4096;

type
  EGraphicCompression = class(Exception);

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

procedure CompressionError(ErrorString: String); overload;

begin
  raise EGraphicCompression.Create(ErrorString);
end;

//----------------- 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;

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

procedure TDecoder.EncodeEnd;

// called after all compression has been done

begin
end;

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

procedure TDecoder.EncodeInit;

// called before any compression 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: Cardinal;
  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