Context Navigation

GR32_ColorGradients.pas

Last change on this file was 2, checked in by chronos, 5 years ago
Source code taken from https://svn.zdechov.net/PascalClassLibrary/GraphicTest/ rev 543.
File size: 136.2 KB

Line
1	unit GR32_ColorGradients;
2
3	(* *** BEGIN LICENSE BLOCK *************************************************
4	* Version: MPL 1.1 or LGPL 2.1 with linking exception *
5	* *
6	* The contents of this file are subject to the Mozilla Public License Version *
7	* 1.1 (the "License"); you may not use this file except in compliance with *
8	* the License. You may obtain a copy of the License at *
9	* http://www.mozilla.org/MPL/ *
10	* *
11	* Software distributed under the License is distributed on an "AS IS" basis, *
12	* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License *
13	* for the specific language governing rights and limitations under the *
14	* License. *
15	* *
16	* Alternatively, the contents of this file may be used under the terms of the *
17	* Free Pascal modified version of the GNU Lesser General Public License *
18	* Version 2.1 (the "FPC modified LGPL License"), in which case the provisions *
19	* of this license are applicable instead of those above. *
20	* Please see the file LICENSE.txt for additional information concerning this *
21	* license. *
22	* *
23	* The Original Code is Color Gradients for Graphics32 *
24	* *
25	* The Initial Developer of the Original Code is Angus Johnson *
26	* *
27	* Portions created by the Initial Developer are Copyright (C) 2008-2012 *
28	* the Initial Developer. All Rights Reserved. *
29	* *
30	* Contributor(s): Christian Budde <Christian@aixcoustic.com> *
31	* *
32	* *** END LICENSE BLOCK ***************************************************)
33
34	interface
35
36	{$I GR32.inc}
37
38	uses
39	Types, Classes, SysUtils, Math, GR32, GR32_Polygons,
40	GR32_VectorUtils, GR32_Bindings;
41
42	type
43	TColor32GradientStop = record
44	Offset: TFloat; //expected range between 0.0 and 1.0
45	Color32: TColor32;
46	end;
47	TArrayOfColor32GradientStop = array of TColor32GradientStop;
48
49	TColor32FloatPoint = record
50	Point: TFloatPoint;
51	Color32: TColor32;
52	end;
53	TArrayOfColor32FloatPoint = array of TColor32FloatPoint;
54
55	TColor32LookupTable = class(TPersistent)
56	private
57	FGradientLUT: PColor32Array;
58	FOrder: Byte;
59	FMask: Cardinal;
60	FSize: Cardinal;
61	FOnOrderChanged: TNotifyEvent;
62	procedure SetOrder(const Value: Byte);
63	function GetColor32(Index: Integer): TColor32; {$IFDEF USEINLINING} inline; {$ENDIF}
64	procedure SetColor32(Index: Integer; const Value: TColor32);
65	protected
66	procedure OrderChanged;
67	procedure AssignTo(Dest: TPersistent); override;
68	public
69	constructor Create(Order: Byte = 9); virtual;
70	destructor Destroy; override;
71
72	property Order: Byte read FOrder write SetOrder;
73	property Size: Cardinal read FSize;
74	property Mask: Cardinal read FMask;
75	property Color32[Index: Integer]: TColor32 read GetColor32 write SetColor32;
76	property Color32Ptr: PColor32Array read FGradientLUT;
77
78	property OnOrderChanged: TNotifyEvent read FOnOrderChanged write FOnOrderChanged;
79	end;
80
81	TColor32Gradient = class(TInterfacedPersistent, IStreamPersist)
82	private
83	FGradientColors: TArrayOfColor32GradientStop;
84	FOnGradientColorsChanged: TNotifyEvent;
85	function GetGradientEntry(Index: Integer): TColor32GradientStop;
86	function GetGradientCount: Integer; {$IFDEF USEINLINING}inline;{$ENDIF}
87	function GetStartColor: TColor32;
88	function GetEndColor: TColor32;
89	procedure SetEndColor(const Value: TColor32);
90	procedure SetStartColor(const Value: TColor32);
91	protected
92	procedure GradientColorsChanged; virtual;
93	procedure AssignTo(Dest: TPersistent); override;
94	public
95	constructor Create(Color: TColor32); overload;
96	constructor Create(StartColor, EndColor: TColor32); overload;
97	constructor Create(const GradientColors: TArrayOfColor32GradientStop); overload;
98
99	procedure LoadFromStream(Stream: TStream);
100	procedure SaveToStream(Stream: TStream);
101
102	procedure ClearColorStops; overload;
103	procedure ClearColorStops(Color: TColor32); overload;
104	procedure AddColorStop(Offset: TFloat; Color: TColor32); overload; virtual;
105	procedure AddColorStop(ColorStop: TColor32GradientStop); overload; virtual;
106	procedure SetColors(const GradientColors: array of const); overload;
107	procedure SetColors(const GradientColors: TArrayOfColor32GradientStop); overload;
108	procedure SetColors(const GradientColors: TArrayOfColor32); overload;
109	procedure SetColors(const Palette: TPalette32); overload;
110	function GetColorAt(Offset: TFloat): TColor32;
111
112	procedure FillColorLookUpTable(var ColorLUT: array of TColor32); overload;
113	procedure FillColorLookUpTable(ColorLUT: PColor32Array; Count: Integer); overload;
114	procedure FillColorLookUpTable(ColorLUT: TColor32LookupTable); overload;
115	property GradientEntry[Index: Integer]: TColor32GradientStop read GetGradientEntry;
116	property GradientCount: Integer read GetGradientCount;
117	property StartColor: TColor32 read GetStartColor write SetStartColor;
118	property EndColor: TColor32 read GetEndColor write SetEndColor;
119	property OnGradientColorsChanged: TNotifyEvent
120	read FOnGradientColorsChanged write FOnGradientColorsChanged;
121	end;
122
123	TCustomSparsePointGradientSampler = class(TCustomSampler)
124	protected
125	function GetCount: Integer; virtual; abstract;
126	function GetColor(Index: Integer): TColor32; virtual; abstract;
127	function GetPoint(Index: Integer): TFloatPoint; virtual; abstract;
128	function GetColorPoint(Index: Integer): TColor32FloatPoint; virtual; abstract;
129	procedure SetColor(Index: Integer; const Value: TColor32); virtual; abstract;
130	procedure SetColorPoint(Index: Integer; const Value: TColor32FloatPoint); virtual; abstract;
131	procedure SetPoint(Index: Integer; const Value: TFloatPoint); virtual; abstract;
132	public
133	function GetSampleFixed(X, Y: TFixed): TColor32; override;
134	function GetSampleInt(X, Y: Integer): TColor32; override;
135
136	procedure SetPoints(Points: TArrayOfFloatPoint); virtual; abstract;
137	procedure SetColorPoints(ColorPoints: TArrayOfColor32FloatPoint); overload; virtual; abstract;
138	procedure SetColorPoints(Points: TArrayOfFloatPoint; Colors: TArrayOfColor32); overload; virtual; abstract;
139
140	property Color[Index: Integer]: TColor32 read GetColor write SetColor;
141	property Point[Index: Integer]: TFloatPoint read GetPoint write SetPoint;
142	property ColorPoint[Index: Integer]: TColor32FloatPoint read GetColorPoint write SetColorPoint;
143	property Count: Integer read GetCount;
144	end;
145
146	TBarycentricGradientSampler = class(TCustomSparsePointGradientSampler)
147	protected
148	FColorPoints: array [0 .. 2] of TColor32FloatPoint;
149	FDists: array [0 .. 1] of TFloatPoint;
150	function GetCount: Integer; override;
151	function GetColor(Index: Integer): TColor32; override;
152	function GetColorPoint(Index: Integer): TColor32FloatPoint; override;
153	function GetPoint(Index: Integer): TFloatPoint; override;
154	procedure SetColor(Index: Integer; const Value: TColor32); override;
155	procedure SetColorPoint(Index: Integer; const Value: TColor32FloatPoint); override;
156	procedure SetPoint(Index: Integer; const Value: TFloatPoint); override;
157	procedure AssignTo(Dest: TPersistent); override;
158	procedure CalculateBarycentricCoordinates(X, Y: TFloat; out U, V, W: TFloat); {$IFDEF USEINLINING} inline; {$ENDIF}
159	public
160	constructor Create(P1, P2, P3: TColor32FloatPoint); overload; virtual;
161	function IsPointInTriangle(X, Y: TFloat): Boolean; overload;
162	function IsPointInTriangle(const Point: TFloatPoint): Boolean; overload;
163
164	procedure SetPoints(Points: TArrayOfFloatPoint); override;
165	procedure SetColorPoints(ColorPoints: TArrayOfColor32FloatPoint); override;
166	procedure SetColorPoints(Points: TArrayOfFloatPoint; Colors: TArrayOfColor32); override;
167
168	procedure PrepareSampling; override;
169	function GetSampleFloat(X, Y: TFloat): TColor32; override;
170	function GetSampleFloatInTriangle(X, Y: TFloat): TColor32;
171	end;
172
173	TBilinearGradientSampler = class(TCustomSparsePointGradientSampler)
174	protected
175	FColorPoints: array [0 .. 3] of TColor32FloatPoint;
176	FDists: array [0 .. 2] of TFloatPoint;
177	FDot: TFloat;
178	FBiasK0: TFloat;
179	FBiasU: TFloat;
180	FK2Sign: Integer;
181	FK2Value: TFloat;
182	function GetCount: Integer; override;
183	function GetColor(Index: Integer): TColor32; override;
184	function GetColorPoint(Index: Integer): TColor32FloatPoint; override;
185	function GetPoint(Index: Integer): TFloatPoint; override;
186	procedure SetColor(Index: Integer; const Value: TColor32); override;
187	procedure SetColorPoint(Index: Integer; const Value: TColor32FloatPoint); override;
188	procedure SetPoint(Index: Integer; const Value: TFloatPoint); override;
189	procedure AssignTo(Dest: TPersistent); override;
190	public
191	procedure SetPoints(Points: TArrayOfFloatPoint); override;
192	procedure SetColorPoints(ColorPoints: TArrayOfColor32FloatPoint); override;
193	procedure SetColorPoints(Points: TArrayOfFloatPoint; Colors: TArrayOfColor32); override;
194
195	procedure PrepareSampling; override;
196	function GetSampleFloat(X, Y: TFloat): TColor32; override;
197	end;
198
199	TCustomArbitrarySparsePointGradientSampler = class(TCustomSparsePointGradientSampler)
200	private
201	FColorPoints: TArrayOfColor32FloatPoint;
202	protected
203	procedure AssignTo(Dest: TPersistent); override;
204	function GetCount: Integer; override;
205	function GetColor(Index: Integer): TColor32; override;
206	function GetColorPoint(Index: Integer): TColor32FloatPoint; override;
207	function GetPoint(Index: Integer): TFloatPoint; override;
208	procedure SetColor(Index: Integer; const Value: TColor32); override;
209	procedure SetColorPoint(Index: Integer; const Value: TColor32FloatPoint); override;
210	procedure SetPoint(Index: Integer; const Value: TFloatPoint); override;
211	public
212	procedure Add(Point: TFloatPoint; Color: TColor32); overload; virtual;
213	procedure Add(const ColorPoint: TColor32FloatPoint); overload; virtual;
214	procedure SetColorPoints(ColorPoints: TArrayOfColor32FloatPoint); override;
215	procedure SetColorPoints(Points: TArrayOfFloatPoint; Colors: TArrayOfColor32); override;
216	procedure SetPoints(Points: TArrayOfFloatPoint); override;
217	procedure Clear; virtual;
218	end;
219
220	TInvertedDistanceWeightingSampler = class(TCustomArbitrarySparsePointGradientSampler)
221	private
222	FDists: TArrayOfFloat;
223	FUsePower: Boolean;
224	FPower: TFloat;
225	FScaledPower: TFloat;
226	public
227	constructor Create; virtual;
228	procedure PrepareSampling; override;
229	procedure FinalizeSampling; override;
230	function GetSampleFloat(X, Y: TFloat): TColor32; override;
231
232	property Power: TFloat read FPower write FPower;
233	end;
234
235	TVoronoiSampler = class(TCustomArbitrarySparsePointGradientSampler)
236	public
237	function GetSampleFloat(X, Y: TFloat): TColor32; override;
238	end;
239
240	TGourandShadedDelaunayTrianglesSampler = class(TCustomArbitrarySparsePointGradientSampler)
241	private
242	FTriangles: TArrayOfTriangleVertexIndices;
243	FBarycentric: array of TBarycentricGradientSampler;
244	public
245	procedure PrepareSampling; override;
246	procedure FinalizeSampling; override;
247	function GetSampleFloat(X, Y: TFloat): TColor32; override;
248	end;
249
250	TCustomGradientSampler = class(TCustomSampler)
251	private
252	FGradient: TColor32Gradient;
253	FWrapMode: TWrapMode;
254	procedure SetGradient(const Value: TColor32Gradient);
255	procedure SetWrapMode(const Value: TWrapMode);
256	protected
257	FInitialized: Boolean;
258	procedure AssignTo(Dest: TPersistent); override;
259	procedure GradientChangedHandler(Sender: TObject);
260	procedure GradientSamplerChanged; //de-initializes sampler
261	procedure WrapModeChanged; virtual;
262	procedure UpdateInternals; virtual; abstract;
263
264	property Initialized: Boolean read FInitialized;
265	public
266	constructor Create(WrapMode: TWrapMode = wmMirror); overload; virtual;
267	constructor Create(ColorGradient: TColor32Gradient); overload; virtual;
268	destructor Destroy; override;
269
270	procedure PrepareSampling; override;
271	function GetSampleInt(X, Y: Integer): TColor32; override;
272	function GetSampleFixed(X, Y: TFixed): TColor32; override;
273
274	property Gradient: TColor32Gradient read FGradient write SetGradient;
275	property WrapMode: TWrapMode read FWrapMode write SetWrapMode;
276	end;
277
278	TCustomGradientLookUpTableSampler = class(TCustomGradientSampler)
279	private
280	FGradientLUT: TColor32LookupTable;
281	FLutPtr: PColor32Array;
282	FLutMask: Integer;
283	FWrapProc: TWrapProc;
284	protected
285	procedure AssignTo(Dest: TPersistent); override;
286	procedure WrapModeChanged; override;
287	procedure UpdateInternals; override;
288
289	property LutPtr: PColor32Array read FLutPtr;
290	property LutMask: Integer read FLutMask;
291	property WrapProc: TWrapProc read FWrapProc;
292	public
293	constructor Create(WrapMode: TWrapMode = wmMirror); override;
294	destructor Destroy; override;
295	end;
296
297	TCustomCenterLutGradientSampler = class(TCustomGradientLookUpTableSampler)
298	private
299	FCenter: TFloatPoint;
300	protected
301	procedure AssignTo(Dest: TPersistent); override;
302	procedure Transform(var X, Y: TFloat); virtual;
303	public
304	constructor Create(WrapMode: TWrapMode = wmMirror); override;
305
306	property Center: TFloatPoint read FCenter write FCenter;
307	end;
308
309	TConicGradientSampler = class(TCustomCenterLutGradientSampler)
310	private
311	FScale: TFloat;
312	FAngle: TFloat;
313	protected
314	procedure AssignTo(Dest: TPersistent); override;
315	procedure UpdateInternals; override;
316	public
317	function GetSampleFloat(X, Y: TFloat): TColor32; override;
318
319	property Angle: TFloat read FAngle write FAngle;
320	end;
321
322	TCustomCenterRadiusLutGradientSampler = class(TCustomCenterLutGradientSampler)
323	private
324	FRadius: TFloat;
325	procedure SetRadius(const Value: TFloat);
326	protected
327	procedure AssignTo(Dest: TPersistent); override;
328	procedure RadiusChanged; virtual;
329	public
330	constructor Create(WrapMode: TWrapMode = wmMirror); override;
331
332	property Radius: TFloat read FRadius write SetRadius;
333	end;
334
335	TRadialGradientSampler = class(TCustomCenterRadiusLutGradientSampler)
336	private
337	FScale: TFloat;
338	protected
339	procedure UpdateInternals; override;
340	public
341	function GetSampleFloat(X, Y: TFloat): TColor32; override;
342	end;
343
344	TCustomCenterRadiusAngleLutGradientSampler = class(TCustomCenterRadiusLutGradientSampler)
345	private
346	FAngle: TFloat;
347	FSinCos: TFloatPoint;
348	procedure SetAngle(const Value: TFloat);
349	protected
350	procedure AssignTo(Dest: TPersistent); override;
351	procedure AngleChanged; virtual;
352	procedure RadiusChanged; override;
353	procedure Transform(var X, Y: TFloat); override;
354	public
355	constructor Create(WrapMode: TWrapMode = wmMirror); override;
356
357	property Angle: TFloat read FAngle write SetAngle;
358	end;
359
360	TDiamondGradientSampler = class(TCustomCenterRadiusAngleLutGradientSampler)
361	private
362	FScale: TFloat;
363	protected
364	procedure UpdateInternals; override;
365	public
366	function GetSampleFloat(X, Y: TFloat): TColor32; override;
367	end;
368
369	TXGradientSampler = class(TCustomCenterRadiusAngleLutGradientSampler)
370	private
371	FScale: TFloat;
372	function GetEndPoint: TFloatPoint;
373	function GetStartPoint: TFloatPoint;
374	procedure SetEndPoint(const Value: TFloatPoint);
375	procedure SetStartPoint(const Value: TFloatPoint);
376	protected
377	procedure UpdateInternals; override;
378	public
379	procedure SimpleGradient(const StartPoint: TFloatPoint; StartColor: TColor32;
380	const EndPoint: TFloatPoint; EndColor: TColor32); virtual;
381	procedure SetPoints(const StartPoint, EndPoint: TFloatPoint); virtual;
382
383	function GetSampleFloat(X, Y: TFloat): TColor32; override;
384	public
385	property StartPoint: TFloatPoint read GetStartPoint write SetStartPoint;
386	property EndPoint: TFloatPoint read GetEndPoint write SetEndPoint;
387	end;
388
389	TLinearGradientSampler = class(TXGradientSampler);
390
391	TXYGradientSampler = class(TCustomCenterRadiusAngleLutGradientSampler)
392	private
393	FScale: TFloat;
394	protected
395	procedure UpdateInternals; override;
396	public
397	function GetSampleFloat(X, Y: TFloat): TColor32; override;
398	end;
399
400	TXYSqrtGradientSampler = class(TCustomCenterRadiusAngleLutGradientSampler)
401	private
402	FScale: TFloat;
403	protected
404	procedure UpdateInternals; override;
405	public
406	function GetSampleFloat(X, Y: TFloat): TColor32; override;
407	end;
408
409	TCustomSparsePointGradientPolygonFiller = class(TCustomPolygonFiller)
410	protected
411	function GetCount: Integer; virtual; abstract;
412	function GetColor(Index: Integer): TColor32; virtual; abstract;
413	function GetPoint(Index: Integer): TFloatPoint; virtual; abstract;
414	function GetColorPoint(Index: Integer): TColor32FloatPoint; virtual; abstract;
415	procedure SetColor(Index: Integer; const Value: TColor32); virtual; abstract;
416	procedure SetColorPoint(Index: Integer; const Value: TColor32FloatPoint); virtual; abstract;
417	procedure SetPoint(Index: Integer; const Value: TFloatPoint); virtual; abstract;
418	public
419	procedure SetPoints(Points: TArrayOfFloatPoint); virtual; abstract;
420	procedure SetColorPoints(ColorPoints: TArrayOfColor32FloatPoint); overload; virtual; abstract;
421	procedure SetColorPoints(Points: TArrayOfFloatPoint; Colors: TArrayOfColor32); overload; virtual; abstract;
422
423	property Color[Index: Integer]: TColor32 read GetColor write SetColor;
424	property Point[Index: Integer]: TFloatPoint read GetPoint write SetPoint;
425	property ColorPoint[Index: Integer]: TColor32FloatPoint read GetColorPoint write SetColorPoint;
426	property Count: Integer read GetCount;
427	end;
428
429	TBarycentricGradientPolygonFiller = class(TCustomSparsePointGradientPolygonFiller)
430	protected
431	FColorPoints: array [0 .. 2] of TColor32FloatPoint;
432	FDists: array [0 .. 1] of TFloatPoint;
433	function GetCount: Integer; override;
434	function GetColor(Index: Integer): TColor32; override;
435	function GetPoint(Index: Integer): TFloatPoint; override;
436	function GetColorPoint(Index: Integer): TColor32FloatPoint; override;
437	procedure SetColor(Index: Integer; const Value: TColor32); override;
438	procedure SetColorPoint(Index: Integer; const Value: TColor32FloatPoint); override;
439	procedure SetPoint(Index: Integer; const Value: TFloatPoint); override;
440	function GetFillLine: TFillLineEvent; override;
441	procedure FillLine(Dst: PColor32; DstX, DstY, Length: Integer;
442	AlphaValues: PColor32; CombineMode: TCombineMode);
443	class function Linear3PointInterpolation(A, B, C: TColor32;
444	WeightA, WeightB, WeightC: Single): TColor32;
445	public
446	procedure BeginRendering; override;
447
448	procedure SetPoints(Points: TArrayOfFloatPoint); override;
449	procedure SetColorPoints(ColorPoints: TArrayOfColor32FloatPoint); overload; override;
450	procedure SetColorPoints(Points: TArrayOfFloatPoint; Colors: TArrayOfColor32); overload; override;
451	end;
452
453	TCustomArbitrarySparsePointGradientPolygonFiller = class(TCustomSparsePointGradientPolygonFiller)
454	private
455	FColorPoints: TArrayOfColor32FloatPoint;
456	protected
457	function GetCount: Integer; override;
458	function GetColor(Index: Integer): TColor32; override;
459	function GetColorPoint(Index: Integer): TColor32FloatPoint; override;
460	function GetPoint(Index: Integer): TFloatPoint; override;
461	procedure SetColor(Index: Integer; const Value: TColor32); override;
462	procedure SetColorPoint(Index: Integer; const Value: TColor32FloatPoint); override;
463	procedure SetPoint(Index: Integer; const Value: TFloatPoint); override;
464	public
465	procedure Add(const Point: TFloatPoint; Color: TColor32); overload; virtual;
466	procedure Add(const ColorPoint: TColor32FloatPoint); overload; virtual;
467	procedure SetColorPoints(ColorPoints: TArrayOfColor32FloatPoint); override;
468	procedure SetColorPoints(Points: TArrayOfFloatPoint; Colors: TArrayOfColor32); override;
469	procedure SetPoints(Points: TArrayOfFloatPoint); override;
470	procedure Clear; virtual;
471	end;
472
473	TGourandShadedDelaunayTrianglesPolygonFiller = class(TCustomArbitrarySparsePointGradientPolygonFiller)
474	private
475	FTriangles: TArrayOfTriangleVertexIndices;
476	FBarycentric: array of TBarycentricGradientSampler;
477	protected
478	function GetFillLine: TFillLineEvent; override;
479	procedure FillLine3(Dst: PColor32; DstX, DstY, Count: Integer;
480	AlphaValues: PColor32; CombineMode: TCombineMode);
481	procedure FillLine(Dst: PColor32; DstX, DstY, Count: Integer;
482	AlphaValues: PColor32; CombineMode: TCombineMode);
483	public
484	procedure BeginRendering; override;
485	end;
486
487	TCustomGradientPolygonFiller = class(TCustomPolygonFiller)
488	private
489	FGradient: TColor32Gradient;
490	FOwnsGradient: Boolean;
491	FWrapMode: TWrapMode;
492	FWrapProc: TWrapProc;
493	procedure SetWrapMode(const Value: TWrapMode);
494	protected
495	procedure GradientColorsChangedHandler(Sender: TObject);
496	procedure FillLineNone(Dst: PColor32; DstX, DstY, Length: Integer;
497	AlphaValues: PColor32; CombineMode: TCombineMode);
498	procedure FillLineSolid(Dst: PColor32; DstX, DstY, Length: Integer;
499	AlphaValues: PColor32; CombineMode: TCombineMode);
500	procedure GradientFillerChanged; virtual;
501	procedure WrapModeChanged; virtual;
502	public
503	constructor Create; overload;
504	constructor Create(ColorGradient: TColor32Gradient); overload; virtual;
505	destructor Destroy; override;
506
507	property Gradient: TColor32Gradient read FGradient;
508	property WrapMode: TWrapMode read FWrapMode write SetWrapMode;
509	end;
510
511	TCustomGradientLookupTablePolygonFiller = class(TCustomGradientPolygonFiller)
512	private
513	FLUTNeedsUpdate: Boolean;
514	FOwnsLUT: Boolean;
515	FGradientLUT: TColor32LookupTable;
516	FUseLookUpTable: Boolean;
517	function GetLUTNeedsUpdate: Boolean;
518	procedure SetUseLookUpTable(const Value: Boolean);
519	procedure SetGradientLUT(const Value: TColor32LookupTable);
520	protected
521	procedure GradientFillerChanged; override;
522	procedure UseLookUpTableChanged; virtual;
523	procedure LookUpTableChangedHandler(Sender: TObject);
524
525	property LookUpTableNeedsUpdate: Boolean read GetLUTNeedsUpdate;
526	public
527	constructor Create; reintroduce; overload;
528	constructor Create(LookupTable: TColor32LookupTable); overload; virtual;
529	destructor Destroy; override;
530
531	property GradientLUT: TColor32LookupTable read FGradientLUT write SetGradientLUT;
532	property UseLookUpTable: Boolean read FUseLookUpTable write SetUseLookUpTable;
533	end;
534
535	TCustomLinearGradientPolygonFiller = class(TCustomGradientLookupTablePolygonFiller)
536	private
537	FIncline: TFloat;
538	FStartPoint: TFloatPoint;
539	FEndPoint: TFloatPoint;
540	procedure SetStartPoint(const Value: TFloatPoint);
541	procedure SetEndPoint(const Value: TFloatPoint);
542
543	procedure UpdateIncline;
544	protected
545	procedure EndPointChanged;
546	procedure StartPointChanged;
547	public
548	procedure SimpleGradient(const StartPoint: TFloatPoint; StartColor: TColor32;
549	const EndPoint: TFloatPoint; EndColor: TColor32); virtual;
550	procedure SimpleGradientX(const StartX: TFloat; StartColor: TColor32;
551	const EndX: TFloat; EndColor: TColor32);
552	procedure SimpleGradientY(const StartY: TFloat; StartColor: TColor32;
553	const EndY: TFloat; EndColor: TColor32);
554	procedure SetPoints(const StartPoint, EndPoint: TFloatPoint); virtual;
555
556	property StartPoint: TFloatPoint read FStartPoint write SetStartPoint;
557	property EndPoint: TFloatPoint read FEndPoint write SetEndPoint;
558	end;
559
560	TLinearGradientPolygonFiller = class(TCustomLinearGradientPolygonFiller)
561	private
562	function ColorStopToScanLine(Index: Integer; Y: Integer): TFloat;
563	protected
564	function GetFillLine: TFillLineEvent; override;
565
566	procedure FillLineNegative(Dst: PColor32; DstX, DstY, Length: Integer;
567	AlphaValues: PColor32;
568	CombineMode: TCombineMode);
569	procedure FillLinePositive(Dst: PColor32; DstX, DstY, Length: Integer;
570	AlphaValues: PColor32;
571	CombineMode: TCombineMode);
572	procedure FillLineVertical(Dst: PColor32;
573	DstX, DstY, Length: Integer; AlphaValues: PColor32;
574	CombineMode: TCombineMode);
575	procedure FillLineVerticalExtreme(Dst: PColor32; DstX, DstY,
576	Length: Integer; AlphaValues: PColor32;
577	CombineMode: TCombineMode);
578
579	procedure FillLineVerticalPad(Dst: PColor32;
580	DstX, DstY, Length: Integer; AlphaValues: PColor32;
581	CombineMode: TCombineMode);
582	procedure FillLineVerticalPadExtreme(Dst: PColor32; DstX, DstY,
583	Length: Integer; AlphaValues: PColor32;
584	CombineMode: TCombineMode);
585	procedure FillLineVerticalWrap(Dst: PColor32;
586	DstX, DstY, Length: Integer; AlphaValues: PColor32;
587	CombineMode: TCombineMode);
588	procedure FillLineHorizontalPadPos(Dst: PColor32;
589	DstX, DstY, Length: Integer; AlphaValues: PColor32;
590	CombineMode: TCombineMode);
591	procedure FillLineHorizontalPadNeg(Dst: PColor32; DstX, DstY,
592	Length: Integer; AlphaValues: PColor32;
593	CombineMode: TCombineMode);
594	procedure FillLineHorizontalWrapNeg(Dst: PColor32; DstX, DstY,
595	Length: Integer; AlphaValues: PColor32;
596	CombineMode: TCombineMode);
597	procedure FillLineHorizontalWrapPos(Dst: PColor32; DstX, DstY,
598	Length: Integer; AlphaValues: PColor32;
599	CombineMode: TCombineMode);
600
601	procedure UseLookUpTableChanged; override;
602	procedure WrapModeChanged; override;
603	public
604	constructor Create(ColorGradient: TColor32Gradient); overload; override;
605	constructor Create(ColorGradient: TColor32Gradient; UseLookupTable: Boolean); overload; virtual;
606
607	procedure BeginRendering; override; //flags initialized
608	end;
609
610	TCustomRadialGradientPolygonFiller = class(TCustomGradientLookupTablePolygonFiller)
611	private
612	FEllipseBounds: TFloatRect;
613	procedure SetEllipseBounds(const Value: TFloatRect);
614	protected
615	procedure EllipseBoundsChanged; virtual; abstract;
616	public
617	property EllipseBounds: TFloatRect read FEllipseBounds write SetEllipseBounds;
618	end;
619
620	TRadialGradientPolygonFiller = class(TCustomRadialGradientPolygonFiller)
621	private
622	FCenter: TFloatPoint;
623	FRadius: TFloatPoint;
624	FRadScale: TFloat;
625	FRadXInv: TFloat;
626
627	procedure SetCenter(const Value: TFloatPoint);
628	procedure SetRadius(const Value: TFloatPoint);
629	procedure UpdateEllipseBounds;
630	procedure UpdateRadiusScale;
631	protected
632	function GetFillLine: TFillLineEvent; override;
633	procedure EllipseBoundsChanged; override;
634	procedure FillLinePad(Dst: PColor32; DstX, DstY, Length: Integer;
635	AlphaValues: PColor32; CombineMode: TCombineMode);
636	procedure FillLineRepeat(Dst: PColor32; DstX, DstY, Length: Integer;
637	AlphaValues: PColor32; CombineMode: TCombineMode);
638	procedure FillLineReflect(Dst: PColor32; DstX, DstY, Length: Integer;
639	AlphaValues: PColor32; CombineMode: TCombineMode);
640	public
641	constructor Create(Radius: TFloatPoint); overload;
642	constructor Create(BoundingBox: TFloatRect); overload;
643	constructor Create(Radius, Center: TFloatPoint); overload;
644	procedure BeginRendering; override;
645
646	property Radius: TFloatPoint read FRadius write SetRadius;
647	property Center: TFloatPoint read FCenter write SetCenter;
648	end;
649
650	TSVGRadialGradientPolygonFiller = class(TCustomRadialGradientPolygonFiller)
651	private
652	FOffset: TFloatPoint;
653	FRadius: TFloatPoint;
654	FCenter: TFloatPoint;
655	FFocalPt: TFloatPoint;
656	FVertDist: TFloat;
657
658	FFocalPointNative: TFloatPoint;
659
660	procedure SetFocalPoint(const Value: TFloatPoint);
661	procedure InitMembers;
662	protected
663	function GetFillLine: TFillLineEvent; override;
664	procedure EllipseBoundsChanged; override;
665	procedure FillLineEllipse(Dst: PColor32; DstX, DstY, Length: Integer;
666	AlphaValues: PColor32; CombineMode: TCombineMode);
667	public
668	constructor Create(EllipseBounds: TFloatRect); overload;
669	constructor Create(EllipseBounds: TFloatRect; FocalPoint: TFloatPoint); overload;
670	procedure BeginRendering; override;
671
672	procedure SetParameters(EllipseBounds: TFloatRect); overload;
673	procedure SetParameters(EllipseBounds: TFloatRect; FocalPoint: TFloatPoint); overload;
674
675	property FocalPoint: TFloatPoint read FFocalPointNative write SetFocalPoint;
676	end;
677
678	function Color32FloatPoint(Color: TColor32; Point: TFloatPoint): TColor32FloatPoint; overload; {$IFDEF USEINLINING} inline; {$ENDIF}
679	function Color32FloatPoint(Color: TColor32; X, Y: TFloat): TColor32FloatPoint; overload; {$IFDEF USEINLINING} inline; {$ENDIF}
680	function Color32GradientStop(Offset: TFloat; Color: TColor32): TColor32GradientStop; overload; {$IFDEF USEINLINING} inline; {$ENDIF}
681
682	const
683	FID_LINEAR3 = 0;
684	FID_LINEAR4 = 1;
685
686	var
687	GradientRegistry: TFunctionRegistry;
688
689	implementation
690
691	uses
692	GR32_LowLevel, GR32_System, GR32_Math, GR32_Geometry, GR32_Blend;
693
694	resourcestring
695	RCStrIndexOutOfBounds = 'Index out of bounds (%d)';
696	RCStrWrongFormat = 'Wrong format';
697	RCStrOnlyExactly3Point = 'Only exactly 3 points expected!';
698	RCStrPointCountMismatch = 'Point count mismatch';
699	RCStrNoTColor32LookupTable = 'No TColor32LookupTable object specified';
700	RCStrNoTColor32Gradient = 'No TColor32Gradient specified';
701	RCStrNoLookupTablePassed = 'No lookup table passed!';
702
703	const
704	CFloatTolerance = 0.001;
705	clNone32: TColor32 = $00000000;
706
707	procedure FillLineAlpha(var Dst, AlphaValues: PColor32; Count: Integer;
708	Color: TColor32; CombineMode: TCombineMode); {$IFDEF USEINLINING}inline;{$ENDIF}
709	var
710	X: Integer;
711	BlendMemEx: TBlendMemEx;
712	begin
713	BlendMemEx := BLEND_MEM_EX[CombineMode]^;
714	for X := 0 to Count - 1 do
715	begin
716	BlendMemEx(Color, Dst^, AlphaValues^);
717	Inc(Dst);
718	Inc(AlphaValues);
719	end;
720	EMMS;
721	end;
722
723	function Color32FloatPoint(Color: TColor32; Point: TFloatPoint): TColor32FloatPoint;
724	begin
725	Result.Point := Point;
726	Result.Color32 := Color;
727	end;
728
729	function Color32FloatPoint(Color: TColor32; X, Y: TFloat): TColor32FloatPoint;
730	begin
731	Result.Point := FloatPoint(X, Y);
732	Result.Color32 := Color;
733	end;
734
735	function Color32GradientStop(Offset: TFloat; Color: TColor32): TColor32GradientStop;
736	begin
737	Result.Offset := Offset;
738	Result.Color32 := Color;
739	end;
740
741	type
742	TLinear3PointInterpolation = function (A, B, C: TColor32; WA, WB, WC: Single): TColor32;
743	TLinear4PointInterpolation = function (A, B, C, D: TColor32; WA, WB, WC, WD: Single): TColor32;
744
745	{ Linear interpolation of several (3, 4) colors }
746
747	var
748	Linear3PointInterpolationProc: TLinear3PointInterpolation;
749	Linear4PointInterpolationProc: TLinear4PointInterpolation;
750
751	function Linear3PointInterpolation_Pas(A, B, C: TColor32; WA, WB, WC: Single): TColor32;
752	var
753	Clr: TColor32Entry absolute Result;
754	begin
755	Clr.B := Clamp(Round(
756	WA * TColor32Entry(A).B +
757	WB * TColor32Entry(B).B +
758	WC * TColor32Entry(C).B));
759	Clr.G := Clamp(Round(
760	WA * TColor32Entry(A).G +
761	WB * TColor32Entry(B).G +
762	WC * TColor32Entry(C).G));
763	Clr.R := Clamp(Round(
764	WA * TColor32Entry(A).R +
765	WB * TColor32Entry(B).R +
766	WC * TColor32Entry(C).R));
767	Clr.A := Clamp(Round(
768	WA * TColor32Entry(A).A +
769	WB * TColor32Entry(B).A +
770	WC * TColor32Entry(C).A));
771	end;
772
773	function Linear4PointInterpolation_Pas(A, B, C, D: TColor32; WA, WB, WC,
774	WD: Single): TColor32;
775	var
776	Clr: TColor32Entry absolute Result;
777	begin
778	Clr.B := Clamp(Round(
779	WA * TColor32Entry(A).B +
780	WB * TColor32Entry(B).B +
781	WC * TColor32Entry(C).B +
782	WD * TColor32Entry(D).B));
783	Clr.G := Clamp(Round(
784	WA * TColor32Entry(A).G +
785	WB * TColor32Entry(B).G +
786	WC * TColor32Entry(C).G +
787	WD * TColor32Entry(D).G));
788	Clr.R := Clamp(Round(
789	WA * TColor32Entry(A).R +
790	WB * TColor32Entry(B).R +
791	WC * TColor32Entry(C).R +
792	WD * TColor32Entry(D).R));
793	Clr.A := Clamp(Round(
794	WA * TColor32Entry(A).A +
795	WB * TColor32Entry(B).A +
796	WC * TColor32Entry(C).A +
797	WD * TColor32Entry(D).A));
798	end;
799
800	{$IFNDEF OMIT_SSE2}
801
802	{$IFNDEF PUREPASCAL}
803	function Linear3PointInterpolation_SSE2(A, B, C: TColor32; WA, WB, WC: Single): TColor32;
804	asm
805	{$IFDEF TARGET_X86}
806	PXOR XMM3,XMM3
807	MOVD XMM0,EAX
808	PUNPCKLBW XMM0,XMM3
809	PUNPCKLWD XMM0,XMM3
810	CVTDQ2PS XMM0,XMM0
811	MOVD XMM1,EDX
812	PUNPCKLBW XMM1,XMM3
813	PUNPCKLWD XMM1,XMM3
814	CVTDQ2PS XMM1,XMM1
815	MOVD XMM2,ECX
816	PUNPCKLBW XMM2,XMM3
817	PUNPCKLWD XMM2,XMM3
818	CVTDQ2PS XMM2,XMM2
819
820	MOV EAX, WA
821	MOV EDX, WB
822	MOV ECX, WC
823	MOVD XMM4,EAX
824	SHUFPS XMM4,XMM4,0
825	MOVD XMM5,EDX
826	SHUFPS XMM5,XMM5,0
827	MOVD XMM6,ECX
828	SHUFPS XMM6,XMM6,0
829
830	MULPS XMM0,XMM4
831	MULPS XMM1,XMM5
832	MULPS XMM2,XMM6
833	ADDPS XMM0,XMM1
834	ADDPS XMM0,XMM2
835	CVTPS2DQ XMM0,XMM0
836	PACKSSDW XMM0,XMM3
837	PACKUSWB XMM0,XMM3
838	MOVD EAX,XMM0
839	{$ENDIF}
840	{$IFDEF TARGET_X64}
841	MOVQ XMM0,XMM3
842	SHUFPS XMM0,XMM0,0
843	MOVD XMM1,WB
844	SHUFPS XMM1,XMM1,0
845	MOVD XMM2,WC
846	SHUFPS XMM2,XMM2,0
847
848	PXOR XMM3,XMM3
849	MOVD XMM4,ECX
850	PUNPCKLBW XMM4,XMM3
851	PUNPCKLWD XMM4,XMM3
852	CVTDQ2PS XMM4,XMM4
853	MOVD XMM5,EDX
854	PUNPCKLBW XMM5,XMM3
855	PUNPCKLWD XMM5,XMM3
856	CVTDQ2PS XMM5,XMM5
857	MOVD XMM6,R8D
858	PUNPCKLBW XMM6,XMM3
859	PUNPCKLWD XMM6,XMM3
860	CVTDQ2PS XMM6,XMM6
861
862	MULPS XMM0,XMM4
863	MULPS XMM1,XMM5
864	MULPS XMM2,XMM6
865	ADDPS XMM0,XMM1
866	ADDPS XMM0,XMM2
867	CVTPS2DQ XMM0,XMM0
868	PACKSSDW XMM0,XMM3
869	PACKUSWB XMM0,XMM3
870	MOVD EAX,XMM0
871	{$ENDIF}
872	end;
873
874	function Linear4PointInterpolation_SSE2(A, B, C, D: TColor32; WA, WB, WC, WD: Single): TColor32;
875	asm
876	{$IFDEF TARGET_X86}
877	PXOR XMM7,XMM7
878
879	MOVD XMM0,EAX
880	PUNPCKLBW XMM0,XMM7
881	PUNPCKLWD XMM0,XMM7
882	CVTDQ2PS XMM0,XMM0
883	MOVD XMM1,EDX
884	PUNPCKLBW XMM1,XMM7
885	PUNPCKLWD XMM1,XMM7
886	CVTDQ2PS XMM1,XMM1
887
888	MOV EAX, WA
889	MOVD XMM4,EAX
890	SHUFPS XMM4,XMM4,0
891	MULPS XMM0,XMM4
892
893	MOV EDX, WB
894	MOVD XMM5,EDX
895	SHUFPS XMM5,XMM5,0
896	MULPS XMM1,XMM5
897	ADDPS XMM0,XMM1
898
899	MOVD XMM2,ECX
900	PUNPCKLBW XMM2,XMM7
901	PUNPCKLWD XMM2,XMM7
902	CVTDQ2PS XMM2,XMM2
903	MOVD XMM3,D
904	PUNPCKLBW XMM3,XMM7
905	PUNPCKLWD XMM3,XMM7
906	CVTDQ2PS XMM3,XMM3
907
908	MOV EAX, WC
909	MOVD XMM4,EAX
910	SHUFPS XMM4,XMM4,0
911	MULPS XMM2,XMM4
912
913	MOV EDX, WD
914	MOVD XMM5,EDX
915	SHUFPS XMM5,XMM5,0
916	MULPS XMM3,XMM5
917	ADDPS XMM2,XMM3
918	ADDPS XMM0,XMM2
919
920	CVTPS2DQ XMM0,XMM0
921	PACKSSDW XMM0,XMM7
922	PACKUSWB XMM0,XMM7
923	MOVD EAX,XMM0
924	{$ENDIF}
925	{$IFDEF TARGET_X64}
926	PXOR XMM7,XMM7
927
928	MOVD XMM0,A
929	PUNPCKLBW XMM0,XMM7
930	PUNPCKLWD XMM0,XMM7
931	CVTDQ2PS XMM0,XMM0
932	MOVD XMM1,B
933	PUNPCKLBW XMM1,XMM7
934	PUNPCKLWD XMM1,XMM7
935	CVTDQ2PS XMM1,XMM1
936
937	MOV EAX, WA
938	MOVD XMM4,EAX
939	SHUFPS XMM4,XMM4,0
940	MULPS XMM0,XMM4
941
942	MOV EDX, WB
943	MOVD XMM5,EDX
944	SHUFPS XMM5,XMM5,0
945	MULPS XMM1,XMM5
946	ADDPS XMM0,XMM1
947
948	MOVD XMM2,C
949	PUNPCKLBW XMM2,XMM7
950	PUNPCKLWD XMM2,XMM7
951	CVTDQ2PS XMM2,XMM2
952	MOVD XMM3,D
953	PUNPCKLBW XMM3,XMM7
954	PUNPCKLWD XMM3,XMM7
955	CVTDQ2PS XMM3,XMM3
956
957	MOV EAX, WC
958	MOVD XMM4,EAX
959	SHUFPS XMM4,XMM4,0
960	MULPS XMM2,XMM4
961
962	MOV EDX, WD
963	MOVD XMM5,EDX
964	SHUFPS XMM5,XMM5,0
965	MULPS XMM3,XMM5
966	ADDPS XMM2,XMM3
967	ADDPS XMM0,XMM2
968
969	CVTPS2DQ XMM0,XMM0
970	PACKSSDW XMM0,XMM7
971	PACKUSWB XMM0,XMM7
972	MOVD EAX,XMM0
973	{$ENDIF}
974	end;
975	{$ENDIF}
976	{$ENDIF}
977
978
979	{ TColor32LookupTable }
980
981	constructor TColor32LookupTable.Create(Order: Byte);
982	begin
983	inherited Create;
984	FOrder := Order;
985	OrderChanged;
986	end;
987
988	destructor TColor32LookupTable.Destroy;
989	begin
990	{$WARNINGS OFF}
991	FreeMem(FGradientLUT);
992	{$WARNINGS ON}
993	inherited;
994	end;
995
996	procedure TColor32LookupTable.AssignTo(Dest: TPersistent);
997	begin
998	if Dest is TColor32LookupTable then
999	with TColor32LookupTable(Dest) do
1000	begin
1001	FOrder := Self.FOrder;
1002	OrderChanged;
1003	Move(Self.FGradientLUT^, FGradientLUT^, FSize * SizeOf(TColor32));
1004	end
1005	else
1006	inherited;
1007	end;
1008
1009	function TColor32LookupTable.GetColor32(Index: Integer): TColor32;
1010	begin
1011	Result := FGradientLUT^[Index and FMask];
1012	end;
1013
1014	procedure TColor32LookupTable.OrderChanged;
1015	begin
1016	FSize := 1 shl FOrder;
1017	FMask := FSize - 1;
1018	{$WARNINGS OFF}
1019	ReallocMem(FGradientLUT, FSize * SizeOf(TColor32));
1020	{$WARNINGS ON}
1021	if Assigned(FOnOrderChanged) then
1022	FOnOrderChanged(Self);
1023	end;
1024
1025	procedure TColor32LookupTable.SetColor32(Index: Integer; const Value: TColor32);
1026	begin
1027	if (Index < 0) or (Index > Integer(FMask)) then
1028	raise Exception.CreateFmt(RCStrIndexOutOfBounds, [Index])
1029	else
1030	FGradientLUT^[Index] := Value;
1031	end;
1032
1033	procedure TColor32LookupTable.SetOrder(const Value: Byte);
1034	begin
1035	if FOrder <> Value then
1036	begin
1037	FOrder := Value;
1038	OrderChanged;
1039	end;
1040	end;
1041
1042
1043	{ TColor32Gradient; }
1044
1045	constructor TColor32Gradient.Create(Color: TColor32);
1046	begin
1047	Create(Color, Color);
1048	end;
1049
1050	constructor TColor32Gradient.Create(StartColor, EndColor: TColor32);
1051	var
1052	Temp: TArrayOfColor32GradientStop;
1053	begin
1054	// simple gradient using 2 color stops
1055	SetLength(Temp, 2);
1056	Temp[0].Offset := 0;
1057	Temp[0].Color32 := StartColor;
1058	Temp[1].Offset := 1;
1059	Temp[1].Color32 := EndColor;
1060
1061	Create(Temp);
1062	end;
1063
1064	constructor TColor32Gradient.Create(const GradientColors: TArrayOfColor32GradientStop);
1065	begin
1066	inherited Create;
1067	SetColors(GradientColors);
1068	end;
1069
1070	procedure TColor32Gradient.AssignTo(Dest: TPersistent);
1071	begin
1072	if Dest is TColor32Gradient then
1073	TColor32Gradient(Dest).SetColors(Self.FGradientColors)
1074	else
1075	inherited;
1076	end;
1077
1078	procedure TColor32Gradient.AddColorStop(ColorStop: TColor32GradientStop);
1079	begin
1080	AddColorStop(ColorStop.Offset, ColorStop.Color32);
1081	end;
1082
1083	procedure TColor32Gradient.AddColorStop(Offset: TFloat; Color: TColor32);
1084	var
1085	Index, OldCount: Integer;
1086	begin
1087	OldCount := Length(FGradientColors);
1088	Index := 0;
1089
1090	// navigate to index where the color stop shall be inserted
1091	while (Index < OldCount) and (Offset >= FGradientColors[Index].Offset) do
1092	Inc(Index);
1093
1094	SetLength(FGradientColors, OldCount + 1);
1095
1096	// move existing color stops to make space for the new color stop
1097	if (Index < OldCount) then
1098	Move(FGradientColors[Index], FGradientColors[Index + 1],
1099	(OldCount - Index) * SizeOf(TColor32GradientStop));
1100
1101	// finally insert new color stop
1102	FGradientColors[Index].Offset := Offset;
1103	FGradientColors[Index].Color32 := Color;
1104	GradientColorsChanged;
1105	end;
1106
1107	procedure TColor32Gradient.ClearColorStops(Color: TColor32);
1108	begin
1109	SetLength(FGradientColors, 0);
1110	FGradientColors[0].Offset := 0;
1111	FGradientColors[0].Color32 := Color;
1112	GradientColorsChanged;
1113	end;
1114
1115	procedure TColor32Gradient.ClearColorStops;
1116	begin
1117	SetLength(FGradientColors, 0);
1118	GradientColorsChanged;
1119	end;
1120
1121	procedure TColor32Gradient.SetColors(const GradientColors: array of const);
1122	var
1123	Index: Integer;
1124	Scale: TFloat;
1125	begin
1126	if High(GradientColors) < 0 then
1127	begin
1128	// no colors specified
1129	if Length(FGradientColors) > 0 then
1130	ClearColorStops;
1131	end else
1132	begin
1133	SetLength(FGradientColors, High(GradientColors) + 1);
1134
1135	if High(GradientColors) >= 1 then
1136	begin
1137	// several colors (at least 2)
1138	Scale := 1 / (Length(GradientColors) - 1);
1139	for Index := 0 to Length(GradientColors) - 1 do
1140	begin
1141	Assert(GradientColors[Index].VType = vtInteger);
1142	FGradientColors[Index].Color32 := GradientColors[Index].VInteger;
1143	FGradientColors[Index].Offset := Index * Scale;
1144	end;
1145	end
1146	else
1147	begin
1148	// only 1 color
1149	Assert(GradientColors[0].VType = vtInteger);
1150	FGradientColors[0].Color32 := GradientColors[0].VInteger;
1151	FGradientColors[0].Offset := 0;
1152	end;
1153
1154	GradientColorsChanged;
1155	end;
1156	end;
1157
1158	procedure TColor32Gradient.SetColors(const GradientColors: TArrayOfColor32GradientStop);
1159	var
1160	Index: Integer;
1161	begin
1162	if Length(GradientColors) = 0 then
1163	begin
1164	if Length(FGradientColors) > 0 then
1165	ClearColorStops;
1166	end else
1167	begin
1168	SetLength(FGradientColors, Length(GradientColors));
1169	for Index := 0 to Length(GradientColors) - 1 do
1170	FGradientColors[Index] := GradientColors[Index];
1171	GradientColorsChanged;
1172	end;
1173	end;
1174
1175	procedure TColor32Gradient.SetColors(const GradientColors: TArrayOfColor32);
1176	var
1177	Index: Integer;
1178	Scale: TFloat;
1179	begin
1180	if Length(GradientColors) = 0 then
1181	begin
1182	// no colors specified
1183	if Length(FGradientColors) > 0 then
1184	ClearColorStops;
1185	end else
1186	begin
1187	SetLength(FGradientColors, Length(GradientColors));
1188
1189	if Length(GradientColors) > 1 then
1190	begin
1191	// several colors (at least 2)
1192	Scale := 1 / (Length(GradientColors) - 1);
1193	for Index := 0 to Length(GradientColors) - 1 do
1194	begin
1195	FGradientColors[Index].Color32 := GradientColors[Index];
1196	FGradientColors[Index].Offset := Index * Scale;
1197	end;
1198	end
1199	else
1200	begin
1201	// only 1 color
1202	FGradientColors[0].Color32 := GradientColors[0];
1203	FGradientColors[0].Offset := 0;
1204	end;
1205
1206	GradientColorsChanged;
1207	end;
1208	end;
1209
1210	procedure TColor32Gradient.SetColors(const Palette: TPalette32);
1211	var
1212	Index: Integer;
1213	Scale: TFloat;
1214	begin
1215	// TPalette32 contains 256 colors
1216	SetLength(FGradientColors, Length(Palette));
1217
1218	Scale := 1 / (Length(Palette) - 1);
1219	for Index := 0 to Length(Palette) - 1 do
1220	begin
1221	FGradientColors[Index].Color32 := Palette[Index];
1222	FGradientColors[Index].Offset := Index * Scale;
1223	end;
1224
1225	GradientColorsChanged;
1226	end;
1227
1228	procedure TColor32Gradient.SetStartColor(const Value: TColor32);
1229	var
1230	HasChanged: Boolean;
1231	begin
1232	HasChanged := False;
1233	if Length(FGradientColors) = 0 then
1234	begin
1235	SetLength(FGradientColors, 1);
1236	HasChanged := True;
1237	end;
1238	if FGradientColors[0].Offset <> 0 then
1239	begin
1240	FGradientColors[0].Offset := 0;
1241	HasChanged := True;
1242	end;
1243	if FGradientColors[0].Color32 <> Value then
1244	begin
1245	FGradientColors[0].Color32 := Value;
1246	HasChanged := True;
1247	end;
1248	if HasChanged then
1249	GradientColorsChanged;
1250	end;
1251
1252	procedure TColor32Gradient.SetEndColor(const Value: TColor32);
1253	var
1254	HasChanged: Boolean;
1255	begin
1256	HasChanged := False;
1257	if Length(FGradientColors) = 1 then
1258	begin
1259	SetLength(FGradientColors, 2);
1260	HasChanged := True;
1261	end;
1262	if FGradientColors[High(FGradientColors)].Offset <> 1 then
1263	begin
1264	FGradientColors[High(FGradientColors)].Offset := 1;
1265	HasChanged := True;
1266	end;
1267	if FGradientColors[High(FGradientColors)].Color32 <> Value then
1268	begin
1269	FGradientColors[High(FGradientColors)].Color32 := Value;
1270	HasChanged := True;
1271	end;
1272	if HasChanged then
1273	GradientColorsChanged;
1274	end;
1275
1276	function TColor32Gradient.GetGradientCount: Integer;
1277	begin
1278	Result := Length(FGradientColors);
1279	end;
1280
1281	function TColor32Gradient.GetGradientEntry(Index: Integer): TColor32GradientStop;
1282	begin
1283	if Index > Length(FGradientColors) then
1284	raise Exception.CreateFmt(RCStrIndexOutOfBounds, [Index])
1285	else
1286	Result := FGradientColors[Index];
1287	end;
1288
1289	function TColor32Gradient.GetStartColor: TColor32;
1290	begin
1291	if Length(FGradientColors) = 0 then
1292	Result := clNone32
1293	else
1294	Result := FGradientColors[0].Color32;
1295	end;
1296
1297	function TColor32Gradient.GetEndColor: TColor32;
1298	var
1299	Count: Integer;
1300	begin
1301	Count := Length(FGradientColors);
1302	if Count = 0 then
1303	Result := clNone32
1304	else
1305	Result := FGradientColors[Count - 1].Color32;
1306	end;
1307
1308	function TColor32Gradient.GetColorAt(Offset: TFloat): TColor32;
1309	var
1310	Index, Count: Integer;
1311	begin
1312	Count := GradientCount;
1313	if (Count = 0) or (Offset <= FGradientColors[0].Offset) then
1314	Result := StartColor
1315	else if (Offset >= FGradientColors[Count - 1].Offset) then
1316	Result := EndColor
1317	else
1318	begin
1319	Index := 1;
1320
1321	// find color index for a given offset (between 0 and 1)
1322	while (Index < Count) and (Offset > FGradientColors[Index].Offset) do
1323	Inc(Index);
1324
1325	// calculate new offset (between two colors before and at 'Index')
1326	Offset := (Offset - FGradientColors[Index - 1].Offset) /
1327	(FGradientColors[Index].Offset - FGradientColors[Index - 1].Offset);
1328
1329	// check if offset is out of bounds
1330	if Offset <= 0 then
1331	Result := FGradientColors[Index - 1].Color32
1332	else if Offset >= 1 then
1333	Result := FGradientColors[Index].Color32
1334	else
1335	begin
1336	// interpolate color
1337	Result := CombineReg(FGradientColors[Index].Color32,
1338	FGradientColors[Index - 1].Color32, Round($FF * Offset));
1339	EMMS;
1340	end;
1341	end;
1342	end;
1343
1344	procedure TColor32Gradient.FillColorLookUpTable(ColorLUT: TColor32LookupTable);
1345	begin
1346	FillColorLookUpTable(ColorLUT.Color32Ptr, ColorLUT.Size);
1347	end;
1348
1349	procedure TColor32Gradient.FillColorLookUpTable(var ColorLUT: array of TColor32);
1350	begin
1351	{$WARNINGS OFF}
1352	FillColorLookUpTable(@ColorLUT[0], Length(ColorLUT));
1353	{$WARNINGS ON}
1354	end;
1355
1356	procedure TColor32Gradient.FillColorLookUpTable(ColorLUT: PColor32Array;
1357	Count: Integer);
1358	var
1359	LutIndex, StopIndex, GradCount: Integer;
1360	RecalculateScale: Boolean;
1361	Fraction, LocalFraction, Delta, Scale: TFloat;
1362	begin
1363	GradCount := GradientCount;
1364
1365	//check trivial case
1366	if (GradCount < 2) or (Count < 2) then
1367	begin
1368	for LutIndex := 0 to Count - 1 do
1369	ColorLUT^[LutIndex] := StartColor;
1370	Exit;
1371	end;
1372
1373	// set first (start) and last (end) color
1374	ColorLUT^[0] := StartColor;
1375	ColorLUT^[Count - 1] := EndColor;
1376	Delta := 1 / Count;
1377	Fraction := Delta;
1378
1379	LutIndex := 1;
1380	while Fraction <= FGradientColors[0].Offset do
1381	begin
1382	ColorLUT^[LutIndex] := ColorLUT^[0];
1383	Fraction := Fraction + Delta;
1384	Inc(LutIndex);
1385	end;
1386
1387	Scale := 1;
1388	StopIndex := 1;
1389	RecalculateScale := True;
1390	for LutIndex := LutIndex to Count - 2 do
1391	begin
1392	// eventually search next stop
1393	while (Fraction > FGradientColors[StopIndex].Offset) do
1394	begin
1395	Inc(StopIndex);
1396	if (StopIndex >= GradCount) then
1397	Break;
1398	RecalculateScale := True;
1399	end;
1400
1401	// eventually fill remaining LUT
1402	if StopIndex = GradCount then
1403	begin
1404	for StopIndex := LutIndex to Count - 2 do
1405	ColorLUT^[StopIndex] := ColorLUT^[Count - 1];
1406	Break;
1407	end;
1408
1409	// eventually recalculate scale
1410	if RecalculateScale then
1411	Scale := 1 / (FGradientColors[StopIndex].Offset -
1412	FGradientColors[StopIndex - 1].Offset);
1413
1414	// calculate current color
1415	LocalFraction := (Fraction - FGradientColors[StopIndex - 1].Offset) * Scale;
1416	if LocalFraction <= 0 then
1417	ColorLUT^[LutIndex] := FGradientColors[StopIndex - 1].Color32
1418	else if LocalFraction >= 1 then
1419	ColorLUT^[LutIndex] := FGradientColors[StopIndex].Color32
1420	else
1421	begin
1422	ColorLUT^[LutIndex] := CombineReg(FGradientColors[StopIndex].Color32,
1423	FGradientColors[StopIndex - 1].Color32, Round($FF * LocalFraction));
1424	EMMS;
1425	end;
1426	Fraction := Fraction + Delta;
1427	end;
1428	end;
1429
1430	procedure TColor32Gradient.GradientColorsChanged;
1431	begin
1432	if Assigned(FOnGradientColorsChanged) then
1433	FOnGradientColorsChanged(Self);
1434	end;
1435
1436	procedure TColor32Gradient.LoadFromStream(Stream: TStream);
1437	var
1438	Index: Integer;
1439	ChunkName: array [0..3] of AnsiChar;
1440	ValueInt: Integer;
1441	ValueFloat: Single;
1442	begin
1443	// read simple header
1444	Stream.Read(ChunkName, 4);
1445	if ChunkName <> 'Grad' then
1446	raise Exception.Create(RCStrWrongFormat);
1447	Stream.Read(ValueInt, 4);
1448	SetLength(FGradientColors, ValueInt);
1449
1450	// read data
1451	for Index := 0 to Length(FGradientColors) - 1 do
1452	begin
1453	ValueFloat := FGradientColors[Index].Offset;
1454	Stream.Read(ValueFloat, 4);
1455	ValueInt := FGradientColors[Index].Color32;
1456	Stream.Read(ValueInt, 4);
1457	end;
1458
1459	GradientColorsChanged;
1460	end;
1461
1462	procedure TColor32Gradient.SaveToStream(Stream: TStream);
1463	var
1464	Index: Integer;
1465	ChunkName: array [0..3] of AnsiChar;
1466	ValueInt: Integer;
1467	ValueFloat: Single;
1468	begin
1469	// write simple header
1470	ChunkName := 'Grad';
1471	Stream.Write(ChunkName, 4);
1472	ValueInt := Length(FGradientColors);
1473	Stream.Write(ValueInt, 4);
1474
1475	// write data
1476	for Index := 0 to Length(FGradientColors) - 1 do
1477	begin
1478	ValueFloat := FGradientColors[Index].Offset;
1479	Stream.Write(ValueFloat, 4);
1480	ValueInt := FGradientColors[Index].Color32;
1481	Stream.Write(ValueInt, 4);
1482	end;
1483	end;
1484
1485
1486	{ TCustomSparsePointGradientSampler }
1487
1488	function TCustomSparsePointGradientSampler.GetSampleFixed(X, Y: TFixed): TColor32;
1489	begin
1490	Result := GetSampleFloat(X * FixedToFloat, Y * FixedToFloat);
1491	end;
1492
1493	function TCustomSparsePointGradientSampler.GetSampleInt(X, Y: Integer): TColor32;
1494	begin
1495	Result := GetSampleFloat(X, Y);
1496	end;
1497
1498
1499	{ TBarycentricGradientSampler }
1500
1501	constructor TBarycentricGradientSampler.Create(P1, P2, P3: TColor32FloatPoint);
1502	begin
1503	FColorPoints[0] := P1;
1504	FColorPoints[1] := P2;
1505	FColorPoints[2] := P3;
1506	inherited Create;
1507	end;
1508
1509	procedure TBarycentricGradientSampler.AssignTo(Dest: TPersistent);
1510	begin
1511	if Dest is TBarycentricGradientSampler then
1512	with TBarycentricGradientSampler(Dest) do
1513	FColorPoints := Self.FColorPoints
1514	else
1515	inherited;
1516	end;
1517
1518	function TBarycentricGradientSampler.GetColor(Index: Integer): TColor32;
1519	begin
1520	if Index in [0 .. 2] then
1521	Result := FColorPoints[Index].Color32
1522	else
1523	raise Exception.CreateFmt(RCStrIndexOutOfBounds, [Index]);
1524	end;
1525
1526	function TBarycentricGradientSampler.GetColorPoint(
1527	Index: Integer): TColor32FloatPoint;
1528	begin
1529	if Index in [0 .. 2] then
1530	Result := FColorPoints[Index]
1531	else
1532	raise Exception.CreateFmt(RCStrIndexOutOfBounds, [Index]);
1533	end;
1534
1535	function TBarycentricGradientSampler.GetCount: Integer;
1536	begin
1537	Result := 3;
1538	end;
1539
1540	function TBarycentricGradientSampler.GetPoint(Index: Integer): TFloatPoint;
1541	begin
1542	if Index in [0 .. 2] then
1543	Result := FColorPoints[Index].Point
1544	else
1545	raise Exception.CreateFmt(RCStrIndexOutOfBounds, [Index]);
1546	end;
1547
1548	procedure TBarycentricGradientSampler.CalculateBarycentricCoordinates(
1549	X, Y: TFloat; out U, V, W: TFloat);
1550	var
1551	Temp: TFloatPoint;
1552	begin
1553	Temp.X := X - FColorPoints[2].Point.X;
1554	Temp.Y := Y - FColorPoints[2].Point.Y;
1555	U := FDists[0].Y * Temp.X + FDists[0].X * Temp.Y;
1556	V := FDists[1].Y * Temp.X + FDists[1].X * Temp.Y;
1557	W := 1 - U - V;
1558	end;
1559
1560	function TBarycentricGradientSampler.GetSampleFloat(X, Y: TFloat): TColor32;
1561	var
1562	U, V, W: TFloat;
1563	begin
1564	CalculateBarycentricCoordinates(X, Y, U, V, W);
1565	Result := Linear3PointInterpolationProc(FColorPoints[0].Color32,
1566	FColorPoints[1].Color32, FColorPoints[2].Color32, U, V, W);
1567	end;
1568
1569	function TBarycentricGradientSampler.GetSampleFloatInTriangle(X,
1570	Y: TFloat): TColor32;
1571	var
1572	U, V, W: TFloat;
1573	begin
1574	CalculateBarycentricCoordinates(X, Y, U, V, W);
1575	if U < 0 then
1576	begin
1577	U := (V + W);
1578	V := V / U;
1579	W := W / U;
1580	U := 0;
1581	end;
1582	if V < 0 then
1583	begin
1584	V := (U + W);
1585	U := U / V;
1586	W := W / V;
1587	V := 0;
1588	end;
1589	if V < 0 then
1590	begin
1591	W := (U + V);
1592	U := U / W;
1593	V := V / W;
1594	W := 0;
1595	end;
1596
1597	Result := Linear3PointInterpolationProc(FColorPoints[0].Color32,
1598	FColorPoints[1].Color32, FColorPoints[2].Color32, U, V, W);
1599	end;
1600
1601	function TBarycentricGradientSampler.IsPointInTriangle(
1602	const Point: TFloatPoint): Boolean;
1603	var
1604	U, V, W: TFloat;
1605	begin
1606	CalculateBarycentricCoordinates(Point.X, Point.Y, U, V, W);
1607	Result := (U >= 0) and (V >= 0) and (W >= 0);
1608	end;
1609
1610	function TBarycentricGradientSampler.IsPointInTriangle(X, Y: TFloat): Boolean;
1611	var
1612	U, V, W: TFloat;
1613	begin
1614	CalculateBarycentricCoordinates(X, Y, U, V, W);
1615	Result := (U >= 0) and (V >= 0) and (W >= 0);
1616	end;
1617
1618	procedure TBarycentricGradientSampler.PrepareSampling;
1619	var
1620	NormScale: TFloat;
1621	begin
1622	NormScale := 1 / ((FColorPoints[1].Point.Y - FColorPoints[2].Point.Y) *
1623	(FColorPoints[0].Point.X - FColorPoints[2].Point.X) +
1624	(FColorPoints[2].Point.X - FColorPoints[1].Point.X) *
1625	(FColorPoints[0].Point.Y - FColorPoints[2].Point.Y));
1626
1627	FDists[0].X := NormScale * (FColorPoints[2].Point.X - FColorPoints[1].Point.X);
1628	FDists[0].Y := NormScale * (FColorPoints[1].Point.Y - FColorPoints[2].Point.Y);
1629	FDists[1].X := NormScale * (FColorPoints[0].Point.X - FColorPoints[2].Point.X);
1630	FDists[1].Y := NormScale * (FColorPoints[2].Point.Y - FColorPoints[0].Point.Y);
1631	end;
1632
1633	procedure TBarycentricGradientSampler.SetColor(Index: Integer;
1634	const Value: TColor32);
1635	begin
1636	if Index in [0 .. 2] then
1637	FColorPoints[Index].Color32 := Value
1638	else
1639	raise Exception.CreateFmt(RCStrIndexOutOfBounds, [Index]);
1640	end;
1641
1642	procedure TBarycentricGradientSampler.SetColorPoint(Index: Integer;
1643	const Value: TColor32FloatPoint);
1644	begin
1645	if Index in [0 .. 2] then
1646	FColorPoints[Index] := Value
1647	else
1648	raise Exception.CreateFmt(RCStrIndexOutOfBounds, [Index]);
1649	end;
1650
1651	procedure TBarycentricGradientSampler.SetColorPoints(
1652	ColorPoints: TArrayOfColor32FloatPoint);
1653	begin
1654	if Length(ColorPoints) <> 3 then
1655	raise Exception.Create(RCStrOnlyExactly3Point);
1656
1657	FColorPoints[0] := ColorPoints[0];
1658	FColorPoints[1] := ColorPoints[1];
1659	FColorPoints[2] := ColorPoints[2];
1660	end;
1661
1662	procedure TBarycentricGradientSampler.SetColorPoints(Points: TArrayOfFloatPoint;
1663	Colors: TArrayOfColor32);
1664	begin
1665	if (Length(Points) <> 3) or (Length(Colors) <> 3) then
1666	raise Exception.Create(RCStrOnlyExactly3Point);
1667
1668	FColorPoints[0] := Color32FloatPoint(Colors[0], Points[0]);
1669	FColorPoints[1] := Color32FloatPoint(Colors[1], Points[1]);
1670	FColorPoints[2] := Color32FloatPoint(Colors[2], Points[2]);
1671	end;
1672
1673	procedure TBarycentricGradientSampler.SetPoint(Index: Integer;
1674	const Value: TFloatPoint);
1675	begin
1676	if Index in [0 .. 2] then
1677	FColorPoints[Index].Point := Value
1678	else
1679	raise Exception.CreateFmt(RCStrIndexOutOfBounds, [Index]);
1680	end;
1681
1682	procedure TBarycentricGradientSampler.SetPoints(Points: TArrayOfFloatPoint);
1683	begin
1684	if Length(Points) <> 3 then
1685	raise Exception.Create(RCStrOnlyExactly3Point);
1686
1687	FColorPoints[0].Point := Points[0];
1688	FColorPoints[1].Point := Points[1];
1689	FColorPoints[2].Point := Points[2];
1690	end;
1691
1692
1693	{ TBilinearGradientSampler }
1694
1695	procedure TBilinearGradientSampler.AssignTo(Dest: TPersistent);
1696	begin
1697	if Dest is TBilinearGradientSampler then
1698	with TBilinearGradientSampler(Dest) do
1699	FColorPoints := Self.FColorPoints
1700	else
1701	inherited;
1702	end;
1703
1704	function TBilinearGradientSampler.GetColor(Index: Integer): TColor32;
1705	begin
1706	if Index in [0 .. 3] then
1707	Result := FColorPoints[Index].Color32
1708	else
1709	raise Exception.CreateFmt(RCStrIndexOutOfBounds, [Index]);
1710	end;
1711
1712	function TBilinearGradientSampler.GetColorPoint(
1713	Index: Integer): TColor32FloatPoint;
1714	begin
1715	if Index in [0 .. 3] then
1716	Result := FColorPoints[Index]
1717	else
1718	raise Exception.CreateFmt(RCStrIndexOutOfBounds, [Index]);
1719	end;
1720
1721	function TBilinearGradientSampler.GetCount: Integer;
1722	begin
1723	Result := 4;
1724	end;
1725
1726	function TBilinearGradientSampler.GetPoint(Index: Integer): TFloatPoint;
1727	begin
1728	if Index in [0 .. 3] then
1729	Result := FColorPoints[Index].Point
1730	else
1731	raise Exception.CreateFmt(RCStrIndexOutOfBounds, [Index]);
1732	end;
1733
1734	function TBilinearGradientSampler.GetSampleFloat(X, Y: TFloat): TColor32;
1735	var
1736	u, v, t, k0, k1: Double;
1737	begin
1738	k1 := FDot + X * FDists[2].Y - Y * FDists[2].X;
1739	k0 := FBiasK0 + X * FDists[0].Y - Y * FDists[0].X;
1740	t := Sqr(k1) - 2 * k0 * FK2Value;
1741
1742	if FK2Value = 0 then
1743	v := -k0 / k1
1744	else
1745	v := (FK2Sign * Sqrt(Abs(t)) - k1) / FK2Value;
1746	u := (X - FBiasU - FDists[1].X * v) / (FDists[0].X + FDists[2].X * v);
1747
1748	Result := Linear4PointInterpolationProc(FColorPoints[0].Color32,
1749	FColorPoints[1].Color32, FColorPoints[2].Color32, FColorPoints[3].Color32,
1750	(1 - u) * (1 - v), u * (1 - v), u * v, (1 - u) * v);
1751	end;
1752
1753	procedure TBilinearGradientSampler.PrepareSampling;
1754	var
1755	v, i, j: Integer;
1756	Orientation: array [0 .. 3] of Boolean;
1757	Indices: array [0 .. 1] of Integer;
1758	TempPoint: TColor32FloatPoint;
1759	begin
1760	Orientation[0] := (FColorPoints[0].Point.X - FColorPoints[3].Point.X) *
1761	(FColorPoints[1].Point.Y - FColorPoints[0].Point.Y) -
1762	(FColorPoints[0].Point.Y - FColorPoints[3].Point.Y) *
1763	(FColorPoints[1].Point.X - FColorPoints[0].Point.X) < 0;
1764	Orientation[1] := (FColorPoints[1].Point.X - FColorPoints[0].Point.X) *
1765	(FColorPoints[2].Point.Y - FColorPoints[1].Point.Y) -
1766	(FColorPoints[1].Point.Y - FColorPoints[0].Point.Y) *
1767	(FColorPoints[2].Point.X - FColorPoints[1].Point.X) < 0;
1768	Orientation[2] := (FColorPoints[2].Point.X - FColorPoints[1].Point.X) *
1769	(FColorPoints[3].Point.Y - FColorPoints[2].Point.Y) -
1770	(FColorPoints[2].Point.Y - FColorPoints[1].Point.Y) *
1771	(FColorPoints[3].Point.X - FColorPoints[2].Point.X) < 0;
1772	Orientation[3] := (FColorPoints[3].Point.X - FColorPoints[2].Point.X) *
1773	(FColorPoints[0].Point.Y - FColorPoints[3].Point.Y) -
1774	(FColorPoints[3].Point.Y - FColorPoints[2].Point.Y) *
1775	(FColorPoints[0].Point.X - FColorPoints[3].Point.X) < 0;
1776
1777	if Orientation[0] then v := -1 else v := 1;
1778	if Orientation[1] then Dec(v) else Inc(v);
1779	if Orientation[2] then Dec(v) else Inc(v);
1780	if Orientation[3] then Dec(v) else Inc(v);
1781	FK2Sign := Sign(v);
1782
1783	if v = 0 then
1784	begin
1785	// correct complex case
1786	i := 0;
1787	j := 0;
1788	repeat
1789	if Orientation[j] then
1790	begin
1791	Indices[i] := j;
1792	Inc(i);
1793	end;
1794	Inc(j);
1795	until i = 2;
1796
1797	// exchange color points
1798	TempPoint := FColorPoints[Indices[0]];
1799	FColorPoints[Indices[0]] := FColorPoints[Indices[1]];
1800	FColorPoints[Indices[1]] := TempPoint;
1801
1802	FK2Sign := 1;
1803	end;
1804
1805	FDists[0].X := FColorPoints[1].Point.X - FColorPoints[0].Point.X;
1806	FDists[0].Y := FColorPoints[1].Point.Y - FColorPoints[0].Point.Y;
1807	FDists[1].X := FColorPoints[3].Point.X - FColorPoints[0].Point.X;
1808	FDists[1].Y := FColorPoints[3].Point.Y - FColorPoints[0].Point.Y;
1809	FDists[2].X := FColorPoints[0].Point.X - FColorPoints[1].Point.X +
1810	FColorPoints[2].Point.X - FColorPoints[3].Point.X;
1811	FDists[2].Y := FColorPoints[0].Point.Y - FColorPoints[1].Point.Y +
1812	FColorPoints[2].Point.Y - FColorPoints[3].Point.Y;
1813	FK2Value := 2 * (FDists[2].X * FDists[1].Y - FDists[2].Y * FDists[1].X);
1814
1815	FDot := FDists[0].X * FDists[1].Y - FDists[0].Y * FDists[1].X -
1816	FColorPoints[0].Point.X * FDists[2].Y + FColorPoints[0].Point.Y * FDists[2].X;
1817	FBiasK0 := FColorPoints[0].Point.Y * FDists[0].X -
1818	FColorPoints[0].Point.X * FDists[0].Y;
1819	FBiasU := FColorPoints[0].Point.X;
1820	end;
1821
1822	procedure TBilinearGradientSampler.SetColor(Index: Integer;
1823	const Value: TColor32);
1824	begin
1825	if Index in [0 .. 3] then
1826	FColorPoints[Index].Color32 := Value
1827	else
1828	raise Exception.CreateFmt(RCStrIndexOutOfBounds, [Index]);
1829	end;
1830
1831	procedure TBilinearGradientSampler.SetColorPoint(Index: Integer;
1832	const Value: TColor32FloatPoint);
1833	begin
1834	if Index in [0 .. 3] then
1835	FColorPoints[Index] := Value
1836	else
1837	raise Exception.CreateFmt(RCStrIndexOutOfBounds, [Index]);
1838	end;
1839
1840	procedure TBilinearGradientSampler.SetColorPoints(
1841	ColorPoints: TArrayOfColor32FloatPoint);
1842	begin
1843	if Length(ColorPoints) <> 4 then
1844	raise Exception.Create(RCStrOnlyExactly3Point);
1845
1846	FColorPoints[0] := ColorPoints[0];
1847	FColorPoints[1] := ColorPoints[1];
1848	FColorPoints[2] := ColorPoints[2];
1849	FColorPoints[3] := ColorPoints[3];
1850	end;
1851
1852	procedure TBilinearGradientSampler.SetColorPoints(Points: TArrayOfFloatPoint;
1853	Colors: TArrayOfColor32);
1854	begin
1855	if (Length(Points) <> 3) or (Length(Colors) <> 3) then
1856	raise Exception.Create(RCStrOnlyExactly3Point);
1857
1858	FColorPoints[0] := Color32FloatPoint(Colors[0], Points[0]);
1859	FColorPoints[1] := Color32FloatPoint(Colors[1], Points[1]);
1860	FColorPoints[2] := Color32FloatPoint(Colors[2], Points[2]);
1861	FColorPoints[3] := Color32FloatPoint(Colors[3], Points[3]);
1862	end;
1863
1864	procedure TBilinearGradientSampler.SetPoint(Index: Integer;
1865	const Value: TFloatPoint);
1866	begin
1867	if Index in [0 .. 3] then
1868	FColorPoints[Index].Point := Value
1869	else
1870	raise Exception.CreateFmt(RCStrIndexOutOfBounds, [Index]);
1871	end;
1872
1873	procedure TBilinearGradientSampler.SetPoints(Points: TArrayOfFloatPoint);
1874	begin
1875	if Length(Points) <> 4 then
1876	raise Exception.Create(RCStrOnlyExactly3Point);
1877
1878	FColorPoints[0].Point := Points[0];
1879	FColorPoints[1].Point := Points[1];
1880	FColorPoints[2].Point := Points[2];
1881	FColorPoints[3].Point := Points[3];
1882	end;
1883
1884
1885	{ TCustomArbitrarySparsePointGradientSampler }
1886
1887	procedure TCustomArbitrarySparsePointGradientSampler.AssignTo(Dest: TPersistent);
1888	begin
1889	if Dest is TCustomArbitrarySparsePointGradientSampler then
1890	with TCustomArbitrarySparsePointGradientSampler(Dest) do
1891	begin
1892	FColorPoints := Self.FColorPoints;
1893	end
1894	else
1895	inherited;
1896	end;
1897
1898	procedure TCustomArbitrarySparsePointGradientSampler.Add(Point: TFloatPoint;
1899	Color: TColor32);
1900	var
1901	Index: Integer;
1902	begin
1903	Index := Length(FColorPoints);
1904	SetLength(FColorPoints, Index + 1);
1905	FColorPoints[Index].Point := Point;
1906	FColorPoints[Index].Color32 := Color;
1907	end;
1908
1909	procedure TCustomArbitrarySparsePointGradientSampler.Add(
1910	const ColorPoint: TColor32FloatPoint);
1911	var
1912	Index: Integer;
1913	begin
1914	Index := Length(FColorPoints);
1915	SetLength(FColorPoints, Index + 1);
1916	FColorPoints[Index].Point := ColorPoint.Point;
1917	FColorPoints[Index].Color32 := ColorPoint.Color32;
1918	end;
1919
1920	procedure TCustomArbitrarySparsePointGradientSampler.Clear;
1921	begin
1922	SetLength(FColorPoints, 0);
1923	end;
1924
1925	function TCustomArbitrarySparsePointGradientSampler.GetColor(
1926	Index: Integer): TColor32;
1927	begin
1928	if (Index >= 0) and (Index < Length(FColorPoints)) then
1929	Result := FColorPoints[Index].Color32
1930	else
1931	raise Exception.CreateFmt(RCStrIndexOutOfBounds, [Index]);
1932	end;
1933
1934	function TCustomArbitrarySparsePointGradientSampler.GetColorPoint(
1935	Index: Integer): TColor32FloatPoint;
1936	begin
1937	if (Index >= 0) and (Index < Length(FColorPoints)) then
1938	Result := FColorPoints[Index]
1939	else
1940	raise Exception.CreateFmt(RCStrIndexOutOfBounds, [Index]);
1941	end;
1942
1943	function TCustomArbitrarySparsePointGradientSampler.GetCount: Integer;
1944	begin
1945	Result := Length(FColorPoints);
1946	end;
1947
1948	function TCustomArbitrarySparsePointGradientSampler.GetPoint(
1949	Index: Integer): TFloatPoint;
1950	begin
1951	if (Index >= 0) and (Index < Length(FColorPoints)) then
1952	Result := FColorPoints[Index].Point
1953	else
1954	raise Exception.CreateFmt(RCStrIndexOutOfBounds, [Index]);
1955	end;
1956
1957	procedure TCustomArbitrarySparsePointGradientSampler.SetColor(Index: Integer;
1958	const Value: TColor32);
1959	begin
1960	if (Index >= 0) and (Index < Length(FColorPoints)) then
1961	FColorPoints[Index].Color32 := Value
1962	else
1963	raise Exception.CreateFmt(RCStrIndexOutOfBounds, [Index]);
1964	end;
1965
1966	procedure TCustomArbitrarySparsePointGradientSampler.SetColorPoint(
1967	Index: Integer; const Value: TColor32FloatPoint);
1968	begin
1969	if (Index >= 0) and (Index < Length(FColorPoints)) then
1970	FColorPoints[Index] := Value
1971	else
1972	raise Exception.CreateFmt(RCStrIndexOutOfBounds, [Index]);
1973	end;
1974
1975	procedure TCustomArbitrarySparsePointGradientSampler.SetPoint(Index: Integer;
1976	const Value: TFloatPoint);
1977	begin
1978	if (Index >= 0) and (Index < Length(FColorPoints)) then
1979	FColorPoints[Index].Point := Value
1980	else
1981	raise Exception.CreateFmt(RCStrIndexOutOfBounds, [Index]);
1982	end;
1983
1984	procedure TCustomArbitrarySparsePointGradientSampler.SetColorPoints(
1985	ColorPoints: TArrayOfColor32FloatPoint);
1986	var
1987	Index: Integer;
1988	begin
1989	SetLength(FColorPoints, Length(ColorPoints));
1990	for Index := 0 to High(FColorPoints) do
1991	FColorPoints[Index] := ColorPoints[Index];
1992	end;
1993
1994	procedure TCustomArbitrarySparsePointGradientSampler.SetColorPoints(
1995	Points: TArrayOfFloatPoint; Colors: TArrayOfColor32);
1996	var
1997	Index: Integer;
1998	begin
1999	if Length(Points) <> Length(Colors) then
2000	raise Exception.Create(RCStrPointCountMismatch);
2001
2002	SetLength(FColorPoints, Length(Points));
2003	for Index := 0 to High(FColorPoints) do
2004	begin
2005	FColorPoints[Index].Point := Points[Index];
2006	FColorPoints[Index].Color32 := Colors[Index];
2007	end;
2008	end;
2009
2010	procedure TCustomArbitrarySparsePointGradientSampler.SetPoints(
2011	Points: TArrayOfFloatPoint);
2012	var
2013	Index: Integer;
2014	begin
2015	if Length(FColorPoints) <> Length(Points) then
2016	raise Exception.Create(RCStrPointCountMismatch);
2017
2018	for Index := 0 to High(Points) do
2019	FColorPoints[Index].Point := Points[Index];
2020	end;
2021
2022
2023	{ TInvertedDistanceWeightingSampler }
2024
2025	constructor TInvertedDistanceWeightingSampler.Create;
2026	begin
2027	inherited;
2028	FPower := 2;
2029	FScaledPower := 0.5 * FPower;
2030	end;
2031
2032	procedure TInvertedDistanceWeightingSampler.FinalizeSampling;
2033	begin
2034	inherited;
2035	Finalize(FDists);
2036	end;
2037
2038	function TInvertedDistanceWeightingSampler.GetSampleFloat(X, Y: TFloat): TColor32;
2039	var
2040	Index: Integer;
2041	Temp, DistSum, Scale: Double;
2042	R, G, B, A: TFloat;
2043	begin
2044	if Count = 1 then
2045	begin
2046	Result := FColorPoints[0].Color32;
2047	Exit;
2048	end;
2049
2050	with FColorPoints[0] do
2051	Temp := Sqr(X - Point.X) + Sqr(Y - Point.Y);
2052	if FUsePower then
2053	Temp := Math.Power(Temp, FScaledPower);
2054	FDists[0] := 1 / Max(1, Temp);
2055	DistSum := FDists[0];
2056	for Index := 1 to Count - 1 do
2057	with FColorPoints[Index] do
2058	begin
2059	Temp := Sqr(X - Point.X) + Sqr(Y - Point.Y);
2060	if FUsePower then
2061	Temp := Math.Power(Temp, FScaledPower);
2062	FDists[Index] := 1 / Max(1, Temp);
2063	DistSum := DistSum + FDists[Index];
2064	end;
2065
2066	Assert(DistSum <> 0);
2067	DistSum := 1 / DistSum;
2068	Scale := FDists[0] * DistSum;
2069
2070	case Count of
2071	3:
2072	begin
2073	// optimization for 3-Point interpolation
2074	Result := Linear3PointInterpolationProc(FColorPoints[0].Color32,
2075	FColorPoints[1].Color32, FColorPoints[2].Color32, FDists[0] * DistSum,
2076	FDists[1] * DistSum, FDists[2] * DistSum);
2077	Exit;
2078	end;
2079	4:
2080	begin
2081	// optimization for 4-Point interpolation
2082	Result := Linear4PointInterpolationProc(FColorPoints[0].Color32,
2083	FColorPoints[1].Color32, FColorPoints[2].Color32,
2084	FColorPoints[3].Color32, FDists[0] * DistSum, FDists[1] * DistSum,
2085	FDists[2] * DistSum, FDists[3] * DistSum);
2086	Exit;
2087	end;
2088	end;
2089
2090	// general n-Point interpolation
2091	R := Scale * TColor32Entry(FColorPoints[0].Color32).R;
2092	G := Scale * TColor32Entry(FColorPoints[0].Color32).G;
2093	B := Scale * TColor32Entry(FColorPoints[0].Color32).B;
2094	A := Scale * TColor32Entry(FColorPoints[0].Color32).A;
2095	for Index := 1 to Count - 1 do
2096	begin
2097	Scale := FDists[Index] * DistSum;
2098	R := R + Scale * TColor32Entry(FColorPoints[Index].Color32).R;
2099	G := G + Scale * TColor32Entry(FColorPoints[Index].Color32).G;
2100	B := B + Scale * TColor32Entry(FColorPoints[Index].Color32).B;
2101	A := A + Scale * TColor32Entry(FColorPoints[Index].Color32).A;
2102	end;
2103
2104	Result := Color32(Clamp(Round(R)), Clamp(Round(G)), Clamp(Round(B)),
2105	Clamp(Round(A)));
2106	end;
2107
2108	procedure TInvertedDistanceWeightingSampler.PrepareSampling;
2109	begin
2110	SetLength(FDists, Count);
2111	FUsePower := FPower <> 2;
2112	FScaledPower := 0.5 * FPower;
2113	inherited;
2114	end;
2115
2116
2117	{ TVoronoiSampler }
2118
2119	function TVoronoiSampler.GetSampleFloat(X, Y: TFloat): TColor32;
2120	var
2121	Index, NearestIndex: Integer;
2122	Distance: TFloat;
2123	NearestDistance: TFloat;
2124	begin
2125	NearestIndex := 0;
2126	NearestDistance := Sqr(X - FColorPoints[0].Point.X) + Sqr(Y - FColorPoints[0].Point.Y);
2127	for Index := 1 to High(FColorPoints) do
2128	begin
2129	Distance := Sqr(X - FColorPoints[Index].Point.X) + Sqr(Y - FColorPoints[Index].Point.Y);
2130	if Distance < NearestDistance then
2131	begin
2132	NearestDistance := Distance;
2133	NearestIndex := Index;
2134	end;
2135	end;
2136	Result := FColorPoints[NearestIndex].Color32;
2137	end;
2138
2139
2140	{ TDelaunaySampler }
2141
2142	procedure FastMergeSortX(const Values: TArrayOfColor32FloatPoint;
2143	out Indexes: TArrayOfInteger; out Bounds: TFloatRect);
2144	var
2145	Temp: TArrayOfInteger;
2146
2147	procedure Merge(I1, I2, J1, J2: Integer);
2148	var
2149	I, J, K: Integer;
2150	begin
2151	if Values[Indexes[I2]].Point.X < Values[Indexes[J1]].Point.X then
2152	Exit;
2153	I := I1;
2154	J := J1;
2155	K := 0;
2156	repeat
2157	if Values[Indexes[I]].Point.X < Values[Indexes[J]].Point.X then
2158	begin
2159	Temp[K] := Indexes[I];
2160	Inc(I);
2161	end
2162	else
2163	begin
2164	Temp[K] := Indexes[J];
2165	Inc(J);
2166	end;
2167	Inc(K);
2168	until (I > I2) or (J > J2);
2169
2170	while I <= I2 do
2171	begin
2172	Temp[K] := Indexes[I];
2173	Inc(I); Inc(K);
2174	end;
2175	while J <= J2 do
2176	begin
2177	Temp[K] := Indexes[J];
2178	Inc(J); Inc(K);
2179	end;
2180	for I := 0 to K - 1 do
2181	begin
2182	Indexes[I + I1] := Temp[I];
2183	end;
2184	end;
2185
2186	procedure Recurse(I1, I2: Integer);
2187	var
2188	I, IX: Integer;
2189	begin
2190	if I1 = I2 then
2191	Indexes[I1] := I1
2192	else if Indexes[I1] = Indexes[I2] then
2193	begin
2194	if Values[I1].Point.X <= Values[I2].Point.X then
2195	begin
2196	for I := I1 to I2 do Indexes[I] := I;
2197	end
2198	else
2199	begin
2200	IX := I1 + I2;
2201	for I := I1 to I2 do Indexes[I] := IX - I;
2202	end;
2203	end
2204	else
2205	begin
2206	IX := (I1 + I2) div 2;
2207	Recurse(I1, IX);
2208	Recurse(IX + 1, I2);
2209	Merge(I1, IX, IX + 1, I2);
2210	end;
2211	end;
2212
2213	var
2214	I, Index, S: Integer;
2215	begin
2216	SetLength(Temp, Length(Values));
2217	SetLength(Indexes, Length(Values));
2218
2219	Index := 0;
2220	S := Math.Sign(Values[1].Point.X - Values[0].Point.X);
2221	if S = 0 then S := 1;
2222
2223	Indexes[0] := 0;
2224
2225	// initialize bounds
2226	Bounds.Left := Values[0].Point.X;
2227	Bounds.Top := Values[0].Point.Y;
2228	Bounds.Right := Bounds.Left;
2229	Bounds.Bottom := Bounds.Top;
2230
2231	for I := 1 to High(Values) do
2232	begin
2233	if Math.Sign(Values[I].Point.X - Values[I - 1].Point.X) = -S then
2234	begin
2235	S := -S;
2236	Inc(Index);
2237	end;
2238
2239	// determine bounds
2240	if Values[I].Point.X < Bounds.Left then
2241	Bounds.Left := Values[I].Point.X;
2242	if Values[I].Point.Y < Bounds.Top then
2243	Bounds.Top := Values[I].Point.Y;
2244	if Values[I].Point.X > Bounds.Right then
2245	Bounds.Right := Values[I].Point.X;
2246	if Values[I].Point.Y > Bounds.Bottom then
2247	Bounds.Bottom := Values[I].Point.Y;
2248
2249	Indexes[I] := Index;
2250	end;
2251
2252	Recurse(0, High(Values));
2253	end;
2254
2255	function DelaunayTriangulation(Points: TArrayOfColor32FloatPoint): TArrayOfTriangleVertexIndices;
2256	var
2257	Complete: array of Byte;
2258	Edges: array of array [0 .. 1] of Integer;
2259	ByteIndex, Bit: Byte;
2260	MaxVerticesCount, EdgeCount, MaxEdgeCount, MaxTriangleCount: Integer;
2261
2262	// For super triangle
2263	ScaledDeltaMax: TFloat;
2264	Mid: TFloatPoint;
2265	Bounds: TFloatRect;
2266
2267	// General Variables
2268	SortedVertexIndices: TArrayOfInteger;
2269	TriangleCount, VertexCount, I, J, K: Integer;
2270	CenterX, CenterY, RadSqr: TFloat;
2271	Inside: Boolean;
2272	const
2273	CSuperTriangleCount = 3; // -> super triangle
2274	CTolerance = 0.000001;
2275
2276	function InCircle(Pt, Pt1, Pt2, Pt3: TFloatPoint): Boolean;
2277	// Return TRUE if the point Pt(x, y) lies inside the circumcircle made up by
2278	// points Pt1(x, y) Pt2(x, y) Pt3(x, y)
2279	// The circumcircle centre is returned in (CenterX, CenterY) and the radius r
2280	// NOTE: A point on the edge is inside the circumcircle
2281	var
2282	M1, M2, MX1, MY1, MX2, MY2: Double;
2283	DeltaX, DeltaY, DeltaRadSqr, AbsY1Y2, AbsY2Y3: Double;
2284	begin
2285	AbsY1Y2 := Abs(Pt1.Y - Pt2.Y);
2286	AbsY2Y3 := Abs(Pt2.Y - Pt3.Y);
2287
2288	// check for coincident points
2289	if (AbsY1Y2 < CTolerance) and (AbsY2Y3 < CTolerance) then
2290	begin
2291	Result := False;
2292	Exit;
2293	end;
2294
2295	if AbsY1Y2 < CTolerance then
2296	begin
2297	M2 := -(Pt3.X - Pt2.X) / (Pt3.Y - Pt2.Y);
2298	MX2 := (Pt2.X + Pt3.X) * 0.5;
2299	MY2 := (Pt2.Y + Pt3.Y) * 0.5;
2300	CenterX := (Pt2.X + Pt1.X) * 0.5;
2301	CenterY := M2 * (CenterX - MX2) + MY2;
2302	end
2303	else if AbsY2Y3 < CTolerance then
2304	begin
2305	M1 := -(Pt2.X - Pt1.X) / (Pt2.Y - Pt1.Y);
2306	MX1 := (Pt1.X + Pt2.X) * 0.5;
2307	MY1 := (Pt1.Y + Pt2.Y) * 0.5;
2308	CenterX := (Pt3.X + Pt2.X) * 0.5;
2309	CenterY := M1 * (CenterX - MX1) + MY1;
2310	end
2311	else
2312	begin
2313	M1 := -(Pt2.X - Pt1.X) / (Pt2.Y - Pt1.Y);
2314	M2 := -(Pt3.X - Pt2.X) / (Pt3.Y - Pt2.Y);
2315	if Abs(M1 - M2) < CTolerance then
2316	begin
2317	Result := False;
2318	Exit;
2319	end;
2320	MX1 := (Pt1.X + Pt2.X) * 0.5;
2321	MX2 := (Pt2.X + Pt3.X) * 0.5;
2322	MY1 := (Pt1.Y + Pt2.Y) * 0.5;
2323	MY2 := (Pt2.Y + Pt3.Y) * 0.5;
2324	CenterX := (M1 * MX1 - M2 * Mx2 + My2 - MY1) / (M1 - M2);
2325	if (AbsY1Y2 > AbsY2Y3) then
2326	CenterY := M1 * (CenterX - MX1) + MY1
2327	else
2328	CenterY := M2 * (CenterX - MX2) + MY2;
2329	end;
2330
2331	DeltaX := Pt2.X - CenterX;
2332	DeltaY := Pt2.Y - CenterY;
2333	RadSqr := DeltaX * DeltaX + DeltaY * DeltaY;
2334	DeltaX := Pt.X - CenterX;
2335	DeltaY := Pt.Y - CenterY;
2336	DeltaRadSqr := Sqr(DeltaX) + Sqr(DeltaY);
2337
2338	Result := (DeltaRadSqr - RadSqr) <= CTolerance;
2339	end;
2340
2341	begin
2342	VertexCount := Length(Points);
2343	MaxVerticesCount := VertexCount + CSuperTriangleCount;
2344
2345	// Sort points by x value and find maximum and minimum vertex bounds.
2346	FastMergeSortX(Points, SortedVertexIndices, Bounds);
2347
2348	SetLength(Points, MaxVerticesCount);
2349	MaxTriangleCount := 2 * (MaxVerticesCount - 1);
2350	SetLength(Result, MaxTriangleCount);
2351	MaxEdgeCount := 3 * (MaxVerticesCount - 1);
2352	SetLength(Edges, MaxEdgeCount);
2353	SetLength(Complete, (MaxTriangleCount + 7) shr 3);
2354
2355	// This is to allow calculation of the bounding triangle
2356	with Bounds do
2357	begin
2358	ScaledDeltaMax := 30 * Max(Right - Left, Bottom - Top);
2359	Mid := FloatPoint((Left + Right) * 0.5, (Top + Bottom) * 0.5);
2360	end;
2361
2362	// Set up the super triangle
2363	// This is a triangle which encompasses all the sample points. The super
2364	// triangle coordinates are added to the end of the vertex list. The super
2365	// triangle is the first triangle in the triangle list.
2366	Points[VertexCount].Point := FloatPoint(Mid.X - ScaledDeltaMax, Mid.Y - ScaledDeltaMax);
2367	Points[VertexCount + 1].Point := FloatPoint(Mid.X + ScaledDeltaMax, Mid.Y);
2368	Points[VertexCount + 2].Point := FloatPoint(Mid.X, Mid.Y + ScaledDeltaMax);
2369
2370	Result[0, 0] := VertexCount;
2371	Result[0, 1] := VertexCount + 1;
2372	Result[0, 2] := VertexCount + 2;
2373
2374	Complete[0] := 0;
2375	TriangleCount := 1;
2376
2377	// Include each point one at a time into the existing mesh
2378	for I := 0 to VertexCount - 1 do
2379	begin
2380	EdgeCount := 0;
2381
2382	// Set up the edge buffer.
2383	// If the point [x, y] lies inside the circumcircle then the hree edges of
2384	// that triangle are added to the edge buffer.
2385	J := 0;
2386	repeat
2387	if Complete[J shr 3] and (1 shl (J and $7)) = 0 then
2388	begin
2389	Inside := InCircle(Points[SortedVertexIndices[I]].Point,
2390	Points[Result[J, 0]].Point, Points[Result[J, 1]].Point,
2391	Points[Result[J, 2]].Point);
2392
2393	ByteIndex := J shr 3;
2394	Bit := 1 shl (J and $7);
2395	if (CenterX < Points[SortedVertexIndices[I]].Point.X) and
2396	((Sqr(Points[SortedVertexIndices[I]].Point.X - CenterX)) > RadSqr) then
2397	Complete[ByteIndex] := Complete[ByteIndex] or Bit
2398	else
2399	if Inside then
2400	begin
2401	Edges[EdgeCount + 0, 0] := Result[J, 0];
2402	Edges[EdgeCount + 0, 1] := Result[J, 1];
2403	Edges[EdgeCount + 1, 0] := Result[J, 1];
2404	Edges[EdgeCount + 1, 1] := Result[J, 2];
2405	Edges[EdgeCount + 2, 0] := Result[J, 2];
2406	Edges[EdgeCount + 2, 1] := Result[J, 0];
2407	EdgeCount := EdgeCount + 3;
2408	Assert(EdgeCount <= MaxEdgeCount);
2409
2410	TriangleCount := TriangleCount - 1;
2411	Result[J] := Result[TriangleCount];
2412
2413	Complete[ByteIndex] := (Complete[ByteIndex] and (not Bit))
2414	or (Complete[TriangleCount shr 3] and Bit);
2415	Continue;
2416	end;
2417	end;
2418	J := J + 1;
2419	until J >= TriangleCount;
2420
2421	// Tag multiple edges
2422	// Note: if all triangles are specified anticlockwise then all
2423	// interior edges are opposite pointing in direction.
2424	for J := 0 to EdgeCount - 2 do
2425	begin
2426	if (Edges[J, 0] <> -1) or (Edges[J, 1] <> -1) then
2427	begin
2428	for K := J + 1 to EdgeCount - 1 do
2429	begin
2430	if (Edges[K, 0] <> -1) or (Edges[K, 1] <> -1) then
2431	begin
2432	if (Edges[J, 0] = Edges[K, 1]) and
2433	(Edges[J, 1] = Edges[K, 0]) then
2434	begin
2435	Edges[J, 0] := -1;
2436	Edges[J, 1] := -1;
2437	Edges[K, 1] := -1;
2438	Edges[K, 0] := -1;
2439	end;
2440	end;
2441	end;
2442	end;
2443	end;
2444
2445	// Form new triangles for the current point.
2446	// Skipping over any tagged edges. All edges are arranged in clockwise
2447	// order.
2448	for J := 0 to EdgeCount - 1 do
2449	begin
2450	if (Edges[J, 0] <> -1) or (Edges[J, 1] <> -1) then
2451	begin
2452	Result[TriangleCount, 0] := Edges[J, 0];
2453	Result[TriangleCount, 1] := Edges[J, 1];
2454	Result[TriangleCount, 2] := SortedVertexIndices[I];
2455	ByteIndex := TriangleCount shr 3;
2456	Bit := 1 shl (TriangleCount and $7);
2457	Complete[ByteIndex] := Complete[ByteIndex] and not Bit;
2458	Inc(TriangleCount);
2459	Assert(TriangleCount <= MaxTriangleCount);
2460	end;
2461	end;
2462	end;
2463
2464	// Remove triangles with supertriangle vertices
2465	// These are triangles which have a vertex number greater than VertexCount
2466	I := 0;
2467	repeat
2468	if (Result[I, 0] >= VertexCount) or
2469	(Result[I, 1] >= VertexCount) or
2470	(Result[I, 2] >= VertexCount) then
2471	begin
2472	TriangleCount := TriangleCount - 1;
2473	Result[I, 0] := Result[TriangleCount, 0];
2474	Result[I, 1] := Result[TriangleCount, 1];
2475	Result[I, 2] := Result[TriangleCount, 2];
2476	I := I - 1;
2477	end;
2478	I := I + 1;
2479	until I >= TriangleCount;
2480
2481	SetLength(Points, Length(Points) - 3);
2482	SetLength(Result, TriangleCount);
2483	end;
2484
2485	procedure TGourandShadedDelaunayTrianglesSampler.PrepareSampling;
2486	var
2487	Index: Integer;
2488	begin
2489	inherited;
2490
2491	// perform triangulation
2492	FTriangles := DelaunayTriangulation(FColorPoints);
2493
2494	// setup internal barycentric samplers
2495	SetLength(FBarycentric, Length(FTriangles));
2496	for Index := 0 to Length(FTriangles) - 1 do
2497	begin
2498	FBarycentric[Index] := TBarycentricGradientSampler.Create(
2499	FColorPoints[FTriangles[Index, 0]], FColorPoints[FTriangles[Index, 1]],
2500	FColorPoints[FTriangles[Index, 2]]);
2501	FBarycentric[Index].PrepareSampling;
2502	end;
2503	SetLength(FTriangles, 0);
2504	end;
2505
2506	function TGourandShadedDelaunayTrianglesSampler.GetSampleFloat(X, Y: TFloat): TColor32;
2507	var
2508	Index: Integer;
2509	U, V, W: TFloat;
2510	Dist, MinDist: TFloat;
2511	MinIndex: Integer;
2512	begin
2513	if Length(FBarycentric) = 0 then
2514	begin
2515	Result := clRed32;
2516	Exit;
2517	end;
2518
2519	// check first barycentric interpolator
2520	FBarycentric[0].CalculateBarycentricCoordinates(X, Y, U, V, W);
2521	if (U >= 0) and (V >= 0) and (W >= 0) then
2522	begin
2523	Result := Linear3PointInterpolationProc(FBarycentric[0].Color[0],
2524	FBarycentric[0].Color[1], FBarycentric[0].Color[2], U, V, W);
2525	Exit;
2526	end;
2527
2528	// calculate minimum distance
2529	MinDist := Sqr(U - 0.5) + Sqr(V - 0.5) + Sqr(W - 0.5);
2530	MinIndex := 0;
2531
2532	for Index := 1 to High(FBarycentric) do
2533	begin
2534	// check barycentric interpolator
2535	FBarycentric[Index].CalculateBarycentricCoordinates(X, Y, U, V, W);
2536	if (U >= 0) and (V >= 0) and (W >= 0) then
2537	begin
2538	Result := Linear3PointInterpolationProc(FBarycentric[Index].Color[0],
2539	FBarycentric[Index].Color[1], FBarycentric[Index].Color[2], U, V, W);
2540	Exit;
2541	end;
2542
2543	// calculate distance and eventually update minimum distance
2544	Dist := Sqr(U - 0.5) + Sqr(V - 0.5) + Sqr(W - 0.5);
2545	if Dist < MinDist then
2546	begin
2547	MinDist := Dist;
2548	MinIndex := Index;
2549	end;
2550	end;
2551
2552	FBarycentric[MinIndex].CalculateBarycentricCoordinates(X, Y, U, V, W);
2553	Result := Linear3PointInterpolationProc(FBarycentric[MinIndex].Color[0],
2554	FBarycentric[MinIndex].Color[1], FBarycentric[MinIndex].Color[2], U, V, W);
2555	end;
2556
2557	procedure TGourandShadedDelaunayTrianglesSampler.FinalizeSampling;
2558	var
2559	Index: Integer;
2560	begin
2561	inherited;
2562	for Index := 0 to Length(FBarycentric) - 1 do
2563	begin
2564	FBarycentric[Index].FinalizeSampling;
2565	FBarycentric[Index].Free;
2566	end;
2567	end;
2568
2569
2570	{ TCustomGradientSampler }
2571
2572	constructor TCustomGradientSampler.Create(WrapMode: TWrapMode);
2573	begin
2574	inherited Create;
2575	FGradient := TColor32Gradient.Create(clNone32);
2576	FGradient.OnGradientColorsChanged := GradientChangedHandler;
2577	FWrapMode := WrapMode;
2578	WrapModeChanged;
2579	end;
2580
2581	constructor TCustomGradientSampler.Create(ColorGradient: TColor32Gradient);
2582	begin
2583	Create;
2584
2585	if Assigned(ColorGradient) then
2586	FGradient.Assign(ColorGradient);
2587	end;
2588
2589	destructor TCustomGradientSampler.Destroy;
2590	begin
2591	FreeAndNil(FGradient);
2592	inherited;
2593	end;
2594
2595	procedure TCustomGradientSampler.AssignTo(Dest: TPersistent);
2596	begin
2597	if Dest is TCustomGradientSampler then
2598	with TCustomGradientSampler(Dest) do
2599	begin
2600	FGradient.Assign(Self.FGradient);
2601	FInitialized := False;
2602	FWrapMode := Self.WrapMode;
2603	end
2604	else
2605	inherited;
2606	end;
2607
2608	procedure TCustomGradientSampler.SetGradient(const Value: TColor32Gradient);
2609	begin
2610	if not Assigned(Value) then
2611	FGradient.ClearColorStops
2612	else
2613	Value.AssignTo(Self);
2614	GradientSamplerChanged;
2615	end;
2616
2617	procedure TCustomGradientSampler.SetWrapMode(const Value: TWrapMode);
2618	begin
2619	if FWrapMode <> Value then
2620	begin
2621	FWrapMode := Value;
2622	WrapModeChanged;
2623	end;
2624	end;
2625
2626	procedure TCustomGradientSampler.WrapModeChanged;
2627	begin
2628	end;
2629
2630	function TCustomGradientSampler.GetSampleFixed(X, Y: TFixed): TColor32;
2631	begin
2632	Result := GetSampleFloat(X * FixedToFloat, Y * FixedToFloat);
2633	end;
2634
2635	function TCustomGradientSampler.GetSampleInt(X, Y: Integer): TColor32;
2636	begin
2637	Result := GetSampleFloat(X, Y);
2638	end;
2639
2640	procedure TCustomGradientSampler.GradientChangedHandler(Sender: TObject);
2641	begin
2642	GradientSamplerChanged;
2643	end;
2644
2645	procedure TCustomGradientSampler.GradientSamplerChanged;
2646	begin
2647	FInitialized := False;
2648	end;
2649
2650	procedure TCustomGradientSampler.PrepareSampling;
2651	begin
2652	inherited;
2653
2654	if not FInitialized then
2655	begin
2656	UpdateInternals;
2657	FInitialized := True;
2658	end;
2659	end;
2660
2661
2662	{ TCustomGradientLookUpTableSampler }
2663
2664	procedure TCustomGradientLookUpTableSampler.AssignTo(Dest: TPersistent);
2665	begin
2666	inherited;
2667
2668	if Dest is TCustomGradientLookUpTableSampler then
2669	with TCustomGradientLookUpTableSampler(Dest) do
2670	begin
2671	FGradientLUT.Assign(Self.FGradientLUT);
2672	FWrapProc := Self.FWrapProc;
2673	end
2674	end;
2675
2676	constructor TCustomGradientLookUpTableSampler.Create(WrapMode: TWrapMode = wmMirror);
2677	begin
2678	FGradientLUT := TColor32LookupTable.Create;
2679	inherited Create(WrapMode);
2680	end;
2681
2682	destructor TCustomGradientLookUpTableSampler.Destroy;
2683	begin
2684	FGradientLUT.Free;
2685	inherited;
2686	end;
2687
2688	procedure TCustomGradientLookUpTableSampler.UpdateInternals;
2689	begin
2690	FGradient.FillColorLookUpTable(FGradientLUT);
2691	FLutPtr := FGradientLUT.Color32Ptr;
2692	FLutMask := FGradientLUT.Mask;
2693	FWrapProc := GetWrapProc(WrapMode, FGradientLUT.Mask);
2694	end;
2695
2696	procedure TCustomGradientLookUpTableSampler.WrapModeChanged;
2697	begin
2698	inherited;
2699	FWrapProc := GetWrapProc(WrapMode);
2700	end;
2701
2702
2703	{ TCustomCenterLutGradientSampler }
2704
2705	constructor TCustomCenterLutGradientSampler.Create(WrapMode: TWrapMode = wmMirror);
2706	begin
2707	inherited Create(WrapMode);
2708	FCenter := FloatPoint(0, 0);
2709	end;
2710
2711	procedure TCustomCenterLutGradientSampler.AssignTo(Dest: TPersistent);
2712	begin
2713	inherited;
2714
2715	if Dest is TCustomCenterLutGradientSampler then
2716	TCustomCenterLutGradientSampler(Dest).FCenter := Self.FCenter;
2717	end;
2718
2719	procedure TCustomCenterLutGradientSampler.Transform(var X, Y: TFloat);
2720	begin
2721	X := X - FCenter.X;
2722	Y := Y - FCenter.Y;
2723	inherited;
2724	end;
2725
2726	{ TConicGradientSampler }
2727
2728	procedure TConicGradientSampler.AssignTo(Dest: TPersistent);
2729	begin
2730	inherited;
2731
2732	if Dest is TConicGradientSampler then
2733	TConicGradientSampler(Dest).FAngle := Self.FAngle;
2734	end;
2735
2736	function TConicGradientSampler.GetSampleFloat(X, Y: TFloat): TColor32;
2737	begin
2738	Transform(X, Y);
2739	Result := FLutPtr^[FWrapProc(Round(FScale * Abs(FAngle + ArcTan2(Y, X))),
2740	FLutMask)];
2741	end;
2742
2743	procedure TConicGradientSampler.UpdateInternals;
2744	begin
2745	inherited;
2746	FLutMask := FGradientLUT.Mask;
2747	FScale := FLutMask / Pi;
2748	end;
2749
2750
2751	{ TCustomCenterRadiusLutGradientSampler }
2752
2753	constructor TCustomCenterRadiusLutGradientSampler.Create(WrapMode: TWrapMode = wmMirror);
2754	begin
2755	inherited Create(WrapMode);
2756	FRadius := 1;
2757	RadiusChanged;
2758	end;
2759
2760	procedure TCustomCenterRadiusLutGradientSampler.AssignTo(Dest: TPersistent);
2761	begin
2762	inherited;
2763
2764	if Dest is TCustomCenterRadiusLutGradientSampler then
2765	TCustomCenterRadiusLutGradientSampler(Dest).FRadius := Self.FRadius;
2766	end;
2767
2768	procedure TCustomCenterRadiusLutGradientSampler.RadiusChanged;
2769	begin
2770	FInitialized := False;
2771	end;
2772
2773	procedure TCustomCenterRadiusLutGradientSampler.SetRadius(
2774	const Value: TFloat);
2775	begin
2776	if FRadius <> Value then
2777	begin
2778	FRadius := Value;
2779	RadiusChanged;
2780	end;
2781	end;
2782
2783
2784	{ TRadialGradientSampler }
2785
2786	function TRadialGradientSampler.GetSampleFloat(X, Y: TFloat): TColor32;
2787	begin
2788	Transform(X, Y);
2789	Result := FGradientLUT.Color32Ptr^[
2790	FWrapProc(Round(Sqrt(Sqr(X) + Sqr(Y)) * FScale), FLutMask)];
2791	end;
2792
2793	procedure TRadialGradientSampler.UpdateInternals;
2794	begin
2795	inherited;
2796	FScale := FLutMask / FRadius;
2797	end;
2798
2799
2800	{ TCustomCenterRadiusAngleLutGradientSampler }
2801
2802	constructor TCustomCenterRadiusAngleLutGradientSampler.Create(WrapMode: TWrapMode = wmMirror);
2803	begin
2804	inherited Create(WrapMode);
2805	FAngle := 0;
2806	FSinCos.X := 1;
2807	FSinCos.Y := 0;
2808	end;
2809
2810	procedure TCustomCenterRadiusAngleLutGradientSampler.AssignTo(
2811	Dest: TPersistent);
2812	begin
2813	inherited;
2814
2815	if Dest is TCustomCenterRadiusAngleLutGradientSampler then
2816	with TCustomCenterRadiusAngleLutGradientSampler(Dest) do
2817	begin
2818	FAngle := Self.FAngle;
2819	FSinCos := Self.FSinCos;
2820	end;
2821	end;
2822
2823	procedure TCustomCenterRadiusAngleLutGradientSampler.RadiusChanged;
2824	begin
2825	inherited;
2826	FInitialized := False;
2827	end;
2828
2829	procedure TCustomCenterRadiusAngleLutGradientSampler.AngleChanged;
2830	begin
2831	GR32_Math.SinCos(FAngle, FSinCos.X, FSinCos.Y);
2832	end;
2833
2834	procedure TCustomCenterRadiusAngleLutGradientSampler.SetAngle(
2835	const Value: TFloat);
2836	begin
2837	if FAngle <> Value then
2838	begin
2839	FAngle := Value;
2840	AngleChanged;
2841	end;
2842	end;
2843
2844	procedure TCustomCenterRadiusAngleLutGradientSampler.Transform(var X,
2845	Y: TFloat);
2846	var
2847	Temp: TFloat;
2848	begin
2849	X := X - FCenter.X;
2850	Y := Y - FCenter.Y;
2851
2852	Temp := X * FSinCos.X + Y * FSinCos.Y;
2853	Y := X * FSinCos.Y - Y * FSinCos.X;
2854	X := Temp;
2855	end;
2856
2857
2858	{ TDiamondGradientSampler }
2859
2860	function TDiamondGradientSampler.GetSampleFloat(X, Y: TFloat): TColor32;
2861	begin
2862	Transform(X, Y);
2863	Result := FLutPtr^[FWrapProc(Round(Max(Abs(X), Abs(Y)) * FScale), FLutMask)];
2864	end;
2865
2866	procedure TDiamondGradientSampler.UpdateInternals;
2867	begin
2868	inherited;
2869	FScale := FLutMask / FRadius;
2870	end;
2871
2872
2873	{ TXGradientSampler }
2874
2875	function TXGradientSampler.GetSampleFloat(X, Y: TFloat): TColor32;
2876	begin
2877	Transform(X, Y);
2878	Result := FLutPtr^[FWrapProc(Round(X * FScale), FLutMask)];
2879	end;
2880
2881	function TXGradientSampler.GetStartPoint: TFloatPoint;
2882	begin
2883	Result := FCenter;
2884	end;
2885
2886	function TXGradientSampler.GetEndPoint: TFloatPoint;
2887	var
2888	X, Y: TFloat;
2889	begin
2890	GR32_Math.SinCos(Angle - 0.5 * Pi, X, Y);
2891	Result := FloatPoint(FCenter.X + X, FCenter.Y + Y);
2892	end;
2893
2894	procedure TXGradientSampler.SetEndPoint(const Value: TFloatPoint);
2895	begin
2896	SetPoints(StartPoint, Value);
2897	end;
2898
2899	procedure TXGradientSampler.SetPoints(const StartPoint, EndPoint: TFloatPoint);
2900	begin
2901	FCenter := StartPoint;
2902	Radius := Distance(EndPoint, StartPoint);
2903	Angle := 0.5 * Pi + GetAngleOfPt2FromPt1(EndPoint, StartPoint);
2904	end;
2905
2906	procedure TXGradientSampler.SetStartPoint(const Value: TFloatPoint);
2907	begin
2908	SetPoints(Value, EndPoint);
2909	end;
2910
2911	procedure TXGradientSampler.SimpleGradient(
2912	const StartPoint: TFloatPoint; StartColor: TColor32;
2913	const EndPoint: TFloatPoint; EndColor: TColor32);
2914	begin
2915	SetPoints(StartPoint, EndPoint);
2916	if Assigned(FGradient) then
2917	begin
2918	FGradient.ClearColorStops;
2919	FGradient.StartColor := StartColor;
2920	FGradient.EndColor := EndColor;
2921	end;
2922	end;
2923
2924	procedure TXGradientSampler.UpdateInternals;
2925	begin
2926	inherited;
2927	FScale := FLutMask / FRadius;
2928	end;
2929
2930
2931	{ TXYGradientSampler }
2932
2933	function TXYGradientSampler.GetSampleFloat(X, Y: TFloat): TColor32;
2934	begin
2935	Transform(X, Y);
2936	Result := FLutPtr^[FWrapProc(Round((Abs(X) * Abs(Y)) * FScale), FLutMask)];
2937	end;
2938
2939	procedure TXYGradientSampler.UpdateInternals;
2940	begin
2941	inherited;
2942	FScale := FLutMask / Sqr(FRadius);
2943	end;
2944
2945
2946	{ TXYSqrtGradientSampler }
2947
2948	function TXYSqrtGradientSampler.GetSampleFloat(X, Y: TFloat): TColor32;
2949	begin
2950	Transform(X, Y);
2951	Result := FLutPtr^[FWrapProc(Round(Sqrt(Abs(X) * Abs(Y)) * FScale), FLutMask)];
2952	end;
2953
2954	procedure TXYSqrtGradientSampler.UpdateInternals;
2955	begin
2956	inherited;
2957	FScale := FLutMask / FRadius;
2958	end;
2959
2960
2961	{TCustomGradientPolygonFiller}
2962
2963	constructor TCustomGradientPolygonFiller.Create;
2964	begin
2965	Create(TColor32Gradient.Create(clNone32));
2966	FGradient.OnGradientColorsChanged := GradientColorsChangedHandler;
2967	FOwnsGradient := True;
2968	FWrapMode := wmClamp;
2969	FWrapProc := Clamp;
2970	end;
2971
2972	constructor TCustomGradientPolygonFiller.Create(ColorGradient: TColor32Gradient);
2973	begin
2974	FOwnsGradient := False;
2975	FGradient := ColorGradient;
2976	inherited Create;
2977	FWrapMode := wmClamp;
2978	FWrapProc := Clamp;
2979	end;
2980
2981	destructor TCustomGradientPolygonFiller.Destroy;
2982	begin
2983	if Assigned(FGradient) then
2984	if FOwnsGradient then
2985	FGradient.Free
2986	else
2987	FGradient.OnGradientColorsChanged := nil;
2988	inherited;
2989	end;
2990
2991	procedure TCustomGradientPolygonFiller.FillLineNone(Dst: PColor32; DstX,
2992	DstY, Length: Integer; AlphaValues: PColor32; CombineMode: TCombineMode);
2993	begin
2994	// do nothing!
2995	end;
2996
2997	procedure TCustomGradientPolygonFiller.FillLineSolid(Dst: PColor32; DstX,
2998	DstY, Length: Integer; AlphaValues: PColor32; CombineMode: TCombineMode);
2999	begin
3000	FillLineAlpha(Dst, AlphaValues, Length, FGradient.StartColor, CombineMode);
3001	end;
3002
3003	procedure TCustomGradientPolygonFiller.GradientColorsChangedHandler(
3004	Sender: TObject);
3005	begin
3006	GradientFillerChanged;
3007	end;
3008
3009	procedure TCustomGradientPolygonFiller.GradientFillerChanged;
3010	begin
3011	// do nothing
3012	end;
3013
3014	procedure TCustomGradientPolygonFiller.SetWrapMode(const Value: TWrapMode);
3015	begin
3016	if FWrapMode <> Value then
3017	begin
3018	FWrapMode := Value;
3019	WrapModeChanged;
3020	end;
3021	end;
3022
3023	procedure TCustomGradientPolygonFiller.WrapModeChanged;
3024	begin
3025	FWrapProc := GetWrapProc(FWrapMode);
3026	end;
3027
3028
3029	{ TBarycentricGradientPolygonFiller }
3030
3031	procedure TBarycentricGradientPolygonFiller.BeginRendering;
3032	var
3033	NormScale: TFloat;
3034	begin
3035	inherited;
3036	NormScale := 1 / ((FColorPoints[1].Point.Y - FColorPoints[2].Point.Y) *
3037	(FColorPoints[0].Point.X - FColorPoints[2].Point.X) +
3038	(FColorPoints[2].Point.X - FColorPoints[1].Point.X) *
3039	(FColorPoints[0].Point.Y - FColorPoints[2].Point.Y));
3040
3041	FDists[0].X := NormScale * (FColorPoints[2].Point.X - FColorPoints[1].Point.X);
3042	FDists[0].Y := NormScale * (FColorPoints[1].Point.Y - FColorPoints[2].Point.Y);
3043	FDists[1].X := NormScale * (FColorPoints[0].Point.X - FColorPoints[2].Point.X);
3044	FDists[1].Y := NormScale * (FColorPoints[2].Point.Y - FColorPoints[0].Point.Y);
3045	end;
3046
3047	procedure TBarycentricGradientPolygonFiller.FillLine(Dst: PColor32; DstX, DstY,
3048	Length: Integer; AlphaValues: PColor32; CombineMode: TCombineMode);
3049	var
3050	X: Integer;
3051	Color32: TColor32;
3052	Temp, DotY1, DotY2: TFloat;
3053	Barycentric: array [0..1] of TFloat;
3054	BlendMemEx: TBlendMemEx;
3055	begin
3056	BlendMemEx := BLEND_MEM_EX[CombineMode]^;
3057	Temp := DstY - FColorPoints[2].Point.Y;
3058	DotY1 := FDists[0].X * Temp;
3059	DotY2 := FDists[1].X * Temp;
3060	for X := DstX to DstX + Length - 1 do
3061	begin
3062	Temp := (X - FColorPoints[2].Point.X);
3063	Barycentric[0] := FDists[0].Y * Temp + DotY1;
3064	Barycentric[1] := FDists[1].Y * Temp + DotY2;
3065
3066	Color32 := Linear3PointInterpolationProc(FColorPoints[0].Color32,
3067	FColorPoints[1].Color32, FColorPoints[2].Color32,
3068	Barycentric[0], Barycentric[1], 1 - Barycentric[1] - Barycentric[0]);
3069
3070	BlendMemEx(Color32, Dst^, AlphaValues^);
3071	EMMS;
3072	Inc(Dst);
3073	Inc(AlphaValues);
3074	end;
3075	end;
3076
3077	function TBarycentricGradientPolygonFiller.GetColor(Index: Integer): TColor32;
3078	begin
3079	if Index in [0 .. 2] then
3080	Result := FColorPoints[Index].Color32
3081	else
3082	raise Exception.CreateFmt(RCStrIndexOutOfBounds, [Index]);
3083	end;
3084
3085	function TBarycentricGradientPolygonFiller.GetColorPoint(
3086	Index: Integer): TColor32FloatPoint;
3087	begin
3088	if Index in [0 .. 2] then
3089	Result := FColorPoints[Index]
3090	else
3091	raise Exception.CreateFmt(RCStrIndexOutOfBounds, [Index]);
3092	end;
3093
3094	function TBarycentricGradientPolygonFiller.GetCount: Integer;
3095	begin
3096	Result := 3;
3097	end;
3098
3099	function TBarycentricGradientPolygonFiller.GetFillLine: TFillLineEvent;
3100	begin
3101	Result := FillLine;
3102	end;
3103
3104	function TBarycentricGradientPolygonFiller.GetPoint(
3105	Index: Integer): TFloatPoint;
3106	begin
3107	if Index in [0 .. 2] then
3108	Result := FColorPoints[Index].Point
3109	else
3110	raise Exception.CreateFmt(RCStrIndexOutOfBounds, [Index]);
3111	end;
3112
3113	class function TBarycentricGradientPolygonFiller.Linear3PointInterpolation(
3114	A, B, C: TColor32; WeightA, WeightB, WeightC: Single): TColor32;
3115	begin
3116	Result := Linear3PointInterpolationProc(A, B, C, WeightA, WeightB, WeightC);
3117	end;
3118
3119	procedure TBarycentricGradientPolygonFiller.SetColor(Index: Integer;
3120	const Value: TColor32);
3121	begin
3122	if Index in [0 .. 2] then
3123	FColorPoints[Index].Color32 := Value
3124	else
3125	raise Exception.CreateFmt(RCStrIndexOutOfBounds, [Index]);
3126	end;
3127
3128	procedure TBarycentricGradientPolygonFiller.SetColorPoints(
3129	ColorPoints: TArrayOfColor32FloatPoint);
3130	begin
3131	if Length(ColorPoints) <> 3 then
3132	raise Exception.Create(RCStrOnlyExactly3Point);
3133
3134	FColorPoints[0] := ColorPoints[0];
3135	FColorPoints[1] := ColorPoints[1];
3136	FColorPoints[2] := ColorPoints[2];
3137	end;
3138
3139	procedure TBarycentricGradientPolygonFiller.SetColorPoint(Index: Integer;
3140	const Value: TColor32FloatPoint);
3141	begin
3142	if Index in [0 .. 2] then
3143	FColorPoints[Index] := Value
3144	else
3145	raise Exception.CreateFmt(RCStrIndexOutOfBounds, [Index]);
3146	end;
3147
3148	procedure TBarycentricGradientPolygonFiller.SetColorPoints(
3149	Points: TArrayOfFloatPoint; Colors: TArrayOfColor32);
3150	begin
3151	if (Length(Points) <> 3) or (Length(Colors) <> 3) then
3152	raise Exception.Create(RCStrOnlyExactly3Point);
3153
3154	FColorPoints[0] := Color32FloatPoint(Colors[0], Points[0]);
3155	FColorPoints[1] := Color32FloatPoint(Colors[1], Points[1]);
3156	FColorPoints[2] := Color32FloatPoint(Colors[2], Points[2]);
3157	end;
3158
3159	procedure TBarycentricGradientPolygonFiller.SetPoint(Index: Integer;
3160	const Value: TFloatPoint);
3161	begin
3162	if Index in [0 .. 2] then
3163	FColorPoints[Index].Point := Value
3164	else
3165	raise Exception.CreateFmt(RCStrIndexOutOfBounds, [Index]);
3166	end;
3167
3168	procedure TBarycentricGradientPolygonFiller.SetPoints(
3169	Points: TArrayOfFloatPoint);
3170	var
3171	Index: Integer;
3172	begin
3173	if Length(Points) <> 3 then
3174	raise Exception.Create(RCStrOnlyExactly3Point);
3175
3176	for Index := 0 to 2 do
3177	FColorPoints[Index].Point := Points[Index];
3178	end;
3179
3180
3181	{ TCustomArbitrarySparsePointGradientPolygonFiller }
3182
3183	procedure TCustomArbitrarySparsePointGradientPolygonFiller.Add(
3184	const Point: TFloatPoint;
3185	Color: TColor32);
3186	var
3187	Index: Integer;
3188	begin
3189	Index := Length(FColorPoints);
3190	SetLength(FColorPoints, Index + 1);
3191	FColorPoints[Index].Point := Point;
3192	FColorPoints[Index].Color32 := Color;
3193	end;
3194
3195	procedure TCustomArbitrarySparsePointGradientPolygonFiller.Add(
3196	const ColorPoint: TColor32FloatPoint);
3197	var
3198	Index: Integer;
3199	begin
3200	Index := Length(FColorPoints);
3201	SetLength(FColorPoints, Index + 1);
3202	FColorPoints[Index].Point := ColorPoint.Point;
3203	FColorPoints[Index].Color32 := ColorPoint.Color32;
3204	end;
3205
3206	procedure TCustomArbitrarySparsePointGradientPolygonFiller.Clear;
3207	begin
3208	SetLength(FColorPoints, 0);
3209	end;
3210
3211	function TCustomArbitrarySparsePointGradientPolygonFiller.GetColor(
3212	Index: Integer): TColor32;
3213	begin
3214	if (Index >= 0) and (Index < Length(FColorPoints)) then
3215	Result := FColorPoints[Index].Color32
3216	else
3217	raise Exception.CreateFmt(RCStrIndexOutOfBounds, [Index]);
3218	end;
3219
3220	function TCustomArbitrarySparsePointGradientPolygonFiller.GetColorPoint(
3221	Index: Integer): TColor32FloatPoint;
3222	begin
3223	if (Index >= 0) and (Index < Length(FColorPoints)) then
3224	Result := FColorPoints[Index]
3225	else
3226	raise Exception.CreateFmt(RCStrIndexOutOfBounds, [Index]);
3227	end;
3228
3229	function TCustomArbitrarySparsePointGradientPolygonFiller.GetCount: Integer;
3230	begin
3231	Result := Length(FColorPoints);
3232	end;
3233
3234	function TCustomArbitrarySparsePointGradientPolygonFiller.GetPoint(
3235	Index: Integer): TFloatPoint;
3236	begin
3237	if (Index >= 0) and (Index < Length(FColorPoints)) then
3238	Result := FColorPoints[Index].Point
3239	else
3240	raise Exception.CreateFmt(RCStrIndexOutOfBounds, [Index]);
3241	end;
3242
3243	procedure TCustomArbitrarySparsePointGradientPolygonFiller.SetColor(Index: Integer;
3244	const Value: TColor32);
3245	begin
3246	if (Index >= 0) and (Index < Length(FColorPoints)) then
3247	FColorPoints[Index].Color32 := Value
3248	else
3249	raise Exception.CreateFmt(RCStrIndexOutOfBounds, [Index]);
3250	end;
3251
3252	procedure TCustomArbitrarySparsePointGradientPolygonFiller.SetColorPoint(
3253	Index: Integer; const Value: TColor32FloatPoint);
3254	begin
3255	if (Index >= 0) and (Index < Length(FColorPoints)) then
3256	FColorPoints[Index] := Value
3257	else
3258	raise Exception.CreateFmt(RCStrIndexOutOfBounds, [Index]);
3259	end;
3260
3261	procedure TCustomArbitrarySparsePointGradientPolygonFiller.SetPoint(Index: Integer;
3262	const Value: TFloatPoint);
3263	begin
3264	if (Index >= 0) and (Index < Length(FColorPoints)) then
3265	FColorPoints[Index].Point := Value
3266	else
3267	raise Exception.CreateFmt(RCStrIndexOutOfBounds, [Index]);
3268	end;
3269
3270	procedure TCustomArbitrarySparsePointGradientPolygonFiller.SetColorPoints(
3271	ColorPoints: TArrayOfColor32FloatPoint);
3272	var
3273	Index: Integer;
3274	begin
3275	SetLength(FColorPoints, Length(ColorPoints));
3276	for Index := 0 to High(FColorPoints) do
3277	FColorPoints[Index] := ColorPoints[Index];
3278	end;
3279
3280	procedure TCustomArbitrarySparsePointGradientPolygonFiller.SetColorPoints(
3281	Points: TArrayOfFloatPoint; Colors: TArrayOfColor32);
3282	var
3283	Index: Integer;
3284	begin
3285	if Length(Points) <> Length(Colors) then
3286	raise Exception.Create(RCStrPointCountMismatch);
3287
3288	SetLength(FColorPoints, Length(Points));
3289	for Index := 0 to High(FColorPoints) do
3290	begin
3291	FColorPoints[Index].Point := Points[Index];
3292	FColorPoints[Index].Color32 := Colors[Index];
3293	end;
3294	end;
3295
3296	procedure TCustomArbitrarySparsePointGradientPolygonFiller.SetPoints(
3297	Points: TArrayOfFloatPoint);
3298	var
3299	Index: Integer;
3300	begin
3301	if Length(FColorPoints) <> Length(Points) then
3302	raise Exception.Create(RCStrPointCountMismatch);
3303
3304	for Index := 0 to High(Points) do
3305	FColorPoints[Index].Point := Points[Index];
3306	end;
3307
3308
3309	{ TGourandShadedDelaunayTrianglesPolygonFiller }
3310
3311	procedure TGourandShadedDelaunayTrianglesPolygonFiller.BeginRendering;
3312	var
3313	Index: Integer;
3314	begin
3315	inherited;
3316
3317	// perform triangulation
3318	FTriangles := DelaunayTriangulation(FColorPoints);
3319
3320	// setup internal barycentric samplers
3321	SetLength(FBarycentric, Length(FTriangles));
3322	for Index := 0 to Length(FTriangles) - 1 do
3323	begin
3324	FBarycentric[Index] := TBarycentricGradientSampler.Create(
3325	FColorPoints[FTriangles[Index, 0]], FColorPoints[FTriangles[Index, 1]],
3326	FColorPoints[FTriangles[Index, 2]]);
3327	FBarycentric[Index].PrepareSampling;
3328	end;
3329	SetLength(FTriangles, 0);
3330	end;
3331
3332	procedure TGourandShadedDelaunayTrianglesPolygonFiller.FillLine3(Dst: PColor32;
3333	DstX, DstY, Count: Integer; AlphaValues: PColor32; CombineMode: TCombineMode);
3334	var
3335	X: Integer;
3336	BlendMemEx: TBlendMemEx;
3337	begin
3338	BlendMemEx := BLEND_MEM_EX[CombineMode]^;
3339	for X := DstX to DstX + Count - 1 do
3340	begin
3341	BlendMemEx(FBarycentric[0].GetSampleFloat(X, DstY), Dst^, AlphaValues^);
3342	EMMS;
3343	Inc(Dst);
3344	Inc(AlphaValues);
3345	end;
3346	end;
3347
3348	procedure TGourandShadedDelaunayTrianglesPolygonFiller.FillLine(Dst: PColor32;
3349	DstX, DstY, Count: Integer; AlphaValues: PColor32; CombineMode: TCombineMode);
3350	var
3351	Index: Integer;
3352	U, V, W: TFloat;
3353	Dist, MinDist: TFloat;
3354	MinIndex: Integer;
3355
3356	X: Integer;
3357	Color32: TColor32;
3358	BlendMemEx: TBlendMemEx;
3359
3360	label
3361	DrawColor;
3362	begin
3363	BlendMemEx := BLEND_MEM_EX[CombineMode]^;
3364	for X := DstX to DstX + Count - 1 do
3365	begin
3366	// check first barycentric interpolator
3367	FBarycentric[0].CalculateBarycentricCoordinates(X, DstY, U, V, W);
3368	if (U >= 0) and (V >= 0) and (W >= 0) then
3369	begin
3370	Color32 := Linear3PointInterpolationProc(FBarycentric[0].Color[0],
3371	FBarycentric[0].Color[1], FBarycentric[0].Color[2], U, V, W);
3372	goto DrawColor;
3373	end;
3374
3375	// calculate minimum distance
3376	MinDist := Sqr(U - 0.5) + Sqr(V - 0.5) + Sqr(W - 0.5);
3377	MinIndex := 0;
3378
3379	for Index := 1 to High(FBarycentric) do
3380	begin
3381	// check barycentric interpolator
3382	FBarycentric[Index].CalculateBarycentricCoordinates(X, DstY, U, V, W);
3383	if (U >= 0) and (V >= 0) and (W >= 0) then
3384	begin
3385	Color32 := Linear3PointInterpolationProc(FBarycentric[Index].Color[0],
3386	FBarycentric[Index].Color[1], FBarycentric[Index].Color[2], U, V, W);
3387	goto DrawColor;
3388	end;
3389
3390	// calculate distance and eventually update minimum distance
3391	Dist := Sqr(U - 0.5) + Sqr(V - 0.5) + Sqr(W - 0.5);
3392	if Dist < MinDist then
3393	begin
3394	MinDist := Dist;
3395	MinIndex := Index;
3396	end;
3397	end;
3398
3399	FBarycentric[MinIndex].CalculateBarycentricCoordinates(X, DstY, U, V, W);
3400	Color32 := Linear3PointInterpolationProc(FBarycentric[MinIndex].Color[0],
3401	FBarycentric[MinIndex].Color[1], FBarycentric[MinIndex].Color[2], U, V, W);
3402
3403	DrawColor:
3404	BlendMemEx(Color32, Dst^, AlphaValues^);
3405	EMMS;
3406	Inc(Dst);
3407	Inc(AlphaValues);
3408	end;
3409	end;
3410
3411	function TGourandShadedDelaunayTrianglesPolygonFiller.GetFillLine: TFillLineEvent;
3412	begin
3413	case Count of
3414	0 .. 2:
3415	raise Exception.Create('Too few color points available');
3416	3:
3417	Result := FillLine3;
3418	else
3419	Result := FillLine;
3420	end;
3421	end;
3422
3423
3424	{ TCustomGradientLookupTablePolygonFiller }
3425
3426	constructor TCustomGradientLookupTablePolygonFiller.Create;
3427	begin
3428	inherited Create;
3429
3430	FUseLookUpTable := True;
3431
3432	// eventually create lookup table if not specified otherwise
3433	if not Assigned(FGradientLUT) then
3434	begin
3435	FGradientLUT := TColor32LookupTable.Create;
3436	FGradientLUT.OnOrderChanged := LookUpTableChangedHandler;
3437	FOwnsLUT := True;
3438	end;
3439	end;
3440
3441	constructor TCustomGradientLookupTablePolygonFiller.Create(
3442	LookupTable: TColor32LookupTable);
3443	begin
3444	if not Assigned(LookupTable) then
3445	raise Exception.Create(RCStrNoLookupTablePassed);
3446
3447	FGradientLUT := LookupTable;
3448	FUseLookUpTable := True;
3449	FOwnsLUT := False;
3450	FGradient := nil;
3451	FOwnsGradient := False;
3452	FWrapMode := wmClamp;
3453	FWrapProc := Clamp;
3454	end;
3455
3456	destructor TCustomGradientLookupTablePolygonFiller.Destroy;
3457	begin
3458	if FOwnsLUT and Assigned(FGradientLUT) then
3459	FGradientLUT.Free;
3460	inherited;
3461	end;
3462
3463	function TCustomGradientLookupTablePolygonFiller.GetLUTNeedsUpdate: Boolean;
3464	begin
3465	Result := FLUTNeedsUpdate or (FUseLookUpTable and (not FOwnsLUT));
3466	end;
3467
3468	procedure TCustomGradientLookupTablePolygonFiller.GradientFillerChanged;
3469	begin
3470	FLUTNeedsUpdate := True;
3471	end;
3472
3473	procedure TCustomGradientLookupTablePolygonFiller.SetGradientLUT(
3474	const Value: TColor32LookupTable);
3475	begin
3476	if FGradientLUT <> Value then
3477	begin
3478	// check whether current look up table is owned and eventually free it
3479	if FOwnsLUT then
3480	FGradientLUT.Free;
3481
3482	// set link to passed look up table
3483	FGradientLUT := Value;
3484
3485	// if no look up table is specified don't use a look up table
3486	if not Assigned(FGradientLUT) then
3487	UseLookUpTable := False;
3488	end;
3489	end;
3490
3491	procedure TCustomGradientLookupTablePolygonFiller.SetUseLookUpTable(
3492	const Value: Boolean);
3493	begin
3494	if FUseLookUpTable <> Value then
3495	begin
3496	FUseLookUpTable := Value;
3497	UseLookUpTableChanged;
3498	end;
3499	end;
3500
3501	procedure TCustomGradientLookupTablePolygonFiller.UseLookUpTableChanged;
3502	begin
3503	if FUseLookUpTable then
3504	if not Assigned(FGradientLUT) then
3505	begin
3506	FGradientLUT := TColor32LookupTable.Create;
3507	FGradientLUT.OnOrderChanged := LookUpTableChangedHandler;
3508	FOwnsLUT := True;
3509	end
3510	else
3511	else
3512	if FOwnsLUT then
3513	begin
3514	if Assigned(FGradientLUT) then
3515	FreeAndNil(FGradientLUT);
3516	FOwnsLUT := False;
3517	end
3518	end;
3519
3520	procedure TCustomGradientLookupTablePolygonFiller.LookUpTableChangedHandler(Sender: TObject);
3521	begin
3522	FLUTNeedsUpdate := True;
3523	end;
3524
3525
3526	{ TCustomLinearGradientPolygonFiller }
3527
3528	procedure TCustomLinearGradientPolygonFiller.SetStartPoint(
3529	const Value: TFloatPoint);
3530	begin
3531	if (FStartPoint.X <> Value.X) or (FStartPoint.Y <> Value.Y) then
3532	begin
3533	FStartPoint := Value;
3534	StartPointChanged;
3535	end;
3536	end;
3537
3538	procedure TCustomLinearGradientPolygonFiller.SimpleGradient(
3539	const StartPoint: TFloatPoint; StartColor: TColor32;
3540	const EndPoint: TFloatPoint; EndColor: TColor32);
3541	begin
3542	SetPoints(StartPoint, EndPoint);
3543	if Assigned(FGradient) then
3544	begin
3545	FGradient.ClearColorStops;
3546	FGradient.StartColor := StartColor;
3547	FGradient.EndColor := EndColor;
3548	end;
3549	end;
3550
3551	procedure TCustomLinearGradientPolygonFiller.SimpleGradientX(
3552	const StartX: TFloat; StartColor: TColor32; const EndX: TFloat;
3553	EndColor: TColor32);
3554	begin
3555	SimpleGradient(
3556	FloatPoint(StartX, 0), StartColor,
3557	FloatPoint(EndX, 0), EndColor);
3558	end;
3559
3560	procedure TCustomLinearGradientPolygonFiller.SimpleGradientY(
3561	const StartY: TFloat; StartColor: TColor32; const EndY: TFloat;
3562	EndColor: TColor32);
3563	begin
3564	SimpleGradient(
3565	FloatPoint(0, StartY), StartColor,
3566	FloatPoint(0, EndY), EndColor);
3567	end;
3568
3569	procedure TCustomLinearGradientPolygonFiller.SetEndPoint(
3570	const Value: TFloatPoint);
3571	begin
3572	if (FEndPoint.X <> Value.X) or (FEndPoint.Y <> Value.Y) then
3573	begin
3574	FEndPoint := Value;
3575	EndPointChanged;
3576	end;
3577	end;
3578
3579	procedure TCustomLinearGradientPolygonFiller.SetPoints(const StartPoint,
3580	EndPoint: TFloatPoint);
3581	begin
3582	FStartPoint := StartPoint;
3583	FEndPoint := EndPoint;
3584	GradientFillerChanged;
3585	UpdateIncline;
3586	end;
3587
3588	procedure TCustomLinearGradientPolygonFiller.StartPointChanged;
3589	begin
3590	GradientFillerChanged;
3591	UpdateIncline;
3592	end;
3593
3594	procedure TCustomLinearGradientPolygonFiller.EndPointChanged;
3595	begin
3596	GradientFillerChanged;
3597	UpdateIncline;
3598	end;
3599
3600	procedure TCustomLinearGradientPolygonFiller.UpdateIncline;
3601	begin
3602	if (FEndPoint.X - FStartPoint.X) <> 0 then
3603	FIncline := (FEndPoint.Y - FStartPoint.Y) / (FEndPoint.X - FStartPoint.X)
3604	else
3605	if (FEndPoint.Y - FStartPoint.Y) <> 0 then
3606	FIncline := 1 / (FEndPoint.Y - FStartPoint.Y);
3607	end;
3608
3609
3610	{ TLinearGradientPolygonFiller }
3611
3612	constructor TLinearGradientPolygonFiller.Create(
3613	ColorGradient: TColor32Gradient);
3614	begin
3615	Create(ColorGradient, True);
3616	end;
3617
3618	constructor TLinearGradientPolygonFiller.Create(
3619	ColorGradient: TColor32Gradient; UseLookupTable: Boolean);
3620	begin
3621	// create lookup table (and set 'own' & 'use' flags)
3622	FGradientLUT := TColor32LookupTable.Create;
3623	FGradientLUT.OnOrderChanged := LookUpTableChangedHandler;
3624	FOwnsLUT := True;
3625	FUseLookUpTable := UseLookupTable;
3626
3627	inherited Create(ColorGradient);
3628
3629	FGradient.OnGradientColorsChanged := GradientColorsChangedHandler;
3630	end;
3631
3632	function TLinearGradientPolygonFiller.ColorStopToScanLine(Index,
3633	Y: Integer): TFloat;
3634	var
3635	Offset: array [0 .. 1] of TFloat;
3636	begin
3637	Offset[0] := FGradient.FGradientColors[Index].Offset;
3638	Offset[1] := 1 - Offset[0];
3639	Result := Offset[1] * FStartPoint.X + Offset[0] * FEndPoint.X + FIncline *
3640	(Offset[1] * (FStartPoint.Y - Y) + Offset[0] * (FEndPoint.Y - Y));
3641	end;
3642
3643	procedure TLinearGradientPolygonFiller.UseLookUpTableChanged;
3644	begin
3645	inherited;
3646
3647	// perfect gradients are only implementd for WrapMode = wmClamp
3648	if (not FUseLookUpTable) and (WrapMode in [wmRepeat, wmMirror]) then
3649	WrapMode := wmClamp;
3650	end;
3651
3652	procedure TLinearGradientPolygonFiller.WrapModeChanged;
3653	begin
3654	inherited;
3655
3656	// perfect gradients are only implementd for WrapMode = wmClamp
3657	if (not FUseLookUpTable) and (WrapMode in [wmRepeat, wmMirror]) then
3658	UseLookUpTable := True;
3659	end;
3660
3661	function TLinearGradientPolygonFiller.GetFillLine: TFillLineEvent;
3662	var
3663	GradientCount: Integer;
3664	begin
3665	if Assigned(FGradient) then
3666	GradientCount := FGradient.GradientCount
3667	else
3668	GradientCount := FGradientLUT.Size;
3669
3670	case GradientCount of
3671	0:
3672	Result := FillLineNone;
3673	1:
3674	Result := FillLineSolid;
3675	else
3676	if FUseLookUpTable then
3677	case FWrapMode of
3678	wmClamp:
3679	if FStartPoint.X = FEndPoint.X then
3680	if FStartPoint.Y = FEndPoint.Y then
3681	Result := FillLineVerticalPadExtreme
3682	else
3683	Result := FillLineVerticalPad
3684	else
3685	if FStartPoint.X < FEndPoint.X then
3686	Result := FillLineHorizontalPadPos
3687	else
3688	Result := FillLineHorizontalPadNeg;
3689	wmMirror, wmRepeat:
3690	if FStartPoint.X = FEndPoint.X then
3691	Result := FillLineVerticalWrap
3692	else
3693	if FStartPoint.X < FEndPoint.X then
3694	Result := FillLineHorizontalWrapPos
3695	else
3696	Result := FillLineHorizontalWrapNeg;
3697	end
3698	else
3699	if FStartPoint.X = FEndPoint.X then
3700	if FStartPoint.Y = FEndPoint.Y then
3701	Result := FillLineVerticalExtreme
3702	else
3703	Result := FillLineVertical
3704	else
3705	if FStartPoint.X < FEndPoint.X then
3706	Result := FillLinePositive
3707	else
3708	Result := FillLineNegative;
3709	end;
3710	end;
3711
3712	procedure TLinearGradientPolygonFiller.FillLineVertical(Dst: PColor32; DstX,
3713	DstY, Length: Integer; AlphaValues: PColor32; CombineMode: TCombineMode);
3714	var
3715	X: Integer;
3716	Color32: TColor32;
3717	BlendMemEx: TBlendMemEx;
3718	begin
3719	BlendMemEx := BLEND_MEM_EX[CombineMode]^;
3720	Color32 := FGradient.GetColorAt((DstY - FStartPoint.Y) * FIncline);
3721
3722	for X := DstX to DstX + Length - 1 do
3723	begin
3724	BlendMemEx(Color32, Dst^, AlphaValues^);
3725	Inc(Dst);
3726	Inc(AlphaValues);
3727	end;
3728	EMMS;
3729	end;
3730
3731	procedure TLinearGradientPolygonFiller.FillLineVerticalExtreme(Dst: PColor32;
3732	DstX, DstY, Length: Integer; AlphaValues: PColor32; CombineMode: TCombineMode);
3733	var
3734	X: Integer;
3735	Color32: TColor32;
3736	BlendMemEx: TBlendMemEx;
3737	begin
3738	BlendMemEx := BLEND_MEM_EX[CombineMode]^;
3739	if DstY < FStartPoint.Y then
3740	Color32 := FGradient.StartColor
3741	else
3742	Color32 := FGradient.EndColor;
3743
3744	for X := DstX to DstX + Length - 1 do
3745	begin
3746	BlendMemEx(Color32, Dst^, AlphaValues^);
3747	Inc(Dst);
3748	Inc(AlphaValues);
3749	end;
3750	EMMS;
3751	end;
3752
3753	procedure TLinearGradientPolygonFiller.FillLinePositive(Dst: PColor32; DstX,
3754	DstY, Length: Integer; AlphaValues: PColor32; CombineMode: TCombineMode);
3755	var
3756	X, Index: Integer;
3757	IntScale, IntValue: Integer;
3758	Colors: array [0..1] of TColor32;
3759	Scale: TFloat;
3760	XOffset: array [0..1] of TFloat;
3761	XPos: array [0..2] of Integer;
3762	BlendMemEx: TBlendMemEx;
3763	begin
3764	BlendMemEx := BLEND_MEM_EX[CombineMode]^;
3765
3766	// set first offset/position
3767	XOffset[0] := ColorStopToScanLine(0, DstY);
3768	XPos[0] := Round(XOffset[0]);
3769	XPos[2] := DstX + Length;
3770
3771	// check if only a solid start color should be drawn.
3772	if XPos[0] >= XPos[2] - 1 then
3773	begin
3774	FillLineSolid(Dst, DstX, DstY, Length, AlphaValues, CombineMode);
3775	Exit;
3776	end;
3777
3778	// set start color
3779	Colors[0] := FGradient.FGradientColors[0].Color32;
3780
3781	// eventually draw solid start color
3782	FillLineAlpha(Dst, AlphaValues, XPos[0] - DstX, Colors[0], CombineMode);
3783
3784	Index := 1;
3785	repeat
3786	// set start position to be at least DstX
3787	if XPos[0] < DstX then
3788	XPos[0] := DstX;
3789
3790	// set destination color and offset
3791	Colors[1] := FGradient.FGradientColors[Index].Color32;
3792	XOffset[1] := ColorStopToScanLine(Index, DstY);
3793
3794	// calculate destination pixel position
3795	XPos[1] := Round(XOffset[1]);
3796	if XPos[1] > XPos[2] then
3797	XPos[1] := XPos[2];
3798
3799	// check whether
3800	if XPos[1] > XPos[0] then
3801	begin
3802	Scale := 1 / (XOffset[1] - XOffset[0]);
3803	IntScale := Round($7FFFFFFF * Scale);
3804	IntValue := Round($7FFFFFFF * (XPos[0] - XOffset[0]) * Scale);
3805
3806	for X := XPos[0] to XPos[1] - 1 do
3807	begin
3808	BlendMemEx(CombineReg(Colors[1], Colors[0], IntValue shr 23),
3809	Dst^, AlphaValues^);
3810	IntValue := IntValue + IntScale;
3811
3812	Inc(Dst);
3813	Inc(AlphaValues);
3814	end;
3815	EMMS;
3816	end;
3817
3818	// check whether further drawing is still necessary
3819	if XPos[1] = XPos[2] then
3820	Exit;
3821
3822	Inc(Index);
3823
3824	XPos[0] := XPos[1];
3825	XOffset[0] := XOffset[1];
3826	Colors[0] := Colors[1];
3827	until (Index = FGradient.GradientCount);
3828
3829	if XPos[0] < DstX then
3830	XPos[0] := DstX;
3831
3832	FillLineAlpha(Dst, AlphaValues, XPos[2] - XPos[0], Colors[0], CombineMode);
3833	end;
3834
3835
3836	procedure TLinearGradientPolygonFiller.FillLineNegative(Dst: PColor32; DstX,
3837	DstY, Length: Integer; AlphaValues: PColor32; CombineMode: TCombineMode);
3838	var
3839	X, Index: Integer;
3840	IntScale, IntValue: Integer;
3841	Colors: array [0..1] of TColor32;
3842	Scale: TFloat;
3843	XOffset: array [0..1] of TFloat;
3844	XPos: array [0..2] of Integer;
3845	BlendMemEx: TBlendMemEx;
3846	begin
3847	BlendMemEx := BLEND_MEM_EX[CombineMode]^;
3848	Index := FGradient.GradientCount - 1;
3849
3850	// set first offset/position
3851	XOffset[0] := ColorStopToScanLine(Index, DstY);
3852	XPos[0] := Round(XOffset[0]);
3853	XPos[2] := DstX + Length;
3854
3855	// set start color
3856	Colors[0] := FGradient.FGradientColors[Index].Color32;
3857
3858	// check if only a solid start color should be drawn.
3859	if XPos[0] >= XPos[2] - 1 then
3860	begin
3861	FillLineAlpha(Dst, AlphaValues, Length, Colors[0], CombineMode);
3862	Exit;
3863	end;
3864
3865	// eventually draw solid start color
3866	FillLineAlpha(Dst, AlphaValues, XPos[0] - DstX, Colors[0], CombineMode);
3867
3868	Dec(Index);
3869	repeat
3870	// set start position to be at least DstX
3871	if XPos[0] < DstX then
3872	XPos[0] := DstX;
3873
3874	// set destination color and offset
3875	Colors[1] := FGradient.FGradientColors[Index].Color32;
3876	XOffset[1] := ColorStopToScanLine(Index, DstY);
3877
3878	// calculate destination pixel position
3879	XPos[1] := Round(XOffset[1]);
3880	if XPos[1] > XPos[2] then
3881	XPos[1] := XPos[2];
3882
3883	// check whether next color needs to be drawn
3884	if XPos[1] > XPos[0] then
3885	begin
3886	Scale := 1 / (XOffset[1] - XOffset[0]);
3887	IntScale := Round($7FFFFFFF * Scale);
3888	IntValue := Round($7FFFFFFF * (XPos[0] - XOffset[0]) * Scale);
3889
3890	for X := XPos[0] to XPos[1] - 1 do
3891	begin
3892	BlendMemEx(CombineReg(Colors[1], Colors[0], IntValue shr 23),
3893	Dst^, AlphaValues^);
3894	IntValue := IntValue + IntScale;
3895
3896	Inc(Dst);
3897	Inc(AlphaValues);
3898	end;
3899	EMMS;
3900	end;
3901
3902	// check whether further drawing is still necessary
3903	if XPos[1] = XPos[2] then
3904	Exit;
3905
3906	Dec(Index);
3907
3908	XPos[0] := XPos[1];
3909	XOffset[0] := XOffset[1];
3910	Colors[0] := Colors[1];
3911	until (Index < 0);
3912
3913	if XPos[0] < DstX then
3914	XPos[0] := DstX;
3915
3916	FillLineAlpha(Dst, AlphaValues, XPos[2] - XPos[0], Colors[0], CombineMode);
3917	end;
3918
3919	procedure TLinearGradientPolygonFiller.FillLineVerticalPad(
3920	Dst: PColor32; DstX, DstY, Length: Integer; AlphaValues: PColor32;
3921	CombineMode: TCombineMode);
3922	var
3923	X: Integer;
3924	Color32: TColor32;
3925	BlendMemEx: TBlendMemEx;
3926	begin
3927	BlendMemEx := BLEND_MEM_EX[CombineMode]^;
3928	Color32 := FGradientLUT.Color32Ptr^[FWrapProc(Round(FGradientLUT.Mask *
3929	(DstY - FStartPoint.Y) * FIncline), FGradientLUT.Mask)];
3930
3931	for X := DstX to DstX + Length - 1 do
3932	begin
3933	BlendMemEx(Color32, Dst^, AlphaValues^);
3934	Inc(Dst);
3935	Inc(AlphaValues);
3936	end;
3937	EMMS;
3938	end;
3939
3940	procedure TLinearGradientPolygonFiller.FillLineVerticalPadExtreme(
3941	Dst: PColor32; DstX, DstY, Length: Integer; AlphaValues: PColor32;
3942	CombineMode: TCombineMode);
3943	var
3944	X: Integer;
3945	Color32: TColor32;
3946	BlendMemEx: TBlendMemEx;
3947	begin
3948	BlendMemEx := BLEND_MEM_EX[CombineMode]^;
3949	if DstY < FStartPoint.Y then
3950	Color32 := FGradientLUT.Color32Ptr^[0]
3951	else
3952	Color32 := FGradientLUT.Color32Ptr^[FGradientLUT.Mask];
3953
3954	for X := DstX to DstX + Length - 1 do
3955	begin
3956	BlendMemEx(Color32, Dst^, AlphaValues^);
3957	Inc(Dst);
3958	Inc(AlphaValues);
3959	end;
3960	EMMS;
3961	end;
3962
3963	procedure TLinearGradientPolygonFiller.FillLineVerticalWrap(
3964	Dst: PColor32; DstX, DstY, Length: Integer; AlphaValues: PColor32;
3965	CombineMode: TCombineMode);
3966	var
3967	X: Integer;
3968	Color32: TColor32;
3969	BlendMemEx: TBlendMemEx;
3970	begin
3971	BlendMemEx := BLEND_MEM_EX[CombineMode]^;
3972	X := Round(FGradientLUT.Mask * (DstY - FStartPoint.Y) * FIncline);
3973	Color32 := FGradientLUT.Color32Ptr^[FWrapProc(X, Integer(FGradientLUT.Mask))];
3974
3975	for X := DstX to DstX + Length - 1 do
3976	begin
3977	BlendMemEx(Color32, Dst^, AlphaValues^);
3978	Inc(Dst);
3979	Inc(AlphaValues);
3980	end;
3981	EMMS;
3982	end;
3983
3984	procedure TLinearGradientPolygonFiller.FillLineHorizontalPadPos(
3985	Dst: PColor32; DstX, DstY, Length: Integer; AlphaValues: PColor32;
3986	CombineMode: TCombineMode);
3987	var
3988	X, XPos, Count, Mask: Integer;
3989	ColorLUT: PColor32Array;
3990	Scale: TFloat;
3991	XOffset: array [0..1] of TFloat;
3992	BlendMemEx: TBlendMemEx;
3993	begin
3994	BlendMemEx := BLEND_MEM_EX[CombineMode]^;
3995	XOffset[0] := FStartPoint.X + (FStartPoint.Y - DstY) * FIncline;
3996	XOffset[1] := FEndPoint.X + (FEndPoint.Y - DstY) * FIncline;
3997
3998	XPos := Round(XOffset[0]);
3999	Count := Round(XOffset[1]) - XPos;
4000	ColorLUT := FGradientLUT.Color32Ptr;
4001
4002	// check if only a solid start color should be drawn.
4003	if XPos >= DstX + Length then
4004	begin
4005	FillLineAlpha(Dst, AlphaValues, Length, ColorLUT^[0], CombineMode);
4006	Exit;
4007	end;
4008
4009	Mask := FGradientLUT.Mask;
4010
4011	// check if only a solid end color should be drawn.
4012	if XPos + Count < DstX then
4013	begin
4014	FillLineAlpha(Dst, AlphaValues, Length, ColorLUT^[Mask], CombineMode);
4015	Exit;
4016	end;
4017
4018	Scale := Mask / (XOffset[1] - XOffset[0]);
4019	for X := DstX to DstX + Length - 1 do
4020	begin
4021	BlendMemEx(ColorLUT^[FWrapProc(Round((X - XOffset[0]) * Scale), Mask)],
4022	Dst^, AlphaValues^);
4023	EMMS;
4024
4025	Inc(Dst);
4026	Inc(AlphaValues);
4027	end;
4028	end;
4029
4030	procedure TLinearGradientPolygonFiller.FillLineHorizontalPadNeg(
4031	Dst: PColor32; DstX, DstY, Length: Integer; AlphaValues: PColor32;
4032	CombineMode: TCombineMode);
4033	var
4034	X, XPos, Count, Mask: Integer;
4035	ColorLUT: PColor32Array;
4036	Scale: TFloat;
4037	XOffset: array [0..1] of TFloat;
4038	BlendMemEx: TBlendMemEx;
4039	begin
4040	BlendMemEx := BLEND_MEM_EX[CombineMode]^;
4041	XOffset[0] := FEndPoint.X + (FEndPoint.Y - DstY) * FIncline;
4042	XOffset[1] := FStartPoint.X + (FStartPoint.Y - DstY) * FIncline;
4043
4044	XPos := Round(XOffset[0]);
4045	Count := Round(XOffset[1]) - XPos;
4046
4047	Mask := FGradientLUT.Mask;
4048	ColorLUT := FGradientLUT.Color32Ptr;
4049
4050	// check if only a solid start color should be drawn.
4051	if XPos >= DstX + Length then
4052	begin
4053	FillLineAlpha(Dst, AlphaValues, Length, ColorLUT^[Mask], CombineMode);
4054	Exit;
4055	end;
4056
4057	// check if only a solid end color should be drawn.
4058	if XPos + Count < DstX then
4059	begin
4060	FillLineAlpha(Dst, AlphaValues, Length, ColorLUT^[0], CombineMode);
4061	Exit;
4062	end;
4063
4064	Scale := Mask / (XOffset[1] - XOffset[0]);
4065	for X := DstX to DstX + Length - 1 do
4066	begin
4067	BlendMemEx(ColorLUT^[FWrapProc(Round((XOffset[1] - X) * Scale), Mask)],
4068	Dst^, AlphaValues^);
4069	EMMS;
4070
4071	Inc(Dst);
4072	Inc(AlphaValues);
4073	end;
4074	end;
4075
4076	procedure TLinearGradientPolygonFiller.FillLineHorizontalWrapPos(
4077	Dst: PColor32; DstX, DstY, Length: Integer; AlphaValues: PColor32;
4078	CombineMode: TCombineMode);
4079	var
4080	X, Index, Mask: Integer;
4081	ColorLUT: PColor32Array;
4082	Scale: TFloat;
4083	XOffset: array [0..1] of TFloat;
4084	BlendMemEx: TBlendMemEx;
4085	begin
4086	BlendMemEx := BLEND_MEM_EX[CombineMode]^;
4087	XOffset[0] := FStartPoint.X + (FStartPoint.Y - DstY) * FIncline;
4088	XOffset[1] := FEndPoint.X + (FEndPoint.Y - DstY) * FIncline;
4089	Mask := Integer(FGradientLUT.Mask);
4090	ColorLUT := FGradientLUT.Color32Ptr;
4091
4092	Scale := Mask / (XOffset[1] - XOffset[0]);
4093	for X := DstX to DstX + Length - 1 do
4094	begin
4095	Index := Round((X - XOffset[0]) * Scale);
4096	BlendMemEx(ColorLUT^[FWrapProc(Index, Mask)], Dst^, AlphaValues^);
4097	EMMS;
4098
4099	Inc(Dst);
4100	Inc(AlphaValues);
4101	end;
4102	end;
4103
4104	procedure TLinearGradientPolygonFiller.FillLineHorizontalWrapNeg(
4105	Dst: PColor32; DstX, DstY, Length: Integer; AlphaValues: PColor32;
4106	CombineMode: TCombineMode);
4107	var
4108	X, Index, Mask: Integer;
4109	ColorLUT: PColor32Array;
4110	Scale: TFloat;
4111	XOffset: array [0..1] of TFloat;
4112	BlendMemEx: TBlendMemEx;
4113	begin
4114	BlendMemEx := BLEND_MEM_EX[CombineMode]^;
4115	XOffset[0] := FEndPoint.X + (FEndPoint.Y - DstY) * FIncline;
4116	XOffset[1] := FStartPoint.X + (FStartPoint.Y - DstY) * FIncline;
4117	Mask := Integer(FGradientLUT.Mask);
4118	ColorLUT := FGradientLUT.Color32Ptr;
4119
4120	Scale := Mask / (XOffset[1] - XOffset[0]);
4121	for X := DstX to DstX + Length - 1 do
4122	begin
4123	Index := Round((XOffset[1] - X) * Scale);
4124	BlendMemEx(ColorLUT^[FWrapProc(Index, Mask)], Dst^, AlphaValues^);
4125	EMMS;
4126
4127	Inc(Dst);
4128	Inc(AlphaValues);
4129	end;
4130	end;
4131
4132	procedure TLinearGradientPolygonFiller.BeginRendering;
4133	begin
4134	if LookUpTableNeedsUpdate then
4135	begin
4136	if FUseLookUpTable then
4137	begin
4138	if not Assigned(FGradientLUT) then
4139	raise Exception.Create(RCStrNoTColor32LookupTable);
4140
4141	if Assigned(FGradient) then
4142	FGradient.FillColorLookUpTable(FGradientLUT);
4143	end
4144	else
4145	if not Assigned(FGradient) then
4146	raise Exception.Create(RCStrNoTColor32Gradient);
4147	inherited;
4148	end;
4149	end;
4150
4151
4152	{ TCustomRadialGradientPolygonFiller }
4153
4154	procedure TCustomRadialGradientPolygonFiller.SetEllipseBounds(
4155	const Value: TFloatRect);
4156	begin
4157	if (FEllipseBounds.Left <> Value.Left) or (FEllipseBounds.Top <> Value.Top) or
4158	(FEllipseBounds.Right <> Value.Right) or
4159	(FEllipseBounds.Bottom <> Value.Bottom) then
4160	begin
4161	FEllipseBounds := Value;
4162	EllipseBoundsChanged;
4163	end;
4164	end;
4165
4166
4167	{ TRadialGradientPolygonFiller }
4168
4169	constructor TRadialGradientPolygonFiller.Create(Radius: TFloatPoint);
4170	begin
4171	inherited Create;
4172	FRadius := Radius;
4173	UpdateEllipseBounds;
4174	UpdateRadiusScale;
4175	end;
4176
4177	constructor TRadialGradientPolygonFiller.Create(Radius, Center: TFloatPoint);
4178	begin
4179	inherited Create;
4180	FRadius := Radius;
4181	FCenter := Center;
4182	UpdateEllipseBounds;
4183	UpdateRadiusScale;
4184	end;
4185
4186	constructor TRadialGradientPolygonFiller.Create(BoundingBox: TFloatRect);
4187	begin
4188	Create(FloatPoint(0.5 * (BoundingBox.Right - BoundingBox.Left),
4189	0.5 * (BoundingBox.Bottom - BoundingBox.Top)),
4190	FloatPoint(0.5 * (BoundingBox.Right + BoundingBox.Left),
4191	0.5 * (BoundingBox.Bottom + BoundingBox.Top)));
4192	end;
4193
4194	procedure TRadialGradientPolygonFiller.EllipseBoundsChanged;
4195	begin
4196	with FEllipseBounds do
4197	begin
4198	FCenter := FloatPoint((Left + Right) * 0.5, (Top + Bottom) * 0.5);
4199	FRadius.X := Round((Right - Left) * 0.5);
4200	FRadius.Y := Round((Bottom - Top) * 0.5);
4201	end;
4202
4203	UpdateRadiusScale;
4204	end;
4205
4206	procedure TRadialGradientPolygonFiller.SetCenter(const Value: TFloatPoint);
4207	begin
4208	if (FCenter.X <> Value.X) or (FCenter.Y <> Value.Y) then
4209	begin
4210	FCenter := Value;
4211	UpdateEllipseBounds;
4212	end;
4213	end;
4214
4215	procedure TRadialGradientPolygonFiller.SetRadius(const Value: TFloatPoint);
4216	begin
4217	if (FRadius.X <> Value.X) or (FRadius.Y <> Value.Y) then
4218	begin
4219	FRadius := Value;
4220	UpdateRadiusScale;
4221	UpdateEllipseBounds;
4222	end;
4223	end;
4224
4225	procedure TRadialGradientPolygonFiller.UpdateEllipseBounds;
4226	begin
4227	with FEllipseBounds do
4228	begin
4229	Left := FCenter.X - FRadius.X;
4230	Top := FCenter.X + FRadius.X;
4231	Right := FCenter.Y - FRadius.Y;
4232	Bottom := FCenter.Y + FRadius.Y;
4233	end;
4234	end;
4235
4236	procedure TRadialGradientPolygonFiller.UpdateRadiusScale;
4237	begin
4238	FRadScale := FRadius.X / FRadius.Y;
4239	FRadXInv := 1 / FRadius.X;
4240	end;
4241
4242	procedure TRadialGradientPolygonFiller.BeginRendering;
4243	begin
4244	if LookUpTableNeedsUpdate then
4245	begin
4246	if FUseLookUpTable then
4247	begin
4248	if not Assigned(FGradientLUT) then
4249	raise Exception.Create(RCStrNoTColor32LookupTable);
4250
4251	if Assigned(FGradient) then
4252	FGradient.FillColorLookUpTable(FGradientLUT);
4253	end
4254	else
4255	if not Assigned(FGradient) then
4256	raise Exception.Create(RCStrNoTColor32Gradient);
4257	inherited;
4258	end;
4259	end;
4260
4261	function TRadialGradientPolygonFiller.GetFillLine: TFillLineEvent;
4262	begin
4263	case FWrapMode of
4264	wmClamp:
4265	Result := FillLinePad;
4266	wmMirror:
4267	Result := FillLineReflect;
4268	wmRepeat:
4269	Result := FillLineRepeat;
4270	end;
4271	end;
4272
4273	procedure TRadialGradientPolygonFiller.FillLinePad(Dst: PColor32; DstX,
4274	DstY, Length: Integer; AlphaValues: PColor32; CombineMode: TCombineMode);
4275	var
4276	X, Index, Count, Mask: Integer;
4277	SqrRelRad, RadMax: TFloat;
4278	ColorLUT: PColor32Array;
4279	YDist, SqrInvRadius: TFloat;
4280	Color32: TColor32;
4281	BlendMemEx: TBlendMemEx;
4282	begin
4283	BlendMemEx := BLEND_MEM_EX[CombineMode]^;
4284	Mask := Integer(FGradientLUT.Mask);
4285	ColorLUT := FGradientLUT.Color32Ptr;
4286
4287	// small optimization
4288	Index := Ceil(FCenter.X - FRadius.X);
4289	if Index > DstX then
4290	begin
4291	Count := Min((Index - DstX), Length);
4292	FillLineAlpha(Dst, AlphaValues, Count, ColorLUT^[Mask], CombineMode);
4293	Length := Length - Count;
4294	if Length = 0 then
4295	Exit;
4296	DstX := Index;
4297	end;
4298
4299	// further optimization
4300	if Abs(DstY - FCenter.Y) > FRadius.Y then
4301	begin
4302	FillLineAlpha(Dst, AlphaValues, Length, ColorLUT^[Mask], CombineMode);
4303	Exit;
4304	end;
4305
4306	SqrInvRadius := Sqr(FRadXInv);
4307	YDist := Sqr((DstY - FCenter.Y) * FRadScale);
4308	RadMax := (Sqr(FRadius.X) + YDist) * SqrInvRadius;
4309
4310	for X := DstX to DstX + Length - 1 do
4311	begin
4312	SqrRelRad := (Sqr(X - FCenter.X) + YDist) * SqrInvRadius;
4313	if SqrRelRad > RadMax then
4314	Index := Mask
4315	else
4316	Index := Min(Round(Mask * FastSqrt(SqrRelRad)), Mask);
4317
4318	Color32 := ColorLUT^[Index];
4319	BlendMemEx(Color32, Dst^, AlphaValues^);
4320	EMMS;
4321	Inc(Dst);
4322	Inc(AlphaValues);
4323	end;
4324	end;
4325
4326	procedure TRadialGradientPolygonFiller.FillLineReflect(Dst: PColor32;
4327	DstX, DstY, Length: Integer; AlphaValues: PColor32;
4328	CombineMode: TCombineMode);
4329	var
4330	X, Index, Mask, DivResult: Integer;
4331	SqrInvRadius: TFloat;
4332	YDist: TFloat;
4333	ColorLUT: PColor32Array;
4334	Color32: TColor32;
4335	BlendMemEx: TBlendMemEx;
4336	begin
4337	BlendMemEx := BLEND_MEM_EX[CombineMode]^;
4338	SqrInvRadius := Sqr(FRadXInv);
4339	YDist := Sqr((DstY - FCenter.Y) * FRadScale);
4340	Mask := Integer(FGradientLUT.Mask);
4341	ColorLUT := FGradientLUT.Color32Ptr;
4342
4343	for X := DstX to DstX + Length - 1 do
4344	begin
4345	Index := Round(Mask * FastSqrt((Sqr(X - FCenter.X) + YDist)
4346	* SqrInvRadius));
4347	DivResult := DivMod(Index, FGradientLUT.Size, Index);
4348	if Odd(DivResult) then
4349	Index := Mask - Index;
4350	Color32 := ColorLUT^[Index];
4351	BlendMemEx(Color32, Dst^, AlphaValues^);
4352	EMMS;
4353	Inc(Dst);
4354	Inc(AlphaValues);
4355	end;
4356	end;
4357
4358	procedure TRadialGradientPolygonFiller.FillLineRepeat(Dst: PColor32;
4359	DstX, DstY, Length: Integer; AlphaValues: PColor32; CombineMode: TCombineMode);
4360	var
4361	X, Mask: Integer;
4362	YDist, SqrInvRadius: TFloat;
4363	ColorLUT: PColor32Array;
4364	Color32: TColor32;
4365	BlendMemEx: TBlendMemEx;
4366	begin
4367	BlendMemEx := BLEND_MEM_EX[CombineMode]^;
4368	SqrInvRadius := Sqr(FRadXInv);
4369	YDist := Sqr((DstY - FCenter.Y) * FRadScale);
4370	Mask := Integer(FGradientLUT.Mask);
4371	ColorLUT := FGradientLUT.Color32Ptr;
4372	for X := DstX to DstX + Length - 1 do
4373	begin
4374	Color32 := ColorLUT^[Round(Mask * FastSqrt((Sqr(X - FCenter.X) + YDist) *
4375	SqrInvRadius)) mod FGradientLUT.Size];
4376	BlendMemEx(Color32, Dst^, AlphaValues^);
4377	EMMS;
4378	Inc(Dst);
4379	Inc(AlphaValues);
4380	end;
4381	end;
4382
4383	{ TSVGRadialGradientPolygonFiller }
4384
4385	constructor TSVGRadialGradientPolygonFiller.Create(EllipseBounds: TFloatRect);
4386	begin
4387	inherited Create;
4388	SetParameters(EllipseBounds);
4389	end;
4390
4391	constructor TSVGRadialGradientPolygonFiller.Create(EllipseBounds: TFloatRect;
4392	FocalPoint: TFloatPoint);
4393	begin
4394	inherited Create;
4395	SetParameters(EllipseBounds, FocalPoint);
4396	end;
4397
4398	procedure TSVGRadialGradientPolygonFiller.EllipseBoundsChanged;
4399	begin
4400	GradientFillerChanged;
4401	end;
4402
4403	procedure TSVGRadialGradientPolygonFiller.SetFocalPoint(const Value: TFloatPoint);
4404	begin
4405	if (FFocalPointNative.X <> Value.X) and (FFocalPointNative.Y <> Value.Y) then
4406	begin
4407	FFocalPointNative := Value;
4408	GradientFillerChanged;
4409	end;
4410	end;
4411
4412	procedure TSVGRadialGradientPolygonFiller.SetParameters(
4413	EllipseBounds: TFloatRect);
4414	begin
4415	FEllipseBounds := EllipseBounds;
4416	FFocalPointNative := FloatPoint(
4417	0.5 * (FEllipseBounds.Left + FEllipseBounds.Right),
4418	0.5 * (FEllipseBounds.Top + FEllipseBounds.Bottom));
4419	GradientFillerChanged;
4420	end;
4421
4422	procedure TSVGRadialGradientPolygonFiller.SetParameters(
4423	EllipseBounds: TFloatRect; FocalPoint: TFloatPoint);
4424	begin
4425	FEllipseBounds := EllipseBounds;
4426	FFocalPointNative := FocalPoint;
4427	GradientFillerChanged;
4428	end;
4429
4430	procedure TSVGRadialGradientPolygonFiller.InitMembers;
4431	var
4432	X, Y: TFloat;
4433	Temp: TFloat;
4434	begin
4435	FRadius.X := (FEllipseBounds.Right - FEllipseBounds.Left) * 0.5;
4436	FRadius.Y := (FEllipseBounds.Bottom - FEllipseBounds.Top) * 0.5;
4437	FCenter.X := (FEllipseBounds.Right + FEllipseBounds.Left) * 0.5;
4438	FCenter.Y := (FEllipseBounds.Bottom + FEllipseBounds.Top) * 0.5;
4439	FOffset.X := FEllipseBounds.Left;
4440	FOffset.Y := FEllipseBounds.Top;
4441
4442	// make FFocalPoint relative to the ellipse midpoint ...
4443	FFocalPt.X := FFocalPointNative.X - FCenter.X;
4444	FFocalPt.Y := FFocalPointNative.Y - FCenter.Y;
4445
4446	// make sure the focal point stays within the bounding ellipse ...
4447	if Abs(FFocalPt.X) < CFloatTolerance then
4448	begin
4449	X := 0;
4450	if FFocalPt.Y < 0 then
4451	Y := -1
4452	else
4453	Y := 1;
4454	end
4455	else
4456	begin
4457	Temp := FRadius.X * FFocalPt.Y / (FRadius.Y * FFocalPt.X);
4458	X := 1 / FastSqrtBab1(1 + Sqr(Temp));
4459	Y := Temp * X;
4460	end;
4461	if FFocalPt.X < 0 then
4462	begin
4463	X := -X;
4464	Y := -Y;
4465	end;
4466	X := X * FRadius.X;
4467	Y := Y * FRadius.Y;
4468	if (Y * Y + X * X) < (Sqr(FFocalPt.X) + Sqr(FFocalPt.Y)) then
4469	begin
4470	FFocalPt.X := 0.999 * X;
4471	FFocalPt.Y := 0.999 * Y;
4472	end;
4473
4474	// Because the slope of vertical lines is infinite, we need to find where a
4475	// vertical line through the FocalPoint intersects with the Ellipse, and
4476	// store the distances from the focal point to these 2 intersections points
4477	FVertDist := FRadius.Y * FastSqrtBab1(1 - Sqr(FFocalPt.X) / Sqr(FRadius.X));
4478	end;
4479
4480	procedure TSVGRadialGradientPolygonFiller.BeginRendering;
4481	begin
4482	if LookUpTableNeedsUpdate then
4483	begin
4484	if FUseLookUpTable then
4485	begin
4486	if not Assigned(FGradientLUT) then
4487	raise Exception.Create(RCStrNoTColor32LookupTable);
4488
4489	if Assigned(FGradient) then
4490	FGradient.FillColorLookUpTable(FGradientLUT);
4491	end
4492	else
4493	if not Assigned(FGradient) then
4494	raise Exception.Create(RCStrNoTColor32Gradient);
4495	inherited;
4496	end;
4497	InitMembers;
4498	end;
4499
4500	function TSVGRadialGradientPolygonFiller.GetFillLine: TFillLineEvent;
4501	begin
4502	Result := FillLineEllipse;
4503	end;
4504
4505	procedure TSVGRadialGradientPolygonFiller.FillLineEllipse(Dst: PColor32;
4506	DstX, DstY, Length: Integer; AlphaValues: PColor32;
4507	CombineMode: TCombineMode);
4508	var
4509	X, Mask: Integer;
4510	ColorLUT: PColor32Array;
4511	Rad, Rad2, X2, Y2: TFloat;
4512	m, b, Qa, Qb, Qc, Qz, XSqr: Double;
4513	RelPos: TFloatPoint;
4514	Color32: TColor32;
4515	BlendMemEx: TBlendMemEx;
4516	begin
4517	BlendMemEx := BLEND_MEM_EX[CombineMode]^;
4518	if (FRadius.X = 0) or (FRadius.Y = 0) then
4519	Exit;
4520
4521	ColorLUT := FGradientLUT.Color32Ptr;
4522
4523	RelPos.Y := DstY - FCenter.Y - FFocalPt.Y;
4524	Mask := Integer(FGradientLUT.Mask);
4525
4526	// check if out of bounds (vertically)
4527	if (DstY < FOffset.Y) or (DstY >= (FRadius.Y * 2) + 1 + FOffset.Y) then
4528	begin
4529	FillLineAlpha(Dst, AlphaValues, Length, ColorLUT^[Mask], CombineMode);
4530	Exit;
4531	end;
4532
4533	for X := DstX to DstX + Length - 1 do
4534	begin
4535	// check if out of bounds (horizontally)
4536	if (X < FOffset.X) or (X >= (FRadius.X * 2) + 1 + FOffset.X) then
4537	Color32 := ColorLUT^[Mask]
4538	else
4539	begin
4540	RelPos.X := X - FCenter.X - FFocalPt.X;
4541
4542	if Abs(RelPos.X) < CFloatTolerance then //ie on the vertical line (see above)
4543	begin
4544	Assert(Abs(X - FCenter.X) <= FRadius.X);
4545
4546	Rad := Abs(RelPos.Y);
4547	if Abs(Abs(X - FCenter.X)) <= FRadius.X then
4548	begin
4549	if RelPos.Y < 0 then
4550	Rad2 := Abs(-FVertDist - FFocalPt.Y)
4551	else
4552	Rad2 := Abs( FVertDist - FFocalPt.Y);
4553	if Rad >= Rad2 then
4554	Color32 := ColorLUT^[Mask]
4555	else
4556	Color32 := ColorLUT^[Round(Mask * Rad / Rad2)];
4557	end else
4558	Color32 := ColorLUT^[Mask];
4559	end
4560	else
4561	begin
4562	m := RelPos.Y / RelPos.X;
4563	b := FFocalPt.Y - m * FFocalPt.X;
4564	XSqr := Sqr(FRadius.X);
4565
4566	// apply quadratic equation ...
4567	Qa := 2 * (Sqr(FRadius.Y) + XSqr * m * m);
4568	Qb := XSqr * 2 * m * b;
4569	Qc := XSqr * (b * b - Sqr(FRadius.Y));
4570	Qz := Qb * Qb - 2 * Qa * Qc;
4571
4572	if Qz >= 0 then
4573	begin
4574	Qz := FastSqrtBab2(Qz);
4575	Qa := 1 / Qa;
4576	X2 := (-Qb + Qz) * Qa;
4577	if (FFocalPt.X > X2) = (RelPos.X > 0) then
4578	X2 := -(Qb + Qz) * Qa;
4579	Y2 := m * X2 + b;
4580	Rad := Sqr(RelPos.X) + Sqr(RelPos.Y);
4581	Rad2 := Sqr(X2 - FFocalPt.X) + Sqr(Y2 - FFocalPt.Y);
4582
4583	if Rad >= Rad2 then
4584	Color32 := ColorLUT^[Mask]
4585	else
4586	Color32 := ColorLUT^[Round(Mask * FastSqrtBab1(Rad / Rad2))];
4587	end else
4588	Color32 := ColorLUT^[Mask]
4589	end;
4590	end;
4591
4592	BlendMemEx(Color32, Dst^, AlphaValues^);
4593	EMMS;
4594	Inc(Dst);
4595	Inc(AlphaValues);
4596	end;
4597	end;
4598
4599	procedure RegisterBindings;
4600	begin
4601	GradientRegistry := NewRegistry('GR32_ColorGradients bindings');
4602	GradientRegistry.RegisterBinding(FID_LINEAR3, @@Linear3PointInterpolationProc);
4603	GradientRegistry.RegisterBinding(FID_LINEAR4, @@Linear4PointInterpolationProc);
4604
4605	// pure pascal
4606	GradientRegistry.Add(FID_LINEAR3, @Linear3PointInterpolation_Pas);
4607	GradientRegistry.Add(FID_LINEAR4, @Linear4PointInterpolation_Pas);
4608
4609	{$IFNDEF PUREPASCAL}
4610	{$IFNDEF OMIT_SSE2}
4611	GradientRegistry.Add(FID_LINEAR3, @Linear3PointInterpolation_SSE2, [ciSSE2]);
4612	GradientRegistry.Add(FID_LINEAR4, @Linear4PointInterpolation_SSE2, [ciSSE2]);
4613	{$ENDIF}
4614	{$ENDIF}
4615
4616	GradientRegistry.RebindAll;
4617	end;
4618
4619	initialization
4620	RegisterBindings;
4621
4622	end.

Note: See TracBrowser for help on using the repository browser.

Context Navigation

source: trunk/Packages/Graphics32/GR32_ColorGradients.pas

Download in other formats: