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