source: trunk/Packages/CevoComponents/ScreenTools.pas@ 331

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