Context Navigation

GR32.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: 181.5 KB

Line
1	unit GR32;
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 Graphics32
24	*
25	* The Initial Developer of the Original Code is
26	* Alex A. Denisov
27	*
28	* Portions created by the Initial Developer are Copyright (C) 2000-2009
29	* the Initial Developer. All Rights Reserved.
30	*
31	* Contributor(s):
32	* Michael Hansen <dyster_tid@hotmail.com>
33	* Andre Beckedorf <Andre@metaException.de>
34	* Mattias Andersson <mattias@centaurix.com>
35	* J. Tulach <tulach at position.cz>
36	* Jouni Airaksinen <markvera at spacesynth.net>
37	* Timothy Weber <teejaydub at users.sourceforge.net>
38	*
39	* *** END LICENSE BLOCK *** *)
40
41	interface
42
43	{$I GR32.inc}
44
45	uses
46	{$IFDEF FPC} LCLIntf, LCLType, Types, {$ELSE}
47	{$IFDEF COMPILERXE2_UP}UITypes, Types, {$ENDIF} Windows, {$ENDIF}
48	Controls, Graphics, Classes, SysUtils;
49
50	{ Version Control }
51
52	const
53	Graphics32Version = '2.0.0 alpha';
54
55	{ 32-bit Color }
56
57	type
58	PColor32 = ^TColor32;
59	TColor32 = type Cardinal;
60
61	PColor32Array = ^TColor32Array;
62	TColor32Array = array [0..0] of TColor32;
63	TArrayOfColor32 = array of TColor32;
64
65	{$IFNDEF RGBA_FORMAT}
66	TColor32Component = (ccBlue, ccGreen, ccRed, ccAlpha);
67	{$ELSE}
68	TColor32Component = (ccRed, ccGreen, ccBlue, ccAlpha);
69	{$ENDIF}
70	TColor32Components = set of TColor32Component;
71
72	PColor32Entry = ^TColor32Entry;
73	TColor32Entry = packed record
74	case Integer of
75	{$IFNDEF RGBA_FORMAT}
76	0: (B, G, R, A: Byte);
77	{$ELSE}
78	0: (R, G, B, A: Byte);
79	{$ENDIF}
80	1: (ARGB: TColor32);
81	2: (Planes: array[0..3] of Byte);
82	3: (Components: array[TColor32Component] of Byte);
83	end;
84
85	PColor32EntryArray = ^TColor32EntryArray;
86	TColor32EntryArray = array [0..0] of TColor32Entry;
87	TArrayOfColor32Entry = array of TColor32Entry;
88
89	PPalette32 = ^TPalette32;
90	TPalette32 = array [Byte] of TColor32;
91
92	const
93	// Some predefined color constants
94	clBlack32 = TColor32($FF000000);
95	clDimGray32 = TColor32($FF3F3F3F);
96	clGray32 = TColor32($FF7F7F7F);
97	clLightGray32 = TColor32($FFBFBFBF);
98	clWhite32 = TColor32($FFFFFFFF);
99	clMaroon32 = TColor32($FF7F0000);
100	clGreen32 = TColor32($FF007F00);
101	clOlive32 = TColor32($FF7F7F00);
102	clNavy32 = TColor32($FF00007F);
103	clPurple32 = TColor32($FF7F007F);
104	clTeal32 = TColor32($FF007F7F);
105	clRed32 = TColor32($FFFF0000);
106	clLime32 = TColor32($FF00FF00);
107	clYellow32 = TColor32($FFFFFF00);
108	clBlue32 = TColor32($FF0000FF);
109	clFuchsia32 = TColor32($FFFF00FF);
110	clAqua32 = TColor32($FF00FFFF);
111
112	clAliceBlue32 = TColor32($FFF0F8FF);
113	clAntiqueWhite32 = TColor32($FFFAEBD7);
114	clAquamarine32 = TColor32($FF7FFFD4);
115	clAzure32 = TColor32($FFF0FFFF);
116	clBeige32 = TColor32($FFF5F5DC);
117	clBisque32 = TColor32($FFFFE4C4);
118	clBlancheDalmond32 = TColor32($FFFFEBCD);
119	clBlueViolet32 = TColor32($FF8A2BE2);
120	clBrown32 = TColor32($FFA52A2A);
121	clBurlyWood32 = TColor32($FFDEB887);
122	clCadetblue32 = TColor32($FF5F9EA0);
123	clChartReuse32 = TColor32($FF7FFF00);
124	clChocolate32 = TColor32($FFD2691E);
125	clCoral32 = TColor32($FFFF7F50);
126	clCornFlowerBlue32 = TColor32($FF6495ED);
127	clCornSilk32 = TColor32($FFFFF8DC);
128	clCrimson32 = TColor32($FFDC143C);
129	clDarkBlue32 = TColor32($FF00008B);
130	clDarkCyan32 = TColor32($FF008B8B);
131	clDarkGoldenRod32 = TColor32($FFB8860B);
132	clDarkGray32 = TColor32($FFA9A9A9);
133	clDarkGreen32 = TColor32($FF006400);
134	clDarkGrey32 = TColor32($FFA9A9A9);
135	clDarkKhaki32 = TColor32($FFBDB76B);
136	clDarkMagenta32 = TColor32($FF8B008B);
137	clDarkOliveGreen32 = TColor32($FF556B2F);
138	clDarkOrange32 = TColor32($FFFF8C00);
139	clDarkOrchid32 = TColor32($FF9932CC);
140	clDarkRed32 = TColor32($FF8B0000);
141	clDarkSalmon32 = TColor32($FFE9967A);
142	clDarkSeaGreen32 = TColor32($FF8FBC8F);
143	clDarkSlateBlue32 = TColor32($FF483D8B);
144	clDarkSlateGray32 = TColor32($FF2F4F4F);
145	clDarkSlateGrey32 = TColor32($FF2F4F4F);
146	clDarkTurquoise32 = TColor32($FF00CED1);
147	clDarkViolet32 = TColor32($FF9400D3);
148	clDeepPink32 = TColor32($FFFF1493);
149	clDeepSkyBlue32 = TColor32($FF00BFFF);
150	clDodgerBlue32 = TColor32($FF1E90FF);
151	clFireBrick32 = TColor32($FFB22222);
152	clFloralWhite32 = TColor32($FFFFFAF0);
153	clGainsBoro32 = TColor32($FFDCDCDC);
154	clGhostWhite32 = TColor32($FFF8F8FF);
155	clGold32 = TColor32($FFFFD700);
156	clGoldenRod32 = TColor32($FFDAA520);
157	clGreenYellow32 = TColor32($FFADFF2F);
158	clGrey32 = TColor32($FF808080);
159	clHoneyDew32 = TColor32($FFF0FFF0);
160	clHotPink32 = TColor32($FFFF69B4);
161	clIndianRed32 = TColor32($FFCD5C5C);
162	clIndigo32 = TColor32($FF4B0082);
163	clIvory32 = TColor32($FFFFFFF0);
164	clKhaki32 = TColor32($FFF0E68C);
165	clLavender32 = TColor32($FFE6E6FA);
166	clLavenderBlush32 = TColor32($FFFFF0F5);
167	clLawnGreen32 = TColor32($FF7CFC00);
168	clLemonChiffon32 = TColor32($FFFFFACD);
169	clLightBlue32 = TColor32($FFADD8E6);
170	clLightCoral32 = TColor32($FFF08080);
171	clLightCyan32 = TColor32($FFE0FFFF);
172	clLightGoldenRodYellow32= TColor32($FFFAFAD2);
173	clLightGreen32 = TColor32($FF90EE90);
174	clLightGrey32 = TColor32($FFD3D3D3);
175	clLightPink32 = TColor32($FFFFB6C1);
176	clLightSalmon32 = TColor32($FFFFA07A);
177	clLightSeagreen32 = TColor32($FF20B2AA);
178	clLightSkyblue32 = TColor32($FF87CEFA);
179	clLightSlategray32 = TColor32($FF778899);
180	clLightSlategrey32 = TColor32($FF778899);
181	clLightSteelblue32 = TColor32($FFB0C4DE);
182	clLightYellow32 = TColor32($FFFFFFE0);
183	clLtGray32 = TColor32($FFC0C0C0);
184	clMedGray32 = TColor32($FFA0A0A4);
185	clDkGray32 = TColor32($FF808080);
186	clMoneyGreen32 = TColor32($FFC0DCC0);
187	clLegacySkyBlue32 = TColor32($FFA6CAF0);
188	clCream32 = TColor32($FFFFFBF0);
189	clLimeGreen32 = TColor32($FF32CD32);
190	clLinen32 = TColor32($FFFAF0E6);
191	clMediumAquamarine32 = TColor32($FF66CDAA);
192	clMediumBlue32 = TColor32($FF0000CD);
193	clMediumOrchid32 = TColor32($FFBA55D3);
194	clMediumPurple32 = TColor32($FF9370DB);
195	clMediumSeaGreen32 = TColor32($FF3CB371);
196	clMediumSlateBlue32 = TColor32($FF7B68EE);
197	clMediumSpringGreen32 = TColor32($FF00FA9A);
198	clMediumTurquoise32 = TColor32($FF48D1CC);
199	clMediumVioletRed32 = TColor32($FFC71585);
200	clMidnightBlue32 = TColor32($FF191970);
201	clMintCream32 = TColor32($FFF5FFFA);
202	clMistyRose32 = TColor32($FFFFE4E1);
203	clMoccasin32 = TColor32($FFFFE4B5);
204	clNavajoWhite32 = TColor32($FFFFDEAD);
205	clOldLace32 = TColor32($FFFDF5E6);
206	clOliveDrab32 = TColor32($FF6B8E23);
207	clOrange32 = TColor32($FFFFA500);
208	clOrangeRed32 = TColor32($FFFF4500);
209	clOrchid32 = TColor32($FFDA70D6);
210	clPaleGoldenRod32 = TColor32($FFEEE8AA);
211	clPaleGreen32 = TColor32($FF98FB98);
212	clPaleTurquoise32 = TColor32($FFAFEEEE);
213	clPaleVioletred32 = TColor32($FFDB7093);
214	clPapayaWhip32 = TColor32($FFFFEFD5);
215	clPeachPuff32 = TColor32($FFFFDAB9);
216	clPeru32 = TColor32($FFCD853F);
217	clPlum32 = TColor32($FFDDA0DD);
218	clPowderBlue32 = TColor32($FFB0E0E6);
219	clRosyBrown32 = TColor32($FFBC8F8F);
220	clRoyalBlue32 = TColor32($FF4169E1);
221	clSaddleBrown32 = TColor32($FF8B4513);
222	clSalmon32 = TColor32($FFFA8072);
223	clSandyBrown32 = TColor32($FFF4A460);
224	clSeaGreen32 = TColor32($FF2E8B57);
225	clSeaShell32 = TColor32($FFFFF5EE);
226	clSienna32 = TColor32($FFA0522D);
227	clSilver32 = TColor32($FFC0C0C0);
228	clSkyblue32 = TColor32($FF87CEEB);
229	clSlateBlue32 = TColor32($FF6A5ACD);
230	clSlateGray32 = TColor32($FF708090);
231	clSlateGrey32 = TColor32($FF708090);
232	clSnow32 = TColor32($FFFFFAFA);
233	clSpringgreen32 = TColor32($FF00FF7F);
234	clSteelblue32 = TColor32($FF4682B4);
235	clTan32 = TColor32($FFD2B48C);
236	clThistle32 = TColor32($FFD8BFD8);
237	clTomato32 = TColor32($FFFF6347);
238	clTurquoise32 = TColor32($FF40E0D0);
239	clViolet32 = TColor32($FFEE82EE);
240	clWheat32 = TColor32($FFF5DEB3);
241	clWhitesmoke32 = TColor32($FFF5F5F5);
242	clYellowgreen32 = TColor32($FF9ACD32);
243
244	// Some semi-transparent color constants
245	clTrWhite32 = TColor32($7FFFFFFF);
246	clTrGray32 = TColor32($7F7F7F7F);
247	clTrBlack32 = TColor32($7F000000);
248	clTrRed32 = TColor32($7FFF0000);
249	clTrGreen32 = TColor32($7F00FF00);
250	clTrBlue32 = TColor32($7F0000FF);
251
252	// Color construction and conversion functions
253	function Color32(WinColor: TColor): TColor32; overload;
254	function Color32(R, G, B: Byte; A: Byte = $FF): TColor32; overload;
255	function Color32(Index: Byte; var Palette: TPalette32): TColor32; overload;
256	function Gray32(Intensity: Byte; Alpha: Byte = $FF): TColor32; {$IFDEF USEINLINING} inline; {$ENDIF}
257	function WinColor(Color32: TColor32): TColor;
258	function ArrayOfColor32(Colors: array of TColor32): TArrayOfColor32;
259
260	// Color component access
261	procedure Color32ToRGB(Color32: TColor32; var R, G, B: Byte);
262	procedure Color32ToRGBA(Color32: TColor32; var R, G, B, A: Byte);
263	function Color32Components(R, G, B, A: Boolean): TColor32Components;
264	function RedComponent(Color32: TColor32): Integer; {$IFDEF USEINLINING} inline; {$ENDIF}
265	function GreenComponent(Color32: TColor32): Integer; {$IFDEF USEINLINING} inline; {$ENDIF}
266	function BlueComponent(Color32: TColor32): Integer; {$IFDEF USEINLINING} inline; {$ENDIF}
267	function AlphaComponent(Color32: TColor32): Integer; {$IFDEF USEINLINING} inline; {$ENDIF}
268	function Intensity(Color32: TColor32): Integer; {$IFDEF USEINLINING} inline; {$ENDIF}
269	function InvertColor(Color32: TColor32): TColor32; {$IFDEF USEINLINING} inline; {$ENDIF}
270	function SetAlpha(Color32: TColor32; NewAlpha: Integer): TColor32; {$IFDEF USEINLINING} inline; {$ENDIF}
271	procedure ModifyAlpha(var Color32: TColor32; NewAlpha: Byte); {$IFDEF USEINLINING} inline; {$ENDIF}
272	procedure ScaleAlpha(var Color32: TColor32; Scale: Single); {$IFDEF USEINLINING} inline; {$ENDIF}
273
274	// Color space conversion
275	function HSLtoRGB(H, S, L: Single): TColor32; overload;
276	procedure RGBtoHSL(RGB: TColor32; out H, S, L : Single); overload;
277	function HSLtoRGB(H, S, L: Integer; A: Integer = $ff): TColor32; overload;
278	procedure RGBtoHSL(RGB: TColor32; out H, S, L: Byte); overload;
279	function HSVtoRGB(H, S, V: Single): TColor32;
280	procedure RGBToHSV(Color: TColor32; out H, S, V: Single);
281
282	{$IFNDEF PLATFORM_INDEPENDENT}
283	// Palette conversion functions
284	function WinPalette(const P: TPalette32): HPALETTE;
285	{$ENDIF}
286
287	{ A fixed-point type }
288
289	type
290	// This type has data bits arrangement compatible with Windows.TFixed
291	PFixed = ^TFixed;
292	TFixed = type Integer;
293	{$NODEFINE TFixed}
294
295	{$NODEFINE PFixedRec}
296	PFixedRec = ^TFixedRec;
297	{$NODEFINE TFixedRec}
298	TFixedRec = packed record
299	case Integer of
300	0: (Fixed: TFixed);
301	1: (Frac: Word; Int: SmallInt);
302	end;
303
304	PFixedArray = ^TFixedArray;
305	TFixedArray = array [0..0] of TFixed;
306	PArrayOfFixed = ^TArrayOfFixed;
307	TArrayOfFixed = array of TFixed;
308	PArrayOfArrayOfFixed = ^TArrayOfArrayOfFixed;
309	TArrayOfArrayOfFixed = array of TArrayOfFixed;
310
311	// TFloat determines the precision level for certain floating-point operations
312	PFloat = ^TFloat;
313	TFloat = Single;
314
315	{ Other dynamic arrays }
316	type
317	PByteArray = ^TByteArray;
318	TByteArray = array [0..0] of Byte;
319	PArrayOfByte = ^TArrayOfByte;
320	TArrayOfByte = array of Byte;
321
322	PWordArray = ^TWordArray;
323	TWordArray = array [0..0] of Word;
324	PArrayOfWord = ^TArrayOfWord;
325	TArrayOfWord = array of Word;
326
327	PIntegerArray = ^TIntegerArray;
328	TIntegerArray = array [0..0] of Integer;
329	PArrayOfInteger = ^TArrayOfInteger;
330	TArrayOfInteger = array of Integer;
331	PArrayOfArrayOfInteger = ^TArrayOfArrayOfInteger;
332	TArrayOfArrayOfInteger = array of TArrayOfInteger;
333
334	PCardinalArray = ^TCardinalArray;
335	TCardinalArray = array [0..0] of Cardinal;
336	PArrayOfCardinal = ^TArrayOfCardinal;
337	TArrayOfCardinal = array of Cardinal;
338	PArrayOfArrayOfCardinal = ^TArrayOfArrayOfCardinal;
339	TArrayOfArrayOfCardinal = array of TArrayOfCardinal;
340
341	PSingleArray = ^TSingleArray;
342	TSingleArray = array [0..0] of Single;
343	PArrayOfSingle = ^TArrayOfSingle;
344	TArrayOfSingle = array of Single;
345
346	PFloatArray = ^TFloatArray;
347	TFloatArray = array [0..0] of TFloat;
348	PArrayOfFloat = ^TArrayOfFloat;
349	TArrayOfFloat = array of TFloat;
350
351	const
352	// Fixed point math constants
353	FixedOne = $10000;
354	FixedHalf = $7FFF;
355	FixedPI = Round(PI * FixedOne);
356	FixedToFloat = 1 / FixedOne;
357
358	COne255th = 1 / $FF;
359
360	function Fixed(S: Single): TFixed; overload; {$IFDEF USEINLINING} inline; {$ENDIF}
361	function Fixed(I: Integer): TFixed; overload; {$IFDEF USEINLINING} inline; {$ENDIF}
362
363	{ Points }
364
365	type
366	{$IFNDEF FPC}
367	{$IFNDEF BCB}
368	PPoint = ^TPoint;
369	TPoint = Windows.TPoint;
370	{$ENDIF}
371	{$ENDIF}
372
373	PPointArray = ^TPointArray;
374	TPointArray = array [0..0] of TPoint;
375	PArrayOfPoint = ^TArrayOfPoint;
376	TArrayOfPoint = array of TPoint;
377	PArrayOfArrayOfPoint = ^TArrayOfArrayOfPoint;
378	TArrayOfArrayOfPoint = array of TArrayOfPoint;
379
380	PFloatPoint = ^TFloatPoint;
381	TFloatPoint = record
382	X, Y: TFloat;
383	{$IFDEF SUPPORT_ENHANCED_RECORDS}
384	public
385	{$IFNDEF FPC}
386	{$IFDEF COMPILERXE2_UP}
387	constructor Create(P: TPointF); overload;
388	{$ENDIF}
389	constructor Create(P: TPoint); overload;
390	constructor Create(X, Y: Integer); overload;
391	constructor Create(X, Y: Single); overload;
392	{$ENDIF}
393
394	// operator overloads
395	class operator Equal(const Lhs, Rhs: TFloatPoint): Boolean;
396	class operator NotEqual(const Lhs, Rhs: TFloatPoint): Boolean;
397	class operator Add(const Lhs, Rhs: TFloatPoint): TFloatPoint;
398	class operator Subtract(const Lhs, Rhs: TFloatPoint): TFloatPoint;
399	{$IFDEF COMPILERXE2_UP}
400	class operator Explicit(A: TPointF): TFloatPoint;
401	class operator Implicit(A: TPointF): TFloatPoint;
402	{$ENDIF}
403
404	class function Zero: TFloatPoint; inline; static;
405	{$ENDIF}
406	end;
407
408	PFloatPointArray = ^TFloatPointArray;
409	TFloatPointArray = array [0..0] of TFloatPoint;
410	PArrayOfFloatPoint = ^TArrayOfFloatPoint;
411	TArrayOfFloatPoint = array of TFloatPoint;
412	PArrayOfArrayOfFloatPoint = ^TArrayOfArrayOfFloatPoint;
413	TArrayOfArrayOfFloatPoint = array of TArrayOfFloatPoint;
414
415	PFixedPoint = ^TFixedPoint;
416	TFixedPoint = record
417	X, Y: TFixed;
418	{$IFDEF SUPPORT_ENHANCED_RECORDS}
419	public
420	{$IFNDEF FPC}
421	{$IFDEF COMPILERXE2_UP}
422	constructor Create(P: TPointF); overload;
423	{$ENDIF}
424	constructor Create(P: TFloatPoint); overload;
425	constructor Create(X, Y: TFixed); overload;
426	constructor Create(X, Y: Integer); overload;
427	constructor Create(X, Y: TFloat); overload;
428	{$ENDIF}
429
430	// operator overloads
431	class operator Equal(const Lhs, Rhs: TFixedPoint): Boolean;
432	class operator NotEqual(const Lhs, Rhs: TFixedPoint): Boolean;
433	class operator Add(const Lhs, Rhs: TFixedPoint): TFixedPoint;
434	class operator Subtract(const Lhs, Rhs: TFixedPoint): TFixedPoint;
435
436	class function Zero: TFixedPoint; inline; static;
437	{$ENDIF}
438	end;
439	{$NODEFINE TFixedPoint}
440
441	PFixedPointArray = ^TFixedPointArray;
442	TFixedPointArray = array [0..0] of TFixedPoint;
443	PArrayOfFixedPoint = ^TArrayOfFixedPoint;
444	TArrayOfFixedPoint = array of TFixedPoint;
445	PArrayOfArrayOfFixedPoint = ^TArrayOfArrayOfFixedPoint;
446	TArrayOfArrayOfFixedPoint = array of TArrayOfFixedPoint;
447
448	// construction and conversion of point types
449	function Point(X, Y: Integer): TPoint; overload; {$IFDEF USEINLINING} inline; {$ENDIF}
450	function Point(const FP: TFloatPoint): TPoint; overload; {$IFDEF USEINLINING} inline; {$ENDIF}
451	function Point(const FXP: TFixedPoint): TPoint; overload; {$IFDEF USEINLINING} inline; {$ENDIF}
452	function FloatPoint(X, Y: Single): TFloatPoint; overload; {$IFDEF USEINLINING} inline; {$ENDIF}
453	function FloatPoint(const P: TPoint): TFloatPoint; overload; {$IFDEF USEINLINING} inline; {$ENDIF}
454	function FloatPoint(const FXP: TFixedPoint): TFloatPoint; overload; {$IFDEF USEINLINING} inline; {$ENDIF}
455	function FixedPoint(X, Y: Integer): TFixedPoint; overload; {$IFDEF USEINLINING} inline; {$ENDIF}
456	function FixedPoint(X, Y: Single): TFixedPoint; overload; {$IFDEF USEINLINING} inline; {$ENDIF}
457	function FixedPoint(const P: TPoint): TFixedPoint; overload; {$IFDEF USEINLINING} inline; {$ENDIF}
458	function FixedPoint(const FP: TFloatPoint): TFixedPoint; overload; {$IFDEF USEINLINING} inline; {$ENDIF}
459
460	{ Rectangles }
461
462	type
463	{$IFNDEF FPC}
464	PRect = Windows.PRect;
465	TRect = Windows.TRect;
466	{$ENDIF}
467
468	PFloatRect = ^TFloatRect;
469	{$NODEFINE TFloatRect}
470	{$IFDEF SupportsBoost}
471	($HPPEMIT '#include <boost/strong_typedef.hpp>')
472	{$ENDIF}
473	($HPPEMIT 'namespace Gr32 {')
474	{$IFDEF SupportsBoost}
475	($HPPEMIT 'BOOST_STRONG_TYPEDEF(int, TFixed)')
476	{$ELSE}
477	($HPPEMIT 'typedef int TFixed;')
478	{$ENDIF}
479	($HPPEMIT 'struct TFixedPoint { float X, Y; }; typedef struct TFixedPoint TFixedPoint;')
480	($HPPEMIT 'struct TFloatRect { float Left, Top, Right, Bottom; }; typedef struct TFloatRect TFloatRect;')
481	($HPPEMIT 'struct TFixedRect { TFixed Left, Top, Right, Bottom; }; typedef struct TFixedRect TFixedRect;')
482	($HPPEMIT '} // namespace Gr32 ')
483	TFloatRect = packed record
484	case Integer of
485	0: (Left, Top, Right, Bottom: TFloat);
486	1: (TopLeft, BottomRight: TFloatPoint);
487	end;
488
489	{$NODEFINE PFixedRect}
490	PFixedRect = ^TFixedRect;
491	{$NODEFINE TFixedRect}
492	TFixedRect = packed record
493	case Integer of
494	0: (Left, Top, Right, Bottom: TFixed);
495	1: (TopLeft, BottomRight: TFixedPoint);
496	end;
497
498	TRectRounding = (rrClosest, rrOutside, rrInside);
499
500	// Rectangle construction/conversion functions
501	function MakeRect(const L, T, R, B: Integer): TRect; overload; {$IFDEF USEINLINING} inline; {$ENDIF}
502	function MakeRect(const FR: TFloatRect; Rounding: TRectRounding = rrClosest): TRect; overload;
503	function MakeRect(const FXR: TFixedRect; Rounding: TRectRounding = rrClosest): TRect; overload;
504	function FixedRect(const L, T, R, B: TFixed): TFixedRect; overload; {$IFDEF USEINLINING} inline; {$ENDIF}
505	function FixedRect(const TopLeft, BottomRight: TFixedPoint): TFixedRect; overload; {$IFDEF USEINLINING} inline; {$ENDIF}
506	function FixedRect(const ARect: TRect): TFixedRect; overload; {$IFDEF USEINLINING} inline; {$ENDIF}
507	function FixedRect(const FR: TFloatRect): TFixedRect; overload; {$IFDEF USEINLINING} inline; {$ENDIF}
508	function FloatRect(const L, T, R, B: TFloat): TFloatRect; overload; {$IFDEF USEINLINING} inline; {$ENDIF}
509	function FloatRect(const TopLeft, BottomRight: TFloatPoint): TFloatRect; overload; {$IFDEF USEINLINING} inline; {$ENDIF}
510	function FloatRect(const ARect: TRect): TFloatRect; overload; {$IFDEF USEINLINING} inline; {$ENDIF}
511	function FloatRect(const FXR: TFixedRect): TFloatRect; overload; {$IFDEF USEINLINING} inline; {$ENDIF}
512
513	// Some basic operations over rectangles
514	function IntersectRect(out Dst: TRect; const R1, R2: TRect): Boolean; overload;
515	function IntersectRect(out Dst: TFloatRect; const FR1, FR2: TFloatRect): Boolean; overload;
516	function UnionRect(out Rect: TRect; const R1, R2: TRect): Boolean; overload;
517	function UnionRect(out Rect: TFloatRect; const R1, R2: TFloatRect): Boolean; overload;
518	function EqualRect(const R1, R2: TRect): Boolean; overload; {$IFDEF USEINLINING} inline; {$ENDIF}
519	function EqualRect(const R1, R2: TFloatRect): Boolean; overload; {$IFDEF USEINLINING} inline; {$ENDIF}
520	procedure InflateRect(var R: TRect; Dx, Dy: Integer); overload; {$IFDEF USEINLINING} inline; {$ENDIF}
521	procedure InflateRect(var FR: TFloatRect; Dx, Dy: TFloat); overload; {$IFDEF USEINLINING} inline; {$ENDIF}
522	procedure OffsetRect(var R: TRect; Dx, Dy: Integer); overload; {$IFDEF USEINLINING} inline; {$ENDIF}
523	procedure OffsetRect(var FR: TFloatRect; Dx, Dy: TFloat); overload; {$IFDEF USEINLINING} inline; {$ENDIF}
524	function IsRectEmpty(const R: TRect): Boolean; overload; {$IFDEF USEINLINING} inline; {$ENDIF}
525	function IsRectEmpty(const FR: TFloatRect): Boolean; overload; {$IFDEF USEINLINING} inline; {$ENDIF}
526	function PtInRect(const R: TRect; const P: TPoint): Boolean; overload; {$IFDEF USEINLINING} inline; {$ENDIF}
527	function PtInRect(const R: TFloatRect; const P: TPoint): Boolean; overload; {$IFDEF USEINLINING} inline; {$ENDIF}
528	function PtInRect(const R: TRect; const P: TFloatPoint): Boolean; overload; {$IFDEF USEINLINING} inline; {$ENDIF}
529	function PtInRect(const R: TFloatRect; const P: TFloatPoint): Boolean; overload; {$IFDEF USEINLINING} inline; {$ENDIF}
530	function EqualRectSize(const R1, R2: TRect): Boolean; overload; {$IFDEF USEINLINING} inline; {$ENDIF}
531	function EqualRectSize(const R1, R2: TFloatRect): Boolean; overload; {$IFDEF USEINLINING} inline; {$ENDIF}
532
533	type
534	{ TBitmap32 draw mode }
535	TDrawMode = (dmOpaque, dmBlend, dmCustom, dmTransparent);
536	TCombineMode = (cmBlend, cmMerge);
537
538	TWrapMode = (wmClamp, wmRepeat, wmMirror);
539	TWrapProc = function(Value, Max: Integer): Integer;
540	TWrapProcEx = function(Value, Min, Max: Integer): Integer;
541
542	{$IFDEF DEPRECATEDMODE}
543	{ Stretch filters }
544	TStretchFilter = (sfNearest, sfDraft, sfLinear, sfCosine, sfSpline,
545	sfLanczos, sfMitchell);
546	{$ENDIF}
547
548	type
549	{ TPlainInterfacedPersistent }
550	{ TPlainInterfacedPersistent provides simple interface support with
551	optional reference-counting operation. }
552	TPlainInterfacedPersistent = class(TPersistent, IInterface)
553	private
554	FRefCounted: Boolean;
555	FRefCount: Integer;
556	protected
557	{ IInterface }
558	{$IFDEF FPC_HAS_CONSTREF}
559	function QueryInterface(constref iid: TGuid; out obj): HResult; {$IFDEF WINDOWS}stdcall{$ELSE}cdecl{$ENDIF};
560	function _AddRef: LongInt; {$IFDEF WINDOWS}stdcall{$ELSE}cdecl{$ENDIF};
561	function _Release: LongInt; {$IFDEF WINDOWS}stdcall{$ELSE}cdecl{$ENDIF};
562	{$ELSE}
563	function QueryInterface(const iid: TGuid; out obj): HResult; stdcall;
564	function _AddRef: LongInt; stdcall;
565	function _Release: LongInt; stdcall;
566	{$ENDIF}
567	property RefCounted: Boolean read FRefCounted write FRefCounted;
568	public
569	procedure AfterConstruction; override;
570	procedure BeforeDestruction; override;
571	class function NewInstance: TObject; override;
572
573	property RefCount: Integer read FRefCount;
574	end;
575
576	{ TNotifiablePersistent }
577	{ TNotifiablePersistent provides a change notification mechanism }
578	TNotifiablePersistent = class(TPlainInterfacedPersistent)
579	private
580	FUpdateCount: Integer;
581	FOnChange: TNotifyEvent;
582	protected
583	property UpdateCount: Integer read FUpdateCount;
584	public
585	procedure Changed; virtual;
586	procedure BeginUpdate; virtual;
587	procedure EndUpdate; virtual;
588	property OnChange: TNotifyEvent read FOnChange write FOnChange;
589	end;
590
591	{ TThreadPersistent }
592	{ TThreadPersistent is an ancestor for TBitmap32 object. In addition to
593	TPersistent methods, it provides thread-safe locking and change notification }
594	TThreadPersistent = class(TNotifiablePersistent)
595	private
596	FLockCount: Integer;
597	protected
598	{$IFDEF FPC}
599	FLock: TCriticalSection;
600	{$ELSE}
601	FLock: TRTLCriticalSection;
602	{$ENDIF}
603	property LockCount: Integer read FLockCount;
604	public
605	constructor Create; virtual;
606	destructor Destroy; override;
607	procedure Lock;
608	procedure Unlock;
609	end;
610
611	{ TCustomMap }
612	{ An ancestor for bitmaps and similar 2D distributions wich have width and
613	height properties }
614	TCustomMap = class(TThreadPersistent)
615	protected
616	FHeight: Integer;
617	FWidth: Integer;
618	FOnResize: TNotifyEvent;
619	procedure SetHeight(NewHeight: Integer); virtual;
620	procedure SetWidth(NewWidth: Integer); virtual;
621	procedure ChangeSize(var Width, Height: Integer; NewWidth, NewHeight: Integer); virtual;
622	public
623	constructor Create(Width, Height: Integer); reintroduce; overload;
624
625	procedure Delete; virtual;
626	function Empty: Boolean; virtual;
627	procedure Resized; virtual;
628	function SetSizeFrom(Source: TPersistent): Boolean;
629	function SetSize(NewWidth, NewHeight: Integer): Boolean; virtual;
630
631	property Height: Integer read FHeight write SetHeight;
632	property Width: Integer read FWidth write SetWidth;
633	property OnResize: TNotifyEvent read FOnResize write FOnResize;
634	end;
635
636	{ TBitmap32 }
637	{ This is the core of Graphics32 unit. The TBitmap32 class is responsible
638	for storage of a bitmap, as well as for drawing in it.
639	The OnCombine event is fired only when DrawMode is set to dmCustom and two
640	bitmaps are blended together. Unlike most normal events, it does not contain
641	"Sender" parameter and is not called through some virtual method. This
642	(a little bit non-standard) approach allows for faster operation. }
643
644	const
645	// common cases
646	AREAINFO_RECT = $80000000;
647	AREAINFO_LINE = $40000000; // 24 bits for line width in pixels...
648	AREAINFO_ELLIPSE = $20000000;
649	AREAINFO_ABSOLUTE = $10000000;
650
651	AREAINFO_MASK = $FF000000;
652
653	type
654	TPixelCombineEvent = procedure(F: TColor32; var B: TColor32; M: TColor32) of object;
655	TAreaChangedEvent = procedure(Sender: TObject; const Area: TRect;
656	const Info: Cardinal) of object;
657
658	TCustomResampler = class;
659
660	TCustomBackend = class;
661	TCustomBackendClass = class of TCustomBackend;
662
663	TCustomBitmap32 = class(TCustomMap)
664	private
665	FBackend: TCustomBackend;
666	FBits: PColor32Array;
667	FClipRect: TRect;
668	FFixedClipRect: TFixedRect;
669	F256ClipRect: TRect;
670	FClipping: Boolean;
671	FDrawMode: TDrawMode;
672	FCombineMode: TCombineMode;
673	FWrapMode: TWrapMode;
674
675	FMasterAlpha: Cardinal;
676	FOuterColor: TColor32;
677	FPenColor: TColor32;
678	FStippleCounter: Single;
679	FStipplePattern: TArrayOfColor32;
680	FStippleStep: Single;
681	{$IFDEF DEPRECATEDMODE}
682	FStretchFilter: TStretchFilter;
683	{$ENDIF}
684	FOnPixelCombine: TPixelCombineEvent;
685	FOnAreaChanged: TAreaChangedEvent;
686	FOldOnAreaChanged: TAreaChangedEvent;
687	FMeasuringMode: Boolean;
688	FResampler: TCustomResampler;
689	procedure BackendChangedHandler(Sender: TObject); virtual;
690	procedure BackendChangingHandler(Sender: TObject); virtual;
691
692	{$IFDEF BITS_GETTER}
693	function GetBits: PColor32Array; {$IFDEF USEINLINING} inline; {$ENDIF}
694	{$ENDIF}
695
696	function GetPixelPtr(X, Y: Integer): PColor32;
697	function GetScanLine(Y: Integer): PColor32Array;
698
699	procedure SetCombineMode(const Value: TCombineMode);
700	procedure SetDrawMode(Value: TDrawMode);
701	procedure SetWrapMode(Value: TWrapMode);
702	procedure SetMasterAlpha(Value: Cardinal);
703	{$IFDEF DEPRECATEDMODE}
704	procedure SetStretchFilter(Value: TStretchFilter);
705	{$ENDIF}
706	procedure SetClipRect(const Value: TRect);
707	procedure SetResampler(Resampler: TCustomResampler);
708	function GetResamplerClassName: string;
709	procedure SetResamplerClassName(const Value: string);
710	function GetPenPos: TPoint;
711	procedure SetPenPos(const Value: TPoint);
712	function GetPenPosF: TFixedPoint;
713	procedure SetPenPosF(const Value: TFixedPoint);
714	protected
715	WrapProcHorz: TWrapProcEx;
716	WrapProcVert: TWrapProcEx;
717	BlendProc: Pointer;
718	RasterX, RasterY: Integer;
719	RasterXF, RasterYF: TFixed;
720	procedure ChangeSize(var Width, Height: Integer; NewWidth, NewHeight: Integer); override;
721	procedure CopyMapTo(Dst: TCustomBitmap32); virtual;
722	procedure CopyPropertiesTo(Dst: TCustomBitmap32); virtual;
723	procedure AssignTo(Dst: TPersistent); override;
724	function Equal(B: TCustomBitmap32): Boolean;
725	procedure SET_T256(X, Y: Integer; C: TColor32);
726	procedure SET_TS256(X, Y: Integer; C: TColor32);
727	function GET_T256(X, Y: Integer): TColor32;
728	function GET_TS256(X, Y: Integer): TColor32;
729	procedure ReadData(Stream: TStream); virtual;
730	procedure WriteData(Stream: TStream); virtual;
731	procedure DefineProperties(Filer: TFiler); override;
732
733	procedure InitializeBackend(Backend: TCustomBackendClass); virtual;
734	procedure FinalizeBackend; virtual;
735	procedure SetBackend(const Backend: TCustomBackend); virtual;
736
737	{$IFDEF FPC_HAS_CONSTREF}
738	function QueryInterface(constref iid: TGuid; out obj): HResult; {$IFDEF WINDOWS}stdcall{$ELSE}cdecl{$ENDIF};
739	{$ELSE}
740	function QueryInterface(const iid: TGuid; out obj): HResult; stdcall;
741	{$ENDIF}
742
743	function GetPixel(X, Y: Integer): TColor32; {$IFDEF USEINLINING} inline; {$ENDIF}
744	function GetPixelS(X, Y: Integer): TColor32; {$IFDEF USEINLINING} inline; {$ENDIF}
745	function GetPixelW(X, Y: Integer): TColor32; {$IFDEF USEINLINING} inline; {$ENDIF}
746
747	function GetPixelF(X, Y: Single): TColor32; {$IFDEF USEINLINING} inline; {$ENDIF}
748	function GetPixelFS(X, Y: Single): TColor32; {$IFDEF USEINLINING} inline; {$ENDIF}
749	function GetPixelFW(X, Y: Single): TColor32; {$IFDEF USEINLINING} inline; {$ENDIF}
750
751	function GetPixelX(X, Y: TFixed): TColor32;
752	function GetPixelXS(X, Y: TFixed): TColor32;
753	function GetPixelXW(X, Y: TFixed): TColor32;
754
755	function GetPixelFR(X, Y: Single): TColor32;
756	function GetPixelXR(X, Y: TFixed): TColor32;
757
758	function GetPixelB(X, Y: Integer): TColor32; {$IFDEF USEINLINING} inline; {$ENDIF}
759
760	procedure SetPixel(X, Y: Integer; Value: TColor32); {$IFDEF USEINLINING} inline; {$ENDIF}
761	procedure SetPixelS(X, Y: Integer; Value: TColor32);
762	procedure SetPixelW(X, Y: Integer; Value: TColor32); {$IFDEF USEINLINING} inline; {$ENDIF}
763
764	procedure SetPixelF(X, Y: Single; Value: TColor32); {$IFDEF USEINLINING} inline; {$ENDIF}
765	procedure SetPixelFS(X, Y: Single; Value: TColor32);
766	procedure SetPixelFW(X, Y: Single; Value: TColor32);
767
768	procedure SetPixelX(X, Y: TFixed; Value: TColor32);
769	procedure SetPixelXS(X, Y: TFixed; Value: TColor32);
770	procedure SetPixelXW(X, Y: TFixed; Value: TColor32);
771	public
772	constructor Create(Backend: TCustomBackendClass); reintroduce; overload; virtual;
773	constructor Create; reintroduce; overload; virtual;
774	constructor Create(Width, Height: Integer); reintroduce; overload; virtual;
775	destructor Destroy; override;
776
777	class function GetPlatformBackendClass: TCustomBackendClass; virtual;
778
779	procedure Assign(Source: TPersistent); override;
780	function BoundsRect: TRect;
781	function Empty: Boolean; override;
782	procedure Clear; overload;
783	procedure Clear(FillColor: TColor32); overload;
784	procedure Delete; override;
785
786	procedure BeginMeasuring(const Callback: TAreaChangedEvent);
787	procedure EndMeasuring;
788
789	function ReleaseBackend: TCustomBackend;
790
791	procedure PropertyChanged; virtual;
792	procedure Changed; overload; override;
793	procedure Changed(const Area: TRect; const Info: Cardinal = AREAINFO_RECT); reintroduce; overload; virtual;
794
795	procedure LoadFromStream(Stream: TStream); virtual;
796	procedure SaveToStream(Stream: TStream; SaveTopDown: Boolean = False); virtual;
797
798	procedure LoadFromFile(const FileName: string); virtual;
799	procedure SaveToFile(const FileName: string; SaveTopDown: Boolean = False); virtual;
800
801	procedure LoadFromResourceID(Instance: THandle; ResID: Integer);
802	procedure LoadFromResourceName(Instance: THandle; const ResName: string);
803
804	procedure ResetAlpha; overload;
805	procedure ResetAlpha(const AlphaValue: Byte); overload;
806
807	procedure Draw(DstX, DstY: Integer; Src: TCustomBitmap32); overload;
808	procedure Draw(DstX, DstY: Integer; const SrcRect: TRect; Src: TCustomBitmap32); overload;
809	procedure Draw(const DstRect, SrcRect: TRect; Src: TCustomBitmap32); overload;
810
811	procedure SetPixelT(X, Y: Integer; Value: TColor32); overload;
812	procedure SetPixelT(var Ptr: PColor32; Value: TColor32); overload;
813	procedure SetPixelTS(X, Y: Integer; Value: TColor32);
814
815	procedure DrawTo(Dst: TCustomBitmap32); overload;
816	procedure DrawTo(Dst: TCustomBitmap32; DstX, DstY: Integer); overload;
817	procedure DrawTo(Dst: TCustomBitmap32; DstX, DstY: Integer; const SrcRect: TRect); overload;
818	procedure DrawTo(Dst: TCustomBitmap32; const DstRect: TRect); overload;
819	procedure DrawTo(Dst: TCustomBitmap32; const DstRect, SrcRect: TRect); overload;
820
821	procedure SetStipple(NewStipple: TArrayOfColor32); overload;
822	procedure SetStipple(NewStipple: array of TColor32); overload;
823	procedure AdvanceStippleCounter(LengthPixels: Single);
824	function GetStippleColor: TColor32;
825
826	procedure HorzLine(X1, Y, X2: Integer; Value: TColor32);
827	procedure HorzLineS(X1, Y, X2: Integer; Value: TColor32);
828	procedure HorzLineT(X1, Y, X2: Integer; Value: TColor32);
829	procedure HorzLineTS(X1, Y, X2: Integer; Value: TColor32);
830	procedure HorzLineTSP(X1, Y, X2: Integer);
831	procedure HorzLineX(X1, Y, X2: TFixed; Value: TColor32);
832	procedure HorzLineXS(X1, Y, X2: TFixed; Value: TColor32);
833
834	procedure VertLine(X, Y1, Y2: Integer; Value: TColor32);
835	procedure VertLineS(X, Y1, Y2: Integer; Value: TColor32);
836	procedure VertLineT(X, Y1, Y2: Integer; Value: TColor32);
837	procedure VertLineTS(X, Y1, Y2: Integer; Value: TColor32);
838	procedure VertLineTSP(X, Y1, Y2: Integer);
839	procedure VertLineX(X, Y1, Y2: TFixed; Value: TColor32);
840	procedure VertLineXS(X, Y1, Y2: TFixed; Value: TColor32);
841
842	procedure Line(X1, Y1, X2, Y2: Integer; Value: TColor32; L: Boolean = False);
843	procedure LineS(X1, Y1, X2, Y2: Integer; Value: TColor32; L: Boolean = False);
844	procedure LineT(X1, Y1, X2, Y2: Integer; Value: TColor32; L: Boolean = False);
845	procedure LineTS(X1, Y1, X2, Y2: Integer; Value: TColor32; L: Boolean = False);
846	procedure LineA(X1, Y1, X2, Y2: Integer; Value: TColor32; L: Boolean = False);
847	procedure LineAS(X1, Y1, X2, Y2: Integer; Value: TColor32; L: Boolean = False);
848	procedure LineX(X1, Y1, X2, Y2: TFixed; Value: TColor32; L: Boolean = False); overload;
849	procedure LineF(X1, Y1, X2, Y2: Single; Value: TColor32; L: Boolean = False); overload;
850	procedure LineXS(X1, Y1, X2, Y2: TFixed; Value: TColor32; L: Boolean = False); overload;
851	procedure LineFS(X1, Y1, X2, Y2: Single; Value: TColor32; L: Boolean = False); overload;
852	procedure LineXP(X1, Y1, X2, Y2: TFixed; L: Boolean = False); overload;
853	procedure LineFP(X1, Y1, X2, Y2: Single; L: Boolean = False); overload;
854	procedure LineXSP(X1, Y1, X2, Y2: TFixed; L: Boolean = False); overload;
855	procedure LineFSP(X1, Y1, X2, Y2: Single; L: Boolean = False); overload;
856
857	property PenColor: TColor32 read FPenColor write FPenColor;
858	procedure MoveTo(X, Y: Integer);
859	procedure LineToS(X, Y: Integer);
860	procedure LineToTS(X, Y: Integer);
861	procedure LineToAS(X, Y: Integer);
862	procedure MoveToX(X, Y: TFixed);
863	procedure MoveToF(X, Y: Single);
864	procedure LineToXS(X, Y: TFixed);
865	procedure LineToFS(X, Y: Single);
866	procedure LineToXSP(X, Y: TFixed);
867	procedure LineToFSP(X, Y: Single);
868	property PenPos: TPoint read GetPenPos write SetPenPos;
869	property PenPosF: TFixedPoint read GetPenPosF write SetPenPosF;
870
871	procedure FillRect(X1, Y1, X2, Y2: Integer; Value: TColor32);
872	procedure FillRectS(X1, Y1, X2, Y2: Integer; Value: TColor32); overload;
873	procedure FillRectT(X1, Y1, X2, Y2: Integer; Value: TColor32);
874	procedure FillRectTS(X1, Y1, X2, Y2: Integer; Value: TColor32); overload;
875	procedure FillRectS(const ARect: TRect; Value: TColor32); overload;
876	procedure FillRectTS(const ARect: TRect; Value: TColor32); overload;
877
878	procedure FrameRectS(X1, Y1, X2, Y2: Integer; Value: TColor32); overload;
879	procedure FrameRectTS(X1, Y1, X2, Y2: Integer; Value: TColor32); overload;
880	procedure FrameRectTSP(X1, Y1, X2, Y2: Integer);
881	procedure FrameRectS(const ARect: TRect; Value: TColor32); overload;
882	procedure FrameRectTS(const ARect: TRect; Value: TColor32); overload;
883
884	procedure RaiseRectTS(X1, Y1, X2, Y2: Integer; Contrast: Integer); overload;
885	procedure RaiseRectTS(const ARect: TRect; Contrast: Integer); overload;
886
887	procedure Roll(Dx, Dy: Integer; FillBack: Boolean; FillColor: TColor32);
888	procedure FlipHorz(Dst: TCustomBitmap32 = nil);
889	procedure FlipVert(Dst: TCustomBitmap32 = nil);
890	procedure Rotate90(Dst: TCustomBitmap32 = nil);
891	procedure Rotate180(Dst: TCustomBitmap32 = nil);
892	procedure Rotate270(Dst: TCustomBitmap32 = nil);
893
894	procedure ResetClipRect;
895
896	property Pixel[X, Y: Integer]: TColor32 read GetPixel write SetPixel; default;
897	property PixelS[X, Y: Integer]: TColor32 read GetPixelS write SetPixelS;
898	property PixelW[X, Y: Integer]: TColor32 read GetPixelW write SetPixelW;
899	property PixelX[X, Y: TFixed]: TColor32 read GetPixelX write SetPixelX;
900	property PixelXS[X, Y: TFixed]: TColor32 read GetPixelXS write SetPixelXS;
901	property PixelXW[X, Y: TFixed]: TColor32 read GetPixelXW write SetPixelXW;
902	property PixelF[X, Y: Single]: TColor32 read GetPixelF write SetPixelF;
903	property PixelFS[X, Y: Single]: TColor32 read GetPixelFS write SetPixelFS;
904	property PixelFW[X, Y: Single]: TColor32 read GetPixelFW write SetPixelFW;
905	property PixelFR[X, Y: Single]: TColor32 read GetPixelFR;
906	property PixelXR[X, Y: TFixed]: TColor32 read GetPixelXR;
907
908	property Backend: TCustomBackend read FBackend write SetBackend;
909
910	{$IFDEF BITS_GETTER}
911	property Bits: PColor32Array read GetBits;
912	{$ELSE}
913	property Bits: PColor32Array read FBits;
914	{$ENDIF}
915
916	property ClipRect: TRect read FClipRect write SetClipRect;
917	property Clipping: Boolean read FClipping;
918
919	property PixelPtr[X, Y: Integer]: PColor32 read GetPixelPtr;
920	property ScanLine[Y: Integer]: PColor32Array read GetScanLine;
921	property StippleCounter: Single read FStippleCounter write FStippleCounter;
922	property StippleStep: Single read FStippleStep write FStippleStep;
923
924	property MeasuringMode: Boolean read FMeasuringMode;
925	published
926	property DrawMode: TDrawMode read FDrawMode write SetDrawMode default dmOpaque;
927	property CombineMode: TCombineMode read FCombineMode write SetCombineMode default cmBlend;
928	property WrapMode: TWrapMode read FWrapMode write SetWrapMode default wmClamp;
929	property MasterAlpha: Cardinal read FMasterAlpha write SetMasterAlpha default $FF;
930	property OuterColor: TColor32 read FOuterColor write FOuterColor default 0;
931	{$IFDEF DEPRECATEDMODE}
932	property StretchFilter: TStretchFilter read FStretchFilter write SetStretchFilter default sfNearest;
933	{$ENDIF}
934	property ResamplerClassName: string read GetResamplerClassName write SetResamplerClassName;
935	property Resampler: TCustomResampler read FResampler write SetResampler;
936	property OnChange;
937	property OnPixelCombine: TPixelCombineEvent read FOnPixelCombine write FOnPixelCombine;
938	property OnAreaChanged: TAreaChangedEvent read FOnAreaChanged write FOnAreaChanged;
939	property OnResize;
940	end;
941
942	TBitmap32 = class(TCustomBitmap32)
943	private
944	FOnHandleChanged: TNotifyEvent;
945
946	procedure BackendChangedHandler(Sender: TObject); override;
947	procedure BackendChangingHandler(Sender: TObject); override;
948
949	procedure FontChanged(Sender: TObject);
950	procedure CanvasChanged(Sender: TObject);
951	function GetCanvas: TCanvas; {$IFDEF USEINLINING} inline; {$ENDIF}
952
953	function GetBitmapInfo: TBitmapInfo; {$IFDEF USEINLINING} inline; {$ENDIF}
954	function GetHandle: HBITMAP; {$IFDEF USEINLINING} inline; {$ENDIF}
955	function GetHDC: HDC; {$IFDEF USEINLINING} inline; {$ENDIF}
956
957	function GetFont: TFont;
958	procedure SetFont(Value: TFont);
959	protected
960	procedure FinalizeBackend; override;
961	procedure SetBackend(const Backend: TCustomBackend); override;
962
963	procedure HandleChanged; virtual;
964	procedure CopyPropertiesTo(Dst: TCustomBitmap32); override;
965	public
966	class function GetPlatformBackendClass: TCustomBackendClass; override;
967
968	{$IFDEF BCB}
969	procedure Draw(const DstRect, SrcRect: TRect; hSrc: Cardinal); overload;
970	{$ELSE}
971	procedure Draw(const DstRect, SrcRect: TRect; hSrc: HDC); overload;
972	{$ENDIF}
973
974	{$IFDEF BCB}
975	procedure DrawTo(hDst: Cardinal; DstX, DstY: Integer); overload;
976	procedure DrawTo(hDst: Cardinal; const DstRect, SrcRect: TRect); overload;
977	procedure TileTo(hDst: Cardinal; const DstRect, SrcRect: TRect); overload;
978	{$ELSE}
979	procedure DrawTo(hDst: HDC; DstX: Integer = 0; DstY: Integer = 0); overload;
980	procedure DrawTo(hDst: HDC; const DstRect, SrcRect: TRect); overload;
981	procedure TileTo(hDst: HDC; const DstRect, SrcRect: TRect); overload;
982	{$ENDIF}
983
984	{$IFDEF COMPILER2009_UP}
985	procedure DrawTo(Dst: TControlCanvas; DstX: Integer = 0; DstY: Integer = 0); overload;
986	procedure DrawTo(Dst: TControlCanvas; const DstRect, SrcRect: TRect); overload;
987	procedure TileTo(Dst: TControlCanvas; const DstRect, SrcRect: TRect); overload;
988	{$ENDIF}
989
990	procedure UpdateFont;
991	procedure Textout(X, Y: Integer; const Text: string); overload;
992	procedure Textout(X, Y: Integer; const ClipRect: TRect; const Text: string); overload;
993	procedure Textout(var DstRect: TRect; const Flags: Cardinal; const Text: string); overload;
994	function TextExtent(const Text: string): TSize;
995	function TextHeight(const Text: string): Integer;
996	function TextWidth(const Text: string): Integer;
997	procedure RenderText(X, Y: Integer; const Text: string; AALevel: Integer; Color: TColor32);
998	procedure TextoutW(X, Y: Integer; const Text: Widestring); overload;
999	procedure TextoutW(X, Y: Integer; const ClipRect: TRect; const Text: Widestring); overload;
1000	procedure TextoutW(var DstRect: TRect; const Flags: Cardinal; const Text: Widestring); overload;
1001	function TextExtentW(const Text: Widestring): TSize;
1002	function TextHeightW(const Text: Widestring): Integer;
1003	function TextWidthW(const Text: Widestring): Integer;
1004	procedure RenderTextW(X, Y: Integer; const Text: Widestring; AALevel: Integer; Color: TColor32);
1005
1006	property Canvas: TCanvas read GetCanvas;
1007	function CanvasAllocated: Boolean;
1008	procedure DeleteCanvas;
1009
1010	property Font: TFont read GetFont write SetFont;
1011
1012	property BitmapHandle: HBITMAP read GetHandle;
1013	property BitmapInfo: TBitmapInfo read GetBitmapInfo;
1014	property Handle: HDC read GetHDC;
1015	published
1016	property OnHandleChanged: TNotifyEvent read FOnHandleChanged write FOnHandleChanged;
1017	end;
1018
1019	{ TCustomBackend }
1020	{ This class functions as backend for the TBitmap32 class.
1021	It manages and provides the backing buffer as well as OS or
1022	graphics subsystem specific features.}
1023
1024	TCustomBackend = class(TThreadPersistent)
1025	protected
1026	FBits: PColor32Array;
1027	FOwner: TCustomBitmap32;
1028	FOnChanging: TNotifyEvent;
1029
1030	procedure Changing; virtual;
1031
1032	{$IFDEF BITS_GETTER}
1033	function GetBits: PColor32Array; virtual;
1034	{$ENDIF}
1035
1036	procedure InitializeSurface(NewWidth, NewHeight: Integer; ClearBuffer: Boolean); virtual;
1037	procedure FinalizeSurface; virtual;
1038	public
1039	constructor Create; overload; override;
1040	constructor Create(Owner: TCustomBitmap32); reintroduce; overload; virtual;
1041	destructor Destroy; override;
1042
1043	procedure Assign(Source: TPersistent); override;
1044
1045	procedure Clear; virtual;
1046	function Empty: Boolean; virtual;
1047
1048	procedure ChangeSize(out Width, Height: Integer; NewWidth, NewHeight: Integer; ClearBuffer: Boolean = True); virtual;
1049
1050	{$IFDEF BITS_GETTER}
1051	property Bits: PColor32Array read GetBits;
1052	{$ELSE}
1053	property Bits: PColor32Array read FBits;
1054	{$ENDIF}
1055
1056	property OnChanging: TNotifyEvent read FOnChanging write FOnChanging;
1057	end;
1058
1059	{ TCustomSampler }
1060	TCustomSampler = class(TNotifiablePersistent)
1061	public
1062	function GetSampleInt(X, Y: Integer): TColor32; virtual;
1063	function GetSampleFixed(X, Y: TFixed): TColor32; virtual;
1064	function GetSampleFloat(X, Y: TFloat): TColor32; virtual;
1065	procedure PrepareSampling; virtual;
1066	procedure FinalizeSampling; virtual;
1067	function HasBounds: Boolean; virtual;
1068	function GetSampleBounds: TFloatRect; virtual;
1069	end;
1070
1071
1072	TPixelAccessMode = (pamUnsafe, pamSafe, pamWrap, pamTransparentEdge);
1073
1074	{ TCustomResampler }
1075	{ Base class for TCustomBitmap32 specific resamplers. }
1076	TCustomResampler = class(TCustomSampler)
1077	private
1078	FBitmap: TCustomBitmap32;
1079	FClipRect: TRect;
1080	FPixelAccessMode: TPixelAccessMode;
1081	procedure SetPixelAccessMode(const Value: TPixelAccessMode);
1082	protected
1083	function GetWidth: TFloat; virtual;
1084	procedure Resample(
1085	Dst: TCustomBitmap32; DstRect: TRect; DstClip: TRect;
1086	Src: TCustomBitmap32; SrcRect: TRect;
1087	CombineOp: TDrawMode; CombineCallBack: TPixelCombineEvent); virtual; abstract;
1088	procedure AssignTo(Dst: TPersistent); override;
1089	property ClipRect: TRect read FClipRect;
1090	public
1091	constructor Create; overload; virtual;
1092	constructor Create(ABitmap: TCustomBitmap32); overload; virtual;
1093	procedure Changed; override;
1094	procedure PrepareSampling; override;
1095	function HasBounds: Boolean; override;
1096	function GetSampleBounds: TFloatRect; override;
1097	property Bitmap: TCustomBitmap32 read FBitmap write FBitmap;
1098	property Width: TFloat read GetWidth;
1099	published
1100	property PixelAccessMode: TPixelAccessMode read FPixelAccessMode write SetPixelAccessMode default pamSafe;
1101	end;
1102	TCustomResamplerClass = class of TCustomResampler;
1103
1104	var
1105	StockBitmap: TBitmap;
1106
1107	resourcestring
1108	RCStrUnmatchedReferenceCounting = 'Unmatched reference counting.';
1109	RCStrCannotSetSize = 'Can''t set size from ''%s''';
1110	RCStrInpropriateBackend = 'Inappropriate Backend';
1111
1112	implementation
1113
1114	uses
1115	Math, GR32_Blend, GR32_LowLevel, GR32_Math, GR32_Resamplers,
1116	GR32_Containers, GR32_Gamma, GR32_Backends, GR32_Backends_Generic,
1117	{$IFDEF FPC}
1118	Clipbrd,
1119	{$IFDEF LCLWin32}
1120	GR32_Backends_LCL_Win,
1121	{$ENDIF}
1122	{$IF defined(LCLGtk) or defined(LCLGtk2)}
1123	GR32_Backends_LCL_Gtk,
1124	{$IFEND}
1125	{$IFDEF LCLCarbon}
1126	GR32_Backends_LCL_Carbon,
1127	{$ENDIF}
1128	{$IFDEF LCLCustomDrawn}
1129	GR32_Backends_LCL_CustomDrawn,
1130	{$ENDIF}
1131	{$ELSE}
1132	Clipbrd, GR32_Backends_VCL,
1133	{$ENDIF}
1134	GR32_VectorUtils;
1135
1136	type
1137	{ We can not use the Win32 defined record here since we are cross-platform. }
1138	TBmpHeader = packed record
1139	bfType: Word;
1140	bfSize: LongInt;
1141	bfReserved: LongInt;
1142	bfOffBits: LongInt;
1143	biSize: LongInt;
1144	biWidth: LongInt;
1145	biHeight: LongInt;
1146	biPlanes: Word;
1147	biBitCount: Word;
1148	biCompression: LongInt;
1149	biSizeImage: LongInt;
1150	biXPelsPerMeter: LongInt;
1151	biYPelsPerMeter: LongInt;
1152	biClrUsed: LongInt;
1153	biClrImportant: LongInt;
1154	end;
1155
1156	TGraphicAccess = class(TGraphic);
1157
1158	const
1159	ZERO_RECT: TRect = (Left: 0; Top: 0; Right: 0; Bottom: 0);
1160
1161	{ Color construction and conversion functions }
1162
1163	{$IFDEF PUREPASCAL}
1164	{$DEFINE USENATIVECODE}
1165	{$ENDIF}
1166	{$IFDEF TARGET_X64}
1167	{$DEFINE USENATIVECODE}
1168	{$ENDIF}
1169
1170	function Color32(WinColor: TColor): TColor32; overload;
1171	{$IFDEF WIN_COLOR_FIX}
1172	var
1173	I: Longword;
1174	{$ENDIF}
1175	begin
1176	if WinColor < 0 then WinColor := GetSysColor(WinColor and $000000FF);
1177
1178	{$IFDEF WIN_COLOR_FIX}
1179	Result := $FF000000;
1180	I := (WinColor and $00FF0000) shr 16;
1181	if I <> 0 then Result := Result or TColor32(Integer(I) - 1);
1182	I := WinColor and $0000FF00;
1183	if I <> 0 then Result := Result or TColor32(Integer(I) - $00000100);
1184	I := WinColor and $000000FF;
1185	if I <> 0 then Result := Result or TColor32(Integer(I) - 1) shl 16;
1186	{$ELSE}
1187	{$IFDEF USENATIVECODE}
1188	Result := $FF shl 24 + (WinColor and $FF0000) shr 16 + (WinColor and $FF00) +
1189	(WinColor and $FF) shl 16;
1190	{$ELSE}
1191	asm
1192	MOV EAX,WinColor
1193	BSWAP EAX
1194	MOV AL,$FF
1195	ROR EAX,8
1196	MOV Result,EAX
1197	end;
1198	{$ENDIF}
1199	{$ENDIF}
1200	end;
1201
1202	function Color32(R, G, B: Byte; A: Byte = $FF): TColor32; overload;
1203	{$IFDEF USENATIVECODE}
1204	begin
1205	Result := (A shl 24) or (R shl 16) or (G shl 8) or B;
1206	{$ELSE}
1207	asm
1208	MOV AH, A
1209	SHL EAX, 16
1210	MOV AH, DL
1211	MOV AL, CL
1212	{$ENDIF}
1213	end;
1214
1215	function Color32(Index: Byte; var Palette: TPalette32): TColor32; overload;
1216	begin
1217	Result := Palette[Index];
1218	end;
1219
1220	function Gray32(Intensity: Byte; Alpha: Byte = $FF): TColor32;
1221	begin
1222	Result := TColor32(Alpha) shl 24 + TColor32(Intensity) shl 16 +
1223	TColor32(Intensity) shl 8 + TColor32(Intensity);
1224	end;
1225
1226	function WinColor(Color32: TColor32): TColor;
1227	{$IFDEF PUREPASCAL}
1228	begin
1229	Result := ((Color32 and $00FF0000) shr 16) or
1230	(Color32 and $0000FF00) or
1231	((Color32 and $000000FF) shl 16);
1232	{$ELSE}
1233	asm
1234	{$IFDEF TARGET_x64}
1235	MOV EAX, ECX
1236	{$ENDIF}
1237	// the alpha channel byte is set to zero!
1238	ROL EAX, 8 // ABGR -> RGBA
1239	XOR AL, AL // BGRA -> BGR0
1240	BSWAP EAX // BGR0 -> 0RGB
1241	{$ENDIF}
1242	end;
1243
1244	function ArrayOfColor32(Colors: array of TColor32): TArrayOfColor32;
1245	var
1246	L: Integer;
1247	begin
1248	// build a dynamic color array from specified colors
1249	L := High(Colors) + 1;
1250	SetLength(Result, L);
1251	MoveLongword(Colors[0], Result[0], L);
1252	end;
1253
1254	procedure Color32ToRGB(Color32: TColor32; var R, G, B: Byte);
1255	begin
1256	R := (Color32 and $00FF0000) shr 16;
1257	G := (Color32 and $0000FF00) shr 8;
1258	B := Color32 and $000000FF;
1259	end;
1260
1261	procedure Color32ToRGBA(Color32: TColor32; var R, G, B, A: Byte);
1262	begin
1263	A := Color32 shr 24;
1264	R := (Color32 and $00FF0000) shr 16;
1265	G := (Color32 and $0000FF00) shr 8;
1266	B := Color32 and $000000FF;
1267	end;
1268
1269	function Color32Components(R, G, B, A: Boolean): TColor32Components;
1270	const
1271	ccR : array[Boolean] of TColor32Components = ([], [ccRed]);
1272	ccG : array[Boolean] of TColor32Components = ([], [ccGreen]);
1273	ccB : array[Boolean] of TColor32Components = ([], [ccBlue]);
1274	ccA : array[Boolean] of TColor32Components = ([], [ccAlpha]);
1275	begin
1276	Result := ccR[R] + ccG[G] + ccB[B] + ccA[A];
1277	end;
1278
1279	function RedComponent(Color32: TColor32): Integer;
1280	begin
1281	Result := (Color32 and $00FF0000) shr 16;
1282	end;
1283
1284	function GreenComponent(Color32: TColor32): Integer;
1285	begin
1286	Result := (Color32 and $0000FF00) shr 8;
1287	end;
1288
1289	function BlueComponent(Color32: TColor32): Integer;
1290	begin
1291	Result := Color32 and $000000FF;
1292	end;
1293
1294	function AlphaComponent(Color32: TColor32): Integer;
1295	begin
1296	Result := Color32 shr 24;
1297	end;
1298
1299	function Intensity(Color32: TColor32): Integer;
1300	begin
1301	// (R * 61 + G * 174 + B * 21) / 256
1302	Result := (
1303	(Color32 and $00FF0000) shr 16 * 61 +
1304	(Color32 and $0000FF00) shr 8 * 174 +
1305	(Color32 and $000000FF) * 21
1306	) shr 8;
1307	end;
1308
1309	function InvertColor(Color32: TColor32): TColor32;
1310	begin
1311	TColor32Entry(Result).R := $FF - TColor32Entry(Color32).R;
1312	TColor32Entry(Result).G := $FF - TColor32Entry(Color32).G;
1313	TColor32Entry(Result).B := $FF - TColor32Entry(Color32).B;
1314	TColor32Entry(Result).A := TColor32Entry(Color32).A;
1315	end;
1316
1317	function SetAlpha(Color32: TColor32; NewAlpha: Integer): TColor32;
1318	begin
1319	if NewAlpha < 0 then
1320	NewAlpha := 0
1321	else if NewAlpha > $FF then
1322	NewAlpha := $FF;
1323	Result := (Color32 and $00FFFFFF) or (TColor32(NewAlpha) shl 24);
1324	end;
1325
1326	procedure ModifyAlpha(var Color32: TColor32; NewAlpha: Byte);
1327	begin
1328	TColor32Entry(Color32).A := NewAlpha;
1329	end;
1330
1331	procedure ScaleAlpha(var Color32: TColor32; Scale: Single);
1332	begin
1333	TColor32Entry(Color32).A := Round(Scale * TColor32Entry(Color32).A);
1334	end;
1335
1336	{ Color space conversions }
1337
1338	function HSLtoRGB(H, S, L: Single): TColor32;
1339	const
1340	OneOverThree = 1 / 3;
1341	var
1342	M1, M2: Single;
1343
1344	function HueToColor(Hue: Single): Byte;
1345	var
1346	V: Double;
1347	begin
1348	Hue := Hue - Floor(Hue);
1349	if 6 * Hue < 1 then
1350	V := M1 + (M2 - M1) * Hue * 6
1351	else if 2 * Hue < 1 then
1352	V := M2
1353	else if 3 * Hue < 2 then
1354	V := M1 + (M2 - M1) * (2 * OneOverThree - Hue) * 6
1355	else V := M1;
1356	Result := Round($FF * V);
1357	end;
1358
1359	begin
1360	if S = 0 then
1361	begin
1362	Result := Gray32(Round($FF * L));
1363	Exit;
1364	end;
1365
1366	if L <= 0.5 then
1367	M2 := L * (1 + S)
1368	else
1369	M2 := L + S - L * S;
1370	M1 := 2 * L - M2;
1371	Result := Color32(
1372	HueToColor(H + OneOverThree),
1373	HueToColor(H),
1374	HueToColor(H - OneOverThree));
1375	end;
1376
1377	procedure RGBtoHSL(RGB: TColor32; out H, S, L : Single);
1378	const
1379	// reciprocal mul. opt.
1380	R6 = 1 / 6;
1381
1382	var
1383	R, G, B, D, Cmax, Cmin: Single;
1384	begin
1385	R := RedComponent(RGB) * COne255th;
1386	G := GreenComponent(RGB) * COne255th;
1387	B := BlueComponent(RGB) * COne255th;
1388	Cmax := Max(R, Max(G, B));
1389	Cmin := Min(R, Min(G, B));
1390	L := (Cmax + Cmin) * 0.5;
1391
1392	if Cmax = Cmin then
1393	begin
1394	H := 0;
1395	S := 0
1396	end
1397	else
1398	begin
1399	D := Cmax - Cmin;
1400	if L < 0.5 then
1401	S := D / (Cmax + Cmin)
1402	else
1403	S := D / (2 - Cmax - Cmin);
1404
1405	if R = Cmax then
1406	H := (G - B) / D
1407	else
1408	if G = Cmax then
1409	H := 2 + (B - R) / D
1410	else
1411	H := 4 + (R - G) / D;
1412
1413	H := H * R6;
1414	if H < 0 then H := H + 1
1415	end;
1416	end;
1417
1418	function HSLtoRGB(H, S, L, A: Integer): TColor32;
1419	var
1420	V, M, M1, M2, VSF: Integer;
1421	begin
1422	if L <= $7F then
1423	V := L * (256 + S) shr 8
1424	else
1425	V := L + S - Integer(Div255(L * S));
1426	if V <= 0 then
1427	Result := $FF000000
1428	else
1429	begin
1430	M := L * 2 - V;
1431	H := H * 6;
1432	VSF := (V - M) * (H and $FF) shr 8;
1433	M1 := M + VSF;
1434	M2 := V - VSF;
1435	case H shr 8 of
1436	0: Result := Color32(V, M1, M, A);
1437	1: Result := Color32(M2, V, M, A);
1438	2: Result := Color32(M, V, M1, A);
1439	3: Result := Color32(M, M2, V, A);
1440	4: Result := Color32(M1, M, V, A);
1441	5: Result := Color32(V, M, M2, A);
1442	else
1443	Result := 0;
1444	end;
1445	end;
1446	end;
1447
1448	procedure RGBtoHSL(RGB: TColor32; out H, S, L: Byte);
1449	var
1450	R, G, B, D, Cmax, Cmin, HL: Integer;
1451	begin
1452	R := (RGB shr 16) and $ff;
1453	G := (RGB shr 8) and $ff;
1454	B := RGB and $ff;
1455
1456	Cmax := Max(R, G, B);
1457	Cmin := Min(R, G, B);
1458	L := (Cmax + Cmin) shr 1;
1459
1460	if Cmax = Cmin then
1461	begin
1462	H := 0;
1463	S := 0
1464	end
1465	else
1466	begin
1467	D := (Cmax - Cmin) * $FF;
1468	if L <= $7F then
1469	S := D div (Cmax + Cmin)
1470	else
1471	S := D div ($FF * 2 - Cmax - Cmin);
1472
1473	D := D * 6;
1474	if R = Cmax then
1475	HL := (G - B) * $FF * $FF div D
1476	else if G = Cmax then
1477	HL := $FF * 2 div 6 + (B - R) * $FF * $FF div D
1478	else
1479	HL := $FF * 4 div 6 + (R - G) * $FF * $FF div D;
1480
1481	if HL < 0 then HL := HL + $FF * 2;
1482	H := HL;
1483	end;
1484	end;
1485
1486	function HSVtoRGB(H, S, V: Single): TColor32;
1487	var
1488	Tmp: TFloat;
1489	Sel, Q, P: Integer;
1490	begin
1491	V := 255 * V;
1492	if S = 0 then
1493	begin
1494	Result := Gray32(Trunc(V));
1495	Exit;
1496	end;
1497
1498	H := H - Floor(H);
1499	Tmp := 6 * H - Floor(6 * H);
1500
1501	Sel := Trunc(6 * H);
1502	if (Sel mod 2) = 0 then
1503	Tmp := 1 - Tmp;
1504
1505	Q := Trunc(V * (1 - S));
1506	P := Trunc(V * (1 - S * Tmp));
1507
1508	case Sel of
1509	0:
1510	Result := Color32(Trunc(V), P, Q);
1511	1:
1512	Result := Color32(P, Trunc(V), Q);
1513	2:
1514	Result := Color32(Q, Trunc(V), P);
1515	3:
1516	Result := Color32(Q, P, Trunc(V));
1517	4:
1518	Result := Color32(P, Q, Trunc(V));
1519	5:
1520	Result := Color32(Trunc(V), Q, P);
1521	else
1522	Result := Gray32(0);
1523	end;
1524	end;
1525
1526	procedure RGBToHSV(Color: TColor32; out H, S, V: Single);
1527	var
1528	Delta, Min, Max: Single;
1529	R, G, B: Integer;
1530	const
1531	COneSixth = 1 / 6;
1532	begin
1533	R := RedComponent(Color);
1534	G := GreenComponent(Color);
1535	B := BlueComponent(Color);
1536
1537	Min := MinIntValue([R, G, B]);
1538	Max := MaxIntValue([R, G, B]);
1539	V := Max / 255;
1540
1541	Delta := Max - Min;
1542	if Max = 0 then
1543	S := 0
1544	else
1545	S := Delta / Max;
1546
1547	if S = 0.0 then
1548	H := 0
1549	else
1550	begin
1551	if R = Max then
1552	H := COneSixth * (G - B) / Delta
1553	else if G = Max then
1554	H := COneSixth * (2 + (B - R) / Delta)
1555	else if B = Max then
1556	H := COneSixth * (4 + (R - G) / Delta);
1557
1558	if H < 0.0 then
1559	H := H + 1;
1560	end;
1561	end;
1562
1563	{ Palette conversion }
1564
1565	function WinPalette(const P: TPalette32): HPALETTE;
1566	var
1567	L: TMaxLogPalette;
1568	L0: LOGPALETTE absolute L;
1569	I: Cardinal;
1570	Cl: TColor32;
1571	begin
1572	L.palVersion := $300;
1573	L.palNumEntries := 256;
1574	for I := 0 to $FF do
1575	begin
1576	Cl := P[I];
1577	with L.palPalEntry[I] do
1578	begin
1579	peFlags := 0;
1580	peRed := RedComponent(Cl);
1581	peGreen := GreenComponent(Cl);
1582	peBlue := BlueComponent(Cl);
1583	end;
1584	end;
1585	Result := CreatePalette(l0);
1586	end;
1587
1588
1589	{ Fixed-point conversion routines }
1590
1591	function Fixed(S: Single): TFixed;
1592	begin
1593	Result := Round(S * FixedOne);
1594	end;
1595
1596	function Fixed(I: Integer): TFixed;
1597	begin
1598	Result := I shl 16;
1599	end;
1600
1601
1602	{ Points }
1603
1604	function Point(X, Y: Integer): TPoint;
1605	begin
1606	Result.X := X;
1607	Result.Y := Y;
1608	end;
1609
1610	function Point(const FP: TFloatPoint): TPoint;
1611	begin
1612	Result.X := Round(FP.X);
1613	Result.Y := Round(FP.Y);
1614	end;
1615
1616	function Point(const FXP: TFixedPoint): TPoint;
1617	begin
1618	Result.X := FixedRound(FXP.X);
1619	Result.Y := FixedRound(FXP.Y);
1620	end;
1621
1622	function FloatPoint(X, Y: Single): TFloatPoint;
1623	begin
1624	Result.X := X;
1625	Result.Y := Y;
1626	end;
1627
1628	function FloatPoint(const P: TPoint): TFloatPoint;
1629	begin
1630	Result.X := P.X;
1631	Result.Y := P.Y;
1632	end;
1633
1634	function FloatPoint(const FXP: TFixedPoint): TFloatPoint;
1635	begin
1636	with FXP do
1637	begin
1638	Result.X := X * FixedToFloat;
1639	Result.Y := Y * FixedToFloat;
1640	end;
1641	end;
1642
1643	{$IFDEF SUPPORT_ENHANCED_RECORDS}
1644	{$IFNDEF FPC}
1645	constructor TFloatPoint.Create(P: TPoint);
1646	begin
1647	Self.X := P.X;
1648	Self.Y := P.Y;
1649	end;
1650
1651	{$IFDEF COMPILERXE2_UP}
1652	constructor TFloatPoint.Create(P: TPointF);
1653	begin
1654	Self.X := P.X;
1655	Self.Y := P.Y;
1656	end;
1657	{$ENDIF}
1658
1659	constructor TFloatPoint.Create(X, Y: Integer);
1660	begin
1661	Self.X := X;
1662	Self.Y := Y;
1663	end;
1664
1665	constructor TFloatPoint.Create(X, Y: TFloat);
1666	begin
1667	Self.X := X;
1668	Self.Y := Y;
1669	end;
1670	{$ENDIF}
1671
1672	// operator overloads
1673	class operator TFloatPoint.Equal(const Lhs, Rhs: TFloatPoint): Boolean;
1674	begin
1675	Result := (Lhs.X = Rhs.X) and (Lhs.Y = Rhs.Y);
1676	end;
1677
1678	class operator TFloatPoint.NotEqual(const Lhs, Rhs: TFloatPoint): Boolean;
1679	begin
1680	Result := (Lhs.X <> Rhs.X) or (Lhs.Y <> Rhs.Y);
1681	end;
1682
1683	class operator TFloatPoint.Add(const Lhs, Rhs: TFloatPoint): TFloatPoint;
1684	begin
1685	Result.X := Lhs.X + Rhs.X;
1686	Result.Y := Lhs.Y + Rhs.Y;
1687	end;
1688
1689	class operator TFloatPoint.Subtract(const Lhs, Rhs: TFloatPoint): TFloatPoint;
1690	begin
1691	Result.X := Lhs.X - Rhs.X;
1692	Result.Y := Lhs.Y - Rhs.Y;
1693	end;
1694
1695	{$IFDEF COMPILERXE2_UP}
1696	class operator TFloatPoint.Explicit(A: TPointF): TFloatPoint;
1697	begin
1698	Result.X := A.X;
1699	Result.Y := A.Y;
1700	end;
1701
1702	class operator TFloatPoint.Implicit(A: TPointF): TFloatPoint;
1703	begin
1704	Result.X := A.X;
1705	Result.Y := A.Y;
1706	end;
1707	{$ENDIF}
1708
1709	class function TFloatPoint.Zero: TFloatPoint;
1710	begin
1711	Result.X := 0;
1712	Result.Y := 0;
1713	end;
1714
1715	{$IFNDEF FPC}
1716	{$IFDEF COMPILERXE2_UP}
1717	constructor TFixedPoint.Create(P: TPointF);
1718	begin
1719	Self.X := Fixed(P.X);
1720	Self.Y := Fixed(P.Y);
1721	end;
1722	{$ENDIF}
1723
1724	constructor TFixedPoint.Create(P: TFloatPoint);
1725	begin
1726	Self.X := Fixed(P.X);
1727	Self.Y := Fixed(P.Y);
1728	end;
1729
1730	constructor TFixedPoint.Create(X, Y: TFixed);
1731	begin
1732	Self.X := X;
1733	Self.Y := Y;
1734	end;
1735
1736	constructor TFixedPoint.Create(X, Y: Integer);
1737	begin
1738	Self.X := Fixed(X);
1739	Self.Y := Fixed(Y);
1740	end;
1741
1742	constructor TFixedPoint.Create(X, Y: TFloat);
1743	begin
1744	Self.X := Fixed(X);
1745	Self.Y := Fixed(Y);
1746	end;
1747	{$ENDIF}
1748
1749	// operator overloads
1750	class operator TFixedPoint.Equal(const Lhs, Rhs: TFixedPoint): Boolean;
1751	begin
1752	Result := (Lhs.X = Rhs.X) and (Lhs.Y = Rhs.Y);
1753	end;
1754
1755	class operator TFixedPoint.NotEqual(const Lhs, Rhs: TFixedPoint): Boolean;
1756	begin
1757	Result := (Lhs.X <> Rhs.X) or (Lhs.Y <> Rhs.Y);
1758	end;
1759
1760	class operator TFixedPoint.Add(const Lhs, Rhs: TFixedPoint): TFixedPoint;
1761	begin
1762	Result.X := Lhs.X + Rhs.X;
1763	Result.Y := Lhs.Y + Rhs.Y;
1764	end;
1765
1766	class operator TFixedPoint.Subtract(const Lhs, Rhs: TFixedPoint): TFixedPoint;
1767	begin
1768	Result.X := Lhs.X - Rhs.X;
1769	Result.Y := Lhs.Y - Rhs.Y;
1770	end;
1771
1772	class function TFixedPoint.Zero: TFixedPoint;
1773	begin
1774	Result.X := 0;
1775	Result.Y := 0;
1776	end;
1777	{$ENDIF}
1778
1779	function FixedPoint(X, Y: Integer): TFixedPoint; overload;
1780	begin
1781	Result.X := X shl 16;
1782	Result.Y := Y shl 16;
1783	end;
1784
1785	function FixedPoint(X, Y: Single): TFixedPoint; overload;
1786	begin
1787	Result.X := Round(X * FixedOne);
1788	Result.Y := Round(Y * FixedOne);
1789	end;
1790
1791	function FixedPoint(const P: TPoint): TFixedPoint; overload;
1792	begin
1793	Result.X := P.X shl 16;
1794	Result.Y := P.Y shl 16;
1795	end;
1796
1797	function FixedPoint(const FP: TFloatPoint): TFixedPoint; overload;
1798	begin
1799	Result.X := Round(FP.X * FixedOne);
1800	Result.Y := Round(FP.Y * FixedOne);
1801	end;
1802
1803
1804	{ Rectangles }
1805
1806	function MakeRect(const L, T, R, B: Integer): TRect;
1807	begin
1808	with Result do
1809	begin
1810	Left := L;
1811	Top := T;
1812	Right := R;
1813	Bottom := B;
1814	end;
1815	end;
1816
1817	function MakeRect(const FR: TFloatRect; Rounding: TRectRounding): TRect;
1818	begin
1819	with FR do
1820	case Rounding of
1821	rrClosest:
1822	begin
1823	Result.Left := Round(Left);
1824	Result.Top := Round(Top);
1825	Result.Right := Round(Right);
1826	Result.Bottom := Round(Bottom);
1827	end;
1828
1829	rrInside:
1830	begin
1831	Result.Left := Ceil(Left);
1832	Result.Top := Ceil(Top);
1833	Result.Right := Floor(Right);
1834	Result.Bottom := Floor(Bottom);
1835	if Result.Right < Result.Left then Result.Right := Result.Left;
1836	if Result.Bottom < Result.Top then Result.Bottom := Result.Top;
1837	end;
1838
1839	rrOutside:
1840	begin
1841	Result.Left := Floor(Left);
1842	Result.Top := Floor(Top);
1843	Result.Right := Ceil(Right);
1844	Result.Bottom := Ceil(Bottom);
1845	end;
1846	end;
1847	end;
1848
1849	function MakeRect(const FXR: TFixedRect; Rounding: TRectRounding): TRect;
1850	begin
1851	with FXR do
1852	case Rounding of
1853	rrClosest:
1854	begin
1855	Result.Left := FixedRound(Left);
1856	Result.Top := FixedRound(Top);
1857	Result.Right := FixedRound(Right);
1858	Result.Bottom := FixedRound(Bottom);
1859	end;
1860
1861	rrInside:
1862	begin
1863	Result.Left := FixedCeil(Left);
1864	Result.Top := FixedCeil(Top);
1865	Result.Right := FixedFloor(Right);
1866	Result.Bottom := FixedFloor(Bottom);
1867	if Result.Right < Result.Left then Result.Right := Result.Left;
1868	if Result.Bottom < Result.Top then Result.Bottom := Result.Top;
1869	end;
1870
1871	rrOutside:
1872	begin
1873	Result.Left := FixedFloor(Left);
1874	Result.Top := FixedFloor(Top);
1875	Result.Right := FixedCeil(Right);
1876	Result.Bottom := FixedCeil(Bottom);
1877	end;
1878	end;
1879	end;
1880
1881	function FixedRect(const L, T, R, B: TFixed): TFixedRect;
1882	begin
1883	with Result do
1884	begin
1885	Left := L;
1886	Top := T;
1887	Right := R;
1888	Bottom := B;
1889	end;
1890	end;
1891
1892	function FixedRect(const TopLeft, BottomRight: TFixedPoint): TFixedRect;
1893	begin
1894	Result.TopLeft := TopLeft;
1895	Result.BottomRight := BottomRight;
1896	end;
1897
1898	function FixedRect(const ARect: TRect): TFixedRect;
1899	begin
1900	with Result do
1901	begin
1902	Left := ARect.Left shl 16;
1903	Top := ARect.Top shl 16;
1904	Right := ARect.Right shl 16;
1905	Bottom := ARect.Bottom shl 16;
1906	end;
1907	end;
1908
1909	function FixedRect(const FR: TFloatRect): TFixedRect;
1910	begin
1911	with Result do
1912	begin
1913	Left := Round(FR.Left * 65536);
1914	Top := Round(FR.Top * 65536);
1915	Right := Round(FR.Right * 65536);
1916	Bottom := Round(FR.Bottom * 65536);
1917	end;
1918	end;
1919
1920	function FloatRect(const L, T, R, B: TFloat): TFloatRect;
1921	begin
1922	with Result do
1923	begin
1924	Left := L;
1925	Top := T;
1926	Right := R;
1927	Bottom := B;
1928	end;
1929	end;
1930
1931	function FloatRect(const TopLeft, BottomRight: TFloatPoint): TFloatRect;
1932	begin
1933	Result.TopLeft := TopLeft;
1934	Result.BottomRight := BottomRight;
1935	end;
1936
1937	function FloatRect(const ARect: TRect): TFloatRect;
1938	begin
1939	with Result do
1940	begin
1941	Left := ARect.Left;
1942	Top := ARect.Top;
1943	Right := ARect.Right;
1944	Bottom := ARect.Bottom;
1945	end;
1946	end;
1947
1948	function FloatRect(const FXR: TFixedRect): TFloatRect;
1949	begin
1950	with Result do
1951	begin
1952	Left := FXR.Left * FixedToFloat;
1953	Top := FXR.Top * FixedToFloat;
1954	Right := FXR.Right * FixedToFloat;
1955	Bottom := FXR.Bottom * FixedToFloat;
1956	end;
1957	end;
1958
1959	function IntersectRect(out Dst: TRect; const R1, R2: TRect): Boolean;
1960	begin
1961	if R1.Left >= R2.Left then Dst.Left := R1.Left else Dst.Left := R2.Left;
1962	if R1.Right <= R2.Right then Dst.Right := R1.Right else Dst.Right := R2.Right;
1963	if R1.Top >= R2.Top then Dst.Top := R1.Top else Dst.Top := R2.Top;
1964	if R1.Bottom <= R2.Bottom then Dst.Bottom := R1.Bottom else Dst.Bottom := R2.Bottom;
1965	Result := (Dst.Right >= Dst.Left) and (Dst.Bottom >= Dst.Top);
1966	if not Result then Dst := ZERO_RECT;
1967	end;
1968
1969	function IntersectRect(out Dst: TFloatRect; const FR1, FR2: TFloatRect): Boolean;
1970	begin
1971	Dst.Left := Math.Max(FR1.Left, FR2.Left);
1972	Dst.Right := Math.Min(FR1.Right, FR2.Right);
1973	Dst.Top := Math.Max(FR1.Top, FR2.Top);
1974	Dst.Bottom := Math.Min(FR1.Bottom, FR2.Bottom);
1975	Result := (Dst.Right >= Dst.Left) and (Dst.Bottom >= Dst.Top);
1976	if not Result then FillLongword(Dst, 4, 0);
1977	end;
1978
1979	function UnionRect(out Rect: TRect; const R1, R2: TRect): Boolean;
1980	begin
1981	Rect := R1;
1982	if not IsRectEmpty(R2) then
1983	begin
1984	if R2.Left < R1.Left then Rect.Left := R2.Left;
1985	if R2.Top < R1.Top then Rect.Top := R2.Top;
1986	if R2.Right > R1.Right then Rect.Right := R2.Right;
1987	if R2.Bottom > R1.Bottom then Rect.Bottom := R2.Bottom;
1988	end;
1989	Result := not IsRectEmpty(Rect);
1990	if not Result then Rect := ZERO_RECT;
1991	end;
1992
1993	function UnionRect(out Rect: TFloatRect; const R1, R2: TFloatRect): Boolean;
1994	begin
1995	Rect := R1;
1996	if not IsRectEmpty(R2) then
1997	begin
1998	if R2.Left < R1.Left then Rect.Left := R2.Left;
1999	if R2.Top < R1.Top then Rect.Top := R2.Top;
2000	if R2.Right > R1.Right then Rect.Right := R2.Right;
2001	if R2.Bottom > R1.Bottom then Rect.Bottom := R2.Bottom;
2002	end;
2003	Result := not IsRectEmpty(Rect);
2004	if not Result then FillLongword(Rect, 4, 0);
2005	end;
2006
2007	function EqualRect(const R1, R2: TRect): Boolean;
2008	begin
2009	Result := CompareMem(@R1, @R2, SizeOf(TRect));
2010	end;
2011
2012	function EqualRect(const R1, R2: TFloatRect): Boolean;
2013	begin
2014	Result := CompareMem(@R1, @R2, SizeOf(TFloatRect));
2015	end;
2016
2017	function EqualRectSize(const R1, R2: TRect): Boolean;
2018	begin
2019	Result := ((R1.Right - R1.Left) = (R2.Right - R2.Left)) and
2020	((R1.Bottom - R1.Top) = (R2.Bottom - R2.Top));
2021	end;
2022
2023	function EqualRectSize(const R1, R2: TFloatRect): Boolean;
2024	var
2025	_R1: TFixedRect;
2026	_R2: TFixedRect;
2027	begin
2028	_R1 := FixedRect(R1);
2029	_R2 := FixedRect(R2);
2030	Result := ((_R1.Right - _R1.Left) = (_R2.Right - _R2.Left)) and
2031	((_R1.Bottom - _R1.Top) = (_R2.Bottom - _R2.Top));
2032	end;
2033
2034	procedure InflateRect(var R: TRect; Dx, Dy: Integer);
2035	begin
2036	Dec(R.Left, Dx); Dec(R.Top, Dy);
2037	Inc(R.Right, Dx); Inc(R.Bottom, Dy);
2038	end;
2039
2040	procedure InflateRect(var FR: TFloatRect; Dx, Dy: TFloat);
2041	begin
2042	with FR do
2043	begin
2044	Left := Left - Dx; Top := Top - Dy;
2045	Right := Right + Dx; Bottom := Bottom + Dy;
2046	end;
2047	end;
2048
2049	procedure OffsetRect(var R: TRect; Dx, Dy: Integer);
2050	begin
2051	Inc(R.Left, Dx); Inc(R.Top, Dy);
2052	Inc(R.Right, Dx); Inc(R.Bottom, Dy);
2053	end;
2054
2055	procedure OffsetRect(var FR: TFloatRect; Dx, Dy: TFloat);
2056	begin
2057	with FR do
2058	begin
2059	Left := Left + Dx; Top := Top + Dy;
2060	Right := Right + Dx; Bottom := Bottom + Dy;
2061	end;
2062	end;
2063
2064	function IsRectEmpty(const R: TRect): Boolean;
2065	begin
2066	Result := (R.Right <= R.Left) or (R.Bottom <= R.Top);
2067	end;
2068
2069	function IsRectEmpty(const FR: TFloatRect): Boolean;
2070	begin
2071	Result := (FR.Right <= FR.Left) or (FR.Bottom <= FR.Top);
2072	end;
2073
2074	function PtInRect(const R: TRect; const P: TPoint): Boolean;
2075	begin
2076	Result := (P.X >= R.Left) and (P.X < R.Right) and
2077	(P.Y >= R.Top) and (P.Y < R.Bottom);
2078	end;
2079
2080	function PtInRect(const R: TFloatRect; const P: TPoint): Boolean;
2081	begin
2082	Result := (P.X >= R.Left) and (P.X < R.Right) and
2083	(P.Y >= R.Top) and (P.Y < R.Bottom);
2084	end;
2085
2086	function PtInRect(const R: TRect; const P: TFloatPoint): Boolean;
2087	begin
2088	Result := (P.X >= R.Left) and (P.X < R.Right) and
2089	(P.Y >= R.Top) and (P.Y < R.Bottom);
2090	end;
2091
2092	function PtInRect(const R: TFloatRect; const P: TFloatPoint): Boolean;
2093	begin
2094	Result := (P.X >= R.Left) and (P.X < R.Right) and
2095	(P.Y >= R.Top) and (P.Y < R.Bottom);
2096	end;
2097
2098	{ TSimpleInterfacedPersistent }
2099
2100	function TPlainInterfacedPersistent._AddRef: Integer;
2101	begin
2102	if FRefCounted then
2103	Result := InterlockedIncrement(FRefCount)
2104	else
2105	Result := -1;
2106	end;
2107
2108	function TPlainInterfacedPersistent._Release: Integer;
2109	begin
2110	if FRefCounted then
2111	begin
2112	Result := InterlockedDecrement(FRefCount);
2113	if Result = 0 then
2114	Destroy;
2115	end
2116	else
2117	Result := -1;
2118	end;
2119
2120	function TPlainInterfacedPersistent.QueryInterface(
2121	{$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF}IID: TGUID; out Obj): HResult;
2122	const
2123	E_NOINTERFACE = HResult($80004002);
2124	begin
2125	if GetInterface(IID, Obj) then
2126	Result := 0
2127	else
2128	Result := E_NOINTERFACE;
2129	end;
2130
2131	procedure TPlainInterfacedPersistent.AfterConstruction;
2132	begin
2133	inherited;
2134
2135	// Release the constructor's implicit refcount
2136	InterlockedDecrement(FRefCount);
2137	end;
2138
2139	procedure TPlainInterfacedPersistent.BeforeDestruction;
2140	begin
2141	if RefCounted and (RefCount <> 0) then
2142	raise Exception.Create(RCStrUnmatchedReferenceCounting);
2143
2144	inherited;
2145	end;
2146
2147	class function TPlainInterfacedPersistent.NewInstance: TObject;
2148	begin
2149	Result := inherited NewInstance;
2150
2151	// Set an implicit refcount so that refcounting
2152	// during construction won't destroy the object.
2153	TPlainInterfacedPersistent(Result).FRefCount := 1;
2154	end;
2155
2156
2157	{ TNotifiablePersistent }
2158
2159	procedure TNotifiablePersistent.BeginUpdate;
2160	begin
2161	Inc(FUpdateCount);
2162	end;
2163
2164	procedure TNotifiablePersistent.Changed;
2165	begin
2166	if (FUpdateCount = 0) and Assigned(FOnChange) then FOnChange(Self);
2167	end;
2168
2169	procedure TNotifiablePersistent.EndUpdate;
2170	begin
2171	Assert(FUpdateCount > 0, 'Unpaired TThreadPersistent.EndUpdate');
2172	Dec(FUpdateCount);
2173	end;
2174
2175
2176	{ TThreadPersistent }
2177
2178	constructor TThreadPersistent.Create;
2179	begin
2180	InitializeCriticalSection(FLock);
2181	end;
2182
2183	destructor TThreadPersistent.Destroy;
2184	begin
2185	DeleteCriticalSection(FLock);
2186	inherited;
2187	end;
2188
2189	procedure TThreadPersistent.Lock;
2190	begin
2191	InterlockedIncrement(FLockCount);
2192	EnterCriticalSection(FLock);
2193	end;
2194
2195	procedure TThreadPersistent.Unlock;
2196	begin
2197	LeaveCriticalSection(FLock);
2198	InterlockedDecrement(FLockCount);
2199	end;
2200
2201
2202	{ TCustomMap }
2203
2204	constructor TCustomMap.Create(Width, Height: Integer);
2205	begin
2206	Create;
2207	SetSize(Width, Height);
2208	end;
2209
2210	procedure TCustomMap.ChangeSize(var Width, Height: Integer; NewWidth, NewHeight: Integer);
2211	begin
2212	Width := NewWidth;
2213	Height := NewHeight;
2214	end;
2215
2216	procedure TCustomMap.Delete;
2217	begin
2218	SetSize(0, 0);
2219	end;
2220
2221	function TCustomMap.Empty: Boolean;
2222	begin
2223	Result := (Width = 0) or (Height = 0);
2224	end;
2225
2226	procedure TCustomMap.Resized;
2227	begin
2228	if Assigned(FOnResize) then FOnResize(Self);
2229	end;
2230
2231	procedure TCustomMap.SetHeight(NewHeight: Integer);
2232	begin
2233	SetSize(Width, NewHeight);
2234	end;
2235
2236	function TCustomMap.SetSize(NewWidth, NewHeight: Integer): Boolean;
2237	begin
2238	if NewWidth < 0 then NewWidth := 0;
2239	if NewHeight < 0 then NewHeight := 0;
2240	Result := (NewWidth <> FWidth) or (NewHeight <> FHeight);
2241	if Result then
2242	begin
2243	ChangeSize(FWidth, FHeight, NewWidth, NewHeight);
2244	Changed;
2245	Resized;
2246	end;
2247	end;
2248
2249	function TCustomMap.SetSizeFrom(Source: TPersistent): Boolean;
2250	begin
2251	if Source is TCustomMap then
2252	Result := SetSize(TCustomMap(Source).Width, TCustomMap(Source).Height)
2253	else if Source is TGraphic then
2254	Result := SetSize(TGraphic(Source).Width, TGraphic(Source).Height)
2255	else if Source is TControl then
2256	Result := SetSize(TControl(Source).Width, TControl(Source).Height)
2257	else if Source = nil then
2258	Result := SetSize(0, 0)
2259	else
2260	raise Exception.CreateFmt(RCStrCannotSetSize, [Source.ClassName]);
2261	end;
2262
2263	procedure TCustomMap.SetWidth(NewWidth: Integer);
2264	begin
2265	SetSize(NewWidth, Height);
2266	end;
2267
2268
2269	{ TCustomBitmap32 }
2270
2271	constructor TCustomBitmap32.Create(Backend: TCustomBackendClass);
2272	begin
2273	inherited Create;
2274
2275	InitializeBackend(Backend);
2276
2277	FOuterColor := $00000000; // by default as full transparency black
2278
2279	FMasterAlpha := $FF;
2280	FPenColor := clWhite32;
2281	FStippleStep := 1;
2282	FCombineMode := cmBlend;
2283	BlendProc := @BLEND_MEM[FCombineMode]^;
2284	WrapProcHorz := GetWrapProcEx(WrapMode);
2285	WrapProcVert := GetWrapProcEx(WrapMode);
2286	FResampler := TNearestResampler.Create(Self);
2287	end;
2288
2289	constructor TCustomBitmap32.Create;
2290	begin
2291	Create(GetPlatformBackendClass);
2292	end;
2293
2294	destructor TCustomBitmap32.Destroy;
2295	begin
2296	BeginUpdate;
2297	Lock;
2298	try
2299	SetSize(0, 0);
2300	FResampler.Free;
2301	FinalizeBackend;
2302	finally
2303	Unlock;
2304	end;
2305	inherited;
2306	end;
2307
2308	procedure TCustomBitmap32.InitializeBackend(Backend: TCustomBackendClass);
2309	begin
2310	Backend.Create(Self);
2311	end;
2312
2313	procedure TCustomBitmap32.FinalizeBackend;
2314	begin
2315	// Drop ownership of backend now:
2316	// It's a zombie now.
2317	FBackend.FOwner := nil;
2318	FBackend.OnChange := nil;
2319	FBackend.OnChanging := nil;
2320
2321	(*
2322	Release our reference to the backend
2323
2324	Note: The backend won't necessarily be freed immediately.
2325
2326	This is required to circumvent a problem with the magic procedure cleanup
2327	of interfaces that have ref-counting forcefully disabled:
2328
2329	Quality Central report #9157 and #9500:
2330	http://qc.codegear.com/wc/qcmain.aspx?d=9157
2331	http://qc.codegear.com/wc/qcmain.aspx?d=9500
2332
2333	if any backend interface is used within the same procedure in which
2334	the owner bitmap is also freed, the magic procedure cleanup will
2335	clear that particular interface long after the bitmap and its backend
2336	are gone. This will result in all sorts of madness - mostly heap corruption
2337	and AVs.
2338
2339	Here is an example:
2340
2341	procedure Test;
2342	var
2343	MyBitmap: TBitmap32;
2344	begin
2345	MyBitmap := TBitmap32.Create;
2346	MyBitmap.SetSize(100, 100);
2347	(MyBitmap.Backend as ICanvasSupport).Canvas;
2348	MyBitmap.Free;
2349	end; // _IntfClear will try to clear (MyBitmap.Backend as ICanvasSupport)
2350	// which points to the interface at the previous location of MyBitmap.Backend in memory.
2351	// MyBitmap.Backend is gone and the _Release call is invalid, so raise hell .
2352
2353	Here is an example for a correct workaround:
2354
2355	procedure Test;
2356	var
2357	MyBitmap: TBitmap32;
2358	CanvasIntf: ICanvasSupport;
2359	begin
2360	MyBitmap := TBitmap32.Create;
2361	MyBitmap.SetSize(100, 100);
2362	CanvasIntf := MyBitmap.Backend as ICanvasSupport;
2363	CanvasIntf.Canvas;
2364	CanvasIntf := nil; // this will call _IntfClear and IInterface._Release
2365	MyBitmap.Free;
2366	end; // _IntfClear will try to clear CanvasIntf,
2367	// it's nil, no _Release is called, everything is fine.
2368
2369	Since the above code is pretty fiddly, we introduce ref-counting for the
2370	backend. That way the backend will be released once all references are dropped.
2371
2372	So, release our reference to the backend now:
2373	*)
2374	FBackend._Release;
2375	FBackend := nil;
2376	end;
2377
2378	procedure TCustomBitmap32.SetBackend(const Backend: TCustomBackend);
2379	begin
2380	if Assigned(Backend) and (Backend <> FBackend) then
2381	begin
2382	BeginUpdate;
2383
2384	Backend.FOwner := Self;
2385
2386	if Assigned(FBackend) then
2387	begin
2388	Backend.Assign(FBackend);
2389	FinalizeBackend;
2390	end;
2391
2392	FBackend := Backend;
2393	FBackend.OnChange := BackendChangedHandler;
2394	FBackend.OnChanging := BackendChangingHandler;
2395
2396	EndUpdate;
2397
2398	FBackend.Changed;
2399	Changed;
2400	end;
2401	end;
2402
2403	function TCustomBitmap32.ReleaseBackend: TCustomBackend;
2404	begin
2405	FBackend._AddRef; // Increase ref-count for external use
2406	Result := FBackend;
2407	end;
2408
2409	function TCustomBitmap32.QueryInterface({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} IID: TGUID; out Obj): HResult;
2410	begin
2411	Result := FBackend.QueryInterface(IID, Obj);
2412	if Result <> S_OK then
2413	Result := inherited QueryInterface(IID, Obj);
2414	end;
2415
2416	procedure TCustomBitmap32.ChangeSize(var Width, Height: Integer; NewWidth, NewHeight: Integer);
2417	begin
2418	FBackend.ChangeSize(Width, Height, NewWidth, NewHeight);
2419	end;
2420
2421	procedure TCustomBitmap32.BackendChangingHandler(Sender: TObject);
2422	begin
2423	// descendants can override this method.
2424	end;
2425
2426	procedure TCustomBitmap32.BackendChangedHandler(Sender: TObject);
2427	begin
2428	FBits := FBackend.Bits;
2429	ResetClipRect;
2430	end;
2431
2432	function TCustomBitmap32.Empty: Boolean;
2433	begin
2434	Result := FBackend.Empty or inherited Empty;
2435	end;
2436
2437	procedure TCustomBitmap32.Clear;
2438	begin
2439	Clear(clBlack32);
2440	end;
2441
2442	procedure TCustomBitmap32.Clear(FillColor: TColor32);
2443	begin
2444	if Empty then Exit;
2445	if not MeasuringMode then
2446	if Clipping then
2447	FillRect(FClipRect.Left, FClipRect.Top, FClipRect.Right, FClipRect.Bottom, FillColor)
2448	else
2449	FillLongword(Bits[0], Width * Height, FillColor);
2450	Changed;
2451	end;
2452
2453	procedure TCustomBitmap32.Delete;
2454	begin
2455	SetSize(0, 0);
2456	end;
2457
2458	procedure TCustomBitmap32.AssignTo(Dst: TPersistent);
2459
2460	procedure AssignToBitmap(Bmp: TBitmap; SrcBitmap: TCustomBitmap32);
2461	var
2462	SavedBackend: TCustomBackend;
2463	begin
2464	RequireBackendSupport(SrcBitmap, [IDeviceContextSupport], romOr, False, SavedBackend);
2465	try
2466	Bmp.HandleType := bmDIB;
2467	Bmp.PixelFormat := pf32Bit;
2468
2469	{$IFDEF COMPILER2009_UP}
2470	Bmp.SetSize(SrcBitmap.Width, SrcBitmap.Height);
2471	{$ELSE}
2472	Bmp.Width := SrcBitmap.Width;
2473	Bmp.Height := SrcBitmap.Height;
2474	{$ENDIF}
2475
2476	if Supports(SrcBitmap.Backend, IFontSupport) then // this is optional
2477	Bmp.Canvas.Font.Assign((SrcBitmap.Backend as IFontSupport).Font);
2478
2479	if SrcBitmap.Empty then Exit;
2480
2481	Bmp.Canvas.Lock;
2482	try
2483	(SrcBitmap.Backend as IDeviceContextSupport).DrawTo(Bmp.Canvas.Handle,
2484	BoundsRect, BoundsRect)
2485	finally
2486	Bmp.Canvas.UnLock;
2487	end;
2488	finally
2489	RestoreBackend(SrcBitmap, SavedBackend);
2490	end;
2491	end;
2492
2493	var
2494	Bmp: TBitmap;
2495	begin
2496	if Dst is TPicture then
2497	AssignToBitmap(TPicture(Dst).Bitmap, Self)
2498	else if Dst is TBitmap then
2499	AssignToBitmap(TBitmap(Dst), Self)
2500	else if Dst is TClipboard then
2501	begin
2502	Bmp := TBitmap.Create;
2503	try
2504	AssignToBitmap(Bmp, Self);
2505	TClipboard(Dst).Assign(Bmp);
2506	finally
2507	Bmp.Free;
2508	end;
2509	end
2510	else
2511	inherited;
2512	end;
2513
2514	procedure TCustomBitmap32.Assign(Source: TPersistent);
2515
2516	procedure AssignFromGraphicPlain(TargetBitmap: TCustomBitmap32;
2517	SrcGraphic: TGraphic; FillColor: TColor32; ResetAlphaAfterDrawing: Boolean);
2518	var
2519	SavedBackend: TCustomBackend;
2520	Canvas: TCanvas;
2521	begin
2522	if not Assigned(SrcGraphic) then
2523	Exit;
2524	RequireBackendSupport(TargetBitmap, [IDeviceContextSupport, ICanvasSupport], romOr, True, SavedBackend);
2525	try
2526	TargetBitmap.SetSize(SrcGraphic.Width, SrcGraphic.Height);
2527	if TargetBitmap.Empty then Exit;
2528
2529	TargetBitmap.Clear(FillColor);
2530
2531	if Supports(TargetBitmap.Backend, IDeviceContextSupport) then
2532	begin
2533	Canvas := TCanvas.Create;
2534	try
2535	Canvas.Lock;
2536	try
2537	Canvas.Handle := (TargetBitmap.Backend as IDeviceContextSupport).Handle;
2538	TGraphicAccess(SrcGraphic).Draw(Canvas,
2539	MakeRect(0, 0, TargetBitmap.Width, TargetBitmap.Height));
2540	finally
2541	Canvas.Unlock;
2542	end;
2543	finally
2544	Canvas.Free;
2545	end;
2546	end else
2547	if Supports(TargetBitmap.Backend, ICanvasSupport) then
2548	TGraphicAccess(SrcGraphic).Draw((TargetBitmap.Backend as ICanvasSupport).Canvas,
2549	MakeRect(0, 0, TargetBitmap.Width, TargetBitmap.Height))
2550	else raise Exception.Create(RCStrInpropriateBackend);
2551
2552	if ResetAlphaAfterDrawing then
2553	ResetAlpha;
2554	finally
2555	RestoreBackend(TargetBitmap, SavedBackend);
2556	end;
2557	end;
2558
2559	procedure AssignFromGraphicMasked(TargetBitmap: TCustomBitmap32; SrcGraphic: TGraphic);
2560	var
2561	TempBitmap: TCustomBitmap32;
2562	I: integer;
2563	DstP, SrcP: PColor32;
2564	DstColor: TColor32;
2565	begin
2566	AssignFromGraphicPlain(TargetBitmap, SrcGraphic, clWhite32, False); // mask on white
2567	if TargetBitmap.Empty then
2568	begin
2569	TargetBitmap.Clear;
2570	Exit;
2571	end;
2572
2573	TempBitmap := TCustomBitmap32.Create;
2574	try
2575	AssignFromGraphicPlain(TempBitmap, SrcGraphic, clRed32, False); // mask on red
2576
2577	DstP := @TargetBitmap.Bits[0];
2578	SrcP := @TempBitmap.Bits[0];
2579	for I := 0 to TargetBitmap.Width * TargetBitmap.Height - 1 do
2580	begin
2581	DstColor := DstP^ and $00FFFFFF;
2582	// this checks for transparency by comparing the pixel-color of the
2583	// temporary bitmap (red masked) with the pixel of our
2584	// bitmap (white masked). if they match, make that pixel opaque
2585	if DstColor = (SrcP^ and $00FFFFFF) then
2586	DstP^ := DstColor or $FF000000
2587	else
2588	// if the colors do not match (that is the case if there is a
2589	// match "is clRed32 = clWhite32 ?"), just make that pixel
2590	// transparent:
2591	DstP^ := DstColor;
2592
2593	Inc(SrcP); Inc(DstP);
2594	end;
2595	finally
2596	TempBitmap.Free;
2597	end;
2598	end;
2599
2600	procedure AssignFromBitmap(TargetBitmap: TCustomBitmap32; SrcBmp: TBitmap);
2601	var
2602	TransparentColor: TColor32;
2603	DstP: PColor32;
2604	I: integer;
2605	DstColor: TColor32;
2606	begin
2607	AssignFromGraphicPlain(TargetBitmap, SrcBmp, 0, SrcBmp.PixelFormat <> pf32bit);
2608	if TargetBitmap.Empty then Exit;
2609
2610	if SrcBmp.Transparent then
2611	begin
2612	TransparentColor := Color32(SrcBmp.TransparentColor) and $00FFFFFF;
2613	DstP := @TargetBitmap.Bits[0];
2614	for I := 0 to TargetBitmap.Width * TargetBitmap.Height - 1 do
2615	begin
2616	DstColor := DstP^ and $00FFFFFF;
2617	if DstColor = TransparentColor then
2618	DstP^ := DstColor;
2619	Inc(DstP);
2620	end;
2621	end;
2622
2623	if Supports(TargetBitmap.Backend, IFontSupport) then // this is optional
2624	(TargetBitmap.Backend as IFontSupport).Font.Assign(SrcBmp.Canvas.Font);
2625	end;
2626
2627	procedure AssignFromIcon(TargetBitmap: TCustomBitmap32; SrcIcon: TIcon);
2628	var
2629	I: Integer;
2630	P: PColor32Entry;
2631	ReassignFromMasked: Boolean;
2632	begin
2633	AssignFromGraphicPlain(TargetBitmap, SrcIcon, 0, False);
2634	if TargetBitmap.Empty then Exit;
2635
2636	// Check if the icon was painted with a merged alpha channel.
2637	// That happens transparently for new-style 32-bit icons.
2638	// For all other bit depths GDI will reset our alpha channel to opaque.
2639	ReassignFromMasked := True;
2640	P := PColor32Entry(@TargetBitmap.Bits[0]);
2641	for I := 0 to TargetBitmap.Height * TargetBitmap.Width - 1 do
2642	begin
2643	if P.A > 0 then
2644	begin
2645	ReassignFromMasked := False;
2646	Break;
2647	end;
2648	Inc(P);
2649	end;
2650
2651	// No alpha values found? Use masked approach...
2652	if ReassignFromMasked then
2653	AssignFromGraphicMasked(TargetBitmap, SrcIcon);
2654	end;
2655
2656	procedure AssignFromGraphic(TargetBitmap: TCustomBitmap32; SrcGraphic: TGraphic);
2657	begin
2658	if SrcGraphic is TBitmap then
2659	AssignFromBitmap(TargetBitmap, TBitmap(SrcGraphic))
2660	else if SrcGraphic is TIcon then
2661	AssignFromIcon(TargetBitmap, TIcon(SrcGraphic))
2662	{$IFNDEF PLATFORM_INDEPENDENT}
2663	else if SrcGraphic is TMetaFile then
2664	AssignFromGraphicMasked(TargetBitmap, SrcGraphic)
2665	{$IFDEF COMPILER2005_UP}
2666	else if SrcGraphic is TWICImage then
2667	AssignFromGraphicPlain(TargetBitmap, SrcGraphic, 0, False)
2668	{$ENDIF}
2669	{$ENDIF}
2670	else
2671	AssignFromGraphicPlain(TargetBitmap, SrcGraphic, clWhite32, True);
2672	end;
2673
2674	var
2675	Picture: TPicture;
2676	begin
2677	BeginUpdate;
2678	try
2679	if not Assigned(Source) then
2680	SetSize(0, 0)
2681	else if Source is TCustomBitmap32 then
2682	begin
2683	TCustomBitmap32(Source).CopyMapTo(Self);
2684	TCustomBitmap32(Source).CopyPropertiesTo(Self);
2685	end
2686	else if Source is TGraphic then
2687	AssignFromGraphic(Self, TGraphic(Source))
2688	else if Source is TPicture then
2689	AssignFromGraphic(Self, TPicture(Source).Graphic)
2690	else if Source is TClipboard then
2691	begin
2692	Picture := TPicture.Create;
2693	try
2694	Picture.Assign(TClipboard(Source));
2695	AssignFromGraphic(Self, Picture.Graphic);
2696	finally
2697	Picture.Free;
2698	end;
2699	end
2700	else
2701	inherited; // default handler
2702	finally;
2703	EndUpdate;
2704	Changed;
2705	end;
2706	end;
2707
2708	procedure TCustomBitmap32.CopyMapTo(Dst: TCustomBitmap32);
2709	begin
2710	Dst.SetSize(Width, Height);
2711	if not Empty then
2712	MoveLongword(Bits[0], Dst.Bits[0], Width * Height);
2713	end;
2714
2715	procedure TCustomBitmap32.CopyPropertiesTo(Dst: TCustomBitmap32);
2716	begin
2717	with Dst do
2718	begin
2719	DrawMode := Self.DrawMode;
2720	CombineMode := Self.CombineMode;
2721	WrapMode := Self.WrapMode;
2722	MasterAlpha := Self.MasterAlpha;
2723	OuterColor := Self.OuterColor;
2724
2725	{$IFDEF DEPRECATEDMODE}
2726	StretchFilter := Self.StretchFilter;
2727	{$ENDIF}
2728	ResamplerClassName := Self.ResamplerClassName;
2729	if Assigned(Resampler) and Assigned(Self.Resampler) then
2730	Resampler.Assign(Self.Resampler);
2731	end;
2732	end;
2733
2734	constructor TCustomBitmap32.Create(Width, Height: Integer);
2735	begin
2736	Create;
2737	SetSize(Width, Height);
2738	end;
2739
2740	{$IFDEF BITS_GETTER}
2741	function TCustomBitmap32.GetBits: PColor32Array;
2742	begin
2743	Result := FBackend.Bits;
2744	end;
2745	{$ENDIF}
2746
2747	procedure TCustomBitmap32.SetPenPos(const Value: TPoint);
2748	begin
2749	MoveTo(Value.X, Value.Y);
2750	end;
2751
2752	procedure TCustomBitmap32.SetPenPosF(const Value: TFixedPoint);
2753	begin
2754	MoveTo(Value.X, Value.Y);
2755	end;
2756
2757	procedure TCustomBitmap32.SetPixel(X, Y: Integer; Value: TColor32);
2758	begin
2759	Bits[X + Y * Width] := Value;
2760	end;
2761
2762	procedure TCustomBitmap32.SetPixelS(X, Y: Integer; Value: TColor32);
2763	begin
2764	if {$IFDEF CHANGED_IN_PIXELS}not FMeasuringMode and{$ENDIF}
2765	(X >= FClipRect.Left) and (X < FClipRect.Right) and
2766	(Y >= FClipRect.Top) and (Y < FClipRect.Bottom) then
2767	Bits[X + Y * Width] := Value;
2768
2769	{$IFDEF CHANGED_IN_PIXELS}
2770	Changed(MakeRect(X, Y, X + 1, Y + 1));
2771	{$ENDIF}
2772	end;
2773
2774	function TCustomBitmap32.GetScanLine(Y: Integer): PColor32Array;
2775	begin
2776	Result := @Bits[Y * FWidth];
2777	end;
2778
2779	function TCustomBitmap32.GetPenPos: TPoint;
2780	begin
2781	Result.X := RasterX;
2782	Result.Y := RasterY;
2783	end;
2784
2785	function TCustomBitmap32.GetPenPosF: TFixedPoint;
2786	begin
2787	Result.X := RasterXF;
2788	Result.Y := RasterYF;
2789	end;
2790
2791	function TCustomBitmap32.GetPixel(X, Y: Integer): TColor32;
2792	begin
2793	Result := Bits[X + Y * Width];
2794	end;
2795
2796	function TCustomBitmap32.GetPixelS(X, Y: Integer): TColor32;
2797	begin
2798	if (X >= FClipRect.Left) and (X < FClipRect.Right) and
2799	(Y >= FClipRect.Top) and (Y < FClipRect.Bottom) then
2800	Result := Bits[X + Y * Width]
2801	else
2802	Result := OuterColor;
2803	end;
2804
2805	function TCustomBitmap32.GetPixelPtr(X, Y: Integer): PColor32;
2806	begin
2807	Result := @Bits[X + Y * Width];
2808	end;
2809
2810	procedure TCustomBitmap32.Draw(DstX, DstY: Integer; Src: TCustomBitmap32);
2811	begin
2812	if Assigned(Src) then Src.DrawTo(Self, DstX, DstY);
2813	end;
2814
2815	procedure TCustomBitmap32.Draw(DstX, DstY: Integer; const SrcRect: TRect;
2816	Src: TCustomBitmap32);
2817	begin
2818	if Assigned(Src) then Src.DrawTo(Self, DstX, DstY, SrcRect);
2819	end;
2820
2821	procedure TCustomBitmap32.Draw(const DstRect, SrcRect: TRect; Src: TCustomBitmap32);
2822	begin
2823	if Assigned(Src) then Src.DrawTo(Self, DstRect, SrcRect);
2824	end;
2825
2826	procedure TCustomBitmap32.DrawTo(Dst: TCustomBitmap32);
2827	begin
2828	BlockTransfer(Dst, 0, 0, Dst.ClipRect, Self, BoundsRect, DrawMode,
2829	FOnPixelCombine);
2830	end;
2831
2832	procedure TCustomBitmap32.DrawTo(Dst: TCustomBitmap32; DstX, DstY: Integer);
2833	begin
2834	BlockTransfer(Dst, DstX, DstY, Dst.ClipRect, Self, BoundsRect, DrawMode,
2835	FOnPixelCombine);
2836	end;
2837
2838	procedure TCustomBitmap32.DrawTo(Dst: TCustomBitmap32; DstX, DstY: Integer;
2839	const SrcRect: TRect);
2840	begin
2841	BlockTransfer(Dst, DstX, DstY, Dst.ClipRect, Self, SrcRect,
2842	DrawMode, FOnPixelCombine);
2843	end;
2844
2845	procedure TCustomBitmap32.DrawTo(Dst: TCustomBitmap32; const DstRect: TRect);
2846	begin
2847	StretchTransfer(Dst, DstRect, Dst.ClipRect, Self, BoundsRect, Resampler,
2848	DrawMode, FOnPixelCombine);
2849	end;
2850
2851	procedure TCustomBitmap32.DrawTo(Dst: TCustomBitmap32; const DstRect,
2852	SrcRect: TRect);
2853	begin
2854	StretchTransfer(Dst, DstRect, Dst.ClipRect, Self, SrcRect, Resampler,
2855	DrawMode, FOnPixelCombine);
2856	end;
2857
2858	procedure TCustomBitmap32.ResetAlpha;
2859	begin
2860	ResetAlpha($FF);
2861	end;
2862
2863	procedure TCustomBitmap32.ResetAlpha(const AlphaValue: Byte);
2864	var
2865	I: Integer;
2866	P: PByteArray;
2867	begin
2868	if not FMeasuringMode then
2869	begin
2870	{$IFDEF FPC}
2871	P := Pointer(Bits);
2872	for I := 0 to Width * Height - 1 do
2873	begin
2874	P^[3] := AlphaValue;
2875	Inc(P, 4);
2876	end
2877	{$ELSE}
2878	P := Pointer(Bits);
2879	Inc(P, 3); //shift the pointer to 'alpha' component of the first pixel
2880
2881	I := Width * Height;
2882
2883	if I > 16 then
2884	begin
2885	I := I * 4 - 64;
2886	Inc(P, I);
2887
2888	//16x enrolled loop
2889	I := - I;
2890	repeat
2891	P^[I] := AlphaValue;
2892	P^[I + 4] := AlphaValue;
2893	P^[I + 8] := AlphaValue;
2894	P^[I + 12] := AlphaValue;
2895	P^[I + 16] := AlphaValue;
2896	P^[I + 20] := AlphaValue;
2897	P^[I + 24] := AlphaValue;
2898	P^[I + 28] := AlphaValue;
2899	P^[I + 32] := AlphaValue;
2900	P^[I + 36] := AlphaValue;
2901	P^[I + 40] := AlphaValue;
2902	P^[I + 44] := AlphaValue;
2903	P^[I + 48] := AlphaValue;
2904	P^[I + 52] := AlphaValue;
2905	P^[I + 56] := AlphaValue;
2906	P^[I + 60] := AlphaValue;
2907	Inc(I, 64)
2908	until I > 0;
2909
2910	//eventually remaining bits
2911	Dec(I, 64);
2912	while I < 0 do
2913	begin
2914	P^[I + 64] := AlphaValue;
2915	Inc(I, 4);
2916	end;
2917	end
2918	else
2919	begin
2920	Dec(I);
2921	I := I * 4;
2922	while I >= 0 do
2923	begin
2924	P^[I] := AlphaValue;
2925	Dec(I, 4);
2926	end;
2927	end;
2928	{$ENDIF}
2929	end;
2930	Changed;
2931	end;
2932
2933	function TCustomBitmap32.GetPixelB(X, Y: Integer): TColor32;
2934	begin
2935	// WARNING: this function should never be used on empty bitmaps !!!
2936	if X < 0 then X := 0
2937	else if X >= Width then X := Width - 1;
2938	if Y < 0 then Y := 0
2939	else if Y >= Height then Y := Height - 1;
2940	Result := Bits[X + Y * Width];
2941	end;
2942
2943	procedure TCustomBitmap32.SetPixelT(X, Y: Integer; Value: TColor32);
2944	begin
2945	TBlendMem(BlendProc)(Value, Bits[X + Y * Width]);
2946	EMMS;
2947	end;
2948
2949	procedure TCustomBitmap32.SetPixelT(var Ptr: PColor32; Value: TColor32);
2950	begin
2951	TBlendMem(BlendProc)(Value, Ptr^);
2952	Inc(Ptr);
2953	EMMS;
2954	end;
2955
2956	procedure TCustomBitmap32.SetPixelTS(X, Y: Integer; Value: TColor32);
2957	begin
2958	if {$IFDEF CHANGED_IN_PIXELS}not FMeasuringMode and{$ENDIF}
2959	(X >= FClipRect.Left) and (X < FClipRect.Right) and
2960	(Y >= FClipRect.Top) and (Y < FClipRect.Bottom) then
2961	begin
2962	TBlendMem(BlendProc)(Value, Bits[X + Y * Width]);
2963	EMMS;
2964	end;
2965	{$IFDEF CHANGED_IN_PIXELS}
2966	Changed(MakeRect(X, Y, X + 1, Y + 1));
2967	{$ENDIF}
2968	end;
2969
2970	procedure TCustomBitmap32.SET_T256(X, Y: Integer; C: TColor32);
2971	var
2972	flrx, flry, celx, cely: Longword;
2973	P: PColor32;
2974	A: TColor32;
2975	begin
2976	{ Warning: EMMS should be called after using this method }
2977
2978	flrx := X and $FF;
2979	flry := Y and $FF;
2980
2981	{$IFDEF USENATIVECODE}
2982	X := X div 256;
2983	Y := Y div 256;
2984	{$ELSE}
2985	asm
2986	SAR X, 8
2987	SAR Y, 8
2988	end;
2989	{$ENDIF}
2990
2991	P := @Bits[X + Y * FWidth];
2992	if FCombineMode = cmBlend then
2993	begin
2994	A := C shr 24; // opacity
2995	celx := A * GAMMA_ENCODING_TABLE[flrx xor $FF];
2996	cely := GAMMA_ENCODING_TABLE[flry xor $FF];
2997	flrx := A * GAMMA_ENCODING_TABLE[flrx];
2998	flry := GAMMA_ENCODING_TABLE[flry];
2999
3000	CombineMem(C, P^, celx * cely shr 16); Inc(P);
3001	CombineMem(C, P^, flrx * cely shr 16); Inc(P, FWidth);
3002	CombineMem(C, P^, flrx * flry shr 16); Dec(P);
3003	CombineMem(C, P^, celx * flry shr 16);
3004	end
3005	else
3006	begin
3007	celx := GAMMA_ENCODING_TABLE[flrx xor $FF];
3008	cely := GAMMA_ENCODING_TABLE[flry xor $FF];
3009	flrx := GAMMA_ENCODING_TABLE[flrx];
3010	flry := GAMMA_ENCODING_TABLE[flry];
3011
3012	CombineMem(MergeReg(C, P^), P^, celx * cely shr 8); Inc(P);
3013	CombineMem(MergeReg(C, P^), P^, flrx * cely shr 8); Inc(P, FWidth);
3014	CombineMem(MergeReg(C, P^), P^, flrx * flry shr 8); Dec(P);
3015	CombineMem(MergeReg(C, P^), P^, celx * flry shr 8);
3016	end;
3017	end;
3018
3019	procedure TCustomBitmap32.SET_TS256(X, Y: Integer; C: TColor32);
3020	var
3021	flrx, flry, celx, cely: Longword;
3022	P: PColor32;
3023	A: TColor32;
3024	begin
3025	{ Warning: EMMS should be called after using this method }
3026
3027	// we're checking against Left - 1 and Top - 1 due to antialiased values...
3028	if (X < F256ClipRect.Left - 256) or (X >= F256ClipRect.Right) or
3029	(Y < F256ClipRect.Top - 256) or (Y >= F256ClipRect.Bottom) then Exit;
3030
3031	flrx := X and $FF;
3032	flry := Y and $FF;
3033
3034	{$IFDEF USENATIVECODE}
3035	X := X div 256;
3036	Y := Y div 256;
3037	{$ELSE}
3038	asm
3039	SAR X, 8
3040	SAR Y, 8
3041	end;
3042	{$ENDIF}
3043
3044	P := @Bits[X + Y * FWidth];
3045	if FCombineMode = cmBlend then
3046	begin
3047	A := C shr 24; // opacity
3048	celx := A * GAMMA_ENCODING_TABLE[flrx xor $FF];
3049	cely := GAMMA_ENCODING_TABLE[flry xor $FF];
3050	flrx := A * GAMMA_ENCODING_TABLE[flrx];
3051	flry := GAMMA_ENCODING_TABLE[flry];
3052
3053	if (X >= FClipRect.Left) and (Y >= FClipRect.Top) and
3054	(X < FClipRect.Right - 1) and (Y < FClipRect.Bottom - 1) then
3055	begin
3056	CombineMem(C, P^, celx * cely shr 16); Inc(P);
3057	CombineMem(C, P^, flrx * cely shr 16); Inc(P, FWidth);
3058	CombineMem(C, P^, flrx * flry shr 16); Dec(P);
3059	CombineMem(C, P^, celx * flry shr 16);
3060	end
3061	else // "pixel" lies on the edge of the bitmap
3062	with FClipRect do
3063	begin
3064	if (X >= Left) and (Y >= Top) then CombineMem(C, P^, celx * cely shr 16); Inc(P);
3065	if (X < Right - 1) and (Y >= Top) then CombineMem(C, P^, flrx * cely shr 16); Inc(P, FWidth);
3066	if (X < Right - 1) and (Y < Bottom - 1) then CombineMem(C, P^, flrx * flry shr 16); Dec(P);
3067	if (X >= Left) and (Y < Bottom - 1) then CombineMem(C, P^, celx * flry shr 16);
3068	end;
3069	end
3070	else
3071	begin
3072	celx := GAMMA_ENCODING_TABLE[flrx xor $FF];
3073	cely := GAMMA_ENCODING_TABLE[flry xor $FF];
3074	flrx := GAMMA_ENCODING_TABLE[flrx];
3075	flry := GAMMA_ENCODING_TABLE[flry];
3076
3077	if (X >= FClipRect.Left) and (Y >= FClipRect.Top) and
3078	(X < FClipRect.Right - 1) and (Y < FClipRect.Bottom - 1) then
3079	begin
3080	CombineMem(MergeReg(C, P^), P^, celx * cely shr 8); Inc(P);
3081	CombineMem(MergeReg(C, P^), P^, flrx * cely shr 8); Inc(P, FWidth);
3082	CombineMem(MergeReg(C, P^), P^, flrx * flry shr 8); Dec(P);
3083	CombineMem(MergeReg(C, P^), P^, celx * flry shr 8);
3084	end
3085	else // "pixel" lies on the edge of the bitmap
3086	with FClipRect do
3087	begin
3088	if (X >= Left) and (Y >= Top) then CombineMem(MergeReg(C, P^), P^, celx * cely shr 8); Inc(P);
3089	if (X < Right - 1) and (Y >= Top) then CombineMem(MergeReg(C, P^), P^, flrx * cely shr 8); Inc(P, FWidth);
3090	if (X < Right - 1) and (Y < Bottom - 1) then CombineMem(MergeReg(C, P^), P^, flrx * flry shr 8); Dec(P);
3091	if (X >= Left) and (Y < Bottom - 1) then CombineMem(MergeReg(C, P^), P^, celx * flry shr 8);
3092	end;
3093	end;
3094	end;
3095
3096	procedure TCustomBitmap32.SetPixelF(X, Y: Single; Value: TColor32);
3097	begin
3098	SET_T256(Round(X * 256), Round(Y * 256), Value);
3099	{$IFNDEF OMIT_MMX}
3100	EMMS;
3101	{$ENDIF}
3102	end;
3103
3104	procedure TCustomBitmap32.SetPixelX(X, Y: TFixed; Value: TColor32);
3105	begin
3106	X := (X + $7F) shr 8;
3107	Y := (Y + $7F) shr 8;
3108	SET_T256(X, Y, Value);
3109	{$IFNDEF OMIT_MMX}
3110	EMMS;
3111	{$ENDIF}
3112	end;
3113
3114	procedure TCustomBitmap32.SetPixelFS(X, Y: Single; Value: TColor32);
3115	begin
3116	{$IFDEF CHANGED_IN_PIXELS}
3117	if not FMeasuringMode then
3118	begin
3119	{$ENDIF}
3120	SET_TS256(Round(X * 256), Round(Y * 256), Value);
3121	EMMS;
3122	{$IFDEF CHANGED_IN_PIXELS}
3123	end;
3124	Changed(MakeRect(FloatRect(X, Y, X + 1, Y + 1)));
3125	{$ENDIF}
3126	end;
3127
3128	procedure TCustomBitmap32.SetPixelFW(X, Y: Single; Value: TColor32);
3129	begin
3130	{$IFDEF CHANGED_IN_PIXELS}
3131	if not FMeasuringMode then
3132	begin
3133	{$ENDIF}
3134	SetPixelXW(Round(X * FixedOne), Round(Y * FixedOne), Value);
3135	EMMS;
3136	{$IFDEF CHANGED_IN_PIXELS}
3137	end;
3138	Changed(MakeRect(FloatRect(X, Y, X + 1, Y + 1)));
3139	{$ENDIF}
3140	end;
3141
3142	procedure TCustomBitmap32.SetPixelXS(X, Y: TFixed; Value: TColor32);
3143	begin
3144	{$IFDEF CHANGED_IN_PIXELS}
3145	if not FMeasuringMode then
3146	begin
3147	{$ENDIF}
3148	{$IFDEF USENATIVECODE}
3149	X := (X + $7F) div 256;
3150	Y := (Y + $7F) div 256;
3151	{$ELSE}
3152	asm
3153	ADD X, $7F
3154	ADD Y, $7F
3155	SAR X, 8
3156	SAR Y, 8
3157	end;
3158	{$ENDIF}
3159
3160	SET_TS256(X, Y, Value);
3161	EMMS;
3162	{$IFDEF CHANGED_IN_PIXELS}
3163	end;
3164	Changed(MakeRect(X, Y, X + 1, Y + 1));
3165	{$ENDIF}
3166	end;
3167
3168	function TCustomBitmap32.GET_T256(X, Y: Integer): TColor32;
3169	// When using this, remember that it interpolates towards next x and y!
3170	var
3171	Pos: Integer;
3172	begin
3173	Pos := (X shr 8) + (Y shr 8) * FWidth;
3174	Result := Interpolator(GAMMA_ENCODING_TABLE[X and $FF xor $FF],
3175	GAMMA_ENCODING_TABLE[Y and $FF xor $FF],
3176	@Bits[Pos], @Bits[Pos + FWidth]);
3177	end;
3178
3179	function TCustomBitmap32.GET_TS256(X, Y: Integer): TColor32;
3180	var
3181	Width256, Height256: Integer;
3182	begin
3183	if (X >= F256ClipRect.Left) and (Y >= F256ClipRect.Top) then
3184	begin
3185	Width256 := (FClipRect.Right - 1) shl 8;
3186	Height256 := (FClipRect.Bottom - 1) shl 8;
3187
3188	if (X < Width256) and (Y < Height256) then
3189	Result := GET_T256(X,Y)
3190	else if (X = Width256) and (Y <= Height256) then
3191	// We're exactly on the right border: no need to interpolate.
3192	Result := Pixel[FClipRect.Right - 1, Y shr 8]
3193	else if (X <= Width256) and (Y = Height256) then
3194	// We're exactly on the bottom border: no need to interpolate.
3195	Result := Pixel[X shr 8, FClipRect.Bottom - 1]
3196	else
3197	Result := FOuterColor;
3198	end
3199	else
3200	Result := FOuterColor;
3201	end;
3202
3203	function TCustomBitmap32.GetPixelF(X, Y: Single): TColor32;
3204	begin
3205	Result := GET_T256(Round(X * 256), Round(Y * 256));
3206	{$IFNDEF OMIT_MMX}
3207	EMMS;
3208	{$ENDIF}
3209	end;
3210
3211	function TCustomBitmap32.GetPixelFS(X, Y: Single): TColor32;
3212	begin
3213	Result := GET_TS256(Round(X * 256), Round(Y * 256));
3214	{$IFNDEF OMIT_MMX}
3215	EMMS;
3216	{$ENDIF}
3217	end;
3218
3219	function TCustomBitmap32.GetPixelFW(X, Y: Single): TColor32;
3220	begin
3221	Result := GetPixelXW(Round(X * FixedOne), Round(Y * FixedOne));
3222	{$IFNDEF OMIT_MMX}
3223	EMMS;
3224	{$ENDIF}
3225	end;
3226
3227	function TCustomBitmap32.GetPixelX(X, Y: TFixed): TColor32;
3228	begin
3229	X := (X + $7F) shr 8;
3230	Y := (Y + $7F) shr 8;
3231	Result := GET_T256(X, Y);
3232	{$IFNDEF OMIT_MMX}
3233	EMMS;
3234	{$ENDIF}
3235	end;
3236
3237	function TCustomBitmap32.GetPixelXS(X, Y: TFixed): TColor32;
3238	{$IFDEF PUREPASCAL}
3239	begin
3240	X := (X + $7F) div 256;
3241	Y := (Y + $7F) div 256;
3242	Result := GET_TS256(X, Y);
3243	EMMS;
3244	{$ELSE}
3245	asm
3246	{$IFDEF TARGET_x64}
3247	PUSH RBP
3248	SUB RSP,$30
3249	{$ENDIF}
3250	ADD X, $7F
3251	ADD Y, $7F
3252	SAR X, 8
3253	SAR Y, 8
3254	CALL TCustomBitmap32.GET_TS256
3255	{$IFNDEF OMIT_MMX}
3256	CMP MMX_ACTIVE.Integer, $00
3257	JZ @Exit
3258	DB $0F, $77 /// EMMS
3259	@Exit:
3260	{$ENDIF}
3261
3262	{$IFDEF TARGET_x64}
3263	LEA RSP,[RBP+$30]
3264	POP RBP
3265	{$ENDIF}
3266
3267	{$ENDIF}
3268	end;
3269
3270	function TCustomBitmap32.GetPixelFR(X, Y: Single): TColor32;
3271	begin
3272	Result := FResampler.GetSampleFloat(X, Y);
3273	end;
3274
3275	function TCustomBitmap32.GetPixelXR(X, Y: TFixed): TColor32;
3276	begin
3277	Result := FResampler.GetSampleFixed(X, Y);
3278	end;
3279
3280	function TCustomBitmap32.GetPixelW(X, Y: Integer): TColor32;
3281	begin
3282	with FClipRect do
3283	Result := Bits[FWidth * WrapProcVert(Y, Top, Bottom - 1) + WrapProcHorz(X, Left, Right - 1)];
3284	end;
3285
3286	procedure TCustomBitmap32.SetPixelW(X, Y: Integer; Value: TColor32);
3287	begin
3288	with FClipRect do
3289	Bits[FWidth * WrapProcVert(Y, Top, Bottom - 1) + WrapProcHorz(X, Left, Right - 1)] := Value;
3290	end;
3291
3292	function TCustomBitmap32.GetPixelXW(X, Y: TFixed): TColor32;
3293	var
3294	X1, X2, Y1, Y2 :Integer;
3295	W: Integer;
3296	begin
3297	X2 := TFixedRec(X).Int;
3298	Y2 := TFixedRec(Y).Int;
3299
3300	with FClipRect do
3301	begin
3302	W := Right - 1;
3303	X1 := WrapProcHorz(X2, Left, W);
3304	X2 := WrapProcHorz(X2 + 1, Left, W);
3305	W := Bottom - 1;
3306	Y1 := WrapProcVert(Y2, Top, W) * Width;
3307	Y2 := WrapProcVert(Y2 + 1, Top, W) * Width;
3308	end;
3309
3310	W := WordRec(TFixedRec(X).Frac).Hi;
3311
3312	Result := CombineReg(CombineReg(Bits[X2 + Y2], Bits[X1 + Y2], W),
3313	CombineReg(Bits[X2 + Y1], Bits[X1 + Y1], W),
3314	WordRec(TFixedRec(Y).Frac).Hi);
3315	EMMS;
3316	end;
3317
3318	class function TCustomBitmap32.GetPlatformBackendClass: TCustomBackendClass;
3319	begin
3320	Result := TMemoryBackend;
3321	end;
3322
3323	procedure TCustomBitmap32.SetPixelXW(X, Y: TFixed; Value: TColor32);
3324	begin
3325	{$IFDEF USENATIVECODE}
3326	X := (X + $7F) div 256;
3327	Y := (Y + $7F) div 256;
3328	{$ELSE}
3329	asm
3330	ADD X, $7F
3331	ADD Y, $7F
3332	SAR X, 8
3333	SAR Y, 8
3334	end;
3335	{$ENDIF}
3336
3337	with F256ClipRect do
3338	SET_T256(WrapProcHorz(X, Left, Right - 128), WrapProcVert(Y, Top, Bottom - 128), Value);
3339	EMMS;
3340	end;
3341
3342
3343	procedure TCustomBitmap32.SetStipple(NewStipple: TArrayOfColor32);
3344	begin
3345	FStippleCounter := 0;
3346	FStipplePattern := Copy(NewStipple, 0, Length(NewStipple));
3347	end;
3348
3349	procedure TCustomBitmap32.SetStipple(NewStipple: array of TColor32);
3350	var
3351	L: Integer;
3352	begin
3353	FStippleCounter := 0;
3354	L := High(NewStipple) + 1;
3355	SetLength(FStipplePattern, L);
3356	MoveLongword(NewStipple[0], FStipplePattern[0], L);
3357	end;
3358
3359	procedure TCustomBitmap32.AdvanceStippleCounter(LengthPixels: Single);
3360	var
3361	L: Integer;
3362	Delta: Single;
3363	begin
3364	L := Length(FStipplePattern);
3365	Delta := LengthPixels * FStippleStep;
3366	if (L = 0) or (Delta = 0) then Exit;
3367	FStippleCounter := FStippleCounter + Delta;
3368	FStippleCounter := FStippleCounter - Floor(FStippleCounter / L) * L;
3369	end;
3370
3371	function TCustomBitmap32.GetStippleColor: TColor32;
3372	var
3373	L: Integer;
3374	NextIndex, PrevIndex: Integer;
3375	PrevWeight: Integer;
3376	begin
3377	L := Length(FStipplePattern);
3378	if L = 0 then
3379	begin
3380	// no pattern defined, just return something and exit
3381	Result := clBlack32;
3382	Exit;
3383	end;
3384	FStippleCounter := Wrap(FStippleCounter, L);
3385	{$IFDEF FPC}
3386	PrevIndex := Trunc(FStippleCounter);
3387	{$ELSE}
3388	PrevIndex := Round(FStippleCounter - 0.5);
3389	{$ENDIF}
3390	PrevWeight := $FF - Round($FF * (FStippleCounter - PrevIndex));
3391	if PrevIndex < 0 then FStippleCounter := L - 1;
3392	NextIndex := PrevIndex + 1;
3393	if NextIndex >= L then NextIndex := 0;
3394	if PrevWeight = $FF then Result := FStipplePattern[PrevIndex]
3395	else
3396	begin
3397	Result := CombineReg(
3398	FStipplePattern[PrevIndex],
3399	FStipplePattern[NextIndex],
3400	PrevWeight);
3401	EMMS;
3402	end;
3403	FStippleCounter := FStippleCounter + FStippleStep;
3404	end;
3405
3406	procedure TCustomBitmap32.HorzLine(X1, Y, X2: Integer; Value: TColor32);
3407	begin
3408	FillLongword(Bits[X1 + Y * Width], X2 - X1 + 1, Value);
3409	end;
3410
3411	procedure TCustomBitmap32.HorzLineS(X1, Y, X2: Integer; Value: TColor32);
3412	begin
3413	if FMeasuringMode then
3414	Changed(MakeRect(X1, Y, X2, Y + 1))
3415	else if (Y >= FClipRect.Top) and (Y < FClipRect.Bottom) and
3416	TestClip(X1, X2, FClipRect.Left, FClipRect.Right) then
3417	begin
3418	HorzLine(X1, Y, X2, Value);
3419	Changed(MakeRect(X1, Y, X2, Y + 1));
3420	end;
3421	end;
3422
3423	procedure TCustomBitmap32.HorzLineT(X1, Y, X2: Integer; Value: TColor32);
3424	var
3425	i: Integer;
3426	P: PColor32;
3427	BlendMem: TBlendMem;
3428	begin
3429	if X2 < X1 then Exit;
3430	P := PixelPtr[X1, Y];
3431	BlendMem := TBlendMem(BlendProc);
3432	for i := X1 to X2 do
3433	begin
3434	BlendMem(Value, P^);
3435	Inc(P);
3436	end;
3437	EMMS;
3438	end;
3439
3440	procedure TCustomBitmap32.HorzLineTS(X1, Y, X2: Integer; Value: TColor32);
3441	begin
3442	if FMeasuringMode then
3443	Changed(MakeRect(X1, Y, X2, Y + 1))
3444	else if (Y >= FClipRect.Top) and (Y < FClipRect.Bottom) and
3445	TestClip(X1, X2, FClipRect.Left, FClipRect.Right) then
3446	begin
3447	HorzLineT(X1, Y, X2, Value);
3448	Changed(MakeRect(X1, Y, X2, Y + 1));
3449	end;
3450	end;
3451
3452	procedure TCustomBitmap32.HorzLineTSP(X1, Y, X2: Integer);
3453	var
3454	I, N: Integer;
3455	begin
3456	if FMeasuringMode then
3457	Changed(MakeRect(X1, Y, X2, Y + 1))
3458	else
3459	begin
3460	if Empty then Exit;
3461	if (Y >= FClipRect.Top) and (Y < FClipRect.Bottom) then
3462	begin
3463	if ((X1 < FClipRect.Left) and (X2 < FClipRect.Left)) or
3464	((X1 >= FClipRect.Right) and (X2 >= FClipRect.Right)) then
3465	begin
3466	AdvanceStippleCounter(Abs(X2 - X1) + 1);
3467	Exit;
3468	end;
3469	if X1 < FClipRect.Left then
3470	begin
3471	AdvanceStippleCounter(FClipRect.Left - X1);
3472	X1 := FClipRect.Left;
3473	end
3474	else if X1 >= FClipRect.Right then
3475	begin
3476	AdvanceStippleCounter(X1 - (FClipRect.Right - 1));
3477	X1 := FClipRect.Right - 1;
3478	end;
3479	N := 0;
3480	if X2 < FClipRect.Left then
3481	begin
3482	N := FClipRect.Left - X2;
3483	X2 := FClipRect.Left;
3484	end
3485	else if X2 >= FClipRect.Right then
3486	begin
3487	N := X2 - (FClipRect.Right - 1);
3488	X2 := FClipRect.Right - 1;
3489	end;
3490
3491	if X2 >= X1 then
3492	for I := X1 to X2 do SetPixelT(I, Y, GetStippleColor)
3493	else
3494	for I := X1 downto X2 do SetPixelT(I, Y, GetStippleColor);
3495
3496	Changed(MakeRect(X1, Y, X2, Y + 1));
3497
3498	if N > 0 then AdvanceStippleCounter(N);
3499	end
3500	else
3501	AdvanceStippleCounter(Abs(X2 - X1) + 1);
3502	end;
3503	end;
3504
3505	procedure TCustomBitmap32.HorzLineX(X1, Y, X2: TFixed; Value: TColor32);
3506	//Author: Michael Hansen
3507	var
3508	I: Integer;
3509	ChangedRect: TFixedRect;
3510	X1F, X2F, YF, Count: Integer;
3511	Wx1, Wx2, Wy, Wt: TColor32;
3512	PDst: PColor32;
3513	begin
3514	if X1 > X2 then Swap(X1, X2);
3515
3516	ChangedRect := FixedRect(X1, Y, X2, Y + 1);
3517	try
3518	X1F := X1 shr 16;
3519	X2F := X2 shr 16;
3520	YF := Y shr 16;
3521
3522	PDst := PixelPtr[X1F, YF];
3523
3524	Wy := Y and $ffff xor $ffff;
3525	Wx1 := X1 and $ffff xor $ffff;
3526	Wx2 := X2 and $ffff;
3527
3528	Count := X2F - X1F - 1;
3529	if Wy > 0 then
3530	begin
3531	CombineMem(Value, PDst^, GAMMA_ENCODING_TABLE[(Wy * Wx1) shr 24]);
3532	Wt := GAMMA_ENCODING_TABLE[Wy shr 8];
3533	Inc(PDst);
3534	for I := 0 to Count - 1 do
3535	begin
3536	CombineMem(Value, PDst^, Wt);
3537	Inc(PDst);
3538	end;
3539	CombineMem(Value, PDst^, GAMMA_ENCODING_TABLE[(Wy * Wx2) shr 24]);
3540	end;
3541
3542	PDst := PixelPtr[X1F, YF + 1];
3543
3544	Wy := Wy xor $ffff;
3545	if Wy > 0 then
3546	begin
3547	CombineMem(Value, PDst^, GAMMA_ENCODING_TABLE[(Wy * Wx1) shr 24]);
3548	Inc(PDst);
3549	Wt := GAMMA_ENCODING_TABLE[Wy shr 8];
3550	for I := 0 to Count - 1 do
3551	begin
3552	CombineMem(Value, PDst^, Wt);
3553	Inc(PDst);
3554	end;
3555	CombineMem(Value, PDst^, GAMMA_ENCODING_TABLE[(Wy * Wx2) shr 24]);
3556	end;
3557
3558	finally
3559	EMMS;
3560	Changed(MakeRect(ChangedRect), AREAINFO_LINE + 2);
3561	end;
3562	end;
3563
3564	procedure TCustomBitmap32.HorzLineXS(X1, Y, X2: TFixed; Value: TColor32);
3565	//author: Michael Hansen
3566	var
3567	ChangedRect: TFixedRect;
3568	begin
3569	if X1 > X2 then Swap(X1, X2);
3570	ChangedRect := FixedRect(X1, Y, X2, Y + 1);
3571	if not FMeasuringMode then
3572	begin
3573	X1 := Constrain(X1, FFixedClipRect.Left, FFixedClipRect.Right);
3574	X2 := Constrain(X2, FFixedClipRect.Left, FFixedClipRect.Right);
3575	if (Abs(X2 - X1) > FIXEDONE) and InRange(Y, FFixedClipRect.Top, FFixedClipRect.Bottom - FIXEDONE) then
3576	HorzLineX(X1, Y, X2, Value)
3577	else
3578	LineXS(X1, Y, X2, Y, Value);
3579	end;
3580	Changed(MakeRect(ChangedRect), AREAINFO_LINE + 2);
3581	end;
3582
3583	procedure TCustomBitmap32.VertLine(X, Y1, Y2: Integer; Value: TColor32);
3584	var
3585	I, NH, NL: Integer;
3586	P: PColor32;
3587	begin
3588	if Y2 < Y1 then Exit;
3589	P := PixelPtr[X, Y1];
3590	I := Y2 - Y1 + 1;
3591	NH := I shr 2;
3592	NL := I and $03;
3593	for I := 0 to NH - 1 do
3594	begin
3595	P^ := Value; Inc(P, Width);
3596	P^ := Value; Inc(P, Width);
3597	P^ := Value; Inc(P, Width);
3598	P^ := Value; Inc(P, Width);
3599	end;
3600	for I := 0 to NL - 1 do
3601	begin
3602	P^ := Value; Inc(P, Width);
3603	end;
3604	end;
3605
3606	procedure TCustomBitmap32.VertLineS(X, Y1, Y2: Integer; Value: TColor32);
3607	begin
3608	if FMeasuringMode then
3609	Changed(MakeRect(X, Y1, X + 1, Y2))
3610	else if (X >= FClipRect.Left) and (X < FClipRect.Right) and
3611	TestClip(Y1, Y2, FClipRect.Top, FClipRect.Bottom) then
3612	begin
3613	VertLine(X, Y1, Y2, Value);
3614	Changed(MakeRect(X, Y1, X + 1, Y2));
3615	end;
3616	end;
3617
3618	procedure TCustomBitmap32.VertLineT(X, Y1, Y2: Integer; Value: TColor32);
3619	var
3620	i: Integer;
3621	P: PColor32;
3622	BlendMem: TBlendMem;
3623	begin
3624	P := PixelPtr[X, Y1];
3625	BlendMem := TBlendMem(BlendProc);
3626	for i := Y1 to Y2 do
3627	begin
3628	BlendMem(Value, P^);
3629	Inc(P, Width);
3630	end;
3631	EMMS;
3632	end;
3633
3634	procedure TCustomBitmap32.VertLineTS(X, Y1, Y2: Integer; Value: TColor32);
3635	begin
3636	if FMeasuringMode then
3637	Changed(MakeRect(X, Y1, X + 1, Y2))
3638	else if (X >= FClipRect.Left) and (X < FClipRect.Right) and
3639	TestClip(Y1, Y2, FClipRect.Top, FClipRect.Bottom) then
3640	begin
3641	VertLineT(X, Y1, Y2, Value);
3642	Changed(MakeRect(X, Y1, X + 1, Y2));
3643	end;
3644	end;
3645
3646	procedure TCustomBitmap32.VertLineTSP(X, Y1, Y2: Integer);
3647	var
3648	I, N: Integer;
3649	begin
3650	if FMeasuringMode then
3651	Changed(MakeRect(X, Y1, X + 1, Y2))
3652	else
3653	begin
3654	if Empty then Exit;
3655	if (X >= FClipRect.Left) and (X < FClipRect.Right) then
3656	begin
3657	if ((Y1 < FClipRect.Top) and (Y2 < FClipRect.Top)) or
3658	((Y1 >= FClipRect.Bottom) and (Y2 >= FClipRect.Bottom)) then
3659	begin
3660	AdvanceStippleCounter(Abs(Y2 - Y1) + 1);
3661	Exit;
3662	end;
3663	if Y1 < FClipRect.Top then
3664	begin
3665	AdvanceStippleCounter(FClipRect.Top - Y1);
3666	Y1 := FClipRect.Top;
3667	end
3668	else if Y1 >= FClipRect.Bottom then
3669	begin
3670	AdvanceStippleCounter(Y1 - (FClipRect.Bottom - 1));
3671	Y1 := FClipRect.Bottom - 1;
3672	end;
3673	N := 0;
3674	if Y2 < FClipRect.Top then
3675	begin
3676	N := FClipRect.Top - Y2;
3677	Y2 := FClipRect.Top;
3678	end
3679	else if Y2 >= FClipRect.Bottom then
3680	begin
3681	N := Y2 - (FClipRect.Bottom - 1);
3682	Y2 := FClipRect.Bottom - 1;
3683	end;
3684
3685	if Y2 >= Y1 then
3686	for I := Y1 to Y2 do SetPixelT(X, I, GetStippleColor)
3687	else
3688	for I := Y1 downto Y2 do SetPixelT(X, I, GetStippleColor);
3689
3690	Changed(MakeRect(X, Y1, X + 1, Y2));
3691
3692	if N > 0 then AdvanceStippleCounter(N);
3693	end
3694	else
3695	AdvanceStippleCounter(Abs(Y2 - Y1) + 1);
3696	end;
3697	end;
3698
3699	procedure TCustomBitmap32.VertLineX(X, Y1, Y2: TFixed; Value: TColor32);
3700	//Author: Michael Hansen
3701	var
3702	I: Integer;
3703	ChangedRect: TFixedRect;
3704	Y1F, Y2F, XF, Count: Integer;
3705	Wy1, Wy2, Wx, Wt: TColor32;
3706	PDst: PColor32;
3707	begin
3708	if Y1 > Y2 then Swap(Y1, Y2);
3709
3710	ChangedRect := FixedRect(X, Y1, X + 1, Y2);
3711	try
3712	Y1F := Y1 shr 16;
3713	Y2F := Y2 shr 16;
3714	XF := X shr 16;
3715
3716	PDst := PixelPtr[XF, Y1F];
3717
3718	Wx := X and $ffff xor $ffff;
3719	Wy1 := Y1 and $ffff xor $ffff;
3720	Wy2 := Y2 and $ffff;
3721
3722	Count := Y2F - Y1F - 1;
3723	if Wx > 0 then
3724	begin
3725	CombineMem(Value, PDst^, GAMMA_ENCODING_TABLE[(Wx * Wy1) shr 24]);
3726	Wt := GAMMA_ENCODING_TABLE[Wx shr 8];
3727	Inc(PDst, FWidth);
3728	for I := 0 to Count - 1 do
3729	begin
3730	CombineMem(Value, PDst^, Wt);
3731	Inc(PDst, FWidth);
3732	end;
3733	CombineMem(Value, PDst^, GAMMA_ENCODING_TABLE[(Wx * Wy2) shr 24]);
3734	end;
3735
3736	PDst := PixelPtr[XF + 1, Y1F];
3737
3738	Wx := Wx xor $ffff;
3739	if Wx > 0 then
3740	begin
3741	CombineMem(Value, PDst^, GAMMA_ENCODING_TABLE[(Wx * Wy1) shr 24]);
3742	Inc(PDst, FWidth);
3743	Wt := GAMMA_ENCODING_TABLE[Wx shr 8];
3744	for I := 0 to Count - 1 do
3745	begin
3746	CombineMem(Value, PDst^, Wt);
3747	Inc(PDst, FWidth);
3748	end;
3749	CombineMem(Value, PDst^, GAMMA_ENCODING_TABLE[(Wx * Wy2) shr 24]);
3750	end;
3751
3752	finally
3753	EMMS;
3754	Changed(MakeRect(ChangedRect), AREAINFO_LINE + 2);
3755	end;
3756	end;
3757
3758	procedure TCustomBitmap32.VertLineXS(X, Y1, Y2: TFixed; Value: TColor32);
3759	//author: Michael Hansen
3760	var
3761	ChangedRect: TFixedRect;
3762	begin
3763	if Y1 > Y2 then Swap(Y1, Y2);
3764	ChangedRect := FixedRect(X, Y1, X + 1, Y2);
3765	if not FMeasuringMode then
3766	begin
3767	Y1 := Constrain(Y1, FFixedClipRect.Top, FFixedClipRect.Bottom - FIXEDONE);
3768	Y2 := Constrain(Y2, FFixedClipRect.Top, FFixedClipRect.Bottom - FIXEDONE);
3769	if (Abs(Y2 - Y1) > FIXEDONE) and InRange(X, FFixedClipRect.Left, FFixedClipRect.Right - FIXEDONE) then
3770	VertLineX(X, Y1, Y2, Value)
3771	else
3772	LineXS(X, Y1, X, Y2, Value);
3773	end;
3774	Changed(MakeRect(ChangedRect), AREAINFO_LINE + 2);
3775	end;
3776
3777	procedure TCustomBitmap32.Line(X1, Y1, X2, Y2: Integer; Value: TColor32; L: Boolean);
3778	var
3779	Dy, Dx, Sy, Sx, I, Delta: Integer;
3780	P: PColor32;
3781	ChangedRect: TRect;
3782	begin
3783	ChangedRect := MakeRect(X1, Y1, X2, Y2);
3784	try
3785	Dx := X2 - X1;
3786	Dy := Y2 - Y1;
3787
3788	if Dx > 0 then Sx := 1
3789	else if Dx < 0 then
3790	begin
3791	Dx := -Dx;
3792	Sx := -1;
3793	end
3794	else // Dx = 0
3795	begin
3796	if Dy > 0 then VertLine(X1, Y1, Y2 - 1, Value)
3797	else if Dy < 0 then VertLine(X1, Y2 + 1, Y1, Value);
3798	if L then Pixel[X2, Y2] := Value;
3799	Exit;
3800	end;
3801
3802	if Dy > 0 then Sy := 1
3803	else if Dy < 0 then
3804	begin
3805	Dy := -Dy;
3806	Sy := -1;
3807	end
3808	else // Dy = 0
3809	begin
3810	if X2 > X1 then HorzLine(X1, Y1, X2 - 1, Value)
3811	else HorzLine(X2 + 1, Y1, X1, Value);
3812	if L then Pixel[X2, Y2] := Value;
3813	Exit;
3814	end;
3815
3816	P := PixelPtr[X1, Y1];
3817	Sy := Sy * Width;
3818
3819	if Dx > Dy then
3820	begin
3821	Delta := Dx shr 1;
3822	for I := 0 to Dx - 1 do
3823	begin
3824	P^ := Value;
3825	Inc(P, Sx);
3826	Inc(Delta, Dy);
3827	if Delta >= Dx then
3828	begin
3829	Inc(P, Sy);
3830	Dec(Delta, Dx);
3831	end;
3832	end;
3833	end
3834	else // Dx < Dy
3835	begin
3836	Delta := Dy shr 1;
3837	for I := 0 to Dy - 1 do
3838	begin
3839	P^ := Value;
3840	Inc(P, Sy);
3841	Inc(Delta, Dx);
3842	if Delta >= Dy then
3843	begin
3844	Inc(P, Sx);
3845	Dec(Delta, Dy);
3846	end;
3847	end;
3848	end;
3849	if L then P^ := Value;
3850	finally
3851	Changed(ChangedRect, AREAINFO_LINE + 2);
3852	end;
3853	end;
3854
3855	procedure TCustomBitmap32.LineS(X1, Y1, X2, Y2: Integer; Value: TColor32; L: Boolean);
3856	var
3857	Dx2, Dy2,Cx1, Cx2, Cy1, Cy2, PI, Sx, Sy, Dx, Dy, xd, yd, rem, term, e: Integer;
3858	OC: Int64;
3859	Swapped, CheckAux: Boolean;
3860	P: PColor32;
3861	ChangedRect: TRect;
3862	begin
3863	ChangedRect := MakeRect(X1, Y1, X2, Y2);
3864
3865	if not FMeasuringMode then
3866	begin
3867	Dx := X2 - X1; Dy := Y2 - Y1;
3868
3869	// check for trivial cases...
3870	if Dx = 0 then // vertical line?
3871	begin
3872	if Dy > 0 then VertLineS(X1, Y1, Y2 - 1, Value)
3873	else if Dy < 0 then VertLineS(X1, Y2 + 1, Y1, Value);
3874	if L then PixelS[X2, Y2] := Value;
3875	Changed;
3876	Exit;
3877	end
3878	else if Dy = 0 then // horizontal line?
3879	begin
3880	if Dx > 0 then HorzLineS(X1, Y1, X2 - 1, Value)
3881	else if Dx < 0 then HorzLineS(X2 + 1, Y1, X1, Value);
3882	if L then PixelS[X2, Y2] := Value;
3883	Changed;
3884	Exit;
3885	end;
3886
3887	Cx1 := FClipRect.Left; Cx2 := FClipRect.Right - 1;
3888	Cy1 := FClipRect.Top; Cy2 := FClipRect.Bottom - 1;
3889
3890	if Dx > 0 then
3891	begin
3892	if (X1 > Cx2) or (X2 < Cx1) then Exit; // segment not visible
3893	Sx := 1;
3894	end
3895	else
3896	begin
3897	if (X2 > Cx2) or (X1 < Cx1) then Exit; // segment not visible
3898	Sx := -1;
3899	X1 := -X1; X2 := -X2; Dx := -Dx;
3900	Cx1 := -Cx1; Cx2 := -Cx2;
3901	Swap(Cx1, Cx2);
3902	end;
3903
3904	if Dy > 0 then
3905	begin
3906	if (Y1 > Cy2) or (Y2 < Cy1) then Exit; // segment not visible
3907	Sy := 1;
3908	end
3909	else
3910	begin
3911	if (Y2 > Cy2) or (Y1 < Cy1) then Exit; // segment not visible
3912	Sy := -1;
3913	Y1 := -Y1; Y2 := -Y2; Dy := -Dy;
3914	Cy1 := -Cy1; Cy2 := -Cy2;
3915	Swap(Cy1, Cy2);
3916	end;
3917
3918	if Dx < Dy then
3919	begin
3920	Swapped := True;
3921	Swap(X1, Y1); Swap(X2, Y2); Swap(Dx, Dy);
3922	Swap(Cx1, Cy1); Swap(Cx2, Cy2); Swap(Sx, Sy);
3923	end
3924	else
3925	Swapped := False;
3926
3927	// Bresenham's set up:
3928	Dx2 := Dx shl 1; Dy2 := Dy shl 1;
3929	xd := X1; yd := Y1; e := Dy2 - Dx; term := X2;
3930	CheckAux := True;
3931
3932	// clipping rect horizontal entry
3933	if Y1 < Cy1 then
3934	begin
3935	OC := Int64(Dx2) * (Cy1 - Y1) - Dx;
3936	Inc(xd, OC div Dy2);
3937	rem := OC mod Dy2;
3938	if xd > Cx2 then Exit;
3939	if xd >= Cx1 then
3940	begin
3941	yd := Cy1;
3942	Dec(e, rem + Dx);
3943	if rem > 0 then
3944	begin
3945	Inc(xd);
3946	Inc(e, Dy2);
3947	end;
3948	CheckAux := False; // to avoid ugly goto we set this to omit the next check
3949	end;
3950	end;
3951
3952	// clipping rect vertical entry
3953	if CheckAux and (X1 < Cx1) then
3954	begin
3955	OC := Int64(Dy2) * (Cx1 - X1);
3956	Inc(yd, OC div Dx2);
3957	rem := OC mod Dx2;
3958	if (yd > Cy2) or (yd = Cy2) and (rem >= Dx) then Exit;
3959	xd := Cx1;
3960	Inc(e, rem);
3961	if (rem >= Dx) then
3962	begin
3963	Inc(yd);
3964	Dec(e, Dx2);
3965	end;
3966	end;
3967
3968	// set auxiliary var to indicate that term is not clipped, since
3969	// term still has the unclipped value assigned at setup.
3970	CheckAux := False;
3971
3972	// is the segment exiting the clipping rect?
3973	if Y2 > Cy2 then
3974	begin
3975	OC := Int64(Dx2) * (Cy2 - Y1) + Dx;
3976	term := X1 + OC div Dy2;
3977	rem := OC mod Dy2;
3978	if rem = 0 then Dec(term);
3979	CheckAux := True; // set auxiliary var to indicate that term is clipped
3980	end;
3981
3982	if term > Cx2 then
3983	begin
3984	term := Cx2;
3985	CheckAux := True; // set auxiliary var to indicate that term is clipped
3986	end;
3987
3988	Inc(term);
3989
3990	if Sy = -1 then
3991	yd := -yd;
3992
3993	if Sx = -1 then
3994	begin
3995	xd := -xd;
3996	term := -term;
3997	end;
3998
3999	Dec(Dx2, Dy2);
4000
4001	if Swapped then
4002	begin
4003	PI := Sx * Width;
4004	P := @Bits[yd + xd * Width];
4005	end
4006	else
4007	begin
4008	PI := Sx;
4009	Sy := Sy * Width;
4010	P := @Bits[xd + yd * Width];
4011	end;
4012
4013	// do we need to skip the last pixel of the line and is term not clipped?
4014	if not(L or CheckAux) then
4015	begin
4016	if xd < term then
4017	Dec(term)
4018	else
4019	Inc(term);
4020	end;
4021
4022	while xd <> term do
4023	begin
4024	Inc(xd, Sx);
4025
4026	P^ := Value;
4027	Inc(P, PI);
4028	if e >= 0 then
4029	begin
4030	Inc(P, Sy);
4031	Dec(e, Dx2);
4032	end
4033	else
4034	Inc(e, Dy2);
4035	end;
4036	end;
4037
4038	Changed(ChangedRect, AREAINFO_LINE + 2);
4039	end;
4040
4041	procedure TCustomBitmap32.LineT(X1, Y1, X2, Y2: Integer; Value: TColor32; L: Boolean);
4042	var
4043	Dy, Dx, Sy, Sx, I, Delta: Integer;
4044	P: PColor32;
4045	BlendMem: TBlendMem;
4046	ChangedRect: TRect;
4047	begin
4048	ChangedRect := MakeRect(X1, Y1, X2, Y2);
4049	try
4050	Dx := X2 - X1;
4051	Dy := Y2 - Y1;
4052
4053	if Dx > 0 then Sx := 1
4054	else if Dx < 0 then
4055	begin
4056	Dx := -Dx;
4057	Sx := -1;
4058	end
4059	else // Dx = 0
4060	begin
4061	if Dy > 0 then VertLineT(X1, Y1, Y2 - 1, Value)
4062	else if Dy < 0 then VertLineT(X1, Y2 + 1, Y1, Value);
4063	if L then SetPixelT(X2, Y2, Value);
4064	Exit;
4065	end;
4066
4067	if Dy > 0 then Sy := 1
4068	else if Dy < 0 then
4069	begin
4070	Dy := -Dy;
4071	Sy := -1;
4072	end
4073	else // Dy = 0
4074	begin
4075	if X2 > X1 then HorzLineT(X1, Y1, X2 - 1, Value)
4076	else HorzLineT(X2 + 1, Y1, X1, Value);
4077	if L then SetPixelT(X2, Y2, Value);
4078	Exit;
4079	end;
4080
4081	P := PixelPtr[X1, Y1];
4082	Sy := Sy * Width;
4083
4084	try
4085	BlendMem := TBlendMem(BlendProc);
4086	if Dx > Dy then
4087	begin
4088	Delta := Dx shr 1;
4089	for I := 0 to Dx - 1 do
4090	begin
4091	BlendMem(Value, P^);
4092	Inc(P, Sx);
4093	Inc(Delta, Dy);
4094	if Delta >= Dx then
4095	begin
4096	Inc(P, Sy);
4097	Dec(Delta, Dx);
4098	end;
4099	end;
4100	end
4101	else // Dx < Dy
4102	begin
4103	Delta := Dy shr 1;
4104	for I := 0 to Dy - 1 do
4105	begin
4106	BlendMem(Value, P^);
4107	Inc(P, Sy);
4108	Inc(Delta, Dx);
4109	if Delta >= Dy then
4110	begin
4111	Inc(P, Sx);
4112	Dec(Delta, Dy);
4113	end;
4114	end;
4115	end;
4116	if L then BlendMem(Value, P^);
4117	finally
4118	EMMS;
4119	end;
4120	finally
4121	Changed(ChangedRect, AREAINFO_LINE + 2);
4122	end;
4123	end;
4124
4125	procedure TCustomBitmap32.LineTS(X1, Y1, X2, Y2: Integer; Value: TColor32; L: Boolean);
4126	var
4127	Cx1, Cx2, Cy1, Cy2, PI, Sx, Sy, Dx, Dy, xd, yd, Dx2, Dy2, rem, term, e: Integer;
4128	OC: Int64;
4129	Swapped, CheckAux: Boolean;
4130	P: PColor32;
4131	BlendMem: TBlendMem;
4132	ChangedRect: TRect;
4133	begin
4134	ChangedRect := MakeRect(X1, Y1, X2, Y2);
4135
4136	if not FMeasuringMode then
4137	begin
4138	Dx := X2 - X1; Dy := Y2 - Y1;
4139
4140	// check for trivial cases...
4141	if Dx = 0 then // vertical line?
4142	begin
4143	if Dy > 0 then VertLineTS(X1, Y1, Y2 - 1, Value)
4144	else if Dy < 0 then VertLineTS(X1, Y2 + 1, Y1, Value);
4145	if L then SetPixelTS(X2, Y2, Value);
4146	Exit;
4147	end
4148	else if Dy = 0 then // horizontal line?
4149	begin
4150	if Dx > 0 then HorzLineTS(X1, Y1, X2 - 1, Value)
4151	else if Dx < 0 then HorzLineTS(X2 + 1, Y1, X1, Value);
4152	if L then SetPixelTS(X2, Y2, Value);
4153	Exit;
4154	end;
4155
4156	Cx1 := FClipRect.Left; Cx2 := FClipRect.Right - 1;
4157	Cy1 := FClipRect.Top; Cy2 := FClipRect.Bottom - 1;
4158
4159	if Dx > 0 then
4160	begin
4161	if (X1 > Cx2) or (X2 < Cx1) then Exit; // segment not visible
4162	Sx := 1;
4163	end
4164	else
4165	begin
4166	if (X2 > Cx2) or (X1 < Cx1) then Exit; // segment not visible
4167	Sx := -1;
4168	X1 := -X1; X2 := -X2; Dx := -Dx;
4169	Cx1 := -Cx1; Cx2 := -Cx2;
4170	Swap(Cx1, Cx2);
4171	end;
4172
4173	if Dy > 0 then
4174	begin
4175	if (Y1 > Cy2) or (Y2 < Cy1) then Exit; // segment not visible
4176	Sy := 1;
4177	end
4178	else
4179	begin
4180	if (Y2 > Cy2) or (Y1 < Cy1) then Exit; // segment not visible
4181	Sy := -1;
4182	Y1 := -Y1; Y2 := -Y2; Dy := -Dy;
4183	Cy1 := -Cy1; Cy2 := -Cy2;
4184	Swap(Cy1, Cy2);
4185	end;
4186
4187	if Dx < Dy then
4188	begin
4189	Swapped := True;
4190	Swap(X1, Y1); Swap(X2, Y2); Swap(Dx, Dy);
4191	Swap(Cx1, Cy1); Swap(Cx2, Cy2); Swap(Sx, Sy);
4192	end
4193	else
4194	Swapped := False;
4195
4196	// Bresenham's set up:
4197	Dx2 := Dx shl 1; Dy2 := Dy shl 1;
4198	xd := X1; yd := Y1; e := Dy2 - Dx; term := X2;
4199	CheckAux := True;
4200
4201	// clipping rect horizontal entry
4202	if Y1 < Cy1 then
4203	begin
4204	OC := Int64(Dx2) * (Cy1 - Y1) - Dx;
4205	Inc(xd, OC div Dy2);
4206	rem := OC mod Dy2;
4207	if xd > Cx2 then Exit;
4208	if xd >= Cx1 then
4209	begin
4210	yd := Cy1;
4211	Dec(e, rem + Dx);
4212	if rem > 0 then
4213	begin
4214	Inc(xd);
4215	Inc(e, Dy2);
4216	end;
4217	CheckAux := False; // to avoid ugly goto we set this to omit the next check
4218	end;
4219	end;
4220
4221	// clipping rect vertical entry
4222	if CheckAux and (X1 < Cx1) then
4223	begin
4224	OC := Int64(Dy2) * (Cx1 - X1);
4225	Inc(yd, OC div Dx2);
4226	rem := OC mod Dx2;
4227	if (yd > Cy2) or (yd = Cy2) and (rem >= Dx) then Exit;
4228	xd := Cx1;
4229	Inc(e, rem);
4230	if (rem >= Dx) then
4231	begin
4232	Inc(yd);
4233	Dec(e, Dx2);
4234	end;
4235	end;
4236
4237	// set auxiliary var to indicate that term is not clipped, since
4238	// term still has the unclipped value assigned at setup.
4239	CheckAux := False;
4240
4241	// is the segment exiting the clipping rect?
4242	if Y2 > Cy2 then
4243	begin
4244	OC := Int64(Dx2) * (Cy2 - Y1) + Dx;
4245	term := X1 + OC div Dy2;
4246	rem := OC mod Dy2;
4247	if rem = 0 then Dec(term);
4248	CheckAux := True; // set auxiliary var to indicate that term is clipped
4249	end;
4250
4251	if term > Cx2 then
4252	begin
4253	term := Cx2;
4254	CheckAux := True; // set auxiliary var to indicate that term is clipped
4255	end;
4256
4257	Inc(term);
4258
4259	if Sy = -1 then
4260	yd := -yd;
4261
4262	if Sx = -1 then
4263	begin
4264	xd := -xd;
4265	term := -term;
4266	end;
4267
4268	Dec(Dx2, Dy2);
4269
4270	if Swapped then
4271	begin
4272	PI := Sx * Width;
4273	P := @Bits[yd + xd * Width];
4274	end
4275	else
4276	begin
4277	PI := Sx;
4278	Sy := Sy * Width;
4279	P := @Bits[xd + yd * Width];
4280	end;
4281
4282	// do we need to skip the last pixel of the line and is term not clipped?
4283	if not(L or CheckAux) then
4284	begin
4285	if xd < term then
4286	Dec(term)
4287	else
4288	Inc(term);
4289	end;
4290
4291	try
4292	BlendMem := BLEND_MEM[FCombineMode]^;
4293	while xd <> term do
4294	begin
4295	Inc(xd, Sx);
4296
4297	BlendMem(Value, P^);
4298	Inc(P, PI);
4299	if e >= 0 then
4300	begin
4301	Inc(P, Sy);
4302	Dec(e, Dx2);
4303	end
4304	else
4305	Inc(e, Dy2);
4306	end;
4307	finally
4308	EMMS;
4309	end;
4310	end;
4311
4312	Changed(ChangedRect, AREAINFO_LINE + 2);
4313	end;
4314
4315	procedure TCustomBitmap32.LineX(X1, Y1, X2, Y2: TFixed; Value: TColor32; L: Boolean);
4316	var
4317	n, i: Integer;
4318	nx, ny, hyp, hypl: Integer;
4319	A: TColor32;
4320	h: Single;
4321	ChangedRect: TFixedRect;
4322	begin
4323	ChangedRect := FixedRect(X1, Y1, X2, Y2);
4324	try
4325	nx := X2 - X1; ny := Y2 - Y1;
4326	Inc(X1, 127); Inc(Y1, 127); Inc(X2, 127); Inc(Y2, 127);
4327	hyp := Hypot(nx, ny);
4328	if hyp = 0 then Exit;
4329	hypl := hyp + (Integer(L) * FixedOne);
4330	if (hypl < 256) then Exit;
4331	n := hypl shr 16;
4332	if n > 0 then
4333	begin
4334	h := 65536 / hyp;
4335	nx := Round(nx * h); ny := Round(ny * h);
4336	for i := 0 to n - 1 do
4337	begin
4338	SET_T256(X1 shr 8, Y1 shr 8, Value);
4339	Inc(X1, nx);
4340	Inc(Y1, ny);
4341	end;
4342	end;
4343	A := Value shr 24;
4344	hyp := hypl - n shl 16;
4345	A := A * Cardinal(hyp) shl 8 and $FF000000;
4346	SET_T256((X1 + X2 - nx) shr 9, (Y1 + Y2 - ny) shr 9, Value and $00FFFFFF + A);
4347	finally
4348	EMMS;
4349	Changed(MakeRect(ChangedRect), AREAINFO_LINE + 2);
4350	end;
4351	end;
4352
4353	procedure TCustomBitmap32.LineF(X1, Y1, X2, Y2: Single; Value: TColor32; L: Boolean);
4354	begin
4355	LineX(Fixed(X1), Fixed(Y1), Fixed(X2), Fixed(Y2), Value, L);
4356	end;
4357
4358	procedure TCustomBitmap32.LineXS(X1, Y1, X2, Y2: TFixed; Value: TColor32; L: Boolean);
4359	var
4360	n, i: Integer;
4361	ex, ey, nx, ny, hyp, hypl: Integer;
4362	A: TColor32;
4363	h: Single;
4364	ChangedRect: TFixedRect;
4365	begin
4366	ChangedRect := FixedRect(X1, Y1, X2, Y2);
4367
4368	if not FMeasuringMode then
4369	begin
4370	ex := X2; ey := Y2;
4371
4372	// Check for visibility and clip the coordinates
4373	if not ClipLine(Integer(X1), Integer(Y1), Integer(X2), Integer(Y2),
4374	FFixedClipRect.Left - $10000,
4375	FFixedClipRect.Top - $10000,
4376	FFixedClipRect.Right, FFixedClipRect.Bottom) then Exit;
4377
4378	{ TODO : Handle L on clipping here... }
4379
4380	if (ex <> X2) or (ey <> Y2) then L := True;
4381
4382	// Check if it lies entirely in the bitmap area. Even after clipping
4383	// some pixels may lie outside the bitmap due to antialiasing
4384	if (X1 > FFixedClipRect.Left) and (X1 < FFixedClipRect.Right - $20000) and
4385	(Y1 > FFixedClipRect.Top) and (Y1 < FFixedClipRect.Bottom - $20000) and
4386	(X2 > FFixedClipRect.Left) and (X2 < FFixedClipRect.Right - $20000) and
4387	(Y2 > FFixedClipRect.Top) and (Y2 < FFixedClipRect.Bottom - $20000) then
4388	begin
4389	LineX(X1, Y1, X2, Y2, Value, L);
4390	Exit;
4391	end;
4392
4393	// if we are still here, it means that the line touches one or several bitmap
4394	// boundaries. Use the safe version of antialiased pixel routine
4395	try
4396	nx := X2 - X1; ny := Y2 - Y1;
4397	Inc(X1, 127); Inc(Y1, 127); Inc(X2, 127); Inc(Y2, 127);
4398	hyp := Hypot(nx, ny);
4399	if hyp = 0 then Exit;
4400	hypl := hyp + (Integer(L) * FixedOne);
4401	if hypl < 256 then Exit;
4402	n := hypl shr 16;
4403	if n > 0 then
4404	begin
4405	h := 65536 / hyp;
4406	nx := Round(nx * h); ny := Round(ny * h);
4407	for i := 0 to n - 1 do
4408	begin
4409	SET_TS256(SAR_8(X1), SAR_8(Y1), Value);
4410	X1 := X1 + nx;
4411	Y1 := Y1 + ny;
4412	end;
4413	end;
4414	A := Value shr 24;
4415	hyp := hypl - n shl 16;
4416	A := A * Cardinal(hyp) shl 8 and $FF000000;
4417	SET_TS256(SAR_9(X1 + X2 - nx), SAR_9(Y1 + Y2 - ny), Value and $00FFFFFF + A);
4418	finally
4419	EMMS;
4420	end;
4421	end;
4422	Changed(MakeRect(ChangedRect), AREAINFO_LINE + 2);
4423	end;
4424
4425	procedure TCustomBitmap32.LineFS(X1, Y1, X2, Y2: Single; Value: TColor32; L: Boolean);
4426	begin
4427	LineXS(Fixed(X1), Fixed(Y1), Fixed(X2), Fixed(Y2), Value, L);
4428	end;
4429
4430	procedure TCustomBitmap32.LineXP(X1, Y1, X2, Y2: TFixed; L: Boolean);
4431	var
4432	n, i: Integer;
4433	nx, ny, hyp, hypl: Integer;
4434	A, C: TColor32;
4435	ChangedRect: TRect;
4436	begin
4437	ChangedRect := MakeRect(FixedRect(X1, Y1, X2, Y2));
4438	try
4439	nx := X2 - X1; ny := Y2 - Y1;
4440	Inc(X1, 127); Inc(Y1, 127); Inc(X2, 127); Inc(Y2, 127);
4441	hyp := Hypot(nx, ny);
4442	if hyp = 0 then Exit;
4443	hypl := hyp + (Integer(L) * FixedOne);
4444	if hypl < 256 then Exit;
4445	n := hypl shr 16;
4446	if n > 0 then
4447	begin
4448	nx := Round(nx / hyp * 65536);
4449	ny := Round(ny / hyp * 65536);
4450	for i := 0 to n - 1 do
4451	begin
4452	C := GetStippleColor;
4453	SET_T256(X1 shr 8, Y1 shr 8, C);
4454	EMMS;
4455	X1 := X1 + nx;
4456	Y1 := Y1 + ny;
4457	end;
4458	end;
4459	C := GetStippleColor;
4460	A := C shr 24;
4461	hyp := hypl - n shl 16;
4462	A := A * Longword(hyp) shl 8 and $FF000000;
4463	SET_T256((X1 + X2 - nx) shr 9, (Y1 + Y2 - ny) shr 9, C and $00FFFFFF + A);
4464	EMMS;
4465	finally
4466	Changed(ChangedRect, AREAINFO_LINE + 2);
4467	end;
4468	end;
4469
4470	procedure TCustomBitmap32.LineFP(X1, Y1, X2, Y2: Single; L: Boolean);
4471	begin
4472	LineXP(Fixed(X1), Fixed(Y1), Fixed(X2), Fixed(Y2), L);
4473	end;
4474
4475	procedure TCustomBitmap32.LineXSP(X1, Y1, X2, Y2: TFixed; L: Boolean);
4476	const
4477	StippleInc: array [Boolean] of Integer = (0, 1);
4478	var
4479	n, i: Integer;
4480	sx, sy, ex, ey, nx, ny, hyp, hypl: Integer;
4481	A, C: TColor32;
4482	ChangedRect: TRect;
4483	begin
4484	ChangedRect := MakeRect(FixedRect(X1, Y1, X2, Y2));
4485
4486	if not FMeasuringMode then
4487	begin
4488	sx := X1; sy := Y1; ex := X2; ey := Y2;
4489
4490	// Check for visibility and clip the coordinates
4491	if not ClipLine(Integer(X1), Integer(Y1), Integer(X2), Integer(Y2),
4492	FFixedClipRect.Left - $10000, FFixedClipRect.Top - $10000,
4493	FFixedClipRect.Right, FFixedClipRect.Bottom) then
4494	begin
4495	AdvanceStippleCounter(GR32_Math.Hypot(Integer((X2 - X1) shr 16),
4496	Integer((Y2 - Y1) shr 16) - StippleInc[L]));
4497	Exit;
4498	end;
4499
4500	if (ex <> X2) or (ey <> Y2) then L := True;
4501
4502	// Check if it lies entirely in the bitmap area. Even after clipping
4503	// some pixels may lie outside the bitmap due to antialiasing
4504	if (X1 > FFixedClipRect.Left) and (X1 < FFixedClipRect.Right - $20000) and
4505	(Y1 > FFixedClipRect.Top) and (Y1 < FFixedClipRect.Bottom - $20000) and
4506	(X2 > FFixedClipRect.Left) and (X2 < FFixedClipRect.Right - $20000) and
4507	(Y2 > FFixedClipRect.Top) and (Y2 < FFixedClipRect.Bottom - $20000) then
4508	begin
4509	LineXP(X1, Y1, X2, Y2, L);
4510	Exit;
4511	end;
4512
4513	if (sx <> X1) or (sy <> Y1) then
4514	AdvanceStippleCounter(GR32_Math.Hypot(Integer((X1 - sx) shr 16),
4515	Integer((Y1 - sy) shr 16)));
4516
4517	// if we are still here, it means that the line touches one or several bitmap
4518	// boundaries. Use the safe version of antialiased pixel routine
4519	nx := X2 - X1; ny := Y2 - Y1;
4520	Inc(X1, 127); Inc(Y1, 127); Inc(X2, 127); Inc(Y2, 127);
4521	hyp := GR32_Math.Hypot(nx, ny);
4522	if hyp = 0 then Exit;
4523	hypl := hyp + (Integer(L) * FixedOne);
4524	if hypl < 256 then Exit;
4525	n := hypl shr 16;
4526	if n > 0 then
4527	begin
4528	nx := Round(nx / hyp * 65536); ny := Round(ny / hyp * 65536);
4529	for i := 0 to n - 1 do
4530	begin
4531	C := GetStippleColor;
4532	SET_TS256(SAR_8(X1), SAR_8(Y1), C);
4533	EMMS;
4534	X1 := X1 + nx;
4535	Y1 := Y1 + ny;
4536	end;
4537	end;
4538	C := GetStippleColor;
4539	A := C shr 24;
4540	hyp := hypl - n shl 16;
4541	A := A * Longword(hyp) shl 8 and $FF000000;
4542	SET_TS256(SAR_9(X1 + X2 - nx), SAR_9(Y1 + Y2 - ny), C and $00FFFFFF + A);
4543	EMMS;
4544
4545	if (ex <> X2) or (ey <> Y2) then
4546	AdvanceStippleCounter(GR32_Math.Hypot(Integer((X2 - ex) shr 16),
4547	Integer((Y2 - ey) shr 16) - StippleInc[L]));
4548	end;
4549
4550	Changed(ChangedRect, AREAINFO_LINE + 4);
4551	end;
4552
4553	procedure TCustomBitmap32.LineFSP(X1, Y1, X2, Y2: Single; L: Boolean);
4554	begin
4555	LineXSP(Fixed(X1), Fixed(Y1), Fixed(X2), Fixed(Y2), L);
4556	end;
4557
4558	procedure TCustomBitmap32.LineA(X1, Y1, X2, Y2: Integer; Value: TColor32; L: Boolean);
4559	var
4560	Dx, Dy, Sx, Sy, D: Integer;
4561	EC, EA: Word;
4562	CI: Byte;
4563	P: PColor32;
4564	BlendMemEx: TBlendMemEx;
4565	begin
4566	if (X1 = X2) or (Y1 = Y2) then
4567	begin
4568	LineT(X1, Y1, X2, Y2, Value, L);
4569	Exit;
4570	end;
4571
4572	Dx := X2 - X1;
4573	Dy := Y2 - Y1;
4574
4575	if Dx > 0 then Sx := 1
4576	else
4577	begin
4578	Sx := -1;
4579	Dx := -Dx;
4580	end;
4581
4582	if Dy > 0 then Sy := 1
4583	else
4584	begin
4585	Sy := -1;
4586	Dy := -Dy;
4587	end;
4588
4589	try
4590	EC := 0;
4591	BLEND_MEM[FCombineMode]^(Value, Bits[X1 + Y1 * Width]);
4592	BlendMemEx := BLEND_MEM_EX[FCombineMode]^;
4593
4594	if Dy > Dx then
4595	begin
4596	EA := Dx shl 16 div Dy;
4597	if not L then Dec(Dy);
4598	while Dy > 0 do
4599	begin
4600	Dec(Dy);
4601	D := EC;
4602	Inc(EC, EA);
4603	if EC <= D then Inc(X1, Sx);
4604	Inc(Y1, Sy);
4605	CI := EC shr 8;
4606	P := @Bits[X1 + Y1 * Width];
4607	BlendMemEx(Value, P^, GAMMA_ENCODING_TABLE[CI xor $FF]);
4608	Inc(P, Sx);
4609	BlendMemEx(Value, P^, GAMMA_ENCODING_TABLE[CI]);
4610	end;
4611	end
4612	else // DY <= DX
4613	begin
4614	EA := Dy shl 16 div Dx;
4615	if not L then Dec(Dx);
4616	while Dx > 0 do
4617	begin
4618	Dec(Dx);
4619	D := EC;
4620	Inc(EC, EA);
4621	if EC <= D then Inc(Y1, Sy);
4622	Inc(X1, Sx);
4623	CI := EC shr 8;
4624	P := @Bits[X1 + Y1 * Width];
4625	BlendMemEx(Value, P^, GAMMA_ENCODING_TABLE[CI xor $FF]);
4626	if Sy = 1 then Inc(P, Width) else Dec(P, Width);
4627	BlendMemEx(Value, P^, GAMMA_ENCODING_TABLE[CI]);
4628	end;
4629	end;
4630	finally
4631	EMMS;
4632	Changed(MakeRect(X1, Y1, X2, Y2), AREAINFO_LINE + 2);
4633	end;
4634	end;
4635
4636	procedure TCustomBitmap32.LineAS(X1, Y1, X2, Y2: Integer; Value: TColor32; L: Boolean);
4637	var
4638	Cx1, Cx2, Cy1, Cy2, PI, Sx, Sy, Dx, Dy, xd, yd, rem, term, tmp: Integer;
4639	CheckVert, CornerAA, TermClipped: Boolean;
4640	D1, D2: PInteger;
4641	EC, EA, ED, D: Word;
4642	CI: Byte;
4643	P: PColor32;
4644	BlendMemEx: TBlendMemEx;
4645	ChangedRect: TRect;
4646	begin
4647	ChangedRect := MakeRect(X1, Y1, X2, Y2);
4648
4649	if not FMeasuringMode then
4650	begin
4651	if (FClipRect.Right - FClipRect.Left = 0) or
4652	(FClipRect.Bottom - FClipRect.Top = 0) then Exit;
4653
4654	Dx := X2 - X1; Dy := Y2 - Y1;
4655
4656	// check for trivial cases...
4657	if Abs(Dx) = Abs(Dy) then // diagonal line?
4658	begin
4659	LineTS(X1, Y1, X2, Y2, Value, L);
4660	Exit;
4661	end
4662	else if Dx = 0 then // vertical line?
4663	begin
4664	if Dy > 0 then VertLineTS(X1, Y1, Y2 - 1, Value)
4665	else if Dy < 0 then VertLineTS(X1, Y2 + 1, Y1, Value);
4666	if L then SetPixelTS(X2, Y2, Value);
4667	Exit;
4668	end
4669	else if Dy = 0 then // horizontal line?
4670	begin
4671	if Dx > 0 then HorzLineTS(X1, Y1, X2 - 1, Value)
4672	else if Dx < 0 then HorzLineTS(X2 + 1, Y1, X1, Value);
4673	if L then SetPixelTS(X2, Y2, Value);
4674	Exit;
4675	end;
4676
4677	Cx1 := FClipRect.Left; Cx2 := FClipRect.Right - 1;
4678	Cy1 := FClipRect.Top; Cy2 := FClipRect.Bottom - 1;
4679
4680	if Dx > 0 then
4681	begin
4682	if (X1 > Cx2) or (X2 < Cx1) then Exit; // segment not visible
4683	Sx := 1;
4684	end
4685	else
4686	begin
4687	if (X2 > Cx2) or (X1 < Cx1) then Exit; // segment not visible
4688	Sx := -1;
4689	X1 := -X1; X2 := -X2; Dx := -Dx;
4690	Cx1 := -Cx1; Cx2 := -Cx2;
4691	Swap(Cx1, Cx2);
4692	end;
4693
4694	if Dy > 0 then
4695	begin
4696	if (Y1 > Cy2) or (Y2 < Cy1) then Exit; // segment not visible
4697	Sy := 1;
4698	end
4699	else
4700	begin
4701	if (Y2 > Cy2) or (Y1 < Cy1) then Exit; // segment not visible
4702	Sy := -1;
4703	Y1 := -Y1; Y2 := -Y2; Dy := -Dy;
4704	Cy1 := -Cy1; Cy2 := -Cy2;
4705	Swap(Cy1, Cy2);
4706	end;
4707
4708	if Dx < Dy then
4709	begin
4710	Swap(X1, Y1); Swap(X2, Y2); Swap(Dx, Dy);
4711	Swap(Cx1, Cy1); Swap(Cx2, Cy2); Swap(Sx, Sy);
4712	D1 := @yd; D2 := @xd;
4713	PI := Sy;
4714	end
4715	else
4716	begin
4717	D1 := @xd; D2 := @yd;
4718	PI := Sy * Width;
4719	end;
4720
4721	rem := 0;
4722	EA := Dy shl 16 div Dx;
4723	EC := 0;
4724	xd := X1; yd := Y1;
4725	CheckVert := True;
4726	CornerAA := False;
4727	BlendMemEx := BLEND_MEM_EX[FCombineMode]^;
4728
4729	// clipping rect horizontal entry
4730	if Y1 < Cy1 then
4731	begin
4732	tmp := (Cy1 - Y1) * 65536;
4733	rem := tmp - 65536; // rem := (Cy1 - Y1 - 1) * 65536;
4734	if tmp mod EA > 0 then
4735	tmp := tmp div EA + 1
4736	else
4737	tmp := tmp div EA;
4738
4739	xd := Math.Min(xd + tmp, X2 + 1);
4740	EC := tmp * EA;
4741
4742	if rem mod EA > 0 then
4743	rem := rem div EA + 1
4744	else
4745	rem := rem div EA;
4746
4747	tmp := tmp - rem;
4748
4749	// check whether the line is partly visible
4750	if xd > Cx2 then
4751	// do we need to draw an antialiased part on the corner of the clip rect?
4752	if xd <= Cx2 + tmp then
4753	CornerAA := True
4754	else
4755	Exit;
4756
4757	if (xd {+ 1} >= Cx1) or CornerAA then
4758	begin
4759	yd := Cy1;
4760	rem := xd; // save old xd
4761
4762	ED := EC - EA;
4763	term := SwapConstrain(xd - tmp, Cx1, Cx2);
4764
4765	if CornerAA then
4766	begin
4767	Dec(ED, (xd - Cx2 - 1) * EA);
4768	xd := Cx2 + 1;
4769	end;
4770
4771	// do we need to negate the vars?
4772	if Sy = -1 then yd := -yd;
4773	if Sx = -1 then
4774	begin
4775	xd := -xd;
4776	term := -term;
4777	end;
4778
4779	// draw special case horizontal line entry (draw only last half of entering segment)
4780	try
4781	while xd <> term do
4782	begin
4783	Inc(xd, -Sx);
4784	BlendMemEx(Value, Bits[D1^ + D2^ * Width], GAMMA_ENCODING_TABLE[ED shr 8]);
4785	Dec(ED, EA);
4786	end;
4787	finally
4788	EMMS;
4789	end;
4790
4791	if CornerAA then
4792	begin
4793	// we only needed to draw the visible antialiased part of the line,
4794	// everything else is outside of our cliprect, so exit now since
4795	// there is nothing more to paint...
4796	{ TODO : Handle Changed here... }
4797	Changed;
4798	Exit;
4799	end;
4800
4801	if Sy = -1 then yd := -yd; // negate back
4802	xd := rem; // restore old xd
4803	CheckVert := False; // to avoid ugly goto we set this to omit the next check
4804	end;
4805	end;
4806
4807	// clipping rect vertical entry
4808	if CheckVert and (X1 < Cx1) then
4809	begin
4810	tmp := (Cx1 - X1) * EA;
4811	Inc(yd, tmp div 65536);
4812	EC := tmp;
4813	xd := Cx1;
4814	if (yd > Cy2) then
4815	Exit
4816	else if (yd = Cy2) then
4817	CornerAA := True;
4818	end;
4819
4820	term := X2;
4821	TermClipped := False;
4822	CheckVert := False;
4823
4824	// horizontal exit?
4825	if Y2 > Cy2 then
4826	begin
4827	tmp := (Cy2 - Y1) * 65536;
4828	term := X1 + tmp div EA;
4829	if not(tmp mod EA > 0) then
4830	Dec(Term);
4831
4832	if term < Cx2 then
4833	begin
4834	rem := tmp + 65536; // was: rem := (Cy2 - Y1 + 1) * 65536;
4835	if rem mod EA > 0 then
4836	rem := X1 + rem div EA + 1
4837	else
4838	rem := X1 + rem div EA;
4839
4840	if rem > Cx2 then rem := Cx2;
4841	CheckVert := True;
4842	end;
4843
4844	TermClipped := True;
4845	end;
4846
4847	if term > Cx2 then
4848	begin
4849	term := Cx2;
4850	TermClipped := True;
4851	end;
4852
4853	Inc(term);
4854
4855	if Sy = -1 then yd := -yd;
4856	if Sx = -1 then
4857	begin
4858	xd := -xd;
4859	term := -term;
4860	rem := -rem;
4861	end;
4862
4863	// draw line
4864	if not CornerAA then
4865	try
4866	// do we need to skip the last pixel of the line and is term not clipped?
4867	if not(L or TermClipped) and not CheckVert then
4868	begin
4869	if xd < term then
4870	Dec(term)
4871	else if xd > term then
4872	Inc(term);
4873	end;
4874
4875	while xd <> term do
4876	begin
4877	CI := EC shr 8;
4878	P := @Bits[D1^ + D2^ * Width];
4879	BlendMemEx(Value, P^, GAMMA_ENCODING_TABLE[CI xor $FF]);
4880	Inc(P, PI);
4881	BlendMemEx(Value, P^, GAMMA_ENCODING_TABLE[CI]);
4882	// check for overflow and jump to next line...
4883	D := EC;
4884	Inc(EC, EA);
4885	if EC <= D then
4886	Inc(yd, Sy);
4887
4888	Inc(xd, Sx);
4889	end;
4890	finally
4891	EMMS;
4892	end;
4893
4894	// draw special case horizontal line exit (draw only first half of exiting segment)
4895	if CheckVert then
4896	try
4897	while xd <> rem do
4898	begin
4899	BlendMemEx(Value, Bits[D1^ + D2^ * Width], GAMMA_ENCODING_TABLE[EC shr 8 xor $FF]);
4900	Inc(EC, EA);
4901	Inc(xd, Sx);
4902	end;
4903	finally
4904	EMMS;
4905	end;
4906	end;
4907
4908	Changed(ChangedRect, AREAINFO_LINE + 2);
4909	end;
4910
4911	procedure TCustomBitmap32.MoveTo(X, Y: Integer);
4912	begin
4913	RasterX := X;
4914	RasterY := Y;
4915	end;
4916
4917	procedure TCustomBitmap32.LineToS(X, Y: Integer);
4918	begin
4919	LineS(RasterX, RasterY, X, Y, PenColor);
4920	RasterX := X;
4921	RasterY := Y;
4922	end;
4923
4924	procedure TCustomBitmap32.LineToTS(X, Y: Integer);
4925	begin
4926	LineTS(RasterX, RasterY, X, Y, PenColor);
4927	RasterX := X;
4928	RasterY := Y;
4929	end;
4930
4931	procedure TCustomBitmap32.LineToAS(X, Y: Integer);
4932	begin
4933	LineAS(RasterX, RasterY, X, Y, PenColor);
4934	RasterX := X;
4935	RasterY := Y;
4936	end;
4937
4938	procedure TCustomBitmap32.MoveToX(X, Y: TFixed);
4939	begin
4940	RasterXF := X;
4941	RasterYF := Y;
4942	end;
4943
4944	procedure TCustomBitmap32.MoveToF(X, Y: Single);
4945	begin
4946	RasterXF := Fixed(X);
4947	RasterYF := Fixed(Y);
4948	end;
4949
4950	procedure TCustomBitmap32.LineToXS(X, Y: TFixed);
4951	begin
4952	LineXS(RasterXF, RasterYF, X, Y, PenColor);
4953	RasterXF := X;
4954	RasterYF := Y;
4955	end;
4956
4957	procedure TCustomBitmap32.LineToFS(X, Y: Single);
4958	begin
4959	LineToXS(Fixed(X), Fixed(Y));
4960	end;
4961
4962	procedure TCustomBitmap32.LineToXSP(X, Y: TFixed);
4963	begin
4964	LineXSP(RasterXF, RasterYF, X, Y);
4965	RasterXF := X;
4966	RasterYF := Y;
4967	end;
4968
4969	procedure TCustomBitmap32.LineToFSP(X, Y: Single);
4970	begin
4971	LineToXSP(Fixed(X), Fixed(Y));
4972	end;
4973
4974	procedure TCustomBitmap32.FillRect(X1, Y1, X2, Y2: Integer; Value: TColor32);
4975	var
4976	j: Integer;
4977	P: PColor32Array;
4978	begin
4979	if Assigned(FBits) then
4980	for j := Y1 to Y2 - 1 do
4981	begin
4982	P := Pointer(@Bits[j * FWidth]);
4983	FillLongword(P[X1], X2 - X1, Value);
4984	end;
4985
4986	Changed(MakeRect(X1, Y1, X2, Y2));
4987	end;
4988
4989	procedure TCustomBitmap32.FillRectS(X1, Y1, X2, Y2: Integer; Value: TColor32);
4990	begin
4991	if not FMeasuringMode and
4992	(X2 > X1) and (Y2 > Y1) and
4993	(X1 < FClipRect.Right) and (Y1 < FClipRect.Bottom) and
4994	(X2 > FClipRect.Left) and (Y2 > FClipRect.Top) then
4995	begin
4996	if X1 < FClipRect.Left then X1 := FClipRect.Left;
4997	if Y1 < FClipRect.Top then Y1 := FClipRect.Top;
4998	if X2 > FClipRect.Right then X2 := FClipRect.Right;
4999	if Y2 > FClipRect.Bottom then Y2 := FClipRect.Bottom;
5000	FillRect(X1, Y1, X2, Y2, Value);
5001	end;
5002	Changed(MakeRect(X1, Y1, X2, Y2));
5003	end;
5004
5005	procedure TCustomBitmap32.FillRectT(X1, Y1, X2, Y2: Integer; Value: TColor32);
5006	var
5007	i, j: Integer;
5008	P: PColor32;
5009	A: Integer;
5010	begin
5011	A := Value shr 24;
5012	if A = $FF then
5013	FillRect(X1, Y1, X2, Y2, Value) // calls Changed...
5014	else if A <> 0 then
5015	try
5016	Dec(Y2);
5017	Dec(X2);
5018	for j := Y1 to Y2 do
5019	begin
5020	P := GetPixelPtr(X1, j);
5021	if CombineMode = cmBlend then
5022	begin
5023	for i := X1 to X2 do
5024	begin
5025	CombineMem(Value, P^, A);
5026	Inc(P);
5027	end;
5028	end
5029	else
5030	begin
5031	for i := X1 to X2 do
5032	begin
5033	MergeMem(Value, P^);
5034	Inc(P);
5035	end;
5036	end;
5037	end;
5038	finally
5039	EMMS;
5040	Changed(MakeRect(X1, Y1, X2 + 1, Y2 + 1));
5041	end;
5042	end;
5043
5044	procedure TCustomBitmap32.FillRectTS(X1, Y1, X2, Y2: Integer; Value: TColor32);
5045	begin
5046	if not FMeasuringMode and
5047	(X2 > X1) and (Y2 > Y1) and
5048	(X1 < FClipRect.Right) and (Y1 < FClipRect.Bottom) and
5049	(X2 > FClipRect.Left) and (Y2 > FClipRect.Top) then
5050	begin
5051	if X1 < FClipRect.Left then X1 := FClipRect.Left;
5052	if Y1 < FClipRect.Top then Y1 := FClipRect.Top;
5053	if X2 > FClipRect.Right then X2 := FClipRect.Right;
5054	if Y2 > FClipRect.Bottom then Y2 := FClipRect.Bottom;
5055	FillRectT(X1, Y1, X2, Y2, Value);
5056	end;
5057	Changed(MakeRect(X1, Y1, X2, Y2));
5058	end;
5059
5060	procedure TCustomBitmap32.FillRectS(const ARect: TRect; Value: TColor32);
5061	begin
5062	if FMeasuringMode then // shortcut...
5063	Changed(ARect)
5064	else
5065	with ARect do FillRectS(Left, Top, Right, Bottom, Value);
5066	end;
5067
5068	procedure TCustomBitmap32.FillRectTS(const ARect: TRect; Value: TColor32);
5069	begin
5070	if FMeasuringMode then // shortcut...
5071	Changed(ARect)
5072	else
5073	with ARect do FillRectTS(Left, Top, Right, Bottom, Value);
5074	end;
5075
5076	procedure TCustomBitmap32.FrameRectS(X1, Y1, X2, Y2: Integer; Value: TColor32);
5077	begin
5078	// measuring is handled in inner drawing operations...
5079	if (X2 > X1) and (Y2 > Y1) and
5080	(X1 < FClipRect.Right) and (Y1 < FClipRect.Bottom) and
5081	(X2 > FClipRect.Left) and (Y2 > FClipRect.Top) then
5082	begin
5083	Dec(Y2);
5084	Dec(X2);
5085	HorzLineS(X1, Y1, X2, Value);
5086	if Y2 > Y1 then HorzLineS(X1, Y2, X2, Value);
5087	if Y2 > Y1 + 1 then
5088	begin
5089	VertLineS(X1, Y1 + 1, Y2 - 1, Value);
5090	if X2 > X1 then VertLineS(X2, Y1 + 1, Y2 - 1, Value);
5091	end;
5092	end;
5093	end;
5094
5095	procedure TCustomBitmap32.FrameRectTS(X1, Y1, X2, Y2: Integer; Value: TColor32);
5096	begin
5097	// measuring is handled in inner drawing operations...
5098	if (X2 > X1) and (Y2 > Y1) and
5099	(X1 < FClipRect.Right) and (Y1 < FClipRect.Bottom) and
5100	(X2 > FClipRect.Left) and (Y2 > FClipRect.Top) then
5101	begin
5102	Dec(Y2);
5103	Dec(X2);
5104	HorzLineTS(X1, Y1, X2, Value);
5105	if Y2 > Y1 then HorzLineTS(X1, Y2, X2, Value);
5106	if Y2 > Y1 + 1 then
5107	begin
5108	VertLineTS(X1, Y1 + 1, Y2 - 1, Value);
5109	if X2 > X1 then VertLineTS(X2, Y1 + 1, Y2 - 1, Value);
5110	end;
5111	end;
5112	end;
5113
5114	procedure TCustomBitmap32.FrameRectTSP(X1, Y1, X2, Y2: Integer);
5115	begin
5116	// measuring is handled in inner drawing operations...
5117	if (X2 > X1) and (Y2 > Y1) and
5118	(X1 < Width) and (Y1 < Height) and // don't check against ClipRect here
5119	(X2 > 0) and (Y2 > 0) then // due to StippleCounter
5120	begin
5121	Dec(X2);
5122	Dec(Y2);
5123	if X1 = X2 then
5124	if Y1 = Y2 then
5125	begin
5126	SetPixelT(X1, Y1, GetStippleColor);
5127	Changed(MakeRect(X1, Y1, X1 + 1, Y1 + 1));
5128	end
5129	else
5130	VertLineTSP(X1, Y1, Y2)
5131	else
5132	if Y1 = Y2 then HorzLineTSP(X1, Y1, X2)
5133	else
5134	begin
5135	HorzLineTSP(X1, Y1, X2 - 1);
5136	VertLineTSP(X2, Y1, Y2 - 1);
5137	HorzLineTSP(X2, Y2, X1 + 1);
5138	VertLineTSP(X1, Y2, Y1 + 1);
5139	end;
5140	end;
5141	end;
5142
5143	procedure TCustomBitmap32.FrameRectS(const ARect: TRect; Value: TColor32);
5144	begin
5145	with ARect do FrameRectS(Left, Top, Right, Bottom, Value);
5146	end;
5147
5148	procedure TCustomBitmap32.FrameRectTS(const ARect: TRect; Value: TColor32);
5149	begin
5150	with ARect do FrameRectTS(Left, Top, Right, Bottom, Value);
5151	end;
5152
5153	procedure TCustomBitmap32.RaiseRectTS(X1, Y1, X2, Y2: Integer; Contrast: Integer);
5154	var
5155	C1, C2: TColor32;
5156	begin
5157	// measuring is handled in inner drawing operations...
5158	if (X2 > X1) and (Y2 > Y1) and
5159	(X1 < FClipRect.Right) and (Y1 < FClipRect.Bottom) and
5160	(X2 > FClipRect.Left) and (Y2 > FClipRect.Top) then
5161	begin
5162	if (Contrast > 0) then
5163	begin
5164	C1 := SetAlpha(clWhite32, Clamp(Contrast * 512 div 100));
5165	C2 := SetAlpha(clBlack32, Clamp(Contrast * $FF div 100));
5166	end
5167	else if Contrast < 0 then
5168	begin
5169	Contrast := -Contrast;
5170	C1 := SetAlpha(clBlack32, Clamp(Contrast * $FF div 100));
5171	C2 := SetAlpha(clWhite32, Clamp(Contrast * 512 div 100));
5172	end
5173	else Exit;
5174
5175	Dec(X2);
5176	Dec(Y2);
5177	HorzLineTS(X1, Y1, X2, C1);
5178	HorzLineTS(X1, Y2, X2, C2);
5179	Inc(Y1);
5180	Dec(Y2);
5181	VertLineTS(X1, Y1, Y2, C1);
5182	VertLineTS(X2, Y1, Y2, C2);
5183	end;
5184	end;
5185
5186	procedure TCustomBitmap32.RaiseRectTS(const ARect: TRect; Contrast: Integer);
5187	begin
5188	with ARect do RaiseRectTS(Left, Top, Right, Bottom, Contrast);
5189	end;
5190
5191	procedure TCustomBitmap32.LoadFromStream(Stream: TStream);
5192	var
5193	I, W: integer;
5194	Header: TBmpHeader;
5195	B: TBitmap;
5196	begin
5197	Stream.ReadBuffer(Header, SizeOf(TBmpHeader));
5198
5199	// Check for Windows bitmap magic bytes and general compatibility of the
5200	// bitmap data that ought to be loaded...
5201	if (Header.bfType = $4D42) and
5202	(Header.biBitCount = 32) and (Header.biPlanes = 1) and
5203	(Header.biCompression = 0) then
5204	begin
5205	SetSize(Header.biWidth, Abs(Header.biHeight));
5206
5207	// Check whether the bitmap is saved top-down
5208	if Header.biHeight > 0 then
5209	begin
5210	W := Width shl 2;
5211	for I := Height - 1 downto 0 do
5212	Stream.ReadBuffer(Scanline[I]^, W);
5213	end
5214	else
5215	Stream.ReadBuffer(Bits^, Width * Height shl 2);
5216	end
5217	else
5218	begin
5219	Stream.Seek(-SizeOf(TBmpHeader), soFromCurrent);
5220	B := TBitmap.Create;
5221	try
5222	B.LoadFromStream(Stream);
5223	Assign(B);
5224	finally
5225	B.Free;
5226	end;
5227	end;
5228
5229	Changed;
5230	end;
5231
5232	procedure TCustomBitmap32.SaveToStream(Stream: TStream; SaveTopDown: Boolean = False);
5233	var
5234	Header: TBmpHeader;
5235	BitmapSize: Integer;
5236	I, W: Integer;
5237	begin
5238	BitmapSize := Width * Height shl 2;
5239
5240	Header.bfType := $4D42; // Magic bytes for Windows Bitmap
5241	Header.bfSize := BitmapSize + SizeOf(TBmpHeader);
5242	Header.bfReserved := 0;
5243	// Save offset relative. However, the spec says it has to be file absolute,
5244	// which we can not do properly within a stream...
5245	Header.bfOffBits := SizeOf(TBmpHeader);
5246	Header.biSize := $28;
5247	Header.biWidth := Width;
5248
5249	if SaveTopDown then
5250	Header.biHeight := Height
5251	else
5252	Header.biHeight := -Height;
5253
5254	Header.biPlanes := 1;
5255	Header.biBitCount := 32;
5256	Header.biCompression := 0; // bi_rgb
5257	Header.biSizeImage := BitmapSize;
5258	Header.biXPelsPerMeter := 0;
5259	Header.biYPelsPerMeter := 0;
5260	Header.biClrUsed := 0;
5261	Header.biClrImportant := 0;
5262
5263	Stream.WriteBuffer(Header, SizeOf(TBmpHeader));
5264
5265	if SaveTopDown then
5266	begin
5267	W := Width shl 2;
5268	for I := Height - 1 downto 0 do
5269	Stream.WriteBuffer(ScanLine[I]^, W);
5270	end
5271	else
5272	begin
5273	// NOTE: We can save the whole buffer in one run because
5274	// we do not support scanline strides (yet).
5275	Stream.WriteBuffer(Bits^, BitmapSize);
5276	end;
5277	end;
5278
5279	procedure TCustomBitmap32.LoadFromFile(const FileName: string);
5280	var
5281	FileStream: TFileStream;
5282	Header: TBmpHeader;
5283	P: TPicture;
5284	begin
5285	FileStream := TFileStream.Create(Filename, fmOpenRead);
5286	try
5287	FileStream.ReadBuffer(Header, SizeOf(TBmpHeader));
5288
5289	// Check for Windows bitmap magic bytes...
5290	if Header.bfType = $4D42 then
5291	begin
5292	// if it is, use our stream read method...
5293	FileStream.Seek(-SizeOf(TBmpHeader), soFromCurrent);
5294	LoadFromStream(FileStream);
5295	Exit;
5296	end
5297	finally
5298	FileStream.Free;
5299	end;
5300
5301	// if we got here, use the fallback approach via TPicture...
5302	P := TPicture.Create;
5303	try
5304	P.LoadFromFile(FileName);
5305	Assign(P);
5306	finally
5307	P.Free;
5308	end;
5309	end;
5310
5311	procedure TCustomBitmap32.SaveToFile(const FileName: string; SaveTopDown: Boolean = False);
5312	var
5313	FileStream: TFileStream;
5314	begin
5315	FileStream := TFileStream.Create(Filename, fmCreate);
5316	try
5317	SaveToStream(FileStream, SaveTopDown);
5318	finally
5319	FileStream.Free;
5320	end;
5321	end;
5322
5323	procedure TCustomBitmap32.LoadFromResourceID(Instance: THandle; ResID: Integer);
5324	var
5325	B: TBitmap;
5326	begin
5327	B := TBitmap.Create;
5328	try
5329	B.LoadFromResourceID(Instance, ResID);
5330	Assign(B);
5331	finally
5332	B.Free;
5333	Changed;
5334	end;
5335	end;
5336
5337	procedure TCustomBitmap32.LoadFromResourceName(Instance: THandle; const ResName: string);
5338	var
5339	B: TBitmap;
5340	begin
5341	B := TBitmap.Create;
5342	try
5343	B.LoadFromResourceName(Instance, ResName);
5344	Assign(B);
5345	finally
5346	B.Free;
5347	Changed;
5348	end;
5349	end;
5350
5351	function TCustomBitmap32.Equal(B: TCustomBitmap32): Boolean;
5352	var
5353	S1, S2: TMemoryStream;
5354	begin
5355	Result := (B <> nil) and (ClassType = B.ClassType);
5356
5357	if Empty or B.Empty then
5358	begin
5359	Result := Empty and B.Empty;
5360	Exit;
5361	end;
5362
5363	if Result then
5364	begin
5365	S1 := TMemoryStream.Create;
5366	try
5367	SaveToStream(S1);
5368	S2 := TMemoryStream.Create;
5369	try
5370	B.SaveToStream(S2);
5371	Result := (S1.Size = S2.Size) and CompareMem(S1.Memory, S2.Memory, S1.Size);
5372	finally
5373	S2.Free;
5374	end;
5375	finally
5376	S1.Free;
5377	end;
5378	end;
5379	end;
5380
5381	procedure TCustomBitmap32.DefineProperties(Filer: TFiler);
5382
5383	function DoWrite: Boolean;
5384	begin
5385	if Filer.Ancestor <> nil then
5386	Result := not (Filer.Ancestor is TCustomBitmap32) or
5387	not Equal(TCustomBitmap32(Filer.Ancestor))
5388	else
5389	Result := not Empty;
5390	end;
5391
5392	begin
5393	Filer.DefineBinaryProperty('Data', ReadData, WriteData, DoWrite);
5394	end;
5395
5396	procedure TCustomBitmap32.ReadData(Stream: TStream);
5397	var
5398	Width, Height: Integer;
5399	begin
5400	try
5401	Stream.ReadBuffer(Width, 4);
5402	Stream.ReadBuffer(Height, 4);
5403	SetSize(Width, Height);
5404	Stream.ReadBuffer(Bits[0], FWidth * FHeight * 4);
5405	finally
5406	Changed;
5407	end;
5408	end;
5409
5410	procedure TCustomBitmap32.WriteData(Stream: TStream);
5411	begin
5412	Stream.WriteBuffer(FWidth, 4);
5413	Stream.WriteBuffer(FHeight, 4);
5414	Stream.WriteBuffer(Bits[0], FWidth * FHeight * 4);
5415	end;
5416
5417	procedure TCustomBitmap32.SetCombineMode(const Value: TCombineMode);
5418	begin
5419	if FCombineMode <> Value then
5420	begin
5421	FCombineMode := Value;
5422	BlendProc := @BLEND_MEM[FCombineMode]^;
5423	Changed;
5424	end;
5425	end;
5426
5427	procedure TCustomBitmap32.SetDrawMode(Value: TDrawMode);
5428	begin
5429	if FDrawMode <> Value then
5430	begin
5431	FDrawMode := Value;
5432	Changed;
5433	end;
5434	end;
5435
5436	procedure TCustomBitmap32.SetWrapMode(Value: TWrapMode);
5437	begin
5438	if FWrapMode <> Value then
5439	begin
5440	FWrapMode := Value;
5441	WrapProcHorz := GetWrapProcEx(WrapMode, FClipRect.Left, FClipRect.Right - 1);
5442	WrapProcVert := GetWrapProcEx(WrapMode, FClipRect.Top, FClipRect.Bottom - 1);
5443	Changed;
5444	end;
5445	end;
5446
5447	procedure TCustomBitmap32.SetMasterAlpha(Value: Cardinal);
5448	begin
5449	if FMasterAlpha <> Value then
5450	begin
5451	FMasterAlpha := Value;
5452	Changed;
5453	end;
5454	end;
5455
5456	{$IFDEF DEPRECATEDMODE}
5457	procedure TCustomBitmap32.SetStretchFilter(Value: TStretchFilter);
5458	begin
5459	if FStretchFilter <> Value then
5460	begin
5461	FStretchFilter := Value;
5462
5463	case FStretchFilter of
5464	sfNearest: TNearestResampler.Create(Self);
5465	sfDraft: TDraftResampler.Create(Self);
5466	sfLinear: TLinearResampler.Create(Self);
5467	else
5468	TKernelResampler.Create(Self);
5469	with FResampler as TKernelResampler do
5470	case FStretchFilter of
5471	sfCosine: Kernel := TCosineKernel.Create;
5472	sfSpline: Kernel := TSplineKernel.Create;
5473	sfLanczos: Kernel := TLanczosKernel.Create;
5474	sfMitchell: Kernel := TMitchellKernel.Create;
5475	end;
5476	end;
5477
5478	Changed;
5479	end;
5480	end;
5481	{$ENDIF}
5482
5483	procedure TCustomBitmap32.Roll(Dx, Dy: Integer; FillBack: Boolean; FillColor: TColor32);
5484	var
5485	Shift, L: Integer;
5486	R: TRect;
5487	begin
5488	if Empty or ((Dx = 0) and (Dy = 0)) then Exit;
5489	if (Abs(Dx) >= Width) or (Abs(Dy) >= Height) then
5490	begin
5491	if FillBack then Clear(FillColor);
5492	Exit;
5493	end;
5494
5495	Shift := Dx + Dy * Width;
5496	L := (Width * Height - Abs(Shift));
5497
5498	if Shift > 0 then
5499	Move(Bits[0], Bits[Shift], L shl 2)
5500	else
5501	MoveLongword(Bits[-Shift], Bits[0], L);
5502
5503	if FillBack then
5504	begin
5505	R := MakeRect(0, 0, Width, Height);
5506	OffsetRect(R, Dx, Dy);
5507	IntersectRect(R, R, MakeRect(0, 0, Width, Height));
5508	if R.Top > 0 then
5509	FillRect(0, 0, Width, R.Top, FillColor)
5510	else
5511	if R.Top = 0 then
5512	FillRect(0, R.Bottom, Width, Height, FillColor);
5513	if R.Left > 0 then
5514	FillRect(0, R.Top, R.Left, R.Bottom, FillColor)
5515	else
5516	if R.Left = 0 then
5517	FillRect(R.Right, R.Top, Width, R.Bottom, FillColor);
5518	end;
5519
5520	Changed;
5521	end;
5522
5523	procedure TCustomBitmap32.FlipHorz(Dst: TCustomBitmap32);
5524	var
5525	i, j: Integer;
5526	P1, P2: PColor32;
5527	tmp: TColor32;
5528	W, W2: Integer;
5529	begin
5530	W := Width;
5531	if (Dst = nil) or (Dst = Self) then
5532	begin
5533	{ In-place flipping }
5534	P1 := PColor32(Bits);
5535	P2 := P1;
5536	Inc(P2, Width - 1);
5537	W2 := Width shr 1;
5538	for J := 0 to Height - 1 do
5539	begin
5540	for I := 0 to W2 - 1 do
5541	begin
5542	tmp := P1^;
5543	P1^ := P2^;
5544	P2^ := tmp;
5545	Inc(P1);
5546	Dec(P2);
5547	end;
5548	Inc(P1, W - W2);
5549	Inc(P2, W + W2);
5550	end;
5551	Changed;
5552	end
5553	else
5554	begin
5555	{ Flip to Dst }
5556	Dst.BeginUpdate;
5557	Dst.SetSize(W, Height);
5558	P1 := PColor32(Bits);
5559	P2 := PColor32(Dst.Bits);
5560	Inc(P2, W - 1);
5561	for J := 0 to Height - 1 do
5562	begin
5563	for I := 0 to W - 1 do
5564	begin
5565	P2^ := P1^;
5566	Inc(P1);
5567	Dec(P2);
5568	end;
5569	Inc(P2, W shl 1);
5570	end;
5571	Dst.EndUpdate;
5572	Dst.Changed;
5573	end;
5574	end;
5575
5576	procedure TCustomBitmap32.FlipVert(Dst: TCustomBitmap32);
5577	var
5578	J, J2: Integer;
5579	Buffer: PColor32Array;
5580	P1, P2: PColor32;
5581	begin
5582	if (Dst = nil) or (Dst = Self) then
5583	begin
5584	{ in-place }
5585	J2 := Height - 1;
5586	GetMem(Buffer, Width shl 2);
5587	for J := 0 to Height div 2 - 1 do
5588	begin
5589	P1 := PColor32(ScanLine[J]);
5590	P2 := PColor32(ScanLine[J2]);
5591	MoveLongword(P1^, Buffer^, Width);
5592	MoveLongword(P2^, P1^, Width);
5593	MoveLongword(Buffer^, P2^, Width);
5594	Dec(J2);
5595	end;
5596	FreeMem(Buffer);
5597	Changed;
5598	end
5599	else
5600	begin
5601	Dst.SetSize(Width, Height);
5602	J2 := Height - 1;
5603	for J := 0 to Height - 1 do
5604	begin
5605	MoveLongword(ScanLine[J]^, Dst.ScanLine[J2]^, Width);
5606	Dec(J2);
5607	end;
5608	Dst.Changed;
5609	end;
5610	end;
5611
5612	procedure TCustomBitmap32.Rotate90(Dst: TCustomBitmap32);
5613	var
5614	Tmp: TCustomBitmap32;
5615	X, Y, I, J: Integer;
5616	begin
5617	if Dst = nil then
5618	begin
5619	Tmp := TCustomBitmap32.Create;
5620	Dst := Tmp;
5621	end
5622	else
5623	begin
5624	Tmp := nil;
5625	Dst.BeginUpdate;
5626	end;
5627
5628	Dst.SetSize(Height, Width);
5629	I := 0;
5630	for Y := 0 to Height - 1 do
5631	begin
5632	J := Height - 1 - Y;
5633	for X := 0 to Width - 1 do
5634	begin
5635	Dst.Bits[J] := Bits[I];
5636	Inc(I);
5637	Inc(J, Height);
5638	end;
5639	end;
5640
5641	if Tmp <> nil then
5642	begin
5643	Tmp.CopyMapTo(Self);
5644	Tmp.Free;
5645	end
5646	else
5647	begin
5648	Dst.EndUpdate;
5649	Dst.Changed;
5650	end;
5651	end;
5652
5653	procedure TCustomBitmap32.Rotate180(Dst: TCustomBitmap32);
5654	var
5655	I, I2: Integer;
5656	Tmp: TColor32;
5657	begin
5658	if Dst <> nil then
5659	begin
5660	Dst.SetSize(Width, Height);
5661	I2 := Width * Height - 1;
5662	for I := 0 to Width * Height - 1 do
5663	begin
5664	Dst.Bits[I2] := Bits[I];
5665	Dec(I2);
5666	end;
5667	Dst.Changed;
5668	end
5669	else
5670	begin
5671	I2 := Width * Height - 1;
5672	for I := 0 to Width * Height div 2 - 1 do
5673	begin
5674	Tmp := Bits[I2];
5675	Bits[I2] := Bits[I];
5676	Bits[I] := Tmp;
5677	Dec(I2);
5678	end;
5679	Changed;
5680	end;
5681	end;
5682
5683	procedure TCustomBitmap32.Rotate270(Dst: TCustomBitmap32);
5684	var
5685	Tmp: TCustomBitmap32;
5686	X, Y, I, J: Integer;
5687	begin
5688	if Dst = nil then
5689	begin
5690	Tmp := TCustomBitmap32.Create; { TODO : Revise creating of temporary bitmaps here... }
5691	Dst := Tmp;
5692	end
5693	else
5694	begin
5695	Tmp := nil;
5696	Dst.BeginUpdate;
5697	end;
5698
5699	Dst.SetSize(Height, Width);
5700	I := 0;
5701	for Y := 0 to Height - 1 do
5702	begin
5703	J := (Width - 1) * Height + Y;
5704	for X := 0 to Width - 1 do
5705	begin
5706	Dst.Bits[J] := Bits[I];
5707	Inc(I);
5708	Dec(J, Height);
5709	end;
5710	end;
5711
5712	if Tmp <> nil then
5713	begin
5714	Tmp.CopyMapTo(Self);
5715	Tmp.Free;
5716	end
5717	else
5718	begin
5719	Dst.EndUpdate;
5720	Dst.Changed;
5721	end;
5722	end;
5723
5724	function TCustomBitmap32.BoundsRect: TRect;
5725	begin
5726	Result.Left := 0;
5727	Result.Top := 0;
5728	Result.Right := Width;
5729	Result.Bottom := Height;
5730	end;
5731
5732	procedure TCustomBitmap32.SetClipRect(const Value: TRect);
5733	begin
5734	IntersectRect(FClipRect, Value, BoundsRect);
5735	FFixedClipRect := FixedRect(FClipRect);
5736	with FClipRect do
5737	F256ClipRect := Rect(Left shl 8, Top shl 8, Right shl 8, Bottom shl 8);
5738	FClipping := not EqualRect(FClipRect, BoundsRect);
5739	WrapProcHorz := GetWrapProcEx(WrapMode, FClipRect.Left, FClipRect.Right - 1);
5740	WrapProcVert := GetWrapProcEx(WrapMode, FClipRect.Top, FClipRect.Bottom - 1);
5741	end;
5742
5743	procedure TCustomBitmap32.ResetClipRect;
5744	begin
5745	ClipRect := BoundsRect;
5746	end;
5747
5748	procedure TCustomBitmap32.BeginMeasuring(const Callback: TAreaChangedEvent);
5749	begin
5750	FMeasuringMode := True;
5751	FOldOnAreaChanged := FOnAreaChanged;
5752	FOnAreaChanged := Callback;
5753	end;
5754
5755	procedure TCustomBitmap32.EndMeasuring;
5756	begin
5757	FMeasuringMode := False;
5758	FOnAreaChanged := FOldOnAreaChanged;
5759	end;
5760
5761	procedure TCustomBitmap32.PropertyChanged;
5762	begin
5763	// don't force invalidation of whole bitmap area as this is unnecessary
5764	inherited Changed;
5765	end;
5766
5767	procedure TCustomBitmap32.Changed;
5768	begin
5769	if ((FUpdateCount = 0) or FMeasuringMode) and Assigned(FOnAreaChanged) then
5770	FOnAreaChanged(Self, BoundsRect, AREAINFO_RECT);
5771
5772	if not FMeasuringMode then
5773	inherited;
5774	end;
5775
5776	procedure TCustomBitmap32.Changed(const Area: TRect; const Info: Cardinal);
5777	begin
5778	if ((FUpdateCount = 0) or FMeasuringMode) and Assigned(FOnAreaChanged) then
5779	FOnAreaChanged(Self, Area, Info);
5780
5781	if not FMeasuringMode then
5782	inherited Changed;
5783	end;
5784
5785	procedure TCustomBitmap32.SetResampler(Resampler: TCustomResampler);
5786	begin
5787	if Assigned(Resampler) and (FResampler <> Resampler) then
5788	begin
5789	if Assigned(FResampler) then FResampler.Free;
5790	FResampler := Resampler;
5791	Changed;
5792	end;
5793	end;
5794
5795	function TCustomBitmap32.GetResamplerClassName: string;
5796	begin
5797	Result := FResampler.ClassName;
5798	end;
5799
5800	procedure TCustomBitmap32.SetResamplerClassName(const Value: string);
5801	var
5802	ResamplerClass: TCustomResamplerClass;
5803	begin
5804	if (Value <> '') and (FResampler.ClassName <> Value) and Assigned(ResamplerList) then
5805	begin
5806	ResamplerClass := TCustomResamplerClass(ResamplerList.Find(Value));
5807	if Assigned(ResamplerClass) then ResamplerClass.Create(Self);
5808	end;
5809	end;
5810
5811	{ TBitmap32 }
5812
5813	procedure TBitmap32.FinalizeBackend;
5814	begin
5815	if Supports(Backend, IFontSupport) then
5816	(Backend as IFontSupport).OnFontChange := nil;
5817
5818	if Supports(Backend, ICanvasSupport) then
5819	(Backend as ICanvasSupport).OnCanvasChange := nil;
5820
5821	inherited;
5822	end;
5823
5824	procedure TBitmap32.BackendChangingHandler(Sender: TObject);
5825	begin
5826	inherited;
5827	FontChanged(Self);
5828	DeleteCanvas;
5829	end;
5830
5831	procedure TBitmap32.BackendChangedHandler(Sender: TObject);
5832	begin
5833	inherited;
5834	HandleChanged;
5835	end;
5836
5837	procedure TBitmap32.FontChanged(Sender: TObject);
5838	begin
5839	// TODO: still required?
5840	end;
5841
5842	procedure TBitmap32.CanvasChanged(Sender: TObject);
5843	begin
5844	Changed;
5845	end;
5846
5847	procedure TBitmap32.CopyPropertiesTo(Dst: TCustomBitmap32);
5848	begin
5849	inherited;
5850
5851	if (Dst is TBitmap32) and
5852	Supports(Dst.Backend, IFontSupport) and Supports(Self.Backend, IFontSupport) then
5853	TBitmap32(Dst).Font.Assign(Self.Font);
5854	end;
5855
5856	function TBitmap32.GetCanvas: TCanvas;
5857	begin
5858	Result := (FBackend as ICanvasSupport).Canvas;
5859	end;
5860
5861	function TBitmap32.GetBitmapInfo: TBitmapInfo;
5862	begin
5863	Result := (FBackend as IBitmapContextSupport).BitmapInfo;
5864	end;
5865
5866	function TBitmap32.GetHandle: HBITMAP;
5867	begin
5868	Result := (FBackend as IBitmapContextSupport).BitmapHandle;
5869	end;
5870
5871	function TBitmap32.GetHDC: HDC;
5872	begin
5873	Result := (FBackend as IDeviceContextSupport).Handle;
5874	end;
5875
5876	class function TBitmap32.GetPlatformBackendClass: TCustomBackendClass;
5877	begin
5878	{$IFDEF FPC}
5879	Result := TLCLBackend;
5880	{$ELSE}
5881	Result := TGDIBackend;
5882	{$ENDIF}
5883	end;
5884
5885	function TBitmap32.GetFont: TFont;
5886	begin
5887	Result := (FBackend as IFontSupport).Font;
5888	end;
5889
5890	procedure TBitmap32.SetBackend(const Backend: TCustomBackend);
5891	var
5892	FontSupport: IFontSupport;
5893	CanvasSupport: ICanvasSupport;
5894	begin
5895	if Assigned(Backend) and (Backend <> FBackend) then
5896	begin
5897	if Supports(Backend, IFontSupport, FontSupport) then
5898	FontSupport.OnFontChange := FontChanged;
5899
5900	if Supports(Backend, ICanvasSupport, CanvasSupport) then
5901	CanvasSupport.OnCanvasChange := CanvasChanged;
5902
5903	inherited;
5904	end;
5905	end;
5906
5907	procedure TBitmap32.SetFont(Value: TFont);
5908	begin
5909	(FBackend as IFontSupport).Font := Value;
5910	end;
5911
5912	procedure TBitmap32.HandleChanged;
5913	begin
5914	if Assigned(FOnHandleChanged) then FOnHandleChanged(Self);
5915	end;
5916
5917	{$IFDEF BCB}
5918	procedure TBitmap32.Draw(const DstRect, SrcRect: TRect; hSrc: Cardinal);
5919	{$ELSE}
5920	procedure TBitmap32.Draw(const DstRect, SrcRect: TRect; hSrc: HDC);
5921	{$ENDIF}
5922	begin
5923	(FBackend as IDeviceContextSupport).Draw(DstRect, SrcRect, hSrc);
5924	end;
5925
5926	procedure TBitmap32.DrawTo(hDst: {$IFDEF BCB}Cardinal{$ELSE}HDC{$ENDIF}; DstX, DstY: Integer);
5927	begin
5928	if Empty then Exit;
5929	(FBackend as IDeviceContextSupport).DrawTo(hDst, DstX, DstY);
5930	end;
5931
5932	procedure TBitmap32.DrawTo(hDst: {$IFDEF BCB}Cardinal{$ELSE}HDC{$ENDIF}; const DstRect, SrcRect: TRect);
5933	begin
5934	if Empty then Exit;
5935	(FBackend as IDeviceContextSupport).DrawTo(hDst, DstRect, SrcRect);
5936	end;
5937
5938	procedure TBitmap32.TileTo(hDst: {$IFDEF BCB}Cardinal{$ELSE}HDC{$ENDIF}; const DstRect, SrcRect: TRect);
5939	const
5940	MaxTileSize = 1024;
5941	var
5942	DstW, DstH: Integer;
5943	TilesX, TilesY: Integer;
5944	Buffer: TCustomBitmap32;
5945	I, J: Integer;
5946	ClipRect, R: TRect;
5947	X, Y: Integer;
5948	begin
5949	DstW := DstRect.Right - DstRect.Left;
5950	DstH := DstRect.Bottom - DstRect.Top;
5951	TilesX := (DstW + MaxTileSize - 1) div MaxTileSize;
5952	TilesY := (DstH + MaxTileSize - 1) div MaxTileSize;
5953	Buffer := TBitmap32.Create;
5954	try
5955	for J := 0 to TilesY - 1 do
5956	begin
5957	for I := 0 to TilesX - 1 do
5958	begin
5959	ClipRect.Left := I * MaxTileSize;
5960	ClipRect.Top := J * MaxTileSize;
5961	ClipRect.Right := (I + 1) * MaxTileSize;
5962	ClipRect.Bottom := (J + 1) * MaxTileSize;
5963	if ClipRect.Right > DstW then ClipRect.Right := DstW;
5964	if ClipRect.Bottom > DstH then ClipRect.Bottom := DstH;
5965	X := ClipRect.Left;
5966	Y := ClipRect.Top;
5967	OffsetRect(ClipRect, -X, -Y);
5968	R := DstRect;
5969	OffsetRect(R, -X - DstRect.Left, -Y - DstRect.Top);
5970	Buffer.SetSize(ClipRect.Right, ClipRect.Bottom);
5971	StretchTransfer(Buffer, R, ClipRect, Self, SrcRect, Resampler, DrawMode, FOnPixelCombine);
5972
5973	(Buffer.Backend as IDeviceContextSupport).DrawTo(hDst,
5974	MakeRect(X + DstRect.Left, Y + DstRect.Top, X + ClipRect.Right,
5975	Y + ClipRect.Bottom), MakeRect(0, 0, Buffer.Width, Buffer.Height)
5976	);
5977	end;
5978	end;
5979	finally
5980	Buffer.Free;
5981	end;
5982	end;
5983
5984	{$IFDEF COMPILER2009_UP}
5985	procedure TBitmap32.DrawTo(Dst: TControlCanvas; DstX, DstY: Integer);
5986	begin
5987	DrawTo(Dst.Handle, DstX, DstY);
5988	end;
5989
5990	procedure TBitmap32.DrawTo(Dst: TControlCanvas; const DstRect, SrcRect: TRect);
5991	begin
5992	DrawTo(Dst.Handle, DstRect, SrcRect);
5993	end;
5994
5995	procedure TBitmap32.TileTo(Dst: TControlCanvas; const DstRect, SrcRect: TRect);
5996	begin
5997	TileTo(Dst.Handle, DstRect, SrcRect);
5998	end;
5999	{$ENDIF}
6000
6001	procedure TBitmap32.UpdateFont;
6002	begin
6003	(FBackend as IFontSupport).UpdateFont;
6004	end;
6005
6006	// Text and Fonts //
6007
6008	function TBitmap32.TextExtent(const Text: string): TSize;
6009	begin
6010	Result := (FBackend as ITextSupport).TextExtent(Text);
6011	end;
6012
6013	function TBitmap32.TextExtentW(const Text: Widestring): TSize;
6014	begin
6015	Result := (FBackend as ITextSupport).TextExtentW(Text);
6016	end;
6017
6018	// -------------------------------------------------------------------
6019
6020	procedure TBitmap32.Textout(X, Y: Integer; const Text: string);
6021	begin
6022	(FBackend as ITextSupport).Textout(X, Y, Text);
6023	end;
6024
6025	procedure TBitmap32.TextoutW(X, Y: Integer; const Text: Widestring);
6026	begin
6027	(FBackend as ITextSupport).TextoutW(X, Y, Text);
6028	end;
6029
6030	// -------------------------------------------------------------------
6031
6032	procedure TBitmap32.Textout(X, Y: Integer; const ClipRect: TRect; const Text: string);
6033	begin
6034	(FBackend as ITextSupport).Textout(X, Y, ClipRect, Text);
6035	end;
6036
6037	procedure TBitmap32.TextoutW(X, Y: Integer; const ClipRect: TRect; const Text: Widestring);
6038	begin
6039	(FBackend as ITextSupport).TextoutW(X, Y, ClipRect, Text);
6040	end;
6041
6042	// -------------------------------------------------------------------
6043
6044	procedure TBitmap32.Textout(var DstRect: TRect; const Flags: Cardinal; const Text: string);
6045	begin
6046	(FBackend as ITextSupport).Textout(DstRect, Flags, Text);
6047	end;
6048
6049	procedure TBitmap32.TextoutW(var DstRect: TRect; const Flags: Cardinal; const Text: Widestring);
6050	begin
6051	(FBackend as ITextSupport).TextoutW(DstRect, Flags, Text);
6052	end;
6053
6054	// -------------------------------------------------------------------
6055
6056	function TBitmap32.TextHeight(const Text: string): Integer;
6057	begin
6058	Result := (FBackend as ITextSupport).TextExtent(Text).cY;
6059	end;
6060
6061	function TBitmap32.TextHeightW(const Text: Widestring): Integer;
6062	begin
6063	Result := (FBackend as ITextSupport).TextExtentW(Text).cY;
6064	end;
6065
6066	// -------------------------------------------------------------------
6067
6068	function TBitmap32.TextWidth(const Text: string): Integer;
6069	begin
6070	Result := (FBackend as ITextSupport).TextExtent(Text).cX;
6071	end;
6072
6073	function TBitmap32.TextWidthW(const Text: Widestring): Integer;
6074	begin
6075	Result := (FBackend as ITextSupport).TextExtentW(Text).cX;
6076	end;
6077
6078	// -------------------------------------------------------------------
6079
6080	{$IFNDEF FPC}
6081	procedure SetFontAntialiasing(const Font: TFont; Quality: Cardinal);
6082	var
6083	LogFont: TLogFont;
6084	begin
6085	with LogFont do
6086	begin
6087	lfHeight := Font.Height;
6088	lfWidth := 0; { have font mapper choose }
6089
6090	{$IFDEF COMPILER2005_UP}
6091	lfEscapement := Font.Orientation;
6092	lfOrientation := Font.Orientation;
6093	{$ELSE}
6094	lfEscapement := 0;
6095	lfOrientation := 0;
6096	{$ENDIF}
6097
6098	if fsBold in Font.Style then
6099	lfWeight := FW_BOLD
6100	else
6101	lfWeight := FW_NORMAL;
6102
6103	lfItalic := Byte(fsItalic in Font.Style);
6104	lfUnderline := Byte(fsUnderline in Font.Style);
6105	lfStrikeOut := Byte(fsStrikeOut in Font.Style);
6106	lfCharSet := Byte(Font.Charset);
6107
6108	// TODO DVT Added cast to fix TFontDataName to string warning. Need to verify is OK
6109	if AnsiCompareText(Font.Name, 'Default') = 0 then // do not localize
6110	StrPCopy(lfFaceName, string(DefFontData.Name))
6111	else
6112	StrPCopy(lfFaceName, Font.Name);
6113
6114	lfQuality := Quality;
6115
6116	{ Only True Type fonts support the angles }
6117	if lfOrientation <> 0 then
6118	lfOutPrecision := OUT_TT_ONLY_PRECIS
6119	else
6120	lfOutPrecision := OUT_DEFAULT_PRECIS;
6121
6122	lfClipPrecision := CLIP_DEFAULT_PRECIS;
6123
6124	case Font.Pitch of
6125	fpVariable: lfPitchAndFamily := VARIABLE_PITCH;
6126	fpFixed: lfPitchAndFamily := FIXED_PITCH;
6127	else
6128	lfPitchAndFamily := DEFAULT_PITCH;
6129	end;
6130	end;
6131	Font.Handle := CreateFontIndirect(LogFont);
6132	end;
6133	{$ENDIF}
6134
6135	procedure TextBlueToAlpha(const B: TCustomBitmap32; const Color: TColor32);
6136	(*
6137	asm
6138	PUSH EDI
6139	MOV ECX, [B+$44].Integer
6140	IMUL ECX, [B+$40].Integer
6141	MOV EDI, [B+$54].Integer
6142	@PixelLoop:
6143	MOV EAX, [EDI]
6144	SHL EAX, 24
6145	ADD EAX, Color
6146	MOV [EDI], EAX
6147	ADD EDI, 4
6148	LOOP @PixelLoop
6149	POP EDI
6150	end;
6151	*)
6152	var
6153	I: Integer;
6154	P: PColor32;
6155	C: TColor32;
6156	begin
6157	// convert blue channel to alpha and fill the color
6158	P := @B.Bits[0];
6159	for I := 0 to B.Width * B.Height - 1 do
6160	begin
6161	C := P^;
6162	if C <> 0 then
6163	begin
6164	C := P^ shl 24; // transfer blue channel to alpha
6165	C := C + Color;
6166	P^ := C;
6167	end;
6168	Inc(P);
6169	end;
6170	end;
6171
6172	procedure TextScaleDown(const B, B2: TCustomBitmap32; const N: Integer;
6173	const Color: TColor32); // use only the blue channel
6174	var
6175	I, J, X, Y, P, Q, Sz, S: Integer;
6176	Src: PColor32;
6177	Dst: PColor32;
6178	begin
6179	Sz := 1 shl N - 1;
6180	Dst := PColor32(B.ScanLine[0]);
6181	for J := 0 to B.Height - 1 do
6182	begin
6183	Y := J shl N;
6184	for I := 0 to B.Width - 1 do
6185	begin
6186	X := I shl N;
6187	S := 0;
6188	for Q := Y to Y + Sz do
6189	begin
6190	Src := B2.PixelPtr[X, Q];
6191	for P := X to X + Sz do
6192	begin
6193	S := S + Integer(Src^ and $000000FF);
6194	Inc(Src);
6195	end;
6196	end;
6197	S := S shr N shr N;
6198	Dst^ := TColor32(S shl 24) + Color;
6199	Inc(Dst);
6200	end;
6201	end;
6202	end;
6203
6204	procedure TBitmap32.RenderText(X, Y: Integer; const Text: string; AALevel: Integer; Color: TColor32);
6205	var
6206	B, B2: TBitmap32;
6207	Sz: TSize;
6208	Alpha: TColor32;
6209	PaddedText: string;
6210	begin
6211	if Empty then Exit;
6212
6213	Alpha := Color shr 24;
6214	Color := Color and $00FFFFFF;
6215	AALevel := Constrain(AALevel, -1, 4);
6216	PaddedText := Text + ' ';
6217
6218	{$IFDEF FPC}
6219	if AALevel > -1 then
6220	Font.Quality := fqNonAntialiased
6221	else
6222	Font.Quality := fqAntialiased;
6223	{$ELSE}
6224	if AALevel > -1 then
6225	SetFontAntialiasing(Font, NONANTIALIASED_QUALITY)
6226	else
6227	SetFontAntialiasing(Font, ANTIALIASED_QUALITY);
6228	{$ENDIF}
6229
6230	{ TODO : Optimize Clipping here }
6231	B := TBitmap32.Create;
6232	with B do
6233	try
6234	if AALevel <= 0 then
6235	begin
6236	Sz := Self.TextExtent(PaddedText);
6237	if Sz.cX > Self.Width then Sz.cX := Self.Width;
6238	if Sz.cY > Self.Height then Sz.cX := Self.Height;
6239	SetSize(Sz.cX, Sz.cY);
6240	Font := Self.Font;
6241	Clear(0);
6242	Font.Color := clWhite;
6243	Textout(0, 0, Text);
6244	TextBlueToAlpha(B, Color);
6245	end
6246	else
6247	begin
6248	B2 := TBitmap32.Create;
6249	with B2 do
6250	try
6251	Font := Self.Font;
6252	Font.Size := Self.Font.Size shl AALevel;
6253	Font.Color := clWhite;
6254	Sz := TextExtent(PaddedText);
6255	Sz.Cx := Sz.cx + 1 shl AALevel;
6256	Sz.Cy := Sz.cy + 1 shl AALevel;
6257	SetSize(Sz.Cx, Sz.Cy);
6258	Clear(0);
6259	Textout(0, 0, Text);
6260	B.SetSize(Sz.cx shr AALevel, Sz.cy shr AALevel);
6261	TextScaleDown(B, B2, AALevel, Color);
6262	finally
6263	Free;
6264	end;
6265	end;
6266
6267	DrawMode := dmBlend;
6268	MasterAlpha := Alpha;
6269	CombineMode := CombineMode;
6270
6271	DrawTo(Self, X, Y);
6272	finally
6273	Free;
6274	end;
6275
6276	{$IFDEF FPC}
6277	Font.Quality := fqDefault;
6278	{$ELSE}
6279	SetFontAntialiasing(Font, DEFAULT_QUALITY);
6280	{$ENDIF}
6281	end;
6282
6283	procedure TBitmap32.RenderTextW(X, Y: Integer; const Text: Widestring; AALevel: Integer; Color: TColor32);
6284	var
6285	B, B2: TBitmap32;
6286	Sz: TSize;
6287	Alpha: TColor32;
6288	StockCanvas: TCanvas;
6289	PaddedText: Widestring;
6290	begin
6291	if Empty then Exit;
6292
6293	Alpha := Color shr 24;
6294	Color := Color and $00FFFFFF;
6295	AALevel := Constrain(AALevel, -1, 4);
6296	PaddedText := Text + ' ';
6297
6298	{$IFDEF FPC}
6299	if AALevel > -1 then
6300	Font.Quality := fqNonAntialiased
6301	else
6302	Font.Quality := fqAntialiased;
6303	{$ELSE}
6304	if AALevel > -1 then
6305	SetFontAntialiasing(Font, NONANTIALIASED_QUALITY)
6306	else
6307	SetFontAntialiasing(Font, ANTIALIASED_QUALITY);
6308	{$ENDIF}
6309
6310	{ TODO : Optimize Clipping here }
6311	B := TBitmap32.Create;
6312	try
6313	if AALevel <= 0 then
6314	begin
6315	Sz := TextExtentW(PaddedText);
6316	B.SetSize(Sz.cX, Sz.cY);
6317	B.Font := Font;
6318	B.Clear(0);
6319	B.Font.Color := clWhite;
6320	B.TextoutW(0, 0, Text);
6321	TextBlueToAlpha(B, Color);
6322	end
6323	else
6324	begin
6325	StockCanvas := StockBitmap.Canvas;
6326	StockCanvas.Lock;
6327	try
6328	StockCanvas.Font := Font;
6329	StockCanvas.Font.Size := Font.Size shl AALevel;
6330	{$IFDEF PLATFORM_INDEPENDENT}
6331	Sz := StockCanvas.TextExtent(PaddedText);
6332	{$ELSE}
6333	Windows.GetTextExtentPoint32W(StockCanvas.Handle, PWideChar(PaddedText),
6334	Length(PaddedText), Sz);
6335	{$ENDIF}
6336	Sz.Cx := (Sz.cx shr AALevel + 1) shl AALevel;
6337	Sz.Cy := (Sz.cy shr AALevel + 1) shl AALevel;
6338	B2 := TBitmap32.Create;
6339	try
6340	B2.SetSize(Sz.Cx, Sz.Cy);
6341	B2.Clear(0);
6342	B2.Font := StockCanvas.Font;
6343	B2.Font.Color := clWhite;
6344	B2.TextoutW(0, 0, Text);
6345	B.SetSize(Sz.cx shr AALevel, Sz.cy shr AALevel);
6346	TextScaleDown(B, B2, AALevel, Color);
6347	finally
6348	B2.Free;
6349	end;
6350	finally
6351	StockCanvas.Unlock;
6352	end;
6353	end;
6354
6355	B.DrawMode := dmBlend;
6356	B.MasterAlpha := Alpha;
6357	B.CombineMode := CombineMode;
6358
6359	B.DrawTo(Self, X, Y);
6360	finally
6361	B.Free;
6362	end;
6363
6364	{$IFDEF FPC}
6365	Font.Quality := fqDefault;
6366	{$ELSE}
6367	SetFontAntialiasing(Font, DEFAULT_QUALITY);
6368	{$ENDIF}
6369	end;
6370
6371	// -------------------------------------------------------------------
6372
6373	function TBitmap32.CanvasAllocated: Boolean;
6374	begin
6375	Result := (FBackend as ICanvasSupport).CanvasAllocated;
6376	end;
6377
6378	procedure TBitmap32.DeleteCanvas;
6379	begin
6380	if Supports(Backend, ICanvasSupport) then
6381	(FBackend as ICanvasSupport).DeleteCanvas;
6382	end;
6383
6384
6385	{ TCustomBackend }
6386
6387	constructor TCustomBackend.Create;
6388	begin
6389	RefCounted := True;
6390	_AddRef;
6391	inherited;
6392	end;
6393
6394	constructor TCustomBackend.Create(Owner: TCustomBitmap32);
6395	begin
6396	FOwner := Owner;
6397	Create;
6398	if Assigned(Owner) then
6399	Owner.Backend := Self;
6400	end;
6401
6402	destructor TCustomBackend.Destroy;
6403	begin
6404	Clear;
6405	inherited;
6406	end;
6407
6408	procedure TCustomBackend.Clear;
6409	var
6410	Width, Height: Integer;
6411	begin
6412	if Assigned(FOwner) then
6413	ChangeSize(FOwner.FWidth, FOwner.FHeight, 0, 0, False)
6414	else
6415	ChangeSize(Width, Height, 0, 0, False);
6416	end;
6417
6418	procedure TCustomBackend.Changing;
6419	begin
6420	if Assigned(FOnChanging) then
6421	FOnChanging(Self);
6422	end;
6423
6424	{$IFDEF BITS_GETTER}
6425	function TCustomBackend.GetBits: PColor32Array;
6426	begin
6427	Result := FBits;
6428	end;
6429	{$ENDIF}
6430
6431	procedure TCustomBackend.ChangeSize(out Width, Height: Integer; NewWidth, NewHeight: Integer; ClearBuffer: Boolean);
6432	begin
6433	try
6434	Changing;
6435
6436	FinalizeSurface;
6437
6438	Width := 0;
6439	Height := 0;
6440
6441	if (NewWidth > 0) and (NewHeight > 0) then
6442	InitializeSurface(NewWidth, NewHeight, ClearBuffer);
6443
6444	Width := NewWidth;
6445	Height := NewHeight;
6446	finally
6447	Changed;
6448	end;
6449	end;
6450
6451	procedure TCustomBackend.Assign(Source: TPersistent);
6452	var
6453	SrcBackend: TCustomBackend;
6454	begin
6455	if Source is TCustomBackend then
6456	begin
6457	if Assigned(FOwner) then
6458	begin
6459	SrcBackend := TCustomBackend(Source);
6460
6461	ChangeSize(
6462	FOwner.FWidth, FOwner.FHeight,
6463	SrcBackend.FOwner.Width, SrcBackend.FOwner.Height,
6464	False
6465	);
6466
6467	if not SrcBackend.Empty then
6468	MoveLongword(
6469	SrcBackend.Bits[0], Bits[0],
6470	SrcBackend.FOwner.Width * SrcBackend.FOwner.Height
6471	);
6472	end;
6473	end
6474	else
6475	inherited;
6476	end;
6477
6478	function TCustomBackend.Empty: Boolean;
6479	begin
6480	Result := False;
6481	end;
6482
6483	procedure TCustomBackend.FinalizeSurface;
6484	begin
6485	// descendants override this method
6486	end;
6487
6488	procedure TCustomBackend.InitializeSurface(NewWidth, NewHeight: Integer; ClearBuffer: Boolean);
6489	begin
6490	// descendants override this method
6491	end;
6492
6493	{ TCustomSampler }
6494
6495	function TCustomSampler.GetSampleInt(X, Y: Integer): TColor32;
6496	begin
6497	Result := GetSampleFixed(X * FixedOne, Y * FixedOne);
6498	end;
6499
6500	function TCustomSampler.GetSampleFixed(X, Y: TFixed): TColor32;
6501	begin
6502	Result := GetSampleFloat(X * FixedToFloat, Y * FixedToFloat);
6503	end;
6504
6505	function TCustomSampler.GetSampleFloat(X, Y: TFloat): TColor32;
6506	begin
6507	Result := GetSampleFixed(Fixed(X), Fixed(Y));
6508	end;
6509
6510	procedure TCustomSampler.PrepareSampling;
6511	begin
6512	// descendants override this method
6513	end;
6514
6515	procedure TCustomSampler.FinalizeSampling;
6516	begin
6517	// descendants override this method
6518	end;
6519
6520	function TCustomSampler.HasBounds: Boolean;
6521	begin
6522	Result := False;
6523	end;
6524
6525	function TCustomSampler.GetSampleBounds: TFloatRect;
6526	const
6527	InfRect: TFloatRect = (Left: -Infinity; Top: -Infinity; Right: Infinity; Bottom: Infinity);
6528	begin
6529	Result := InfRect;
6530	end;
6531
6532
6533	{ TCustomResampler }
6534
6535	procedure TCustomResampler.AssignTo(Dst: TPersistent);
6536	begin
6537	if Dst is TCustomResampler then
6538	SmartAssign(Self, Dst)
6539	else
6540	inherited;
6541	end;
6542
6543	procedure TCustomResampler.Changed;
6544	begin
6545	if Assigned(FBitmap) then FBitmap.Changed;
6546	end;
6547
6548	constructor TCustomResampler.Create;
6549	begin
6550	inherited;
6551	FPixelAccessMode := pamSafe;
6552	end;
6553
6554	constructor TCustomResampler.Create(ABitmap: TCustomBitmap32);
6555	begin
6556	Create;
6557	FBitmap := ABitmap;
6558	if Assigned(ABitmap) then ABitmap.Resampler := Self;
6559	end;
6560
6561	function TCustomResampler.GetSampleBounds: TFloatRect;
6562	begin
6563	Result := FloatRect(FBitmap.ClipRect);
6564	if PixelAccessMode = pamTransparentEdge then
6565	InflateRect(Result, 1, 1);
6566	end;
6567
6568	function TCustomResampler.GetWidth: TFloat;
6569	begin
6570	Result := 0;
6571	end;
6572
6573	function TCustomResampler.HasBounds: Boolean;
6574	begin
6575	Result := FPixelAccessMode <> pamWrap;
6576	end;
6577
6578	procedure TCustomResampler.PrepareSampling;
6579	begin
6580	FClipRect := FBitmap.ClipRect;
6581	end;
6582
6583	procedure TCustomResampler.SetPixelAccessMode(
6584	const Value: TPixelAccessMode);
6585	begin
6586	if FPixelAccessMode <> Value then
6587	begin
6588	FPixelAccessMode := Value;
6589	Changed;
6590	end;
6591	end;
6592
6593	initialization
6594	SetGamma;
6595	StockBitmap := TBitmap.Create;
6596	StockBitmap.Width := 8;
6597	StockBitmap.Height := 8;
6598
6599	finalization
6600	StockBitmap.Free;
6601
6602	end.

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

Context Navigation

source: trunk/Packages/Graphics32/GR32.pas

Download in other formats: