source: branches/delphi/ScreenTools.pas

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