graphicex.pas

很管用的GIS控件

  {$ifdef PortableNetworkGraphic}
  // *.png images
  TChunkType = array[0..3] of Char;

  // This header is followed by a variable number of data bytes, which are followed by the CRC for this data.
  // The actual size of this data is given by field length in the chunk header.
  // CRC is Cardinal (4 byte unsigned integer).
  TPNGChunkHeader = packed record
    Length: Cardinal;  // size of data (entire chunk excluding itself, CRC and type)
    ChunkType: TChunkType;
  end;

  TPNGGraphic = class(TGraphicExGraphic)
  private
    FDecoder: TLZ77Decoder;
    FIDATSize: Integer;        // remaining bytes in the current IDAT chunk
    FRawBuffer,                // buffer to load raw chunk data and to check CRC
    FCurrentSource: Pointer;   // points into FRawBuffer for current position of decoding
    FHeader: TPNGChunkHeader;  // header of the current chunk
    FCurrentCRC: Cardinal;     // running CRC for the current chunk
    FSourceBPP: Integer;       // bits per pixel used in the file
    FPalette: HPALETTE;        // used to hold the palette handle until we can set it finally after the pixel format
                               // has been set too (as this destroys the current palette)
    FTransparency: TByteArray; // If the image is indexed then this array might contain alpha values (depends on file)
                               // each entry corresponding to the same palette index as the index in this array.
                               // For grayscale and RGB images FTransparentColor contains the (only) transparent
                               // color.
    FTransparentColor: TColor; // transparent color for gray and RGB
    FBackgroundColor: TColor;  // index or color ref
    procedure ApplyFilter(Filter: Byte; Line, PrevLine, Target: PByte; BPP, BytesPerRow: Integer);
    function IsChunk(ChunkType: TChunkType): Boolean;
    function LoadAndSwapHeader: Cardinal;
    procedure LoadBackgroundColor(const Description);
    procedure LoadIDAT(const Description);
    procedure LoadTransparency(const Description);
    procedure ReadDataAndCheckCRC;
    procedure ReadRow(RowBuffer: Pointer; BytesPerRow: Integer);
    function SetupColorDepth(ColorType, BitDepth: Integer): Integer;
  public
    class function CanLoad(Stream: TStream): Boolean; override;
    procedure LoadFromStream(Stream: TStream); override;
    function ReadImageProperties(Stream: TStream; ImageIndex: Cardinal): Boolean; override;

    property BackgroundColor: TColor read FBackgroundColor;
    property Transparency: TByteArray read FTransparency;
  end;
  {$endif} // PortableNetworkGraphic

  // ---------- file format management stuff
  TFormatType = (
    ftAnimation,   // format contains an animation (like GIF or AVI)
    ftLayered,     // format supports multiple layers (like PSP, PSD)
    ftMultiImage,  // format can contain more than one image (like TIF or GIF)
    ftRaster,      // format is contains raster data (this is mainly used)
    ftVector       // format contains vector data (like DXF or PSP file version 4)
  );
  TFormatTypes = set of TFormatType;
  TFilterSortType = (
    fstNone,        // do not sort entries, list them as they are registered
    fstBoth,        // sort entries first by description then by extension
    fstDescription, // sort entries by description only
    fstExtension    // sort entries by extension only
  );

  TFilterOption = (
    foCompact,          // use the compact form in filter strings instead listing each extension on a separate line
    foIncludeAll,       // include the 'All image files' filter string
    foIncludeExtension  // add the extension to the description
  );
  TFilterOptions = set of TFilterOption;

  // The file format list is an alternative to Delphi's own poor implementation which does neither allow to filter
  // graphic formats nor to build common entries in filter strings nor does it care for duplicate entries or
  // alphabetic ordering. Additionally, some properties are maintained for each format to do searches, filter partiuclar
  // formats for a certain case etc.
  TFileFormatList = class
  private
    FClassList,
    FExtensionList: TList;
  protected
    function FindExtension(const Extension: String): Integer;
    function FindGraphicClass(GraphicClass: TGraphicClass): Integer;
  public
    constructor Create;
    destructor Destroy; override;

    procedure Clear;
    function GetDescription(Graphic: TGraphicClass): String;
    procedure GetExtensionList(List: TStrings);
    function GetGraphicFilter(Formats: TFormatTypes; SortType: TFilterSortType; Options: TFilterOptions;
      GraphicClass: TGraphicClass): String;
    function GraphicFromExtension(S: String): TGraphicClass;
    function GraphicFromContent(const FileName: String): TGraphicExGraphicClass; overload;
    function GraphicFromContent(Stream: TStream): TGraphicExGraphicClass; overload;
    procedure RegisterFileFormat(const Extension, Common, Individual: String; FormatTypes: TFormatTypes;
      Replace, RegisterDefault: Boolean; GraphicClass: TGraphicClass);
    procedure UnregisterFileFormat(const Extension: String; GraphicClass: TGraphicClass);
  end;

  // resampling support types
  TResamplingFilter = (sfBox, sfTriangle, sfHermite, sfBell, sfSpline, sfLanczos3, sfMitchell);

// Resampling support routines
procedure Stretch(NewWidth, NewHeight: Cardinal; Filter: TResamplingFilter; Radius: Single; Source, Target: TBitmap); overload;
procedure Stretch(NewWidth, NewHeight: Cardinal; Filter: TResamplingFilter; Radius: Single; Source: TBitmap); overload;

var
  FileFormatList: TFileFormatList;
  
//----------------------------------------------------------------------------------------------------------------------

implementation

uses
  Consts, Math, MZLib;

type
  // resampling support types
  TRGBInt = record
   R, G, B: Integer;
  end;

  PRGBWord = ^TRGBWord;
  TRGBWord = record
   R, G, B: Word;
  end;

  PRGBAWord = ^TRGBAWord;
  TRGBAWord = record
   R, G, B, A: Word;
  end;

  PBGR = ^TBGR;
  TBGR = packed record
   B, G, R: Byte;
  end;

  PBGRA = ^TBGRA;
  TBGRA = packed record
   B, G, R, A: Byte;
  end;

  PRGB = ^TRGB;
  TRGB = packed record
   R, G, B: Byte;
  end;

  PRGBA = ^TRGBA;
  TRGBA = packed record
   R, G, B, A: Byte;
  end;

  PPixelArray = ^TPixelArray;
  TPixelArray = array[0..0] of TBGR;

  TFilterFunction = function(Value: Single): Single;

  // contributor for a Pixel
  PContributor = ^TContributor;
  TContributor = record
   Weight: Integer; // Pixel Weight
   Pixel: Integer; // Source Pixel
  end;

  TContributors = array of TContributor;

  // list of source pixels contributing to a destination pixel
  TContributorEntry = record
   N: Integer;
   Contributors: TContributors;
  end;

  TContributorList = array of TContributorEntry;

const
  DefaultFilterRadius: array[TResamplingFilter] of Single = (0.5, 1, 1, 1.5, 2, 3, 2);

threadvar // globally used cache for current image (speeds up resampling about 10%)
  CurrentLineR: array of Integer;
  CurrentLineG: array of Integer;
  CurrentLineB: array of Integer;

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

procedure GraphicExError(ErrorString: String); overload;

begin
  raise EInvalidGraphic.Create(ErrorString);
end;

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

procedure GraphicExError(ErrorString: String; Args: array of const); overload;

begin
  raise EInvalidGraphic.CreateFmt(ErrorString, Args);
end;

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

procedure Upsample(Width, Height, ScaledWidth: Cardinal; Pixels: PChar);

// Creates a new image that is a integral size greater than an existing one.

var
  X, Y: Cardinal;
  P, Q, R: PChar;

begin
  for Y := 0 to Height - 1 do
  begin
    P := Pixels + (Height - 1 - Y) * ScaledWidth + (Width - 1);
    Q := Pixels + ((Height - 1 - Y) shl 1) * ScaledWidth + ((Width - 1) shl 1);
    Q^ := P^;
    (Q + 1)^ := P^;
    for X := 1 to Width - 1 do
    begin
      Dec(P);
      Dec(Q, 2);
      Q^ := P^;
      (Q + 1)^ := Char((Word(P^) + Word((P + 1)^) + 1) shr 1);
    end;
  end;            

  for Y := 0 to Height - 2 do
  begin
    P := Pixels + (Y shl 1) * ScaledWidth;
    Q := P + ScaledWidth;
    R := Q + ScaledWidth;
    for X := 0 to Width - 2 do
    begin
      Q^ := Char((Word(P^) + Word(R^) + 1) shr 1);
      (Q + 1)^ := Char((Word(P^) + Word((P + 2)^) + Word(R^) + Word((R + 2)^) + 2) shr 2);
      Inc(Q, 2);
      Inc(P, 2);
      Inc(R, 2);
    end;
    Q^ := Char((Word(P^) + Word(R^) + 1) shr 1);
    Inc(P);
    Inc(Q);
    Q^ := Char((Word(P^) + Word(R^) + 1) shr 1);
  end;
  P := Pixels + (2 * Height - 2) * ScaledWidth;
  Q := Pixels + (2 * Height - 1) * ScaledWidth;
  Move(P^, Q^, 2 * Width);
end;

//----------------- filter functions for stretching --------------------------------------------------------------------

function HermiteFilter(Value: Single): Single;

// f(t) = 2|t|^3 - 3|t|^2 + 1, -1 <= t <= 1

begin
  if Value < 0 then Value := -Value;
  if Value < 1 then Result := (2 * Value - 3) * Sqr(Value) + 1
               else Result := 0;
end;

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

function BoxFilter(Value: Single): Single;

// This filter is also known as 'nearest neighbour' Filter.

begin
  if (Value > -0.5) and (Value <= 0.5) then Result := 1
                                       else Result := 0;
end;

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

function TriangleFilter(Value: Single): Single;

// aka 'linear' or 'bilinear' filter

begin
  if Value < 0 then Value := -Value;
  if Value < 1 then Result := 1 - Value
               else Result := 0;
end;

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

function BellFilter(Value: Single): Single;

begin
  if Value < 0 then Value := -Value;
  if Value < 0.5 then Result := 0.75 - Sqr(Value)
                 else
    if Value < 1.5 then
    begin
      Value := Value - 1.5;
      Result := 0.5 * Sqr(Value);
    end
    else Result := 0;
end;

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

function SplineFilter(Value: Single): Single;

// B-spline filter

var
  Temp: Single;

begin
  if Value < 0 then Value := -Value;
  if Value < 1 then
  begin
    Temp := Sqr(Value);
    Result := 0.5 * Temp * Value - Temp + 2 / 3;
  end
  else
    if Value < 2 then
    begin
      Value := 2 - Value;
      Result := Sqr(Value) * Value / 6;
    end
    else Result := 0;
end;

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

function Lanczos3Filter(Value: Single): Single;

  //--------------- local function --------------------------------------------

  function SinC(Value: Single): Single;

  begin
    if Value <> 0 then
    begin
      Value := Value * Pi;
      Result := Sin(Value) / Value;
    end
    else Result := 1;
  end;

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

begin
  if Value < 0 then Value := -Value;
  if Value < 3 then Result := SinC(Value) * SinC(Value / 3)
               else Result := 0;
end;

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

function MitchellFilter(Value: Single): Single;

const
  B = 1 / 3;
  C = 1 / 3;

var Temp: Single;

begin
  if Value < 0 then Value := -Value;
  Temp := Sqr(Value);
  if Value < 1 then
  begin
    Value := (((12 - 9 * B - 6 * C) * (Value * Temp))
             + ((-18 + 12 * B + 6 * C) * Temp)
             + (6 - 2 * B));
    Result := Value / 6;
  end
  else
    if Value < 2 then