Context Navigation

source: trunk/ScreenTools.pas@ 24

Last change on this file since 24 was 21, checked in by chronos, 9 years ago
Fixed: Run as 64-bit application. Can't load 32-bit StdAI library in 64-bit mode. Fixed: Various Warnings and Hints.
File size: 48.1 KB

Line
1	{$INCLUDE Switches.pas}
2	unit ScreenTools;
3
4	interface
5
6	uses
7	{$IFDEF WINDOWS}
8	Windows,
9	{$ENDIF}
10	StringTables,
11	LCLIntf, LCLType, SysUtils, Classes, Graphics, Controls,
12	Forms, Menus;
13
14	type
15	TTexture = record
16	Image: TBitmap;
17	clBevelLight, clBevelShade, clTextLight, clTextShade, clLitText, clMark,
18	clPage, clCover: TColor;
19	end;
20
21	{$IFDEF WINDOWS}
22	function ChangeResolution(x, y, bpp, freq: integer): boolean;
23	{$ENDIF}
24	procedure RestoreResolution;
25	function Play(Item: string; Index: integer = -1): boolean;
26	procedure PreparePlay(Item: string; Index: integer = -1);
27	procedure EmptyMenu(MenuItems: TMenuItem; Keep: integer = 0);
28	function turntoyear(Turn: integer): integer;
29	function TurnToString(Turn: integer): string;
30	function MovementToString(Movement: integer): string;
31	procedure BtnFrame(ca: TCanvas; p: TRect; const T: TTexture);
32	procedure EditFrame(ca: TCanvas; p: TRect; const T: TTexture);
33	function HexStringToColor(s: string): integer;
34	function LoadGraphicFile(bmp: TBitmap; Path: string;
35	Options: integer = 0): boolean;
36	function LoadLocalizedGraphicFile(bmp: TBitmap; Path: string;
37	Options: integer = 0): boolean;
38	function LoadGraphicSet(Name: string): integer;
39	procedure Dump(dst: TBitmap; HGr, xDst, yDst, Width, Height, xGr, yGr: integer);
40	procedure Sprite(Canvas: TCanvas; HGr, xDst, yDst, Width, Height, xGr,
41	yGr: integer); overload;
42	procedure Sprite(dst: TBitmap; HGr, xDst, yDst, Width, Height, xGr,
43	yGr: integer); overload;
44	procedure MakeBlue(dst: TBitmap; x, y, w, h: integer);
45	procedure ImageOp_B(dst, Src: TBitmap; xDst, yDst, xSrc, ySrc, w, h: integer);
46	procedure ImageOp_BCC(dst, Src: TBitmap; xDst, yDst, xSrc, ySrc, w, h, Color1,
47	Color2: integer);
48	procedure ImageOp_CCC(bmp: TBitmap; x, y, w, h, Color0, Color1,
49	Color2: integer);
50	procedure SLine(ca: TCanvas; x0, x1, y: integer; cl: TColor);
51	procedure DLine(ca: TCanvas; x0, x1, y: integer; cl0, cl1: TColor);
52	procedure Frame(ca: TCanvas; x0, y0, x1, y1: integer; cl0, cl1: TColor);
53	procedure RFrame(ca: TCanvas; x0, y0, x1, y1: integer; cl0, cl1: TColor);
54	procedure CFrame(ca: TCanvas; x0, y0, x1, y1, Corner: integer; cl: TColor);
55	procedure FrameImage(ca: TCanvas; Src: TBitmap;
56	x, y, Width, Height, xSrc, ySrc: integer; IsControl: boolean = false);
57	procedure GlowFrame(dst: TBitmap; x0, y0, Width, Height: integer; cl: TColor);
58	procedure InitOrnament;
59	procedure InitCityMark(const T: TTexture);
60	procedure Fill(ca: TCanvas; Left, Top, Width, Height, xOffset,
61	yOffset: integer);
62	procedure FillLarge(ca: TCanvas; x0, y0, x1, y1, xm: integer);
63	procedure FillSeamless(ca: TCanvas; Left, Top, Width, Height, xOffset,
64	yOffset: integer; const Texture: TBitmap);
65	procedure FillRectSeamless(ca: TCanvas; x0, y0, x1, y1, xOffset,
66	yOffset: integer; const Texture: TBitmap);
67	procedure PaintBackground(Form: TForm; Left, Top, Width, Height: integer);
68	procedure Corner(ca: TCanvas; x, y, Kind: integer; const T: TTexture);
69	procedure BiColorTextOut(ca: TCanvas; clMain, clBack: TColor; x, y: integer;
70	s: string);
71	procedure LoweredTextOut(ca: TCanvas; cl: TColor; const T: TTexture;
72	x, y: integer; s: string);
73	function BiColorTextWidth(ca: TCanvas; s: string): integer;
74	procedure RisedTextOut(ca: TCanvas; x, y: integer; s: string);
75	procedure LightGradient(ca: TCanvas; x, y, Width, Color: integer);
76	procedure DarkGradient(ca: TCanvas; x, y, Width, Kind: integer);
77	procedure VLightGradient(ca: TCanvas; x, y, Height, Color: integer);
78	procedure VDarkGradient(ca: TCanvas; x, y, Height, Kind: integer);
79	procedure NumberBar(dst: TBitmap; x, y: integer; Cap: string; val: integer;
80	const T: TTexture);
81	procedure CountBar(dst: TBitmap; x, y, w: integer; Kind: integer; Cap: string;
82	val: integer; const T: TTexture);
83	procedure PaintProgressBar(ca: TCanvas; Kind, x, y, pos, Growth, max: integer;
84	const T: TTexture);
85	procedure PaintRelativeProgressBar(ca: TCanvas; Kind, x, y, size, pos, Growth,
86	max: integer; IndicateComplete: boolean; const T: TTexture);
87	procedure PaintLogo(ca: TCanvas; x, y, clLight, clShade: integer);
88	function SetMainTextureByAge(Age: integer): boolean;
89
90	const
91	nGrExtmax = 64;
92	wMainTexture = 640;
93	hMainTexture = 480;
94
95	// template positions in Template.bmp
96	xLogo = 1;
97	yLogo = 1;
98	wLogo = 122;
99	hLogo = 23; // logo
100	xBBook = 1;
101	yBBook = 74;
102	wBBook = 143;
103	hBBook = 73; // big book
104	xSBook = 72;
105	ySBook = 37;
106	wSBook = 72;
107	hSBook = 36; // small book
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	// template positions in System2.bmp
122	xOrna = 156;
123	yOrna = 1;
124	wOrna = 27;
125	hOrna = 26; // ornament
126
127	// sound modes
128	smOff = 0;
129	smOn = 1;
130	smOnAlt = 2;
131
132	// color matrix
133	clkAge0 = 1;
134	cliTexture = 0;
135	cliBevelLight = cliTexture + 1;
136	cliBevelShade = cliTexture + 2;
137	cliTextLight = cliTexture + 3;
138	cliTextShade = cliTexture + 4;
139	cliLitText = cliTexture + 5;
140	cliMark = cliTexture + 6;
141	cliDimmedText = cliTexture + 7;
142	cliRoad = 8;
143	cliHouse = cliRoad + 1;
144	cliImp = cliRoad + 2;
145	cliImpProject = cliRoad + 3;
146	cliPage = 13;
147	cliCover = cliPage + 1;
148	clkMisc = 5;
149	cliPaper = 0;
150	cliPaperText = 1;
151	cliPaperCaption = 2;
152	clkCity = 6;
153	cliPlains = 0;
154	cliPrairie = 1;
155	cliHills = 2;
156	cliTundra = 3;
157	cliWater = 4;
158
159	// LoadGraphicFile options
160	gfNoError = $01;
161	gfNoGamma = $02;
162	gfJPG = $04;
163
164	type
165	TGrExtDescr = record { don't use dynamic strings here! }
166	Name: string[31];
167	Data, Mask: TBitmap;
168	pixUsed: array [Byte] of Byte;
169	end;
170
171	TGrExtDescrSize = record { for size calculation only - must be the same as
172	TGrExtDescr, but without pixUsed }
173	Name: string[31];
174	Data, Mask: TBitmap;
175	end;
176
177	TFontType = (ftNormal, ftSmall, ftTiny, ftCaption, ftButton);
178
179	var
180	Phrases, Phrases2, Sounds: TStringTable;
181	nGrExt: integer;
182	GrExt: array [0 .. nGrExtmax - 1] of ^TGrExtDescr;
183	HGrSystem, HGrSystem2, ClickFrameColor, SoundMode, MainTextureAge: integer;
184	MainTexture: TTexture;
185	Templates, Colors, Paper, BigImp, LogoBuffer: TBitmap;
186	FullScreen, GenerateNames, InitOrnamentDone,
187	Phrases2FallenBackToEnglish: boolean;
188
189	UniFont: array [TFontType] of TFont;
190
191	implementation
192
193	uses
194	Directories, Sound, Registry;
195
196	var
197	{$IFDEF WINDOWS}
198	StartResolution: TDeviceMode;
199	{$ENDIF}
200	ResolutionChanged: boolean;
201
202	Gamma: integer; // global gamma correction (cent)
203	GammaLUT: array [0 .. 255] of Byte;
204
205	{$IFDEF WINDOWS}
206	function ChangeResolution(x, y, bpp, freq: integer): boolean;
207	var
208	DevMode: TDeviceMode;
209	begin
210	EnumDisplaySettings(nil, 0, DevMode);
211	DevMode.dmFields := DM_PELSWIDTH or DM_PELSHEIGHT or DM_BITSPERPEL or
212	DM_DISPLAYFREQUENCY;
213	DevMode.dmPelsWidth := x;
214	DevMode.dmPelsHeight := y;
215	DevMode.dmBitsPerPel := bpp;
216	DevMode.dmDisplayFrequency := freq;
217	result := ChangeDisplaySettings(DevMode, 0) = DISP_CHANGE_SUCCESSFUL;
218	if result then
219	ResolutionChanged := true;
220	end;
221	{$ENDIF}
222
223	procedure RestoreResolution;
224	begin
225	{$IFDEF WINDOWS}
226	if ResolutionChanged then
227	ChangeDisplaySettings(StartResolution, 0);
228	{$ENDIF}
229	ResolutionChanged := false;
230	end;
231
232	function Play(Item: string; Index: integer = -1): boolean;
233	{$IFNDEF DEBUG}
234	var
235	WAVFileName: string;
236	{$ENDIF}
237	begin
238	{$IFNDEF DEBUG}
239	if (Sounds = nil) or (SoundMode = smOff) or (Item = '') then
240	begin
241	result := true;
242	exit;
243	end;
244	WAVFileName := Sounds.Lookup(Item, Index);
245	assert(WAVFileName[1] <> '[');
246	result := (WAVFileName <> '') and (WAVFileName[1] <> '[') and
247	(WAVFileName <> '*');
248	if result then
249	// SndPlaySound(pchar(HomeDir+'Sounds' +DirectorySeparator+WAVFileName+'.wav'),SND_ASYNC)
250	PlaySound(HomeDir + 'Sounds' + DirectorySeparator + WAVFileName)
251	{$ENDIF}
252	end;
253
254	procedure PreparePlay(Item: string; Index: integer = -1);
255	{$IFNDEF DEBUG}
256	var
257	WAVFileName: string;
258	{$ENDIF}
259	begin
260	{$IFNDEF DEBUG}
261	if (Sounds = nil) or (SoundMode = smOff) or (Item = '') then
262	exit;
263	WAVFileName := Sounds.Lookup(Item, Index);
264	assert(WAVFileName[1] <> '[');
265	if (WAVFileName <> '') and (WAVFileName[1] <> '[') and (WAVFileName <> '*')
266	then
267	PrepareSound(HomeDir + 'Sounds' + DirectorySeparator + WAVFileName)
268	{$ENDIF}
269	end;
270
271	procedure EmptyMenu(MenuItems: TMenuItem; Keep: integer = 0);
272	var
273	m: TMenuItem;
274	begin
275	while MenuItems.Count > Keep do
276	begin
277	m := MenuItems[MenuItems.Count - 1];
278	MenuItems.Delete(MenuItems.Count - 1);
279	m.Free;
280	end;
281	end;
282
283	function turntoyear(Turn: integer): integer;
284	var
285	i: integer;
286	begin
287	result := -4000;
288	for i := 1 to Turn do
289	if result < -1000 then
290	inc(result, 50) // 0..60
291	else if result < 0 then
292	inc(result, 25) // 60..100
293	else if result < 1500 then
294	inc(result, 20) // 100..175
295	else if result < 1750 then
296	inc(result, 10) // 175..200
297	else if result < 1850 then
298	inc(result, 2) // 200..250
299	else
300	inc(result);
301	end;
302
303	function TurnToString(Turn: integer): string;
304	var
305	year: integer;
306	begin
307	if GenerateNames then
308	begin
309	year := turntoyear(Turn);
310	if year < 0 then
311	result := Format(Phrases.Lookup('BC'), [-year])
312	else
313	result := Format(Phrases.Lookup('AD'), [year]);
314	end
315	else
316	result := IntToStr(Turn)
317	end;
318
319	function MovementToString(Movement: integer): string;
320	begin
321	if Movement >= 1000 then
322	begin
323	result := char(48 + Movement div 1000);
324	Movement := Movement mod 1000;
325	end
326	else
327	result := '';
328	result := result + char(48 + Movement div 100);
329	Movement := Movement mod 100;
330	if Movement > 0 then
331	begin
332	result := result + '.' + char(48 + Movement div 10);
333	Movement := Movement mod 10;
334	if Movement > 0 then
335	result := result + char(48 + Movement);
336	end
337	end;
338
339	procedure BtnFrame(ca: TCanvas; p: TRect; const T: TTexture);
340	begin
341	RFrame(ca, p.Left - 1, p.Top - 1, p.Right, p.Bottom, T.clBevelShade,
342	T.clBevelLight)
343	end;
344
345	procedure EditFrame(ca: TCanvas; p: TRect; const T: TTexture);
346	begin
347	Frame(ca, p.Left - 1, p.Top - 1, p.Right, p.Bottom, $000000, $000000);
348	Frame(ca, p.Left - 2, p.Top - 2, p.Right + 1, p.Bottom + 1, $000000, $000000);
349	Frame(ca, p.Left - 3, p.Top - 3, p.Right + 2, p.Bottom + 1, $000000, $000000);
350	RFrame(ca, p.Left - 4, p.Top - 4, p.Right + 3, p.Bottom + 2, T.clBevelShade,
351	T.clBevelLight)
352	end;
353
354	function HexStringToColor(s: string): integer;
355
356	function HexCharToInt(x: char): integer;
357	begin
358	case x of
359	'0' .. '9':
360	result := ord(x) - 48;
361	'A' .. 'F':
362	result := ord(x) - 65 + 10;
363	'a' .. 'f':
364	result := ord(x) - 97 + 10;
365	else
366	result := 0
367	end
368	end;
369
370	begin
371	while (Length(s) > 0) and (s[1] = ' ') do
372	Delete(s, 1, 1);
373	s := s + '000000';
374	if Gamma = 100 then
375	result := $10 * HexCharToInt(s[1]) + $1 * HexCharToInt(s[2]) + $1000 *
376	HexCharToInt(s[3]) + $100 * HexCharToInt(s[4]) + $100000 *
377	HexCharToInt(s[5]) + $10000 * HexCharToInt(s[6])
378	else
379	result := GammaLUT[$10 * HexCharToInt(s[1]) + HexCharToInt(s[2])] + $100 *
380	GammaLUT[$10 * HexCharToInt(s[3]) + HexCharToInt(s[4])] + $10000 *
381	GammaLUT[$10 * HexCharToInt(s[5]) + HexCharToInt(s[6])];
382	end;
383
384	procedure ApplyGamma(Start, Stop: pbyte);
385	begin
386	while Start < Stop do
387	begin
388	Start^ := GammaLUT[Start^];
389	inc(Start);
390	end;
391	end;
392
393	function LoadGraphicFile(bmp: TBitmap; Path: string; Options: integer): boolean;
394	type
395	TLine = array [0 .. 9999, 0 .. 2] of Byte;
396	var
397	FirstLine, LastLine: ^TLine;
398	jtex: tjpegimage;
399	begin
400	result := true;
401	if Options and gfJPG <> 0 then
402	begin
403	jtex := tjpegimage.create;
404	try
405	jtex.loadfromfile(Path + '.jpg');
406	except
407	result := false;
408	end;
409	if result then
410	begin
411	if Options and gfNoGamma = 0 then
412	bmp.PixelFormat := pf24bit;
413	bmp.Width := jtex.Width;
414	bmp.Height := jtex.Height;
415	bmp.Canvas.draw(0, 0, jtex);
416	end;
417	jtex.Free;
418	end
419	else
420	begin
421	try
422	bmp.loadfromfile(Path + '.bmp');
423	except
424	result := false;
425	end;
426	if result then
427	begin
428	if Options and gfNoGamma = 0 then
429	bmp.PixelFormat := pf24bit;
430	end
431	end;
432	if not result then
433	begin
434	if Options and gfNoError = 0 then
435	Application.MessageBox(PChar(Format(Phrases.Lookup('FILENOTFOUND'),
436	[Path])), 'C-evo', 0);
437	exit;
438	end;
439	if (Options and gfNoGamma = 0) and (Gamma <> 100) then
440	begin
441	FirstLine := bmp.ScanLine[0];
442	LastLine := bmp.ScanLine[bmp.Height - 1];
443	if FirstLine < LastLine then
444	ApplyGamma(pointer(FirstLine), @LastLine[bmp.Width])
445	else
446	ApplyGamma(pointer(LastLine), @FirstLine[bmp.Width])
447	end
448	end;
449
450	function LoadLocalizedGraphicFile(bmp: TBitmap; Path: string;
451	Options: integer): boolean;
452	type
453	TLine = array [0 .. 9999, 0 .. 2] of Byte;
454	var
455	FirstLine, LastLine: ^TLine;
456	jtex: tjpegimage;
457	begin
458	result := true;
459	if Options and gfJPG <> 0 then
460	begin
461	jtex := tjpegimage.create;
462	try
463	jtex.loadfromfile(LocalizedFilePath(Path + '.jpg'));
464	except
465	result := false;
466	end;
467	if result then
468	begin
469	if Options and gfNoGamma = 0 then
470	bmp.PixelFormat := pf24bit;
471	bmp.Width := jtex.Width;
472	bmp.Height := jtex.Height;
473	bmp.Canvas.draw(0, 0, jtex);
474	end;
475	jtex.Free;
476	end
477	else
478	begin
479	try
480	bmp.loadfromfile(LocalizedFilePath(Path + '.bmp'));
481	except
482	result := false;
483	end;
484	if result then
485	begin
486	if Options and gfNoGamma = 0 then
487	bmp.PixelFormat := pf24bit;
488	end
489	end;
490	if not result then
491	begin
492	if Options and gfNoError = 0 then
493	Application.MessageBox(PChar(Format(Phrases.Lookup('FILENOTFOUND'),
494	[Path])), 'C-evo', 0);
495	exit;
496	end;
497	if (Options and gfNoGamma = 0) and (Gamma <> 100) then
498	begin
499	FirstLine := bmp.ScanLine[0];
500	LastLine := bmp.ScanLine[bmp.Height - 1];
501	if FirstLine < LastLine then
502	ApplyGamma(pointer(FirstLine), @LastLine[bmp.Width])
503	else
504	ApplyGamma(pointer(LastLine), @FirstLine[bmp.Width])
505	end
506	end;
507
508	function LoadGraphicSet(Name: string): integer;
509	type
510	TLine = array [0 .. 999, 0 .. 2] of Byte;
511	var
512	i, x, y, xmax, OriginalColor: integer;
513	FileName: string;
514	Source: TBitmap;
515	DataLine, MaskLine: ^TLine;
516	begin
517	i := 0;
518	while (i < nGrExt) and (GrExt[i].Name <> Name) do
519	inc(i);
520	result := i;
521	if i = nGrExt then
522	begin
523	FileName := HomeDir + 'Graphics' + DirectorySeparator + Name + '.bmp';
524	Source := TBitmap.Create;
525	try
526	Source.LoadFromFile(FileName)
527	except
528	Result := -1;
529	Application.MessageBox(PChar(Format(Phrases.Lookup('FILENOTFOUND'),
530	[FileName])), 'C-evo', 0);
531	exit;
532	end;
533
534	GetMem(GrExt[nGrExt], SizeOf(TGrExtDescrSize) + Source.Height div 49 * 10);
535	GrExt[nGrExt].Name := Name;
536
537	xmax := Source.Width - 1; // allows 4-byte access even for last pixel
538	if xmax > 970 then
539	xmax := 970;
540
541	GrExt[nGrExt].Data := Source;
542	GrExt[nGrExt].Data.PixelFormat := pf24bit;
543	GrExt[nGrExt].Mask := TBitmap.create;
544	GrExt[nGrExt].Mask.PixelFormat := pf24bit;
545	GrExt[nGrExt].Mask.Width := Source.Width;
546	GrExt[nGrExt].Mask.Height := Source.Height;
547
548	for y := 0 to Source.Height - 1 do
549	begin
550	DataLine := GrExt[nGrExt].Data.ScanLine[y];
551	MaskLine := GrExt[nGrExt].Mask.ScanLine[y];
552	for x := 0 to xmax - 1 do
553	begin
554	OriginalColor := Cardinal((@DataLine[x])^) and $FFFFFF;
555	if (OriginalColor = $FF00FF) or (OriginalColor = $7F007F) then
556	begin // transparent
557	Cardinal((@MaskLine[x])^) := $FFFFFF;
558	Cardinal((@DataLine[x])^) := Cardinal((@DataLine[x])^) and $FF000000
559	end
560	else
561	begin
562	Cardinal((@MaskLine[x])^) := $000000; // non-transparent
563	if Gamma <> 100 then
564	begin
565	DataLine[x, 0] := GammaLUT[DataLine[x, 0]];
566	DataLine[x, 1] := GammaLUT[DataLine[x, 1]];
567	DataLine[x, 2] := GammaLUT[DataLine[x, 2]];
568	end
569	end
570	end
571	end;
572
573	FillChar(GrExt[nGrExt].pixUsed, GrExt[nGrExt].Data.Height div 49 * 10, 0);
574	inc(nGrExt)
575	end
576	end;
577
578	procedure Dump(dst: TBitmap; HGr, xDst, yDst, Width, Height, xGr, yGr: integer);
579	begin
580	BitBlt(dst.Canvas.Handle, xDst, yDst, Width, Height,
581	GrExt[HGr].Data.Canvas.Handle, xGr, yGr, SRCCOPY);
582	end;
583
584	procedure MakeBlue(dst: TBitmap; x, y, w, h: integer);
585	type
586	TLine = array [0 .. 99999, 0 .. 2] of Byte;
587	PLine = ^TLine;
588
589	procedure BlueLine(line: PLine; Length: integer);
590	var
591	i: integer;
592	begin
593	for i := 0 to Length - 1 do
594	begin
595	line[i, 0] := line[i, 0] div 2;
596	line[i, 1] := line[i, 1] div 2;
597	line[i, 2] := line[i, 2] div 2;
598	end
599	end;
600
601	var
602	i: integer;
603	begin
604	for i := 0 to h - 1 do
605	BlueLine(@(PLine(dst.ScanLine[y + i])[x]), w)
606	end;
607
608	procedure ImageOp_B(dst, Src: TBitmap; xDst, yDst, xSrc, ySrc, w, h: integer);
609	// Src is template
610	// X channel = background amp (old Dst content), 128=original brightness
611	type
612	TPixel = array [0..2] of Byte;
613	PPixel = ^TPixel;
614	var
615	i, Brightness, test: integer;
616	PixelSrc: ^Byte;
617	PixelDst: PPixel;
618	begin
619	{TODO assert(Src.PixelFormat = pf8bit);}
620	assert(dst.PixelFormat = pf24bit);
621	if xDst < 0 then
622	begin
623	w := w + xDst;
624	xSrc := xSrc - xDst;
625	xDst := 0;
626	end;
627	if yDst < 0 then
628	begin
629	h := h + yDst;
630	ySrc := ySrc - yDst;
631	yDst := 0;
632	end;
633	if xDst + w > dst.Width then
634	w := dst.Width - xDst;
635	if yDst + h > dst.Height then
636	h := dst.Height - yDst;
637	if (w < 0) or (h < 0) then
638	exit;
639
640	h := yDst + h;
641	while yDst < h do
642	begin
643	PixelDst := dst.ScanLine[yDst] + 3 * xDst;
644	PixelSrc := Src.ScanLine[ySrc] + xSrc;
645	for i := 0 to w - 1 do
646	begin
647	Brightness := PixelSrc^;
648	test := (PixelDst[2] * Brightness) shr 7;
649	if test >= 256 then
650	PixelDst[2] := 255
651	else
652	PixelDst[2] := test; // Red
653	test := (PixelDst[1] * Brightness) shr 7;
654	if test >= 256 then
655	PixelDst[1] := 255
656	else
657	PixelDst[1] := test; // Green
658	test := (PixelDst[0] * Brightness) shr 7;
659	if test >= 256 then
660	PixelDst[2] := 255
661	else
662	PixelDst[0] := test; // Blue
663	PixelDst := Pointer(PixelDst) + 3;
664	PixelSrc := Pointer(PixelSrc) + 1;
665	end;
666	inc(yDst);
667	inc(ySrc);
668	end
669	end;
670
671	procedure ImageOp_BCC(dst, Src: TBitmap; xDst, yDst, xSrc, ySrc, w, h, Color1,
672	Color2: integer);
673	// Src is template
674	// B channel = background amp (old Dst content), 128=original brightness
675	// G channel = Color1 amp, 128=original brightness
676	// R channel = Color2 amp, 128=original brightness
677	type
678	TLine = array [0 .. 9999, 0 .. 2] of Byte;
679	var
680	ix, iy, amp1, amp2, trans, Value: integer;
681	SrcLine, DstLine: ^TLine;
682	begin
683	if xDst < 0 then
684	begin
685	w := w + xDst;
686	xSrc := xSrc - xDst;
687	xDst := 0;
688	end;
689	if yDst < 0 then
690	begin
691	h := h + yDst;
692	ySrc := ySrc - yDst;
693	yDst := 0;
694	end;
695	if xDst + w > dst.Width then
696	w := dst.Width - xDst;
697	if yDst + h > dst.Height then
698	h := dst.Height - yDst;
699	if (w < 0) or (h < 0) then
700	exit;
701
702	for iy := 0 to h - 1 do
703	begin
704	SrcLine := Src.ScanLine[ySrc + iy];
705	DstLine := dst.ScanLine[yDst + iy];
706	for ix := 0 to w - 1 do
707	begin
708	trans := SrcLine[xSrc + ix, 0] * 2; // green channel = transparency
709	amp1 := SrcLine[xSrc + ix, 1] * 2;
710	amp2 := SrcLine[xSrc + ix, 2] * 2;
711	if trans <> $FF then
712	begin
713	Value := (DstLine[xDst + ix][0] * trans + (Color2 shr 16 and $FF) * amp2
714	+ (Color1 shr 16 and $FF) * amp1) div $FF;
715	if Value < 256 then
716	DstLine[xDst + ix][0] := Value
717	else
718	DstLine[xDst + ix][0] := 255;
719	Value := (DstLine[xDst + ix][1] * trans + (Color2 shr 8 and $FF) * amp2
720	+ (Color1 shr 8 and $FF) * amp1) div $FF;
721	if Value < 256 then
722	DstLine[xDst + ix][1] := Value
723	else
724	DstLine[xDst + ix][1] := 255;
725	Value := (DstLine[xDst + ix][2] * trans + (Color2 and $FF) * amp2 +
726	(Color1 and $FF) * amp1) div $FF;
727	if Value < 256 then
728	DstLine[xDst + ix][2] := Value
729	else
730	DstLine[xDst + ix][2] := 255;
731	end
732	end
733	end;
734	end;
735
736	procedure ImageOp_CCC(bmp: TBitmap; x, y, w, h, Color0, Color1,
737	Color2: integer);
738	// Bmp is template
739	// B channel = Color0 amp, 128=original brightness
740	// G channel = Color1 amp, 128=original brightness
741	// R channel = Color2 amp, 128=original brightness
742	type
743	TPixel = array [0 .. 2] of Byte;
744	var
745	i, Red, Green: integer;
746	Pixel: ^TPixel;
747	begin
748	assert(bmp.PixelFormat = pf24bit);
749	h := y + h;
750	while y < h do
751	begin
752	Pixel := bmp.ScanLine[y] + 3 * x;
753	for i := 0 to w - 1 do
754	begin
755	Red := (Pixel[0] * (Color0 and $0000FF) + Pixel[1] * (Color1 and $0000FF)
756	+ Pixel[2] * (Color2 and $0000FF)) shr 8;
757	Green := (Pixel[0] * (Color0 shr 8 and $0000FF) + Pixel[1] *
758	(Color1 shr 8 and $0000FF) + Pixel[2] * (Color2 shr 8 and
759	$0000FF)) shr 8;
760	Pixel[0] := (Pixel[0] * (Color0 shr 16 and $0000FF) + Pixel[1] *
761	(Color1 shr 16 and $0000FF) + Pixel[2] * (Color2 shr 16 and $0000FF))
762	shr 8; // Blue
763	Pixel[1] := Green;
764	Pixel[2] := Red;
765	Pixel := Pointer(Pixel) + 3;
766	end;
767	inc(y);
768	end
769	end;
770
771	procedure Sprite(Canvas: TCanvas; HGr, xDst, yDst, Width, Height, xGr,
772	yGr: integer);
773	begin
774	BitBlt(Canvas.Handle, xDst, yDst, Width, Height,
775	GrExt[HGr].Mask.Canvas.Handle, xGr, yGr, SRCAND);
776	BitBlt(Canvas.Handle, xDst, yDst, Width, Height,
777	GrExt[HGr].Data.Canvas.Handle, xGr, yGr, SRCPAINT);
778	end;
779
780	procedure Sprite(dst: TBitmap; HGr, xDst, yDst, Width, Height, xGr,
781	yGr: integer);
782	begin
783	BitBlt(dst.Canvas.Handle, xDst, yDst, Width, Height,
784	GrExt[HGr].Mask.Canvas.Handle, xGr, yGr, SRCAND);
785	BitBlt(dst.Canvas.Handle, xDst, yDst, Width, Height,
786	GrExt[HGr].Data.Canvas.Handle, xGr, yGr, SRCPAINT);
787	end;
788
789	procedure SLine(ca: TCanvas; x0, x1, y: integer; cl: TColor);
790	begin
791	with ca do
792	begin
793	Pen.Color := cl;
794	MoveTo(x0, y);
795	LineTo(x1 + 1, y);
796	end
797	end;
798
799	procedure DLine(ca: TCanvas; x0, x1, y: integer; cl0, cl1: TColor);
800	begin
801	with ca do
802	begin
803	Pen.Color := cl0;
804	MoveTo(x0, y);
805	LineTo(x1, y);
806	Pen.Color := cl1;
807	MoveTo(x0 + 1, y + 1);
808	LineTo(x1 + 1, y + 1);
809	Pixels[x0, y + 1] := cl0;
810	Pixels[x1, y] := cl1;
811	end
812	end;
813
814	procedure Frame(ca: TCanvas; x0, y0, x1, y1: integer; cl0, cl1: TColor);
815	begin
816	with ca do
817	begin
818	MoveTo(x0, y1);
819	Pen.Color := cl0;
820	LineTo(x0, y0);
821	LineTo(x1, y0);
822	Pen.Color := cl1;
823	LineTo(x1, y1);
824	LineTo(x0, y1);
825	end
826	end;
827
828	procedure RFrame(ca: TCanvas; x0, y0, x1, y1: integer; cl0, cl1: TColor);
829	begin
830	with ca do
831	begin
832	Pen.Color := cl0;
833	MoveTo(x0, y0 + 1);
834	LineTo(x0, y1);
835	MoveTo(x0 + 1, y0);
836	LineTo(x1, y0);
837	Pen.Color := cl1;
838	MoveTo(x1, y0 + 1);
839	LineTo(x1, y1);
840	MoveTo(x0 + 1, y1);
841	LineTo(x1, y1);
842	end
843	end;
844
845	procedure CFrame(ca: TCanvas; x0, y0, x1, y1, Corner: integer; cl: TColor);
846	begin
847	with ca do
848	begin
849	Pen.Color := cl;
850	MoveTo(x0, y0 + Corner - 1);
851	LineTo(x0, y0);
852	LineTo(x0 + Corner, y0);
853	MoveTo(x1, y0 + Corner - 1);
854	LineTo(x1, y0);
855	LineTo(x1 - Corner, y0);
856	MoveTo(x1, y1 - Corner + 1);
857	LineTo(x1, y1);
858	LineTo(x1 - Corner, y1);
859	MoveTo(x0, y1 - Corner + 1);
860	LineTo(x0, y1);
861	LineTo(x0 + Corner, y1);
862	end
863	end;
864
865	procedure FrameImage(ca: TCanvas; Src: TBitmap;
866	x, y, Width, Height, xSrc, ySrc: integer; IsControl: boolean = false);
867	begin
868	if IsControl then
869	begin
870	Frame(ca, x - 1, y - 1, x + Width, y + Height, $B0B0B0, $FFFFFF);
871	RFrame(ca, x - 2, y - 2, x + Width + 1, y + Height + 1, $FFFFFF, $B0B0B0);
872	end
873	else
874	Frame(ca, x - 1, y - 1, x + Width, y + Height, $000000, $000000);
875	BitBlt(ca.Handle, x, y, Width, Height, Src.Canvas.Handle, xSrc, ySrc,
876	SRCCOPY);
877	end;
878
879	procedure GlowFrame(dst: TBitmap; x0, y0, Width, Height: integer; cl: TColor);
880	type
881	TLine = array [0 .. 649, 0 .. 2] of Byte;
882	var
883	x, y, ch, r: integer;
884	DstLine: ^TLine;
885	begin
886	for y := -GlowRange + 1 to Height - 1 + GlowRange - 1 do
887	begin
888	DstLine := dst.ScanLine[y0 + y];
889	for x := -GlowRange + 1 to Width - 1 + GlowRange - 1 do
890	begin
891	if x < 0 then
892	if y < 0 then
893	r := round(sqrt(sqr(x) + sqr(y)))
894	else if y >= Height then
895	r := round(sqrt(sqr(x) + sqr(y - (Height - 1))))
896	else
897	r := -x
898	else if x >= Width then
899	if y < 0 then
900	r := round(sqrt(sqr(x - (Width - 1)) + sqr(y)))
901	else if y >= Height then
902	r := round(sqrt(sqr(x - (Width - 1)) + sqr(y - (Height - 1))))
903	else
904	r := x - (Width - 1)
905	else if y < 0 then
906	r := -y
907	else if y >= Height then
908	r := y - (Height - 1)
909	else
910	continue;
911	if r = 0 then
912	r := 1;
913	if r < GlowRange then
914	for ch := 0 to 2 do
915	DstLine[x0 + x][2 - ch] :=
916	(DstLine[x0 + x][2 - ch] * (r - 1) + (cl shr (8 * ch) and $FF) *
917	(GlowRange - r)) div (GlowRange - 1);
918	end;
919	end
920	end;
921
922	procedure InitOrnament;
923	var
924	x, y, p, light, shade: integer;
925	begin
926	if InitOrnamentDone then
927	exit;
928	light := MainTexture.clBevelLight;
929	// and $FCFCFC shr 2*3+MainTexture.clBevelShade and $FCFCFC shr 2;
930	shade := MainTexture.clBevelShade and $FCFCFC shr 2 * 3 +
931	MainTexture.clBevelLight and $FCFCFC shr 2;
932	for x := 0 to wOrna - 1 do
933	for y := 0 to hOrna - 1 do
934	begin
935	p := GrExt[HGrSystem2].Data.Canvas.Pixels[xOrna + x, yOrna + y];
936	if p = $0000FF then
937	GrExt[HGrSystem2].Data.Canvas.Pixels[xOrna + x, yOrna + y] := light
938	else if p = $FF0000 then
939	GrExt[HGrSystem2].Data.Canvas.Pixels[xOrna + x, yOrna + y] := shade
940	end;
941	InitOrnamentDone := true
942	end;
943
944	procedure InitCityMark(const T: TTexture);
945	var
946	x, y, intensity: integer;
947	begin
948	for x := 0 to 9 do
949	for y := 0 to 9 do
950	if GrExt[HGrSystem].Mask.Canvas.Pixels[66 + x, 47 + y] = 0 then
951	begin
952	intensity := GrExt[HGrSystem].Data.Canvas.Pixels
953	[66 + x, 47 + y] and $FF;
954	GrExt[HGrSystem].Data.Canvas.Pixels[77 + x, 47 + y] := T.clMark and
955	$FF * intensity div $FF + T.clMark shr 8 and
956	$FF * intensity div $FF shl 8 + T.clMark shr 16 and
957	$FF * intensity div $FF shl 16
958	end;
959	BitBlt(GrExt[HGrSystem].Mask.Canvas.Handle, 77, 47, 10, 10,
960	GrExt[HGrSystem].Mask.Canvas.Handle, 66, 47, SRCCOPY);
961	end;
962
963	procedure Fill(ca: TCanvas; Left, Top, Width, Height, xOffset,
964	yOffset: integer);
965	begin
966	assert((Left + xOffset >= 0) and (Left + xOffset + Width <= wMainTexture) and
967	(Top + yOffset >= 0) and (Top + yOffset + Height <= hMainTexture));
968	BitBlt(ca.Handle, Left, Top, Width, Height, MainTexture.Image.Canvas.Handle,
969	Left + xOffset, Top + yOffset, SRCCOPY);
970	end;
971
972	procedure FillLarge(ca: TCanvas; x0, y0, x1, y1, xm: integer);
973
974	function band(i: integer): integer;
975	var
976	n: integer;
977	begin
978	n := ((hMainTexture div 2) div (y1 - y0)) * 2;
979	while hMainTexture div 2 + (i + 1) * (y1 - y0) > hMainTexture do
980	dec(i, n);
981	while hMainTexture div 2 + i * (y1 - y0) < 0 do
982	inc(i, n);
983	result := i;
984	end;
985
986	var
987	i: integer;
988	begin
989	for i := 0 to (x1 - xm) div wMainTexture - 1 do
990	BitBlt(ca.Handle, xm + i * wMainTexture, y0, wMainTexture, y1 - y0,
991	MainTexture.Image.Canvas.Handle, 0, hMainTexture div 2 + band(i) *
992	(y1 - y0), SRCCOPY);
993	BitBlt(ca.Handle, xm + ((x1 - xm) div wMainTexture) * wMainTexture, y0,
994	x1 - (xm + ((x1 - xm) div wMainTexture) * wMainTexture), y1 - y0,
995	MainTexture.Image.Canvas.Handle, 0, hMainTexture div 2 +
996	band((x1 - xm) div wMainTexture) * (y1 - y0), SRCCOPY);
997	for i := 0 to (xm - x0) div wMainTexture - 1 do
998	BitBlt(ca.Handle, xm - (i + 1) * wMainTexture, y0, wMainTexture, y1 - y0,
999	MainTexture.Image.Canvas.Handle, 0, hMainTexture div 2 + band(-i - 1) *
1000	(y1 - y0), SRCCOPY);
1001	BitBlt(ca.Handle, x0, y0, xm - ((xm - x0) div wMainTexture) * wMainTexture -
1002	x0, y1 - y0, MainTexture.Image.Canvas.Handle,
1003	((xm - x0) div wMainTexture + 1) * wMainTexture - (xm - x0),
1004	hMainTexture div 2 + band(-(xm - x0) div wMainTexture - 1) *
1005	(y1 - y0), SRCCOPY);
1006	end;
1007
1008	procedure FillSeamless(ca: TCanvas; Left, Top, Width, Height, xOffset,
1009	yOffset: integer; const Texture: TBitmap);
1010	var
1011	x, y, x0cut, y0cut, x1cut, y1cut: integer;
1012	begin
1013	while xOffset < 0 do
1014	inc(xOffset, Texture.Width);
1015	while yOffset < 0 do
1016	inc(yOffset, Texture.Height);
1017	for y := (Top + yOffset) div Texture.Height to (Top + yOffset + Height - 1)
1018	div Texture.Height do
1019	begin
1020	y0cut := Top + yOffset - y * Texture.Height;
1021	if y0cut < 0 then
1022	y0cut := 0;
1023	y1cut := (y + 1) * Texture.Height - (Top + yOffset + Height);
1024	if y1cut < 0 then
1025	y1cut := 0;
1026	for x := (Left + xOffset) div Texture.Width to (Left + xOffset + Width - 1)
1027	div Texture.Width do
1028	begin
1029	x0cut := Left + xOffset - x * Texture.Width;
1030	if x0cut < 0 then
1031	x0cut := 0;
1032	x1cut := (x + 1) * Texture.Width - (Left + xOffset + Width);
1033	if x1cut < 0 then
1034	x1cut := 0;
1035	BitBlt(ca.Handle, x * Texture.Width + x0cut - xOffset,
1036	y * Texture.Height + y0cut - yOffset, Texture.Width - x0cut - x1cut,
1037	Texture.Height - y0cut - y1cut, Texture.Canvas.Handle, x0cut,
1038	y0cut, SRCCOPY);
1039	end
1040	end;
1041	end;
1042
1043	procedure FillRectSeamless(ca: TCanvas; x0, y0, x1, y1, xOffset,
1044	yOffset: integer; const Texture: TBitmap);
1045	begin
1046	FillSeamless(ca, x0, y0, x1 - x0, y1 - y0, xOffset, yOffset, Texture);
1047	end;
1048
1049	procedure PaintBackground(Form: TForm; Left, Top, Width, Height: integer);
1050	begin
1051	Fill(Form.Canvas, Left, Top, Width, Height, (wMainTexture - Form.ClientWidth)
1052	div 2, (hMainTexture - Form.ClientHeight) div 2);
1053	end;
1054
1055	procedure Corner(ca: TCanvas; x, y, Kind: integer; const T: TTexture);
1056	begin
1057	{ BitBlt(ca.Handle,x,y,8,8,GrExt[T.HGr].Mask.Canvas.Handle,
1058	T.xGr+29+Kind*9,T.yGr+89,SRCAND);
1059	BitBlt(ca.Handle,x,y,8,8,GrExt[T.HGr].Data.Canvas.Handle,
1060	T.xGr+29+Kind*9,T.yGr+89,SRCPAINT); }
1061	end;
1062
1063	procedure BiColorTextOut(ca: TCanvas; clMain, clBack: TColor; x, y: integer;
1064	s: string);
1065
1066	procedure PaintIcon(x, y, Kind: integer);
1067	begin
1068	BitBlt(ca.Handle, x, y + 6, 10, 10, GrExt[HGrSystem].Mask.Canvas.Handle,
1069	66 + Kind mod 11 * 11, 115 + Kind div 11 * 11, SRCAND);
1070	BitBlt(ca.Handle, x, y + 6, 10, 10, GrExt[HGrSystem].Data.Canvas.Handle,
1071	66 + Kind mod 11 * 11, 115 + Kind div 11 * 11, SRCPAINT);
1072	end;
1073
1074	var
1075	p, xp: integer;
1076	sp: string;
1077	shadow: boolean;
1078	begin
1079	inc(x);
1080	inc(y);
1081	for shadow := true downto false do
1082	with ca do
1083	if not shadow or (clBack <> $7F007F) then
1084	begin
1085	if shadow then
1086	Font.Color := clBack
1087	else
1088	Font.Color := clMain;
1089	sp := s;
1090	xp := x;
1091	repeat
1092	p := pos('%', sp);
1093	if (p = 0) or (p + 1 > Length(sp)) or
1094	not(sp[p + 1] in ['c', 'f', 'l', 'm', 'n', 'o', 'p', 'r', 't', 'w'])
1095	then
1096	begin
1097	ca.Textout(xp, y, sp);
1098	break
1099	end
1100	else
1101	begin
1102	Textout(xp, y, copy(sp, 1, p - 1));
1103	inc(xp, ca.TextWidth(copy(sp, 1, p - 1)));
1104	if not shadow then
1105	case sp[p + 1] of
1106	'c':
1107	PaintIcon(xp + 1, y, 6);
1108	'f':
1109	PaintIcon(xp + 1, y, 0);
1110	'l':
1111	PaintIcon(xp + 1, y, 8);
1112	'm':
1113	PaintIcon(xp + 1, y, 17);
1114	'n':
1115	PaintIcon(xp + 1, y, 7);
1116	'o':
1117	PaintIcon(xp + 1, y, 16);
1118	'p':
1119	PaintIcon(xp + 1, y, 2);
1120	'r':
1121	PaintIcon(xp + 1, y, 12);
1122	't':
1123	PaintIcon(xp + 1, y, 4);
1124	'w':
1125	PaintIcon(xp + 1, y, 13);
1126	end;
1127	inc(xp, 10);
1128	Delete(sp, 1, p + 1);
1129	end
1130	until false;
1131	dec(x);
1132	dec(y);
1133	end
1134	end;
1135
1136	function BiColorTextWidth(ca: TCanvas; s: string): integer;
1137	var
1138	p: integer;
1139	begin
1140	result := 1;
1141	repeat
1142	p := pos('%', s);
1143	if (p = 0) or (p = Length(s)) then
1144	begin
1145	inc(result, ca.TextWidth(s));
1146	break
1147	end
1148	else
1149	begin
1150	if not(s[p + 1] in ['c', 'f', 'l', 'm', 'n', 'o', 'p', 'r', 't', 'w'])
1151	then
1152	inc(result, ca.TextWidth(copy(s, 1, p + 1)))
1153	else
1154	inc(result, ca.TextWidth(copy(s, 1, p - 1)) + 10);
1155	Delete(s, 1, p + 1);
1156	end
1157	until false;
1158	end;
1159
1160	procedure LoweredTextOut(ca: TCanvas; cl: TColor; const T: TTexture;
1161	x, y: integer; s: string);
1162	begin
1163	if cl = -2 then
1164	BiColorTextOut(ca, (T.clBevelShade and $FEFEFE) shr 1,
1165	T.clBevelLight, x, y, s)
1166	else if cl < 0 then
1167	BiColorTextOut(ca, T.clTextShade, T.clTextLight, x, y, s)
1168	else
1169	BiColorTextOut(ca, cl, T.clTextLight, x, y, s)
1170	end;
1171
1172	procedure RisedTextOut(ca: TCanvas; x, y: integer; s: string);
1173	begin
1174	BiColorTextOut(ca, $FFFFFF, $000000, x, y, s)
1175	end;
1176
1177	procedure Gradient(ca: TCanvas; x, y, dx, dy, Width, Height, Color: integer;
1178	Brightness: array of integer);
1179	var
1180	i, r, g, b: integer;
1181	begin
1182	with ca do
1183	begin
1184	for i := 0 to 15 do
1185	begin // gradient
1186	r := Color and $FF + Brightness[i];
1187	if r < 0 then
1188	r := 0
1189	else if r >= 256 then
1190	r := 255;
1191	g := Color shr 8 and $FF + Brightness[i];
1192	if g < 0 then
1193	g := 0
1194	else if g >= 256 then
1195	g := 255;
1196	b := Color shr 16 and $FF + Brightness[i];
1197	if b < 0 then
1198	b := 0
1199	else if b >= 256 then
1200	b := 255;
1201	Pen.Color := r + g shl 8 + b shl 16;
1202	MoveTo(x + dx * i, y + dy * i);
1203	LineTo(x + dx * i + Width, y + dy * i + Height);
1204	end;
1205	Pen.Color := $000000;
1206	MoveTo(x + 1, y + 16 * dy + Height);
1207	LineTo(x + 16 * dx + Width, y + 16 * dy + Height);
1208	LineTo(x + 16 * dx + Width, y);
1209	end
1210	end;
1211
1212	procedure LightGradient(ca: TCanvas; x, y, Width, Color: integer);
1213	const
1214	Brightness: array [0 .. 15] of integer = (16, 12, 8, 4, 0, -4, -8, -12,
1215	-16, -20, -24, -28, -32, -36, -40, -44);
1216	begin
1217	Gradient(ca, x, y, 0, 1, Width, 0, Color, Brightness)
1218	end;
1219
1220	procedure DarkGradient(ca: TCanvas; x, y, Width, Kind: integer);
1221	const
1222	Brightness: array [0 .. 15] of integer = (16, 12, 8, 4, 0, -4, -8,
1223	-12 - 24, -16 + 16, -20, -24, -28, -32, -36, -40, -44);
1224	begin
1225	Gradient(ca, x, y, 0, 1, Width, 0, GrExt[HGrSystem].Data.Canvas.Pixels
1226	[187, 137 + Kind], Brightness)
1227	end;
1228
1229	procedure VLightGradient(ca: TCanvas; x, y, Height, Color: integer);
1230	const
1231	Brightness: array [0 .. 15] of integer = (16, 12, 8, 4, 0, -4, -8, -12,
1232	-16, -20, -24, -28, -32, -36, -40, -44);
1233	begin
1234	Gradient(ca, x, y, 1, 0, 0, Height, Color, Brightness)
1235	end;
1236
1237	procedure VDarkGradient(ca: TCanvas; x, y, Height, Kind: integer);
1238	const
1239	Brightness: array [0 .. 15] of integer = (16, 12, 8, 4, 0, -4, -8,
1240	-12 - 24, -16 + 16, -20, -24, -28, -32, -36, -40, -44);
1241	begin
1242	Gradient(ca, x, y, 1, 0, 0, Height, GrExt[HGrSystem].Data.Canvas.Pixels
1243	[187, 137 + Kind], Brightness)
1244	end;
1245
1246	procedure NumberBar(dst: TBitmap; x, y: integer; Cap: string; val: integer;
1247	const T: TTexture);
1248	var
1249	s: string;
1250	begin
1251	if val > 0 then
1252	begin
1253	DLine(dst.Canvas, x - 2, x + 170, y + 16, T.clBevelShade,
1254	T.clBevelLight);
1255	LoweredTextOut(dst.Canvas, -1, T, x - 2, y, Cap);
1256	s := IntToStr(val);
1257	RisedTextOut(dst.Canvas, x + 170 - BiColorTextWidth(dst.Canvas,
1258	s), y, s);
1259	end
1260	end;
1261
1262	procedure CountBar(dst: TBitmap; x, y, w: integer; Kind: integer;
1263	Cap: string; val: integer; const T: TTexture);
1264	var
1265	i, sd, ld, cl, xIcon, yIcon: integer;
1266	s: string;
1267	begin
1268	// val:=random(40); //!!!
1269	if val = 0 then
1270	exit;
1271	assert(Kind >= 0);
1272	with dst.Canvas do
1273	begin
1274	// xIcon:=x+100;
1275	// yIcon:=y;
1276	// DLine(dst.Canvas,x-2,x+170+32,y+16,T.clBevelShade,T.clBevelLight);
1277
1278	xIcon := x - 5;
1279	yIcon := y + 15;
1280	DLine(dst.Canvas, x - 2, xIcon + w + 2, yIcon + 16, T.clBevelShade,
1281	T.clBevelLight);
1282
1283	s := IntToStr(val);
1284	if val < 0 then
1285	cl := $0000FF
1286	else
1287	cl := -1;
1288	LoweredTextOut(dst.Canvas, cl, T, x - 2, y, Cap);
1289	LoweredTextOut(dst.Canvas, cl, T,
1290	xIcon + w + 2 - BiColorTextWidth(dst.Canvas, s), yIcon, s);
1291
1292	if (Kind = 12) and (val >= 100) then
1293	begin // science with symbol for 100
1294	val := val div 10;
1295	sd := 14 * (val div 10 + val mod 10 - 1);
1296	if sd = 0 then
1297	sd := 1;
1298	if sd < w - 44 then
1299	ld := sd
1300	else
1301	ld := w - 44;
1302	for i := 0 to val mod 10 - 1 do
1303	begin
1304	BitBlt(Handle, xIcon + 4 + i * (14 * ld div sd), yIcon + 2 + 1, 14,
1305	14, GrExt[HGrSystem].Mask.Canvas.Handle, 67 + Kind mod 8 * 15,
1306	70 + Kind div 8 * 15, SRCAND);
1307	Sprite(dst, HGrSystem, xIcon + 3 + i * (14 * ld div sd), yIcon + 2,
1308	14, 14, 67 + Kind mod 8 * 15, 70 + Kind div 8 * 15);
1309	end;
1310	for i := 0 to val div 10 - 1 do
1311	begin
1312	BitBlt(dst.Canvas.Handle, xIcon + 4 + (val mod 10) *
1313	(14 * ld div sd) + i * (14 * ld div sd), yIcon + 3, 14, 14,
1314	GrExt[HGrSystem].Mask.Canvas.Handle, 67 + 7 mod 8 * 15,
1315	70 + 7 div 8 * 15, SRCAND);
1316	Sprite(dst, HGrSystem, xIcon + 3 + (val mod 10) * (14 * ld div sd) +
1317	i * (14 * ld div sd), yIcon + 2, 14, 14, 67 + 7 mod 8 * 15,
1318	70 + 7 div 8 * 15);
1319	end;
1320	end
1321	else
1322	begin
1323	val := abs(val);
1324	if val mod 10 = 0 then
1325	sd := 14 * (val div 10 - 1)
1326	else
1327	sd := 10 * (val mod 10 - 1) + 14 * (val div 10);
1328	if sd = 0 then
1329	sd := 1;
1330	if sd < w - 44 then
1331	ld := sd
1332	else
1333	ld := w - 44;
1334	for i := 0 to val div 10 - 1 do
1335	begin
1336	BitBlt(Handle, xIcon + 4 + i * (14 * ld div sd), yIcon + 3, 14, 14,
1337	GrExt[HGrSystem].Mask.Canvas.Handle, 67 + Kind mod 8 * 15,
1338	70 + Kind div 8 * 15, SRCAND);
1339	Sprite(dst, HGrSystem, xIcon + 3 + i * (14 * ld div sd), yIcon + 2,
1340	14, 14, 67 + Kind mod 8 * 15, 70 + Kind div 8 * 15);
1341	end;
1342	for i := 0 to val mod 10 - 1 do
1343	begin
1344	BitBlt(dst.Canvas.Handle, xIcon + 4 + (val div 10) *
1345	(14 * ld div sd) + i * (10 * ld div sd), yIcon + 7, 10, 10,
1346	GrExt[HGrSystem].Mask.Canvas.Handle, 66 + Kind mod 11 * 11,
1347	115 + Kind div 11 * 11, SRCAND);
1348	Sprite(dst, HGrSystem, xIcon + 3 + (val div 10) * (14 * ld div sd) +
1349	i * (10 * ld div sd), yIcon + 6, 10, 10, 66 + Kind mod 11 * 11,
1350	115 + Kind div 11 * 11)
1351	end;
1352	end
1353	end
1354	end; // CountBar
1355
1356	procedure PaintProgressBar(ca: TCanvas;
1357	Kind, x, y, pos, Growth, max: integer; const T: TTexture);
1358	var
1359	i: integer;
1360	begin
1361	if pos > max then
1362	pos := max;
1363	if Growth < 0 then
1364	begin
1365	pos := pos + Growth;
1366	if pos < 0 then
1367	begin
1368	Growth := Growth - pos;
1369	pos := 0
1370	end
1371	end
1372	else if pos + Growth > max then
1373	Growth := max - pos;
1374	Frame(ca, x - 1, y - 1, x + max, y + 7, $000000, $000000);
1375	RFrame(ca, x - 2, y - 2, x + max + 1, y + 8, T.clBevelShade,
1376	T.clBevelLight);
1377	with ca do
1378	begin
1379	for i := 0 to pos div 8 - 1 do
1380	BitBlt(Handle, x + i * 8, y, 8, 7,
1381	GrExt[HGrSystem].Data.Canvas.Handle, 104, 9 + 8 * Kind, SRCCOPY);
1382	BitBlt(Handle, x + 8 * (pos div 8), y, pos - 8 * (pos div 8), 7,
1383	GrExt[HGrSystem].Data.Canvas.Handle, 104, 9 + 8 * Kind, SRCCOPY);
1384	if Growth > 0 then
1385	begin
1386	for i := 0 to Growth div 8 - 1 do
1387	BitBlt(Handle, x + pos + i * 8, y, 8, 7,
1388	GrExt[HGrSystem].Data.Canvas.Handle, 112, 9 + 8 * Kind, SRCCOPY);
1389	BitBlt(Handle, x + pos + 8 * (Growth div 8), y,
1390	Growth - 8 * (Growth div 8), 7, GrExt[HGrSystem].Data.Canvas.Handle,
1391	112, 9 + 8 * Kind, SRCCOPY);
1392	end
1393	else if Growth < 0 then
1394	begin
1395	for i := 0 to -Growth div 8 - 1 do
1396	BitBlt(Handle, x + pos + i * 8, y, 8, 7,
1397	GrExt[HGrSystem].Data.Canvas.Handle, 104, 1, SRCCOPY);
1398	BitBlt(Handle, x + pos + 8 * (-Growth div 8), y,
1399	-Growth - 8 * (-Growth div 8), 7,
1400	GrExt[HGrSystem].Data.Canvas.Handle, 104, 1, SRCCOPY);
1401	end;
1402	Brush.Color := $000000;
1403	FillRect(Rect(x + pos + abs(Growth), y, x + max, y + 7));
1404	Brush.Style := bsClear;
1405	end
1406	end;
1407
1408	// pos and growth are relative to max, set size independent
1409	procedure PaintRelativeProgressBar(ca: TCanvas;
1410	Kind, x, y, size, pos, Growth, max: integer; IndicateComplete: boolean;
1411	const T: TTexture);
1412	begin
1413	if Growth > 0 then
1414	PaintProgressBar(ca, Kind, x, y, pos * size div max,
1415	(Growth * size + max div 2) div max, size, T)
1416	else
1417	PaintProgressBar(ca, Kind, x, y, pos * size div max,
1418	(Growth * size - max div 2) div max, size, T);
1419	if IndicateComplete and (pos + Growth >= max) then
1420	Sprite(ca, HGrSystem, x + size - 10, y - 7, 23, 16, 1, 129);
1421	end;
1422
1423	procedure PaintLogo(ca: TCanvas; x, y, clLight, clShade: integer);
1424	begin
1425	BitBlt(LogoBuffer.Canvas.Handle, 0, 0, wLogo, hLogo, ca.Handle, x,
1426	y, SRCCOPY);
1427	ImageOp_BCC(LogoBuffer, Templates, 0, 0, 1, 1, wLogo, hLogo,
1428	clLight, clShade);
1429	BitBlt(ca.Handle, x, y, wLogo, hLogo, LogoBuffer.Canvas.Handle, 0,
1430	0, SRCCOPY);
1431	end;
1432
1433	function SetMainTextureByAge(Age: integer): boolean;
1434	begin
1435	if Age <> MainTextureAge then
1436	with MainTexture do
1437	begin
1438	MainTextureAge := Age;
1439	LoadGraphicFile(Image, HomeDir + 'Graphics' + DirectorySeparator + 'Texture' +
1440	IntToStr(Age + 1), gfJPG);
1441	clBevelLight := Colors.Canvas.Pixels[clkAge0 + Age, cliBevelLight];
1442	clBevelShade := Colors.Canvas.Pixels[clkAge0 + Age, cliBevelShade];
1443	clTextLight := Colors.Canvas.Pixels[clkAge0 + Age, cliTextLight];
1444	clTextShade := Colors.Canvas.Pixels[clkAge0 + Age, cliTextShade];
1445	clLitText := Colors.Canvas.Pixels[clkAge0 + Age, cliLitText];
1446	clMark := Colors.Canvas.Pixels[clkAge0 + Age, cliMark];
1447	clPage := Colors.Canvas.Pixels[clkAge0 + Age, cliPage];
1448	clCover := Colors.Canvas.Pixels[clkAge0 + Age, cliCover];
1449	result := true
1450	end
1451	else
1452	result := false
1453	end;
1454
1455	var
1456	i, p, size: integer;
1457	s: string;
1458	fontscript: TextFile;
1459	section: TFontType;
1460	Reg: TRegistry;
1461
1462	initialization
1463
1464	Reg := TRegistry.create;
1465	try
1466	Reg.OpenKey('SOFTWARE\cevo\RegVer9', true);
1467	if Reg.ValueExists('Gamma') then
1468	Gamma := Reg.ReadInteger('Gamma')
1469	else begin
1470	Gamma := 100;
1471	Reg.WriteInteger('Gamma', Gamma);
1472	end;
1473	finally
1474	Reg.Free;
1475	end;
1476
1477	if Gamma <> 100 then
1478	begin
1479	GammaLUT[0] := 0;
1480	for i := 1 to 255 do
1481	begin
1482	p := round(255.0 * exp(ln(i / 255.0) * 100.0 / Gamma));
1483	assert((p >= 0) and (p < 256));
1484	GammaLUT[i] := p;
1485	end;
1486	end;
1487
1488	{$IFDEF WINDOWS}
1489	EnumDisplaySettings(nil, $FFFFFFFF, StartResolution);
1490	{$ENDIF}
1491	ResolutionChanged := false;
1492
1493	Phrases := TStringTable.create;
1494	Phrases2 := TStringTable.create;
1495	Phrases2FallenBackToEnglish := false;
1496	if FileExists(DataDir + 'Localization' + DirectorySeparator + 'Language.txt') then
1497	begin
1498	Phrases.loadfromfile(DataDir + 'Localization' + DirectorySeparator + ' + Language.txt');
1499	if FileExists(DataDir + 'Localization' + DirectorySeparator + 'Language2.txt') then
1500	Phrases2.loadfromfile(DataDir + 'Localization' + DirectorySeparator + 'Language2.txt')
1501	else
1502	begin
1503	Phrases2.loadfromfile(HomeDir + 'Language2.txt');
1504	Phrases2FallenBackToEnglish := true;
1505	end
1506	end
1507	else
1508	begin
1509	Phrases.loadfromfile(HomeDir + 'Language.txt');
1510	Phrases2.loadfromfile(HomeDir + 'Language2.txt');
1511	end;
1512
1513	Sounds := TStringTable.create;
1514	if not Sounds.loadfromfile(HomeDir + 'Sounds' + DirectorySeparator + 'sound.txt') then
1515	begin
1516	Sounds.Free;
1517	Sounds := nil
1518	end;
1519
1520	for section := Low(TFontType) to High(TFontType) do
1521	UniFont[section] := TFont.create;
1522
1523	LogoBuffer := TBitmap.create;
1524	LogoBuffer.PixelFormat := pf24bit;
1525	LogoBuffer.Width := wBBook;
1526	LogoBuffer.Height := hBBook;
1527
1528	section := ftNormal;
1529	AssignFile(fontscript, LocalizedFilePath('Fonts.txt'));
1530	try
1531	Reset(fontscript);
1532	while not eof(fontscript) do
1533	begin
1534	ReadLn(fontscript, s);
1535	if s <> '' then
1536	if s[1] = '#' then
1537	begin
1538	s := TrimRight(s);
1539	if s = '#SMALL' then
1540	section := ftSmall
1541	else if s = '#TINY' then
1542	section := ftTiny
1543	else if s = '#CAPTION' then
1544	section := ftCaption
1545	else if s = '#BUTTON' then
1546	section := ftButton
1547	else
1548	section := ftNormal;
1549	end
1550	else
1551	begin
1552	p := pos(',', s);
1553	if p > 0 then
1554	begin
1555	UniFont[section].Name := Trim(copy(s, 1, p - 1));
1556	size := 0;
1557	for i := p + 1 to Length(s) do
1558	case s[i] of
1559	'0' .. '9':
1560	size := size * 10 + Byte(s[i]) - 48;
1561	'B', 'b':
1562	UniFont[section].Style := UniFont[section].Style + [fsBold];
1563	'I', 'i':
1564	UniFont[section].Style := UniFont[section].Style + [fsItalic];
1565	end;
1566	UniFont[section].size :=
1567	round(size * 72 / UniFont[section].PixelsPerInch);
1568	end
1569	end
1570	end;
1571	CloseFile(fontscript);
1572	except
1573	end;
1574
1575	nGrExt := 0;
1576	HGrSystem := LoadGraphicSet('System');
1577	HGrSystem2 := LoadGraphicSet('System2');
1578	Templates := TBitmap.create;
1579	LoadGraphicFile(Templates, HomeDir + 'Graphics' + DirectorySeparator + 'Templates', gfNoGamma);
1580	Templates.PixelFormat := pf24bit;
1581	Colors := TBitmap.create;
1582	LoadGraphicFile(Colors, HomeDir + 'Graphics' + DirectorySeparator + 'Colors');
1583	Paper := TBitmap.create;
1584	LoadGraphicFile(Paper, HomeDir + 'Graphics' + DirectorySeparator + 'Paper', gfJPG);
1585	BigImp := TBitmap.create;
1586	LoadGraphicFile(BigImp, HomeDir + 'Graphics' + DirectorySeparator + 'Icons');
1587	MainTexture.Image := TBitmap.create;
1588	MainTextureAge := -2;
1589	ClickFrameColor := GrExt[HGrSystem].Data.Canvas.Pixels[187, 175];
1590	InitOrnamentDone := false;
1591	GenerateNames := true;
1592
1593	finalization
1594
1595	RestoreResolution;
1596	for i := 0 to nGrExt - 1 do
1597	begin
1598	GrExt[i].Data.Free;
1599	GrExt[i].Mask.Free;
1600	FreeMem(GrExt[i]);
1601	end;
1602	for section := Low(TFontType) to High(TFontType) do
1603	UniFont[section].Free;
1604	Phrases.Free;
1605	FreeAndNil(Phrases2);
1606	if Sounds <> nil then
1607	Sounds.Free;
1608	LogoBuffer.Free;
1609	BigImp.Free;
1610	Paper.Free;
1611	Templates.Free;
1612	Colors.Free;
1613	MainTexture.Image.Free;
1614
1615	end.

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

Download in other formats: