1 // SPDX-License-Identifier: LGPL-3.0-linking-exception
2 unit BGRAGradientScanner;
3 
4 {$mode objfpc}{$H+}
5 
6 interface
7 
8 { This unit contains scanners that generate gradients }
9 
10 uses
11   SysUtils, BGRABitmapTypes, BGRATransform;
12 
13 type
14   TBGRAColorInterpolation = (ciStdRGB, ciLinearRGB, ciLinearHSLPositive, ciLinearHSLNegative, ciGSBPositive, ciGSBNegative);
15   TBGRAGradientRepetition = (grPad, grRepeat, grReflect, grSine);
16 
17   { TBGRASimpleGradient }
18 
19   TBGRASimpleGradient = class(TBGRACustomGradient)
20   protected
21     FColor1,FColor2: TBGRAPixel;
22     ec1,ec2: TExpandedPixel;
23     FRepetition: TBGRAGradientRepetition;
InterpolateToBGRAnull24     function InterpolateToBGRA(position: word): TBGRAPixel; virtual; abstract;
InterpolateToExpandednull25     function InterpolateToExpanded(position: word): TExpandedPixel; virtual; abstract;
26   public
CreateAnynull27     class function CreateAny(AInterpolation: TBGRAColorInterpolation; AColor1,AColor2: TBGRAPixel; ARepetition: TBGRAGradientRepetition): TBGRASimpleGradient; overload; static;
CreateAnynull28     class function CreateAny(AInterpolation: TBGRAColorInterpolation; AColor1,AColor2: TExpandedPixel; ARepetition: TBGRAGradientRepetition): TBGRASimpleGradient; overload; static;
29     constructor Create(AColor1,AColor2: TBGRAPixel; ARepetition: TBGRAGradientRepetition); overload; //do not call directly
30     constructor Create(AColor1,AColor2: TExpandedPixel; ARepetition: TBGRAGradientRepetition); overload; //do not call directly
GetColorAtnull31     function GetColorAt(position: integer): TBGRAPixel; override;
GetColorAtFnull32     function GetColorAtF(position: single): TBGRAPixel; override;
GetExpandedColorAtnull33     function GetExpandedColorAt(position: integer): TExpandedPixel; override;
GetExpandedColorAtFnull34     function GetExpandedColorAtF(position: single): TExpandedPixel; override;
GetAverageColornull35     function GetAverageColor: TBGRAPixel; override;
GetAverageExpandedColornull36     function GetAverageExpandedColor: TExpandedPixel; override;
GetMonochromenull37     function GetMonochrome: boolean; override;
38     property Repetition: TBGRAGradientRepetition read FRepetition write FRepetition;
39   end;
40 
41   { TBGRASimpleGradientWithoutGammaCorrection }
42 
43   TBGRASimpleGradientWithoutGammaCorrection = class(TBGRASimpleGradient)
44   protected
InterpolateToBGRAnull45     function InterpolateToBGRA(position: word): TBGRAPixel; override;
InterpolateToExpandednull46     function InterpolateToExpanded(position: word): TExpandedPixel; override;
47   public
48     constructor Create(Color1,Color2: TBGRAPixel; ARepetition: TBGRAGradientRepetition = grPad); overload;
49     constructor Create(Color1,Color2: TExpandedPixel; ARepetition: TBGRAGradientRepetition = grPad); overload;
50   end;
51 
52   { TBGRASimpleGradientWithGammaCorrection }
53 
54   TBGRASimpleGradientWithGammaCorrection = class(TBGRASimpleGradient)
55   protected
InterpolateToBGRAnull56     function InterpolateToBGRA(position: word): TBGRAPixel; override;
InterpolateToExpandednull57     function InterpolateToExpanded(position: word): TExpandedPixel; override;
58   public
59     constructor Create(Color1,Color2: TBGRAPixel; ARepetition: TBGRAGradientRepetition = grPad); overload;
60     constructor Create(Color1,Color2: TExpandedPixel; ARepetition: TBGRAGradientRepetition = grPad); overload;
61   end;
62 
63   THueGradientOption = (hgoRepeat, hgoReflect,                       //repetition
64                         hgoPositiveDirection, hgoNegativeDirection,  //hue orientation
65                         hgoHueCorrection, hgoLightnessCorrection);   //color interpolation
66   THueGradientOptions = set of THueGradientOption;
67 
68   { TBGRAHueGradient }
69 
70   TBGRAHueGradient = class(TBGRASimpleGradient)
71   private
72     hsla1,hsla2: THSLAPixel;
73     hue1,hue2: LongWord;
74     FOptions: THueGradientOptions;
75     procedure Init(c1,c2: THSLAPixel; AOptions: THueGradientOptions);
InterpolateToHSLAnull76     function InterpolateToHSLA(position: word): THSLAPixel;
77   protected
InterpolateToBGRAnull78     function InterpolateToBGRA(position: word): TBGRAPixel; override;
InterpolateToExpandednull79     function InterpolateToExpanded(position: word): TExpandedPixel; override;
80   public
81     constructor Create(Color1,Color2: TBGRAPixel; options: THueGradientOptions); overload;
82     constructor Create(Color1,Color2: TExpandedPixel; options: THueGradientOptions); overload;
83     constructor Create(Color1,Color2: THSLAPixel; options: THueGradientOptions); overload;
84     constructor Create(AHue1,AHue2: Word; Saturation,Lightness: Word; options: THueGradientOptions); overload;
GetMonochromenull85     function GetMonochrome: boolean; override;
86   end;
87 
88   TGradientInterpolationFunction = function(t: single): single of object;
89 
90   { TBGRAMultiGradient }
91 
92   TBGRAMultiGradient = class(TBGRACustomGradient)
93   private
94     FColors: array of TBGRAPixel;
95     FPositions: array of integer;
96     FPositionsF: array of single;
97     FEColors: array of TExpandedPixel;
98     FCycle: Boolean;
TGradientInterpolationFunctionnull99     FInterpolationFunction: TGradientInterpolationFunction;
100     procedure Init(Colors: array of TBGRAPixel; Positions0To1: array of single; AGammaCorrection, ACycle: boolean);
101   public
102     GammaCorrection: boolean;
CosineInterpolationnull103     function CosineInterpolation(t: single): single;
HalfCosineInterpolationnull104     function HalfCosineInterpolation(t: single): single;
105     constructor Create(Colors: array of TBGRAPixel; Positions0To1: array of single; AGammaCorrection: boolean; ACycle: boolean = false);
GetColorAtnull106     function GetColorAt(position: integer): TBGRAPixel; override;
GetExpandedColorAtnull107     function GetExpandedColorAt(position: integer): TExpandedPixel; override;
GetAverageColornull108     function GetAverageColor: TBGRAPixel; override;
GetMonochromenull109     function GetMonochrome: boolean; override;
TGradientInterpolationFunctionnull110     property InterpolationFunction: TGradientInterpolationFunction read FInterpolationFunction write FInterpolationFunction;
111   end;
112 
113   { TBGRABufferedGradient }
114 
115   TBGRABufferedGradient = class(TBGRACustomGradient)
116   protected
117     FGradient: TBGRACustomGradient;
118     FGradientOwned: boolean;
119     FPadded: boolean;
120     FAverageColorComputed: boolean;
121     FAverageColorExpanded: TExpandedPixel;
122     FMonochromeComputed: boolean;
123     FMonochrome: boolean;
124     FBufferSize, FBufferShift: integer;
125     FColorTab: array of TBGRAPixel;
126     FColorComputed: bitpacked array[0..65535] of boolean;
127     FRepetition: TBGRAGradientRepetition;
128   public
129     constructor Create(AGradient: TBGRACustomGradient; AOwner: boolean; APadded: boolean;
130       ABufferSize: integer);
131     destructor Destroy; override;
132     {** Returns the color at a given ''position''. The reference range is
133         from 0 to 65535, however values beyond are possible as well }
GetColorAtnull134     function GetColorAt(position: integer): TBGRAPixel; override;
135     {** Returns the average color of the gradient }
GetAverageColornull136     function GetAverageColor: TBGRAPixel; override;
GetAverageExpandedColornull137     function GetAverageExpandedColor: TExpandedPixel; override;
GetMonochromenull138     function GetMonochrome: boolean; override;
139   end;
140 
singlenull141   TBGRAGradientScannerInternalScanNextFunc = function():single of object;
onstnull142   TBGRAGradientScannerInternalScanAtFunc = function(const p: TPointF):single of object;
143 
144   { TBGRAGradientScanner }
145 
146   TBGRAGradientScanner = class(TBGRACustomScanner)
147   protected
148     FGradientType: TGradientType;
149     FOrigin,FDir1,FDir2: TPointF;
150     FRelativeFocal: TPointF;
151     FRadius, FFocalRadius: single;
152     FTransform, FHiddenTransform: TAffineMatrix;
153     FSinus: Boolean;
154     FGradient: TBGRACustomGradient;
155     FGradientOwner: boolean;
156     FFlipGradient: boolean;
157 
158     FMatrix: TAffineMatrix;
159     FRepeatHoriz, FIsAverage: boolean;
160     FAverageColor: TBGRAPixel;
161     FAverageExpandedColor: TExpandedPixel;
162     FScanNextFunc: TBGRAGradientScannerInternalScanNextFunc;
163     FScanAtFunc: TBGRAGradientScannerInternalScanAtFunc;
164     FGetGradientColor: TBGRAGradientGetColorAtFloatFunc;
165     FGetGradientExpandedColor: TBGRAGradientGetExpandedColorAtFloatFunc;
166     FFocalDistance: single;
167     FFocalDirection, FFocalNormal: TPointF;
168     FRadialDenominator, FRadialDeltaSign, maxW1, maxW2: single;
169 
170     FPosition: TPointF;
171     FHorizColor: TBGRAPixel;
172     FHorizExpandedColor: TExpandedPixel;
173 
174     procedure Init(AGradientType: TGradientType; AOrigin, d1: TPointF; ATransform: TAffineMatrix; Sinus: Boolean=False); overload;
175     procedure Init(AGradientType: TGradientType; AOrigin, d1, d2: TPointF; ATransform: TAffineMatrix; Sinus: Boolean=False); overload;
176     procedure Init(AOrigin: TPointF; ARadius: single; AFocal: TPointF; AFocalRadius: single; ATransform: TAffineMatrix; AHiddenTransform: TAffineMatrix); overload;
177 
178     procedure InitGradientType;
179     procedure InitTransform;
180     procedure InitGradient;
181 
ComputeRadialFocalnull182     function ComputeRadialFocal(const p: TPointF): single;
183 
ScanNextLinearnull184     function ScanNextLinear: single;
ScanNextReflectednull185     function ScanNextReflected: single;
ScanNextDiamondnull186     function ScanNextDiamond: single;
ScanNextRadialnull187     function ScanNextRadial: single;
ScanNextRadial2null188     function ScanNextRadial2: single;
ScanNextRadialFocalnull189     function ScanNextRadialFocal: single;
ScanNextAngularnull190     function ScanNextAngular: single;
191 
ScanAtLinearnull192     function ScanAtLinear(const p: TPointF): single;
ScanAtReflectednull193     function ScanAtReflected(const p: TPointF): single;
ScanAtDiamondnull194     function ScanAtDiamond(const p: TPointF): single;
ScanAtRadialnull195     function ScanAtRadial(const p: TPointF): single;
ScanAtRadial2null196     function ScanAtRadial2(const p: TPointF): single;
ScanAtRadialFocalnull197     function ScanAtRadialFocal(const p: TPointF): single;
ScanAtAngularnull198     function ScanAtAngular(const p: TPointF): single;
199 
ScanNextInlinenull200     function ScanNextInline: TBGRAPixel; inline;
ScanNextExpandedInlinenull201     function ScanNextExpandedInline: TExpandedPixel; inline;
202     procedure SetTransform(AValue: TAffineMatrix);
203     procedure SetFlipGradient(AValue: boolean);
204     procedure SetSinus(AValue: boolean);
GetGradientColornull205     function GetGradientColor(a: single): TBGRAPixel;
GetGradientExpandedColornull206     function GetGradientExpandedColor(a: single): TExpandedPixel;
GetGradientColorFlippednull207     function GetGradientColorFlipped(a: single): TBGRAPixel;
GetGradientExpandedColorFlippednull208     function GetGradientExpandedColorFlipped(a: single): TExpandedPixel;
GetGradientColorSinusnull209     function GetGradientColorSinus(a: single): TBGRAPixel;
GetGradientExpandedColorSinusnull210     function GetGradientExpandedColorSinus(a: single): TExpandedPixel;
211     procedure UpdateGetGradientColorFunctions;
212   public
213     constructor Create(AGradientType: TGradientType; AOrigin, d1: TPointF); overload;
214     constructor Create(AGradientType: TGradientType; AOrigin, d1, d2: TPointF); overload;
215     constructor Create(AOrigin, d1, d2, AFocal: TPointF; ARadiusRatio: single = 1; AFocalRadiusRatio: single = 0); overload;
216     constructor Create(AOrigin: TPointF; ARadius: single; AFocal: TPointF; AFocalRadius: single); overload;
217 
218     constructor Create(c1, c2: TBGRAPixel; AGradientType: TGradientType; AOrigin, d1: TPointF;
219                        gammaColorCorrection: boolean = True; Sinus: Boolean=False); overload;
220     constructor Create(c1, c2: TBGRAPixel; AGradientType: TGradientType; AOrigin, d1, d2: TPointF;
221                        gammaColorCorrection: boolean = True; Sinus: Boolean=False); overload;
222 
223     constructor Create(gradient: TBGRACustomGradient; AGradientType: TGradientType; AOrigin, d1: TPointF;
224                        Sinus: Boolean=False; AGradientOwner: Boolean=False); overload;
225     constructor Create(gradient: TBGRACustomGradient; AGradientType: TGradientType; AOrigin, d1, d2: TPointF;
226                        Sinus: Boolean=False; AGradientOwner: Boolean=False); overload;
227     constructor Create(gradient: TBGRACustomGradient; AOrigin: TPointF; ARadius: single; AFocal: TPointF;
228                        AFocalRadius: single; AGradientOwner: Boolean=False); overload;
229 
230     procedure SetGradient(c1,c2: TBGRAPixel; AGammaCorrection: boolean = true); overload;
231     procedure SetGradient(AGradient: TBGRACustomGradient; AOwner: boolean); overload;
232     destructor Destroy; override;
233     procedure ScanMoveTo(X, Y: Integer); override;
ScanNextPixelnull234     function ScanNextPixel: TBGRAPixel; override;
ScanNextExpandedPixelnull235     function ScanNextExpandedPixel: TExpandedPixel; override;
ScanAtnull236     function ScanAt(X, Y: Single): TBGRAPixel; override;
ScanAtExpandednull237     function ScanAtExpanded(X, Y: Single): TExpandedPixel; override;
238     procedure ScanPutPixels(pdest: PBGRAPixel; count: integer; mode: TDrawMode); override;
239     procedure ScanSkipPixels(ACount: integer); override;
IsScanPutPixelsDefinednull240     function IsScanPutPixelsDefined: boolean; override;
241     property Transform: TAffineMatrix read FTransform write SetTransform;
242     property Gradient: TBGRACustomGradient read FGradient;
243     property FlipGradient: boolean read FFlipGradient write SetFlipGradient;
244     property Sinus: boolean Read FSinus write SetSinus;
245   end;
246 
247   { TBGRAConstantScanner }
248 
249   TBGRAConstantScanner = class(TBGRAGradientScanner)
250     constructor Create(c: TBGRAPixel);
251   end;
252 
253   { TBGRARandomScanner }
254 
255   TBGRARandomScanner = class(TBGRACustomScanner)
256   private
257     FOpacity: byte;
258     FGrayscale: boolean;
259     FRandomBuffer, FRandomBufferCount: integer;
260   public
261     constructor Create(AGrayscale: Boolean; AOpacity: byte);
ScanAtIntegernull262     function ScanAtInteger({%H-}X, {%H-}Y: integer): TBGRAPixel; override;
ScanNextPixelnull263     function ScanNextPixel: TBGRAPixel; override;
ScanAtnull264     function ScanAt({%H-}X, {%H-}Y: Single): TBGRAPixel; override;
265   end;
266 
267   { TBGRAGradientTriangleScanner }
268 
269   TBGRAGradientTriangleScanner= class(TBGRACustomScanner)
270   protected
271     FMatrix: TAffineMatrix;
272     FColor1,FDiff2,FDiff3,FStep: TColorF;
273     FCurColor: TColorF;
274   public
275     constructor Create(pt1,pt2,pt3: TPointF; c1,c2,c3: TBGRAPixel);
276     procedure ScanMoveTo(X,Y: Integer); override;
277     procedure ScanMoveToF(X,Y: Single);
ScanAtnull278     function ScanAt(X,Y: Single): TBGRAPixel; override;
ScanNextPixelnull279     function ScanNextPixel: TBGRAPixel; override;
ScanNextExpandedPixelnull280     function ScanNextExpandedPixel: TExpandedPixel; override;
281     procedure ScanSkipPixels(ACount: integer); override;
282   end;
283 
284   { TBGRASolidColorMaskScanner }
285 
286   TBGRASolidColorMaskScanner = class(TBGRACustomScanner)
287   private
288     FOffset: TPoint;
289     FMask: IBGRAScanner;
290     FSolidColor: TBGRAPixel;
291   public
292     constructor Create(AMask: IBGRAScanner; AOffset: TPoint; ASolidColor: TBGRAPixel);
293     destructor Destroy; override;
IsScanPutPixelsDefinednull294     function IsScanPutPixelsDefined: boolean; override;
295     procedure ScanPutPixels(pdest: PBGRAPixel; count: integer; mode: TDrawMode); override;
296     procedure ScanSkipPixels(ACount: integer); override;
297     procedure ScanMoveTo(X,Y: Integer); override;
ScanNextPixelnull298     function ScanNextPixel: TBGRAPixel; override;
ScanAtnull299     function ScanAt(X,Y: Single): TBGRAPixel; override;
300     property Color: TBGRAPixel read FSolidColor write FSolidColor;
301   end;
302 
303   { TBGRATextureMaskScanner }
304 
305   TBGRATextureMaskScanner = class(TBGRACustomScanner)
306   private
307     FOffset: TPoint;
308     FMask: IBGRAScanner;
309     FTexture: IBGRAScanner;
310     FTextureScanNext : TScanNextPixelFunction;
FTextureScanAtnull311     FTextureScanAt : TScanAtFunction;
312     FGlobalOpacity: Byte;
313     FMemTex: packed array of TBGRAPixel;
314   public
315     constructor Create(AMask: IBGRAScanner; AOffset: TPoint; ATexture: IBGRAScanner; AGlobalOpacity: Byte = 255);
316     destructor Destroy; override;
IsScanPutPixelsDefinednull317     function IsScanPutPixelsDefined: boolean; override;
318     procedure ScanPutPixels(pdest: PBGRAPixel; count: integer; mode: TDrawMode); override;
319     procedure ScanSkipPixels(ACount: integer); override;
320     procedure ScanMoveTo(X,Y: Integer); override;
ScanNextPixelnull321     function ScanNextPixel: TBGRAPixel; override;
ScanAtnull322     function ScanAt(X,Y: Single): TBGRAPixel; override;
323   end;
324 
325   { TBGRAOpacityScanner }
326 
327   TBGRAOpacityScanner = class(TBGRACustomScanner)
328   private
329       FTexture: IBGRAScanner;
330       FOwnedScanner: TBGRACustomScanner;
331       FGlobalOpacity: Byte;
332       FScanNext : TScanNextPixelFunction;
FScanAtnull333       FScanAt : TScanAtFunction;
334       FMemTex: packed array of TBGRAPixel;
335   public
336     constructor Create(ATexture: IBGRAScanner; AGlobalOpacity: Byte = 255);
337     constructor Create(ATexture: TBGRACustomScanner; AGlobalOpacity: Byte; AOwned: boolean);
338     destructor Destroy; override;
IsScanPutPixelsDefinednull339     function IsScanPutPixelsDefined: boolean; override;
340     procedure ScanPutPixels(pdest: PBGRAPixel; count: integer; mode: TDrawMode); override;
341     procedure ScanSkipPixels(ACount: integer); override;
342     procedure ScanMoveTo(X,Y: Integer); override;
ScanNextPixelnull343     function ScanNextPixel: TBGRAPixel; override;
ScanAtnull344     function ScanAt(X,Y: Single): TBGRAPixel; override;
345   end;
346 
347 implementation
348 
349 uses BGRABlend, Math;
350 
351 { TBGRABufferedGradient }
352 
353 constructor TBGRABufferedGradient.Create(AGradient: TBGRACustomGradient;
354   AOwner: boolean; APadded: boolean; ABufferSize: integer);
355 var
356   bufferPowSize: integer;
357 begin
358   FGradient := AGradient;
359   FGradientOwned:= AOwner;
360   FPadded := APadded;
361   bufferPowSize := 0;
362   while ABufferSize > 1 do
363   begin
364     ABufferSize := ABufferSize shr 1;
365     inc(bufferPowSize);
366   end;
367   if bufferPowSize > 16 then bufferPowSize := 16;
368   FBufferSize:= 1 shl bufferPowSize;
369   setlength(FColorTab, FBufferSize);
370   FBufferShift := 16-bufferPowSize;
371 end;
372 
373 destructor TBGRABufferedGradient.Destroy;
374 begin
375   if FGradientOwned then FGradient.Free;
376   inherited Destroy;
377 end;
378 
TBGRABufferedGradient.GetColorAtnull379 function TBGRABufferedGradient.GetColorAt(position: integer): TBGRAPixel;
380 var
381   posBuf: Integer;
382 begin
383   if FPadded then
384   begin
385     if position < 0 then
386       position := 0 else
387     if position >= 65536 then
388       position := 65536;
389     posBuf := position shr FBufferShift;
390     if posBuf > FBufferSize shr 1 then dec(posBuf);
391   end else
392   begin
393     position := position and 131071;
394     posBuf := position shr (FBufferShift+1);
395   end;
396 
397   if not FColorComputed[posBuf] then
398   begin
399     result := FGradient.GetColorAt(position);
400     FColorTab[posBuf] := result;
401     FColorComputed[posBuf] := true;
402   end else
403     result := FColorTab[posBuf];
404 end;
405 
TBGRABufferedGradient.GetAverageColornull406 function TBGRABufferedGradient.GetAverageColor: TBGRAPixel;
407 begin
408   result := GammaCompression(GetAverageExpandedColor);
409 end;
410 
TBGRABufferedGradient.GetAverageExpandedColornull411 function TBGRABufferedGradient.GetAverageExpandedColor: TExpandedPixel;
412 begin
413   if not FAverageColorComputed then
414   begin
415     FAverageColorExpanded := FGradient.GetAverageExpandedColor;
416     FAverageColorComputed := true;
417   end;
418   result := FAverageColorExpanded;
419 end;
420 
GetMonochromenull421 function TBGRABufferedGradient.GetMonochrome: boolean;
422 begin
423   if not FMonochromeComputed then
424   begin
425     FMonochrome:= FGradient.Monochrome;
426     FMonochromeComputed:= true;
427   end;
428   result := FMonochrome;
429 end;
430 
431 { TBGRASimpleGradient }
432 
433 constructor TBGRASimpleGradient.Create(AColor1, AColor2: TBGRAPixel; ARepetition: TBGRAGradientRepetition);
434 begin
435   FColor1 := AColor1;
436   FColor2 := AColor2;
437   ec1 := GammaExpansion(AColor1);
438   ec2 := GammaExpansion(AColor2);
439   FRepetition:= ARepetition;
440 end;
441 
442 constructor TBGRASimpleGradient.Create(AColor1, AColor2: TExpandedPixel;
443   ARepetition: TBGRAGradientRepetition);
444 begin
445   FColor1 := GammaCompression(AColor1);
446   FColor2 := GammaCompression(AColor2);
447   ec1 := AColor1;
448   ec2 := AColor2;
449   FRepetition:= ARepetition;
450 end;
451 
TBGRASimpleGradient.CreateAnynull452 class function TBGRASimpleGradient.CreateAny(AInterpolation: TBGRAColorInterpolation;
453   AColor1, AColor2: TBGRAPixel; ARepetition: TBGRAGradientRepetition): TBGRASimpleGradient;
454 begin
455   case AInterpolation of
456     ciStdRGB: result := TBGRASimpleGradientWithoutGammaCorrection.Create(AColor1,AColor2);
457     ciLinearRGB: result := TBGRASimpleGradientWithGammaCorrection.Create(AColor1,AColor2);
458     ciLinearHSLPositive: result := TBGRAHueGradient.Create(AColor1,AColor2,[hgoPositiveDirection]);
459     ciLinearHSLNegative: result := TBGRAHueGradient.Create(AColor1,AColor2,[hgoNegativeDirection]);
460     ciGSBPositive: result := TBGRAHueGradient.Create(AColor1,AColor2,[hgoPositiveDirection, hgoHueCorrection, hgoLightnessCorrection]);
461     ciGSBNegative: result := TBGRAHueGradient.Create(AColor1,AColor2,[hgoNegativeDirection, hgoHueCorrection, hgoLightnessCorrection]);
462   end;
463   result.Repetition := ARepetition;
464 end;
465 
TBGRASimpleGradient.CreateAnynull466 class function TBGRASimpleGradient.CreateAny(AInterpolation: TBGRAColorInterpolation;
467   AColor1, AColor2: TExpandedPixel; ARepetition: TBGRAGradientRepetition): TBGRASimpleGradient;
468 begin
469   case AInterpolation of
470     ciStdRGB: result := TBGRASimpleGradientWithoutGammaCorrection.Create(AColor1,AColor2);
471     ciLinearRGB: result := TBGRASimpleGradientWithGammaCorrection.Create(AColor1,AColor2);
472     ciLinearHSLPositive: result := TBGRAHueGradient.Create(AColor1,AColor2,[hgoPositiveDirection]);
473     ciLinearHSLNegative: result := TBGRAHueGradient.Create(AColor1,AColor2,[hgoNegativeDirection]);
474     ciGSBPositive: result := TBGRAHueGradient.Create(AColor1,AColor2,[hgoPositiveDirection, hgoHueCorrection, hgoLightnessCorrection]);
475     ciGSBNegative: result := TBGRAHueGradient.Create(AColor1,AColor2,[hgoNegativeDirection, hgoHueCorrection, hgoLightnessCorrection]);
476   end;
477   result.Repetition := ARepetition;
478 end;
479 
TBGRASimpleGradient.GetAverageColornull480 function TBGRASimpleGradient.GetAverageColor: TBGRAPixel;
481 begin
482   result := InterpolateToBGRA(32768);
483 end;
484 
TBGRASimpleGradient.GetAverageExpandedColornull485 function TBGRASimpleGradient.GetAverageExpandedColor: TExpandedPixel;
486 begin
487   Result:= InterpolateToExpanded(32768);
488 end;
489 
TBGRASimpleGradient.GetColorAtnull490 function TBGRASimpleGradient.GetColorAt(position: integer): TBGRAPixel;
491 begin
492   case FRepetition of
493   grSine: begin
494             position := Sin65536(position and $ffff);
495             if position = 65536 then
496               result := FColor2
497             else
498               result := InterpolateToBGRA(position);
499           end;
500   grRepeat: result := InterpolateToBGRA(position and $ffff);
501   grReflect:
502     begin
503       position := position and $1ffff;
504       if position >= $10000 then
505       begin
506         if position = $10000 then
507           result := FColor2
508         else
509           result := InterpolateToBGRA($20000 - position);
510       end
511       else
512         result := InterpolateToBGRA(position);
513     end;
514   else
515     begin
516       if position <= 0 then
517         result := FColor1 else
518       if position >= 65536 then
519         result := FColor2 else
520         result := InterpolateToBGRA(position);
521     end;
522   end;
523 end;
524 
TBGRASimpleGradient.GetColorAtFnull525 function TBGRASimpleGradient.GetColorAtF(position: single): TBGRAPixel;
526 begin
527   if position = EmptySingle then result := BGRAPixelTransparent else
528   if FRepetition <> grPad then
529     result := GetColorAt(round(frac(position*0.5)*131072)) else  //divided by 2 for reflected repetition
530   begin
531     if position <= 0 then
532       result := FColor1 else
533     if position >= 1 then
534       result := FColor2 else
535       result := GetColorAt(round(position*65536));
536   end;
537 end;
538 
GetExpandedColorAtnull539 function TBGRASimpleGradient.GetExpandedColorAt(position: integer
540   ): TExpandedPixel;
541 begin
542   case FRepetition of
543   grSine: begin
544             position := Sin65536(position and $ffff);
545             if position = 65536 then
546               result := ec2
547             else
548               result := InterpolateToExpanded(position);
549           end;
550   grRepeat: result := InterpolateToExpanded(position and $ffff);
551   grReflect:
552     begin
553       position := position and $1ffff;
554       if position >= $10000 then
555       begin
556         if position = $10000 then
557           result := ec2
558         else
559           result := InterpolateToExpanded($20000 - position);
560       end
561       else
562         result := InterpolateToExpanded(position);
563     end;
564   else
565     begin
566       if position <= 0 then
567         result := ec1 else
568       if position >= 65536 then
569         result := ec2 else
570         result := InterpolateToExpanded(position);
571     end;
572   end;
573 end;
574 
GetExpandedColorAtFnull575 function TBGRASimpleGradient.GetExpandedColorAtF(position: single
576   ): TExpandedPixel;
577 begin
578   if position = EmptySingle then result := BGRAPixelTransparent else
579   if FRepetition <> grPad then
580     result := GetExpandedColorAt(round(frac(position*0.5)*131072)) else  //divided by 2 for reflected repetition
581   begin
582     if position <= 0 then
583       result := ec1 else
584     if position >= 1 then
585       result := ec2 else
586       result := GetExpandedColorAt(round(position*65536));
587   end;
588 end;
589 
GetMonochromenull590 function TBGRASimpleGradient.GetMonochrome: boolean;
591 begin
592   Result:= (FColor1 = FColor2);
593 end;
594 
595 { TBGRAConstantScanner }
596 
597 constructor TBGRAConstantScanner.Create(c: TBGRAPixel);
598 begin
599   inherited Create(c,c,gtLinear,PointF(0,0),PointF(0,0),false);
600 end;
601 
602 { TBGRARandomScanner }
603 
604 constructor TBGRARandomScanner.Create(AGrayscale: Boolean; AOpacity: byte);
605 begin
606   FGrayscale:= AGrayscale;
607   FOpacity:= AOpacity;
608   FRandomBufferCount := 0;
609 end;
610 
ScanAtIntegernull611 function TBGRARandomScanner.ScanAtInteger(X, Y: integer): TBGRAPixel;
612 begin
613   Result:=ScanNextPixel;
614 end;
615 
ScanNextPixelnull616 function TBGRARandomScanner.ScanNextPixel: TBGRAPixel;
617 var rgb: integer;
618 begin
619   if FGrayscale then
620   begin
621     if FRandomBufferCount = 0 then
622     begin
623       FRandomBuffer := random(256*256*256);
624       FRandomBufferCount := 3;
625     end;
626     result.red := FRandomBuffer and 255;
627     FRandomBuffer:= FRandomBuffer shr 8;
628     dec(FRandomBufferCount);
629     result.green := result.red;
630     result.blue := result.red;
631     result.alpha:= FOpacity;
632   end else
633   begin
634     rgb := random(256*256*256);
635     Result:= BGRA(rgb and 255,(rgb shr 8) and 255,(rgb shr 16) and 255,FOpacity);
636   end;
637 end;
638 
ScanAtnull639 function TBGRARandomScanner.ScanAt(X, Y: Single): TBGRAPixel;
640 begin
641   Result:=ScanNextPixel;
642 end;
643 
644 { TBGRAHueGradient }
645 
646 procedure TBGRAHueGradient.Init(c1, c2: THSLAPixel; AOptions: THueGradientOptions);
647 begin
648   FOptions:= AOptions;
649   if (hgoLightnessCorrection in AOptions) then
650   begin
651     hsla1 := ExpandedToGSBA(ec1);
652     hsla2 := ExpandedToGSBA(ec2);
653   end else
654   begin
655     hsla1 := c1;
656     hsla2 := c2;
657   end;
658   if not (hgoHueCorrection in AOptions) then
659   begin
660     hue1 := c1.hue;
661     hue2 := c2.hue;
662   end else
663   begin
664     hue1 := HtoG(c1.hue);
665     hue2 := HtoG(c2.hue);
666   end;
667   if (hgoPositiveDirection in AOptions) and not (hgoNegativeDirection in AOptions) then
668   begin
669     if c2.hue <= c1.hue then inc(hue2, 65536);
670   end else
671   if not (hgoPositiveDirection in AOptions) and (hgoNegativeDirection in AOptions) then
672   begin
673     if c2.hue >= c1.hue then inc(hue1, 65536);
674   end;
675 end;
676 
TBGRAHueGradient.InterpolateToHSLAnull677 function TBGRAHueGradient.InterpolateToHSLA(position: word): THSLAPixel;
678 var b,b2: LongWord;
679 begin
680   b      := position shr 2;
681   b2     := 16384-b;
682   result.hue := ((hue1 * b2 + hue2 * b + 8191) shr 14) and $ffff;
683   result.saturation := (hsla1.saturation * b2 + hsla2.saturation * b + 8191) shr 14;
684   result.lightness := (hsla1.lightness * b2 + hsla2.lightness * b + 8191) shr 14;
685   result.alpha := (hsla1.alpha * b2 + hsla2.alpha * b + 8191) shr 14;
686   if hgoLightnessCorrection in FOptions then
687   begin
688     if not (hgoHueCorrection in FOptions) then
689       result.hue := HtoG(result.hue);
690   end else
691   begin
692     if hgoHueCorrection in FOptions then
693       result.hue := GtoH(result.hue);
694   end;
695 end;
696 
TBGRAHueGradient.InterpolateToBGRAnull697 function TBGRAHueGradient.InterpolateToBGRA(position: word): TBGRAPixel;
698 begin
699   if hgoLightnessCorrection in FOptions then
700     result := GSBAToBGRA(InterpolateToHSLA(position))
701   else
702     result := HSLAToBGRA(InterpolateToHSLA(position));
703 end;
704 
InterpolateToExpandednull705 function TBGRAHueGradient.InterpolateToExpanded(position: word): TExpandedPixel;
706 begin
707   if hgoLightnessCorrection in FOptions then
708     result := GSBAToExpanded(InterpolateToHSLA(position))
709   else
710     result := HSLAToExpanded(InterpolateToHSLA(position));
711 end;
712 
713 constructor TBGRAHueGradient.Create(Color1, Color2: TBGRAPixel;options: THueGradientOptions);
714 begin
715   if hgoReflect in options then
716     inherited Create(Color1,Color2,grReflect)
717   else if hgoRepeat in options then
718     inherited Create(Color1,Color2,grRepeat)
719   else
720     inherited Create(Color1,Color2,grPad);
721 
722   Init(BGRAToHSLA(Color1),BGRAToHSLA(Color2),options);
723 end;
724 
725 constructor TBGRAHueGradient.Create(Color1, Color2: TExpandedPixel;
726   options: THueGradientOptions);
727 begin
728   if hgoReflect in options then
729     inherited Create(Color1,Color2,grReflect)
730   else if hgoRepeat in options then
731     inherited Create(Color1,Color2,grRepeat)
732   else
733     inherited Create(Color1,Color2,grPad);
734 
735   Init(ExpandedToHSLA(Color1),ExpandedToHSLA(Color2),options);
736 end;
737 
738 constructor TBGRAHueGradient.Create(Color1, Color2: THSLAPixel; options: THueGradientOptions);
739 begin
740   if hgoReflect in options then
741     inherited Create(Color1.ToExpanded,Color2.ToExpanded,grReflect)
742   else if hgoRepeat in options then
743     inherited Create(Color1.ToExpanded,Color2.ToExpanded,grRepeat)
744   else
745     inherited Create(Color1.ToExpanded,Color2.ToExpanded,grPad);
746 
747   Init(Color1,Color2, options);
748 end;
749 
750 constructor TBGRAHueGradient.Create(AHue1, AHue2: Word; Saturation,
751   Lightness: Word; options: THueGradientOptions);
752 begin
753   Create(HSLA(AHue1,saturation,lightness), HSLA(AHue2,saturation,lightness), options);
754 end;
755 
TBGRAHueGradient.GetMonochromenull756 function TBGRAHueGradient.GetMonochrome: boolean;
757 begin
758   Result:= false;
759 end;
760 
761 { TBGRAMultiGradient }
762 
763 procedure TBGRAMultiGradient.Init(Colors: array of TBGRAPixel;
764   Positions0To1: array of single; AGammaCorrection, ACycle: boolean);
765 var
766   i: Integer;
767 begin
768   if length(Positions0To1) <> length(colors) then
769     raise Exception.Create('Dimension mismatch');
770   if length(Positions0To1) = 0 then
771     raise Exception.Create('Empty gradient');
772   setlength(FColors,length(Colors));
773   setlength(FPositions,length(Positions0To1));
774   setlength(FPositionsF,length(Positions0To1));
775   setlength(FEColors,length(Colors));
776   for i := 0 to high(colors) do
777   begin
778     FColors[i]:= colors[i];
779     FPositions[i]:= round(Positions0To1[i]*65536);
780     FPositionsF[i]:= Positions0To1[i];
781     FEColors[i]:= GammaExpansion(colors[i]);
782   end;
783   GammaCorrection := AGammaCorrection;
784   FCycle := ACycle;
785   if FPositions[high(FPositions)] = FPositions[0] then FCycle := false;
786 end;
787 
CosineInterpolationnull788 function TBGRAMultiGradient.CosineInterpolation(t: single): single;
789 begin
790   result := (1-cos(t*Pi))*0.5;
791 end;
792 
HalfCosineInterpolationnull793 function TBGRAMultiGradient.HalfCosineInterpolation(t: single): single;
794 begin
795   result := (1-cos(t*Pi))*0.25 + t*0.5;
796 end;
797 
798 constructor TBGRAMultiGradient.Create(Colors: array of TBGRAPixel;
799   Positions0To1: array of single; AGammaCorrection: boolean; ACycle: boolean);
800 begin
801   Init(Colors,Positions0To1,AGammaCorrection, ACycle);
802 end;
803 
TBGRAMultiGradient.GetColorAtnull804 function TBGRAMultiGradient.GetColorAt(position: integer): TBGRAPixel;
805 var i: Int32or64;
806     ec: TExpandedPixel;
807     curPos,posDiff: Int32or64;
808 begin
809   if FCycle then
810     position := (position-FPositions[0]) mod (FPositions[high(FPositions)] - FPositions[0]) + FPositions[0];
811   if position <= FPositions[0] then
812     result := FColors[0] else
813   if position >= FPositions[high(FPositions)] then
814     result := FColors[high(FColors)] else
815   begin
816     i := 0;
817     while (i < high(FPositions)-1) and (position >= FPositions[i+1]) do
818       inc(i);
819 
820     if Position = FPositions[i] then
821       result := FColors[i]
822     else
823     begin
824       curPos := position-FPositions[i];
825       posDiff := FPositions[i+1]-FPositions[i];
826       if FInterpolationFunction <> nil then
827       begin
828         curPos := round(FInterpolationFunction(curPos/posDiff)*65536);
829         posDiff := 65536;
830       end;
831       if GammaCorrection then
832       begin
833         if FEColors[i+1].red < FEColors[i].red then
834           ec.red := FEColors[i].red - UInt32or64(curPos)*UInt32or64(FEColors[i].red-FEColors[i+1].red) div UInt32or64(posDiff) else
835           ec.red := FEColors[i].red + UInt32or64(curPos)*UInt32or64(FEColors[i+1].red-FEColors[i].red) div UInt32or64(posDiff);
836         if FEColors[i+1].green < FEColors[i].green then
837           ec.green := FEColors[i].green - UInt32or64(curPos)*UInt32or64(FEColors[i].green-FEColors[i+1].green) div UInt32or64(posDiff) else
838           ec.green := FEColors[i].green + UInt32or64(curPos)*UInt32or64(FEColors[i+1].green-FEColors[i].green) div UInt32or64(posDiff);
839         if FEColors[i+1].blue < FEColors[i].blue then
840           ec.blue := FEColors[i].blue - UInt32or64(curPos)*UInt32or64(FEColors[i].blue-FEColors[i+1].blue) div UInt32or64(posDiff) else
841           ec.blue := FEColors[i].blue + UInt32or64(curPos)*UInt32or64(FEColors[i+1].blue-FEColors[i].blue) div UInt32or64(posDiff);
842         if FEColors[i+1].alpha < FEColors[i].alpha then
843           ec.alpha := FEColors[i].alpha - UInt32or64(curPos)*UInt32or64(FEColors[i].alpha-FEColors[i+1].alpha) div UInt32or64(posDiff) else
844           ec.alpha := FEColors[i].alpha + UInt32or64(curPos)*UInt32or64(FEColors[i+1].alpha-FEColors[i].alpha) div UInt32or64(posDiff);
845         result := GammaCompression(ec);
846       end else
847       begin
848         result.red := FColors[i].red + (curPos)*(FColors[i+1].red-FColors[i].red) div (posDiff);
849         result.green := FColors[i].green + (curPos)*(FColors[i+1].green-FColors[i].green) div (posDiff);
850         result.blue := FColors[i].blue + (curPos)*(FColors[i+1].blue-FColors[i].blue) div (posDiff);
851         result.alpha := FColors[i].alpha + (curPos)*(FColors[i+1].alpha-FColors[i].alpha) div (posDiff);
852       end;
853     end;
854   end;
855 end;
856 
GetExpandedColorAtnull857 function TBGRAMultiGradient.GetExpandedColorAt(position: integer
858   ): TExpandedPixel;
859 var i: Int32or64;
860     curPos,posDiff: Int32or64;
861     rw,gw,bw: UInt32or64;
862 begin
863   if FCycle then
864     position := (position-FPositions[0]) mod (FPositions[high(FPositions)] - FPositions[0]) + FPositions[0];
865   if position <= FPositions[0] then
866     result := FEColors[0] else
867   if position >= FPositions[high(FPositions)] then
868     result := FEColors[high(FColors)] else
869   begin
870     i := 0;
871     while (i < high(FPositions)-1) and (position >= FPositions[i+1]) do
872       inc(i);
873 
874     if Position = FPositions[i] then
875       result := FEColors[i]
876     else
877     begin
878       curPos := position-FPositions[i];
879       posDiff := FPositions[i+1]-FPositions[i];
880       if FInterpolationFunction <> nil then
881       begin
882         curPos := round(FInterpolationFunction(curPos/posDiff)*65536);
883         posDiff := 65536;
884       end;
885       if GammaCorrection then
886       begin
887         if FEColors[i+1].red < FEColors[i].red then
888           result.red := FEColors[i].red - UInt32or64(curPos)*UInt32or64(FEColors[i].red-FEColors[i+1].red) div UInt32or64(posDiff) else
889           result.red := FEColors[i].red + UInt32or64(curPos)*UInt32or64(FEColors[i+1].red-FEColors[i].red) div UInt32or64(posDiff);
890         if FEColors[i+1].green < FEColors[i].green then
891           result.green := FEColors[i].green - UInt32or64(curPos)*UInt32or64(FEColors[i].green-FEColors[i+1].green) div UInt32or64(posDiff) else
892           result.green := FEColors[i].green + UInt32or64(curPos)*UInt32or64(FEColors[i+1].green-FEColors[i].green) div UInt32or64(posDiff);
893         if FEColors[i+1].blue < FEColors[i].blue then
894           result.blue := FEColors[i].blue - UInt32or64(curPos)*UInt32or64(FEColors[i].blue-FEColors[i+1].blue) div UInt32or64(posDiff) else
895           result.blue := FEColors[i].blue + UInt32or64(curPos)*UInt32or64(FEColors[i+1].blue-FEColors[i].blue) div UInt32or64(posDiff);
896         if FEColors[i+1].alpha < FEColors[i].alpha then
897           result.alpha := FEColors[i].alpha - UInt32or64(curPos)*UInt32or64(FEColors[i].alpha-FEColors[i+1].alpha) div UInt32or64(posDiff) else
898           result.alpha := FEColors[i].alpha + UInt32or64(curPos)*UInt32or64(FEColors[i+1].alpha-FEColors[i].alpha) div UInt32or64(posDiff);
899       end else
900       begin
901         rw := Int32or64(FColors[i].red shl 8) + (((curPos) shl 8)*(FColors[i+1].red-FColors[i].red)) div (posDiff);
902         gw := Int32or64(FColors[i].green shl 8) + (((curPos) shl 8)*(FColors[i+1].green-FColors[i].green)) div (posDiff);
903         bw := Int32or64(FColors[i].blue shl 8) + (((curPos) shl 8)*(FColors[i+1].blue-FColors[i].blue)) div (posDiff);
904 
905         if rw >= $ff00 then result.red := $ffff
906         else result.red := (GammaExpansionTab[rw shr 8]*UInt32or64(255 - (rw and 255)) + GammaExpansionTab[(rw shr 8)+1]*UInt32or64(rw and 255)) shr 8;
907         if gw >= $ff00 then result.green := $ffff
908         else result.green := (GammaExpansionTab[gw shr 8]*UInt32or64(255 - (gw and 255)) + GammaExpansionTab[(gw shr 8)+1]*UInt32or64(gw and 255)) shr 8;
909         if bw >= $ff00 then result.blue := $ffff
910         else result.blue := (GammaExpansionTab[bw shr 8]*UInt32or64(255 - (bw and 255)) + GammaExpansionTab[(bw shr 8)+1]*UInt32or64(bw and 255)) shr 8;
911         result.alpha := Int32or64(FColors[i].alpha shl 8) + (((curPos) shl 8)*(FColors[i+1].alpha-FColors[i].alpha)) div (posDiff);
912         result.alpha := result.alpha + (result.alpha shr 8);
913       end;
914     end;
915   end;
916 end;
917 
TBGRAMultiGradient.GetAverageColornull918 function TBGRAMultiGradient.GetAverageColor: TBGRAPixel;
919 var sumR,sumG,sumB,sumA: integer;
920   i: Integer;
921 begin
922   sumR := 0;
923   sumG := 0;
924   sumB := 0;
925   sumA := 0;
926   for i := 0 to high(FColors) do
927   begin
928     inc(sumR, FColors[i].red);
929     inc(sumG, FColors[i].green);
930     inc(sumB, FColors[i].blue);
931     inc(sumA, FColors[i].alpha);
932   end;
933   result := BGRA(sumR div length(FColors),sumG div length(FColors),
934     sumB div length(FColors),sumA div length(FColors));
935 end;
936 
GetMonochromenull937 function TBGRAMultiGradient.GetMonochrome: boolean;
938 var i: integer;
939 begin
940   for i := 1 to high(FColors) do
941     if FColors[i] <> FColors[0] then
942     begin
943       result := false;
944       exit;
945     end;
946   Result:= true;
947 end;
948 
949 { TBGRASimpleGradientWithGammaCorrection }
950 
TBGRASimpleGradientWithGammaCorrection.InterpolateToBGRAnull951 function TBGRASimpleGradientWithGammaCorrection.InterpolateToBGRA(position: word
952   ): TBGRAPixel;
953 var b,b2: LongWord;
954     ec: TExpandedPixel;
955 begin
956   b      := position;
957   b2     := 65536-b;
958   ec.red := (ec1.red * b2 + ec2.red * b + 32767) shr 16;
959   ec.green := (ec1.green * b2 + ec2.green * b + 32767) shr 16;
960   ec.blue := (ec1.blue * b2 + ec2.blue * b + 32767) shr 16;
961   ec.alpha := (ec1.alpha * b2 + ec2.alpha * b + 32767) shr 16;
962   result := GammaCompression(ec);
963 end;
964 
TBGRASimpleGradientWithGammaCorrection.InterpolateToExpandednull965 function TBGRASimpleGradientWithGammaCorrection.InterpolateToExpanded(
966   position: word): TExpandedPixel;
967 var b,b2: LongWord;
968 begin
969   b      := position;
970   b2     := 65536-b;
971   result.red := (ec1.red * b2 + ec2.red * b + 32767) shr 16;
972   result.green := (ec1.green * b2 + ec2.green * b + 32767) shr 16;
973   result.blue := (ec1.blue * b2 + ec2.blue * b + 32767) shr 16;
974   result.alpha := (ec1.alpha * b2 + ec2.alpha * b + 32767) shr 16;
975 end;
976 
977 constructor TBGRASimpleGradientWithGammaCorrection.Create(Color1,
978   Color2: TBGRAPixel; ARepetition: TBGRAGradientRepetition);
979 begin
980   inherited Create(Color1,Color2,ARepetition);
981 end;
982 
983 constructor TBGRASimpleGradientWithGammaCorrection.Create(Color1,
984   Color2: TExpandedPixel; ARepetition: TBGRAGradientRepetition);
985 begin
986   inherited Create(Color1,Color2,ARepetition);
987 end;
988 
989 { TBGRASimpleGradientWithoutGammaCorrection }
990 
TBGRASimpleGradientWithoutGammaCorrection.InterpolateToBGRAnull991 function TBGRASimpleGradientWithoutGammaCorrection.InterpolateToBGRA(
992   position: word): TBGRAPixel;
993 var b,b2: LongWord;
994 begin
995   b      := position shr 6;
996   b2     := 1024-b;
997   result.red  := (FColor1.red * b2 + FColor2.red * b + 511) shr 10;
998   result.green := (FColor1.green * b2 + FColor2.green * b + 511) shr 10;
999   result.blue := (FColor1.blue * b2 + FColor2.blue * b + 511) shr 10;
1000   result.alpha := (FColor1.alpha * b2 + FColor2.alpha * b + 511) shr 10;
1001 end;
1002 
TBGRASimpleGradientWithoutGammaCorrection.InterpolateToExpandednull1003 function TBGRASimpleGradientWithoutGammaCorrection.InterpolateToExpanded(
1004   position: word): TExpandedPixel;
1005 var b,b2: LongWord;
1006     rw,gw,bw: word;
1007 begin
1008   b      := position shr 6;
1009   b2     := 1024-b;
1010   rw  := (FColor1.red * b2 + FColor2.red * b + 511) shr 2;
1011   gw := (FColor1.green * b2 + FColor2.green * b + 511) shr 2;
1012   bw := (FColor1.blue * b2 + FColor2.blue * b + 511) shr 2;
1013 
1014   if rw >= $ff00 then
1015     result.red := 65535
1016   else
1017     result.red := (GammaExpansionTab[rw shr 8]*UInt32or64(255 - (rw and 255)) + GammaExpansionTab[(rw shr 8)+1]*UInt32or64(rw and 255)) shr 8;
1018 
1019   if gw >= $ff00 then
1020     result.green := 65535
1021   else
1022     result.green := (GammaExpansionTab[gw shr 8]*UInt32or64(255 - (gw and 255)) + GammaExpansionTab[(gw shr 8)+1]*UInt32or64(gw and 255)) shr 8;
1023 
1024   if bw >= $ff00 then
1025     result.blue := 65535
1026   else
1027     result.blue := (GammaExpansionTab[bw shr 8]*UInt32or64(255 - (bw and 255)) + GammaExpansionTab[(bw shr 8)+1]*UInt32or64(bw and 255)) shr 8;
1028 
1029   result.alpha := (FColor1.alpha * b2 + FColor2.alpha * b + 511) shr 2;
1030 end;
1031 
1032 constructor TBGRASimpleGradientWithoutGammaCorrection.Create(Color1,
1033   Color2: TBGRAPixel; ARepetition: TBGRAGradientRepetition);
1034 begin
1035   inherited Create(Color1,Color2,ARepetition);
1036 end;
1037 
1038 constructor TBGRASimpleGradientWithoutGammaCorrection.Create(Color1,
1039   Color2: TExpandedPixel; ARepetition: TBGRAGradientRepetition);
1040 begin
1041   inherited Create(Color1,Color2,ARepetition);
1042 end;
1043 
1044 { TBGRAGradientTriangleScanner }
1045 
1046 constructor TBGRAGradientTriangleScanner.Create(pt1, pt2, pt3: TPointF; c1, c2,
1047   c3: TBGRAPixel);
1048 var ec1,ec2,ec3: TExpandedPixel;
1049 begin
1050   FMatrix := AffineMatrix(pt2.X-pt1.X, pt3.X-pt1.X, 0,
1051                           pt2.Y-pt1.Y, pt3.Y-pt1.Y, 0);
1052   if not IsAffineMatrixInversible(FMatrix) then
1053     FMatrix := AffineMatrix(0,0,0,0,0,0)
1054   else
1055     FMatrix := AffineMatrixInverse(FMatrix) * AffineMatrixTranslation(-pt1.x,-pt1.y);
1056 
1057   ec1 := GammaExpansion(c1);
1058   ec2 := GammaExpansion(c2);
1059   ec3 := GammaExpansion(c3);
1060   FColor1[1] := ec1.red;
1061   FColor1[2] := ec1.green;
1062   FColor1[3] := ec1.blue;
1063   FColor1[4] := ec1.alpha;
1064   FDiff2[1] := ec2.red - ec1.red;
1065   FDiff2[2] := ec2.green - ec1.green;
1066   FDiff2[3] := ec2.blue - ec1.blue;
1067   FDiff2[4] := ec2.alpha - ec1.alpha;
1068   FDiff3[1] := ec3.red - ec1.red;
1069   FDiff3[2] := ec3.green - ec1.green;
1070   FDiff3[3] := ec3.blue - ec1.blue;
1071   FDiff3[4] := ec3.alpha - ec1.alpha;
1072   FStep := FDiff2*FMatrix[1,1]+FDiff3*FMatrix[2,1];
1073 end;
1074 
1075 procedure TBGRAGradientTriangleScanner.ScanMoveTo(X, Y: Integer);
1076 begin
1077   ScanMoveToF(X, Y);
1078 end;
1079 
1080 procedure TBGRAGradientTriangleScanner.ScanMoveToF(X, Y: Single);
1081 var
1082   Cur: TPointF;
1083 begin
1084   Cur := FMatrix*PointF(X,Y);
1085   FCurColor := FColor1+FDiff2*Cur.X+FDiff3*Cur.Y;
1086 end;
1087 
ScanAtnull1088 function TBGRAGradientTriangleScanner.ScanAt(X, Y: Single): TBGRAPixel;
1089 begin
1090   ScanMoveToF(X,Y);
1091   result := ScanNextPixel;
1092 end;
1093 
TBGRAGradientTriangleScanner.ScanNextPixelnull1094 function TBGRAGradientTriangleScanner.ScanNextPixel: TBGRAPixel;
1095 var r,g,b,a: int64;
1096 begin
1097   r := round(FCurColor[1]);
1098   g := round(FCurColor[2]);
1099   b := round(FCurColor[3]);
1100   a := round(FCurColor[4]);
1101   if r > 65535 then r := 65535 else
1102   if r < 0 then r := 0;
1103   if g > 65535 then g := 65535 else
1104   if g < 0 then g := 0;
1105   if b > 65535 then b := 65535 else
1106   if b < 0 then b := 0;
1107   if a > 65535 then a := 65535 else
1108   if a < 0 then a := 0;
1109   result.red := GammaCompressionTab[r];
1110   result.green := GammaCompressionTab[g];
1111   result.blue := GammaCompressionTab[b];
1112   result.alpha := a shr 8;
1113   FCurColor := FCurColor + FStep;
1114 end;
1115 
ScanNextExpandedPixelnull1116 function TBGRAGradientTriangleScanner.ScanNextExpandedPixel: TExpandedPixel;
1117 var r,g,b,a: int64;
1118 begin
1119   r := round(FCurColor[1]);
1120   g := round(FCurColor[2]);
1121   b := round(FCurColor[3]);
1122   a := round(FCurColor[4]);
1123   if r > 65535 then r := 65535 else
1124   if r < 0 then r := 0;
1125   if g > 65535 then g := 65535 else
1126   if g < 0 then g := 0;
1127   if b > 65535 then b := 65535 else
1128   if b < 0 then b := 0;
1129   if a > 65535 then a := 65535 else
1130   if a < 0 then a := 0;
1131   result.red := r;
1132   result.green := g;
1133   result.blue := b;
1134   result.alpha := a;
1135   FCurColor := FCurColor + FStep;
1136 end;
1137 
1138 procedure TBGRAGradientTriangleScanner.ScanSkipPixels(ACount: integer);
1139 begin
1140   FCurColor := FCurColor + FStep*ACount;
1141 end;
1142 
1143 { TBGRAGradientScanner }
1144 
1145 procedure TBGRAGradientScanner.SetTransform(AValue: TAffineMatrix);
1146 begin
1147   if FTransform=AValue then Exit;
1148   FTransform:=AValue;
1149   InitTransform;
1150 end;
1151 
1152 constructor TBGRAGradientScanner.Create(AGradientType: TGradientType; AOrigin, d1: TPointF);
1153 begin
1154   FGradient := nil;
1155   SetGradient(BGRABlack,BGRAWhite,False);
1156   Init(AGradientType,AOrigin,d1,AffineMatrixIdentity,False);
1157 end;
1158 
1159 constructor TBGRAGradientScanner.Create(AGradientType: TGradientType; AOrigin, d1,d2: TPointF);
1160 begin
1161   FGradient := nil;
1162   SetGradient(BGRABlack,BGRAWhite,False);
1163   Init(AGradientType,AOrigin,d1,d2,AffineMatrixIdentity,False);
1164 end;
1165 
1166 constructor TBGRAGradientScanner.Create(AOrigin,
1167   d1, d2, AFocal: TPointF; ARadiusRatio: single; AFocalRadiusRatio: single);
1168 var
1169   m, mInv: TAffineMatrix;
1170   focalInv: TPointF;
1171 begin
1172   FGradient := nil;
1173   SetGradient(BGRABlack,BGRAWhite,False);
1174 
1175   m := AffineMatrix((d1-AOrigin).x, (d2-AOrigin).x, AOrigin.x,
1176                     (d1-AOrigin).y, (d2-AOrigin).y, AOrigin.y);
1177   if IsAffineMatrixInversible(m) then
1178   begin
1179     mInv := AffineMatrixInverse(m);
1180     focalInv := mInv*AFocal;
1181   end else
1182     focalInv := PointF(0,0);
1183 
1184   Init(PointF(0,0), ARadiusRatio, focalInv, AFocalRadiusRatio, AffineMatrixIdentity, m);
1185 end;
1186 
1187 constructor TBGRAGradientScanner.Create(AOrigin: TPointF; ARadius: single;
1188   AFocal: TPointF; AFocalRadius: single);
1189 begin
1190   FGradient := nil;
1191   SetGradient(BGRABlack,BGRAWhite,False);
1192 
1193   Init(AOrigin, ARadius, AFocal, AFocalRadius, AffineMatrixIdentity, AffineMatrixIdentity);
1194 end;
1195 
1196 procedure TBGRAGradientScanner.SetFlipGradient(AValue: boolean);
1197 begin
1198   if FFlipGradient=AValue then Exit;
1199   FFlipGradient:=AValue;
1200   UpdateGetGradientColorFunctions;
1201 end;
1202 
TBGRAGradientScanner.GetGradientColornull1203 function TBGRAGradientScanner.GetGradientColor(a: single): TBGRAPixel;
1204 begin
1205   if a = EmptySingle then
1206     result := BGRAPixelTransparent
1207   else
1208   begin
1209     if FFlipGradient then a := 1-a;
1210     if FSinus then
1211     begin
1212       a := a*65536;
1213       if (a <= low(int64)) or (a >= high(int64)) then
1214         result := FAverageColor
1215       else
1216         result := FGradient.GetColorAt(Sin65536(round(a) and 65535));
1217     end else
1218       result := FGradient.GetColorAtF(a);
1219   end;
1220 end;
1221 
GetGradientExpandedColornull1222 function TBGRAGradientScanner.GetGradientExpandedColor(a: single): TExpandedPixel;
1223 begin
1224   if a = EmptySingle then
1225     QWord(result) := 0
1226   else
1227   begin
1228     if FFlipGradient then a := 1-a;
1229     if FSinus then
1230     begin
1231       a := a * 65536;
1232       if (a <= low(int64)) or (a >= high(int64)) then
1233         result := FAverageExpandedColor
1234       else
1235         result := FGradient.GetExpandedColorAt(Sin65536(round(a) and 65535));
1236     end else
1237       result := FGradient.GetExpandedColorAtF(a);
1238   end;
1239 end;
1240 
TBGRAGradientScanner.GetGradientColorFlippednull1241 function TBGRAGradientScanner.GetGradientColorFlipped(a: single): TBGRAPixel;
1242 begin
1243   result := FGradient.GetColorAtF(1 - a);
1244 end;
1245 
GetGradientExpandedColorFlippednull1246 function TBGRAGradientScanner.GetGradientExpandedColorFlipped(a: single): TExpandedPixel;
1247 begin
1248   result := FGradient.GetExpandedColorAtF(1 - a);
1249 end;
1250 
GetGradientColorSinusnull1251 function TBGRAGradientScanner.GetGradientColorSinus(a: single): TBGRAPixel;
1252 begin
1253   if FFlipGradient then a := 1-a;
1254   a := a * 65536;
1255   if (a <= low(int64)) or (a >= high(int64)) then
1256     result := FAverageColor
1257     else result := FGradient.GetColorAt(Sin65536(round(a) and 65535));
1258 end;
1259 
TBGRAGradientScanner.GetGradientExpandedColorSinusnull1260 function TBGRAGradientScanner.GetGradientExpandedColorSinus(a: single): TExpandedPixel;
1261 begin
1262   if FFlipGradient then a := 1-a;
1263   a := a * 65536;
1264   if (a <= low(int64)) or (a >= high(int64)) then
1265     result := FAverageExpandedColor
1266     else result := FGradient.GetExpandedColorAt(Sin65536(round(a) and 65535));
1267 end;
1268 
1269 procedure TBGRAGradientScanner.UpdateGetGradientColorFunctions;
1270 begin
1271   if FSinus then
1272   begin
1273     FGetGradientColor:= @GetGradientColorSinus;
1274     FGetGradientExpandedColor:= @GetGradientExpandedColorSinus;
1275   end else
1276   if FFlipGradient then
1277   begin
1278     FGetGradientColor:= @GetGradientColorFlipped;
1279     FGetGradientExpandedColor:= @GetGradientExpandedColorFlipped;
1280   end else
1281   begin
1282     FGetGradientColor:= @FGradient.GetColorAtF;
1283     FGetGradientExpandedColor:= @FGradient.GetExpandedColorAtF;
1284   end;
1285 end;
1286 
1287 procedure TBGRAGradientScanner.SetSinus(AValue: boolean);
1288 begin
1289   if FSinus=AValue then Exit;
1290   FSinus:=AValue;
1291   UpdateGetGradientColorFunctions;
1292 end;
1293 
1294 procedure TBGRAGradientScanner.Init(AGradientType: TGradientType; AOrigin, d1: TPointF;
1295   ATransform: TAffineMatrix; Sinus: Boolean);
1296 var d2: TPointF;
1297 begin
1298   with (d1-AOrigin) do
1299     d2 := PointF(AOrigin.x+y,AOrigin.y-x);
1300   Init(AGradientType,AOrigin,d1,d2,ATransform,Sinus);
1301 end;
1302 
1303 procedure TBGRAGradientScanner.Init(AGradientType: TGradientType; AOrigin, d1, d2: TPointF;
1304   ATransform: TAffineMatrix; Sinus: Boolean);
1305 begin
1306   FGradientType:= AGradientType;
1307   FFlipGradient:= false;
1308   FOrigin := AOrigin;
1309   FDir1 := d1;
1310   FDir2 := d2;
1311   FSinus := Sinus;
1312   FTransform := ATransform;
1313   FHiddenTransform := AffineMatrixIdentity;
1314 
1315   FRadius := 1;
1316   FRelativeFocal := PointF(0,0);
1317   FFocalRadius := 0;
1318 
1319   InitGradientType;
1320   InitTransform;
1321   UpdateGetGradientColorFunctions;
1322 end;
1323 
1324 procedure TBGRAGradientScanner.Init(AOrigin: TPointF; ARadius: single;
1325   AFocal: TPointF; AFocalRadius: single; ATransform: TAffineMatrix; AHiddenTransform: TAffineMatrix);
1326 var maxRadius: single;
1327 begin
1328   FGradientType:= gtRadial;
1329   FFlipGradient:= false;
1330   FOrigin := AOrigin;
1331   ARadius := abs(ARadius);
1332   AFocalRadius := abs(AFocalRadius);
1333   maxRadius := max(ARadius,AFocalRadius);
1334   FDir1 := AOrigin+PointF(maxRadius,0);
1335   FDir2 := AOrigin+PointF(0,maxRadius);
1336   FSinus := False;
1337   FTransform := ATransform;
1338   FHiddenTransform := AHiddenTransform;
1339 
1340   FRadius := ARadius/maxRadius;
1341   FRelativeFocal := (AFocal - AOrigin)*(1/maxRadius);
1342   FFocalRadius := AFocalRadius/maxRadius;
1343 
1344   InitGradientType;
1345   InitTransform;
1346   UpdateGetGradientColorFunctions;
1347 end;
1348 
1349 procedure TBGRAGradientScanner.InitGradientType;
1350 begin
1351   case FGradientType of
1352     gtReflected: begin
1353       FScanNextFunc:= @ScanNextReflected;
1354       FScanAtFunc:= @ScanAtReflected;
1355     end;
1356     gtDiamond: begin
1357       FScanNextFunc:= @ScanNextDiamond;
1358       FScanAtFunc:= @ScanAtDiamond;
1359     end;
1360     gtRadial: if (FRelativeFocal.x = 0) and (FRelativeFocal.y = 0) then
1361     begin
1362       if (FFocalRadius = 0) and (FRadius = 1) then
1363       begin
1364         FScanNextFunc:= @ScanNextRadial;
1365         FScanAtFunc:= @ScanAtRadial;
1366       end else
1367       begin
1368         FScanNextFunc:= @ScanNextRadial2;
1369         FScanAtFunc:= @ScanAtRadial2;
1370       end;
1371     end else
1372     begin
1373       FScanNextFunc:= @ScanNextRadialFocal;
1374       FScanAtFunc:= @ScanAtRadialFocal;
1375 
1376       FFocalDirection := FRelativeFocal;
1377       FFocalDistance := VectLen(FFocalDirection);
1378       if FFocalDistance > 0 then FFocalDirection := FFocalDirection * (1/FFocalDistance);
1379       FFocalNormal := PointF(-FFocalDirection.y,FFocalDirection.x);
1380       FRadialDenominator := sqr(FRadius-FFocalRadius)-sqr(FFocalDistance);
1381 
1382       //case in which the second circle is bigger and the first circle is within the second
1383       if (FRadius < FFocalRadius) and (FFocalDistance <= FFocalRadius-FRadius) then
1384         FRadialDeltaSign := -1
1385       else
1386         FRadialDeltaSign := 1;
1387 
1388       //clipping afer the apex
1389       if (FFocalRadius < FRadius) and (FFocalDistance > FRadius-FFocalRadius) then
1390       begin
1391         maxW1 := FRadius/(FRadius-FFocalRadius)*FFocalDistance;
1392         maxW2 := MaxSingle;
1393       end else
1394       if (FRadius < FFocalRadius) and (FFocalDistance > FFocalRadius-FRadius) then
1395       begin
1396         maxW1 := MaxSingle;
1397         maxW2 := FFocalRadius/(FFocalRadius-FRadius)*FFocalDistance;
1398       end else
1399       begin
1400         maxW1 := MaxSingle;
1401         maxW2 := MaxSingle;
1402       end;
1403     end;
1404     gtAngular: begin
1405       FScanNextFunc:= @ScanNextAngular;
1406       FScanAtFunc:= @ScanAtAngular;
1407     end;
1408   else
1409     {gtLinear:} begin
1410       FScanNextFunc:= @ScanNextLinear;
1411       FScanAtFunc:= @ScanAtLinear;
1412     end;
1413   end;
1414 end;
1415 
1416 procedure TBGRAGradientScanner.SetGradient(c1, c2: TBGRAPixel;
1417   AGammaCorrection: boolean);
1418 begin
1419   if Assigned(FGradient) and FGradientOwner then FreeAndNil(FGradient);
1420 
1421   //transparent pixels have no color so
1422   //take it from other color
1423   if c1.alpha = 0 then c1 := BGRA(c2.red,c2.green,c2.blue,0);
1424   if c2.alpha = 0 then c2 := BGRA(c1.red,c1.green,c1.blue,0);
1425 
1426   if AGammaCorrection then
1427     FGradient := TBGRASimpleGradientWithGammaCorrection.Create(c1,c2)
1428   else
1429     FGradient := TBGRASimpleGradientWithoutGammaCorrection.Create(c1,c2);
1430   FGradientOwner := true;
1431   InitGradient;
1432 end;
1433 
1434 procedure TBGRAGradientScanner.SetGradient(AGradient: TBGRACustomGradient;
1435   AOwner: boolean);
1436 begin
1437   if Assigned(FGradient) and FGradientOwner then FreeAndNil(FGradient);
1438   FGradient := AGradient;
1439   FGradientOwner := AOwner;
1440   InitGradient;
1441 end;
1442 
1443 procedure TBGRAGradientScanner.InitTransform;
1444 var u,v: TPointF;
1445 begin
1446   u := FDir1-FOrigin;
1447   if FGradientType in[gtLinear,gtReflected] then
1448     v := PointF(u.y, -u.x)
1449   else
1450     v := FDir2-FOrigin;
1451 
1452   FMatrix := FTransform * FHiddenTransform * AffineMatrix(u.x, v.x, FOrigin.x,
1453                                                           u.y, v.y, FOrigin.y);
1454   if IsAffineMatrixInversible(FMatrix) then
1455   begin
1456     FMatrix := AffineMatrixInverse(FMatrix);
1457     FIsAverage:= false;
1458   end else
1459   begin
1460     FMatrix := AffineMatrixIdentity;
1461     FIsAverage:= true;
1462   end;
1463 
1464   case FGradientType of
1465     gtReflected: FRepeatHoriz := (FMatrix[1,1]=0);
1466     gtDiamond,gtAngular: FRepeatHoriz:= false;
1467     gtRadial: begin
1468       FRepeatHoriz:= false;
1469       if FFocalRadius = FRadius then FIsAverage:= true;
1470     end
1471   else
1472     {gtLinear:} FRepeatHoriz := (FMatrix[1,1]=0);
1473   end;
1474 
1475   if FGradient.Monochrome then
1476     FIsAverage:= true;
1477 
1478   if FIsAverage then
1479     FRepeatHoriz:= true;
1480 
1481   FPosition := PointF(0,0);
1482 end;
1483 
1484 procedure TBGRAGradientScanner.InitGradient;
1485 begin
1486   FAverageColor := FGradient.GetAverageColor;
1487   FAverageExpandedColor := FGradient.GetAverageExpandedColor;
1488   UpdateGetGradientColorFunctions;
1489 end;
1490 
ComputeRadialFocalnull1491 function TBGRAGradientScanner.ComputeRadialFocal(const p: TPointF): single;
1492 var
1493   w1,w2,num: single;
1494   h,d1,d2,delta: double;
1495 begin
1496   w1 := p*FFocalDirection;
1497   w2 := FFocalDistance-w1;
1498   if (w1 < maxW1) and (w2 < maxW2) then
1499   begin
1500     //vertical position and distances
1501     h := sqr(p*FFocalNormal);
1502     d1 := sqr(w1)+h;
1503     d2 := sqr(w2)+h;
1504     //finding t
1505     delta := sqr(FFocalRadius)*d1 + 2*FRadius*FFocalRadius*(p*(FRelativeFocal-p))+
1506              sqr(FRadius)*d2 - sqr(VectDet(p,FRelativeFocal));
1507     if delta >= 0 then
1508     begin
1509       num := -FFocalRadius*(FRadius-FFocalRadius)-(FRelativeFocal*(FRelativeFocal-p));
1510       result := (num+FRadialDeltaSign*sqrt(delta))/FRadialDenominator;
1511     end else
1512       result := EmptySingle;
1513   end else
1514     result := EmptySingle;
1515 end;
1516 
ScanNextLinearnull1517 function TBGRAGradientScanner.ScanNextLinear: single;
1518 begin
1519   result := FPosition.x;
1520 end;
1521 
ScanNextReflectednull1522 function TBGRAGradientScanner.ScanNextReflected: single;
1523 begin
1524   result := abs(FPosition.x);
1525 end;
1526 
TBGRAGradientScanner.ScanNextDiamondnull1527 function TBGRAGradientScanner.ScanNextDiamond: single;
1528 begin
1529   result := max(abs(FPosition.x), abs(FPosition.y));
1530 end;
1531 
ScanNextRadialnull1532 function TBGRAGradientScanner.ScanNextRadial: single;
1533 begin
1534   result := sqrt(sqr(FPosition.x) + sqr(FPosition.y));
1535 end;
1536 
ScanNextRadial2null1537 function TBGRAGradientScanner.ScanNextRadial2: single;
1538 begin
1539   result := (sqrt(sqr(FPosition.x) + sqr(FPosition.y))-FFocalRadius)/(FRadius-FFocalRadius);
1540 end;
1541 
TBGRAGradientScanner.ScanNextRadialFocalnull1542 function TBGRAGradientScanner.ScanNextRadialFocal: single;
1543 begin
1544   result := ComputeRadialFocal(FPosition);
1545 end;
1546 
ScanNextAngularnull1547 function TBGRAGradientScanner.ScanNextAngular: single;
1548 begin
1549   if FPosition.y >= 0 then
1550     result := arctan2(FPosition.y,FPosition.x)/(2*Pi)
1551   else
1552     result := 1-arctan2(-FPosition.y,FPosition.x)/(2*Pi)
1553 end;
1554 
ScanAtLinearnull1555 function TBGRAGradientScanner.ScanAtLinear(const p: TPointF): single;
1556 begin
1557   with (FMatrix*p) do
1558     result := x;
1559 end;
1560 
ScanAtReflectednull1561 function TBGRAGradientScanner.ScanAtReflected(const p: TPointF): single;
1562 begin
1563   with (FMatrix*p) do
1564     result := abs(x);
1565 end;
1566 
ScanAtDiamondnull1567 function TBGRAGradientScanner.ScanAtDiamond(const p: TPointF): single;
1568 begin
1569   with (FMatrix*p) do
1570     result := max(abs(x), abs(y));
1571 end;
1572 
ScanAtRadialnull1573 function TBGRAGradientScanner.ScanAtRadial(const p: TPointF): single;
1574 begin
1575   with (FMatrix*p) do
1576     result := sqrt(sqr(x) + sqr(y));
1577 end;
1578 
ScanAtRadial2null1579 function TBGRAGradientScanner.ScanAtRadial2(const p: TPointF): single;
1580 begin
1581   with (FMatrix*p) do
1582     result := (sqrt(sqr(x) + sqr(y))-FFocalRadius)/(FRadius-FFocalRadius);
1583 end;
1584 
ScanAtRadialFocalnull1585 function TBGRAGradientScanner.ScanAtRadialFocal(const p: TPointF): single;
1586 begin
1587   result := ComputeRadialFocal(FMatrix*p);
1588 end;
1589 
ScanAtAngularnull1590 function TBGRAGradientScanner.ScanAtAngular(const p: TPointF): single;
1591 begin
1592   with (FMatrix*p) do
1593   begin
1594     if y >= 0 then
1595       result := arctan2(y,x)/(2*Pi)
1596     else
1597       result := 1-arctan2(-y,x)/(2*Pi)
1598   end;
1599 end;
1600 
ScanNextInlinenull1601 function TBGRAGradientScanner.ScanNextInline: TBGRAPixel;
1602 begin
1603   result := FGetGradientColor(FScanNextFunc());
1604   FPosition.x := FPosition.x + FMatrix[1,1];
1605   FPosition.y := FPosition.y + FMatrix[2,1];
1606 end;
1607 
ScanNextExpandedInlinenull1608 function TBGRAGradientScanner.ScanNextExpandedInline: TExpandedPixel;
1609 begin
1610   result := FGetGradientExpandedColor(FScanNextFunc());
1611   FPosition.x := FPosition.x + FMatrix[1,1];
1612   FPosition.y := FPosition.y + FMatrix[2,1];
1613 end;
1614 
1615 constructor TBGRAGradientScanner.Create(c1, c2: TBGRAPixel;
1616   AGradientType: TGradientType; AOrigin, d1: TPointF; gammaColorCorrection: boolean;
1617   Sinus: Boolean);
1618 begin
1619   FGradient := nil;
1620   SetGradient(c1,c2,gammaColorCorrection);
1621   Init(AGradientType,AOrigin,d1,AffineMatrixIdentity,Sinus);
1622 end;
1623 
1624 constructor TBGRAGradientScanner.Create(c1, c2: TBGRAPixel;
1625   AGradientType: TGradientType; AOrigin, d1, d2: TPointF; gammaColorCorrection: boolean;
1626   Sinus: Boolean);
1627 begin
1628   FGradient := nil;
1629   if AGradientType in[gtLinear,gtReflected] then raise EInvalidArgument.Create('Two directions are not required for linear and reflected gradients');
1630   SetGradient(c1,c2,gammaColorCorrection);
1631   Init(AGradientType,AOrigin,d1,d2,AffineMatrixIdentity,Sinus);
1632 end;
1633 
1634 constructor TBGRAGradientScanner.Create(gradient: TBGRACustomGradient;
1635   AGradientType: TGradientType; AOrigin, d1: TPointF; Sinus: Boolean; AGradientOwner: Boolean=False);
1636 begin
1637   FGradient := gradient;
1638   FGradientOwner := AGradientOwner;
1639   InitGradient;
1640   Init(AGradientType,AOrigin,d1,AffineMatrixIdentity,Sinus);
1641 end;
1642 
1643 constructor TBGRAGradientScanner.Create(gradient: TBGRACustomGradient;
1644   AGradientType: TGradientType; AOrigin, d1, d2: TPointF; Sinus: Boolean;
1645   AGradientOwner: Boolean);
1646 begin
1647   if AGradientType in[gtLinear,gtReflected] then raise EInvalidArgument.Create('Two directions are not required for linear and reflected gradients');
1648   FGradient := gradient;
1649   FGradientOwner := AGradientOwner;
1650   InitGradient;
1651   Init(AGradientType,AOrigin,d1,d2,AffineMatrixIdentity,Sinus);
1652 end;
1653 
1654 constructor TBGRAGradientScanner.Create(gradient: TBGRACustomGradient;
1655   AOrigin: TPointF; ARadius: single; AFocal: TPointF; AFocalRadius: single;
1656   AGradientOwner: Boolean);
1657 begin
1658   FGradient := gradient;
1659   FGradientOwner := AGradientOwner;
1660   InitGradient;
1661   Init(AOrigin, ARadius, AFocal, AFocalRadius, AffineMatrixIdentity, AffineMatrixIdentity);
1662 end;
1663 
1664 destructor TBGRAGradientScanner.Destroy;
1665 begin
1666   if FGradientOwner then
1667     FGradient.Free;
1668   inherited Destroy;
1669 end;
1670 
1671 procedure TBGRAGradientScanner.ScanMoveTo(X, Y: Integer);
1672 begin
1673   FPosition := FMatrix*PointF(x,y);
1674   if FRepeatHoriz then
1675   begin
1676     if FIsAverage then
1677     begin
1678       FHorizColor := FAverageColor;
1679       FHorizExpandedColor := FAverageExpandedColor;
1680     end else
1681     begin
1682       FHorizColor := ScanNextInline;
1683       FHorizExpandedColor := ScanNextExpandedInline;
1684     end;
1685   end;
1686 end;
1687 
TBGRAGradientScanner.ScanNextPixelnull1688 function TBGRAGradientScanner.ScanNextPixel: TBGRAPixel;
1689 begin
1690   if FRepeatHoriz then
1691     result := FHorizColor
1692   else
1693     result := ScanNextInline;
1694 end;
1695 
ScanNextExpandedPixelnull1696 function TBGRAGradientScanner.ScanNextExpandedPixel: TExpandedPixel;
1697 begin
1698   if FRepeatHoriz then
1699     result := FHorizExpandedColor
1700   else
1701     result := ScanNextExpandedInline;
1702 end;
1703 
ScanAtnull1704 function TBGRAGradientScanner.ScanAt(X, Y: Single): TBGRAPixel;
1705 begin
1706   if FIsAverage then
1707     result := FAverageColor
1708   else
1709     result := GetGradientColor(FScanAtFunc(PointF(X,Y)));
1710 end;
1711 
TBGRAGradientScanner.ScanAtExpandednull1712 function TBGRAGradientScanner.ScanAtExpanded(X, Y: Single): TExpandedPixel;
1713 begin
1714   if FIsAverage then
1715     result := FAverageExpandedColor
1716   else
1717     result := GetGradientExpandedColor(FScanAtFunc(PointF(X,Y)));
1718 end;
1719 
1720 procedure TBGRAGradientScanner.ScanPutPixels(pdest: PBGRAPixel; count: integer;
1721   mode: TDrawMode);
1722 var c: TBGRAPixel;
1723 begin
1724   if FRepeatHoriz then
1725   begin
1726     c := FHorizColor;
1727     case mode of
1728       dmDrawWithTransparency: DrawPixelsInline(pdest,c,count);
1729       dmLinearBlend: FastBlendPixelsInline(pdest,c,count);
1730       dmSet: FillDWord(pdest^,count,Longword(c));
1731       dmXor: XorInline(pdest,c,count);
1732       dmSetExceptTransparent: if c.alpha = 255 then FillDWord(pdest^,count,Longword(c));
1733     end;
1734     exit;
1735   end;
1736 
1737   case mode of
1738     dmDrawWithTransparency:
1739       while count > 0 do
1740       begin
1741         DrawPixelInlineWithAlphaCheck(pdest,ScanNextInline);
1742         inc(pdest);
1743         dec(count);
1744       end;
1745     dmLinearBlend:
1746       while count > 0 do
1747       begin
1748         FastBlendPixelInline(pdest,ScanNextInline);
1749         inc(pdest);
1750         dec(count);
1751       end;
1752     dmXor:
1753       while count > 0 do
1754       begin
1755         PLongWord(pdest)^ := PLongWord(pdest)^ xor LongWord(ScanNextInline);
1756         inc(pdest);
1757         dec(count);
1758       end;
1759     dmSet:
1760       while count > 0 do
1761       begin
1762         pdest^ := ScanNextInline;
1763         inc(pdest);
1764         dec(count);
1765       end;
1766     dmSetExceptTransparent:
1767       while count > 0 do
1768       begin
1769         c := ScanNextInline;
1770         if c.alpha = 255 then pdest^ := c;
1771         inc(pdest);
1772         dec(count);
1773       end;
1774   end;
1775 end;
1776 
1777 procedure TBGRAGradientScanner.ScanSkipPixels(ACount: integer);
1778 begin
1779   if not FRepeatHoriz and not FIsAverage then
1780     FPosition.Offset(FMatrix[1,1]*ACount,FMatrix[2,1]*ACount);
1781 end;
1782 
TBGRAGradientScanner.IsScanPutPixelsDefinednull1783 function TBGRAGradientScanner.IsScanPutPixelsDefined: boolean;
1784 begin
1785   result := true;
1786 end;
1787 
1788 { TBGRATextureMaskScanner }
1789 
1790 constructor TBGRATextureMaskScanner.Create(AMask: IBGRAScanner;
1791   AOffset: TPoint; ATexture: IBGRAScanner; AGlobalOpacity: Byte);
1792 begin
1793   FMask := AMask;
1794   FOffset := AOffset;
1795   FTexture := ATexture;
1796   FTextureScanNext := @FTexture.ScanNextPixel;
1797   FTextureScanAt := @FTexture.ScanAt;
1798   FGlobalOpacity:= AGlobalOpacity;
1799 end;
1800 
1801 destructor TBGRATextureMaskScanner.Destroy;
1802 begin
1803   fillchar(FMask,sizeof(FMask),0); //avoids interface deref
1804   fillchar(FTexture,sizeof(FTexture),0);
1805   inherited Destroy;
1806 end;
1807 
IsScanPutPixelsDefinednull1808 function TBGRATextureMaskScanner.IsScanPutPixelsDefined: boolean;
1809 begin
1810   Result:= true;
1811 end;
1812 
1813 procedure TBGRATextureMaskScanner.ScanPutPixels(pdest: PBGRAPixel;
1814   count: integer; mode: TDrawMode);
1815 var c: TBGRAPixel;
1816     ptex: pbgrapixel;
1817     pmask: PByteMask;
1818     stride, qty: integer;
1819 
GetNextnull1820   function GetNext: TBGRAPixel; inline;
1821   begin
1822     result := ptex^;
1823     inc(ptex);
1824     result.alpha := ApplyOpacity(result.alpha, pmask^.gray);
1825     inc(pmask, stride);
1826   end;
1827 
GetNextWithGlobalnull1828   function GetNextWithGlobal: TBGRAPixel; inline;
1829   begin
1830     result := ptex^;
1831     inc(ptex);
1832     result.alpha := ApplyOpacity( ApplyOpacity(result.alpha, pmask^.gray), FGlobalOpacity );
1833     inc(pmask, stride);
1834   end;
1835 
1836 begin
1837   if count > length(FMemTex) then setlength(FMemTex, max(length(FMemTex)*2,count));
1838   ScannerPutPixels(FTexture,@FMemTex[0],count,dmSet);
1839   ptex := @FMemTex[0];
1840   while count > 0 do
1841   begin
1842     qty := count;
1843     FMask.ScanNextMaskChunk(qty, pMask, stride);
1844     dec(count, qty);
1845     if FGlobalOpacity <> 255 then
1846     begin
1847       case mode of
1848         dmDrawWithTransparency:
1849           while qty > 0 do
1850           begin
1851             DrawPixelInlineWithAlphaCheck(pdest,GetNextWithGlobal);
1852             inc(pdest);
1853             dec(qty);
1854           end;
1855         dmLinearBlend:
1856           while qty > 0 do
1857           begin
1858             FastBlendPixelInline(pdest,GetNextWithGlobal);
1859             inc(pdest);
1860             dec(qty);
1861           end;
1862         dmXor:
1863           while qty > 0 do
1864           begin
1865             PLongWord(pdest)^ := PLongWord(pdest)^ xor LongWord(GetNextWithGlobal);
1866             inc(pdest);
1867             dec(qty);
1868           end;
1869         dmSet:
1870           while qty > 0 do
1871           begin
1872             pdest^ := GetNextWithGlobal;
1873             inc(pdest);
1874             dec(qty);
1875           end;
1876         dmSetExceptTransparent:
1877           while qty > 0 do
1878           begin
1879             c := GetNextWithGlobal;
1880             if c.alpha = 255 then pdest^ := c;
1881             inc(pdest);
1882             dec(qty);
1883           end;
1884       end;
1885     end else
1886     begin
1887       case mode of
1888         dmDrawWithTransparency:
1889           while qty > 0 do
1890           begin
1891             DrawPixelInlineWithAlphaCheck(pdest,GetNext);
1892             inc(pdest);
1893             dec(qty);
1894           end;
1895         dmLinearBlend:
1896           while qty > 0 do
1897           begin
1898             FastBlendPixelInline(pdest,GetNext);
1899             inc(pdest);
1900             dec(qty);
1901           end;
1902         dmXor:
1903           while qty > 0 do
1904           begin
1905             PLongWord(pdest)^ := PLongWord(pdest)^ xor LongWord(GetNext);
1906             inc(pdest);
1907             dec(qty);
1908           end;
1909         dmSet:
1910           while qty > 0 do
1911           begin
1912             pdest^ := GetNext;
1913             inc(pdest);
1914             dec(qty);
1915           end;
1916         dmSetExceptTransparent:
1917           while qty > 0 do
1918           begin
1919             c := GetNext;
1920             if c.alpha = 255 then pdest^ := c;
1921             inc(pdest);
1922             dec(qty);
1923           end;
1924       end;
1925     end;
1926   end;
1927 end;
1928 
1929 procedure TBGRATextureMaskScanner.ScanSkipPixels(ACount: integer);
1930 begin
1931   FMask.ScanSkipPixels(ACount);
1932   FTexture.ScanSkipPixels(ACount);
1933 end;
1934 
1935 procedure TBGRATextureMaskScanner.ScanMoveTo(X, Y: Integer);
1936 begin
1937   FMask.ScanMoveTo(X+FOffset.X,Y+FOffset.Y);
1938   FTexture.ScanMoveTo(X,Y);
1939 end;
1940 
ScanNextPixelnull1941 function TBGRATextureMaskScanner.ScanNextPixel: TBGRAPixel;
1942 var
1943   pMask: PByteMask;
1944   stride, qty: integer;
1945 begin
1946   qty := 1;
1947   FMask.ScanNextMaskChunk(qty,pMask,stride);
1948   result := FTextureScanNext();
1949   result.alpha := ApplyOpacity( ApplyOpacity(result.alpha,pMask^.gray), FGlobalOpacity );
1950 end;
1951 
ScanAtnull1952 function TBGRATextureMaskScanner.ScanAt(X, Y: Single): TBGRAPixel;
1953 var alpha: byte;
1954 begin
1955   alpha := FMask.ScanAtMask(X+FOffset.X,Y+FOffset.Y).gray;
1956   result := FTextureScanAt(X,Y);
1957   result.alpha := ApplyOpacity( ApplyOpacity(result.alpha,alpha), FGlobalOpacity );
1958 end;
1959 
1960 { TBGRASolidColorMaskScanner }
1961 
1962 constructor TBGRASolidColorMaskScanner.Create(AMask: IBGRAScanner;
1963   AOffset: TPoint; ASolidColor: TBGRAPixel);
1964 begin
1965   FMask := AMask;
1966   FOffset := AOffset;
1967   FSolidColor := ASolidColor;
1968 end;
1969 
1970 destructor TBGRASolidColorMaskScanner.Destroy;
1971 begin
1972   fillchar(FMask,sizeof(FMask),0); //avoids interface deref
1973   inherited Destroy;
1974 end;
1975 
IsScanPutPixelsDefinednull1976 function TBGRASolidColorMaskScanner.IsScanPutPixelsDefined: boolean;
1977 begin
1978   Result:= true;
1979 end;
1980 
1981 procedure TBGRASolidColorMaskScanner.ScanPutPixels(pdest: PBGRAPixel;
1982   count: integer; mode: TDrawMode);
1983 var c: TBGRAPixel;
1984     pmask: PByteMask;
1985     stride, qty: integer;
1986 
GetNextnull1987   function GetNext: TBGRAPixel; inline;
1988   begin
1989     result := FSolidColor;
1990     result.alpha := ApplyOpacity(result.alpha,pmask^.gray);
1991     inc(pmask, stride);
1992   end;
1993 
1994 begin
1995   while count > 0 do
1996   begin
1997     qty := count;
1998     FMask.ScanNextMaskChunk(qty, pMask, stride);
1999     dec(count, qty);
2000     case mode of
2001       dmDrawWithTransparency:
2002         while qty > 0 do
2003         begin
2004           DrawPixelInlineWithAlphaCheck(pdest,GetNext);
2005           inc(pdest);
2006           dec(qty);
2007         end;
2008       dmLinearBlend:
2009         while qty > 0 do
2010         begin
2011           FastBlendPixelInline(pdest,GetNext);
2012           inc(pdest);
2013           dec(qty);
2014         end;
2015       dmXor:
2016         while qty > 0 do
2017         begin
2018           PLongWord(pdest)^ := PLongWord(pdest)^ xor LongWord(GetNext);
2019           inc(pdest);
2020           dec(qty);
2021         end;
2022       dmSet:
2023         while qty > 0 do
2024         begin
2025           pdest^ := GetNext;
2026           inc(pdest);
2027           dec(qty);
2028         end;
2029       dmSetExceptTransparent:
2030         while qty > 0 do
2031         begin
2032           c := GetNext;
2033           if c.alpha = 255 then pdest^ := c;
2034           inc(pdest);
2035           dec(qty);
2036         end;
2037     end;
2038   end;
2039 end;
2040 
2041 procedure TBGRASolidColorMaskScanner.ScanSkipPixels(ACount: integer);
2042 begin
2043   FMask.ScanSkipPixels(ACount);
2044 end;
2045 
2046 procedure TBGRASolidColorMaskScanner.ScanMoveTo(X, Y: Integer);
2047 begin
2048   FMask.ScanMoveTo(X+FOffset.X,Y+FOffset.Y);
2049 end;
2050 
TBGRASolidColorMaskScanner.ScanNextPixelnull2051 function TBGRASolidColorMaskScanner.ScanNextPixel: TBGRAPixel;
2052 var
2053   pMask: PByteMask;
2054   stride, qty: integer;
2055 begin
2056   qty := 1;
2057   FMask.ScanNextMaskChunk(qty,pMask,stride);
2058   result := FSolidColor;
2059   result.alpha := ApplyOpacity(result.alpha,pMask^.gray);
2060 end;
2061 
ScanAtnull2062 function TBGRASolidColorMaskScanner.ScanAt(X, Y: Single): TBGRAPixel;
2063 var alpha: byte;
2064 begin
2065   alpha := FMask.ScanAtMask(X,Y).gray;
2066   result := FSolidColor;
2067   result.alpha := ApplyOpacity(result.alpha,alpha);
2068 end;
2069 
2070 { TBGRAOpacityScanner }
2071 
2072 constructor TBGRAOpacityScanner.Create(ATexture: IBGRAScanner;
2073   AGlobalOpacity: Byte);
2074 begin
2075   FTexture := ATexture;
2076   FScanNext := @FTexture.ScanNextPixel;
2077   FScanAt := @FTexture.ScanAt;
2078   FGlobalOpacity:= AGlobalOpacity;
2079   FOwnedScanner := nil;
2080 end;
2081 
2082 constructor TBGRAOpacityScanner.Create(ATexture: TBGRACustomScanner;
2083   AGlobalOpacity: Byte; AOwned: boolean);
2084 begin
2085   FTexture := ATexture;
2086   FScanNext := @FTexture.ScanNextPixel;
2087   FScanAt := @FTexture.ScanAt;
2088   FGlobalOpacity:= AGlobalOpacity;
2089   if AOwned then
2090     FOwnedScanner := ATexture
2091   else
2092     FOwnedScanner := nil;
2093 end;
2094 
2095 destructor TBGRAOpacityScanner.Destroy;
2096 begin
2097   fillchar(FTexture,sizeof(FTexture),0);
2098   FOwnedScanner.Free;
2099   inherited Destroy;
2100 end;
2101 
IsScanPutPixelsDefinednull2102 function TBGRAOpacityScanner.IsScanPutPixelsDefined: boolean;
2103 begin
2104   Result:= true;
2105 end;
2106 
2107 procedure TBGRAOpacityScanner.ScanPutPixels(pdest: PBGRAPixel; count: integer;
2108   mode: TDrawMode);
2109 var c: TBGRAPixel;
2110     ptex: pbgrapixel;
2111 
GetNextnull2112   function GetNext: TBGRAPixel; inline;
2113   begin
2114     result := ptex^;
2115     inc(ptex);
2116     result.alpha := ApplyOpacity(result.alpha,FGlobalOpacity);
2117   end;
2118 
2119 begin
2120   if count > length(FMemTex) then setlength(FMemTex, max(length(FMemTex)*2,count));
2121   ScannerPutPixels(FTexture,@FMemTex[0],count,dmSet);
2122 
2123   ptex := @FMemTex[0];
2124 
2125   case mode of
2126     dmDrawWithTransparency:
2127       while count > 0 do
2128       begin
2129         DrawPixelInlineWithAlphaCheck(pdest,GetNext);
2130         inc(pdest);
2131         dec(count);
2132       end;
2133     dmLinearBlend:
2134       while count > 0 do
2135       begin
2136         FastBlendPixelInline(pdest,GetNext);
2137         inc(pdest);
2138         dec(count);
2139       end;
2140     dmXor:
2141       while count > 0 do
2142       begin
2143         PLongWord(pdest)^ := PLongWord(pdest)^ xor LongWord(GetNext);
2144         inc(pdest);
2145         dec(count);
2146       end;
2147     dmSet:
2148       while count > 0 do
2149       begin
2150         pdest^ := GetNext;
2151         inc(pdest);
2152         dec(count);
2153       end;
2154     dmSetExceptTransparent:
2155       while count > 0 do
2156       begin
2157         c := GetNext;
2158         if c.alpha = 255 then pdest^ := c;
2159         inc(pdest);
2160         dec(count);
2161       end;
2162   end;
2163 end;
2164 
2165 procedure TBGRAOpacityScanner.ScanSkipPixels(ACount: integer);
2166 begin
2167   FTexture.ScanSkipPixels(ACount);
2168 end;
2169 
2170 procedure TBGRAOpacityScanner.ScanMoveTo(X, Y: Integer);
2171 begin
2172   FTexture.ScanMoveTo(X,Y);
2173 end;
2174 
TBGRAOpacityScanner.ScanNextPixelnull2175 function TBGRAOpacityScanner.ScanNextPixel: TBGRAPixel;
2176 begin
2177   result := FScanNext();
2178   result.alpha := ApplyOpacity(result.alpha, FGlobalOpacity );
2179 end;
2180 
ScanAtnull2181 function TBGRAOpacityScanner.ScanAt(X, Y: Single): TBGRAPixel;
2182 begin
2183   result := FScanAt(X,Y);
2184   result.alpha := ApplyOpacity(result.alpha, FGlobalOpacity );
2185 end;
2186 
2187 initialization
2188 
2189   Randomize;
2190 
2191 end.
2192 
2193