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

Last change on this file was 717, checked in by chronos, 8 weeks ago

Merged revision(s) 705-716 from trunk:

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