/Graphics32/Source/GR32_Resamplers.pas

Large files files are truncated, but you can click here to view the full file

unit GR32_Resamplers;



(* ***** BEGIN LICENSE BLOCK *****

 * Version: MPL 1.1 or LGPL 2.1 with linking exception

 *

 * The contents of this file are subject to the Mozilla Public License Version

 * 1.1 (the "License"); you may not use this file except in compliance with

 * the License. You may obtain a copy of the License at

 * http://www.mozilla.org/MPL/

 *

 * Software distributed under the License is distributed on an "AS IS" basis,

 * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License

 * for the specific language governing rights and limitations under the

 * License.

 *

 * Alternatively, the contents of this file may be used under the terms of the

 * Free Pascal modified version of the GNU Lesser General Public License

 * Version 2.1 (the "FPC modified LGPL License"), in which case the provisions

 * of this license are applicable instead of those above.

 * Please see the file LICENSE.txt for additional information concerning this

 * license.

 *

 * The Original Code is Graphics32

 *

 * The Initial Developers of the Original Code is

 * Mattias Andersson <mattias@centaurix.com>

 * (parts of this unit were taken from GR32_Transforms.pas by Alex A. Denisov)

 *

 * Portions created by the Initial Developer are Copyright (C) 2000-2009

 * the Initial Developer. All Rights Reserved.

 *

 * Contributor(s):

 * Michael Hansen <dyster_tid@hotmail.com>

 *

 * ***** END LICENSE BLOCK ***** *)



interface



{$I GR32.inc}



{$IFNDEF FPC}

{-$IFDEF USE_3DNOW}

{$ENDIF}



uses

{$IFDEF FPC}

  LCLIntf,

{$ELSE}

  Windows, Types,

{$ENDIF}

  Classes, SysUtils, GR32, GR32_Transforms, GR32_Containers,

  GR32_OrdinalMaps, GR32_Blend, GR32_System, GR32_Bindings;



procedure BlockTransfer(

  Dst: TCustomBitmap32; DstX: Integer; DstY: Integer; DstClip: TRect;

  Src: TCustomBitmap32; SrcRect: TRect;

  CombineOp: TDrawMode;

  CombineMode: TCombineMode = cmMerge;

  MasterAlpha: Cardinal = 255;

  OuterColor: TColor32 = 0;

  CombineCallBack: TPixelCombineEvent = nil); overload;



procedure BlockTransfer(

  Dst: TCustomBitmap32; DstX: Integer; DstY: Integer; DstClip: TRect;

  SrcBits: PColor32Array; SrcWidth, SrcHeight: Integer; SrcRect: TRect;

  CombineOp: TDrawMode;

  CombineMode: TCombineMode = cmMerge;

  MasterAlpha: Cardinal = 255;

  OuterColor: TColor32 = 0;

  CombineCallBack: TPixelCombineEvent = nil); overload;



procedure BlockTransferX(

  Dst: TCustomBitmap32; DstX, DstY: TFixed;

  Src: TCustomBitmap32; SrcRect: TRect;

  CombineOp: TDrawMode;

  CombineMode: TCombineMode = cmMerge;

  MasterAlpha: Cardinal = 255;

  CombineCallBack: TPixelCombineEvent = nil);



procedure StretchTransfer(

  Dst: TCustomBitmap32; DstRect: TRect; DstClip: TRect;

  Src: TCustomBitmap32; SrcRect: TRect;

  Resampler: TCustomResampler;

  CombineOp: TDrawMode;

  CombineMode: TCombineMode = cmMerge;

  MasterAlpha: Cardinal = 255;

  OuterColor: TColor32 = 0;

  CombineCallBack: TPixelCombineEvent = nil); overload;



procedure StretchTransfer(

  Dst: TCustomBitmap32; DstRect: TRect; DstClip: TRect;

  SrcBits: PColor32Array; SrcWidth, SrcHeight: Integer; SrcRect: TRect;

  Resampler: TCustomResampler;

  CombineOp: TDrawMode;

  CombineMode: TCombineMode = cmMerge;

  MasterAlpha: Cardinal = 255;

  OuterColor: TColor32 = 0;

  CombineCallBack: TPixelCombineEvent = nil); overload;



procedure BlendTransfer(

  Dst: TCustomBitmap32; DstX, DstY: Integer; DstClip: TRect;

  SrcF: TCustomBitmap32; SrcRectF: TRect;

  SrcB: TCustomBitmap32; SrcRectB: TRect;

  BlendCallback: TBlendReg); overload;



procedure BlendTransfer(

  Dst: TCustomBitmap32; DstX, DstY: Integer; DstClip: TRect;

  SrcF: TCustomBitmap32; SrcRectF: TRect;

  SrcB: TCustomBitmap32; SrcRectB: TRect;

  BlendCallback: TBlendRegEx; MasterAlpha: Integer); overload;



const

  MAX_KERNEL_WIDTH = 16;



type

  PKernelEntry = ^TKernelEntry;

  TKernelEntry = array [-MAX_KERNEL_WIDTH..MAX_KERNEL_WIDTH] of Integer;



  TArrayOfKernelEntry = array of TArrayOfInteger;

  PKernelEntryArray = ^TKernelEntryArray;

  TKernelEntryArray = array [0..0] of TArrayOfInteger;



  TFilterMethod = function(Value: TFloat): TFloat of object;



  EBitmapException = class(Exception);

  ESrcInvalidException = class(Exception);

  ENestedException = class(Exception);



  TGetSampleInt = function(X, Y: Integer): TColor32 of object;

  TGetSampleFloat = function(X, Y: TFloat): TColor32 of object;

  TGetSampleFixed = function(X, Y: TFixed): TColor32 of object;



  { TCustomKernel }

  TCustomKernel = class(TPersistent)

  protected

    FObserver: TNotifiablePersistent;

  protected

    procedure AssignTo(Dst: TPersistent); override;

    function RangeCheck: Boolean; virtual;

  public

    constructor Create; virtual;

    procedure Changed;

    function Filter(Value: TFloat): TFloat; virtual; abstract;

    function GetWidth: TFloat; virtual; abstract;

    property Observer: TNotifiablePersistent read FObserver;

  end;

  TCustomKernelClass = class of TCustomKernel;



  { TBoxKernel }

  TBoxKernel = class(TCustomKernel)

  public

    function Filter(Value: TFloat): TFloat; override;

    function GetWidth: TFloat; override;

  end;



  { TLinearKernel }

  TLinearKernel = class(TCustomKernel)

  public

    function Filter(Value: TFloat): TFloat; override;

    function GetWidth: TFloat; override;

  end;



  { TCosineKernel }

  TCosineKernel = class(TCustomKernel)

  public

    function Filter(Value: TFloat): TFloat; override;

    function GetWidth: TFloat; override;

  end;



  { TSplineKernel }

  TSplineKernel = class(TCustomKernel)

  protected

    function RangeCheck: Boolean; override;

  public

    function Filter(Value: TFloat): TFloat; override;

    function GetWidth: TFloat; override;

  end;



  { TMitchellKernel }

  TMitchellKernel = class(TCustomKernel)

  protected

    function RangeCheck: Boolean; override;

  public

    function Filter(Value: TFloat): TFloat; override;

    function GetWidth: TFloat; override;

  end;



  { TCubicKernel }

  TCubicKernel = class(TCustomKernel)

  private

    FCoeff: TFloat;

    procedure SetCoeff(const Value: TFloat);

  protected

    function RangeCheck: Boolean; override;

  public

    constructor Create; override;

    function Filter(Value: TFloat): TFloat; override;

    function GetWidth: TFloat; override;

  published

    property Coeff: TFloat read FCoeff write SetCoeff;

  end;



  { THermiteKernel }

  THermiteKernel = class(TCustomKernel)

  private

    FBias: TFloat;

    FTension: TFloat;

    procedure SetBias(const Value: TFloat);

    procedure SetTension(const Value: TFloat);

  protected

    function RangeCheck: Boolean; override;

  public

    constructor Create; override;

    function Filter(Value: TFloat): TFloat; override;

    function GetWidth: TFloat; override;

  published

    property Bias: TFloat read FBias write SetBias;

    property Tension: TFloat read FTension write SetTension;

  end;



  { TWindowedSincKernel }

  TWindowedSincKernel = class(TCustomKernel)

  private

    FWidth : TFloat;

    FWidthReciprocal : TFloat;

  protected

    function RangeCheck: Boolean; override;

    function Window(Value: TFloat): TFloat; virtual; abstract;

  public

    constructor Create; override;

    function Filter(Value: TFloat): TFloat; override;

    procedure SetWidth(Value: TFloat);

    function GetWidth: TFloat; override;

    property WidthReciprocal : TFloat read FWidthReciprocal;

  published

    property Width: TFloat read FWidth write SetWidth;

  end;



  { TAlbrecht-Kernel }

  TAlbrechtKernel = class(TWindowedSincKernel)

  private

    FTerms: Integer;

    FCoefPointer : Array [0..11] of Double;

    procedure SetTerms(Value : Integer);

  protected

    function Window(Value: TFloat): TFloat; override;

  public

    constructor Create; override;

  published

    property Terms: Integer read FTerms write SetTerms;

  end;



  { TLanczosKernel }

  TLanczosKernel = class(TWindowedSincKernel)

  protected

    function Window(Value: TFloat): TFloat; override;

  public

  end;



  { TGaussianKernel }

  TGaussianKernel = class(TWindowedSincKernel)

  private

    FSigma: TFloat;

    FSigmaReciprocalLn2: TFloat;

    procedure SetSigma(const Value: TFloat);

  protected

    function Window(Value: TFloat): TFloat; override;

  public

    constructor Create; override;

  published

    property Sigma: TFloat read FSigma write SetSigma;

  end;



  { TBlackmanKernel }

  TBlackmanKernel = class(TWindowedSincKernel)

  protected

    function Window(Value: TFloat): TFloat; override;

  end;



  { THannKernel }

  THannKernel = class(TWindowedSincKernel)

  protected

    function Window(Value: TFloat): TFloat; override;

  end;



  { THammingKernel }

  THammingKernel = class(TWindowedSincKernel)

  protected

    function Window(Value: TFloat): TFloat; override;

  end;



  { TSinshKernel }

  TSinshKernel = class(TCustomKernel)

  private

    FWidth: TFloat;

    FCoeff: TFloat;

    procedure SetCoeff(const Value: TFloat);

  protected

    function  RangeCheck: Boolean; override;

  public

    constructor Create; override;

    procedure SetWidth(Value: TFloat);

    function  GetWidth: TFloat; override;

    function  Filter(Value: TFloat): TFloat; override;

  published

    property Coeff: TFloat read FCoeff write SetCoeff;

    property Width: TFloat read GetWidth write SetWidth;

  end;





  { TNearestResampler }

  TNearestResampler = class(TCustomResampler)

  private

    FGetSampleInt: TGetSampleInt;

  protected

    function GetPixelTransparentEdge(X, Y: Integer): TColor32;

    function GetWidth: TFloat; override;

    procedure Resample(

      Dst: TCustomBitmap32; DstRect: TRect; DstClip: TRect;

      SrcBits: PColor32Array; SrcWidth, SrcHeight: Integer; SrcRect: TRect;

      OuterColor: TColor32;

      CombineOp: TDrawMode;

      CombineMode: TCombineMode;

      MasterAlpha: Cardinal;

      CombineCallBack: TPixelCombineEvent); override;

  public

    function GetSampleInt(X, Y: Integer): TColor32; override;

    function GetSampleFixed(X, Y: TFixed): TColor32; override;

    function GetSampleFloat(X, Y: TFloat): TColor32; override;

    procedure PrepareSampling; override;

  end;



  { TLinearResampler }

  TLinearResampler = class(TCustomResampler)

  private

    FLinearKernel: TLinearKernel;

    FGetSampleFixed: TGetSampleFixed;

  protected

    function GetWidth: TFloat; override;

    function GetPixelTransparentEdge(X, Y: TFixed): TColor32;

    procedure Resample(

      Dst: TCustomBitmap32; DstRect: TRect; DstClip: TRect;

      SrcBits: PColor32Array; SrcWidth, SrcHeight: Integer; SrcRect: TRect;

      OuterColor: TColor32;

      CombineOp: TDrawMode;

      CombineMode: TCombineMode;

      MasterAlpha: Cardinal;

      CombineCallBack: TPixelCombineEvent); override;

  public

    constructor Create; override;

    destructor Destroy; override;

    function GetSampleFixed(X, Y: TFixed): TColor32; override;

    function GetSampleFloat(X, Y: TFloat): TColor32; override;

    procedure PrepareSampling; override;

  end;



  { TDraftResampler }

  TDraftResampler = class(TLinearResampler)

  protected

    procedure Resample(

      Dst: TCustomBitmap32; DstRect: TRect; DstClip: TRect;

      SrcBits: PColor32Array; SrcWidth, SrcHeight: Integer; SrcRect: TRect;

      OuterColor: TColor32;

      CombineOp: TDrawMode;

      CombineMode: TCombineMode;

      MasterAlpha: Cardinal;

      CombineCallBack: TPixelCombineEvent); override;

  end;



  { TKernelResampler }

  { This resampler class will perform resampling by using an arbitrary

    reconstruction kernel. By using the kmTableNearest and kmTableLinear

    kernel modes, kernel values are precomputed in a look-up table. This

    allows GetSample to execute faster for complex kernels. }



  TKernelMode = (kmDynamic, kmTableNearest, kmTableLinear);



  TKernelResampler = class(TCustomResampler)

  private

    FKernel: TCustomKernel;

    FKernelMode: TKernelMode;

    FWeightTable: TIntegerMap;

    FTableSize: Integer;

    FOuterColor: TColor32;

    procedure SetKernel(const Value: TCustomKernel);

    function GetKernelClassName: string;

    procedure SetKernelClassName(Value: string);

    procedure SetKernelMode(const Value: TKernelMode);

    procedure SetTableSize(Value: Integer);

  protected

    function GetWidth: TFloat; override;

  public

    constructor Create; override;

    destructor Destroy; override;

    function GetSampleFloat(X, Y: TFloat): TColor32; override;

    procedure Resample(

      Dst: TCustomBitmap32; DstRect: TRect; DstClip: TRect;

      SrcBits: PColor32Array; SrcWidth, SrcHeight: Integer; SrcRect: TRect;

      OuterColor: TColor32;

      CombineOp: TDrawMode;

      CombineMode: TCombineMode;

      MasterAlpha: Cardinal;

      CombineCallBack: TPixelCombineEvent); override;

    procedure PrepareSampling; override;

    procedure FinalizeSampling; override;

  published

    property KernelClassName: string read GetKernelClassName write SetKernelClassName;

    property Kernel: TCustomKernel read FKernel write SetKernel;

    property KernelMode: TKernelMode read FKernelMode write SetKernelMode;

    property TableSize: Integer read FTableSize write SetTableSize;

  end;



  { TNestedSampler }

  TNestedSampler = class(TCustomSampler)

  private

    FSampler: TCustomSampler;

    FGetSampleInt: TGetSampleInt;

    FGetSampleFixed: TGetSampleFixed;

    FGetSampleFloat: TGetSampleFloat;

    procedure SetSampler(const Value: TCustomSampler);

  protected

    procedure AssignTo(Dst: TPersistent); override;

  public

    constructor Create(ASampler: TCustomSampler); reintroduce; virtual; 

    procedure PrepareSampling; override;

    procedure FinalizeSampling; override;

    function HasBounds: Boolean; override;

    function GetSampleBounds: TFloatRect; override;

  published

    property Sampler: TCustomSampler read FSampler write SetSampler;

  end;



  { TTransformer }

  TReverseTransformInt = procedure(DstX, DstY: Integer; out SrcX, SrcY: Integer) of object;

  TReverseTransformFixed = procedure(DstX, DstY: TFixed; out SrcX, SrcY: TFixed) of object;

  TReverseTransformFloat = procedure(DstX, DstY: TFloat; out SrcX, SrcY: TFloat) of object;



  TTransformer = class(TNestedSampler)

  private

    FTransformation: TTransformation;

    FTransformationReverseTransformInt: TReverseTransformInt;

    FTransformationReverseTransformFixed: TReverseTransformFixed;

    FTransformationReverseTransformFloat: TReverseTransformFloat;

    procedure SetTransformation(const Value: TTransformation);

  public

    constructor Create(ASampler: TCustomSampler; ATransformation: TTransformation); reintroduce;

    procedure PrepareSampling; override;

    function GetSampleInt(X, Y: Integer): TColor32; override;

    function GetSampleFixed(X, Y: TFixed): TColor32; override;

    function GetSampleFloat(X, Y: TFloat): TColor32; override;

    function HasBounds: Boolean; override;

    function GetSampleBounds: TFloatRect; override;

  published

    property Transformation: TTransformation read FTransformation write SetTransformation;

  end;



  { TSuperSampler }

  TSamplingRange = 1..MaxInt;



  TSuperSampler = class(TNestedSampler)

  private

    FSamplingY: TSamplingRange;

    FSamplingX: TSamplingRange;

    FDistanceX: TFixed;

    FDistanceY: TFixed;

    FOffsetX: TFixed;

    FOffsetY: TFixed;

    FScale: TFixed;

    procedure SetSamplingX(const Value: TSamplingRange);

    procedure SetSamplingY(const Value: TSamplingRange);

  public

    constructor Create(Sampler: TCustomSampler); override;

    function GetSampleFixed(X, Y: TFixed): TColor32; override;

  published

    property SamplingX: TSamplingRange read FSamplingX write SetSamplingX;

    property SamplingY: TSamplingRange read FSamplingY write SetSamplingY;

  end;



  { TAdaptiveSuperSampler }

  TRecurseProc = function(X, Y, W: TFixed; const C1, C2: TColor32): TColor32 of object;



  TAdaptiveSuperSampler = class(TNestedSampler)

  private

    FMinOffset: TFixed;

    FLevel: Integer;

    FTolerance: Integer;

    procedure SetLevel(const Value: Integer);

    function DoRecurse(X, Y, Offset: TFixed; const A, B, C, D, E: TColor32): TColor32;

    function QuadrantColor(const C1, C2: TColor32; X, Y, Offset: TFixed;

      Proc: TRecurseProc): TColor32;

    function RecurseAC(X, Y, Offset: TFixed; const A, C: TColor32): TColor32;

    function RecurseBD(X, Y, Offset: TFixed; const B, D: TColor32): TColor32;

  protected

    function CompareColors(C1, C2: TColor32): Boolean; virtual;

  public

    constructor Create(Sampler: TCustomSampler); override;

    function GetSampleFixed(X, Y: TFixed): TColor32; override;

  published

    property Level: Integer read FLevel write SetLevel;

    property Tolerance: Integer read FTolerance write FTolerance;

  end;



  { TPatternSampler }

  TFloatSamplePattern = array of array of TArrayOfFloatPoint;

  TFixedSamplePattern = array of array of TArrayOfFixedPoint;



  TPatternSampler = class(TNestedSampler)

  private

    FPattern: TFixedSamplePattern;

    procedure SetPattern(const Value: TFixedSamplePattern);

  protected

    WrapProcVert: TWrapProc;

  public

    destructor Destroy; override;

    function GetSampleFixed(X, Y: TFixed): TColor32; override;

    property Pattern: TFixedSamplePattern read FPattern write SetPattern;

  end;



  { Auxiliary record used in accumulation routines }

  PBufferEntry = ^TBufferEntry;

  TBufferEntry = record

    B, G, R, A: Integer;

  end;



  { TKernelSampler }

  TKernelSampler = class(TNestedSampler)

  private

    FKernel: TIntegerMap;

    FStartEntry: TBufferEntry;

    FCenterX: Integer;

    FCenterY: Integer;

  protected

    procedure UpdateBuffer(var Buffer: TBufferEntry; Color: TColor32;

      Weight: Integer); virtual; abstract;

    function ConvertBuffer(var Buffer: TBufferEntry): TColor32; virtual;

  public

    constructor Create(ASampler: TCustomSampler); override;

    destructor Destroy; override;

    function GetSampleInt(X, Y: Integer): TColor32; override;

    function GetSampleFixed(X, Y: TFixed): TColor32; override;

  published

    property Kernel: TIntegerMap read FKernel write FKernel;

    property CenterX: Integer read FCenterX write FCenterX;

    property CenterY: Integer read FCenterY write FCenterY;

  end;



  { TConvolver }

  TConvolver = class(TKernelSampler)

  protected

    procedure UpdateBuffer(var Buffer: TBufferEntry; Color: TColor32;

      Weight: Integer); override;

  end;



  { TSelectiveConvolver }

  TSelectiveConvolver = class(TConvolver)

  private

    FRefColor: TColor32;

    FDelta: Integer;

    FWeightSum: TBufferEntry;

  protected

    procedure UpdateBuffer(var Buffer: TBufferEntry; Color: TColor32;

      Weight: Integer); override;

    function ConvertBuffer(var Buffer: TBufferEntry): TColor32; override;

  public

    constructor Create(ASampler: TCustomSampler); override;

    function GetSampleInt(X, Y: Integer): TColor32; override;

    function GetSampleFixed(X, Y: TFixed): TColor32; override;

  published

    property Delta: Integer read FDelta write FDelta;

  end;



  { TMorphologicalSampler }

  TMorphologicalSampler = class(TKernelSampler)

  protected

    function ConvertBuffer(var Buffer: TBufferEntry): TColor32; override;

  end;



  { TDilater }

  TDilater = class(TMorphologicalSampler)

  protected

    procedure UpdateBuffer(var Buffer: TBufferEntry; Color: TColor32;

      Weight: Integer); override;

  end;



  { TEroder }

  TEroder = class(TMorphologicalSampler)

  protected

    procedure UpdateBuffer(var Buffer: TBufferEntry; Color: TColor32;

      Weight: Integer); override;

  public

    constructor Create(ASampler: TCustomSampler); override;

  end;



  { TExpander }

  TExpander = class(TKernelSampler)

  protected

    procedure UpdateBuffer(var Buffer: TBufferEntry; Color: TColor32;

      Weight: Integer); override;

  end;



  { TContracter }

  TContracter = class(TExpander)

  private

    FMaxWeight: TColor32;

  protected

    procedure UpdateBuffer(var Buffer: TBufferEntry; Color: TColor32;

      Weight: Integer); override;

  public

    procedure PrepareSampling; override;

    function GetSampleInt(X, Y: Integer): TColor32; override;

    function GetSampleFixed(X, Y: TFixed): TColor32; override;

  end;



function CreateJitteredPattern(TileWidth, TileHeight, SamplesX, SamplesY: Integer): TFixedSamplePattern;



{ Convolution and morphological routines }

procedure Convolve(Src, Dst: TCustomBitmap32; Kernel: TIntegerMap; CenterX, CenterY: Integer);

procedure Dilate(Src, Dst: TCustomBitmap32; Kernel: TIntegerMap; CenterX, CenterY: Integer);

procedure Erode(Src, Dst: TCustomBitmap32; Kernel: TIntegerMap; CenterX, CenterY: Integer);

procedure Expand(Src, Dst: TCustomBitmap32; Kernel: TIntegerMap; CenterX, CenterY: Integer);

procedure Contract(Src, Dst: TCustomBitmap32; Kernel: TIntegerMap; CenterX, CenterY: Integer);



{ Auxiliary routines for accumulating colors in a buffer }

procedure IncBuffer(var Buffer: TBufferEntry; Color: TColor32); {$IFDEF USEINLINING} inline; {$ENDIF}

procedure MultiplyBuffer(var Buffer: TBufferEntry; W: Integer); {$IFDEF USEINLINING} inline; {$ENDIF}

function BufferToColor32(Buffer: TBufferEntry; Shift: Integer): TColor32; {$IFDEF USEINLINING} inline; {$ENDIF}

procedure ShrBuffer(var Buffer: TBufferEntry; Shift: Integer); {$IFDEF USEINLINING} inline; {$ENDIF}



{ Registration routines }

procedure RegisterResampler(ResamplerClass: TCustomResamplerClass);

procedure RegisterKernel(KernelClass: TCustomKernelClass);



var

  KernelList: TClassList;

  ResamplerList: TClassList;



const

  EMPTY_ENTRY: TBufferEntry = (B: 0; G: 0; R: 0; A: 0);



var

  BlockAverage: function(Dlx, Dly: Cardinal; RowSrc: PColor32; OffSrc: Cardinal): TColor32;

  Interpolator: function(WX_256, WY_256: Cardinal; C11, C21: PColor32): TColor32;



resourcestring

  SDstNil = 'Destination bitmap is nil';

  SSrcNil = 'Source bitmap is nil';

  SSrcInvalid = 'Source rectangle is invalid';

  SSamplerNil = 'Nested sampler is nil';



implementation



uses

  GR32_LowLevel, GR32_Rasterizers, GR32_Math, Math;



resourcestring

  RCStrInvalidSrcRect = 'Invalid SrcRect';



const

  CAlbrecht2    : array [0..1] of Double = (5.383553946707251E-1, 4.616446053292749E-1);

  CAlbrecht3    : array [0..2] of Double = (3.46100822018625E-1,  4.97340635096738E-1,

                                            1.56558542884637E-1);

  CAlbrecht4    : array [0..3] of Double = (2.26982412792069E-1,  4.57254070828427E-1,

                                            2.73199027957384E-1,  4.25644884221201E-2);

  CAlbrecht5    : array [0..4] of Double = (1.48942606015830E-1,  3.86001173639176E-1,

                                            3.40977403214053E-1,  1.139879604246E-1,

                                            1.00908567063414E-2);

  CAlbrecht6    : array [0..5] of Double = (9.71676200107429E-2,  3.08845222524055E-1,

                                            3.62623371437917E-1,  1.88953325525116E-1,

                                            4.02095714148751E-2,  2.20088908729420E-3);

  CAlbrecht7    : array [0..6] of Double = (6.39644241143904E-2,  2.39938645993528E-1,

                                            3.50159563238205E-1,  2.47741118970808E-1,

                                            8.54382560558580E-2,  1.23202033692932E-2,

                                            4.37788257917735E-4);

  CAlbrecht8    : array [0..7] of Double = (4.21072107042137E-2,  1.82076226633776E-1,

                                            3.17713781059942E-1,  2.84438001373442E-1,

                                            1.36762237777383E-1,  3.34038053504025E-2,

                                            3.41677216705768E-3,  8.19649337831348E-5);

  CAlbrecht9    : array [0..8] of Double = (2.76143731612611E-2,  1.35382228758844E-1,

                                            2.75287234472237E-1,  2.98843335317801E-1,

                                            1.85319330279284E-1,  6.48884482549063E-2,

                                            1.17641910285655E-2,  8.85987580106899E-4,

                                            1.48711469943406E-5);

  CAlbrecht10   : array [0..9] of Double = (1.79908225352538E-2,  9.87959586065210E-2,

                                            2.29883817001211E-1,  2.94113019095183E-1,

                                            2.24338977814325E-1,  1.03248806248099E-1,

                                            2.75674109448523E-2,  3.83958622947123E-3,

                                            2.18971708430106E-4,  2.62981665347889E-6);

  CAlbrecht11  : array [0..10] of Double = (1.18717127796602E-2,  7.19533651951142E-2,

                                            1.87887160922585E-1,  2.75808174097291E-1,

                                            2.48904243244464E-1,  1.41729867200712E-1,

                                            5.02002976228256E-2,  1.04589649084984E-2,

                                            1.13615112741660E-3,  4.96285981703436E-5,

                                            4.34303262685720E-7);

type

  TTransformationAccess = class(TTransformation);

  TCustomBitmap32Access = class(TCustomBitmap32);

  TCustomResamplerAccess = class(TCustomResampler);



  PPointRec = ^TPointRec;

  TPointRec = record

    Pos: Integer;

    Weight: Cardinal;

  end;



  TCluster = array of TPointRec;

  TMappingTable = array of TCluster;





type

  TKernelSamplerClass = class of TKernelSampler;



{ Auxiliary rasterization routine for kernel-based samplers }

procedure RasterizeKernelSampler(Src, Dst: TCustomBitmap32; Kernel: TIntegerMap;

  CenterX, CenterY: Integer; SamplerClass: TKernelSamplerClass);

var

  Sampler: TKernelSampler;

  Rasterizer: TRasterizer;

begin

  Rasterizer := DefaultRasterizerClass.Create;

  try

    Dst.SetSizeFrom(Src);

    Sampler := SamplerClass.Create(Src.Resampler);

    Sampler.Kernel := Kernel;

    try

      Rasterizer.Sampler := Sampler;

      Rasterizer.Rasterize(Dst);

    finally

      Sampler.Free;

    end;

  finally

    Rasterizer.Free;

  end;

end;



procedure Convolve(Src, Dst: TCustomBitmap32; Kernel: TIntegerMap; CenterX, CenterY: Integer);

begin

  RasterizeKernelSampler(Src, Dst, Kernel, CenterX, CenterY, TConvolver);

end;



procedure Dilate(Src, Dst: TCustomBitmap32; Kernel: TIntegerMap; CenterX, CenterY: Integer);

begin

  RasterizeKernelSampler(Src, Dst, Kernel, CenterX, CenterY, TDilater);

end;



procedure Erode(Src, Dst: TCustomBitmap32; Kernel: TIntegerMap; CenterX, CenterY: Integer);

begin

  RasterizeKernelSampler(Src, Dst, Kernel, CenterX, CenterY, TEroder);

end;



procedure Expand(Src, Dst: TCustomBitmap32; Kernel: TIntegerMap; CenterX, CenterY: Integer);

begin

  RasterizeKernelSampler(Src, Dst, Kernel, CenterX, CenterY, TExpander);

end;



procedure Contract(Src, Dst: TCustomBitmap32; Kernel: TIntegerMap; CenterX, CenterY: Integer);

begin

  RasterizeKernelSampler(Src, Dst, Kernel, CenterX, CenterY, TContracter);

end;



{ Auxiliary routines }



procedure IncBuffer(var Buffer: TBufferEntry; Color: TColor32);

begin

  with TColor32Entry(Color) do

  begin

    Inc(Buffer.B, B);

    Inc(Buffer.G, G);

    Inc(Buffer.R, R);

    Inc(Buffer.A, A);

  end;

end;



procedure MultiplyBuffer(var Buffer: TBufferEntry; W: Integer);

begin

  Buffer.B := Buffer.B * W;

  Buffer.G := Buffer.G * W;

  Buffer.R := Buffer.R * W;

  Buffer.A := Buffer.A * W;

end;



procedure ShrBuffer(var Buffer: TBufferEntry; Shift: Integer);

begin

  Buffer.B := Buffer.B shr Shift;

  Buffer.G := Buffer.G shr Shift;

  Buffer.R := Buffer.R shr Shift;

  Buffer.A := Buffer.A shr Shift;

end;



function BufferToColor32(Buffer: TBufferEntry; Shift: Integer): TColor32;

begin

  with TColor32Entry(Result) do

  begin

    B := Buffer.B shr Shift;

    G := Buffer.G shr Shift;

    R := Buffer.R shr Shift;

    A := Buffer.A shr Shift;

  end;

end;



procedure CheckBitmaps(Dst, Src: TCustomBitmap32); {$IFDEF USEINLINING}inline;{$ENDIF}

begin

  if not Assigned(Dst) then raise EBitmapException.Create(SDstNil);

  if not Assigned(Src) then raise EBitmapException.Create(SSrcNil);

end;



procedure BlendBlock(

  Dst: TCustomBitmap32; DstRect: TRect;

  SrcBits: PColor32Array; SrcWidth, SrcHeight: Integer;

  SrcX, SrcY: Integer;

  OuterColor: TColor32;

  CombineOp: TDrawMode;

  CombineMode: TCombineMode;

  MasterAlpha: Cardinal;

  CombineCallBack: TPixelCombineEvent);

var

  SrcP, DstP: PColor32;

  SP, DP: PColor32;

  MC: TColor32;

  W, I, DstY: Integer;

  BlendLine: TBlendLine;

  BlendLineEx: TBlendLineEx;

begin

  { Internal routine }

  W := DstRect.Right - DstRect.Left;

  SrcP := @SrcBits[SrcX + SrcY*SrcWidth];

  DstP := Dst.PixelPtr[DstRect.Left, DstRect.Top];



  case CombineOp of

    dmOpaque:

      begin

        for DstY := DstRect.Top to DstRect.Bottom - 1 do

        begin

          //Move(SrcP^, DstP^, W shl 2); // for FastCode

          MoveLongWord(SrcP^, DstP^, W);

          Inc(SrcP, SrcWidth);

          Inc(DstP, Dst.Width);

        end;

      end;

    dmBlend:

      if MasterAlpha >= 255 then

      begin

        BlendLine := BLEND_LINE[CombineMode]^;

        for DstY := DstRect.Top to DstRect.Bottom - 1 do

        begin

          BlendLine(SrcP, DstP, W);

          Inc(SrcP, SrcWidth);

          Inc(DstP, Dst.Width);

        end

      end

      else

      begin

        BlendLineEx := BLEND_LINE_EX[CombineMode]^;

        for DstY := DstRect.Top to DstRect.Bottom - 1 do

        begin

          BlendLineEx(SrcP, DstP, W, MasterAlpha);

          Inc(SrcP, SrcWidth);

          Inc(DstP, Dst.Width);

        end

      end;

    dmTransparent:

      begin

        MC := OuterColor;

        for DstY := DstRect.Top to DstRect.Bottom - 1 do

        begin

          SP := SrcP;

          DP := DstP;

          { TODO: Write an optimized routine for fast masked transfers. }

          for I := 0 to W - 1 do

          begin

            if MC <> SP^ then DP^ := SP^;

            Inc(SP); Inc(DP);

          end;

          Inc(SrcP, SrcWidth);

          Inc(DstP, Dst.Width);

        end;

      end;

    else //  dmCustom:

      begin

        for DstY := DstRect.Top to DstRect.Bottom - 1 do

        begin

          SP := SrcP;

          DP := DstP;

          for I := 0 to W - 1 do

          begin

            CombineCallBack(SP^, DP^, MasterAlpha);

            Inc(SP); Inc(DP);

          end;

          Inc(SrcP, SrcWidth);

          Inc(DstP, Dst.Width);

        end;

      end;

    end;

end;



procedure BlockTransfer(

  Dst: TCustomBitmap32; DstX: Integer; DstY: Integer; DstClip: TRect;

  Src: TCustomBitmap32; SrcRect: TRect;

  CombineOp: TDrawMode;

  CombineMode: TCombineMode;

  MasterAlpha: Cardinal;

  OuterColor: TColor32;

  CombineCallBack: TPixelCombineEvent);

begin

  CheckBitmaps(Dst, Src);

  BlockTransfer(Dst, DstX, DstY, DstClip, Src.Bits, Src.Width, Src.Height,

    SrcRect, CombineOp, CombineMode, MasterAlpha, OuterColor, CombineCallBack);

end;



procedure BlockTransfer(

  Dst: TCustomBitmap32; DstX: Integer; DstY: Integer; DstClip: TRect;

  SrcBits: PColor32Array; SrcWidth, SrcHeight: Integer; SrcRect: TRect;

  CombineOp: TDrawMode;

  CombineMode: TCombineMode;

  MasterAlpha: Cardinal;

  OuterColor: TColor32;

  CombineCallBack: TPixelCombineEvent);

var

  SrcX, SrcY: Integer;

begin

  if not Assigned(Dst) then raise EBitmapException.Create(SDstNil);

  if Dst.Empty or not Assigned(SrcBits) or (SrcWidth <= 0) or (SrcHeight <= 0) or

    ((CombineOp = dmBlend) and (MasterAlpha = 0)) then Exit;



  SrcX := SrcRect.Left;

  SrcY := SrcRect.Top;



  GR32.IntersectRect(DstClip, DstClip, Dst.BoundsRect);

  GR32.IntersectRect(SrcRect, SrcRect, Bounds(0, 0, SrcWidth, SrcHeight));



  GR32.OffsetRect(SrcRect, DstX - SrcX, DstY - SrcY);

  GR32.IntersectRect(SrcRect, DstClip, SrcRect);

  if GR32.IsRectEmpty(SrcRect) then

    exit;



  DstClip := SrcRect;

  GR32.OffsetRect(SrcRect, SrcX - DstX, SrcY - DstY);



  if not Dst.MeasuringMode then

  begin

    try

      if (CombineOp = dmCustom) and not Assigned(CombineCallBack) then

        CombineOp := dmOpaque;



      BlendBlock(Dst, DstClip, SrcBits, SrcWidth, SrcHeight,

        SrcRect.Left, SrcRect.Top, OuterColor, CombineOp,

        CombineMode, MasterAlpha, CombineCallBack);

    finally

      EMMS;

    end;

  end;



  Dst.Changed(DstClip);

end;



{$WARNINGS OFF}

procedure BlockTransferX(

  Dst: TCustomBitmap32; DstX, DstY: TFixed;

  Src: TCustomBitmap32; SrcRect: TRect;

  CombineOp: TDrawMode;

  CombineMode: TCombineMode;

  MasterAlpha: Cardinal;

  CombineCallBack: TPixelCombineEvent);

type

  TColor32Array = array [0..1] of TColor32;

  PColor32Array = ^TColor32Array;

var

  I, Index, SrcW, SrcRectW, SrcRectH, DstW, DstH: Integer;

  FracX, FracY: Integer;

  Buffer: array [0..1] of TArrayOfColor32;

  SrcP, Buf1, Buf2: PColor32Array;

  DstP: PColor32;

  C1, C2, C3, C4: TColor32;

  LW, RW, TW, BW, MA: Integer;

  DstBounds: TRect;



  BlendLineEx: TBlendLineEx;

  BlendMemEx: TBlendMemEx;

begin

  CheckBitmaps(Dst, Src);

  if Dst.Empty or Src.Empty or ((CombineOp = dmBlend) and (MasterAlpha = 0)) then Exit;



  SrcRectW := SrcRect.Right - SrcRect.Left - 1;

  SrcRectH := SrcRect.Bottom - SrcRect.Top - 1;



  FracX := (DstX and $FFFF) shr 8;

  FracY := (DstY and $FFFF) shr 8;



  DstX := DstX div $10000;

  DstY := DstY div $10000;



  DstW := Dst.Width;

  DstH := Dst.Height;



  MA := MasterAlpha;



  if (DstX >= DstW) or (DstY >= DstH) or (MA = 0) then Exit;



  if (DstX + SrcRectW <= 0) or (Dsty + SrcRectH <= 0) then Exit;



  if DstX < 0 then LW := $FF else LW := FracX xor $FF;

  if DstY < 0 then TW := $FF else TW := FracY xor $FF;

  if DstX + SrcRectW >= DstW then RW := $FF else RW := FracX;

  if DstY + SrcRectH >= DstH then BW := $FF else BW := FracY;



  DstBounds := Dst.BoundsRect;

  Dec(DstBounds.Right);

  Dec(DstBounds.Bottom);

  GR32.OffsetRect(DstBounds, SrcRect.Left - DstX, SrcRect.Top - DstY);

  GR32.IntersectRect(SrcRect, SrcRect, DstBounds);



  if GR32.IsRectEmpty(SrcRect) then Exit;



  SrcW := Src.Width;



  SrcRectW := SrcRect.Right - SrcRect.Left;

  SrcRectH := SrcRect.Bottom - SrcRect.Top;



  if DstX < 0 then DstX := 0;

  if DstY < 0 then DstY := 0;



  if not Dst.MeasuringMode then

  begin

    SetLength(Buffer[0], SrcRectW + 1);

    SetLength(Buffer[1], SrcRectW + 1);



    BlendLineEx := BLEND_LINE_EX[CombineMode]^;

    BlendMemEx := BLEND_MEM_EX[CombineMode]^;



    try

      SrcP := PColor32Array(Src.PixelPtr[SrcRect.Left, SrcRect.Top - 1]);

      DstP := Dst.PixelPtr[DstX, DstY];



      Buf1 := @Buffer[0][0];

      Buf2 := @Buffer[1][0];



      if SrcRect.Top > 0 then

      begin

        MoveLongWord(SrcP[0], Buf1[0], SrcRectW);

        CombineLine(@Buf1[1], @Buf1[0], SrcRectW, FracX);



        if SrcRect.Left > 0 then

          {$IFDEF HAS_NATIVEINT}

          C2 := CombineReg(PColor32(NativeUInt(SrcP) - 4)^, SrcP[0], FracX xor $FF)

          {$ELSE}

          C2 := CombineReg(PColor32(Integer(SrcP) - 4)^, SrcP[0], FracX xor $FF)

          {$ENDIF}

        else

          C2 := SrcP[0];



        if SrcRect.Right < SrcW then

          C4 := CombineReg(SrcP[SrcRectW - 1], SrcP[SrcRectW], FracX)

        else

          C4 := SrcP[SrcRectW - 1];

      end;



      Inc(PColor32(SrcP), SrcW);

      MoveLongWord(SrcP^, Buf2^, SrcRectW);

      CombineLine(@Buf2[1], @Buf2[0], SrcRectW, FracX xor $FF);



      if SrcRect.Left > 0 then

        {$IFDEF HAS_NATIVEINT}

        C1 := CombineReg(PColor32(NativeUInt(SrcP) - 4)^, SrcP[0], FracX)

        {$ELSE}

        C1 := CombineReg(PColor32(Integer(SrcP) - 4)^, SrcP[0], FracX)

        {$ENDIF}

      else

        C1 := SrcP[0];



      if SrcRect.Right < SrcW then

        C3 := CombineReg(SrcP[SrcRectW - 1], SrcP[SrcRectW], FracX)

      else

        C3 := SrcP[SrcRectW - 1];



      if SrcRect.Top > 0 then

      begin

        BlendMemEx(CombineReg(C1, C2, FracY), DstP^, LW * TW * MA shr 16);

        CombineLine(@Buf2[0], @Buf1[0], SrcRectW, FracY xor $FF);

      end

      else

      begin

        BlendMemEx(C1, DstP^, LW * TW * MA shr 16);

        MoveLongWord(Buf2^, Buf1^, SrcRectW);

      end;



      Inc(DstP, 1);

      BlendLineEx(@Buf1[0], DstP, SrcRectW - 1, TW * MA shr 8);



      Inc(DstP, SrcRectW - 1);



      if SrcRect.Top > 0 then

        BlendMemEx(CombineReg(C3, C4, FracY), DstP^, RW * TW * MA shr 16)

      else

        BlendMemEx(C3, DstP^, RW * TW * MA shr 16);



      Inc(DstP, DstW - SrcRectW);



      Index := 1;

      for I := SrcRect.Top to SrcRect.Bottom - 2 do

      begin

        Buf1 := @Buffer[Index][0];

        Buf2 := @Buffer[Index xor 1][0];

        Inc(PColor32(SrcP), SrcW);



        MoveLongWord(SrcP[0], Buf2^, SrcRectW);



        // Horizontal translation

        CombineLine(@Buf2[1], @Buf2[0], SrcRectW, FracX xor $FF);



        if SrcRect.Left > 0 then

          {$IFDEF HAS_NATIVEINT}

          C2 := CombineReg(PColor32(NativeUInt(SrcP) - 4)^, SrcP[0], FracX xor $FF)

          {$ELSE}

          C2 := CombineReg(PColor32(Integer(SrcP) - 4)^, SrcP[0], FracX xor $FF)

          {$ENDIF}

        else

          C2 := SrcP[0];



        BlendMemEx(CombineReg(C1, C2, FracY), DstP^, LW * MA shr 8);

        Inc(DstP);

        C1 := C2;



        // Vertical translation

        CombineLine(@Buf2[0], @Buf1[0], SrcRectW, FracY xor $FF);



        // Blend horizontal line to Dst

        BlendLineEx(@Buf1[0], DstP, SrcRectW - 1, MA);

        Inc(DstP, SrcRectW - 1);



        if SrcRect.Right < SrcW then

          C4 := CombineReg(SrcP[SrcRectW - 1], SrcP[SrcRectW], FracX)

        else

          C4 := SrcP[SrcRectW - 1];



        BlendMemEx(CombineReg(C3, C4, FracY), DstP^, RW * MA shr 8);



        Inc(DstP, DstW - SrcRectW);

        C3 := C4;



        Index := Index xor 1;

      end;



      Buf1 := @Buffer[Index][0];

      Buf2 := @Buffer[Index xor 1][0];



      Inc(PColor32(SrcP), SrcW);



      if SrcRect.Bottom < Src.Height then

      begin

        MoveLongWord(SrcP[0], Buf2^, SrcRectW);

        CombineLine(@Buf2[1], @Buf2[0], SrcRectW, FracY xor $FF);

        CombineLine(@Buf2[0], @Buf1[0], SrcRectW, FracY xor $FF);

        if SrcRect.Left > 0 then

          {$IFDEF HAS_NATIVEINT}

          C2 := CombineReg(PColor32(NativeUInt(SrcP) - 4)^, SrcP[0], FracX xor $FF)

          {$ELSE}

          C2 := CombineReg(PColor32(Integer(SrcP) - 4)^, SrcP[0], FracX xor $FF)

          {$ENDIF}

        else

          C2 := SrcP[0];

        BlendMemEx(CombineReg(C1, C2, FracY), DstP^, LW * BW * MA shr 16)

      end

      else

        BlendMemEx(C1, DstP^, LW * BW * MA shr 16);



      Inc(DstP);

      BlendLineEx(@Buf1[0], DstP, SrcRectW - 1, BW * MA shr 8);

      Inc(DstP, SrcRectW - 1);



      if SrcRect.Bottom < Src.Height then

      begin

        if SrcRect.Right < SrcW then

          C4 := CombineReg(SrcP[SrcRectW - 1], SrcP[SrcRectW], FracX)

        else

          C4 := SrcP[SrcRectW - 1];

        BlendMemEx(CombineReg(C3, C4, FracY), DstP^, RW * BW * MA shr 16);

      end

      else

        BlendMemEx(C3, DstP^, RW * BW * MA shr 16);



    finally

      EMMS;

      Buffer[0] := nil;

      Buffer[1] := nil;

    end;

  end;



  Dst.Changed(MakeRect(DstX, DstY, DstX + SrcRectW + 1, DstY + SrcRectH + 1));

end;

{$WARNINGS ON}



procedure BlendTransfer(

  Dst: TCustomBitmap32; DstX, DstY: Integer; DstClip: TRect;

  SrcF: TCustomBitmap32; SrcRectF: TRect;

  SrcB: TCustomBitmap32; SrcRectB: TRect;

  BlendCallback: TBlendReg);

var

  I, J, SrcFX, SrcFY, SrcBX, SrcBY: Integer;

  PSrcF, PSrcB, PDst: PColor32Array;

begin

  if not Assigned(Dst) then raise EBitmapException.Create(SDstNil);

  if not Assigned(SrcF) then raise EBitmapException.Create(SSrcNil);

  if not Assigned(SrcB) then raise EBitmapException.Create(SSrcNil);



  if Dst.Empty or SrcF.Empty or SrcB.Empty or not Assigned(BlendCallback) then Exit;



  if not Dst.MeasuringMode then

  begin

    SrcFX := SrcRectF.Left - DstX;

    SrcFY := SrcRectF.Top - DstY;

    SrcBX := SrcRectB.Left - DstX;

    SrcBY := SrcRectB.Top - DstY;



    GR32.IntersectRect(DstClip, DstClip, Dst.BoundsRect);

    GR32.IntersectRect(SrcRectF, SrcRectF, SrcF.BoundsRect);

    GR32.IntersectRect(SrcRectB, SrcRectB, SrcB.BoundsRect);



    GR32.OffsetRect(SrcRectF, -SrcFX, -SrcFY);

    GR32.OffsetRect(SrcRectB, -SrcBX, -SrcFY);



    GR32.IntersectRect(DstClip, DstClip, SrcRectF);

    GR32.IntersectRect(DstClip, DstClip, SrcRectB);



    if not GR32.IsRectEmpty(DstClip) then

    try

      for I := DstClip.Top to DstClip.Bottom - 1 do

      begin

        PSrcF := PColor32Array(SrcF.PixelPtr[SrcFX, SrcFY + I]);

        PSrcB := PColor32Array(SrcB.PixelPtr[SrcBX, SrcBY + I]);

        PDst := Dst.ScanLine[I];

        for J := DstClip.Left to DstClip.Right - 1 do

          PDst[J] := BlendCallback(PSrcF[J], PSrcB[J]);

      end;

    finally

      EMMS;

    end;

  end;

  Dst.Changed(DstClip);

end;



procedure BlendTransfer(

  Dst: TCustomBitmap32; DstX, DstY: Integer; DstClip: TRect;

  SrcF: TCustomBitmap32; SrcRectF: TRect;

  SrcB: TCustomBitmap32; SrcRectB: TRect;

  BlendCallback: TBlendRegEx; MasterAlpha: Integer);

var

  I, J, SrcFX, SrcFY, SrcBX, SrcBY: Integer;

  PSrcF, PSrcB, PDst: PColor32Array;

begin

  if not Assigned(Dst) then raise EBitmapException.Create(SDstNil);

  if not Assigned(SrcF) then raise EBitmapException.Create(SSrcNil);

  if not Assigned(SrcB) then raise EBitmapException.Create(SSrcNil);



  if Dst.Empty or SrcF.Empty or SrcB.Empty or not Assigned(BlendCallback) then Exit;



  if not Dst.MeasuringMode then

  begin

    SrcFX := SrcRectF.Left - DstX;

    SrcFY := SrcRectF.Top - DstY;

    SrcBX := SrcRectB.Left - DstX;

    SrcBY := SrcRectB.Top - DstY;



    GR32.IntersectRect(DstClip, DstClip, Dst.BoundsRect);

    GR32.IntersectRect(SrcRectF, SrcRectF, SrcF.BoundsRect);

    GR32.IntersectRect(SrcRectB, SrcRectB, SrcB.BoundsRect);



    GR32.OffsetRect(SrcRectF, -SrcFX, -SrcFY);

    GR32.OffsetRect(SrcRectB, -SrcBX, -SrcFY);



    GR32.IntersectRect(DstClip, DstClip, SrcRectF);

    GR32.IntersectRect(DstClip, DstClip, SrcRectB);



    if not GR32.IsRectEmpty(DstClip) then

    try

      for I := DstClip.Top to DstClip.Bottom - 1 do

      begin

        PSrcF := PColor32Array(SrcF.PixelPtr[SrcFX, SrcFY + I]);

        PSrcB := PColor32Array(SrcB.PixelPtr[SrcBX, SrcBY + I]);

        PDst := Dst.ScanLine[I];

        for J := DstClip.Left to DstClip.Right - 1 do

          PDst[J] := BlendCallback(PSrcF[J], PSrcB[J], MasterAlpha);

      end;

    finally

      EMMS;

    end;

  end;

  Dst.Changed(DstClip);

end;



procedure StretchNearest(

  Dst: TCustomBitmap32; DstRect, DstClip: TRect;

  SrcBits: PColor32Array; SrcWidth, SrcHeight: Integer; SrcRect: TRect;

  OuterColor: TColor32;

  CombineOp: TDrawMode;

  CombineMode: TCombineMode;

  MasterAlpha: Cardinal;

  CombineCallBack: TPixelCombineEvent);

var

  R: TRect;

  SrcW, SrcH, DstW, DstH, DstClipW, DstClipH: Integer;

  SrcY, OldSrcY: Integer;

  I, J: Integer;

  MapHorz: PIntegerArray;

  SrcLine, DstLine: PColor32Array;

  Buffer: TArrayOfColor32;

  Scale: TFloat;

  BlendLine: TBlendLine;

  BlendLineEx: TBlendLineEx;

  DstLinePtr, MapPtr: PColor32;

begin

  GR32.IntersectRect(DstClip, DstClip, MakeRect(0, 0, Dst.Width, Dst.Height));

  GR32.IntersectRect(DstClip, DstClip, DstRect);

  if GR32.IsRectEmpty(DstClip) then Exit;

  GR32.IntersectRect(R, DstClip, DstRect);

  if GR32.IsRectEmpty(R) then Exit;

  if (SrcRect.Left < 0) or (SrcRect.Top < 0) or (SrcRect.Right > SrcWidth) or

    (SrcRect.Bottom > SrcHeight) then

    raise Exception.Create(RCStrInvalidSrcRect);



  SrcW := SrcRect.Right - SrcRect.Left;

  SrcH := SrcRect.Bottom - SrcRect.Top;

  DstW := DstRect.Right - DstRect.Left;

  DstH := DstRect.Bottom - DstRect.Top;

  DstClipW := DstClip.Right - DstClip.Left;

  DstClipH := DstClip.Bottom - DstClip.Top;

  try

    if (SrcW = DstW) and (SrcH = DstH) then

    begin

      { Copy without resampling }

      BlendBlock(Dst, DstClip, SrcBits, SrcWidth, SrcHeight,

        SrcRect.Left + DstClip.Left - DstRect.Left,

        SrcRect.Top + DstClip.Top - DstRect.Top, OuterColor, CombineOp, CombineMode,

        MasterAlpha, CombineCallBack);

    end

    else

    begin

      GetMem(MapHorz, DstClipW * SizeOf(Integer));

      try

        if DstW > 1 then

        begin

          if FullEdge then

          begin

            Scale := SrcW / DstW;

            for I := 0 to DstClipW - 1 do

              MapHorz^[I] := Trunc(SrcRect.Left + (I + DstClip.Left - DstRect.Left) * Scale);

          end

          else

          begin

            Scale := (SrcW - 1) / (DstW - 1);

            for I := 0 to DstClipW - 1 do

              MapHorz^[I] := Round(SrcRect.Left + (I + DstClip.Left - DstRect.Left) * Scale);

          end;

        

          Assert(MapHorz^[0] >= SrcRect.Left);

          Assert(MapHorz^[DstClipW - 1] < SrcRect.Right);

        end

        else

          MapHorz^[0] := (SrcRect.Left + SrcRect.Right - 1) div 2;



        if DstH <= 1 then Scale := 0

        else if FullEdge then Scale := SrcH / DstH

        else Scale := (SrcH - 1) / (DstH - 1);



        if CombineOp = dmOpaque then

        begin

          DstLine := PColor32Array(Dst.PixelPtr[DstClip.Left, DstClip.Top]);

          OldSrcY := -1;

        

          for J := 0 to DstClipH - 1 do

          begin

            if DstH <= 1 then

              SrcY := (SrcRect.Top + SrcRect.Bottom - 1) div 2

            else if FullEdge then

              SrcY := Trunc(SrcRect.Top + (J + DstClip.Top - DstRect.Top) * Scale)

            else

              SrcY := Round(SrcRect.Top + (J + DstClip.Top - DstRect.Top) * Scale);

            

            if SrcY <> OldSrcY then

            begin

              SrcLine := @SrcBits[SrcY * SrcWidth];

              DstLinePtr := @DstLine[0];

              MapPtr := @MapHorz^[0];

              for I := 0 to DstClipW - 1 do

              begin

                DstLinePtr^ := SrcLine[MapPtr^];

                Inc(DstLinePtr);

                Inc(MapPtr);

              end;

              OldSrcY := SrcY;

            end

            else

              MoveLongWord(DstLine[-Dst.Width], DstLine[0], DstClipW);

            Inc(DstLine, Dst.Width);

          end;

        end

        else

        begin

          SetLength(Buffer, DstClipW);

          DstLine := PColor32Array(Dst.PixelPtr[DstClip.Left, DstClip.Top]);

          OldSrcY := -1;



          if MasterAlpha >= 255 then

          begin

            BlendLine := BLEND_LINE[CombineMode]^;

            BlendLineEx := nil; // stop compiler warnings...

          end

          else

          begin

            BlendLineEx := BLEND_LINE_EX[CombineMode]^;

            BlendLine := nil; // stop compiler warnings...

          end;



          for J := 0 to DstClipH - 1 do

          begin

            if DstH > 1 then

            begin

              EMMS;

              if FullEdge then

                SrcY := Trunc(SrcRect.Top + (J + DstClip.Top - DstRect.Top) * Scale)

              else

                SrcY := Round(SrcRect.Top + (J + DstClip.Top - DstRect.Top) * Scale);

            end

            else

              SrcY := (SrcRect.Top + SrcRect.Bottom - 1) div 2;

            

            if SrcY <> OldSrcY then

            begin

              SrcLine := @SrcBits[SrcY * SrcWidth];

              DstLinePtr := @Buffer[0];

              MapPtr := @MapHorz^[0];

              for I := 0 to DstClipW - 1 do

              begin

                DstLinePtr^ := SrcLine[MapPtr^];

                Inc(DstLinePtr);

                Inc(MapPtr);

              end;

              OldSrcY := SrcY;

            end;



            case CombineOp of

              dmBlend:

                if MasterAlpha >= 255 then

                  BlendLine(@Buffer[0], @DstLine[0], DstClipW)

                else

                  BlendLineEx(@Buffer[0], @DstLine[0], DstClipW, MasterAlpha);

              dmTransparent:

                for I := 0 to DstClipW - 1 do

                  if Buffer[I] <> OuterColor then DstLine[I] := Buffer[I];

              dmCustom:

                for I := 0 to DstClipW - 1 do

                  CombineCallBack(Buffer[I], DstLine[I], MasterAlpha);

            end;



            Inc(DstLine, Dst.Width);

          end;

        end;

      finally

        FreeMem(MapHorz);

      end;

    end;

  finally

    EMMS;

  end;

end;



procedure StretchHorzStretchVertLinear(

  Dst: TCustomBitmap32; DstRect, DstClip: TRect;

  SrcBits: PColor32Array; SrcWidth, SrcHeight: Integer; SrcRect: TRect;

  OuterColor: TColor32;

  CombineOp: TDrawMode;

  CombineMode: TCombineMode;

  MasterAlpha: Cardinal;

  CombineCallBack: TPixelCombineEvent);

//Assure DstRect is >= SrcRect, otherwise quality loss will occur

var

  SrcW, SrcH, DstW, DstH, DstClipW, DstClipH: Integer;

  MapHorz, MapVert: array of TPointRec;

  t2, Scale: TFloat;

  SrcLine, DstLine: PColor32Array;

  SrcIndex: Integer;

  SrcPtr1, SrcPtr2: PColor32;

  I, J: Integer;

  WY: Cardinal;

  C: TColor32;

  BlendMemEx: TBlendMemEx;

begin

  SrcW := SrcRect.Right - SrcRect.Left;

  SrcH := SrcRect.Bottom - SrcRect.Top;

  DstW :…