source: trunk/Packages/CevoComponents/ScreenTools.pas

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