/Graphics32/Source/GR32_Resamplers.pas
Pascal | 4347 lines | 3634 code | 511 blank | 202 comment | 318 complexity | c51200a529e561a4069e13900c2f3c40 MD5 | raw file
Possible License(s): GPL-3.0
- 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 := DstRect.Right - DstRect.Left;
- DstH := DstRect.Bottom - DstRect.Top;
- DstClipW := DstClip.Right - DstClip.Left;
- DstClipH := DstClip.Bottom - DstClip.Top;
-
- SetLength(MapHorz, DstClipW);
- if FullEdge then Scale := SrcW / DstW
- else Scale := (SrcW - 1) / (DstW - 1);
- for I := 0 to DstClipW - 1 do
- begin
- if FullEdge then t2 := SrcRect.Left - 0.5 + (I + DstClip.Left - DstRect.Left + 0.5) * Scale
- else t2 := SrcRect.Left + (I + DstClip.Left - DstRect.Left) * Scale;
- if t2 < 0 then t2 := 0
- else if t2 > SrcWidth - 1 then t2 := SrcWidth - 1;
- MapHorz[I].Pos := Floor(t2);
- MapHorz[I].Weight := 256 - Round(Frac(t2) * 256);
- //Pre-pack weights to reduce MMX Reg. setups per pixel:
- //MapHorz[I].Weight:= MapHorz[I].Weight shl 16 + MapHorz[I].Weight;
- end;
- I := DstClipW - 1;
- while MapHorz[I].Pos = SrcRect.Right - 1 do
- begin
- Dec(MapHorz[I].Pos);
- MapHorz[I].Weight := 0;
- Dec(I);
- end;
-
- SetLength(MapVert, DstClipH);
- if FullEdge then Scale := SrcH / DstH
- else Scale := (SrcH - 1) / (DstH - 1);
- for I := 0 to DstClipH - 1 do
- begin
- if FullEdge then t2 := SrcRect.Top - 0.5 + (I + DstClip.Top - DstRect.Top + 0.5) * Scale
- else t2 := SrcRect.Top + (I + DstClip.Top - DstRect.Top) * Scale;
- if t2 < 0 then t2 := 0
- else if t2 > SrcHeight - 1 then t2 := SrcHeight - 1;
- MapVert[I].Pos := Floor(t2);
- MapVert[I].Weight := 256 - Round(Frac(t2) * 256);
- //Pre-pack weights to reduce MMX Reg. setups per pixel:
- //MapVert[I].Weight := MapVert[I].Weight shl 16 + MapVert[I].Weight;
- end;
- I := DstClipH - 1;
- while MapVert[I].Pos = SrcRect.Bottom - 1 do
- begin
- Dec(MapVert[I].Pos);
- MapVert[I].Weight := 0;
- Dec(I);
- end;
-
- DstLine := PColor32Array(Dst.PixelPtr[DstClip.Left, DstClip.Top]);
- SrcW := SrcWidth;
- DstW := Dst.Width;
- case CombineOp of
- dmOpaque:
- for J := 0 to DstClipH - 1 do
- begin
- SrcLine := @SrcBits[MapVert[J].Pos * SrcWidth];
- WY := MapVert[J].Weight;
-
- SrcIndex := MapHorz[0].Pos;
- SrcPtr1 := @SrcLine[SrcIndex];
- SrcPtr2 := @SrcLine[SrcIndex + SrcW];
- for I := 0 to DstClipW - 1 do
- begin
- if SrcIndex <> MapHorz[I].Pos then
- begin
- SrcIndex := MapHorz[I].Pos;
- SrcPtr1 := @SrcLine[SrcIndex];
- SrcPtr2 := @SrcLine[SrcIndex + SrcW];
- end;
- DstLine[I] := Interpolator(MapHorz[I].Weight, WY, SrcPtr1, SrcPtr2);
- end;
- Inc(DstLine, DstW);
- end;
- dmBlend:
- begin
- BlendMemEx := BLEND_MEM_EX[CombineMode]^;
- for J := 0 to DstClipH - 1 do
- begin
- SrcLine := @SrcBits[MapVert[J].Pos * SrcWidth];
- WY := MapVert[J].Weight;
- SrcIndex := MapHorz[0].Pos;
- SrcPtr1 := @SrcLine[SrcIndex];
- SrcPtr2 := @SrcLine[SrcIndex + SrcW];
- for I := 0 to DstClipW - 1 do
- begin
- if SrcIndex <> MapHorz[I].Pos then
- begin
- SrcIndex := MapHorz[I].Pos;
- SrcPtr1 := @SrcLine[SrcIndex];
- SrcPtr2 := @SrcLine[SrcIndex + SrcW];
- end;
- C := Interpolator(MapHorz[I].Weight, WY, SrcPtr1, SrcPtr2);
- BlendMemEx(C, DstLine[I], MasterAlpha)
- end;
- Inc(DstLine, Dst.Width);
- end
- end;
- dmTransparent:
- begin
- for J := 0 to DstClipH - 1 do
- begin
- SrcLine := @SrcBits[MapVert[J].Pos * SrcWidth];
- WY := MapVert[J].Weight;
- SrcIndex := MapHorz[0].Pos;
- SrcPtr1 := @SrcLine[SrcIndex];
- SrcPtr2 := @SrcLine[SrcIndex + SrcW];
- for I := 0 to DstClipW - 1 do
- begin
- if SrcIndex <> MapHorz[I].Pos then
- begin
- SrcIndex := MapHorz[I].Pos;
- SrcPtr1 := @SrcLine[SrcIndex];
- SrcPtr2 := @SrcLine[SrcIndex + SrcW];
- end;
- C := Interpolator(MapHorz[I].Weight, WY, SrcPtr1, SrcPtr2);
- if C <> OuterColor then DstLine[I] := C;
- end;
- Inc(DstLine, Dst.Width);
- end
- end;
- else // cmCustom
- for J := 0 to DstClipH - 1 do
- begin
- SrcLine := @SrcBits[MapVert[J].Pos * SrcWidth];
- WY := MapVert[J].Weight;
- SrcIndex := MapHorz[0].Pos;
- SrcPtr1 := @SrcLine[SrcIndex];
- SrcPtr2 := @SrcLine[SrcIndex + SrcW];
- for I := 0 to DstClipW - 1 do
- begin
- if SrcIndex <> MapHorz[I].Pos then
- begin
- SrcIndex := MapHorz[I].Pos;
- SrcPtr1 := @SrcLine[SrcIndex];
- SrcPtr2 := @SrcLine[SrcIndex + SrcW];
- end;
- C := Interpolator(MapHorz[I].Weight, WY, SrcPtr1, SrcPtr2);
- CombineCallBack(C, DstLine[I], MasterAlpha);
- end;
- Inc(DstLine, Dst.Width);
- end;
- end;
- EMMS;
- end;
-
- function BuildMappingTable(
- DstLo, DstHi: Integer;
- ClipLo, ClipHi: Integer;
- SrcLo, SrcHi: Integer;
- Kernel: TCustomKernel): TMappingTable;
- var
- SrcW, DstW, ClipW: Integer;
- Filter: TFilterMethod;
- FilterWidth: TFloat;
- Scale, OldScale: TFloat;
- Center: TFloat;
- Count: Integer;
- Left, Right: Integer;
- I, J, K: Integer;
- Weight: Integer;
- begin
- SrcW := SrcHi - SrcLo;
- DstW := DstHi - DstLo;
- ClipW := ClipHi - ClipLo;
- if SrcW = 0 then
- begin
- Result := nil;
- Exit;
- end
- else if SrcW = 1 then
- begin
- SetLength(Result, ClipW);
- for I := 0 to ClipW - 1 do
- begin
- SetLength(Result[I], 1);
- Result[I][0].Pos := SrcLo;
- Result[I][0].Weight := 256;
- end;
- Exit;
- end;
- SetLength(Result, ClipW);
- if ClipW = 0 then Exit;
-
- if FullEdge then Scale := DstW / SrcW
- else Scale := (DstW - 1) / (SrcW - 1);
-
- Filter := Kernel.Filter;
- FilterWidth := Kernel.GetWidth;
- K := 0;
-
- if Scale = 0 then
- begin
- Assert(Length(Result) = 1);
- SetLength(Result[0], 1);
- Result[0][0].Pos := (SrcLo + SrcHi) div 2;
- Result[0][0].Weight := 256;
- end
- else if Scale < 1 then
- begin
- OldScale := Scale;
- Scale := 1 / Scale;
- FilterWidth := FilterWidth * Scale;
- for I := 0 to ClipW - 1 do
- begin
- if FullEdge then
- Center := SrcLo - 0.5 + (I - DstLo + ClipLo + 0.5) * Scale
- else
- Center := SrcLo + (I - DstLo + ClipLo) * Scale;
- Left := Floor(Center - FilterWidth);
- Right := Ceil(Center + FilterWidth);
- Count := -256;
- for J := Left to Right do
- begin
- Weight := Round(256 * Filter((Center - J) * OldScale) * OldScale);
- if Weight <> 0 then
- begin
- Inc(Count, Weight);
- K := Length(Result[I]);
- SetLength(Result[I], K + 1);
- Result[I][K].Pos := Constrain(J, SrcLo, SrcHi - 1);
- Result[I][K].Weight := Weight;
- end;
- end;
- if Length(Result[I]) = 0 then
- begin
- SetLength(Result[I], 1);
- Result[I][0].Pos := Floor(Center);
- Result[I][0].Weight := 256;
- end
- else if Count <> 0 then
- Dec(Result[I][K div 2].Weight, Count);
- end;
- end
- else // scale > 1
- begin
- Scale := 1 / Scale;
- for I := 0 to ClipW - 1 do
- begin
- if FullEdge then
- Center := SrcLo - 0.5 + (I - DstLo + ClipLo + 0.5) * Scale
- else
- Center := SrcLo + (I - DstLo + ClipLo) * Scale;
- Left := Floor(Center - FilterWidth);
- Right := Ceil(Center + FilterWidth);
- Count := -256;
- for J := Left to Right do
- begin
- Weight := Round(256 * Filter(Center - j));
- if Weight <> 0 then
- begin
- Inc(Count, Weight);
- K := Length(Result[I]);
- SetLength(Result[I], k + 1);
- Result[I][K].Pos := Constrain(j, SrcLo, SrcHi - 1);
- Result[I][K].Weight := Weight;
- end;
- end;
- if Count <> 0 then
- Dec(Result[I][K div 2].Weight, Count);
- end;
- end;
- end;
-
- {$WARNINGS OFF}
- procedure Resample(
- Dst: TCustomBitmap32; DstRect: TRect; DstClip: TRect;
- SrcBits: PColor32Array; SrcWidth, SrcHeight: Integer; SrcRect: TRect;
- Kernel: TCustomKernel;
- OuterColor: TColor32;
- CombineOp: TDrawMode;
- CombineMode: TCombineMode;
- MasterAlpha: Cardinal;
- CombineCallBack: TPixelCombineEvent);
- var
- DstClipW: Integer;
- MapX, MapY: TMappingTable;
- I, J, X, Y: Integer;
- MapXLoPos, MapXHiPos: Integer;
- HorzBuffer: array of TBufferEntry;
- ClusterX, ClusterY: TCluster;
- Wt, Cr, Cg, Cb, Ca: Integer;
- C: Cardinal;
- ClustYW: Integer;
- DstLine: PColor32Array;
- RangeCheck: Boolean;
- BlendMemEx: TBlendMemEx;
- begin
- if (CombineOp = dmCustom) and not Assigned(CombineCallBack) then
- CombineOp := dmOpaque;
-
- { check source and destination }
- if (CombineOp = dmBlend) and (MasterAlpha = 0) then Exit;
-
- BlendMemEx := BLEND_MEM_EX[CombineMode]^; // store in local variable
-
- DstClipW := DstClip.Right - DstClip.Left;
-
- // mapping tables
- MapX := BuildMappingTable(DstRect.Left, DstRect.Right, DstClip.Left, DstClip.Right, SrcRect.Left, SrcRect.Right, Kernel);
- MapY := BuildMappingTable(DstRect.Top, DstRect.Bottom, DstClip.Top, DstClip.Bottom, SrcRect.Top, SrcRect.Bottom, Kernel);
- ClusterX := nil;
- ClusterY := nil;
- try
- RangeCheck := Kernel.RangeCheck; //StretchFilter in [sfLanczos, sfMitchell];
- if (MapX = nil) or (MapY = nil) then Exit;
-
- MapXLoPos := MapX[0][0].Pos;
- MapXHiPos := MapX[DstClipW - 1][High(MapX[DstClipW - 1])].Pos;
- SetLength(HorzBuffer, MapXHiPos - MapXLoPos + 1);
-
- { transfer pixels }
- for J := DstClip.Top to DstClip.Bottom - 1 do
- begin
- ClusterY := MapY[J - DstClip.Top];
- for X := MapXLoPos to MapXHiPos do
- begin
- Ca := 0; Cr := 0; Cg := 0; Cb := 0;
- for Y := 0 to Length(ClusterY) - 1 do
- begin
- C := SrcBits[X + ClusterY[Y].Pos * SrcWidth];
- ClustYW := ClusterY[Y].Weight;
- Inc(Ca, C shr 24 * ClustYW);
- Inc(Cr, (C and $00FF0000) shr 16 * ClustYW);
- Inc(Cg, (C and $0000FF00) shr 8 * ClustYW);
- Inc(Cb, (C and $000000FF) * ClustYW);
- end;
- with HorzBuffer[X - MapXLoPos] do
- begin
- R := Cr;
- G := Cg;
- B := Cb;
- A := Ca;
- end;
- end;
-
- DstLine := Dst.ScanLine[J];
- for I := DstClip.Left to DstClip.Right - 1 do
- begin
- ClusterX := MapX[I - DstClip.Left];
- Ca := 0; Cr := 0; Cg := 0; Cb := 0;
- for X := 0 to Length(ClusterX) - 1 do
- begin
- Wt := ClusterX[X].Weight;
- with HorzBuffer[ClusterX[X].Pos - MapXLoPos] do
- begin
- Inc(Ca, A * Wt);
- Inc(Cr, R * Wt);
- Inc(Cg, G * Wt);
- Inc(Cb, B * Wt);
- end;
- end;
-
- if RangeCheck then
- begin
- if Ca > $FF0000 then Ca := $FF0000
- else if Ca < 0 then Ca := 0
- else Ca := Ca and $00FF0000;
-
- if Cr > $FF0000 then Cr := $FF0000
- else if Cr < 0 then Cr := 0
- else Cr := Cr and $00FF0000;
-
- if Cg > $FF0000 then Cg := $FF0000
- else if Cg < 0 then Cg := 0
- else Cg := Cg and $00FF0000;
-
- if Cb > $FF0000 then Cb := $FF0000
- else if Cb < 0 then Cb := 0
- else Cb := Cb and $00FF0000;
-
- C := (Ca shl 8) or Cr or (Cg shr 8) or (Cb shr 16);
- end
- else
- C := ((Ca and $00FF0000) shl 8) or (Cr and $00FF0000) or ((Cg and $00FF0000) shr 8) or ((Cb and $00FF0000) shr 16);
-
- // combine it with the background
- case CombineOp of
- dmOpaque: DstLine[I] := C;
- dmBlend: BlendMemEx(C, DstLine[I], MasterAlpha);
- dmTransparent: if C <> OuterColor then DstLine[I] := C;
- dmCustom: CombineCallBack(C, DstLine[I], MasterAlpha);
- end;
- end;
- end;
- finally
- EMMS;
- MapX := nil;
- MapY := nil;
- end;
- end;
- {$WARNINGS ON}
-
- { Draft Resample Routines }
-
- function BlockAverage_Pas(Dlx, Dly: Cardinal; RowSrc: PColor32; OffSrc: Cardinal): TColor32;
- var
- C: PColor32Entry;
- ix, iy, iA, iR, iG, iB, Area: Cardinal;
- begin
- iR := 0; iB := iR; iG := iR; iA := iR;
- for iy := 1 to Dly do
- begin
- C := PColor32Entry(RowSrc);
- for ix := 1 to Dlx do
- begin
- Inc(iB, C.B);
- Inc(iG, C.G);
- Inc(iR, C.R);
- Inc(iA, C.A);
- Inc(C);
- end;
- {$IFDEF HAS_NATIVEINT}
- Inc(NativeUInt(RowSrc), OffSrc);
- {$ELSE}
- Inc(Cardinal(RowSrc), OffSrc);
- {$ENDIF}
- end;
-
- Area := Dlx * Dly;
- Area := $1000000 div Area;
- Result := iA * Area and $FF000000 or
- iR * Area shr 8 and $FF0000 or
- iG * Area shr 16 and $FF00 or
- iB * Area shr 24 and $FF;
- end;
-
- {$IFNDEF PUREPASCAL}
- function BlockAverage_MMX(Dlx, Dly: Cardinal; RowSrc: PColor32; OffSrc: Cardinal): TColor32;
- asm
- {$IFDEF TARGET_X64}
- MOV R10D,ECX
- MOV R11D,EDX
-
- SHL R10,$02
- SUB R9,R10
-
- PXOR MM1,MM1
- PXOR MM2,MM2
- PXOR MM7,MM7
-
- @@LoopY:
- MOV R10,RCX
- PXOR MM0,MM0
- LEA R8,[R8+R10*4]
- NEG R10
- @@LoopX:
- MOVD MM6,[R8+R10*4]
- PUNPCKLBW MM6,MM7
- PADDW MM0,MM6
- INC R10
- JNZ @@LoopX
-
- MOVQ MM6,MM0
- PUNPCKLWD MM6,MM7
- PADDD MM1,MM6
- MOVQ MM6,MM0
- PUNPCKHWD MM6,MM7
- PADDD MM2,MM6
- ADD R8,R9
- DEC EDX
- JNZ @@LoopY
-
- MOV EAX, ECX
- MUL R11D
- MOV ECX,EAX
- MOV EAX,$01000000
- DIV ECX
- MOV ECX,EAX
-
- MOVD EAX,MM1
- MUL ECX
- SHR EAX,$18
- MOV R11D,EAX
-
- PSRLQ MM1,$20
- MOVD EAX,MM1
- MUL ECX
- SHR EAX,$10
- AND EAX,$0000FF00
- ADD R11D,EAX
-
- MOVD EAX,MM2
- MUL ECX
- SHR EAX,$08
- AND EAX,$00FF0000
- ADD R11D,EAX
-
- PSRLQ MM2,$20
- MOVD EAX,MM2
- MUL ECX
- AND EAX,$FF000000
- ADD EAX,R11D
- {$ELSE}
- PUSH EBX
- PUSH ESI
- PUSH EDI
-
- MOV EBX,OffSrc
- MOV ESI,EAX
- MOV EDI,EDX
-
- SHL ESI,$02
- SUB EBX,ESI
-
- PXOR MM1,MM1
- PXOR MM2,MM2
- PXOR MM7,MM7
-
- @@LoopY:
- MOV ESI,EAX
- PXOR MM0,MM0
- LEA ECX,[ECX+ESI*4]
- NEG ESI
- @@LoopX:
- MOVD MM6,[ECX+ESI*4]
- PUNPCKLBW MM6,MM7
- PADDW MM0,MM6
- INC ESI
- JNZ @@LoopX
-
- MOVQ MM6,MM0
- PUNPCKLWD MM6,MM7
- PADDD MM1,MM6
- MOVQ MM6,MM0
- PUNPCKHWD MM6,MM7
- PADDD MM2,MM6
- ADD ECX,EBX
- DEC EDX
- JNZ @@LoopY
-
- MUL EDI
- MOV ECX,EAX
- MOV EAX,$01000000
- DIV ECX
- MOV ECX,EAX
-
- MOVD EAX,MM1
- MUL ECX
- SHR EAX,$18
- MOV EDI,EAX
-
- PSRLQ MM1,$20
- MOVD EAX,MM1
- MUL ECX
- SHR EAX,$10
- AND EAX,$0000FF00
- ADD EDI,EAX
-
- MOVD EAX,MM2
- MUL ECX
- SHR EAX,$08
- AND EAX,$00FF0000
- ADD EDI,EAX
-
- PSRLQ MM2,$20
- MOVD EAX,MM2
- MUL ECX
- AND EAX,$FF000000
- ADD EAX,EDI
-
- POP EDI
- POP ESI
- POP EBX
- {$ENDIF}
- end;
-
- {$IFDEF USE_3DNOW}
- function BlockAverage_3DNow(Dlx, Dly: Cardinal; RowSrc: PColor32; OffSrc: Cardinal): TColor32;
- asm
- PUSH EBX
- PUSH ESI
- PUSH EDI
-
- MOV EBX,OffSrc
- MOV ESI,EAX
- MOV EDI,EDX
-
- SHL ESI,$02
- SUB EBX,ESI
-
- PXOR MM1,MM1
- PXOR MM2,MM2
- PXOR MM7,MM7
-
- @@LoopY:
- MOV ESI,EAX
- PXOR MM0,MM0
- LEA ECX,[ECX+ESI*4]
- NEG ESI
- db $0F,$0D,$84,$B1,$00,$02,$00,$00 // PREFETCH [ECX + ESI * 4 + 512]
- @@LoopX:
- MOVD MM6,[ECX + ESI * 4]
- PUNPCKLBW MM6,MM7
- PADDW MM0,MM6
- INC ESI
-
- JNZ @@LoopX
-
- MOVQ MM6,MM0
- PUNPCKLWD MM6,MM7
- PADDD MM1,MM6
- MOVQ MM6,MM0
- PUNPCKHWD MM6,MM7
- PADDD MM2,MM6
- ADD ECX,EBX
- DEC EDX
-
- JNZ @@LoopY
-
- MUL EDI
- MOV ECX,EAX
- MOV EAX,$01000000
- div ECX
- MOV ECX,EAX
-
- MOVD EAX,MM1
- MUL ECX
- SHR EAX,$18
- MOV EDI,EAX
-
- PSRLQ MM1,$20
- MOVD EAX,MM1
- MUL ECX
- SHR EAX,$10
- AND EAX,$0000FF00
- ADD EDI,EAX
-
- MOVD EAX,MM2
- MUL ECX
- SHR EAX,$08
- AND EAX,$00FF0000
- ADD EDI,EAX
-
- PSRLQ MM2,$20
- MOVD EAX,MM2
- MUL ECX
- AND EAX,$FF000000
- ADD EAX,EDI
-
- POP EDI
- POP ESI
- POP EBX
- end;
- {$ENDIF}
-
- function BlockAverage_SSE2(Dlx, Dly: Cardinal; RowSrc: PColor32; OffSrc: Cardinal): TColor32;
- asm
- {$IFDEF TARGET_X64}
- MOV EAX,ECX
- MOV R10D,EDX
-
- SHL EAX,$02
- SUB R9D,EAX
-
- PXOR XMM1,XMM1
- PXOR XMM2,XMM2
- PXOR XMM7,XMM7
-
- @@LoopY:
- MOV EAX,ECX
- PXOR XMM0,XMM0
- LEA R8,[R8+RAX*4]
- NEG RAX
- @@LoopX:
- MOVD XMM6,[R8+RAX*4]
- PUNPCKLBW XMM6,XMM7
- PADDW XMM0,XMM6
- INC RAX
- JNZ @@LoopX
-
- MOVQ XMM6,XMM0
- PUNPCKLWD XMM6,XMM7
- PADDD XMM1,XMM6
- ADD R8,R9
- DEC EDX
- JNZ @@LoopY
-
- MOV EAX, ECX
- MUL R10D
- MOV ECX,EAX
- MOV EAX,$01000000
- DIV ECX
- MOV ECX,EAX
-
- MOVD EAX,XMM1
- MUL ECX
- SHR EAX,$18
- MOV R10D,EAX
-
- SHUFPS XMM1,XMM1,$39
- MOVD EAX,XMM1
- MUL ECX
- SHR EAX,$10
- AND EAX,$0000FF00
- ADD R10D,EAX
-
- PSHUFD XMM1,XMM1,$39
- MOVD EAX,XMM1
- MUL ECX
- SHR EAX,$08
- AND EAX,$00FF0000
- ADD R10D,EAX
-
- PSHUFD XMM1,XMM1,$39
- MOVD EAX,XMM1
- MUL ECX
- AND EAX,$FF000000
- ADD EAX,R10D
- {$ELSE}
- PUSH EBX
- PUSH ESI
- PUSH EDI
-
- MOV EBX,OffSrc
- MOV ESI,EAX
- MOV EDI,EDX
-
- SHL ESI,$02
- SUB EBX,ESI
-
- PXOR XMM1,XMM1
- PXOR XMM2,XMM2
- PXOR XMM7,XMM7
-
- @@LoopY:
- MOV ESI,EAX
- PXOR XMM0,XMM0
- LEA ECX,[ECX+ESI*4]
- NEG ESI
- @@LoopX:
- MOVD XMM6,[ECX+ESI*4]
- PUNPCKLBW XMM6,XMM7
- PADDW XMM0,XMM6
- INC ESI
- JNZ @@LoopX
-
- MOVQ XMM6,XMM0
- PUNPCKLWD XMM6,XMM7
- PADDD XMM1,XMM6
- ADD ECX,EBX
- DEC EDX
- JNZ @@LoopY
-
- MUL EDI
- MOV ECX,EAX
- MOV EAX,$01000000
- DIV ECX
- MOV ECX,EAX
-
- MOVD EAX,XMM1
- MUL ECX
- SHR EAX,$18
- MOV EDI,EAX
-
- SHUFPS XMM1,XMM1,$39
- MOVD EAX,XMM1
- MUL ECX
- SHR EAX,$10
- AND EAX,$0000FF00
- ADD EDI,EAX
-
- PSHUFD XMM1,XMM1,$39
- MOVD EAX,XMM1
- MUL ECX
- SHR EAX,$08
- AND EAX,$00FF0000
- ADD EDI,EAX
-
- PSHUFD XMM1,XMM1,$39
- MOVD EAX,XMM1
- MUL ECX
- AND EAX,$FF000000
- ADD EAX,EDI
-
- POP EDI
- POP ESI
- POP EBX
- {$ENDIF}
- end;
- {$ENDIF}
-
-
- procedure DraftResample(Dst: TCustomBitmap32; DstRect: TRect; DstClip: TRect;
- SrcBits: PColor32Array; SrcWidth, SrcHeight: Integer; SrcRect: TRect;
- Kernel: TCustomKernel;
- OuterColor: TColor32;
- CombineOp: TDrawMode;
- CombineMode: TCombineMode;
- MasterAlpha: Cardinal;
- CombineCallBack: TPixelCombineEvent);
- var
- SrcW, SrcH,
- DstW, DstH,
- DstClipW, DstClipH: Cardinal;
- RowSrc: PColor32;
- xsrc: PColor32;
- OffSrc,
- dy, dx,
- c1, c2, r1, r2,
- xs: Cardinal;
- C: TColor32;
- DstLine: PColor32Array;
- ScaleFactor: TFloat;
- I,J, sc, sr, cx, cy: Integer;
- BlendMemEx: TBlendMemEx;
- begin
- { rangechecking and rect intersection done by caller }
-
- 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;
-
- BlendMemEx := BLEND_MEM_EX[CombineMode]^;
-
- if (DstW > SrcW)or(DstH > SrcH) then begin
- if (SrcW < 2) or (SrcH < 2) then
- Resample(Dst, DstRect, DstClip, SrcBits, SrcWidth, SrcHeight, SrcRect,
- Kernel, OuterColor, CombineOp, CombineMode,
- MasterAlpha, CombineCallBack)
- else
- StretchHorzStretchVertLinear(Dst, DstRect, DstClip, SrcBits, SrcWidth, SrcHeight, SrcRect, OuterColor, CombineOp,
- CombineMode, MasterAlpha, CombineCallBack);
- end
- else
- begin //Full Scaledown, ignores Fulledge - cannot be integrated into this resampling method
- OffSrc := SrcWidth * 4;
-
- ScaleFactor:= SrcW / DstW;
- cx := Trunc( (DstClip.Left - DstRect.Left) * ScaleFactor);
- r2 := Trunc(ScaleFactor);
- sr := Trunc( $10000 * ScaleFactor );
-
- ScaleFactor:= SrcH / DstH;
- cy := Trunc( (DstClip.Top - DstRect.Top) * ScaleFactor);
- c2 := Trunc(ScaleFactor);
- sc := Trunc( $10000 * ScaleFactor );
-
- DstLine := PColor32Array(Dst.PixelPtr[0, DstClip.Top]);
- RowSrc := @SrcBits[SrcRect.Left + cx + (SrcRect.Top + cy) * SrcWidth];
-
- xs := r2;
- c1 := 0;
- Dec(DstClip.Left, 2);
- Inc(DstClipW);
- Inc(DstClipH);
-
- for J := 2 to DstClipH do
- begin
- dy := c2 - c1;
- c1 := c2;
- c2 := FixedMul(J, sc);
- r1 := 0;
- r2 := xs;
- xsrc := RowSrc;
-
- case CombineOp of
- dmOpaque:
- for I := 2 to DstClipW do
- begin
- dx := r2 - r1; r1 := r2;
- r2 := FixedMul(I, sr);
- DstLine[DstClip.Left + I] := BlockAverage(dx, dy, xsrc, OffSrc);
- Inc(xsrc, dx);
- end;
- dmBlend:
- for I := 2 to DstClipW do
- begin
- dx := r2 - r1; r1 := r2;
- r2 := FixedMul(I, sr);
- BlendMemEx(BlockAverage(dx, dy, xsrc, OffSrc),
- DstLine[DstClip.Left + I], MasterAlpha);
- Inc(xsrc, dx);
- end;
- dmTransparent:
- for I := 2 to DstClipW do
- begin
- dx := r2 - r1; r1 := r2;
- r2 := FixedMul(I, sr);
- C := BlockAverage(dx, dy, xsrc, OffSrc);
- if C <> OuterColor then DstLine[DstClip.Left + I] := C;
- Inc(xsrc, dx);
- end;
- dmCustom:
- for I := 2 to DstClipW do
- begin
- dx := r2 - r1; r1 := r2;
- r2 := FixedMul(I, sr);
- CombineCallBack(BlockAverage(dx, dy, xsrc, OffSrc),
- DstLine[DstClip.Left + I], MasterAlpha);
- Inc(xsrc, dx);
- end;
- end;
-
- Inc(DstLine, Dst.Width);
- {$IFDEF HAS_NATIVEINT}
- Inc(NativeUInt(RowSrc), OffSrc * dy);
- {$ELSE}
- Inc(Cardinal(RowSrc), OffSrc * dy);
- {$ENDIF}
- end;
- end;
- EMMS;
- end;
-
- { Special interpolators (for sfLinear and sfDraft) }
-
- function Interpolator_Pas(WX_256, WY_256: Cardinal; C11, C21: PColor32): TColor32;
- var
- C1, C3: TColor32;
- begin
- if WX_256 > $FF then WX_256:= $FF;
- if WY_256 > $FF then WY_256:= $FF;
- C1 := C11^; Inc(C11);
- C3 := C21^; Inc(C21);
- Result := CombineReg(CombineReg(C1, C11^, WX_256),
- CombineReg(C3, C21^, WX_256), WY_256);
- end;
-
- {$IFNDEF PUREPASCAL}
- function Interpolator_MMX(WX_256, WY_256: Cardinal; C11, C21: PColor32): TColor32;
- asm
- {$IFDEF TARGET_X64}
- MOV RAX, RCX
- MOVQ MM1,QWORD PTR [R8]
- MOVQ MM2,MM1
- MOVQ MM3,QWORD PTR [R9]
- {$ELSE}
- MOVQ MM1,[ECX]
- MOVQ MM2,MM1
- MOV ECX,C21
- MOVQ MM3,[ECX]
- {$ENDIF}
- PSRLQ MM1,32
- MOVQ MM4,MM3
- PSRLQ MM3,32
- MOVD MM5,EAX
- PSHUFW MM5,MM5,0
- PXOR MM0,MM0
- PUNPCKLBW MM1,MM0
- PUNPCKLBW MM2,MM0
- PSUBW MM2,MM1
- PMULLW MM2,MM5
- PSLLW MM1,8
- PADDW MM2,MM1
- PSRLW MM2,8
- PUNPCKLBW MM3,MM0
- PUNPCKLBW MM4,MM0
- PSUBW MM4,MM3
- PSLLW MM3,8
- PMULLW MM4,MM5
- PADDW MM4,MM3
- PSRLW MM4,8
- MOVD MM5,EDX
- PSHUFW MM5,MM5,0
- PSUBW MM2,MM4
- PMULLW MM2,MM5
- PSLLW MM4,8
- PADDW MM2,MM4
- PSRLW MM2,8
- PACKUSWB MM2,MM0
- MOVD EAX,MM2
- end;
-
- function Interpolator_SSE2(WX_256, WY_256: Cardinal; C11, C21: PColor32): TColor32;
- asm
- {$IFDEF TARGET_X64}
- MOV RAX, RCX
- MOVQ XMM1,QWORD PTR [R8]
- MOVQ XMM2,XMM1
- MOVQ XMM3,QWORD PTR [R9]
- {$ELSE}
- MOVQ XMM1,[ECX]
- MOVQ XMM2,XMM1
- MOV ECX,C21
- MOVQ XMM3,[ECX]
- {$ENDIF}
- PSRLQ XMM1,32
- MOVQ XMM4,XMM3
- PSRLQ XMM3,32
- MOVD XMM5,EAX
- PSHUFLW XMM5,XMM5,0
- PXOR XMM0,XMM0
- PUNPCKLBW XMM1,XMM0
- PUNPCKLBW XMM2,XMM0
- PSUBW XMM2,XMM1
- PMULLW XMM2,XMM5
- PSLLW XMM1,8
- PADDW XMM2,XMM1
- PSRLW XMM2,8
- PUNPCKLBW XMM3,XMM0
- PUNPCKLBW XMM4,XMM0
- PSUBW XMM4,XMM3
- PSLLW XMM3,8
- PMULLW XMM4,XMM5
- PADDW XMM4,XMM3
- PSRLW XMM4,8
- MOVD XMM5,EDX
- PSHUFLW XMM5,XMM5,0
- PSUBW XMM2,XMM4
- PMULLW XMM2,XMM5
- PSLLW XMM4,8
- PADDW XMM2,XMM4
- PSRLW XMM2,8
- PACKUSWB XMM2,XMM0
- MOVD EAX,XMM2
- end;
- {$ENDIF}
-
- { Stretch Transfer }
-
- {$WARNINGS OFF}
- procedure StretchTransfer(
- Dst: TCustomBitmap32; DstRect: TRect; DstClip: TRect;
- Src: TCustomBitmap32; SrcRect: TRect;
- Resampler: TCustomResampler;
- CombineOp: TDrawMode;
- CombineMode: TCombineMode;
- MasterAlpha: Cardinal;
- OuterColor: TColor32;
- CombineCallBack: TPixelCombineEvent);
- begin
- CheckBitmaps(Dst, Src);
- StretchTransfer(Dst, DstRect, DstClip, Src.Bits, Src.Width, Src.Height,
- SrcRect, Resampler, CombineOp, CombineMode, MasterAlpha, OuterColor,
- CombineCallBack);
- end;
-
- procedure StretchTransfer(
- Dst: TCustomBitmap32; DstRect: TRect; DstClip: TRect;
- SrcBits: PColor32Array; SrcWidth, SrcHeight: Integer; SrcRect: TRect;
- Resampler: TCustomResampler;
- CombineOp: TDrawMode;
- CombineMode: TCombineMode;
- MasterAlpha: Cardinal;
- OuterColor: TColor32;
- CombineCallBack: TPixelCombineEvent);
- var
- SrcW, SrcH: Integer;
- DstW, DstH: Integer;
- R: TRect;
- RatioX, RatioY: Single;
- begin
- if not Assigned(Dst) then raise EBitmapException.Create(SDstNil);
-
- // transform dest rect when the src rect is out of the src bitmap's bounds
- if (SrcRect.Left < 0) or (SrcRect.Right > SrcWidth) or
- (SrcRect.Top < 0) or (SrcRect.Bottom > SrcHeight) then
- begin
- RatioX := (DstRect.Right - DstRect.Left) / (SrcRect.Right - SrcRect.Left);
- RatioY := (DstRect.Bottom - DstRect.Top) / (SrcRect.Bottom - SrcRect.Top);
-
- if SrcRect.Left < 0 then
- begin
- DstRect.Left := DstRect.Left + Ceil(-SrcRect.Left * RatioX);
- SrcRect.Left := 0;
- end;
-
- if SrcRect.Top < 0 then
- begin
- DstRect.Top := DstRect.Top + Ceil(-SrcRect.Top * RatioY);
- SrcRect.Top := 0;
- end;
-
- if SrcRect.Right > SrcWidth then
- begin
- DstRect.Right := DstRect.Right - Floor((SrcRect.Right - SrcWidth) * RatioX);
- SrcRect.Right := SrcWidth;
- end;
-
- if SrcRect.Bottom > SrcHeight then
- begin
- DstRect.Bottom := DstRect.Bottom - Floor((SrcRect.Bottom - SrcHeight) * RatioY);
- SrcRect.Bottom := SrcHeight;
- end;
- end;
-
- if not Assigned(SrcBits) or (SrcWidth <= 0) or (SrcHeight <= 0) or Dst.Empty or
- ((CombineOp = dmBlend) and (MasterAlpha = 0)) or
- GR32.IsRectEmpty(SrcRect) then
- Exit;
-
- if not Dst.MeasuringMode then
- begin
- GR32.IntersectRect(DstClip, DstClip, Dst.BoundsRect);
- GR32.IntersectRect(DstClip, DstClip, DstRect);
- if GR32.IsRectEmpty(DstClip) then Exit;
- GR32.IntersectRect(R, DstClip, DstRect);
- if GR32.IsRectEmpty(R) then Exit;
-
- if (CombineOp = dmCustom) and not Assigned(CombineCallBack) then
- CombineOp := dmOpaque;
-
- SrcW := SrcRect.Right - SrcRect.Left;
- SrcH := SrcRect.Bottom - SrcRect.Top;
- DstW := DstRect.Right - DstRect.Left;
- DstH := DstRect.Bottom - DstRect.Top;
-
- try
- if (SrcW = DstW) and (SrcH = DstH) then
- BlendBlock(Dst, DstClip, SrcBits, SrcWidth, SrcHeight,
- SrcRect.Left + DstClip.Left - DstRect.Left,
- SrcRect.Top + DstClip.Top - DstRect.Top,
- OuterColor, CombineOp, CombineMode,
- MasterAlpha, CombineCallBack)
- else
- TCustomResamplerAccess(Resampler).Resample(
- Dst, DstRect, DstClip, SrcBits, SrcWidth, SrcHeight, SrcRect,
- OuterColor, CombineOp, CombineMode,
- MasterAlpha, CombineCallBack);
- finally
- EMMS;
- end;
- end;
-
- Dst.Changed(DstRect);
- end;
- {$WARNINGS ON}
-
-
-
- { TCustomKernel }
-
- procedure TCustomKernel.AssignTo(Dst: TPersistent);
- begin
- if Dst is TCustomKernel then
- SmartAssign(Self, Dst)
- else
- inherited;
- end;
-
- procedure TCustomKernel.Changed;
- begin
- if Assigned(FObserver) then FObserver.Changed;
- end;
-
- constructor TCustomKernel.Create;
- begin
- end;
-
- function TCustomKernel.RangeCheck: Boolean;
- begin
- Result := False;
- end;
-
-
- { TBoxKernel }
-
- function TBoxKernel.Filter(Value: TFloat): TFloat;
- begin
- if (Value >= -0.5) and (Value <= 0.5) then Result := 1.0
- else Result := 0;
- end;
-
- function TBoxKernel.GetWidth: TFloat;
- begin
- Result := 1;
- end;
-
- { TLinearKernel }
-
- function TLinearKernel.Filter(Value: TFloat): TFloat;
- begin
- if Value < -1 then Result := 0
- else if Value < 0 then Result := 1 + Value
- else if Value < 1 then Result := 1 - Value
- else Result := 0;
- end;
-
- function TLinearKernel.GetWidth: TFloat;
- begin
- Result := 1;
- end;
-
- { TCosineKernel }
-
- function TCosineKernel.Filter(Value: TFloat): TFloat;
- begin
- Result := 0;
- if Abs(Value) < 1 then
- Result := (Cos(Value * Pi) + 1) * 0.5;
- end;
-
- function TCosineKernel.GetWidth: TFloat;
- begin
- Result := 1;
- end;
-
- { TSplineKernel }
-
- function TSplineKernel.Filter(Value: TFloat): TFloat;
- var
- tt: TFloat;
- const
- TwoThirds = 2 / 3;
- OneSixth = 1 / 6;
- begin
- Value := Abs(Value);
- if Value < 1 then
- begin
- tt := Sqr(Value);
- Result := 0.5 * tt * Value - tt + TwoThirds;
- end
- else if Value < 2 then
- begin
- Value := 2 - Value;
- Result := OneSixth * Sqr(Value) * Value;
- end
- else Result := 0;
- end;
-
- function TSplineKernel.RangeCheck: Boolean;
- begin
- Result := True;
- end;
-
- function TSplineKernel.GetWidth: TFloat;
- begin
- Result := 2;
- end;
-
- { TWindowedSincKernel }
-
- function SInc(Value: TFloat): TFloat;
- begin
- if Value <> 0 then
- begin
- Value := Value * Pi;
- Result := Sin(Value) / Value;
- end
- else Result := 1;
- end;
-
- constructor TWindowedSincKernel.Create;
- begin
- FWidth := 3;
- FWidthReciprocal := 1 / FWidth;
- end;
-
- function TWindowedSincKernel.Filter(Value: TFloat): TFloat;
- begin
- Value := Abs(Value);
- if Value < FWidth then
- Result := SInc(Value) * Window(Value)
- else
- Result := 0;
- end;
-
- function TWindowedSincKernel.RangeCheck: Boolean;
- begin
- Result := True;
- end;
-
- procedure TWindowedSincKernel.SetWidth(Value: TFloat);
- begin
- Value := Min(MAX_KERNEL_WIDTH, Value);
- if Value <> FWidth then
- begin
- FWidth := Value;
- FWidthReciprocal := 1 / FWidth;
- Changed;
- end;
- end;
-
- function TWindowedSincKernel.GetWidth: TFloat;
- begin
- Result := FWidth;
- end;
-
- { TAlbrechtKernel }
-
- constructor TAlbrechtKernel.Create;
- begin
- inherited;
- Terms := 7;
- end;
-
- procedure TAlbrechtKernel.SetTerms(Value: Integer);
- begin
- if (Value < 2) then Value := 2;
- if (Value > 11) then Value := 11;
- if FTerms <> Value then
- begin
- FTerms := Value;
- case Value of
- 2 : Move(CAlbrecht2 [0], FCoefPointer[0], Value * SizeOf(Double));
- 3 : Move(CAlbrecht3 [0], FCoefPointer[0], Value * SizeOf(Double));
- 4 : Move(CAlbrecht4 [0], FCoefPointer[0], Value * SizeOf(Double));
- 5 : Move(CAlbrecht5 [0], FCoefPointer[0], Value * SizeOf(Double));
- 6 : Move(CAlbrecht6 [0], FCoefPointer[0], Value * SizeOf(Double));
- 7 : Move(CAlbrecht7 [0], FCoefPointer[0], Value * SizeOf(Double));
- 8 : Move(CAlbrecht8 [0], FCoefPointer[0], Value * SizeOf(Double));
- 9 : Move(CAlbrecht9 [0], FCoefPointer[0], Value * SizeOf(Double));
- 10 : Move(CAlbrecht10[0], FCoefPointer[0], Value * SizeOf(Double));
- 11 : Move(CAlbrecht11[0], FCoefPointer[0], Value * SizeOf(Double));
- end;
- end;
- end;
-
- function TAlbrechtKernel.Window(Value: TFloat): TFloat;
- var
- cs : Double;
- i : Integer;
- begin
- cs := Cos(Pi * Value * FWidthReciprocal);
- i := FTerms - 1;
- Result := FCoefPointer[i];
- while i > 0 do
- begin
- Dec(i);
- Result := Result * cs + FCoefPointer[i];
- end;
- end;
-
- { TLanczosKernel }
-
- function TLanczosKernel.Window(Value: TFloat): TFloat;
- begin
- Result := SInc(Value * FWidthReciprocal); // Get rid of division
- end;
-
- { TMitchellKernel }
-
- function TMitchellKernel.Filter(Value: TFloat): TFloat;
- var
- tt, ttt: TFloat;
- const OneEighteenth = 1 / 18;
- begin
- Value := Abs(Value);
- tt := Sqr(Value);
- ttt := tt * Value;
- if Value < 1 then Result := (21 * ttt - 36 * tt + 16 ) * OneEighteenth // get rid of divisions
- else if Value < 2 then Result := (- 7 * ttt + 36 * tt - 60 * Value + 32) * OneEighteenth // "
- else Result := 0;
- end;
-
- function TMitchellKernel.RangeCheck: Boolean;
- begin
- Result := True;
- end;
-
- function TMitchellKernel.GetWidth: TFloat;
- begin
- Result := 2;
- end;
-
- { TCubicKernel }
-
- constructor TCubicKernel.Create;
- begin
- FCoeff := -0.5;
- end;
-
- function TCubicKernel.Filter(Value: TFloat): TFloat;
- var
- tt, ttt: TFloat;
- begin
- Value := Abs(Value);
- tt := Sqr(Value);
- ttt := tt * Value;
- if Value < 1 then
- Result := (FCoeff + 2) * ttt - (FCoeff + 3) * tt + 1
- else if Value < 2 then
- Result := FCoeff * (ttt - 5 * tt + 8 * Value - 4)
- else
- Result := 0;
- end;
-
- function TCubicKernel.RangeCheck: Boolean;
- begin
- Result := True;
- end;
-
- function TCubicKernel.GetWidth: TFloat;
- begin
- Result := 2;
- end;
-
- { TGaussKernel }
-
- constructor TGaussianKernel.Create;
- begin
- inherited;
- FSigma := 1.33;
- FSigmaReciprocalLn2 := -Ln(2) / FSigma;
- end;
-
- procedure TGaussianKernel.SetSigma(const Value: TFloat);
- begin
- if (FSigma <> Value) and (FSigma <> 0) then
- begin
- FSigma := Value;
- FSigmaReciprocalLn2 := -Ln(2) / FSigma;
- Changed;
- end;
- end;
-
- function TGaussianKernel.Window(Value: TFloat): TFloat;
- begin
- Result := Exp(Sqr(Value) * FSigmaReciprocalLn2); // get rid of nasty LN2 and divition
- end;
-
- procedure TCubicKernel.SetCoeff(const Value: TFloat);
- begin
- if Value <> FCoeff then
- begin
- FCoeff := Value;
- Changed;
- end
- end;
-
- { TBlackmanKernel }
-
- function TBlackmanKernel.Window(Value: TFloat): TFloat;
- begin
- Value := Cos(Pi * Value * FWidthReciprocal); // get rid of division
- Result := 0.34 + 0.5 * Value + 0.16 * sqr(Value);
- end;
-
- { THannKernel }
-
- function THannKernel.Window(Value: TFloat): TFloat;
- begin
- Result := 0.5 + 0.5 * Cos(Pi * Value * FWidthReciprocal); // get rid of division
- end;
-
- { THammingKernel }
-
- function THammingKernel.Window(Value: TFloat): TFloat;
- begin
- Result := 0.54 + 0.46 * Cos(Pi * Value * FWidthReciprocal); // get rid of division
- end;
-
- { TSinshKernel }
-
- constructor TSinshKernel.Create;
- begin
- FWidth := 3;
- FCoeff := 0.5;
- end;
-
- function TSinshKernel.Filter(Value: TFloat): TFloat;
- begin
- if Value = 0 then
- Result := 1
- else
- Result := FCoeff * Sin(Pi * Value) / Sinh(Pi * FCoeff * Value);
- end;
-
- function TSinshKernel.RangeCheck: Boolean;
- begin
- Result := True;
- end;
-
- procedure TSinshKernel.SetWidth(Value: TFloat);
- begin
- if FWidth <> Value then
- begin
- FWidth := Value;
- Changed;
- end;
- end;
-
- function TSinshKernel.GetWidth: TFloat;
- begin
- Result := FWidth;
- end;
-
- procedure TSinshKernel.SetCoeff(const Value: TFloat);
- begin
- if (FCoeff <> Value) and (FCoeff <> 0) then
- begin
- FCoeff := Value;
- Changed;
- end;
- end;
-
- { THermiteKernel }
-
- constructor THermiteKernel.Create;
- begin
- FBias := 0;
- FTension := 0;
- end;
-
- function THermiteKernel.Filter(Value: TFloat): TFloat;
- var
- Z: Integer;
- t, t2, t3, m0, m1, a0, a1, a2, a3: TFloat;
- begin
- t := (1 - FTension) * 0.5;
- m0 := (1 + FBias) * t;
- m1 := (1 - FBias) * t;
-
- Z := Floor(Value);
- t := Abs(Z - Value);
- t2 := t * t;
- t3 := t2 * t;
-
- a1 := t3 - 2 * t2 + t;
- a2 := t3 - t2;
- a3 := -2 * t3 + 3 * t2;
- a0 := -a3 + 1;
-
- case Z of
- -2: Result := a2 * m1;
- -1: Result := a3 + a1 * m1 + a2 * (m0 - m1);
- 0: Result := a0 + a1 * (m0 - m1) - a2 * m0;
- 1: Result := -a1 * m0;
- else
- Result := 0;
- end;
- end;
-
- function THermiteKernel.GetWidth: TFloat;
- begin
- Result := 2;
- end;
-
- function THermiteKernel.RangeCheck: Boolean;
- begin
- Result := True;
- end;
-
- procedure THermiteKernel.SetBias(const Value: TFloat);
- begin
- if FBias <> Value then
- begin
- FBias := Value;
- Changed;
- end;
- end;
-
- procedure THermiteKernel.SetTension(const Value: TFloat);
- begin
- if FTension <> Value then
- begin
- FTension := Value;
- Changed;
- end;
- end;
-
-
-
- { TKernelResampler }
-
- constructor TKernelResampler.Create;
- begin
- inherited;
- Kernel := TBoxKernel.Create;
- FTableSize := 32;
- end;
-
- destructor TKernelResampler.Destroy;
- begin
- FKernel.Free;
- inherited;
- end;
-
- function TKernelResampler.GetKernelClassName: string;
- begin
- Result := FKernel.ClassName;
- end;
-
- procedure TKernelResampler.SetKernelClassName(Value: string);
- var
- KernelClass: TCustomKernelClass;
- begin
- if (Value <> '') and (FKernel.ClassName <> Value) and Assigned(KernelList) then
- begin
- KernelClass := TCustomKernelClass(KernelList.Find(Value));
- if Assigned(KernelClass) then
- begin
- FKernel.Free;
- FKernel := KernelClass.Create;
- Changed;
- end;
- end;
- end;
-
- procedure TKernelResampler.SetKernel(const Value: TCustomKernel);
- begin
- if Assigned(Value) and (FKernel <> Value) then
- begin
- FKernel.Free;
- FKernel := Value;
- Changed;
- end;
- end;
-
- procedure TKernelResampler.Resample(Dst: TCustomBitmap32; DstRect,
- DstClip: TRect;
- SrcBits: PColor32Array; SrcWidth, SrcHeight: Integer; SrcRect: TRect;
- OuterColor: TColor32;
- CombineOp: TDrawMode;
- CombineMode: TCombineMode;
- MasterAlpha: Cardinal;
- CombineCallBack: TPixelCombineEvent);
- begin
- GR32_Resamplers.Resample(Dst, DstRect, DstClip, SrcBits, SrcWidth, SrcHeight,
- SrcRect, FKernel, OuterColor,
- CombineOp, CombineMode, MasterAlpha, CombineCallBack);
- end;
-
- {$WARNINGS OFF}
-
- function TKernelResampler.GetSampleFloat(X, Y: TFloat): TColor32;
- var
- clX, clY: Integer;
- fracX, fracY: Integer;
- fracXS: TFloat absolute fracX;
- fracYS: TFloat absolute fracY;
-
- Filter: TFilterMethod;
- WrapProcVert: TWrapProcEx absolute Filter;
- WrapProcHorz: TWrapProcEx;
- Colors: PColor32EntryArray;
- KWidth, W, Wv, I, J, Incr, Dev: Integer;
- SrcP: PColor32Entry;
- C: TColor32Entry absolute SrcP;
- LoX, HiX, LoY, HiY, MappingY: Integer;
-
- HorzKernel, VertKernel: TKernelEntry;
- PHorzKernel, PVertKernel, FloorKernel, CeilKernel: PKernelEntry;
-
- HorzEntry, VertEntry: TBufferEntry;
- MappingX: TKernelEntry;
- Edge: Boolean;
-
- Alpha: integer;
- OuterPremultColorR, OuterPremultColorG, OuterPremultColorB: Byte;
- begin
- KWidth := Ceil(FKernel.GetWidth);
-
- clX := Ceil(X);
- clY := Ceil(Y);
-
- case PixelAccessMode of
- pamUnsafe, pamWrap:
- begin
- LoX := -KWidth; HiX := KWidth;
- LoY := -KWidth; HiY := KWidth;
- end;
-
- pamSafe, pamTransparentEdge:
- begin
- with ClipRect do
- begin
- if not ((clX < Left) or (clX > Right) or (clY < Top) or (clY > Bottom)) then
- begin
- Edge := False;
-
- if clX - KWidth < Left then
- begin
- LoX := Left - clX;
- Edge := True;
- end
- else
- LoX := -KWidth;
-
- if clX + KWidth >= Right then
- begin
- HiX := Right - clX - 1;
- Edge := True;
- end
- else
- HiX := KWidth;
-
- if clY - KWidth < Top then
- begin
- LoY := Top - clY;
- Edge := True;
- end
- else
- LoY := -KWidth;
-
- if clY + KWidth >= Bottom then
- begin
- HiY := Bottom - clY - 1;
- Edge := True;
- end
- else
- HiY := KWidth;
-
- end
- else
- begin
- if PixelAccessMode = pamTransparentEdge then
- Result := 0
- else
- Result := FOuterColor;
- Exit;
- end;
-
- end;
- end;
- end;
-
- case FKernelMode of
- kmDynamic:
- begin
- Filter := FKernel.Filter;
- fracXS := clX - X;
- fracYS := clY - Y;
-
- PHorzKernel := @HorzKernel;
- PVertKernel := @VertKernel;
-
- Dev := -256;
- for I := -KWidth to KWidth do
- begin
- W := Round(Filter(I + fracXS) * 256);
- HorzKernel[I] := W;
- Inc(Dev, W);
- end;
- Dec(HorzKernel[0], Dev);
-
- Dev := -256;
- for I := -KWidth to KWidth do
- begin
- W := Round(Filter(I + fracYS) * 256);
- VertKernel[I] := W;
- Inc(Dev, W);
- end;
- Dec(VertKernel[0], Dev);
-
- end;
- kmTableNearest:
- begin
- W := FWeightTable.Height - 2;
- PHorzKernel := @FWeightTable.ValPtr[KWidth - MAX_KERNEL_WIDTH, Round((clX - X) * W)]^;
- PVertKernel := @FWeightTable.ValPtr[KWidth - MAX_KERNEL_WIDTH, Round((clY - Y) * W)]^;
- end;
- kmTableLinear:
- begin
- W := (FWeightTable.Height - 2) * $10000;
- J := FWeightTable.Width * 4;
-
- with TFixedRec(FracX) do
- begin
- Fixed := Round((clX - X) * W);
- PHorzKernel := @HorzKernel;
- FloorKernel := @FWeightTable.ValPtr[KWidth - MAX_KERNEL_WIDTH, Int]^;
- {$IFDEF HAS_NATIVEINT}
- CeilKernel := PKernelEntry(NativeUInt(FloorKernel) + J);
- {$ELSE}
- CeilKernel := PKernelEntry(Cardinal(FloorKernel) + J);
- {$ENDIF}
- Dev := -256;
- for I := -KWidth to KWidth do
- begin
- Wv := FloorKernel[I] + ((CeilKernel[I] - FloorKernel[I]) * Frac + $7FFF) div FixedOne;
- HorzKernel[I] := Wv;
- Inc(Dev, Wv);
- end;
- Dec(HorzKernel[0], Dev);
- end;
-
- with TFixedRec(FracY) do
- begin
- Fixed := Round((clY - Y) * W);
- PVertKernel := @VertKernel;
- FloorKernel := @FWeightTable.ValPtr[KWidth - MAX_KERNEL_WIDTH, Int]^;
- {$IFDEF HAS_NATIVEINT}
- CeilKernel := PKernelEntry(NativeUInt(FloorKernel) + J);
- {$ELSE}
- CeilKernel := PKernelEntry(Cardinal(FloorKernel) + J);
- {$ENDIF}
- Dev := -256;
- for I := -KWidth to KWidth do
- begin
- Wv := FloorKernel[I] + ((CeilKernel[I] - FloorKernel[I]) * Frac + $7FFF) div FixedOne;
- VertKernel[I] := Wv;
- Inc(Dev, Wv);
- end;
- Dec(VertKernel[0], Dev);
- end;
- end;
-
- end;
-
- VertEntry := EMPTY_ENTRY;
- case PixelAccessMode of
- pamUnsafe, pamSafe, pamTransparentEdge:
- begin
- SrcP := PColor32Entry(Bitmap.PixelPtr[LoX + clX, LoY + clY]);
- Incr := Bitmap.Width - (HiX - LoX) - 1;
- for I := LoY to HiY do
- begin
- Wv := PVertKernel[I];
- if Wv <> 0 then
- begin
- HorzEntry := EMPTY_ENTRY;
- for J := LoX to HiX do
- begin
- // Alpha=0 should not contribute to sample.
- Alpha := SrcP.A;
- if (Alpha <> 0) then
- begin
- W := PHorzKernel[J];
- Inc(HorzEntry.A, Alpha * W);
- // Sample premultiplied values
- if (Alpha = 255) then
- begin
- Inc(HorzEntry.R, SrcP.R * W);
- Inc(HorzEntry.G, SrcP.G * W);
- Inc(HorzEntry.B, SrcP.B * W);
- end else
- begin
- Inc(HorzEntry.R, Div255(Alpha * SrcP.R) * W);
- Inc(HorzEntry.G, Div255(Alpha * SrcP.G) * W);
- Inc(HorzEntry.B, Div255(Alpha * SrcP.B) * W);
- end;
- end;
- Inc(SrcP);
- end;
- Inc(VertEntry.A, HorzEntry.A * Wv);
- Inc(VertEntry.R, HorzEntry.R * Wv);
- Inc(VertEntry.G, HorzEntry.G * Wv);
- Inc(VertEntry.B, HorzEntry.B * Wv);
- end else Inc(SrcP, HiX - LoX + 1);
- Inc(SrcP, Incr);
- end;
-
- if (PixelAccessMode = pamSafe) and Edge then
- begin
- Alpha := TColor32Entry(FOuterColor).A;
-
- // Alpha=0 should not contribute to sample.
- if (Alpha <> 0) then
- begin
- // Sample premultiplied values
- OuterPremultColorR := Div255(Alpha * TColor32Entry(FOuterColor).R);
- OuterPremultColorG := Div255(Alpha * TColor32Entry(FOuterColor).G);
- OuterPremultColorB := Div255(Alpha * TColor32Entry(FOuterColor).B);
-
- for I := -KWidth to KWidth do
- begin
- Wv := PVertKernel[I];
- if Wv <> 0 then
- begin
- HorzEntry := EMPTY_ENTRY;
- for J := -KWidth to KWidth do
- if (J < LoX) or (J > HiX) or (I < LoY) or (I > HiY) then
- begin
- W := PHorzKernel[J];
- Inc(HorzEntry.A, Alpha * W);
- Inc(HorzEntry.R, OuterPremultColorR * W);
- Inc(HorzEntry.G, OuterPremultColorG * W);
- Inc(HorzEntry.B, OuterPremultColorB * W);
- end;
- Inc(VertEntry.A, HorzEntry.A * Wv);
- Inc(VertEntry.R, HorzEntry.R * Wv);
- Inc(VertEntry.G, HorzEntry.G * Wv);
- Inc(VertEntry.B, HorzEntry.B * Wv);
- end;
- end
- end;
- end;
- end;
-
- pamWrap:
- begin
- WrapProcHorz := GetWrapProcEx(Bitmap.WrapMode, ClipRect.Left, ClipRect.Right - 1);
- WrapProcVert := GetWrapProcEx(Bitmap.WrapMode, ClipRect.Top, ClipRect.Bottom - 1);
-
- for I := -KWidth to KWidth do
- MappingX[I] := WrapProcHorz(clX + I, ClipRect.Left, ClipRect.Right - 1);
-
- for I := -KWidth to KWidth do
- begin
- Wv := PVertKernel[I];
- if Wv <> 0 then
- begin
- MappingY := WrapProcVert(clY + I, ClipRect.Top, ClipRect.Bottom - 1);
- Colors := PColor32EntryArray(Bitmap.ScanLine[MappingY]);
- HorzEntry := EMPTY_ENTRY;
- for J := -KWidth to KWidth do
- begin
- C := Colors[MappingX[J]];
- Alpha := C.A;
- // Alpha=0 should not contribute to sample.
- if (Alpha <> 0) then
- begin
- W := PHorzKernel[J];
- Inc(HorzEntry.A, Alpha * W);
- // Sample premultiplied values
- if (Alpha = 255) then
- begin
- Inc(HorzEntry.R, C.R * W);
- Inc(HorzEntry.G, C.G * W);
- Inc(HorzEntry.B, C.B * W);
- end else
- begin
- Inc(HorzEntry.R, Div255(Alpha * C.R) * W);
- Inc(HorzEntry.G, Div255(Alpha * C.G) * W);
- Inc(HorzEntry.B, Div255(Alpha * C.B) * W);
- end;
- end;
- end;
- Inc(VertEntry.A, HorzEntry.A * Wv);
- Inc(VertEntry.R, HorzEntry.R * Wv);
- Inc(VertEntry.G, HorzEntry.G * Wv);
- Inc(VertEntry.B, HorzEntry.B * Wv);
- end;
- end;
- end;
- end;
-
- // Round and unpremultiply result
- with TColor32Entry(Result) do
- begin
- if FKernel.RangeCheck then
- begin
- A := Clamp(TFixedRec(Integer(VertEntry.A + FixedHalf)).Int);
- if (A = 255) then
- begin
- R := Clamp(TFixedRec(Integer(VertEntry.R + FixedHalf)).Int);
- G := Clamp(TFixedRec(Integer(VertEntry.G + FixedHalf)).Int);
- B := Clamp(TFixedRec(Integer(VertEntry.B + FixedHalf)).Int);
- end else
- if (A <> 0) then
- begin
- R := Clamp(TFixedRec(Integer(VertEntry.R + FixedHalf)).Int * 255 div A);
- G := Clamp(TFixedRec(Integer(VertEntry.G + FixedHalf)).Int * 255 div A);
- B := Clamp(TFixedRec(Integer(VertEntry.B + FixedHalf)).Int * 255 div A);
- end else
- begin
- R := 0;
- G := 0;
- B := 0;
- end;
- end
- else
- begin
- A := TFixedRec(Integer(VertEntry.A + FixedHalf)).Int;
- if (A = 255) then
- begin
- R := TFixedRec(Integer(VertEntry.R + FixedHalf)).Int;
- G := TFixedRec(Integer(VertEntry.G + FixedHalf)).Int;
- B := TFixedRec(Integer(VertEntry.B + FixedHalf)).Int;
- end else
- if (A <> 0) then
- begin
- R := TFixedRec(Integer(VertEntry.R + FixedHalf)).Int * 255 div A;
- G := TFixedRec(Integer(VertEntry.G + FixedHalf)).Int * 255 div A;
- B := TFixedRec(Integer(VertEntry.B + FixedHalf)).Int * 255 div A;
- end else
- begin
- R := 0;
- G := 0;
- B := 0;
- end;
- end;
- end;
- end;
- {$WARNINGS ON}
-
- function TKernelResampler.GetWidth: TFloat;
- begin
- Result := Kernel.GetWidth;
- end;
-
- procedure TKernelResampler.SetKernelMode(const Value: TKernelMode);
- begin
- if FKernelMode <> Value then
- begin
- FKernelMode := Value;
- Changed;
- end;
- end;
-
- procedure TKernelResampler.SetTableSize(Value: Integer);
- begin
- if Value < 2 then Value := 2;
- if FTableSize <> Value then
- begin
- FTableSize := Value;
- Changed;
- end;
- end;
-
- procedure TKernelResampler.FinalizeSampling;
- begin
- if FKernelMode in [kmTableNearest, kmTableLinear] then
- FWeightTable.Free;
- inherited;
- end;
-
- procedure TKernelResampler.PrepareSampling;
- var
- I, J, W, Weight, Dev: Integer;
- Fraction: TFloat;
- KernelPtr: PKernelEntry;
- begin
- inherited;
- FOuterColor := Bitmap.OuterColor;
- W := Ceil(FKernel.GetWidth);
- if FKernelMode in [kmTableNearest, kmTableLinear] then
- begin
- FWeightTable := TIntegerMap.Create;
- FWeightTable.SetSize(W * 2 + 1, FTableSize + 1);
- for I := 0 to FTableSize do
- begin
- Fraction := I / (FTableSize - 1);
- KernelPtr := @FWeightTable.ValPtr[W - MAX_KERNEL_WIDTH, I]^;
- Dev := - 256;
- for J := -W to W do
- begin
- Weight := Round(FKernel.Filter(J + Fraction) * 256);
- KernelPtr[J] := Weight;
- Inc(Dev, Weight);
- end;
- Dec(KernelPtr[0], Dev);
- end;
- end;
- end;
-
- { TCustomBitmap32NearestResampler }
-
- function TNearestResampler.GetSampleInt(X, Y: Integer): TColor32;
- begin
- Result := FGetSampleInt(X, Y);
- end;
-
- function TNearestResampler.GetSampleFixed(X, Y: TFixed): TColor32;
- begin
- Result := FGetSampleInt(FixedRound(X), FixedRound(Y));
- end;
-
- function TNearestResampler.GetSampleFloat(X, Y: TFloat): TColor32;
- begin
- Result := FGetSampleInt(Round(X), Round(Y));
- end;
-
- function TNearestResampler.GetWidth: TFloat;
- begin
- Result := 1;
- end;
-
- function TNearestResampler.GetPixelTransparentEdge(X,Y: Integer): TColor32;
- var
- I, J: Integer;
- begin
- with Bitmap, Bitmap.ClipRect do
- begin
- I := Clamp(X, Left, Right - 1);
- J := Clamp(Y, Top, Bottom - 1);
- Result := Pixel[I, J];
- if (I <> X) or (J <> Y) then
- Result := Result and $00FFFFFF;
- end;
- end;
-
- procedure TNearestResampler.PrepareSampling;
- begin
- inherited;
- case PixelAccessMode of
- pamUnsafe: FGetSampleInt := TCustomBitmap32Access(Bitmap).GetPixel;
- pamSafe: FGetSampleInt := TCustomBitmap32Access(Bitmap).GetPixelS;
- pamWrap: FGetSampleInt := TCustomBitmap32Access(Bitmap).GetPixelW;
- pamTransparentEdge: FGetSampleInt := GetPixelTransparentEdge;
- end;
- end;
-
- procedure TNearestResampler.Resample(
- Dst: TCustomBitmap32; DstRect: TRect; DstClip: TRect;
- SrcBits: PColor32Array; SrcWidth, SrcHeight: Integer; SrcRect: TRect;
- OuterColor: TColor32;
- CombineOp: TDrawMode;
- CombineMode: TCombineMode;
- MasterAlpha: Cardinal;
- CombineCallBack: TPixelCombineEvent);
- begin
- StretchNearest(Dst, DstRect, DstClip, SrcBits, SrcWidth, SrcHeight, SrcRect,
- OuterColor, CombineOp, CombineMode,
- MasterAlpha, CombineCallBack)
- end;
-
-
- { TCustomBitmap32LinearResampler }
-
- constructor TLinearResampler.Create;
- begin
- inherited;
- FLinearKernel := TLinearKernel.Create;
- end;
-
- destructor TLinearResampler.Destroy;
- begin
- FLinearKernel.Free;
- inherited Destroy;
- end;
-
- function TLinearResampler.GetSampleFixed(X, Y: TFixed): TColor32;
- begin
- Result := FGetSampleFixed(X, Y);
- end;
-
- function TLinearResampler.GetSampleFloat(X, Y: TFloat): TColor32;
- begin
- Result := FGetSampleFixed(Round(X * FixedOne), Round(Y * FixedOne));
- end;
-
- function TLinearResampler.GetPixelTransparentEdge(X, Y: TFixed): TColor32;
- var
- I, J, X1, X2, Y1, Y2, WX, R, B: TFixed;
- C1, C2, C3, C4: TColor32;
- PSrc: PColor32Array;
- begin
- with TCustomBitmap32Access(Bitmap), Bitmap.ClipRect do
- begin
- R := Right - 1;
- B := Bottom - 1;
-
- I := TFixedRec(X).Int;
- J := TFixedRec(Y).Int;
-
- if (I >= Left) and (J >= Top) and (I < R) and (J < B) then
- begin //Safe
- Result := GET_T256(X shr 8, Y shr 8);
- EMMS;
- end
- else
- if (I >= Left - 1) and (J >= Top - 1) and (I <= R) and (J <= B) then
- begin //Near edge, on edge or outside
-
- X1 := Clamp(I, R);
- X2 := Clamp(I + Sign(X), R);
- Y1 := Clamp(J, B) * Width;
- Y2 := Clamp(J + Sign(Y), B) * Width;
-
- PSrc := @Bits[0];
- C1 := PSrc[X1 + Y1];
- C2 := PSrc[X2 + Y1];
- C3 := PSrc[X1 + Y2];
- C4 := PSrc[X2 + Y2];
-
- if X <= Fixed(Left) then
- begin
- C1 := C1 and $00FFFFFF;
- C3 := C3 and $00FFFFFF;
- end
- else if I = R then
- begin
- C2 := C2 and $00FFFFFF;
- C4 := C4 and $00FFFFFF;
- end;
-
- if Y <= Fixed(Top) then
- begin
- C1 := C1 and $00FFFFFF;
- C2 := C2 and $00FFFFFF;
- end
- else if J = B then
- begin
- C3 := C3 and $00FFFFFF;
- C4 := C4 and $00FFFFFF;
- end;
-
- WX := GAMMA_TABLE[((X shr 8) and $FF) xor $FF];
- Result := CombineReg(CombineReg(C1, C2, WX),
- CombineReg(C3, C4, WX),
- GAMMA_TABLE[((Y shr 8) and $FF) xor $FF]);
- EMMS;
- end
- else
- Result := 0; //Nothing really makes sense here, return zero
- end;
- end;
-
- procedure TLinearResampler.PrepareSampling;
- begin
- inherited;
- case PixelAccessMode of
- pamUnsafe: FGetSampleFixed := TCustomBitmap32Access(Bitmap).GetPixelX;
- pamSafe: FGetSampleFixed := TCustomBitmap32Access(Bitmap).GetPixelXS;
- pamWrap: FGetSampleFixed := TCustomBitmap32Access(Bitmap).GetPixelXW;
- pamTransparentEdge: FGetSampleFixed := GetPixelTransparentEdge;
- end;
- end;
-
- function TLinearResampler.GetWidth: TFloat;
- begin
- Result := 1;
- end;
-
- procedure TLinearResampler.Resample(
- Dst: TCustomBitmap32; DstRect: TRect; DstClip: TRect;
- SrcBits: PColor32Array; SrcWidth, SrcHeight: Integer; SrcRect: TRect;
- OuterColor: TColor32;
- CombineOp: TDrawMode;
- CombineMode: TCombineMode;
- MasterAlpha: Cardinal;
- CombineCallBack: TPixelCombineEvent);
- var
- SrcW, SrcH: TFloat;
- DstW, DstH: Integer;
- begin
- SrcW := SrcRect.Right - SrcRect.Left;
- SrcH := SrcRect.Bottom - SrcRect.Top;
- DstW := DstRect.Right - DstRect.Left;
- DstH := DstRect.Bottom - DstRect.Top;
- if (DstW > SrcW) and (DstH > SrcH) and (SrcW > 1) and (SrcH > 1) then
- StretchHorzStretchVertLinear(Dst, DstRect, DstClip, SrcBits, SrcWidth, SrcHeight,
- SrcRect, OuterColor, CombineOp,
- CombineMode, MasterAlpha, CombineCallBack)
- else
- GR32_Resamplers.Resample(Dst, DstRect, DstClip, SrcBits, SrcWidth, SrcHeight,
- SrcRect, FLinearKernel, OuterColor,
- CombineOp, CombineMode, MasterAlpha, CombineCallBack);
- end;
-
- procedure TDraftResampler.Resample(
- Dst: TCustomBitmap32; DstRect: TRect; DstClip: TRect;
- SrcBits: PColor32Array; SrcWidth, SrcHeight: Integer; SrcRect: TRect;
- OuterColor: TColor32;
- CombineOp: TDrawMode;
- CombineMode: TCombineMode;
- MasterAlpha: Cardinal;
- CombineCallBack: TPixelCombineEvent);
- begin
- DraftResample(
- Dst, DstRect, DstClip, SrcBits, SrcWidth, SrcHeight, SrcRect,
- FLinearKernel, OuterColor, CombineOp,
- CombineMode, MasterAlpha, CombineCallBack)
- end;
-
- { TTransformer }
-
- function TTransformer.GetSampleInt(X, Y: Integer): TColor32;
- var
- U, V: TFixed;
- begin
- FTransformationReverseTransformFixed(X * FixedOne + FixedHalf, Y * FixedOne + FixedHalf, U, V);
- Result := FGetSampleFixed(U - FixedHalf, V - FixedHalf);
- end;
-
- function TTransformer.GetSampleFixed(X, Y: TFixed): TColor32;
- var
- U, V: TFixed;
- begin
- FTransformationReverseTransformFixed(X + FixedHalf, Y + FixedHalf, U, V);
- Result := FGetSampleFixed(U - FixedHalf, V - FixedHalf);
- end;
-
- function TTransformer.GetSampleFloat(X, Y: TFloat): TColor32;
- var
- U, V: TFloat;
- begin
- FTransformationReverseTransformFloat(X + 0.5, Y + 0.5, U, V);
- Result := FGetSampleFloat(U - 0.5, V - 0.5);
- end;
-
- procedure TTransformer.SetTransformation(const Value: TTransformation);
- begin
- FTransformation := Value;
- if Assigned(Value) then
- begin
- FTransformationReverseTransformInt := TTransformationAccess(FTransformation).ReverseTransformInt;
- FTransformationReverseTransformFixed := TTransformationAccess(FTransformation).ReverseTransformFixed;
- FTransformationReverseTransformFloat := TTransformationAccess(FTransformation).ReverseTransformFloat;
- end;
- end;
-
- constructor TTransformer.Create(ASampler: TCustomSampler; ATransformation: TTransformation);
- begin
- inherited Create(ASampler);
- Transformation := ATransformation;
- end;
-
- procedure TTransformer.PrepareSampling;
- begin
- inherited;
- with TTransformationAccess(FTransformation) do
- if not TransformValid then
- PrepareTransform;
- end;
-
- function TTransformer.GetSampleBounds: TFloatRect;
- begin
- IntersectRect(Result, inherited GetSampleBounds, FTransformation.SrcRect);
- Result := FTransformation.GetTransformedBounds(Result);
- end;
-
- function TTransformer.HasBounds: Boolean;
- begin
- Result := FTransformation.HasTransformedBounds and inherited HasBounds;
- end;
-
-
- { TSuperSampler }
-
- constructor TSuperSampler.Create(Sampler: TCustomSampler);
- begin
- inherited Create(Sampler);
- FSamplingX := 4;
- FSamplingY := 4;
- SamplingX := 4;
- SamplingY := 4;
- end;
-
- function TSuperSampler.GetSampleFixed(X, Y: TFixed): TColor32;
- var
- I, J: Integer;
- dX, dY, tX: TFixed;
- Buffer: TBufferEntry;
- begin
- Buffer := EMPTY_ENTRY;
- tX := X + FOffsetX;
- Inc(Y, FOffsetY);
- dX := FDistanceX;
- dY := FDistanceY;
- for J := 1 to FSamplingY do
- begin
- X := tX;
- for I := 1 to FSamplingX do
- begin
- IncBuffer(Buffer, FGetSampleFixed(X, Y));
- Inc(X, dX);
- end;
- Inc(Y, dY);
- end;
- MultiplyBuffer(Buffer, FScale);
- Result := BufferToColor32(Buffer, 16);
- end;
-
- procedure TSuperSampler.SetSamplingX(const Value: TSamplingRange);
- begin
- FSamplingX := Value;
- FDistanceX := Fixed(1 / Value);
- FOffsetX := Fixed(((1 / Value) - 1) * 0.5); // replaced "/2" by "*0.5"
- FScale := Fixed(1 / (FSamplingX * FSamplingY));
- end;
-
- procedure TSuperSampler.SetSamplingY(const Value: TSamplingRange);
- begin
- FSamplingY := Value;
- FDistanceY := Fixed(1 / Value);
- FOffsetY := Fixed(((1 / Value) - 1) * 0.5); // replaced "/2" by "*0.5"
- FScale := Fixed(1 / (FSamplingX * FSamplingY));
- end;
-
- { TAdaptiveSuperSampler }
-
- function TAdaptiveSuperSampler.CompareColors(C1, C2: TColor32): Boolean;
- var
- Diff: TColor32Entry;
- begin
- Diff.ARGB := ColorDifference(C1, C2);
- Result := FTolerance < Diff.R + Diff.G + Diff.B;
- end;
-
- constructor TAdaptiveSuperSampler.Create(Sampler: TCustomSampler);
- begin
- inherited Create(Sampler);
- Level := 4;
- Tolerance := 256;
- end;
-
- function TAdaptiveSuperSampler.DoRecurse(X, Y, Offset: TFixed; const A, B,
- C, D, E: TColor32): TColor32;
- var
- C1, C2, C3, C4: TColor32;
- begin
- C1 := QuadrantColor(A, E, X - Offset, Y - Offset, Offset, RecurseAC);
- C2 := QuadrantColor(B, E, X + Offset, Y - Offset, Offset, RecurseBD);
- C3 := QuadrantColor(E, C, X + Offset, Y + Offset, Offset, RecurseAC);
- C4 := QuadrantColor(E, D, X - Offset, Y + Offset, Offset, RecurseBD);
- Result := ColorAverage(ColorAverage(C1, C2), ColorAverage(C3, C4));
- end;
-
- function TAdaptiveSuperSampler.GetSampleFixed(X, Y: TFixed): TColor32;
- var
- A, B, C, D, E: TColor32;
- const
- FIXED_HALF = 32768;
- begin
- A := FGetSampleFixed(X - FIXED_HALF, Y - FIXED_HALF);
- B := FGetSampleFixed(X + FIXED_HALF, Y - FIXED_HALF);
- C := FGetSampleFixed(X + FIXED_HALF, Y + FIXED_HALF);
- D := FGetSampleFixed(X - FIXED_HALF, Y + FIXED_HALF);
- E := FGetSampleFixed(X, Y);
- Result := Self.DoRecurse(X, Y, 16384, A, B, C, D, E);
- EMMS;
- end;
-
- function TAdaptiveSuperSampler.QuadrantColor(const C1, C2: TColor32; X, Y,
- Offset: TFixed; Proc: TRecurseProc): TColor32;
- begin
- if CompareColors(C1, C2) and (Offset >= FMinOffset) then
- Result := Proc(X, Y, Offset, C1, C2)
- else
- Result := ColorAverage(C1, C2);
- end;
-
- function TAdaptiveSuperSampler.RecurseAC(X, Y, Offset: TFixed; const A,
- C: TColor32): TColor32;
- var
- B, D, E: TColor32;
- begin
- EMMS;
- B := FGetSampleFixed(X + Offset, Y - Offset);
- D := FGetSampleFixed(X - Offset, Y + Offset);
- E := FGetSampleFixed(X, Y);
- Result := DoRecurse(X, Y, Offset shr 1, A, B, C, D, E);
- end;
-
- function TAdaptiveSuperSampler.RecurseBD(X, Y, Offset: TFixed; const B,
- D: TColor32): TColor32;
- var
- A, C, E: TColor32;
- begin
- EMMS;
- A := FGetSampleFixed(X - Offset, Y - Offset);
- C := FGetSampleFixed(X + Offset, Y + Offset);
- E := FGetSampleFixed(X, Y);
- Result := DoRecurse(X, Y, Offset shr 1, A, B, C, D, E);
- end;
-
- procedure TAdaptiveSuperSampler.SetLevel(const Value: Integer);
- begin
- FLevel := Value;
- FMinOffset := Fixed(1 / (1 shl Value));
- end;
-
- { TPatternSampler }
-
- destructor TPatternSampler.Destroy;
- begin
- if Assigned(FPattern) then FPattern := nil;
- inherited;
- end;
-
- function TPatternSampler.GetSampleFixed(X, Y: TFixed): TColor32;
- var
- Points: TArrayOfFixedPoint;
- P: PFixedPoint;
- I, PY: Integer;
- Buffer: TBufferEntry;
- GetSample: TGetSampleFixed;
- WrapProcHorz: TWrapProc;
- begin
- GetSample := FSampler.GetSampleFixed;
- PY := WrapProcVert(TFixedRec(Y).Int, High(FPattern));
- I := High(FPattern[PY]);
- WrapProcHorz := GetOptimalWrap(I);
- Points := FPattern[PY][WrapProcHorz(TFixedRec(X).Int, I)];
- Buffer := EMPTY_ENTRY;
- P := @Points[0];
- for I := 0 to High(Points) do
- begin
- IncBuffer(Buffer, GetSample(P.X + X, P.Y + Y));
- Inc(P);
- end;
- MultiplyBuffer(Buffer, FixedOne div Length(Points));
- Result := BufferToColor32(Buffer, 16);
- end;
-
- procedure TPatternSampler.SetPattern(const Value: TFixedSamplePattern);
- begin
- if Assigned(Value) then
- begin
- FPattern := nil;
- FPattern := Value;
- WrapProcVert := GetOptimalWrap(High(FPattern));
- end;
- end;
-
- function JitteredPattern(XRes, YRes: Integer): TArrayOfFixedPoint;
- var
- I, J: Integer;
- begin
- SetLength(Result, XRes * YRes);
- for I := 0 to XRes - 1 do
- for J := 0 to YRes - 1 do
- with Result[I + J * XRes] do
- begin
- X := (Random(65536) + I * 65536) div XRes - 32768;
- Y := (Random(65536) + J * 65536) div YRes - 32768;
- end;
- end;
-
- function CreateJitteredPattern(TileWidth, TileHeight, SamplesX, SamplesY: Integer): TFixedSamplePattern;
- var
- I, J: Integer;
- begin
- SetLength(Result, TileHeight, TileWidth);
- for I := 0 to TileWidth - 1 do
- for J := 0 to TileHeight - 1 do
- Result[J][I] := JitteredPattern(SamplesX, SamplesY);
- end;
-
- procedure RegisterResampler(ResamplerClass: TCustomResamplerClass);
- begin
- if not Assigned(ResamplerList) then ResamplerList := TClassList.Create;
- ResamplerList.ADD(ResamplerClass);
- end;
-
- procedure RegisterKernel(KernelClass: TCustomKernelClass);
- begin
- if not Assigned(KernelList) then KernelList := TClassList.Create;
- KernelList.ADD(KernelClass);
- end;
-
- { TNestedSampler }
-
- procedure TNestedSampler.AssignTo(Dst: TPersistent);
- begin
- if Dst is TNestedSampler then
- SmartAssign(Self, Dst)
- else
- inherited;
- end;
-
- constructor TNestedSampler.Create(ASampler: TCustomSampler);
- begin
- inherited Create;
- Sampler := ASampler;
- end;
-
- procedure TNestedSampler.FinalizeSampling;
- begin
- if not Assigned(FSampler) then
- raise ENestedException.Create(SSamplerNil)
- else
- FSampler.FinalizeSampling;
- end;
-
- {$WARNINGS OFF}
- function TNestedSampler.GetSampleBounds: TFloatRect;
- begin
- if not Assigned(FSampler) then
- raise ENestedException.Create(SSamplerNil)
- else
- Result := FSampler.GetSampleBounds;
- end;
-
- function TNestedSampler.HasBounds: Boolean;
- begin
- if not Assigned(FSampler) then
- raise ENestedException.Create(SSamplerNil)
- else
- Result := FSampler.HasBounds;
- end;
- {$WARNINGS ON}
-
- procedure TNestedSampler.PrepareSampling;
- begin
- if not Assigned(FSampler) then
- raise ENestedException.Create(SSamplerNil)
- else
- FSampler.PrepareSampling;
- end;
-
- procedure TNestedSampler.SetSampler(const Value: TCustomSampler);
- begin
- FSampler := Value;
- if Assigned(Value) then
- begin
- FGetSampleInt := FSampler.GetSampleInt;
- FGetSampleFixed := FSampler.GetSampleFixed;
- FGetSampleFloat := FSampler.GetSampleFloat;
- end;
- end;
-
-
- { TKernelSampler }
-
- function TKernelSampler.ConvertBuffer(var Buffer: TBufferEntry): TColor32;
- begin
- Buffer.A := Constrain(Buffer.A, 0, $FFFF);
- Buffer.R := Constrain(Buffer.R, 0, $FFFF);
- Buffer.G := Constrain(Buffer.G, 0, $FFFF);
- Buffer.B := Constrain(Buffer.B, 0, $FFFF);
-
- Result := BufferToColor32(Buffer, 8);
- end;
-
- constructor TKernelSampler.Create(ASampler: TCustomSampler);
- begin
- inherited;
- FKernel := TIntegerMap.Create;
- FStartEntry := EMPTY_ENTRY;
- end;
-
- destructor TKernelSampler.Destroy;
- begin
- FKernel.Free;
- inherited;
- end;
-
- function TKernelSampler.GetSampleFixed(X, Y: TFixed): TColor32;
- var
- I, J: Integer;
- Buffer: TBufferEntry;
- begin
- X := X + FCenterX shl 16;
- Y := Y + FCenterY shl 16;
- Buffer := FStartEntry;
- for I := 0 to FKernel.Width - 1 do
- for J := 0 to FKernel.Height - 1 do
- UpdateBuffer(Buffer, FGetSampleFixed(X - I shl 16, Y - J shl 16), FKernel[I, J]);
-
- Result := ConvertBuffer(Buffer);
- end;
-
- function TKernelSampler.GetSampleInt(X, Y: Integer): TColor32;
- var
- I, J: Integer;
- Buffer: TBufferEntry;
- begin
- X := X + FCenterX;
- Y := Y + FCenterY;
- Buffer := FStartEntry;
- for I := 0 to FKernel.Width - 1 do
- for J := 0 to FKernel.Height - 1 do
- UpdateBuffer(Buffer, FGetSampleInt(X - I, Y - J), FKernel[I, J]);
-
- Result := ConvertBuffer(Buffer);
- end;
-
- { TConvolver }
-
- procedure TConvolver.UpdateBuffer(var Buffer: TBufferEntry; Color: TColor32;
- Weight: Integer);
- begin
- with TColor32Entry(Color) do
- begin
- Inc(Buffer.A, A * Weight);
- Inc(Buffer.R, R * Weight);
- Inc(Buffer.G, G * Weight);
- Inc(Buffer.B, B * Weight);
- end;
- end;
-
- { TDilater }
-
- procedure TDilater.UpdateBuffer(var Buffer: TBufferEntry; Color: TColor32;
- Weight: Integer);
- begin
- with TColor32Entry(Color) do
- begin
- Buffer.A := Max(Buffer.A, A + Weight);
- Buffer.R := Max(Buffer.R, R + Weight);
- Buffer.G := Max(Buffer.G, G + Weight);
- Buffer.B := Max(Buffer.B, B + Weight);
- end;
- end;
-
- { TEroder }
-
- constructor TEroder.Create(ASampler: TCustomSampler);
- const
- START_ENTRY: TBufferEntry = (B: $FFFF; G: $FFFF; R: $FFFF; A: $FFFF);
- begin
- inherited;
- FStartEntry := START_ENTRY;
- end;
-
- procedure TEroder.UpdateBuffer(var Buffer: TBufferEntry; Color: TColor32;
- Weight: Integer);
- begin
- with TColor32Entry(Color) do
- begin
- Buffer.A := Min(Buffer.A, A - Weight);
- Buffer.R := Min(Buffer.R, R - Weight);
- Buffer.G := Min(Buffer.G, G - Weight);
- Buffer.B := Min(Buffer.B, B - Weight);
- end;
- end;
-
- { TExpander }
-
- procedure TExpander.UpdateBuffer(var Buffer: TBufferEntry; Color: TColor32;
- Weight: Integer);
- begin
- with TColor32Entry(Color) do
- begin
- Buffer.A := Max(Buffer.A, A * Weight);
- Buffer.R := Max(Buffer.R, R * Weight);
- Buffer.G := Max(Buffer.G, G * Weight);
- Buffer.B := Max(Buffer.B, B * Weight);
- end;
- end;
-
- { TContracter }
-
- function TContracter.GetSampleFixed(X, Y: TFixed): TColor32;
- begin
- Result := ColorSub(FMaxWeight, inherited GetSampleFixed(X, Y));
- end;
-
- function TContracter.GetSampleInt(X, Y: Integer): TColor32;
- begin
- Result := ColorSub(FMaxWeight, inherited GetSampleInt(X, Y));
- end;
-
- procedure TContracter.PrepareSampling;
- var
- I, J, W: Integer;
- begin
- W := Low(Integer);
- for I := 0 to FKernel.Width - 1 do
- for J := 0 to FKernel.Height - 1 do
- W := Max(W, FKernel[I, J]);
- if W > 255 then W := 255;
- FMaxWeight := Gray32(W, W);
- end;
-
- procedure TContracter.UpdateBuffer(var Buffer: TBufferEntry; Color: TColor32;
- Weight: Integer);
- begin
- inherited UpdateBuffer(Buffer, Color xor $FFFFFFFF, Weight);
- end;
-
- { TMorphologicalSampler }
-
- function TMorphologicalSampler.ConvertBuffer(
- var Buffer: TBufferEntry): TColor32;
- begin
- Buffer.A := Constrain(Buffer.A, 0, $FF);
- Buffer.R := Constrain(Buffer.R, 0, $FF);
- Buffer.G := Constrain(Buffer.G, 0, $FF);
- Buffer.B := Constrain(Buffer.B, 0, $FF);
-
- with TColor32Entry(Result) do
- begin
- A := Buffer.A;
- R := Buffer.R;
- G := Buffer.G;
- B := Buffer.B;
- end;
- end;
-
- { TSelectiveConvolver }
-
- function TSelectiveConvolver.ConvertBuffer(var Buffer: TBufferEntry): TColor32;
- begin
- with TColor32Entry(Result) do
- begin
- A := Buffer.A div FWeightSum.A;
- R := Buffer.R div FWeightSum.R;
- G := Buffer.G div FWeightSum.G;
- B := Buffer.B div FWeightSum.B;
- end;
- end;
-
- constructor TSelectiveConvolver.Create(ASampler: TCustomSampler);
- begin
- inherited;
- FDelta := 30;
- end;
-
- function TSelectiveConvolver.GetSampleFixed(X, Y: TFixed): TColor32;
- begin
- FRefColor := FGetSampleFixed(X, Y);
- FWeightSum := EMPTY_ENTRY;
- Result := inherited GetSampleFixed(X, Y);
- end;
-
- function TSelectiveConvolver.GetSampleInt(X, Y: Integer): TColor32;
- begin
- FRefColor := FGetSampleInt(X, Y);
- FWeightSum := EMPTY_ENTRY;
- Result := inherited GetSampleInt(X, Y);
- end;
-
- procedure TSelectiveConvolver.UpdateBuffer(var Buffer: TBufferEntry;
- Color: TColor32; Weight: Integer);
- begin
- with TColor32Entry(Color) do
- begin
- if Abs(TColor32Entry(FRefColor).A - A) <= FDelta then
- begin
- Inc(Buffer.A, A * Weight);
- Inc(FWeightSum.A, Weight);
- end;
- if Abs(TColor32Entry(FRefColor).R - R) <= FDelta then
- begin
- Inc(Buffer.R, R * Weight);
- Inc(FWeightSum.R, Weight);
- end;
- if Abs(TColor32Entry(FRefColor).G - G) <= FDelta then
- begin
- Inc(Buffer.G, G * Weight);
- Inc(FWeightSum.G, Weight);
- end;
- if Abs(TColor32Entry(FRefColor).B - B) <= FDelta then
- begin
- Inc(Buffer.B, B * Weight);
- Inc(FWeightSum.B, Weight);
- end;
- end;
- end;
-
- {CPU target and feature Function templates}
-
- const
- FID_BLOCKAVERAGE = 0;
- FID_INTERPOLATOR = 1;
-
- var
- Registry: TFunctionRegistry;
-
- procedure RegisterBindings;
- begin
- Registry := NewRegistry('GR32_Resamplers bindings');
- Registry.RegisterBinding(FID_BLOCKAVERAGE, @@BlockAverage);
- Registry.RegisterBinding(FID_INTERPOLATOR, @@Interpolator);
-
- Registry.ADD(FID_BLOCKAVERAGE, @BlockAverage_Pas);
- Registry.ADD(FID_INTERPOLATOR, @Interpolator_Pas);
- {$IFNDEF PUREPASCAL}
- Registry.ADD(FID_BLOCKAVERAGE, @BlockAverage_MMX, [ciMMX]);
- {$IFDEF USE_3DNOW}
- Registry.ADD(FID_BLOCKAVERAGE, @BlockAverage_3DNow, [ci3DNow]);
- {$ENDIF}
- Registry.ADD(FID_BLOCKAVERAGE, @BlockAverage_SSE2, [ciSSE2]);
- Registry.ADD(FID_INTERPOLATOR, @Interpolator_MMX, [ciMMX, ciSSE]);
- Registry.ADD(FID_INTERPOLATOR, @Interpolator_SSE2, [ciSSE2]);
- {$ENDIF}
- Registry.RebindAll;
- end;
-
- initialization
- RegisterBindings;
-
- { Register resamplers }
- RegisterResampler(TNearestResampler);
- RegisterResampler(TLinearResampler);
- RegisterResampler(TDraftResampler);
- RegisterResampler(TKernelResampler);
-
- { Register kernels }
- RegisterKernel(TBoxKernel);
- RegisterKernel(TLinearKernel);
- RegisterKernel(TCosineKernel);
- RegisterKernel(TSplineKernel);
- RegisterKernel(TCubicKernel);
- RegisterKernel(TMitchellKernel);
- RegisterKernel(TAlbrechtKernel);
- RegisterKernel(TLanczosKernel);
- RegisterKernel(TGaussianKernel);
- RegisterKernel(TBlackmanKernel);
- RegisterKernel(THannKernel);
- RegisterKernel(THammingKernel);
- RegisterKernel(TSinshKernel);
- RegisterKernel(THermiteKernel);
-
- finalization
- ResamplerList.Free;
- KernelList.Free;
-
- end.