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

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