Context Navigation

source: tags/1.3.1/Packages/CevoComponents/ScreenTools.pas

Last change on this file was 442, checked in by chronos, 2 years ago
Modified: Code cleanup.
File size: 56.6 KB

Line
1	unit ScreenTools;
2
3	interface
4
5	uses
6	{$IFDEF WINDOWS}
7	Windows,
8	{$ENDIF}
9	StringTables, LCLIntf, LCLType, SysUtils, Classes, Graphics, Controls, Math,
10	Forms, Menus, GraphType, UGraphicSet, LazFileUtils, UTexture;
11
12	type
13	TLoadGraphicFileOption = (gfNoError, gfNoGamma);
14	TLoadGraphicFileOptions = set of TLoadGraphicFileOption;
15
16	TFontType = (ftNormal, ftSmall, ftTiny, ftCaption, ftButton);
17
18	{$IFDEF WINDOWS}
19	function ChangeResolution(x, y, bpp, freq: integer): boolean;
20	{$ENDIF}
21	procedure RestoreResolution;
22	procedure EmptyMenu(MenuItems: TMenuItem; Keep: Integer = 0);
23	function TurnToYear(Turn: integer): integer;
24	function TurnToString(Turn: integer): string;
25	function MovementToString(Movement: integer): string;
26	procedure BtnFrame(ca: TCanvas; p: TRect; T: TTexture);
27	procedure EditFrame(ca: TCanvas; p: TRect; T: TTexture);
28	function HexStringToColor(S: string): integer;
29	function ExtractFileNameWithoutExt(const Filename: string): string;
30	function LoadGraphicFile(Bmp: TBitmap; FileName: string; Options: TLoadGraphicFileOptions = []): boolean;
31	function LoadGraphicSet(const Name: string; Transparency: Boolean = True): TGraphicSet;
32	procedure Dump(dst: TBitmap; HGr: TGraphicSet; xDst, yDst, Width, Height, xGr, yGr: integer);
33	procedure BitmapReplaceColor(Dst: TBitmap; X, Y, Width, Height: Integer; OldColor, NewColor: TColor);
34	procedure Sprite(Canvas: TCanvas; HGr: TGraphicSet; xDst, yDst, Width, Height, xGr, yGr: integer);
35	overload;
36	procedure Sprite(dst: TBitmap; HGr: TGraphicSet; xDst, yDst, Width, Height, xGr, yGr: integer);
37	overload;
38	procedure MakeBlue(Dst: TBitmap; X, Y, Width, Height: Integer);
39	procedure MakeRed(Dst: TBitmap; X, Y, Width, Height: Integer);
40	procedure ImageOp_B(dst, Src: TBitmap; xDst, yDst, xSrc, ySrc, Width, Height: Integer);
41	procedure ImageOp_BCC(Dst, Src: TBitmap;
42	xDst, yDst, xSrc, ySrc, Width, Height, Color1, Color2: Integer); overload;
43	procedure ImageOp_BCC(Dst, Src: TBitmap;
44	DstPos: TPoint; SrcRect: TRect; Color1, Color2: Integer); overload;
45	procedure ImageOp_CBC(Dst, Src: TBitmap; xDst, yDst, xSrc, ySrc, Width, Height,
46	Color0, Color2: Integer);
47	procedure ImageOp_CCC(bmp: TBitmap; x, y, Width, Height, Color0, Color1, Color2: Integer);
48	function BitBltCanvas(DestCanvas: TCanvas; X, Y, Width, Height: Integer;
49	SrcCanvas: TCanvas; XSrc, YSrc: Integer; Rop: DWORD = SRCCOPY): Boolean; overload;
50	function BitBltCanvas(Dest: TCanvas; DestRect: TRect;
51	Src: TCanvas; SrcPos: TPoint; Rop: DWORD = SRCCOPY): Boolean; overload;
52	function BitBltBitmap(Dest: TBitmap; X, Y, Width, Height: Integer;
53	Src: TBitmap; XSrc, YSrc: Integer; Rop: DWORD = SRCCOPY): Boolean; overload;
54	function BitBltBitmap(Dest: TBitmap; DestRect: TRect;
55	Src: TBitmap; SrcPos: TPoint; Rop: DWORD = SRCCOPY): Boolean; overload;
56	procedure SLine(ca: TCanvas; x0, x1, y: integer; cl: TColor);
57	procedure DLine(ca: TCanvas; x0, x1, y: integer; cl0, cl1: TColor);
58	procedure Frame(ca: TCanvas; x0, y0, x1, y1: integer; cl0, cl1: TColor);
59	procedure RFrame(ca: TCanvas; x0, y0, x1, y1: integer; cl0, cl1: TColor);
60	procedure CFrame(ca: TCanvas; x0, y0, x1, y1, Corner: integer; cl: TColor);
61	procedure FrameImage(ca: TCanvas; Src: TBitmap;
62	x, y, Width, Height, xSrc, ySrc: integer; IsControl: boolean = False);
63	procedure GlowFrame(Dst: TBitmap; x0, y0, Width, Height: integer; cl: TColor);
64	procedure InitOrnament;
65	procedure InitCityMark(T: TTexture);
66	procedure Fill(ca: TCanvas; Left, Top, Width, Height, xOffset, yOffset: integer); overload;
67	procedure Fill(Canvas: TCanvas; Rect: TRect; Offset: TPoint); overload;
68	procedure FillLarge(ca: TCanvas; x0, y0, x1, y1, xm: integer);
69	procedure FillSeamless(ca: TCanvas; Left, Top, Width, Height, xOffset, yOffset: integer;
70	const Texture: TBitmap);
71	procedure FillRectSeamless(ca: TCanvas; x0, y0, x1, y1, xOffset, yOffset: integer;
72	const Texture: TBitmap);
73	procedure PaintBackground(Form: TForm; Left, Top, Width, Height: integer);
74	procedure Corner(ca: TCanvas; x, y, Kind: integer; T: TTexture);
75	procedure BiColorTextOut(ca: TCanvas; clMain, clBack: TColor; x, y: integer; s: string);
76	procedure LoweredTextOut(ca: TCanvas; cl: TColor; T: TTexture;
77	x, y: integer; s: string);
78	function BiColorTextWidth(ca: TCanvas; s: string): integer;
79	procedure RisedTextOut(ca: TCanvas; x, y: integer; s: string);
80	procedure LightGradient(ca: TCanvas; x, y, Width, Color: integer);
81	procedure DarkGradient(ca: TCanvas; x, y, Width, Kind: integer);
82	procedure VLightGradient(ca: TCanvas; x, y, Height, Color: integer);
83	procedure VDarkGradient(ca: TCanvas; x, y, Height, Kind: integer);
84	procedure UnderlinedTitleValue(Canvas: TCanvas; Title, Value: string; X, Y, Width: Integer);
85	procedure NumberBar(dst: TBitmap; x, y: integer; Cap: string; val: integer;
86	T: TTexture);
87	procedure CountBar(dst: TBitmap; x, y, w: integer; Kind: integer;
88	Cap: string; val: integer; T: TTexture);
89	procedure PaintProgressBar(ca: TCanvas; Kind, x, y, pos, Growth, max: integer;
90	T: TTexture);
91	procedure PaintRelativeProgressBar(ca: TCanvas;
92	Kind, x, y, size, pos, Growth, max: integer; IndicateComplete: boolean;
93	T: TTexture);
94	procedure PaintLogo(Canvas: TCanvas; X, Y, LightColor, ShadeColor: integer);
95	procedure LoadPhrases;
96	procedure Texturize(Dest, Texture: TBitmap; TransparentColor: Cardinal);
97	procedure DarkenImage(Bitmap: TBitmap; Change: Integer);
98	function ScaleToNative(Value: Integer): Integer;
99	function ScaleFromNative(Value: Integer): Integer;
100	procedure UnshareBitmap(Bitmap: TBitmap);
101	procedure Gtk2Fix;
102
103	const
104	TransparentColor1 = $FF00FF;
105	TransparentColor2 = $7F007F;
106
107	// template positions in Templates.png
108	xNation = 1;
109	yNation = 25;
110	xCoal = 1;
111	yCoal = 148;
112
113	// Icons.bmp structure
114	xSizeBig = 56;
115	ySizeBig = 40;
116
117	GlowRange = 8;
118
119	EmptySpaceColor = $101010;
120
121	// color matrix
122	clkAge0 = 1;
123	cliTexture = 0;
124	cliBevelLight = cliTexture + 1;
125	cliBevelShade = cliTexture + 2;
126	cliTextLight = cliTexture + 3;
127	cliTextShade = cliTexture + 4;
128	cliLitText = cliTexture + 5;
129	cliMark = cliTexture + 6;
130	cliDimmedText = cliTexture + 7;
131	cliRoad = 8;
132	cliHouse = cliRoad + 1;
133	cliImp = cliRoad + 2;
134	cliImpProject = cliRoad + 3;
135	cliPage = 13;
136	cliCover = cliPage + 1;
137	clkMisc = 5;
138	cliPaper = 0;
139	cliPaperText = 1;
140	cliPaperCaption = 2;
141	clkCity = 6;
142	cliPlains = 0;
143	cliPrairie = 1;
144	cliHills = 2;
145	cliTundra = 3;
146	cliWater = 4;
147
148	var
149	Phrases: TStringTable;
150	Phrases2: TStringTable;
151	GrExt: TGraphicSets;
152
153	HGrSystem: TGraphicSet;
154	CityMark1: TGraphicSetItem;
155	CityMark2: TGraphicSetItem;
156
157	HGrSystem2: TGraphicSet;
158	Ornament: TGraphicSetItem;
159	GBrainNoTerm: TGraphicSetItem;
160	GBrainSuperVirtual: TGraphicSetItem;
161	GBrainTerm: TGraphicSetItem;
162	GBrainRandom: TGraphicSetItem;
163
164	Templates: TGraphicSet;
165	Logo: TGraphicSetItem;
166	BigBook: TGraphicSetItem;
167	SmallBook: TGraphicSetItem;
168	MenuLogo: TGraphicSetItem;
169	LinkArrows: TGraphicSetItem;
170	ScienceNationDot: TGraphicSetItem;
171	ResearchIcon: TGraphicSetItem;
172	ChangeIcon: TGraphicSetItem;
173	TreasuryIcon: TGraphicSetItem;
174	StarshipDeparted: TGraphicSetItem;
175	WeightOn: TGraphicSetItem;
176	WeightOff: TGraphicSetItem;
177
178	ClickFrameColor: Integer;
179	MainTexture: TTexture;
180	Colors: TBitmap;
181	Paper: TBitmap;
182	BigImp: TBitmap;
183	LogoBuffer: TBitmap;
184	FullScreen: Boolean;
185	GenerateNames: Boolean;
186	InitOrnamentDone: Boolean;
187	Phrases2FallenBackToEnglish: Boolean;
188
189	UniFont: array [TFontType] of TFont;
190	Gamma: Integer; // global gamma correction (cent)
191
192	procedure LoadAssets;
193	procedure UnitInit;
194	procedure UnitDone;
195	procedure InitGammaLookupTable;
196
197
198	implementation
199
200	uses
201	Directories, Sound, UPixelPointer;
202
203	var
204	{$IFDEF WINDOWS}
205	StartResolution: TDeviceMode;
206	ResolutionChanged: boolean;
207	{$ENDIF}
208
209	GammaLookupTable: array [0..255] of Byte;
210
211	{$IFDEF WINDOWS}
212	function ChangeResolution(x, y, bpp, freq: integer): boolean;
213	var
214	DevMode: TDeviceMode;
215	begin
216	EnumDisplaySettings(nil, 0, DevMode);
217	DevMode.dmFields := DM_PELSWIDTH or DM_PELSHEIGHT or DM_BITSPERPEL or
218	DM_DISPLAYFREQUENCY;
219	DevMode.dmPelsWidth := x;
220	DevMode.dmPelsHeight := y;
221	DevMode.dmBitsPerPel := bpp;
222	DevMode.dmDisplayFrequency := freq;
223	Result := ChangeDisplaySettings(DevMode, 0) = DISP_CHANGE_SUCCESSFUL;
224	if Result then
225	ResolutionChanged := True;
226	end;
227
228	{$ENDIF}
229
230	procedure RestoreResolution;
231	begin
232	{$IFDEF WINDOWS}
233	if ResolutionChanged then
234	ChangeDisplaySettings(StartResolution, 0);
235	ResolutionChanged := False;
236	{$ENDIF}
237	end;
238
239	procedure EmptyMenu(MenuItems: TMenuItem; Keep: Integer = 0);
240	var
241	MenuItem: TMenuItem;
242	begin
243	while MenuItems.Count > Keep do begin
244	MenuItem := MenuItems[MenuItems.Count - 1];
245	MenuItems.Delete(MenuItems.Count - 1);
246	FreeAndNil(MenuItem);
247	end;
248	end;
249
250	function TurnToYear(Turn: Integer): Integer;
251	begin
252	Result := -4000;
253	if Turn <= 0 then Exit;
254
255	// Year -4000..-1000, Turn 0..60
256	Inc(Result, Min(60, Turn) * 50);
257	Dec(Turn, Min(60, Turn));
258	if Turn = 0 then Exit;
259
260	// Year -1000..0, Turn 60..100
261	Inc(Result, Min(40, Turn) * 25);
262	Dec(Turn, Min(40, Turn));
263	if Turn = 0 then Exit;
264
265	// Year 0..1500, Turn 100..175
266	Inc(Result, Min(75, Turn) * 20);
267	Dec(Turn, Min(75, Turn));
268	if Turn = 0 then Exit;
269
270	// Year 1500..1750, Turn 175..200
271	Inc(Result, Min(25, Turn) * 10);
272	Dec(Turn, Min(25, Turn));
273	if Turn = 0 then Exit;
274
275	// Year 1750..1850, Turn 200..250
276	Inc(Result, Min(50, Turn) * 2);
277	Dec(Turn, Min(50, Turn));
278	if Turn = 0 then Exit;
279
280	// Year 1850.., Turn 250..
281	Inc(Result, Turn);
282	end;
283
284	function TurnToString(Turn: Integer): string;
285	var
286	Year: Integer;
287	begin
288	if GenerateNames then
289	begin
290	Year := TurnToYear(Turn);
291	if Year < 0 then
292	Result := Format(Phrases.Lookup('BC'), [-Year])
293	else
294	Result := Format(Phrases.Lookup('AD'), [Year]);
295	end
296	else
297	Result := IntToStr(Turn);
298	end;
299
300	function MovementToString(Movement: Integer): string;
301	begin
302	if Movement >= 1000 then
303	begin
304	Result := Char(48 + Movement div 1000);
305	Movement := Movement mod 1000;
306	end
307	else
308	Result := '';
309	Result := Result + Char(48 + Movement div 100);
310	Movement := Movement mod 100;
311	if Movement > 0 then
312	begin
313	Result := Result + '.' + Char(48 + Movement div 10);
314	Movement := Movement mod 10;
315	if Movement > 0 then
316	Result := Result + Char(48 + Movement);
317	end;
318	end;
319
320	procedure BtnFrame(ca: TCanvas; p: TRect; T: TTexture);
321	begin
322	RFrame(ca, p.Left - 1, p.Top - 1, p.Right, p.Bottom, T.ColorBevelShade,
323	T.ColorBevelLight);
324	end;
325
326	procedure EditFrame(ca: TCanvas; p: TRect; T: TTexture);
327	begin
328	Frame(ca, p.Left - 1, p.Top - 1, p.Right, p.Bottom, $000000, $000000);
329	Frame(ca, p.Left - 2, p.Top - 2, p.Right + 1, p.Bottom + 1, $000000, $000000);
330	Frame(ca, p.Left - 3, p.Top - 3, p.Right + 2, p.Bottom + 1, $000000, $000000);
331	RFrame(ca, p.Left - 4, p.Top - 4, p.Right + 3, p.Bottom + 2, T.ColorBevelShade,
332	T.ColorBevelLight);
333	end;
334
335	function HexCharToInt(X: Char): Integer;
336	begin
337	case x of
338	'0' .. '9': Result := Ord(X) - Ord('0');
339	'A' .. 'F': Result := Ord(X) - Ord('A') + 10;
340	'a' .. 'f': Result := Ord(X) - Ord('a') + 10;
341	else Result := 0
342	end;
343	end;
344
345	function HexStringToColor(S: string): Integer;
346	begin
347	while (Length(S) > 0) and (S[1] = ' ') do
348	Delete(S, 1, 1);
349	S := S + '000000';
350	if Gamma = 100 then
351	Result := $10 * HexCharToInt(S[1]) + $1 * HexCharToInt(S[2]) +
352	$1000 * HexCharToInt(S[3]) + $100 * HexCharToInt(S[4]) +
353	$100000 * HexCharToInt(S[5]) + $10000 * HexCharToInt(S[6])
354	else
355	Result := GammaLookupTable[$10 * HexCharToInt(S[1]) + HexCharToInt(S[2])] +
356	$100 * GammaLookupTable[$10 * HexCharToInt(S[3]) + HexCharToInt(S[4])] +
357	$10000 * GammaLookupTable[$10 * HexCharToInt(S[5]) + HexCharToInt(S[6])];
358	end;
359
360	function ApplyGammaToPixel(Pixel: TPixel32): TPixel32;
361	begin
362	Result.R := GammaLookupTable[Pixel.R];
363	Result.G := GammaLookupTable[Pixel.G];
364	Result.B := GammaLookupTable[Pixel.B];
365	end;
366
367	procedure ApplyGammaToBitmap(Bitmap: TBitmap);
368	var
369	PixelPtr: TPixelPointer;
370	X, Y: Integer;
371	begin
372	Bitmap.BeginUpdate;
373	PixelPtr := PixelPointer(Bitmap);
374	for Y := 0 to ScaleToNative(Bitmap.Height) - 1 do begin
375	for X := 0 to ScaleToNative(Bitmap.Width) - 1 do begin
376	PixelPtr.Pixel^ := ApplyGammaToPixel(PixelPtr.Pixel^);
377	PixelPtr.NextPixel;
378	end;
379	PixelPtr.NextLine;
380	end;
381	Bitmap.EndUpdate;
382	end;
383
384	procedure CopyGray8BitTo24bitBitmap(Dst, Src: TRasterImage);
385	var
386	SrcPtr, DstPtr: TPixelPointer;
387	X, Y: Integer;
388	begin
389	//Dst.SetSize(Src.Width, Src.Height);
390	SrcPtr := PixelPointer(Src);
391	DstPtr := PixelPointer(Dst);
392	for Y := 0 to ScaleToNative(Src.Height - 1) do begin
393	for X := 0 to ScaleToNative(Src.Width - 1) do begin
394	DstPtr.Pixel^.B := SrcPtr.Pixel^.B;
395	DstPtr.Pixel^.G := SrcPtr.Pixel^.B;
396	DstPtr.Pixel^.R := SrcPtr.Pixel^.B;
397	SrcPtr.NextPixel;
398	DstPtr.NextPixel;
399	end;
400	SrcPtr.NextLine;
401	DstPtr.NextLine;
402	end;
403	end;
404
405	function LoadGraphicFile(Bmp: TBitmap; FileName: string; Options:
406	TLoadGraphicFileOptions = []): Boolean;
407	var
408	Jpeg: TJpegImage;
409	Png: TPortableNetworkGraphic;
410	begin
411	Result := False;
412	if ExtractFileExt(FileName) = '' then
413	FileName := FileName + '.png';
414
415	if FileExists(FileName) then begin
416	if ExtractFileExt(FileName) = '.jpg' then begin
417	Jpeg := TJpegImage.Create;
418	try
419	Jpeg.LoadFromFile(FileName);
420	if not (gfNoGamma in Options) then
421	Bmp.PixelFormat := pf24bit;
422	Bmp.SetSize(Jpeg.Width, Jpeg.Height);
423	Bmp.Canvas.Draw(0, 0, Jpeg);
424	Result := True;
425	except
426	Result := False;
427	end;
428	FreeAndNil(Jpeg);
429	end else
430	if ExtractFileExt(FileName) = '.png' then begin
431	Png := TPortableNetworkGraphic.Create;
432	try
433	Png.PixelFormat := Bmp.PixelFormat;
434	Png.LoadFromFile(FileName);
435	if not (gfNoGamma in Options) then
436	Bmp.PixelFormat := pf24bit;
437	Bmp.SetSize(Png.Width, Png.Height);
438	if (Png.RawImage.Description.Format = ricfGray) then
439	begin
440	// LCL doesn't support 8-bit colors properly. Use 24-bit instead.
441	Bmp.PixelFormat := pf24bit;
442	CopyGray8BitTo24bitBitmap(Bmp, Png);
443	end
444	else
445	Bmp.Canvas.Draw(0, 0, Png);
446	Result := True;
447	except
448	Result := False;
449	end;
450	FreeAndNil(Png);
451	end else
452	if ExtractFileExt(FileName) = '.bmp' then begin
453	try
454	Bmp.LoadFromFile(FileName);
455	if not (gfNoGamma in Options) then
456	Bmp.PixelFormat := pf24bit;
457	Result := True;
458	except
459	Result := False;
460	end;
461	end else
462	raise Exception.Create('Unsupported image file type ' + ExtractFileExt(FileName));
463	end;
464
465	if not Result then begin
466	if not (gfNoError in Options) then
467	raise Exception.Create(Format(Phrases.Lookup('FILENOTFOUND'), [FileName]));
468	end;
469
470	if (not (gfNoGamma in Options)) and (Gamma <> 100) then
471	ApplyGammaToBitmap(Bmp);
472	end;
473
474	function ExtractFileNameWithoutExt(const Filename: string): string;
475	var
476	P: Integer;
477	begin
478	Result := Filename;
479	P := Length(Result);
480	while P > 0 do begin
481	case Result[P] of
482	PathDelim: Exit;
483	{$ifdef windows}
484	'/': if ('/' in AllowDirectorySeparators) then Exit;
485	{$endif}
486	'.': Exit(Copy(Result, 1, P - 1));
487	end;
488	Dec(P);
489	end;
490	end;
491
492	function LoadGraphicSet(const Name: string; Transparency: Boolean = True): TGraphicSet;
493	var
494	x: Integer;
495	y: Integer;
496	OriginalColor: Integer;
497	FileName: string;
498	DataPixel: TPixelPointer;
499	MaskPixel: TPixelPointer;
500	begin
501	Result := GrExt.SearchByName(Name);
502	if not Assigned(Result) then begin
503	Result := GrExt.AddNew(Name);
504	FileName := GetGraphicsDir + DirectorySeparator + Name;
505	// Do not apply gamma during file load as it would affect also transparency colors
506	if not LoadGraphicFile(Result.Data, FileName, [gfNoGamma]) then begin
507	Result := nil;
508	Exit;
509	end;
510
511	FileName := ExtractFileNameWithoutExt(FileName) + GraphicSetFileExt;
512	if FileExists(FileName) then
513	Result.LoadFromFile(FileName);
514
515	Result.ResetPixUsed;
516
517	if Transparency then begin
518	Result.Mask.SetSize(Result.Data.Width, Result.Data.Height);
519
520	Result.Data.BeginUpdate;
521	Result.Mask.BeginUpdate;
522	DataPixel := PixelPointer(Result.Data);
523	MaskPixel := PixelPointer(Result.Mask);
524	for y := 0 to ScaleToNative(Result.Data.Height) - 1 do begin
525	for x := 0 to ScaleToNative(Result.Data.Width) - 1 do begin
526	OriginalColor := DataPixel.Pixel^.ARGB and $FFFFFF;
527	if (OriginalColor = TransparentColor1) or (OriginalColor = TransparentColor2) then begin
528	MaskPixel.Pixel^.R := $FF;
529	MaskPixel.Pixel^.G := $FF;
530	MaskPixel.Pixel^.B := $FF;
531	DataPixel.Pixel^.R := 0;
532	DataPixel.Pixel^.G := 0;
533	DataPixel.Pixel^.B := 0;
534	end else begin
535	MaskPixel.Pixel^.R := $00;
536	MaskPixel.Pixel^.G := $00;
537	MaskPixel.Pixel^.B := $00;
538	end;
539	DataPixel.NextPixel;
540	MaskPixel.NextPixel;
541	end;
542	DataPixel.NextLine;
543	MaskPixel.NextLine;
544	end;
545	Result.Data.EndUpdate;
546	Result.Mask.EndUpdate;
547
548	if Gamma <> 100 then
549	ApplyGammaToBitmap(Result.Data);
550	end;
551	end;
552	end;
553
554	procedure Dump(dst: TBitmap; HGr: TGraphicSet; xDst, yDst, Width, Height, xGr, yGr: integer);
555	begin
556	BitBltCanvas(dst.Canvas, xDst, yDst, Width, Height,
557	HGr.Data.Canvas, xGr, yGr);
558	end;
559
560	procedure BitmapReplaceColor(Dst: TBitmap; X, Y, Width, Height: Integer; OldColor, NewColor: TColor);
561	var
562	XX, YY: Integer;
563	PixelPtr: TPixelPointer;
564	begin
565	Dst.BeginUpdate;
566	PixelPtr := PixelPointer(Dst, ScaleToNative(X), ScaleToNative(Y));
567	for YY := 0 to ScaleToNative(Height) - 1 do begin
568	for XX := 0 to ScaleToNative(Width) - 1 do begin
569	if PixelPtr.Pixel^.RGB = SwapRedBlue(OldColor) then begin
570	PixelPtr.Pixel^.RGB := SwapRedBlue(NewColor);
571	end;
572	PixelPtr.NextPixel;
573	end;
574	PixelPtr.NextLine;
575	end;
576	Dst.EndUpdate;
577	end;
578
579	procedure MakeBlue(Dst: TBitmap; X, Y, Width, Height: Integer);
580	var
581	XX, YY: Integer;
582	PixelPtr: TPixelPointer;
583	begin
584	Dst.BeginUpdate;
585	PixelPtr := PixelPointer(Dst, ScaleToNative(X), ScaleToNative(Y));
586	for yy := 0 to ScaleToNative(Height) - 1 do begin
587	for xx := 0 to ScaleToNative(Width) - 1 do begin
588	PixelPtr.Pixel^.B := PixelPtr.Pixel^.B div 2;
589	PixelPtr.Pixel^.G := PixelPtr.Pixel^.G div 2;
590	PixelPtr.Pixel^.R := PixelPtr.Pixel^.R div 2;
591	PixelPtr.NextPixel;
592	end;
593	PixelPtr.NextLine;
594	end;
595	Dst.EndUpdate;
596	end;
597
598	procedure MakeRed(Dst: TBitmap; X, Y, Width, Height: Integer);
599	var
600	XX, YY: Integer;
601	Gray: Integer;
602	PixelPtr: TPixelPointer;
603	begin
604	Dst.BeginUpdate;
605	PixelPtr := PixelPointer(Dst, ScaleToNative(X), ScaleToNative(Y));
606	for YY := 0 to ScaleToNative(Height) - 1 do begin
607	for XX := 0 to ScaleToNative(Width) - 1 do begin
608	Gray := (Integer(PixelPtr.Pixel^.B) + Integer(PixelPtr.Pixel^.G) +
609	Integer(PixelPtr.Pixel^.R)) * 85 shr 8;
610	PixelPtr.Pixel^.B := 0;
611	PixelPtr.Pixel^.G := 0;
612	PixelPtr.Pixel^.R := Gray; // 255-(255-gray) div 2;
613	PixelPtr.NextPixel;
614	end;
615	PixelPtr.NextLine;
616	end;
617	Dst.EndUpdate;
618	end;
619
620	procedure ImageOp_B(dst, Src: TBitmap; xDst, yDst, xSrc, ySrc, Width, Height: Integer);
621	// Src is template
622	// X channel = background amp (old Dst content), 128=original brightness
623	var
624	X, Y: Integer;
625	Brightness, Test: Integer;
626	PixelSrc: TPixelPointer;
627	PixelDst: TPixelPointer;
628	begin
629	xDst := ScaleToNative(xDst);
630	yDst := ScaleToNative(yDst);
631	xSrc := ScaleToNative(xSrc);
632	ySrc := ScaleToNative(ySrc);
633	Width := ScaleToNative(Width);
634	Height := ScaleToNative(Height);
635	//Assert(Src.PixelFormat = pf8bit);
636	Assert(dst.PixelFormat = pf24bit);
637	if xDst < 0 then begin
638	Width := Width + xDst;
639	xSrc := xSrc - xDst;
640	xDst := 0;
641	end;
642	if yDst < 0 then begin
643	Height := Height + yDst;
644	ySrc := ySrc - yDst;
645	yDst := 0;
646	end;
647	if xDst + Width > ScaleToNative(dst.Width) then
648	Width := ScaleToNative(dst.Width) - xDst;
649	if yDst + Height > ScaleToNative(dst.Height) then
650	Height := ScaleToNative(dst.Height) - yDst;
651	if (Width < 0) or (Height < 0) then
652	exit;
653
654	dst.BeginUpdate;
655	Src.BeginUpdate;
656	PixelDst := PixelPointer(Dst, xDst, yDst);
657	PixelSrc := PixelPointer(Src, xSrc, ySrc);
658	for Y := 0 to Height - 1 do begin
659	for X := 0 to Width - 1 do begin
660	Brightness := PixelSrc.Pixel^.B; // One byte for 8-bit color
661	test := (PixelDst.Pixel^.R * Brightness) shr 7;
662	if test >= 256 then
663	PixelDst.Pixel^.R := 255
664	else
665	PixelDst.Pixel^.R := test; // Red
666	test := (PixelDst.Pixel^.G * Brightness) shr 7;
667	if test >= 256 then
668	PixelDst.Pixel^.G := 255
669	else
670	PixelDst.Pixel^.G := test; // Green
671	test := (PixelDst.Pixel^.B * Brightness) shr 7;
672	if test >= 256 then
673	PixelDst.Pixel^.R := 255
674	else
675	PixelDst.Pixel^.B := Test; // Blue
676	PixelDst.NextPixel;
677	PixelSrc.NextPixel;
678	end;
679	PixelDst.NextLine;
680	PixelSrc.NextLine;
681	end;
682	src.EndUpdate;
683	dst.EndUpdate;
684	end;
685
686	procedure ImageOp_BCC(dst, Src: TBitmap; xDst, yDst, xSrc, ySrc, Width, Height,
687	Color1, Color2: Integer);
688	// Src is template
689	// B channel = background amp (old Dst content), 128=original brightness
690	// G channel = Color1 amp, 128=original brightness
691	// R channel = Color2 amp, 128=original brightness
692	var
693	ix, iy, amp1, amp2, trans, Value: Integer;
694	SrcPixel: TPixelPointer;
695	DstPixel: TPixelPointer;
696	begin
697	xDst := ScaleToNative(xDst);
698	yDst := ScaleToNative(yDst);
699	xSrc := ScaleToNative(xSrc);
700	ySrc := ScaleToNative(ySrc);
701	Width := ScaleToNative(Width);
702	Height := ScaleToNative(Height);
703	if xDst < 0 then begin
704	Width := Width + xDst;
705	xSrc := xSrc - xDst;
706	xDst := 0;
707	end;
708	if yDst < 0 then begin
709	Height := Height + yDst;
710	ySrc := ySrc - yDst;
711	yDst := 0;
712	end;
713	if xDst + Width > ScaleToNative(dst.Width) then
714	Width := ScaleToNative(dst.Width) - xDst;
715	if yDst + Height > ScaleToNative(dst.Height) then
716	Height := ScaleToNative(dst.Height) - yDst;
717	if (Width < 0) or (Height < 0) then
718	exit;
719
720	Src.BeginUpdate;
721	dst.BeginUpdate;
722	SrcPixel := PixelPointer(Src, xSrc, ySrc);
723	DstPixel := PixelPointer(Dst, xDst, yDst);
724	for iy := 0 to Height - 1 do begin
725	for ix := 0 to Width - 1 do begin
726	trans := SrcPixel.Pixel^.B * 2; // green channel = transparency
727	amp1 := SrcPixel.Pixel^.G * 2;
728	amp2 := SrcPixel.Pixel^.R * 2;
729	if trans <> $FF then begin
730	Value := (DstPixel.Pixel^.B * trans + ((Color2 shr 16) and $FF) *
731	amp2 + ((Color1 shr 16) and $FF) * amp1) div $FF;
732	DstPixel.Pixel^.B := Min(Value, 255);
733
734	Value := (DstPixel.Pixel^.G * trans + ((Color2 shr 8) and $FF) *
735	amp2 + ((Color1 shr 8) and $FF) * amp1) div $FF;
736	DstPixel.Pixel^.G := Min(Value, 255);
737
738	Value := (DstPixel.Pixel^.R * trans + (Color2 and $FF) *
739	amp2 + (Color1 and $FF) * amp1) div $FF;
740	DstPixel.Pixel^.R := Min(Value, 255);
741	end;
742
743	SrcPixel.NextPixel;
744	DstPixel.NextPixel;
745	end;
746	SrcPixel.NextLine;
747	DstPixel.NextLine;
748	end;
749	Src.EndUpdate;
750	dst.EndUpdate;
751	end;
752
753	procedure ImageOp_BCC(Dst, Src: TBitmap; DstPos: TPoint; SrcRect: TRect;
754	Color1, Color2: Integer);
755	begin
756	ImageOp_BCC(Dst, Src, DstPos.X, DstPos.Y, SrcRect.Left, SrcRect.Top,
757	SrcRect.Width, SrcRect.Height, Color1, Color2);
758	end;
759
760	procedure ImageOp_CBC(Dst, Src: TBitmap; xDst, yDst, xSrc, ySrc, Width, Height,
761	Color0, Color2: Integer);
762	// Src is template
763	// B channel = Color0 amp
764	// G channel = background amp (old Dst content), 128=original brightness
765	// R channel = Color2 amp
766	var
767	ix, iy, amp0, amp1, trans, Value: integer;
768	SrcPixel: TPixelPointer;
769	DstPixel: TPixelPointer;
770	begin
771	xDst := ScaleToNative(xDst);
772	yDst := ScaleToNative(yDst);
773	xSrc := ScaleToNative(xSrc);
774	ySrc := ScaleToNative(ySrc);
775	Width := ScaleToNative(Width);
776	Height := ScaleToNative(Height);
777	Src.BeginUpdate;
778	Dst.BeginUpdate;
779	SrcPixel := PixelPointer(Src, xSrc, ySrc);
780	DstPixel := PixelPointer(Dst, xDst, yDst);
781	for iy := 0 to Height - 1 do begin
782	for ix := 0 to Width - 1 do begin
783	trans := SrcPixel.Pixel^.B * 2; // green channel = transparency
784	amp0 := SrcPixel.Pixel^.G * 2;
785	amp1 := SrcPixel.Pixel^.R * 2;
786	if trans <> $FF then begin
787	Value := (DstPixel.Pixel^.B * trans + (Color2 shr 16 and $FF) * amp1 +
788	(Color0 shr 16 and $FF) * amp0) div $FF;
789	DstPixel.Pixel^.B := Min(Value, 255);
790
791	Value := (DstPixel.Pixel^.G * trans + (Color2 shr 8 and $FF) * amp1 +
792	(Color0 shr 8 and $FF) * amp0) div $FF;
793	DstPixel.Pixel^.G := Min(Value, 255);
794
795	Value := (DstPixel.Pixel^.R * trans + (Color2 and $FF) * amp1 +
796	(Color0 and $FF) * amp0) div $FF;
797	DstPixel.Pixel^.R := Min(Value, 255);
798	end;
799	SrcPixel.NextPixel;
800	DstPixel.NextPixel;
801	end;
802	SrcPixel.NextLine;
803	DstPixel.NextLine;
804	end;
805	Src.EndUpdate;
806	Dst.EndUpdate;
807	end;
808
809	procedure ImageOp_CCC(bmp: TBitmap; x, y, Width, Height, Color0, Color1, Color2: Integer);
810	// Bmp is template
811	// B channel = Color0 amp, 128=original brightness
812	// G channel = Color1 amp, 128=original brightness
813	// R channel = Color2 amp, 128=original brightness
814	var
815	i, Red, Green: Integer;
816	PixelPtr: TPixelPointer;
817	begin
818	X := ScaleToNative(X);
819	Y := ScaleToNative(Y);
820	Width := ScaleToNative(Width);
821	Height := ScaleToNative(Height);
822	bmp.BeginUpdate;
823	assert(bmp.PixelFormat = pf24bit);
824	Height := y + Height;
825	PixelPtr := PixelPointer(Bmp, x, y);
826	while y < Height do begin
827	for i := 0 to Width - 1 do begin
828	Red := ((PixelPtr.Pixel^.B * (Color0 and $0000FF) + PixelPtr.Pixel^.G *
829	(Color1 and $0000FF) + PixelPtr.Pixel^.R * (Color2 and $0000FF)) shr 8) and $ff;
830	Green := ((PixelPtr.Pixel^.B * ((Color0 shr 8) and $0000FF) +
831	PixelPtr.Pixel^.G * ((Color1 shr 8) and $0000FF) + PixelPtr.Pixel^.R *
832	((Color2 shr 8) and $0000FF)) shr 8) and $ff;
833	PixelPtr.Pixel^.B := ((PixelPtr.Pixel^.B * ((Color0 shr 16) and $0000FF) +
834	PixelPtr.Pixel^.G * ((Color1 shr 16) and $0000FF) + PixelPtr.Pixel^.R *
835	((Color2 shr 16) and $0000FF)) shr 8) and $ff; // Blue
836	PixelPtr.Pixel^.G := Green;
837	PixelPtr.Pixel^.R := Red;
838	PixelPtr.NextPixel;
839	end;
840	Inc(y);
841	PixelPtr.NextLine;
842	end;
843	bmp.EndUpdate;
844	end;
845
846	procedure Sprite(Canvas: TCanvas; HGr: TGraphicSet; xDst, yDst, Width, Height, xGr, yGr: integer);
847	begin
848	BitBltCanvas(Canvas, xDst, yDst, Width, Height,
849	HGr.Mask.Canvas, xGr, yGr, SRCAND);
850	BitBltCanvas(Canvas, xDst, yDst, Width, Height,
851	HGr.Data.Canvas, xGr, yGr, SRCPAINT);
852	end;
853
854	procedure Sprite(dst: TBitmap; HGr: TGraphicSet; xDst, yDst, Width, Height, xGr, yGr: integer);
855	begin
856	BitBltCanvas(dst.Canvas, xDst, yDst, Width, Height,
857	HGr.Mask.Canvas, xGr, yGr, SRCAND);
858	BitBltCanvas(dst.Canvas, xDst, yDst, Width, Height,
859	HGr.Data.Canvas, xGr, yGr, SRCPAINT);
860	end;
861
862	function BitBltCanvas(DestCanvas: TCanvas; X, Y, Width, Height: Integer;
863	SrcCanvas: TCanvas; XSrc, YSrc: Integer; Rop: DWORD = SRCCOPY): Boolean;
864	begin
865	{$IFDEF WINDOWS}
866	// LCLIntf.BitBlt is slower than direct Windows BitBlt
867	Result := Windows.BitBlt(DestCanvas.Handle, X, Y, Width, Height, SrcCanvas.Handle, XSrc, YSrc, Rop);
868	{$ELSE}
869	Result := BitBlt(DestCanvas.Handle, X, Y, Width, Height, SrcCanvas.Handle, XSrc, YSrc, Rop);
870	{$ENDIF}
871	end;
872
873	function BitBltCanvas(Dest: TCanvas; DestRect: TRect; Src: TCanvas;
874	SrcPos: TPoint; Rop: DWORD): Boolean;
875	begin
876	Result := BitBltCanvas(Dest, DestRect.Left, DestRect.Top, DestRect.Width, DestRect.Height,
877	Src, SrcPos.X, SrcPos.Y, Rop);
878	end;
879
880	function BitBltBitmap(Dest: TBitmap; X, Y, Width, Height: Integer;
881	Src: TBitmap; XSrc, YSrc: Integer; Rop: DWORD): Boolean;
882	begin
883	Result := BitBltCanvas(Dest.Canvas, X, Y, Width, Height, Src.Canvas, XSrc, YSrc, Rop);
884	end;
885
886	function BitBltBitmap(Dest: TBitmap; DestRect: TRect; Src: TBitmap;
887	SrcPos: TPoint; Rop: DWORD): Boolean;
888	begin
889	Result := BitBltCanvas(Dest.Canvas, DestRect, Src.Canvas, SrcPos, Rop);
890	end;
891
892	procedure SLine(ca: TCanvas; x0, x1, y: integer; cl: TColor);
893	begin
894	with ca do begin
895	Pen.Color := cl;
896	MoveTo(x0, y);
897	LineTo(x1 + 1, y);
898	end;
899	end;
900
901	procedure DLine(ca: TCanvas; x0, x1, y: integer; cl0, cl1: TColor);
902	begin
903	with ca do begin
904	Pen.Color := cl0;
905	MoveTo(x0, y);
906	LineTo(x1, y);
907	Pen.Color := cl1;
908	MoveTo(x0 + 1, y + 1);
909	LineTo(x1 + 1, y + 1);
910	Pixels[x0, y + 1] := cl0;
911	Pixels[x1, y] := cl1;
912	end;
913	end;
914
915	procedure Frame(ca: TCanvas; x0, y0, x1, y1: integer; cl0, cl1: TColor);
916	begin
917	with ca do begin
918	MoveTo(x0, y1);
919	Pen.Color := cl0;
920	LineTo(x0, y0);
921	LineTo(x1, y0);
922	Pen.Color := cl1;
923	LineTo(x1, y1);
924	LineTo(x0, y1);
925	end;
926	end;
927
928	procedure RFrame(ca: TCanvas; x0, y0, x1, y1: integer; cl0, cl1: TColor);
929	begin
930	with ca do begin
931	Pen.Color := cl0;
932	MoveTo(x0, y0 + 1);
933	LineTo(x0, y1);
934	MoveTo(x0 + 1, y0);
935	LineTo(x1, y0);
936	Pen.Color := cl1;
937	MoveTo(x1, y0 + 1);
938	LineTo(x1, y1);
939	MoveTo(x0 + 1, y1);
940	LineTo(x1, y1);
941	end;
942	end;
943
944	procedure CFrame(ca: TCanvas; x0, y0, x1, y1, Corner: integer; cl: TColor);
945	begin
946	with ca do begin
947	Pen.Color := cl;
948	MoveTo(x0, y0 + Corner - 1);
949	LineTo(x0, y0);
950	LineTo(x0 + Corner, y0);
951	MoveTo(x1, y0 + Corner - 1);
952	LineTo(x1, y0);
953	LineTo(x1 - Corner, y0);
954	MoveTo(x1, y1 - Corner + 1);
955	LineTo(x1, y1);
956	LineTo(x1 - Corner, y1);
957	MoveTo(x0, y1 - Corner + 1);
958	LineTo(x0, y1);
959	LineTo(x0 + Corner, y1);
960	end;
961	end;
962
963	procedure FrameImage(ca: TCanvas; Src: TBitmap;
964	x, y, Width, Height, xSrc, ySrc: integer; IsControl: boolean = False);
965	begin
966	if IsControl then begin
967	Frame(ca, x - 1, y - 1, x + Width, y + Height, $B0B0B0, $FFFFFF);
968	RFrame(ca, x - 2, y - 2, x + Width + 1, y + Height + 1, $FFFFFF, $B0B0B0);
969	end else
970	Frame(ca, x - 1, y - 1, x + Width, y + Height, $000000, $000000);
971	BitBltCanvas(ca, x, y, Width, Height, Src.Canvas, xSrc, ySrc);
972	end;
973
974	procedure GlowFrame(Dst: TBitmap; x0, y0, Width, Height: Integer; cl: TColor);
975	var
976	x, y, ch, r: Integer;
977	DstPtr: TPixelPointer;
978	DpiGlowRange: Integer;
979	begin
980	DpiGlowRange := ScaleToNative(GlowRange);
981	X0 := ScaleToNative(X0);
982	Y0 := ScaleToNative(Y0);
983	Width := ScaleToNative(Width);
984	Height := ScaleToNative(Height);
985	Dst.BeginUpdate;
986	DstPtr := PixelPointer(Dst, x0 - DpiGlowRange + 1, y0 - DpiGlowRange + 1);
987	for y := -DpiGlowRange + 1 to Height - 1 + DpiGlowRange - 1 do begin
988	for x := -DpiGlowRange + 1 to Width - 1 + DpiGlowRange - 1 do begin
989	if x < 0 then
990	if y < 0 then
991	r := round(sqrt(sqr(x) + sqr(y)))
992	else if y >= Height then
993	r := round(sqrt(sqr(x) + sqr(y - (Height - 1))))
994	else
995	r := -x
996	else if x >= Width then
997	if y < 0 then
998	r := round(sqrt(sqr(x - (Width - 1)) + sqr(y)))
999	else if y >= Height then
1000	r := round(sqrt(sqr(x - (Width - 1)) + sqr(y - (Height - 1))))
1001	else
1002	r := x - (Width - 1)
1003	else if y < 0 then
1004	r := -y
1005	else if y >= Height then
1006	r := y - (Height - 1)
1007	else begin
1008	DstPtr.NextPixel;
1009	continue;
1010	end;
1011	if r = 0 then
1012	r := 1;
1013	if r < DpiGlowRange then
1014	for ch := 0 to 2 do
1015	DstPtr.Pixel^.Planes[2 - ch] :=
1016	(DstPtr.Pixel^.Planes[2 - ch] * (r - 1) + (cl shr (8 * ch) and $FF) *
1017	(DpiGlowRange - r)) div (DpiGlowRange - 1);
1018	DstPtr.NextPixel;
1019	end;
1020	DstPtr.NextLine;
1021	end;
1022	Dst.EndUpdate;
1023	end;
1024
1025	procedure InitOrnament;
1026	var
1027	P: TColor;
1028	X, Y: Integer;
1029	Light, Shade: TColor32;
1030	PixelPtr: TPixelPointer;
1031	begin
1032	if InitOrnamentDone then Exit;
1033	Light := ColorToColor32(MainTexture.ColorBevelLight);
1034	// and $FCFCFC shr 2*3+MainTexture.ColorBevelShade and $FCFCFC shr 2;
1035	Shade := ColorToColor32(MainTexture.ColorBevelShade and $FCFCFC shr 2 * 3 +
1036	MainTexture.ColorBevelLight and $FCFCFC shr 2);
1037	HGrSystem2.Data.BeginUpdate;
1038	PixelPtr := PixelPointer(HGrSystem2.Data, ScaleToNative(Ornament.Left),
1039	ScaleToNative(Ornament.Top));
1040	if PixelPtr.BytesPerPixel = 3 then begin
1041	for Y := 0 to ScaleToNative(Ornament.Height) - 1 do begin
1042	for X := 0 to ScaleToNative(Ornament.Width) - 1 do begin
1043	P := Color32ToColor(PixelPtr.Pixel^.RGB);
1044	if P = $0000FF then PixelPtr.Pixel^.RGB := Light
1045	else if P = $FF0000 then PixelPtr.Pixel^.RGB := Shade;
1046	PixelPtr.NextPixel;
1047	end;
1048	PixelPtr.NextLine;
1049	end;
1050	end else begin
1051	for Y := 0 to ScaleToNative(Ornament.Height) - 1 do begin
1052	for X := 0 to ScaleToNative(Ornament.Width) - 1 do begin
1053	P := Color32ToColor(PixelPtr.Pixel^.ARGB);
1054	if P = $0000FF then PixelPtr.Pixel^.ARGB := Light
1055	else if P = $FF0000 then PixelPtr.Pixel^.ARGB := Shade;
1056	PixelPtr.NextPixel;
1057	end;
1058	PixelPtr.NextLine;
1059	end;
1060	end;
1061	InitOrnamentDone := True;
1062	HGrSystem2.Data.EndUpdate;
1063	end;
1064
1065	procedure InitCityMark(T: TTexture);
1066	var
1067	x: Integer;
1068	y: Integer;
1069	Intensity: Integer;
1070	begin
1071	for x := 0 to CityMark1.Width - 1 do begin
1072	for y := 0 to CityMark1.Height - 1 do begin
1073	if HGrSystem.Mask.Canvas.Pixels[CityMark1.Left + x, CityMark1.Top + y] = 0 then
1074	begin
1075	Intensity := HGrSystem.Data.Canvas.Pixels[CityMark1.Left +
1076	x, CityMark1.Top + y] and $FF;
1077	HGrSystem.Data.Canvas.Pixels[CityMark2.Left + x, CityMark2.Top + y] :=
1078	T.ColorMark and $FF * Intensity div $FF + T.ColorMark shr 8 and
1079	$FF * Intensity div $FF shl 8 + T.ColorMark shr 16 and
1080	$FF * Intensity div $FF shl 16;
1081	end;
1082	end;
1083	end;
1084	BitBltCanvas(HGrSystem.Mask.Canvas, CityMark2.Left, CityMark2.Top, CityMark1.Width, CityMark1.Width,
1085	HGrSystem.Mask.Canvas, CityMark1.Left, CityMark1.Top);
1086	end;
1087
1088	procedure Fill(ca: TCanvas; Left, Top, Width, Height, xOffset, yOffset: Integer);
1089	begin
1090	Assert((Left + xOffset >= 0) and (Left + xOffset + Width <= MainTexture.Width) and
1091	(Top + yOffset >= 0) and (Top + yOffset + Height <= MainTexture.Height));
1092	BitBltCanvas(ca, Left, Top, Width, Height, MainTexture.Image.Canvas,
1093	Left + xOffset, Top + yOffset);
1094	end;
1095
1096	procedure Fill(Canvas: TCanvas; Rect: TRect; Offset: TPoint);
1097	begin
1098	Fill(Canvas, Rect.Left, Rect.Top, Rect.Width, Rect.Height, Offset.X, Offset.Y);
1099	end;
1100
1101	procedure FillLarge(ca: TCanvas; x0, y0, x1, y1, xm: Integer);
1102
1103	function Band(I: Integer): Integer;
1104	var
1105	n: integer;
1106	begin
1107	n := ((MainTexture.Height div 2) div (y1 - y0)) * 2;
1108	while MainTexture.Height div 2 + (I + 1) * (y1 - y0) > MainTexture.Height do
1109	Dec(I, n);
1110	while MainTexture.Height div 2 + I * (y1 - y0) < 0 do
1111	Inc(I, n);
1112	Result := I;
1113	end;
1114
1115	var
1116	I: Integer;
1117	begin
1118	for I := 0 to (x1 - xm) div MainTexture.Width - 1 do
1119	BitBltCanvas(ca, xm + I * MainTexture.Width, y0, MainTexture.Width, y1 - y0,
1120	MainTexture.Image.Canvas, 0, MainTexture.Height div 2 + Band(I) *
1121	(y1 - y0));
1122	BitBltCanvas(ca, xm + ((x1 - xm) div MainTexture.Width) * MainTexture.Width, y0,
1123	x1 - (xm + ((x1 - xm) div MainTexture.Width) * MainTexture.Width), y1 - y0,
1124	MainTexture.Image.Canvas, 0, MainTexture.Height div 2 + Band(
1125	(x1 - xm) div MainTexture.Width) * (y1 - y0));
1126	for I := 0 to (xm - x0) div MainTexture.Width - 1 do
1127	BitBltCanvas(ca, xm - (I + 1) * MainTexture.Width, y0, MainTexture.Width, y1 - y0,
1128	MainTexture.Image.Canvas, 0, MainTexture.Height div 2 +
1129	Band(-I - 1) * (y1 - y0));
1130	BitBltCanvas(ca, x0, y0, xm - ((xm - x0) div MainTexture.Width) *
1131	MainTexture.Width - x0, y1 - y0, MainTexture.Image.Canvas,
1132	((xm - x0) div MainTexture.Width + 1) * MainTexture.Width - (xm - x0),
1133	MainTexture.Height div 2 + Band(-(xm - x0) div MainTexture.Width - 1) * (y1 - y0));
1134	end;
1135
1136	procedure FillSeamless(ca: TCanvas; Left, Top, Width, Height, xOffset, yOffset: Integer;
1137	const Texture: TBitmap);
1138	var
1139	x, y, x0cut, y0cut, x1cut, y1cut: Integer;
1140	begin
1141	while xOffset < 0 do
1142	Inc(xOffset, Texture.Width);
1143	while yOffset < 0 do
1144	Inc(yOffset, Texture.Height);
1145	for y := (Top + yOffset) div Texture.Height to (Top + yOffset + Height - 1) div
1146	Texture.Height do
1147	begin
1148	y0cut := Top + yOffset - y * Texture.Height;
1149	if y0cut < 0 then
1150	y0cut := 0;
1151	y1cut := (y + 1) * Texture.Height - (Top + yOffset + Height);
1152	if y1cut < 0 then
1153	y1cut := 0;
1154	for x := (Left + xOffset) div Texture.Width to (Left + xOffset + Width - 1) div
1155	Texture.Width do
1156	begin
1157	x0cut := Left + xOffset - x * Texture.Width;
1158	if x0cut < 0 then
1159	x0cut := 0;
1160	x1cut := (x + 1) * Texture.Width - (Left + xOffset + Width);
1161	if x1cut < 0 then
1162	x1cut := 0;
1163	BitBltCanvas(ca, x * Texture.Width + x0cut - xOffset,
1164	y * Texture.Height + y0cut - yOffset, Texture.Width - x0cut - x1cut,
1165	Texture.Height - y0cut - y1cut, Texture.Canvas, x0cut, y0cut);
1166	end;
1167	end;
1168	end;
1169
1170	procedure FillRectSeamless(ca: TCanvas; x0, y0, x1, y1, xOffset, yOffset: Integer;
1171	const Texture: TBitmap);
1172	begin
1173	FillSeamless(ca, x0, y0, x1 - x0, y1 - y0, xOffset, yOffset, Texture);
1174	end;
1175
1176	procedure PaintBackground(Form: TForm; Left, Top, Width, Height: Integer);
1177	begin
1178	Fill(Form.Canvas, Left, Top, Width, Height, (MainTexture.Width - Form.ClientWidth) div
1179	2, (MainTexture.Height - Form.ClientHeight) div 2);
1180	end;
1181
1182	procedure Corner(ca: TCanvas; x, y, Kind: Integer; T: TTexture);
1183	begin
1184	{ BitBltCanvas(ca,x,y,8,8,T.HGr.Mask.Canvas,
1185	T.xGr+29+Kind*9,T.yGr+89,SRCAND);
1186	BitBltCanvas(ca,x,y,8,8,T.HGr.Data.Canvas,
1187	T.xGr+29+Kind*9,T.yGr+89,SRCPAINT); }
1188	end;
1189
1190	procedure BiColorTextOut(ca: TCanvas; clMain, clBack: TColor; x, y: Integer; s: string);
1191
1192	procedure PaintIcon(x, y, Kind: Integer);
1193	begin
1194	BitBltCanvas(ca, x, y + 6, 10, 10, HGrSystem.Mask.Canvas,
1195	66 + Kind mod 11 * 11, 115 + Kind div 11 * 11, SRCAND);
1196	BitBltCanvas(ca, x, y + 6, 10, 10, HGrSystem.Data.Canvas,
1197	66 + Kind mod 11 * 11, 115 + Kind div 11 * 11, SRCPAINT);
1198	end;
1199
1200	var
1201	p, xp: Integer;
1202	sp: string;
1203	shadow: Boolean;
1204	Text: string;
1205	begin
1206	Inc(x);
1207	Inc(y);
1208	for shadow := True downto False do
1209	with ca do
1210	if not shadow or (clBack <> $7F007F) then
1211	begin
1212	if shadow then
1213	Font.Color := clBack
1214	else
1215	Font.Color := clMain;
1216	sp := s;
1217	xp := x;
1218	repeat
1219	p := pos('%', sp);
1220	if (p = 0) or (p + 1 > Length(sp)) or not
1221	(sp[p + 1] in ['c', 'f', 'l', 'm', 'n', 'o', 'p', 'r', 't', 'w']) then
1222	begin
1223	ca.Textout(xp, y, sp);
1224	Break;
1225	end
1226	else
1227	begin
1228	Text := Copy(sp, 1, p - 1);
1229	Textout(xp, y, Text);
1230	Inc(xp, ca.TextWidth(Text));
1231	if not shadow then
1232	case sp[p + 1] of
1233	'c': PaintIcon(xp + 1, y, 6);
1234	'f': PaintIcon(xp + 1, y, 0);
1235	'l': PaintIcon(xp + 1, y, 8);
1236	'm': PaintIcon(xp + 1, y, 17);
1237	'n': PaintIcon(xp + 1, y, 7);
1238	'o': PaintIcon(xp + 1, y, 16);
1239	'p': PaintIcon(xp + 1, y, 2);
1240	'r': PaintIcon(xp + 1, y, 12);
1241	't': PaintIcon(xp + 1, y, 4);
1242	'w': PaintIcon(xp + 1, y, 13);
1243	end;
1244	Inc(xp, 10);
1245	Delete(sp, 1, p + 1);
1246	end;
1247	until False;
1248	Dec(x);
1249	Dec(y);
1250	end;
1251	end;
1252
1253	function BiColorTextWidth(ca: TCanvas; s: string): Integer;
1254	var
1255	P: Integer;
1256	begin
1257	Result := 1;
1258	repeat
1259	P := Pos('%', s);
1260	if (P = 0) or (P = Length(s)) then
1261	begin
1262	Inc(Result, ca.TextWidth(s));
1263	Break;
1264	end
1265	else
1266	begin
1267	if not (s[P + 1] in ['c', 'f', 'l', 'm', 'n', 'o', 'p', 'r', 't', 'w'])
1268	then
1269	Inc(Result, ca.TextWidth(copy(s, 1, P + 1)))
1270	else
1271	Inc(Result, ca.TextWidth(copy(s, 1, P - 1)) + 10);
1272	Delete(s, 1, P + 1);
1273	end;
1274	until False;
1275	end;
1276
1277	procedure LoweredTextOut(ca: TCanvas; cl: TColor; T: TTexture;
1278	x, y: Integer; s: string);
1279	begin
1280	if cl = -2 then
1281	BiColorTextOut(ca, (T.ColorBevelShade and $FEFEFE) shr 1,
1282	T.ColorBevelLight, x, y, s)
1283	else if cl < 0 then
1284	BiColorTextOut(ca, T.ColorTextShade, T.ColorTextLight, x, y, s)
1285	else
1286	BiColorTextOut(ca, cl, T.ColorTextLight, x, y, s);
1287	end;
1288
1289	procedure RisedTextOut(ca: TCanvas; x, y: integer; s: string);
1290	begin
1291	BiColorTextOut(ca, $FFFFFF, $000000, x, y, s);
1292	end;
1293
1294	procedure Gradient(ca: TCanvas; x, y, dx, dy, Width, Height, Color: Integer;
1295	Brightness: array of integer);
1296	var
1297	i, r, g, b: Integer;
1298	begin
1299	for i := 0 to Length(Brightness) - 1 do begin // gradient
1300	r := Color and $FF + Brightness[i];
1301	if r < 0 then
1302	r := 0
1303	else if r >= 256 then
1304	r := 255;
1305	g := Color shr 8 and $FF + Brightness[i];
1306	if g < 0 then
1307	g := 0
1308	else if g >= 256 then
1309	g := 255;
1310	b := Color shr 16 and $FF + Brightness[i];
1311	if b < 0 then
1312	b := 0
1313	else if b >= 256 then
1314	b := 255;
1315	ca.Pen.Color := r + g shl 8 + b shl 16;
1316	ca.MoveTo(x + dx * i, y + dy * i);
1317	ca.LineTo(x + dx * i + Width, y + dy * i + Height);
1318	end;
1319	ca.Pen.Color := $000000;
1320	ca.MoveTo(x + 1, y + 16 * dy + Height);
1321	ca.LineTo(x + 16 * dx + Width, y + 16 * dy + Height);
1322	ca.LineTo(x + 16 * dx + Width, y);
1323	end;
1324
1325	procedure LightGradient(ca: TCanvas; x, y, Width, Color: Integer);
1326	const
1327	Brightness: array [0 .. 15] of integer =
1328	(16, 12, 8, 4, 0, -4, -8, -12, -16, -20, -24, -28, -32, -36, -40, -44);
1329	begin
1330	Gradient(ca, x, y, 0, 1, Width, 0, Color, Brightness);
1331	end;
1332
1333	procedure DarkGradient(ca: TCanvas; x, y, Width, Kind: Integer);
1334	const
1335	Brightness: array [0 .. 15] of integer =
1336	(16, 12, 8, 4, 0, -4, -8, -12 - 24, -16 + 16, -20, -24, -28, -32, -36, -40, -44);
1337	begin
1338	Gradient(ca, x, y, 0, 1, Width, 0, HGrSystem.Data.Canvas.Pixels
1339	[187, 137 + Kind], Brightness);
1340	end;
1341
1342	procedure VLightGradient(ca: TCanvas; x, y, Height, Color: Integer);
1343	const
1344	Brightness: array [0 .. 15] of integer =
1345	(16, 12, 8, 4, 0, -4, -8, -12, -16, -20, -24, -28, -32, -36, -40, -44);
1346	begin
1347	Gradient(ca, x, y, 1, 0, 0, Height, Color, Brightness);
1348	end;
1349
1350	procedure VDarkGradient(ca: TCanvas; x, y, Height, Kind: Integer);
1351	const
1352	Brightness: array [0 .. 15] of integer =
1353	(16, 12, 8, 4, 0, -4, -8, -12 - 24, -16 + 16, -20, -24, -28, -32, -36, -40, -44);
1354	begin
1355	Gradient(ca, x, y, 1, 0, 0, Height,
1356	HGrSystem.Data.Canvas.Pixels[187, 137 + Kind], Brightness);
1357	end;
1358
1359	procedure UnderlinedTitleValue(Canvas: TCanvas; Title, Value: string; X, Y, Width: Integer);
1360	begin
1361	DLine(Canvas, X, X + Width, Y + 19, MainTexture.ColorBevelLight, MainTexture.ColorBevelShade);
1362	RisedTextOut(Canvas, X, Y, Title);
1363	RisedTextOut(Canvas, X + Width - BiColorTextWidth(Canvas, Value), Y, Value);
1364	end;
1365
1366	procedure NumberBar(dst: TBitmap; x, y: integer; Cap: string;
1367	val: Integer; T: TTexture);
1368	var
1369	s: string;
1370	begin
1371	if val > 0 then
1372	begin
1373	DLine(dst.Canvas, x - 2, x + 170, y + 16, T.ColorBevelShade,
1374	T.ColorBevelLight);
1375	LoweredTextOut(dst.Canvas, -1, T, x - 2, y, Cap);
1376	s := IntToStr(val);
1377	RisedTextOut(dst.Canvas, x + 170 - BiColorTextWidth(dst.Canvas,
1378	s), y, s);
1379	end;
1380	end;
1381
1382	procedure CountBar(dst: TBitmap; x, y, w: Integer; Kind: Integer;
1383	Cap: string; val: Integer; T: TTexture);
1384	var
1385	i, sd, ld, cl, xIcon, yIcon: Integer;
1386	s: string;
1387	begin
1388	// val:=random(40); //!!!
1389	if val = 0 then
1390	Exit;
1391	Assert(Kind >= 0);
1392	with dst.Canvas do
1393	begin
1394	// xIcon:=x+100;
1395	// yIcon:=y;
1396	// DLine(dst.Canvas,x-2,x+170+32,y+16,T.ColorBevelShade,T.ColorBevelLight);
1397
1398	xIcon := x - 5;
1399	yIcon := y + 15;
1400	DLine(dst.Canvas, x - 2, xIcon + w + 2, yIcon + 16, T.ColorBevelShade,
1401	T.ColorBevelLight);
1402
1403	s := IntToStr(val);
1404	if val < 0 then
1405	cl := $0000FF
1406	else
1407	cl := -1;
1408	LoweredTextOut(dst.Canvas, cl, T, x - 2, y, Cap);
1409	LoweredTextOut(dst.Canvas, cl, T,
1410	xIcon + w + 2 - BiColorTextWidth(dst.Canvas, s), yIcon, s);
1411
1412	if (Kind = 12) and (val >= 100) then
1413	begin // science with symbol for 100
1414	val := val div 10;
1415	sd := 14 * (val div 10 + val mod 10 - 1);
1416	if sd = 0 then
1417	sd := 1;
1418	if sd < w - 44 then
1419	ld := sd
1420	else
1421	ld := w - 44;
1422	for i := 0 to val mod 10 - 1 do
1423	begin
1424	BitBltCanvas(dst.Canvas, xIcon + 4 + i * (14 * ld div sd), yIcon + 2 + 1, 14,
1425	14, HGrSystem.Mask.Canvas, 67 + Kind mod 8 * 15,
1426	70 + Kind div 8 * 15, SRCAND);
1427	Sprite(dst, HGrSystem, xIcon + 3 + i * (14 * ld div sd), yIcon + 2,
1428	14, 14, 67 + Kind mod 8 * 15, 70 + Kind div 8 * 15);
1429	end;
1430	for i := 0 to val div 10 - 1 do
1431	begin
1432	BitBltCanvas(dst.Canvas, xIcon + 4 + (val mod 10) *
1433	(14 * ld div sd) + i * (14 * ld div sd), yIcon + 3, 14, 14,
1434	HGrSystem.Mask.Canvas, 67 + 7 mod 8 * 15,
1435	70 + 7 div 8 * 15, SRCAND);
1436	Sprite(dst, HGrSystem, xIcon + 3 + (val mod 10) *
1437	(14 * ld div sd) + i * (14 * ld div sd), yIcon + 2, 14,
1438	14, 67 + 7 mod 8 * 15,
1439	70 + 7 div 8 * 15);
1440	end;
1441	end
1442	else
1443	begin
1444	val := abs(val);
1445	if val mod 10 = 0 then
1446	sd := 14 * (val div 10 - 1)
1447	else
1448	sd := 10 * (val mod 10 - 1) + 14 * (val div 10);
1449	if sd = 0 then
1450	sd := 1;
1451	if sd < w - 44 then
1452	ld := sd
1453	else
1454	ld := w - 44;
1455	for i := 0 to val div 10 - 1 do
1456	begin
1457	BitBltCanvas(dst.Canvas, xIcon + 4 + i * (14 * ld div sd), yIcon + 3, 14, 14,
1458	HGrSystem.Mask.Canvas, 67 + Kind mod 8 * 15,
1459	70 + Kind div 8 * 15, SRCAND);
1460	Sprite(dst, HGrSystem, xIcon + 3 + i * (14 * ld div sd), yIcon + 2,
1461	14, 14, 67 + Kind mod 8 * 15, 70 + Kind div 8 * 15);
1462	end;
1463	for i := 0 to val mod 10 - 1 do
1464	begin
1465	BitBltCanvas(dst.Canvas, xIcon + 4 + (val div 10) *
1466	(14 * ld div sd) + i * (10 * ld div sd), yIcon + 7, 10, 10,
1467	HGrSystem.Mask.Canvas, 66 + Kind mod 11 * 11,
1468	115 + Kind div 11 * 11, SRCAND);
1469	Sprite(dst, HGrSystem, xIcon + 3 + (val div 10) *
1470	(14 * ld div sd) + i * (10 * ld div sd), yIcon + 6, 10,
1471	10, 66 + Kind mod 11 * 11,
1472	115 + Kind div 11 * 11);
1473	end;
1474	end;
1475	end;
1476	end;
1477
1478	procedure PaintProgressBar(ca: TCanvas; Kind, x, y, pos, Growth, max: Integer;
1479	T: TTexture);
1480	var
1481	i: Integer;
1482	begin
1483	if pos > max then
1484	pos := max;
1485	if Growth < 0 then
1486	begin
1487	pos := pos + Growth;
1488	if pos < 0 then
1489	begin
1490	Growth := Growth - pos;
1491	pos := 0;
1492	end;
1493	end
1494	else if pos + Growth > max then
1495	Growth := max - pos;
1496	Frame(ca, x - 1, y - 1, x + max, y + 7, $000000, $000000);
1497	RFrame(ca, x - 2, y - 2, x + max + 1, y + 8, T.ColorBevelShade,
1498	T.ColorBevelLight);
1499	with ca do
1500	begin
1501	for i := 0 to pos div 8 - 1 do
1502	BitBltCanvas(ca, x + i * 8, y, 8, 7,
1503	HGrSystem.Data.Canvas, 104, 9 + 8 * Kind);
1504	BitBltCanvas(ca, x + 8 * (pos div 8), y, pos - 8 * (pos div 8), 7,
1505	HGrSystem.Data.Canvas, 104, 9 + 8 * Kind);
1506	if Growth > 0 then
1507	begin
1508	for i := 0 to Growth div 8 - 1 do
1509	BitBltCanvas(ca, x + pos + i * 8, y, 8, 7,
1510	HGrSystem.Data.Canvas, 112, 9 + 8 * Kind);
1511	BitBltCanvas(ca, x + pos + 8 * (Growth div 8), y,
1512	Growth - 8 * (Growth div 8), 7, HGrSystem.Data.Canvas,
1513	112, 9 + 8 * Kind);
1514	end
1515	else if Growth < 0 then
1516	begin
1517	for i := 0 to -Growth div 8 - 1 do
1518	BitBltCanvas(ca, x + pos + i * 8, y, 8, 7,
1519	HGrSystem.Data.Canvas, 104, 1);
1520	BitBltCanvas(ca, x + pos + 8 * (-Growth div 8), y, -Growth -
1521	8 * (-Growth div 8), 7,
1522	HGrSystem.Data.Canvas, 104, 1);
1523	end;
1524	Brush.Color := $000000;
1525	FillRect(Rect(x + pos + abs(Growth), y, x + max, y + 7));
1526	Brush.Style := bsClear;
1527	end;
1528	end;
1529
1530	// pos and growth are relative to max, set size independent
1531	procedure PaintRelativeProgressBar(ca: TCanvas;
1532	Kind, x, y, size, pos, Growth, max: Integer; IndicateComplete: Boolean;
1533	T: TTexture);
1534	begin
1535	if Growth > 0 then
1536	PaintProgressBar(ca, Kind, x, y, pos * size div max,
1537	(Growth * size + max div 2) div max, size, T)
1538	else
1539	PaintProgressBar(ca, Kind, x, y, pos * size div max,
1540	(Growth * size - max div 2) div max, size, T);
1541	if IndicateComplete and (pos + Growth >= max) then
1542	Sprite(ca, HGrSystem, x + size - 10, y - 7, 23, 16, 1, 129);
1543	end;
1544
1545	procedure PaintLogo(Canvas: TCanvas; X, Y, LightColor, ShadeColor: Integer);
1546	begin
1547	UnshareBitmap(LogoBuffer);
1548	BitBltCanvas(LogoBuffer.Canvas, 0, 0, Logo.Width, Logo.Height, Canvas, X, Y);
1549	ImageOp_BCC(LogoBuffer, Templates.Data, Point(0, 0), Logo.BoundsRect,
1550	LightColor, ShadeColor);
1551	BitBltCanvas(Canvas, X, Y, Logo.Width, Logo.Height, LogoBuffer.Canvas, 0, 0);
1552	end;
1553
1554	procedure LoadPhrases;
1555	begin
1556	if Phrases = nil then Phrases := TStringTable.Create;
1557	if Phrases2 = nil then Phrases2 := TStringTable.Create;
1558	Phrases2FallenBackToEnglish := False;
1559	if FileExists(LocalizedFilePath('Language.txt')) then
1560	begin
1561	Phrases.LoadFromFile(LocalizedFilePath('Language.txt'));
1562	if FileExists(LocalizedFilePath('Language2.txt')) then
1563	Phrases2.LoadFromFile(LocalizedFilePath('Language2.txt'))
1564	else
1565	begin
1566	Phrases2.LoadFromFile(HomeDir + 'Language2.txt');
1567	Phrases2FallenBackToEnglish := True;
1568	end;
1569	end
1570	else
1571	begin
1572	Phrases.LoadFromFile(HomeDir + 'Language.txt');
1573	Phrases2.LoadFromFile(HomeDir + 'Language2.txt');
1574	end;
1575
1576	if Sounds = nil then Sounds := TStringTable.Create;
1577	if not Sounds.LoadFromFile(GetSoundsDir + DirectorySeparator + 'sound.txt') then
1578	begin
1579	FreeAndNil(Sounds);
1580	end;
1581	end;
1582
1583	procedure Texturize(Dest, Texture: TBitmap; TransparentColor: Cardinal);
1584	var
1585	SrcPixel, DstPixel: TPixelPointer;
1586	X, Y: Integer;
1587	TexWidth, TexHeight: Integer;
1588	begin
1589	// texturize background
1590	Dest.BeginUpdate;
1591	TexWidth := Texture.Width;
1592	TexHeight := Texture.Height;
1593	DstPixel := PixelPointer(Dest);
1594	SrcPixel := PixelPointer(Texture);
1595	for Y := 0 to ScaleToNative(Dest.Height) - 1 do begin
1596	for X := 0 to ScaleToNative(Dest.Width) - 1 do begin
1597	if (DstPixel.Pixel^.ARGB and $FFFFFF) = TransparentColor then begin
1598	SrcPixel.SetXY(X mod TexWidth, Y mod TexHeight);
1599	DstPixel.Pixel^.B := SrcPixel.Pixel^.B;
1600	DstPixel.Pixel^.G := SrcPixel.Pixel^.G;
1601	DstPixel.Pixel^.R := SrcPixel.Pixel^.R;
1602	end;
1603	DstPixel.NextPixel;
1604	end;
1605	DstPixel.NextLine;
1606	end;
1607	Dest.EndUpdate;
1608	end;
1609
1610	procedure DarkenImage(Bitmap: TBitmap; Change: Integer);
1611	var
1612	x, y: integer;
1613	PicturePixel: TPixelPointer;
1614	begin
1615	Bitmap.BeginUpdate;
1616	PicturePixel := PixelPointer(Bitmap);
1617	for y := 0 to ScaleToNative(Bitmap.Height) - 1 do begin
1618	for x := 0 to ScaleToNative(Bitmap.Width) - 1 do begin
1619	PicturePixel.Pixel^.B := Max(PicturePixel.Pixel^.B - Change, 0);
1620	PicturePixel.Pixel^.G := Max(PicturePixel.Pixel^.G - Change, 0);
1621	PicturePixel.Pixel^.R := Max(PicturePixel.Pixel^.R - Change, 0);
1622	PicturePixel.NextPixel;
1623	end;
1624	PicturePixel.NextLine;
1625	end;
1626	Bitmap.EndUpdate;
1627	end;
1628
1629	function ScaleToNative(Value: Integer): Integer;
1630	begin
1631	Result := Value;
1632	end;
1633
1634	function ScaleFromNative(Value: Integer): Integer;
1635	begin
1636	Result := Value;
1637	end;
1638
1639	procedure UnshareBitmap(Bitmap: TBitmap);
1640	begin
1641	// FillRect cause image data to be freed so subsequent BitBlt can access valid image data
1642	Bitmap.Canvas.FillRect(0, 0, 0, 0);
1643	end;
1644
1645	procedure Gtk2Fix;
1646	{$IFDEF UNIX}
1647	var
1648	I: Integer;
1649	{$ENDIF}
1650	begin
1651	{$IFDEF UNIX}
1652	// Wait and process messages little bit to avoid crash or force repaint under Gtk2
1653	for I := 0 to 10 do begin
1654	Sleep(1);
1655	Application.ProcessMessages;
1656	end;
1657	{$ENDIF}
1658	end;
1659
1660	procedure LoadFonts;
1661	var
1662	Section: TFontType;
1663	FontScript: TextFile;
1664	Size: integer;
1665	S: string;
1666	I: integer;
1667	P: integer;
1668	begin
1669	Section := ftNormal;
1670	AssignFile(FontScript, LocalizedFilePath('Fonts.txt'));
1671	try
1672	Reset(FontScript);
1673	while not Eof(FontScript) do begin
1674	ReadLn(FontScript, s);
1675	if s <> '' then
1676	if s[1] = '#' then begin
1677	s := TrimRight(s);
1678	if s = '#SMALL' then Section := ftSmall
1679	else if s = '#TINY' then Section := ftTiny
1680	else if s = '#CAPTION' then Section := ftCaption
1681	else if s = '#BUTTON' then Section := ftButton
1682	else Section := ftNormal;
1683	end else begin
1684	p := Pos(',', s);
1685	if p > 0 then begin
1686	UniFont[section].Name := Trim(Copy(s, 1, p - 1));
1687	Size := 0;
1688	for i := p + 1 to Length(s) do
1689	case s[i] of
1690	'0' .. '9':
1691	Size := Size * 10 + Byte(s[i]) - 48;
1692	'B', 'b':
1693	UniFont[section].Style := UniFont[section].Style + [fsBold];
1694	'I', 'i':
1695	UniFont[section].Style := UniFont[section].Style + [fsItalic];
1696	end;
1697	UniFont[section].Size := Round(Size * 72 / UniFont[section].PixelsPerInch);
1698	end;
1699	end;
1700	end;
1701	CloseFile(FontScript);
1702	except
1703	end;
1704	end;
1705
1706	procedure ReleaseFonts;
1707	var
1708	Section: TFontType;
1709	begin
1710	for Section := Low(TFontType) to High(TFontType) do
1711	FreeAndNil(UniFont[section]);
1712	end;
1713
1714	procedure InitGammaLookupTable;
1715	var
1716	I: Integer;
1717	P: Integer;
1718	begin
1719	GammaLookupTable[0] := 0;
1720	for I := 1 to 255 do begin
1721	P := Round(255.0 * Exp(Ln(I / 255.0) * 100.0 / Gamma));
1722	Assert((P >= 0) and (P < 256));
1723	GammaLookupTable[I] := P;
1724	end;
1725	end;
1726
1727	procedure LoadAssets;
1728	begin
1729	LoadPhrases;
1730	LoadFonts;
1731	Templates := LoadGraphicSet('Templates.png', False);
1732	with Templates do begin
1733	Logo := GetItem('Logo');
1734	BigBook := GetItem('BigBook');
1735	SmallBook := GetItem('SmallBook');
1736	MenuLogo := GetItem('MenuLogo');
1737	LinkArrows := GetItem('LinkArrows');
1738	ScienceNationDot := GetItem('ScienceNationDot');
1739	ResearchIcon := GetItem('Research');
1740	ChangeIcon := GetItem('Change');
1741	TreasuryIcon := GetItem('Treasury');
1742	StarshipDeparted := GetItem('StarshipDeparted');
1743	WeightOn := GetItem('WeightOn');
1744	WeightOff := GetItem('WeightOff');
1745	end;
1746
1747	LoadGraphicFile(Colors, GetGraphicsDir + DirectorySeparator + 'Colors.png');
1748	LoadGraphicFile(Paper, GetGraphicsDir + DirectorySeparator + 'Paper.jpg');
1749	LoadGraphicFile(BigImp, GetGraphicsDir + DirectorySeparator + 'Icons.png');
1750	end;
1751
1752	procedure UnitInit;
1753	var
1754	Section: TFontType;
1755	begin
1756	Gamma := 100;
1757	InitGammaLookupTable;
1758
1759	{$IFDEF WINDOWS}
1760	EnumDisplaySettings(nil, $FFFFFFFF, StartResolution);
1761	ResolutionChanged := False;
1762	{$ENDIF}
1763
1764	for Section := Low(TFontType) to High(TFontType) do
1765	UniFont[Section] := TFont.Create;
1766
1767	GrExt := TGraphicSets.Create;
1768
1769	HGrSystem := LoadGraphicSet('System.png');
1770	with HGrSystem do begin
1771	CityMark1 := GetItem('CityMark1');
1772	CityMark2 := GetItem('CityMark2');
1773	end;
1774
1775	HGrSystem2 := LoadGraphicSet('System2.png');
1776	with HGrSystem2 do begin
1777	Ornament := GetItem('Ornament');
1778	GBrainNoTerm := GetItem('BrainNoTerm');
1779	GBrainSuperVirtual := GetItem('BrainSuperVirtual');
1780	GBrainTerm := GetItem('BrainTerm');
1781	GBrainRandom := GetItem('BrainRandom');
1782	end;
1783
1784	Colors := TBitmap.Create;
1785	Colors.PixelFormat := pf24bit;
1786	Paper := TBitmap.Create;
1787	Paper.PixelFormat := pf24bit;
1788	BigImp := TBitmap.Create;
1789	BigImp.PixelFormat := pf24bit;
1790	MainTexture := TTexture.Create;
1791	ClickFrameColor := HGrSystem.Data.Canvas.Pixels[187, 175];
1792	InitOrnamentDone := False;
1793	GenerateNames := True;
1794
1795	LoadAssets;
1796
1797	LogoBuffer := TBitmap.Create;
1798	LogoBuffer.PixelFormat := pf24bit;
1799	LogoBuffer.SetSize(BigBook.Width, BigBook.Height);
1800	end;
1801
1802	procedure UnitDone;
1803	begin
1804	RestoreResolution;
1805	FreeAndNil(GrExt);
1806	ReleaseFonts;
1807	FreeAndNil(Phrases);
1808	FreeAndNil(Phrases2);
1809	FreeAndNil(LogoBuffer);
1810	FreeAndNil(BigImp);
1811	FreeAndNil(Paper);
1812	FreeAndNil(Colors);
1813	FreeAndNil(MainTexture);
1814	end;
1815
1816	end.

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

Download in other formats: