source: branches/AlphaChannel/Packages/CevoComponents/ScreenTools.pas

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