unit ScreenTools;

interface

uses
  {$IFDEF WINDOWS}
  Windows,
  {$ENDIF}
  StringTables, LCLIntf, LCLType, SysUtils, Classes, Math,
  GraphType, GraphicSet, LazFileUtils, Texture,
  {$IFDEF DPI}Dpi.Forms, Dpi.Menus, Dpi.Graphics, Dpi.Controls, Dpi.Common{$ELSE}
  Forms, Menus, Graphics, Controls{$ENDIF};

type
  TLoadGraphicFileOption = (gfNoError, gfNoGamma);
  TLoadGraphicFileOptions = set of TLoadGraphicFileOption;

  TFontType = (ftNormal, ftSmall, ftTiny, ftCaption, ftButton);

{$IFDEF WINDOWS}
function ChangeResolution(X, Y, bpp, freq: Integer): Boolean;
{$ENDIF}
procedure RestoreResolution;
procedure EmptyMenu(MenuItems: TMenuItem; Keep: Integer = 0);
function TurnToYear(Turn: Integer): Integer;
function TurnToString(Turn: Integer): string;
function MovementToString(Movement: Integer): string;
procedure BtnFrame(Canvas: TCanvas; P: TRect; T: TTexture);
procedure EditFrame(Canvas: TCanvas; P: TRect; T: TTexture);
function HexStringToColor(S: string): Integer;
function ExtractFileNameWithoutExt(const Filename: string): string;
function LoadGraphicFile(Bmp: TBitmap; FileName: string; Options: TLoadGraphicFileOptions = []): Boolean;
function LoadGraphicSet(const Name: string; Transparency: Boolean = True): TGraphicSet;
procedure Dump(Dst: TBitmap; HGr: TGraphicSet; xDst, yDst, Width, Height, xGr, yGr: Integer);
procedure BitmapReplaceColor(Dst: TBitmap; X, Y, Width, Height: Integer; OldColor, NewColor: TColor);
procedure Sprite(Canvas: TCanvas; HGr: TGraphicSet; xDst, yDst, Width, Height, xGr, yGr: Integer);
  overload;
procedure Sprite(Canvas: TCanvas; xDst, yDst: Integer; GraphicSetItem: TGraphicSetItem);
  overload;
procedure Sprite(Dst: TBitmap; HGr: TGraphicSet; xDst, yDst, Width, Height, xGr, yGr: Integer);
  overload;
procedure MakeBlue(Dst: TBitmap; X, Y, Width, Height: Integer);
procedure MakeRed(Dst: TBitmap; X, Y, Width, Height: Integer);
procedure ImageOp_B(Dst, Src: TBitmap; xDst, yDst, xSrc, ySrc, Width, Height: Integer);
procedure ImageOp_BCC(Dst, Src: TBitmap;
  xDst, yDst, xSrc, ySrc, Width, Height, Color1, Color2: Integer); overload;
procedure ImageOp_BCC(Dst, Src: TBitmap;
  DstPos: TPoint; SrcRect: TRect; Color1, Color2: Integer); overload;
procedure ImageOp_CBC(Dst, Src: TBitmap; xDst, yDst, xSrc, ySrc, Width, Height,
  Color0, Color2: Integer);
procedure ImageOp_CCC(Bmp: TBitmap; X, Y, Width, Height, Color0, Color1, Color2: Integer);
function BitBltCanvas(DestCanvas: TCanvas; X, Y, Width, Height: Integer;
  SrcCanvas: TCanvas; XSrc, YSrc: Integer; Rop: DWORD = SRCCOPY): Boolean; overload;
function BitBltCanvas(Dest: TCanvas; DestRect: TRect;
  Src: TCanvas; SrcPos: TPoint; Rop: DWORD = SRCCOPY): Boolean; overload;
function BitBltBitmap(Dest: TBitmap; X, Y, Width, Height: Integer;
  Src: TBitmap; XSrc, YSrc: Integer; Rop: DWORD = SRCCOPY): Boolean; overload;
function BitBltBitmap(Dest: TBitmap; DestRect: TRect;
  Src: TBitmap; SrcPos: TPoint; Rop: DWORD = SRCCOPY): Boolean; overload;
procedure SLine(Canvas: TCanvas; x0, x1, Y: Integer; cl: TColor);
procedure DLine(Canvas: TCanvas; x0, x1, Y: Integer; cl0, cl1: TColor);
procedure Frame(Canvas: TCanvas; x0, y0, x1, y1: Integer; cl0, cl1: TColor);
procedure RFrame(Canvas: TCanvas; x0, y0, x1, y1: Integer; cl0, cl1: TColor);
procedure CFrame(Canvas: TCanvas; x0, y0, x1, y1, Corner: Integer; cl: TColor);
procedure FrameImage(Canvas: TCanvas; Src: TBitmap;
  X, Y, Width, Height, xSrc, ySrc: Integer; IsControl: Boolean = False);
procedure GlowFrame(Dst: TBitmap; x0, y0, Width, Height: Integer; cl: TColor);
procedure InitOrnament;
procedure InitCityMark(Texture: TTexture);
procedure Fill(Canvas: TCanvas; Left, Top, Width, Height, xOffset, yOffset: Integer); overload;
procedure Fill(Canvas: TCanvas; Rect: TRect; Offset: TPoint); overload;
procedure FillLarge(Canvas: TCanvas; x0, y0, x1, y1, xm: Integer);
procedure FillSeamless(Canvas: TCanvas; Left, Top, Width, Height, xOffset, yOffset: Integer;
  const Texture: TBitmap);
procedure FillRectSeamless(Canvas: TCanvas; x0, y0, x1, y1, xOffset, yOffset: Integer;
  const Texture: TBitmap);
procedure PaintBackground(Canvas: TCanvas; Left, Top, Width, Height, FormWidth,
  FormHeight: Integer);
procedure Corner(Canvas: TCanvas; X, Y, Kind: Integer; T: TTexture);
procedure BiColorTextOut(Canvas: TCanvas; clMain, clBack: TColor; X, Y: Integer; S: string);
procedure LoweredTextOut(Canvas: TCanvas; cl: TColor; T: TTexture;
  X, Y: Integer; S: string);
function BiColorTextWidth(Canvas: TCanvas; S: string): Integer;
procedure RisedTextOut(Canvas: TCanvas; X, Y: Integer; S: string);
procedure LightGradient(Canvas: TCanvas; X, Y, Width, Color: Integer);
procedure DarkGradient(Canvas: TCanvas; X, Y, Width, Kind: Integer);
procedure VLightGradient(Canvas: TCanvas; X, Y, Height, Color: Integer);
procedure VDarkGradient(Canvas: TCanvas; X, Y, Height, Kind: Integer);
procedure UnderlinedTitleValue(Canvas: TCanvas; Title, Value: string; X, Y, Width: Integer);
procedure NumberBar(Dst: TBitmap; X, Y: Integer; Cap: string; Val: Integer;
  T: TTexture);
procedure CountBar(Dst: TBitmap; X, Y, W: Integer; Kind: Integer;
  Cap: string; Val: Integer; T: TTexture);
procedure PaintProgressBar(Canvas: TCanvas; Kind, X, Y, Pos, Growth, Max: Integer;
  T: TTexture);
procedure PaintRelativeProgressBar(Canvas: TCanvas;
  Kind, X, Y, Size, Pos, Growth, Max: Integer; IndicateComplete: Boolean;
  T: TTexture);
procedure PaintLogo(Canvas: TCanvas; X, Y, LightColor, ShadeColor: Integer);
procedure DrawBufferEnsureSize(Width, Height: Integer);
procedure LoadPhrases;
procedure Texturize(Dest, Texture: TBitmap; TransparentColor: Cardinal);
procedure DarkenImage(Bitmap: TBitmap; Change: Integer);
{$IFNDEF DPI}
function ScaleToNative(Value: Integer): Integer;
function ScaleToNativeDist(Base, Value: Integer): Integer;
function ScaleFromNative(Value: Integer): Integer;
function BitBltBitmapPrecise(Dest: TBitmap; X, Y, Width, Height: Integer; Src: TBitmap;
  XSrc, YSrc: Integer; Rop: DWORD = SRCCOPY; Precise: Boolean = False): Boolean;
{$ENDIF}
procedure UnshareBitmap(Bitmap: TBitmap);
procedure Gtk2Fix;
procedure Gtk2DisableControlStyling(WinControl: TWinControl);
procedure LoadConfig(Key: string);
procedure SaveConfig(Key: string);

const
  BmpExt = '.bmp';
  PngExt = '.png';
  JpgExt = '.jpg';

  TransparentColor1 = $FF00FF;
  TransparentColor2 = $7F007F;

  // template positions in Templates.png
  xNation = 1;
  yNation = 25;
  xCoal = 1;
  yCoal = 148;

  // Icons.bmp structure
  xSizeBig = 56;
  ySizeBig = 40;

  GlowRange = 8;

  EmptySpaceColor = $101010;

  // color matrix
  clkAge0 = 1;
  cliTexture = 0;
  cliBevelLight = cliTexture + 1;
  cliBevelShade = cliTexture + 2;
  cliTextLight = cliTexture + 3;
  cliTextShade = cliTexture + 4;
  cliLitText = cliTexture + 5;
  cliMark = cliTexture + 6;
  cliDimmedText = cliTexture + 7;
  cliRoad = 8;
  cliHouse = cliRoad + 1;
  cliImp = cliRoad + 2;
  cliImpProject = cliRoad + 3;
  cliPage = 13;
  cliCover = cliPage + 1;
  clkMisc = 5;
  cliPaper = 0;
  cliPaperText = 1;
  cliPaperCaption = 2;
  clkCity = 6;
  cliPlains = 0;
  cliPrairie = 1;
  cliHills = 2;
  cliTundra = 3;
  cliWater = 4;

var
  Phrases: TStringTable;
  Phrases2: TStringTable;
  GrExt: TGraphicSets;

  HGrSystem: TGraphicSet;
  CityMark1: TGraphicSetItem;
  CityMark2: TGraphicSetItem;

  HGrSystem2: TGraphicSet;
  Ornament: TGraphicSetItem;
  GBrainNoTerm: TGraphicSetItem;
  GBrainSuperVirtual: TGraphicSetItem;
  GBrainTerm: TGraphicSetItem;
  GBrainRandom: TGraphicSetItem;

  Templates: TGraphicSet;
  Logo: TGraphicSetItem;
  BigBook: TGraphicSetItem;
  SmallBook: TGraphicSetItem;
  MenuLogo: TGraphicSetItem;
  LinkArrows: TGraphicSetItem;
  ScienceNationDot: TGraphicSetItem;
  ResearchIcon: TGraphicSetItem;
  ChangeIcon: TGraphicSetItem;
  TreasuryIcon: TGraphicSetItem;
  StarshipDeparted: TGraphicSetItem;
  WeightOn: TGraphicSetItem;
  WeightOff: TGraphicSetItem;

  ClickFrameColor: Integer;
  MainTexture: TTexture;
  Colors: TBitmap;
  Paper: TBitmap;
  BigImp: TBitmap;
  DrawBuffer: TBitmap;
  FullScreen: Boolean;
  MusicEnabled: Boolean;
  MusicVolume: Single;
  TermBounds: TRect;
  GenerateNames: Boolean;
  InitOrnamentDone: Boolean;
  Phrases2FallenBackToEnglish: Boolean;

  UniFont: array [TFontType] of TFont;
  Gamma: Integer; // global gamma correction (cent)
  CustomDpiEnabled: Boolean;
  CustomDpi: Integer;

procedure LoadAssets;
procedure UnitInit;
procedure UnitDone;
procedure InitGammaLookupTable;


implementation

uses
  {$IFDEF DPI}Dpi.PixelPointer,{$ELSE}PixelPointer,{$ENDIF}
  Directories, Sound, Registry
  {$IFDEF LCLGTK2}, gtk2, WSProc{$ENDIF};

var
  {$IFDEF WINDOWS}
  StartResolution: TDeviceMode;
  ResolutionChanged: Boolean;
  {$ENDIF}

  GammaLookupTable: array [0..255] of Byte;

{$IFDEF WINDOWS}
function ChangeResolution(X, Y, bpp, freq: Integer): Boolean;
var
  DevMode: TDeviceMode;
begin
  EnumDisplaySettings(nil, 0, DevMode);
  DevMode.dmFields := DM_PELSWIDTH or DM_PELSHEIGHT or DM_BITSPERPEL or
    DM_DISPLAYFREQUENCY;
  DevMode.dmPelsWidth := X;
  DevMode.dmPelsHeight := Y;
  DevMode.dmBitsPerPel := bpp;
  DevMode.dmDisplayFrequency := freq;
  Result := ChangeDisplaySettings(DevMode, 0) = DISP_CHANGE_SUCCESSFUL;
  if Result then
    ResolutionChanged := True;
end;

{$ENDIF}

procedure RestoreResolution;
begin
  {$IFDEF WINDOWS}
  if ResolutionChanged then
    ChangeDisplaySettings(StartResolution, 0);
  ResolutionChanged := False;
  {$ENDIF}
end;

procedure EmptyMenu(MenuItems: TMenuItem; Keep: Integer = 0);
var
  MenuItem: TMenuItem;
begin
  if Keep = 0 then MenuItems.Clear
  else
  while MenuItems.Count > Keep do begin
    MenuItem := MenuItems[MenuItems.Count - 1];
    MenuItems.Delete(MenuItems.Count - 1);
    FreeAndNil(MenuItem);
  end;
end;

function TurnToYear(Turn: Integer): Integer;
begin
  Result := -4000;
  if Turn <= 0 then Exit;

  // Year -4000..-1000, Turn 0..60
  Inc(Result, Min(60, Turn) * 50);
  Dec(Turn, Min(60, Turn));
  if Turn = 0 then Exit;

  // Year -1000..0, Turn 60..100
  Inc(Result, Min(40, Turn) * 25);
  Dec(Turn, Min(40, Turn));
  if Turn = 0 then Exit;

  // Year 0..1500, Turn 100..175
  Inc(Result, Min(75, Turn) * 20);
  Dec(Turn, Min(75, Turn));
  if Turn = 0 then Exit;

  // Year 1500..1750, Turn 175..200
  Inc(Result, Min(25, Turn) * 10);
  Dec(Turn, Min(25, Turn));
  if Turn = 0 then Exit;

  // Year 1750..1850, Turn 200..250
  Inc(Result, Min(50, Turn) * 2);
  Dec(Turn, Min(50, Turn));
  if Turn = 0 then Exit;

  // Year 1850.., Turn 250..
  Inc(Result, Turn);
end;

function TurnToString(Turn: Integer): string;
var
  Year: Integer;
begin
  if GenerateNames then
  begin
    Year := TurnToYear(Turn);
    if Year < 0 then
      Result := Format(Phrases.Lookup('BC'), [-Year])
    else
      Result := Format(Phrases.Lookup('AD'), [Year]);
  end
  else
    Result := IntToStr(Turn);
end;

function MovementToString(Movement: Integer): string;
begin
  if Movement >= 1000 then
  begin
    Result := Char(48 + Movement div 1000);
    Movement := Movement mod 1000;
  end
  else
    Result := '';
  Result := Result + Char(48 + Movement div 100);
  Movement := Movement mod 100;
  if Movement > 0 then
  begin
    Result := Result + '.' + Char(48 + Movement div 10);
    Movement := Movement mod 10;
    if Movement > 0 then
      Result := Result + Char(48 + Movement);
  end;
end;

procedure BtnFrame(Canvas: TCanvas; P: TRect; T: TTexture);
begin
  RFrame(Canvas, P.Left - 1, P.Top - 1, P.Right, P.Bottom, T.ColorBevelShade,
    T.ColorBevelLight);
end;

procedure EditFrame(Canvas: TCanvas; P: TRect; T: TTexture);
begin
  Frame(Canvas, P.Left - 1, P.Top - 1, P.Right, P.Bottom, $000000, $000000);
  Frame(Canvas, P.Left - 2, P.Top - 2, P.Right + 1, P.Bottom + 1, $000000, $000000);
  Frame(Canvas, P.Left - 3, P.Top - 3, P.Right + 2, P.Bottom + 1, $000000, $000000);
  RFrame(Canvas, P.Left - 4, P.Top - 4, P.Right + 3, P.Bottom + 2, T.ColorBevelShade,
    T.ColorBevelLight);
end;

function HexCharToInt(X: Char): Integer;
begin
  case X of
    '0' .. '9': Result := Ord(X) - Ord('0');
    'A' .. 'F': Result := Ord(X) - Ord('A') + 10;
    'a' .. 'f': Result := Ord(X) - Ord('a') + 10;
    else Result := 0
  end;
end;

function HexStringToColor(S: string): Integer;
begin
  while (Length(S) > 0) and (S[1] = ' ') do
    Delete(S, 1, 1);
  S := S + '000000';
  if Gamma = 100 then
    Result := $10 * HexCharToInt(S[1]) + $1 * HexCharToInt(S[2]) +
      $1000 * HexCharToInt(S[3]) + $100 * HexCharToInt(S[4]) +
      $100000 * HexCharToInt(S[5]) + $10000 * HexCharToInt(S[6])
  else
    Result := GammaLookupTable[$10 * HexCharToInt(S[1]) + HexCharToInt(S[2])] +
      $100 * GammaLookupTable[$10 * HexCharToInt(S[3]) + HexCharToInt(S[4])] +
      $10000 * GammaLookupTable[$10 * HexCharToInt(S[5]) + HexCharToInt(S[6])];
end;

function ApplyGammaToPixel(Pixel: TPixel32): TPixel32;
begin
  Result.R := GammaLookupTable[Pixel.R];
  Result.G := GammaLookupTable[Pixel.G];
  Result.B := GammaLookupTable[Pixel.B];
end;

procedure ApplyGammaToBitmap(Bitmap: TBitmap);
var
  PixelPtr: TPixelPointer;
  X, Y: Integer;
begin
  Bitmap.BeginUpdate;
  PixelPtr := TPixelPointer.Create(Bitmap);
  for Y := 0 to ScaleToNative(Bitmap.Height) - 1 do begin
    for X := 0 to ScaleToNative(Bitmap.Width) - 1 do begin
      PixelPtr.Pixel^ := ApplyGammaToPixel(PixelPtr.Pixel^);
      PixelPtr.NextPixel;
    end;
    PixelPtr.NextLine;
  end;
  Bitmap.EndUpdate;
end;

procedure CopyGray8BitTo24bitBitmap(Dst, Src: TRasterImage);
var
  SrcPtr, DstPtr: TPixelPointer;
  X, Y: Integer;
begin
  //Dst.SetSize(Src.Width, Src.Height);
  SrcPtr := TPixelPointer.Create(Src);
  DstPtr := TPixelPointer.Create(Dst);
  for Y := 0 to ScaleToNative(Src.Height - 1) do begin
    for X := 0 to ScaleToNative(Src.Width - 1) do begin
      DstPtr.PixelB := SrcPtr.PixelB;
      DstPtr.PixelG := SrcPtr.PixelB;
      DstPtr.PixelR := SrcPtr.PixelB;
      SrcPtr.NextPixel;
      DstPtr.NextPixel;
    end;
    SrcPtr.NextLine;
    DstPtr.NextLine;
  end;
end;

function LoadGraphicFile(Bmp: TBitmap; FileName: string; Options:
  TLoadGraphicFileOptions = []): Boolean;
var
  Jpeg: TJpegImage;
  Png: TPortableNetworkGraphic;
begin
  Result := False;
  if ExtractFileExt(FileName) = '' then
    FileName := FileName + PngExt;

  if FileExists(FileName) then begin
    if ExtractFileExt(FileName) = JpgExt then begin
      Jpeg := TJpegImage.Create;
      try
        Jpeg.LoadFromFile(FileName);
        if not (gfNoGamma in Options) then
          Bmp.PixelFormat := TPixelFormat.pf24bit;
        Bmp.SetSize(Jpeg.Width, Jpeg.Height);
        Bmp.Canvas.Draw(0, 0, Jpeg);
        Result := True;
      except
        Result := False;
      end;
      FreeAndNil(Jpeg);
    end else
    if ExtractFileExt(FileName) = PngExt then begin
      Png := TPortableNetworkGraphic.Create;
      try
        Png.PixelFormat := Bmp.PixelFormat;
        Png.LoadFromFile(FileName);
        if not (gfNoGamma in Options) then
          Bmp.PixelFormat := TPixelFormat.pf24bit;
        Bmp.SetSize(Png.Width, Png.Height);
        if (Png.RawImage.Description.Format = ricfGray) then
        begin
          // LCL doesn't support 8-bit colors properly. Use 24-bit instead.
          Bmp.PixelFormat := TPixelFormat.pf24bit;
          CopyGray8BitTo24bitBitmap(Bmp, Png);
        end
        else
          Bmp.Canvas.Draw(0, 0, Png);
        Result := True;
      except
        Result := False;
      end;
      FreeAndNil(Png);
    end else
    if ExtractFileExt(FileName) = BmpExt then begin
      try
        Bmp.LoadFromFile(FileName);
        if not (gfNoGamma in Options) then
          Bmp.PixelFormat := TPixelFormat.pf24bit;
        Result := True;
      except
        Result := False;
      end;
    end else
      raise Exception.Create('Unsupported image file type ' + ExtractFileExt(FileName));
  end;

  if not Result then begin
    if not (gfNoError in Options) then
      raise Exception.Create(Format(Phrases.Lookup('FILENOTFOUND'), [FileName]));
  end;

  if (not (gfNoGamma in Options)) and (Gamma <> 100) then
    ApplyGammaToBitmap(Bmp);
end;

function ExtractFileNameWithoutExt(const Filename: string): string;
var
  P: Integer;
begin
  Result := Filename;
  P := Length(Result);
  while P > 0 do begin
    case Result[P] of
      PathDelim: Exit;
      {$ifdef windows}
      '/': if ('/' in AllowDirectorySeparators) then Exit;
      {$endif}
      '.': Exit(Copy(Result, 1, P - 1));
    end;
    Dec(P);
  end;
end;

function LoadGraphicSet(const Name: string; Transparency: Boolean = True): TGraphicSet;
var
  X: Integer;
  Y: Integer;
  OriginalColor: Integer;
  FileName: string;
  DataPixel: TPixelPointer;
  MaskPixel: TPixelPointer;
begin
  Result := GrExt.SearchByName(Name);
  if not Assigned(Result) then begin
    Result := GrExt.AddNew(Name);
    FileName := GetGraphicsDir + DirectorySeparator + Name;
    // Do not apply gamma during file load as it would affect also transparency colors
    if not LoadGraphicFile(Result.Data, FileName, [gfNoGamma]) then begin
      Result := nil;
      Exit;
    end;

    FileName := ExtractFileNameWithoutExt(FileName) + GraphicSetFileExt;

    if FileExists(FileName) then
      Result.LoadFromFile(FileName);

    Result.ResetPixUsed;

    if Transparency then begin
      Result.Mask.SetSize(Result.Data.Width, Result.Data.Height);

      Result.Data.BeginUpdate;
      Result.Mask.BeginUpdate;
      DataPixel := TPixelPointer.Create(Result.Data);
      MaskPixel := TPixelPointer.Create(Result.Mask);
      for Y := 0 to ScaleToNative(Result.Data.Height) - 1 do begin
        for X := 0 to ScaleToNative(Result.Data.Width) - 1 do begin
          OriginalColor := DataPixel.PixelARGB and $FFFFFF;
          if (OriginalColor = TransparentColor1) or (OriginalColor = TransparentColor2) then begin
            MaskPixel.PixelRGB := $ffffff;
            DataPixel.PixelRGB := 0;
          end else begin
            MaskPixel.PixelRGB := 0;
          end;
          DataPixel.NextPixel;
          MaskPixel.NextPixel;
        end;
        DataPixel.NextLine;
        MaskPixel.NextLine;
      end;
      Result.Data.EndUpdate;
      Result.Mask.EndUpdate;

      if Gamma <> 100 then
        ApplyGammaToBitmap(Result.Data);
    end;
  end;
end;

procedure Dump(Dst: TBitmap; HGr: TGraphicSet; xDst, yDst, Width, Height, xGr, yGr: Integer);
begin
  BitBltBitmap(Dst, xDst, yDst, Width, Height, HGr.Data, xGr, yGr);
end;

procedure BitmapReplaceColor(Dst: TBitmap; X, Y, Width, Height: Integer; OldColor, NewColor: TColor);
var
  XX, YY: Integer;
  PixelPtr: TPixelPointer;
begin
  Dst.BeginUpdate;
  PixelPtr := TPixelPointer.Create(Dst, ScaleToNative(X), ScaleToNative(Y));
  for YY := 0 to ScaleToNative(Height) - 1 do begin
    for XX := 0 to ScaleToNative(Width) - 1 do begin
      if PixelPtr.PixelRGB = SwapRedBlue(OldColor) then begin
        PixelPtr.PixelRGB := SwapRedBlue(NewColor);
      end;
      PixelPtr.NextPixel;
    end;
    PixelPtr.NextLine;
  end;
  Dst.EndUpdate;
end;

procedure MakeBlue(Dst: TBitmap; X, Y, Width, Height: Integer);
var
  XX, YY: Integer;
  PixelPtr: TPixelPointer;
begin
  Dst.BeginUpdate;
  PixelPtr := TPixelPointer.Create(Dst, ScaleToNative(X), ScaleToNative(Y));
  for yy := 0 to ScaleToNative(Height) - 1 do begin
    for xx := 0 to ScaleToNative(Width) - 1 do begin
      PixelPtr.PixelB := PixelPtr.PixelB div 2;
      PixelPtr.PixelG := PixelPtr.PixelG div 2;
      PixelPtr.PixelR := PixelPtr.PixelR div 2;
      PixelPtr.NextPixel;
    end;
    PixelPtr.NextLine;
  end;
  Dst.EndUpdate;
end;

procedure MakeRed(Dst: TBitmap; X, Y, Width, Height: Integer);
var
  XX, YY: Integer;
  Gray: Integer;
  PixelPtr: TPixelPointer;
begin
  Dst.BeginUpdate;
  PixelPtr := TPixelPointer.Create(Dst, ScaleToNative(X), ScaleToNative(Y));
  for YY := 0 to ScaleToNative(Height) - 1 do begin
    for XX := 0 to ScaleToNative(Width) - 1 do begin
      Gray := (Integer(PixelPtr.PixelB) + Integer(PixelPtr.PixelG) +
        Integer(PixelPtr.PixelR)) * 85 shr 8;
      PixelPtr.PixelB := 0;
      PixelPtr.PixelG := 0;
      PixelPtr.PixelR := Gray; // 255-(255-gray) div 2;
      PixelPtr.NextPixel;
    end;
    PixelPtr.NextLine;
  end;
  Dst.EndUpdate;
end;

procedure ImageOp_B(Dst, Src: TBitmap; xDst, yDst, xSrc, ySrc, Width, Height: Integer);
// Src is template
// X channel = background amp (old Dst content), 128=original brightness
var
  X, Y: Integer;
  Brightness, Test: Integer;
  PixelSrc: TPixelPointer;
  PixelDst: TPixelPointer;
begin
  xDst := ScaleToNative(xDst);
  yDst := ScaleToNative(yDst);
  xSrc := ScaleToNative(xSrc);
  ySrc := ScaleToNative(ySrc);
  Width := ScaleToNative(Width);
  Height := ScaleToNative(Height);
  //Assert(Src.PixelFormat = pf8bit);
  Assert(Dst.PixelFormat = TPixelFormat.pf24bit);
  if xDst < 0 then begin
    Width := Width + xDst;
    xSrc := xSrc - xDst;
    xDst := 0;
  end;
  if yDst < 0 then begin
    Height := Height + yDst;
    ySrc := ySrc - yDst;
    yDst := 0;
  end;
  if xDst + Width > ScaleToNative(Dst.Width) then
    Width := ScaleToNative(Dst.Width) - xDst;
  if yDst + Height > ScaleToNative(Dst.Height) then
    Height := ScaleToNative(Dst.Height) - yDst;
  if (Width < 0) or (Height < 0) then
    Exit;

  Dst.BeginUpdate;
  Src.BeginUpdate;
  PixelDst := TPixelPointer.Create(Dst, xDst, yDst);
  PixelSrc := TPixelPointer.Create(Src, xSrc, ySrc);
  for Y := 0 to Height - 1 do begin
    for X := 0 to Width - 1 do  begin
      Brightness := PixelSrc.PixelB; // One byte for 8-bit color
      Test := (PixelDst.PixelR * Brightness) shr 7;
      if Test >= 256 then
        PixelDst.PixelR := 255
      else
        PixelDst.PixelR := Test; // Red
      Test := (PixelDst.PixelG * Brightness) shr 7;
      if Test >= 256 then
        PixelDst.PixelG := 255
      else
        PixelDst.PixelG := Test; // Green
      Test := (PixelDst.PixelB * Brightness) shr 7;
      if Test >= 256 then
        PixelDst.PixelR := 255
      else
        PixelDst.PixelB := Test; // Blue
      PixelDst.NextPixel;
      PixelSrc.NextPixel;
    end;
    PixelDst.NextLine;
    PixelSrc.NextLine;
  end;
  Src.EndUpdate;
  Dst.EndUpdate;
end;

procedure ImageOp_BCC(Dst, Src: TBitmap; xDst, yDst, xSrc, ySrc, Width, Height,
  Color1, Color2: Integer);
// Src is template
// B channel = background amp (old Dst content), 128=original brightness
// G channel = Color1 amp, 128=original brightness
// R channel = Color2 amp, 128=original brightness
var
  ix, iy, amp1, amp2, trans, Value: Integer;
  SrcPixel: TPixelPointer;
  DstPixel: TPixelPointer;
  DstWidth, DstHeight: Integer;
  SrcWidth, SrcHeight: Integer;
begin
  if xDst < 0 then begin
    Width := Width + xDst;
    xSrc := xSrc - xDst;
    xDst := 0;
  end;
  if yDst < 0 then begin
    Height := Height + yDst;
    ySrc := ySrc - yDst;
    yDst := 0;
  end;
  if xDst + Width > Dst.Width then
    Width := Dst.Width - xDst;
  if yDst + Height > Dst.Height then
    Height := Dst.Height - yDst;
  if (Width < 0) or (Height < 0) then
    Exit;
  DstWidth := ScaleToNativeDist(xDst, Width);
  DstHeight := ScaleToNativeDist(yDst, Height);
  SrcWidth := ScaleToNativeDist(xSrc, Width);
  SrcHeight := ScaleToNativeDist(ySrc, Height);
  xDst := ScaleToNative(xDst);
  yDst := ScaleToNative(yDst);
  xSrc := ScaleToNative(xSrc);
  ySrc := ScaleToNative(ySrc);

  Src.BeginUpdate;
  Dst.BeginUpdate;
  SrcPixel := TPixelPointer.Create(Src, xSrc, ySrc);
  DstPixel := TPixelPointer.Create(Dst, xDst, yDst);
  for iy := 0 to DstHeight - 1 do begin
    for ix := 0 to DstWidth - 1 do begin
      trans := SrcPixel.PixelB * 2; // green channel = transparency
      amp1 := SrcPixel.PixelG * 2;
      amp2 := SrcPixel.PixelR * 2;
      if trans <> $FF then begin
        Value := (DstPixel.PixelB * trans + ((Color2 shr 16) and $FF) *
          amp2 + ((Color1 shr 16) and $FF) * amp1) div $FF;
        DstPixel.PixelB := Min(Value, 255);

        Value := (DstPixel.PixelG * trans + ((Color2 shr 8) and $FF) *
          amp2 + ((Color1 shr 8) and $FF) * amp1) div $FF;
        DstPixel.PixelG := Min(Value, 255);

        Value := (DstPixel.PixelR * trans + (Color2 and $FF) *
          amp2 + (Color1 and $FF) * amp1) div $FF;
        DstPixel.PixelR := Min(Value, 255);
      end;

      if ix < SrcWidth - 1 then SrcPixel.NextPixel;
      DstPixel.NextPixel;
    end;
    if iy < SrcHeight - 1 then SrcPixel.NextLine
      else SrcPixel.SetX(0);
    DstPixel.NextLine;
  end;
  Src.EndUpdate;
  Dst.EndUpdate;
end;

procedure ImageOp_BCC(Dst, Src: TBitmap; DstPos: TPoint; SrcRect: TRect;
  Color1, Color2: Integer);
begin
  ImageOp_BCC(Dst, Src, DstPos.X, DstPos.Y, SrcRect.Left, SrcRect.Top,
    SrcRect.Width, SrcRect.Height, Color1, Color2);
end;

procedure ImageOp_CBC(Dst, Src: TBitmap; xDst, yDst, xSrc, ySrc, Width, Height,
  Color0, Color2: Integer);
// Src is template
// B channel = Color0 amp
// G channel = background amp (old Dst content), 128=original brightness
// R channel = Color2 amp
var
  ix, iy, amp0, amp1, trans, Value: Integer;
  SrcPixel: TPixelPointer;
  DstPixel: TPixelPointer;
begin
  xDst := ScaleToNative(xDst);
  yDst := ScaleToNative(yDst);
  xSrc := ScaleToNative(xSrc);
  ySrc := ScaleToNative(ySrc);
  Width := ScaleToNative(Width);
  Height := ScaleToNative(Height);
  Src.BeginUpdate;
  Dst.BeginUpdate;
  SrcPixel := TPixelPointer.Create(Src, xSrc, ySrc);
  DstPixel := TPixelPointer.Create(Dst, xDst, yDst);
  for iy := 0 to Height - 1 do begin
    for ix := 0 to Width - 1 do begin
      trans := SrcPixel.PixelB * 2; // green channel = transparency
      amp0 := SrcPixel.PixelG * 2;
      amp1 := SrcPixel.PixelR * 2;
      if trans <> $FF then begin
        Value := (DstPixel.PixelB * trans + (Color2 shr 16 and $FF) * amp1 +
          (Color0 shr 16 and $FF) * amp0) div $FF;
        DstPixel.PixelB := Min(Value, 255);

        Value := (DstPixel.PixelG * trans + (Color2 shr 8 and $FF) * amp1 +
          (Color0 shr 8 and $FF) * amp0) div $FF;
        DstPixel.PixelG := Min(Value, 255);

        Value := (DstPixel.PixelR * trans + (Color2 and $FF) * amp1 +
          (Color0 and $FF) * amp0) div $FF;
        DstPixel.PixelR := Min(Value, 255);
      end;
      SrcPixel.NextPixel;
      DstPixel.NextPixel;
    end;
    SrcPixel.NextLine;
    DstPixel.NextLine;
  end;
  Src.EndUpdate;
  Dst.EndUpdate;
end;

procedure ImageOp_CCC(Bmp: TBitmap; X, Y, Width, Height, Color0, Color1, Color2: Integer);
// Bmp is template
// B channel = Color0 amp, 128=original brightness
// G channel = Color1 amp, 128=original brightness
// R channel = Color2 amp, 128=original brightness
var
  XX, YY: Integer;
  Red, Green: Integer;
  PixelPtr: TPixelPointer;
begin
  X := ScaleToNative(X);
  Y := ScaleToNative(Y);
  Width := ScaleToNativeDist(X, Width);
  Height := ScaleToNativeDist(Y, Height);

  if X + Width > ScaleToNative(Bmp.Width) then
    Width := ScaleToNative(Bmp.Width) - X;
  if Y + Height > ScaleToNative(Bmp.Height) then
    Height := ScaleToNative(Bmp.Height) - Y;
  if (Width < 0) or (Height < 0) then
    Exit;

  Bmp.BeginUpdate;
  Assert(Bmp.PixelFormat = TPixelFormat.pf24bit);
  PixelPtr := TPixelPointer.Create(Bmp, X, Y);
  for YY := 0 to Height - 1 do begin
    for XX := 0 to Width - 1 do begin
      Red := ((PixelPtr.PixelB * (Color0 and $0000FF) + PixelPtr.PixelG *
        (Color1 and $0000FF) + PixelPtr.PixelR * (Color2 and $0000FF)) shr 8) and $ff;
      Green := ((PixelPtr.PixelB * ((Color0 shr 8) and $0000FF) +
        PixelPtr.PixelG * ((Color1 shr 8) and $0000FF) + PixelPtr.PixelR *
        ((Color2 shr 8) and $0000FF)) shr 8) and $ff;
      PixelPtr.PixelB := ((PixelPtr.PixelB * ((Color0 shr 16) and $0000FF) +
        PixelPtr.PixelG * ((Color1 shr 16) and $0000FF) + PixelPtr.PixelR *
        ((Color2 shr 16) and $0000FF)) shr 8) and $ff; // Blue
      PixelPtr.PixelG := Green;
      PixelPtr.PixelR := Red;
      PixelPtr.NextPixel;
    end;
    PixelPtr.NextLine;
  end;
  Bmp.EndUpdate;
end;

procedure Sprite(Canvas: TCanvas; HGr: TGraphicSet; xDst, yDst, Width, Height, xGr, yGr: Integer);
begin
  BitBltCanvas(Canvas, xDst, yDst, Width, Height, HGr.Mask.Canvas, xGr, yGr, SRCAND);
  BitBltCanvas(Canvas, xDst, yDst, Width, Height, HGr.Data.Canvas, xGr, yGr, SRCPAINT);
end;

procedure Sprite(Canvas: TCanvas; xDst, yDst: Integer; GraphicSetItem: TGraphicSetItem);
begin
  Sprite(Canvas, GraphicSetItem.GraphicSet, xDst, yDst, GraphicSetItem.Width,
    GraphicSetItem.Height, GraphicSetItem.Left, GraphicSetItem.Top);
end;

procedure Sprite(Dst: TBitmap; HGr: TGraphicSet; xDst, yDst, Width, Height, xGr, yGr: Integer);
begin
  Sprite(Dst.Canvas, HGr, xDst, yDst, Width, Height, xGr, yGr);
end;

function BitBltCanvas(DestCanvas: TCanvas; X, Y, Width, Height: Integer;
  SrcCanvas: TCanvas; XSrc, YSrc: Integer; Rop: DWORD = SRCCOPY): Boolean;
begin
  {$IFDEF WINDOWS}
    {$IFDEF DPI}
    Result := BitBlt(DestCanvas.Handle, X, Y, Width, Height, SrcCanvas.Handle, XSrc, YSrc, Rop);
    {$ELSE}
    // LCLIntf.BitBlt is slower than direct Windows BitBlt
    Result := Windows.BitBlt(DestCanvas.Handle, ScaleToNative(X), ScaleToNative(Y),
      ScaleToNative(Width), ScaleToNative(Height), SrcCanvas.Handle,
      ScaleToNative(XSrc), ScaleToNative(YSrc), Rop);
    {$ENDIF}
  {$ELSE}
  Result := BitBlt(DestCanvas.Handle, X, Y, Width, Height, SrcCanvas.Handle, XSrc, YSrc, Rop);
  {$ENDIF}
end;

function BitBltCanvas(Dest: TCanvas; DestRect: TRect; Src: TCanvas;
  SrcPos: TPoint; Rop: DWORD): Boolean;
begin
  Result := BitBltCanvas(Dest, DestRect.Left, DestRect.Top, DestRect.Width, DestRect.Height,
    Src, SrcPos.X, SrcPos.Y, Rop);
end;

function BitBltBitmap(Dest: TBitmap; X, Y, Width, Height: Integer;
  Src: TBitmap; XSrc, YSrc: Integer; Rop: DWORD): Boolean;
begin
  Result := BitBltCanvas(Dest.Canvas, X, Y, Width, Height, Src.Canvas, XSrc, YSrc, Rop);
end;

function BitBltBitmap(Dest: TBitmap; DestRect: TRect; Src: TBitmap;
  SrcPos: TPoint; Rop: DWORD): Boolean;
begin
  Result := BitBltCanvas(Dest.Canvas, DestRect, Src.Canvas, SrcPos, Rop);
end;

procedure SLine(Canvas: TCanvas; x0, x1, Y: Integer; cl: TColor);
begin
  with Canvas do begin
    Pen.Color := cl;
    MoveTo(x0, Y);
    LineTo(x1 + 1, Y);
  end;
end;

procedure DLine(Canvas: TCanvas; x0, x1, Y: Integer; cl0, cl1: TColor);
begin
  with Canvas do begin
    Pen.Color := cl0;
    MoveTo(x0, Y);
    LineTo(x1, Y);
    Pen.Color := cl1;
    MoveTo(x0 + 1, Y + 1);
    LineTo(x1 + 1, Y + 1);
    Pixels[x0, Y + 1] := cl0;
    Pixels[x1, Y] := cl1;
  end;
end;

procedure Frame(Canvas: TCanvas; x0, y0, x1, y1: Integer; cl0, cl1: TColor);
begin
  with Canvas do begin
    MoveTo(x0, y1);
    Pen.Color := cl0;
    LineTo(x0, y0);
    LineTo(x1, y0);
    Pen.Color := cl1;
    LineTo(x1, y1);
    LineTo(x0, y1);
  end;
end;

procedure RFrame(Canvas: TCanvas; x0, y0, x1, y1: Integer; cl0, cl1: TColor);
begin
  with Canvas do begin
    Pen.Color := cl0;
    MoveTo(x0, y0 + 1);
    LineTo(x0, y1);
    MoveTo(x0 + 1, y0);
    LineTo(x1, y0);
    Pen.Color := cl1;
    MoveTo(x1, y0 + 1);
    LineTo(x1, y1);
    MoveTo(x0 + 1, y1);
    LineTo(x1, y1);
  end;
end;

procedure CFrame(Canvas: TCanvas; x0, y0, x1, y1, Corner: Integer; cl: TColor);
begin
  with Canvas do begin
    Pen.Color := cl;
    MoveTo(x0, y0 + Corner - 1);
    LineTo(x0, y0);
    LineTo(x0 + Corner, y0);
    MoveTo(x1, y0 + Corner - 1);
    LineTo(x1, y0);
    LineTo(x1 - Corner, y0);
    MoveTo(x1, y1 - Corner + 1);
    LineTo(x1, y1);
    LineTo(x1 - Corner, y1);
    MoveTo(x0, y1 - Corner + 1);
    LineTo(x0, y1);
    LineTo(x0 + Corner, y1);
  end;
end;

procedure FrameImage(Canvas: TCanvas; Src: TBitmap;
  X, Y, Width, Height, xSrc, ySrc: Integer; IsControl: Boolean = False);
begin
  if IsControl then begin
    Frame(Canvas, X - 1, Y - 1, X + Width, Y + Height, $B0B0B0, $FFFFFF);
    RFrame(Canvas, X - 2, Y - 2, X + Width + 1, Y + Height + 1, $FFFFFF, $B0B0B0);
  end else
    Frame(Canvas, X - 1, Y - 1, X + Width, Y + Height, $000000, $000000);
  BitBltCanvas(Canvas, X, Y, Width, Height, Src.Canvas, xSrc, ySrc);
end;

procedure GlowFrame(Dst: TBitmap; x0, y0, Width, Height: Integer; cl: TColor);
var
  X, Y, ch, R: Integer;
  DstPtr: TPixelPointer;
  DpiGlowRange: Integer;
begin
  DpiGlowRange := ScaleToNative(GlowRange);
  X0 := ScaleToNative(X0);
  Y0 := ScaleToNative(Y0);
  Width := ScaleToNative(Width);
  Height := ScaleToNative(Height);
  Dst.BeginUpdate;
  DstPtr := TPixelPointer.Create(Dst, x0 - DpiGlowRange + 1, y0 - DpiGlowRange + 1);
  for Y := -DpiGlowRange + 1 to Height - 1 + DpiGlowRange - 1 do begin
    for X := -DpiGlowRange + 1 to Width - 1 + DpiGlowRange - 1 do begin
      if X < 0 then
        if Y < 0 then
          R := Round(Sqrt(Sqr(X) + Sqr(Y)))
        else if Y >= Height then
          R := Round(Sqrt(Sqr(X) + Sqr(Y - (Height - 1))))
        else
          R := -X
      else if X >= Width then
        if Y < 0 then
          R := Round(sqrt(Sqr(X - (Width - 1)) + Sqr(Y)))
        else if Y >= Height then
          R := Round(Sqrt(Sqr(X - (Width - 1)) + Sqr(Y - (Height - 1))))
        else
          R := X - (Width - 1)
      else if Y < 0 then
        R := -Y
      else if Y >= Height then
        R := Y - (Height - 1)
      else begin
        DstPtr.NextPixel;
        Continue;
      end;
      if R = 0 then
        R := 1;
      if R < DpiGlowRange then
        for ch := 0 to 2 do
          DstPtr.PixelPlane[2 - ch] :=
            (DstPtr.PixelPlane[2 - ch] * (R - 1) + (cl shr (8 * ch) and $FF) *
            (DpiGlowRange - R)) div (DpiGlowRange - 1);
      DstPtr.NextPixel;
    end;
    DstPtr.NextLine;
  end;
  Dst.EndUpdate;
end;

procedure InitOrnament;
var
  P: TColor;
  X, Y: Integer;
  Light, Shade: TColor32;
  PixelPtr: TPixelPointer;
begin
  if InitOrnamentDone then Exit;
  Light := ColorToColor32(MainTexture.ColorBevelLight);
  // and $FCFCFC shr 2*3+MainTexture.ColorBevelShade and $FCFCFC shr 2;
  Shade := ColorToColor32(MainTexture.ColorBevelShade and $FCFCFC shr 2 * 3 +
    MainTexture.ColorBevelLight and $FCFCFC shr 2);
  HGrSystem2.Data.BeginUpdate;
  PixelPtr := TPixelPointer.Create(HGrSystem2.Data, ScaleToNative(Ornament.Left),
    ScaleToNative(Ornament.Top));
  if PixelPtr.BytesPerPixel = 3 then begin
    for Y := 0 to ScaleToNative(Ornament.Height) - 1 do begin
      for X := 0 to ScaleToNative(Ornament.Width) - 1 do begin
        P := Color32ToColor(PixelPtr.PixelRGB);
        if P = $0000FF then PixelPtr.PixelRGB := Light
        else if P = $FF0000 then PixelPtr.PixelRGB := Shade;
        PixelPtr.NextPixel;
      end;
      PixelPtr.NextLine;
    end;
  end else begin
    for Y := 0 to ScaleToNative(Ornament.Height) - 1 do begin
      for X := 0 to ScaleToNative(Ornament.Width) - 1 do begin
        P := Color32ToColor(PixelPtr.PixelARGB);
        if P = $0000FF then PixelPtr.PixelARGB := Light
        else if P = $FF0000 then PixelPtr.PixelARGB := Shade;
        PixelPtr.NextPixel;
      end;
      PixelPtr.NextLine;
    end;
  end;
  InitOrnamentDone := True;
  HGrSystem2.Data.EndUpdate;
end;

procedure InitCityMark(Texture: TTexture);
var
  X: Integer;
  Y: Integer;
  Intensity: Integer;
begin
  for X := 0 to CityMark1.Width - 1 do begin
    for Y := 0 to CityMark1.Height - 1 do begin
      if HGrSystem.Mask.Canvas.Pixels[CityMark1.Left + X, CityMark1.Top + Y] = 0 then
      begin
        Intensity := HGrSystem.Data.Canvas.Pixels[CityMark1.Left +
          X, CityMark1.Top + Y] and $FF;
        HGrSystem.Data.Canvas.Pixels[CityMark2.Left + X, CityMark2.Top + Y] :=
          Texture.ColorMark and $FF * Intensity div $FF + Texture.ColorMark shr 8 and
          $FF * Intensity div $FF shl 8 + Texture.ColorMark shr 16 and
          $FF * Intensity div $FF shl 16;
      end;
    end;
  end;
  BitBltBitmap(HGrSystem.Mask, CityMark2.Left, CityMark2.Top, CityMark1.Width,
    CityMark1.Width, HGrSystem.Mask, CityMark1.Left, CityMark1.Top);
end;

procedure Fill(Canvas: TCanvas; Left, Top, Width, Height, xOffset, yOffset: Integer);
var
  X, Y: Integer;
  XX, YY: Integer;
  W, H: Integer;
begin
  // BitBltCanvas(Canvas, Left, Top, Width, Height, MainTexture.Image.Canvas,
  //   Left + xOffset, Top + yOffset);
  if Width < MainTexture.Width then W := Width
    else W := MainTexture.Width;
  if Height < MainTexture.Height then H := Height
    else H := MainTexture.Height;
  if MainTexture.Height > 0 then YY := Trunc(Height / MainTexture.Height)
    else YY := 0;
  if MainTexture.Width > 0 then XX := Trunc(Width / MainTexture.Width)
    else XX := 0;
  for Y := 0 to YY do
  for X := 0 to XX do
    begin
    BitBltCanvas(Canvas, Left + X * MainTexture.Width, Top + Y * MainTexture.Height,
      W, H, MainTexture.Image.Canvas, 0, 0);
  end;
end;

procedure Fill(Canvas: TCanvas; Rect: TRect; Offset: TPoint);
begin
  Fill(Canvas, Rect.Left, Rect.Top, Rect.Width, Rect.Height, Offset.X, Offset.Y);
end;

procedure FillLarge(Canvas: TCanvas; x0, y0, x1, y1, xm: Integer);

  function Band(I: Integer): Integer;
  var
    N: Integer;
  begin
    N := ((MainTexture.Height div 2) div (y1 - y0)) * 2;
    while MainTexture.Height div 2 + (I + 1) * (y1 - y0) > MainTexture.Height do
      Dec(I, N);
    while MainTexture.Height div 2 + I * (y1 - y0) < 0 do
      Inc(I, N);
    Result := I;
  end;

var
  I: Integer;
begin
  for I := 0 to (x1 - xm) div MainTexture.Width - 1 do
    BitBltCanvas(Canvas, xm + I * MainTexture.Width, y0, MainTexture.Width, y1 - y0,
      MainTexture.Image.Canvas, 0, MainTexture.Height div 2 + Band(I) *
      (y1 - y0));
  BitBltCanvas(Canvas, xm + ((x1 - xm) div MainTexture.Width) * MainTexture.Width, y0,
    x1 - (xm + ((x1 - xm) div MainTexture.Width) * MainTexture.Width), y1 - y0,
    MainTexture.Image.Canvas, 0, MainTexture.Height div 2 + Band(
    (x1 - xm) div MainTexture.Width) * (y1 - y0));
  for I := 0 to (xm - x0) div MainTexture.Width - 1 do
    BitBltCanvas(Canvas, xm - (I + 1) * MainTexture.Width, y0, MainTexture.Width, y1 - y0,
      MainTexture.Image.Canvas, 0, MainTexture.Height div 2 +
      Band(-I - 1) * (y1 - y0));
  BitBltCanvas(Canvas, x0, y0, xm - ((xm - x0) div MainTexture.Width) *
    MainTexture.Width - x0, y1 - y0, MainTexture.Image.Canvas,
    ((xm - x0) div MainTexture.Width + 1) * MainTexture.Width - (xm - x0),
    MainTexture.Height div 2 + Band(-(xm - x0) div MainTexture.Width - 1) * (y1 - y0));
end;

procedure FillSeamless(Canvas: TCanvas; Left, Top, Width, Height, xOffset, yOffset: Integer;
  const Texture: TBitmap);
var
  X, Y, x0cut, y0cut, x1cut, y1cut: Integer;
begin
  while xOffset < 0 do
    Inc(xOffset, Texture.Width);
  while yOffset < 0 do
    Inc(yOffset, Texture.Height);
  for Y := (Top + yOffset) div Texture.Height to (Top + yOffset + Height - 1) div
    Texture.Height do
  begin
    y0cut := Top + yOffset - Y * Texture.Height;
    if y0cut < 0 then
      y0cut := 0;
    y1cut := (Y + 1) * Texture.Height - (Top + yOffset + Height);
    if y1cut < 0 then
      y1cut := 0;
    for X := (Left + xOffset) div Texture.Width to (Left + xOffset + Width - 1) div
      Texture.Width do
    begin
      x0cut := Left + xOffset - X * Texture.Width;
      if x0cut < 0 then
        x0cut := 0;
      x1cut := (X + 1) * Texture.Width - (Left + xOffset + Width);
      if x1cut < 0 then
        x1cut := 0;
      BitBltCanvas(Canvas, X * Texture.Width + x0cut - xOffset,
        Y * Texture.Height + y0cut - yOffset, Texture.Width - x0cut - x1cut,
        Texture.Height - y0cut - y1cut, Texture.Canvas, x0cut, y0cut);
    end;
  end;
end;

procedure FillRectSeamless(Canvas: TCanvas; x0, y0, x1, y1, xOffset, yOffset: Integer;
  const Texture: TBitmap);
begin
  FillSeamless(Canvas, x0, y0, x1 - x0, y1 - y0, xOffset, yOffset, Texture);
end;

procedure PaintBackground(Canvas: TCanvas; Left, Top, Width, Height, FormWidth,
  FormHeight: Integer);
begin
  Fill(Canvas, Left, Top, Width, Height, 0, 0)
end;

procedure Corner(Canvas: TCanvas; X, Y, Kind: Integer; T: TTexture);
begin
  { BitBltCanvas(Canvas, x, y, 8, 8, T.HGr.Mask.Canvas,
    T.xGr + 29 + Kind * 9, T.yGr + 89, SRCAND);
    BitBltCanvas(Canvas, X, Y, 8, 8, T.HGr.Data.Canvas,
    T.xGr + 29 + Kind * 9, T.yGr + 89, SRCPAINT); }
end;

procedure BiColorTextOut(Canvas: TCanvas; clMain, clBack: TColor; X, Y: Integer; S: string);

  procedure PaintIcon(X, Y, Kind: Integer);
  begin
    Sprite(Canvas, HGrSystem, X, Y + 6, 10, 10,
      66 + Kind mod 11 * 11, 115 + Kind div 11 * 11);
  end;

var
  P, xp: Integer;
  sp: string;
  Shadow: Boolean;
  Text: string;
begin
  Inc(X);
  Inc(Y);
  for Shadow := True downto False do
    with Canvas do
      if not Shadow or (clBack <> $7F007F) then
      begin
        if Shadow then
          Font.Color := clBack
        else
          Font.Color := clMain;
        sp := S;
        xp := X;
        repeat
          P := Pos('%', sp);
          if (P = 0) or (P + 1 > Length(sp)) or not
            (sp[P + 1] in ['c', 'f', 'l', 'm', 'n', 'o', 'p', 'r', 't', 'w']) then
          begin
            Canvas.TextOut(xp, Y, sp);
            Break;
          end
          else
          begin
            Text := Copy(sp, 1, P - 1);
            TextOut(xp, Y, Text);
            Inc(xp, Canvas.TextWidth(Text));
            if not Shadow then
              case sp[P + 1] of
                'c': PaintIcon(xp + 1, Y, 6);
                'f': PaintIcon(xp + 1, Y, 0);
                'l': PaintIcon(xp + 1, Y, 8);
                'm': PaintIcon(xp + 1, Y, 17);
                'n': PaintIcon(xp + 1, Y, 7);
                'o': PaintIcon(xp + 1, Y, 16);
                'p': PaintIcon(xp + 1, Y, 2);
                'r': PaintIcon(xp + 1, Y, 12);
                't': PaintIcon(xp + 1, Y, 4);
                'w': PaintIcon(xp + 1, Y, 13);
              end;
            Inc(xp, 10);
            Delete(sp, 1, P + 1);
          end;
        until False;
        Dec(X);
        Dec(Y);
      end;
end;

function BiColorTextWidth(Canvas: TCanvas; S: string): Integer;
var
  P: Integer;
begin
  Result := 1;
  repeat
    P := Pos('%', S);
    if (P = 0) or (P = Length(S)) then
    begin
      Inc(Result, Canvas.TextWidth(S));
      Break;
    end
    else
    begin
      if not (S[P + 1] in ['c', 'f', 'l', 'm', 'n', 'o', 'p', 'r', 't', 'w'])
      then
        Inc(Result, Canvas.TextWidth(Copy(S, 1, P + 1)))
      else
        Inc(Result, Canvas.TextWidth(Copy(S, 1, P - 1)) + 10);
      Delete(S, 1, P + 1);
    end;
  until False;
end;

procedure LoweredTextOut(Canvas: TCanvas; cl: TColor; T: TTexture;
  X, Y: Integer; S: string);
begin
  if cl = -2 then
    BiColorTextOut(Canvas, (T.ColorBevelShade and $FEFEFE) shr 1,
      T.ColorBevelLight, X, Y, S)
  else if cl < 0 then
    BiColorTextOut(Canvas, T.ColorTextShade, T.ColorTextLight, X, Y, S)
  else
    BiColorTextOut(Canvas, cl, T.ColorTextLight, X, Y, S);
end;

procedure RisedTextOut(Canvas: TCanvas; X, Y: Integer; S: string);
begin
  BiColorTextOut(Canvas, $FFFFFF, $000000, X, Y, S);
end;

procedure Gradient(Canvas: TCanvas; X, Y, dx, dy, Width, Height, Color: Integer;
  Brightness: array of Integer);
var
  I, R, G, B: Integer;
begin
  for I := 0 to Length(Brightness) - 1 do begin // gradient
    R := Color and $FF + Brightness[I];
    if R < 0 then
      R := 0
    else if R >= 256 then
      R := 255;
    G := Color shr 8 and $FF + Brightness[I];
    if G < 0 then
      G := 0
    else if G >= 256 then
      G := 255;
    B := Color shr 16 and $FF + Brightness[I];
    if B < 0 then
      B := 0
    else if B >= 256 then
      B := 255;
    Canvas.Pen.Color := R + G shl 8 + B shl 16;
    Canvas.MoveTo(X + dx * I, Y + dy * I);
    Canvas.LineTo(X + dx * I + Width, Y + dy * I + Height);
  end;
  Canvas.Pen.Color := $000000;
  Canvas.MoveTo(X + 1, Y + 16 * dy + Height);
  Canvas.LineTo(X + 16 * dx + Width, Y + 16 * dy + Height);
  Canvas.LineTo(X + 16 * dx + Width, Y);
end;

procedure LightGradient(Canvas: TCanvas; X, Y, Width, Color: Integer);
const
  Brightness: array [0 .. 15] of Integer =
    (16, 12, 8, 4, 0, -4, -8, -12, -16, -20, -24, -28, -32, -36, -40, -44);
begin
  Gradient(Canvas, X, Y, 0, 1, Width, 0, Color, Brightness);
end;

procedure DarkGradient(Canvas: TCanvas; X, Y, Width, Kind: Integer);
const
  Brightness: array [0 .. 15] of Integer =
    (16, 12, 8, 4, 0, -4, -8, -12 - 24, -16 + 16, -20, -24, -28, -32, -36, -40, -44);
begin
  Gradient(Canvas, X, Y, 0, 1, Width, 0, HGrSystem.Data.Canvas.Pixels
    [187, 137 + Kind], Brightness);
end;

procedure VLightGradient(Canvas: TCanvas; X, Y, Height, Color: Integer);
const
  Brightness: array [0 .. 15] of Integer =
    (16, 12, 8, 4, 0, -4, -8, -12, -16, -20, -24, -28, -32, -36, -40, -44);
begin
  Gradient(Canvas, X, Y, 1, 0, 0, Height, Color, Brightness);
end;

procedure VDarkGradient(Canvas: TCanvas; X, Y, Height, Kind: Integer);
const
  Brightness: array [0 .. 15] of Integer =
    (16, 12, 8, 4, 0, -4, -8, -12 - 24, -16 + 16, -20, -24, -28, -32, -36, -40, -44);
begin
  Gradient(Canvas, X, Y, 1, 0, 0, Height,
    HGrSystem.Data.Canvas.Pixels[187, 137 + Kind], Brightness);
end;

procedure UnderlinedTitleValue(Canvas: TCanvas; Title, Value: string; X, Y, Width: Integer);
begin
  DLine(Canvas, X, X + Width, Y + 19, MainTexture.ColorBevelLight, MainTexture.ColorBevelShade);
  RisedTextOut(Canvas, X, Y, Title);
  RisedTextOut(Canvas, X + Width - BiColorTextWidth(Canvas, Value), Y, Value);
end;

procedure NumberBar(Dst: TBitmap; X, Y: Integer; Cap: string;
  Val: Integer; T: TTexture);
var
  S: string;
begin
  if Val > 0 then
  begin
    DLine(Dst.Canvas, X - 2, X + 170, Y + 16, T.ColorBevelShade,
      T.ColorBevelLight);
    LoweredTextOut(Dst.Canvas, -1, T, X - 2, Y, Cap);
    S := IntToStr(Val);
    RisedTextOut(Dst.Canvas, X + 170 - BiColorTextWidth(Dst.Canvas,
      S), Y, S);
  end;
end;

procedure CountBar(Dst: TBitmap; X, Y, W: Integer; Kind: Integer;
  Cap: string; Val: Integer; T: TTexture);
var
  I, sd, ld, cl, xIcon, yIcon: Integer;
  S: string;
begin
  // Val := Random(40); //!!!
  if Val = 0 then
    Exit;
  Assert(Kind >= 0);
  with Dst.Canvas do
  begin
    // xIcon:=x+100;
    // yIcon:=y;
    // DLine(Dst.Canvas,x-2,x+170+32,y+16,T.ColorBevelShade,T.ColorBevelLight);

    xIcon := X - 5;
    yIcon := Y + 15;
    DLine(Dst.Canvas, X - 2, xIcon + W + 2, yIcon + 16, T.ColorBevelShade,
      T.ColorBevelLight);

    S := IntToStr(Val);
    if Val < 0 then
      cl := $0000FF
    else
      cl := -1;
    LoweredTextOut(Dst.Canvas, cl, T, X - 2, Y, Cap);
    LoweredTextOut(Dst.Canvas, cl, T,
      xIcon + W + 2 - BiColorTextWidth(Dst.Canvas, S), yIcon, S);

    if (Kind = 12) and (Val >= 100) then
    begin // science with symbol for 100
      Val := Val div 10;
      sd := 14 * (Val div 10 + Val mod 10 - 1);
      if sd = 0 then
        sd := 1;
      if sd < W - 44 then
        ld := sd
      else
        ld := W - 44;
      for I := 0 to Val mod 10 - 1 do
      begin
        BitBltBitmap(Dst, xIcon + 4 + I * (14 * ld div sd), yIcon + 2 + 1, 14,
          14, HGrSystem.Mask, 67 + Kind mod 8 * 15,
          70 + Kind div 8 * 15, SRCAND);
        Sprite(Dst, HGrSystem, xIcon + 3 + I * (14 * ld div sd), yIcon + 2,
          14, 14, 67 + Kind mod 8 * 15, 70 + Kind div 8 * 15);
      end;
      for I := 0 to Val div 10 - 1 do
      begin
        BitBltBitmap(Dst, xIcon + 4 + (Val mod 10) *
          (14 * ld div sd) + I * (14 * ld div sd), yIcon + 3, 14, 14,
          HGrSystem.Mask, 67 + 7 mod 8 * 15,
          70 + 7 div 8 * 15, SRCAND);
        Sprite(Dst, HGrSystem, xIcon + 3 + (Val mod 10) *
          (14 * ld div sd) + I * (14 * ld div sd), yIcon + 2, 14,
          14, 67 + 7 mod 8 * 15,
          70 + 7 div 8 * 15);
      end;
    end
    else
    begin
      Val := Abs(Val);
      if Val mod 10 = 0 then
        sd := 14 * (Val div 10 - 1)
      else
        sd := 10 * (Val mod 10 - 1) + 14 * (Val div 10);
      if sd = 0 then
        sd := 1;
      if sd < W - 44 then
        ld := sd
      else
        ld := W - 44;
      for I := 0 to Val div 10 - 1 do
      begin
        BitBltBitmap(Dst, xIcon + 4 + I * (14 * ld div sd), yIcon + 3, 14, 14,
          HGrSystem.Mask, 67 + Kind mod 8 * 15,
          70 + Kind div 8 * 15, SRCAND);
        Sprite(Dst, HGrSystem, xIcon + 3 + I * (14 * ld div sd), yIcon + 2,
          14, 14, 67 + Kind mod 8 * 15, 70 + Kind div 8 * 15);
      end;
      for I := 0 to Val mod 10 - 1 do
      begin
        BitBltBitmap(Dst, xIcon + 4 + (Val div 10) *
          (14 * ld div sd) + I * (10 * ld div sd), yIcon + 7, 10, 10,
          HGrSystem.Mask, 66 + Kind mod 11 * 11,
          115 + Kind div 11 * 11, SRCAND);
        Sprite(Dst, HGrSystem, xIcon + 3 + (Val div 10) *
          (14 * ld div sd) + I * (10 * ld div sd), yIcon + 6, 10,
          10, 66 + Kind mod 11 * 11,
          115 + Kind div 11 * 11);
      end;
    end;
  end;
end;

procedure PaintProgressBar(Canvas: TCanvas; Kind, X, Y, Pos, Growth, Max: Integer;
  T: TTexture);
var
  I: Integer;
begin
  if Pos > Max then
    Pos := Max;
  if Growth < 0 then
  begin
    Pos := Pos + Growth;
    if Pos < 0 then
    begin
      Growth := Growth - Pos;
      Pos := 0;
    end;
  end
  else if Pos + Growth > Max then
    Growth := Max - Pos;
  Frame(Canvas, X - 1, Y - 1, X + Max, Y + 7, $000000, $000000);
  RFrame(Canvas, X - 2, Y - 2, X + Max + 1, Y + 8, T.ColorBevelShade,
    T.ColorBevelLight);
  with Canvas do
  begin
    for I := 0 to Pos div 8 - 1 do
      BitBltCanvas(Canvas, X + I * 8, Y, 8, 7,
        HGrSystem.Data.Canvas, 104, 9 + 8 * Kind);
    BitBltCanvas(Canvas, X + 8 * (Pos div 8), Y, Pos - 8 * (Pos div 8), 7,
      HGrSystem.Data.Canvas, 104, 9 + 8 * Kind);
    if Growth > 0 then
    begin
      for I := 0 to Growth div 8 - 1 do
        BitBltCanvas(Canvas, X + Pos + I * 8, Y, 8, 7,
          HGrSystem.Data.Canvas, 112, 9 + 8 * Kind);
      BitBltCanvas(Canvas, X + Pos + 8 * (Growth div 8), Y,
        Growth - 8 * (Growth div 8), 7, HGrSystem.Data.Canvas,
        112, 9 + 8 * Kind);
    end
    else if Growth < 0 then
    begin
      for I := 0 to -Growth div 8 - 1 do
        BitBltCanvas(Canvas, X + Pos + I * 8, Y, 8, 7,
          HGrSystem.Data.Canvas, 104, 1);
      BitBltCanvas(Canvas, X + Pos + 8 * (-Growth div 8), Y, -Growth -
        8 * (-Growth div 8), 7,
        HGrSystem.Data.Canvas, 104, 1);
    end;
    Brush.Color := $000000;
    FillRect(Rect(X + Pos + Abs(Growth), Y, X + Max, Y + 7));
    Brush.Style := TBrushStyle.bsClear;
  end;
end;

// pos and growth are relative to max, set size independent
procedure PaintRelativeProgressBar(Canvas: TCanvas;
  Kind, X, Y, Size, Pos, Growth, Max: Integer; IndicateComplete: Boolean;
  T: TTexture);
begin
  if Growth > 0 then
    PaintProgressBar(Canvas, Kind, X, Y, Pos * Size div Max,
      (Growth * Size + Max div 2) div Max, Size, T)
  else
    PaintProgressBar(Canvas, Kind, X, Y, Pos * Size div Max,
      (Growth * Size - Max div 2) div Max, Size, T);
  if IndicateComplete and (Pos + Growth >= Max) then
    Sprite(Canvas, HGrSystem, X + Size - 10, Y - 7, 23, 16, 1, 129);
end;

procedure PaintLogo(Canvas: TCanvas; X, Y, LightColor, ShadeColor: Integer);
begin
  if not Assigned(DrawBuffer) then Exit;
  DrawBufferEnsureSize(Logo.Width, Logo.Height);
  UnshareBitmap(DrawBuffer);
  BitBltCanvas(DrawBuffer.Canvas, 0, 0, Logo.Width, Logo.Height, Canvas, X, Y);
  ImageOp_BCC(DrawBuffer, Templates.Data, Point(0, 0), Logo.BoundsRect,
    LightColor, ShadeColor);
  BitBltCanvas(Canvas, X, Y, Logo.Width, Logo.Height, DrawBuffer.Canvas, 0, 0);
end;

procedure DrawBufferEnsureSize(Width, Height: Integer);
begin
  if (DrawBuffer.Width >= Width) and (DrawBuffer.Height >= Height) then Exit;
  if (DrawBuffer.Width < Width) and (DrawBuffer.Height < Height) then
    DrawBuffer.SetSize(Width, Height)
  else if DrawBuffer.Width < Width then DrawBuffer.Width := Width
  else if DrawBuffer.Height < Height then DrawBuffer.Height := Height;
  DrawBuffer.Canvas.FillRect(0, 0, DrawBuffer.Width, DrawBuffer.Height);
end;

procedure LoadPhrases;
begin
  if Phrases = nil then Phrases := TStringTable.Create;
  if Phrases2 = nil then Phrases2 := TStringTable.Create;
  Phrases2FallenBackToEnglish := False;
  if FileExists(LocalizedFilePath('Language.txt')) then
  begin
    Phrases.LoadFromFile(LocalizedFilePath('Language.txt'));
    if FileExists(LocalizedFilePath('Language2.txt')) then
      Phrases2.LoadFromFile(LocalizedFilePath('Language2.txt'))
    else
    begin
      Phrases2.LoadFromFile(GetAppSharePath('Language2.txt'));
      Phrases2FallenBackToEnglish := True;
    end;
  end
  else
  begin
    Phrases.LoadFromFile(GetAppSharePath('Language.txt'));
    Phrases2.LoadFromFile(GetAppSharePath('Language2.txt'));
  end;

  if Sounds = nil then Sounds := TStringTable.Create;
  if not Sounds.LoadFromFile(GetSoundsDir + DirectorySeparator + 'sound.txt') then
  begin
    FreeAndNil(Sounds);
  end;
end;

procedure Texturize(Dest, Texture: TBitmap; TransparentColor: Cardinal);
var
  SrcPixel, DstPixel: TPixelPointer;
  X, Y: Integer;
  TexWidth, TexHeight: Integer;
begin
  // Texturize background
  Dest.BeginUpdate;
  TexWidth := Texture.Width;
  TexHeight := Texture.Height;
  DstPixel := TPixelPointer.Create(Dest);
  SrcPixel := TPixelPointer.Create(Texture);
  for Y := 0 to ScaleToNative(Dest.Height) - 1 do begin
    for X := 0 to ScaleToNative(Dest.Width) - 1 do begin
      if DstPixel.PixelRGB = TransparentColor then begin
        SrcPixel.SetXY(X mod TexWidth, Y mod TexHeight);
        DstPixel.PixelRGB := SrcPixel.PixelRGB;
      end;
      DstPixel.NextPixel;
    end;
    DstPixel.NextLine;
  end;
  Dest.EndUpdate;
end;

procedure DarkenImage(Bitmap: TBitmap; Change: Integer);
var
  X, Y: Integer;
  PicturePixel: TPixelPointer;
begin
  Bitmap.BeginUpdate;
  PicturePixel := TPixelPointer.Create(Bitmap);
  for Y := 0 to ScaleToNative(Bitmap.Height) - 1 do begin
    for X := 0 to ScaleToNative(Bitmap.Width) - 1 do begin
      PicturePixel.PixelB := Max(PicturePixel.PixelB - Change, 0);
      PicturePixel.PixelG := Max(PicturePixel.PixelG - Change, 0);
      PicturePixel.PixelR := Max(PicturePixel.PixelR - Change, 0);
      PicturePixel.NextPixel;
    end;
    PicturePixel.NextLine;
  end;
  Bitmap.EndUpdate;
end;

{$IFNDEF DPI}
function ScaleToNative(Value: Integer): Integer;
begin
  Result := Value;
end;

function ScaleToNativeDist(Base, Value: Integer): Integer;
begin
  Result := Value;
end;

function ScaleFromNative(Value: Integer): Integer;
begin
  Result := Value;
end;

function BitBltBitmapPrecise(Dest: TBitmap; X, Y, Width, Height: Integer; Src: TBitmap;
  XSrc, YSrc: Integer; Rop: DWORD = SRCCOPY; Precise: Boolean = False): Boolean;
begin
  Result := BitBltBitmap(Dest, X, Y, Width, Height, Src, XSrc, YSrc, Rop);
end;
{$ENDIF}

procedure UnshareBitmap(Bitmap: TBitmap);
begin
  // FillRect cause image data to be freed so subsequent BitBlt can access valid image data
  Bitmap.Canvas.FillRect(0, 0, 0, 0);
end;

procedure Gtk2Fix;
{$IFDEF UNIX}
var
  I: Integer;
{$ENDIF}
begin
  {$IFDEF UNIX}
  // Wait and process messages little bit to avoid crash or force repaint under Gtk2
  for I := 0 to 10 do begin
    Sleep(1);
    Application.ProcessMessages;
  end;
  {$ENDIF}
end;

procedure LoadFonts;
var
  Section: TFontType;
  FontScript: TextFile;
  Size: Integer;
  S: string;
  I: Integer;
  P: Integer;
begin
  Section := ftNormal;
  AssignFile(FontScript, LocalizedFilePath('Fonts.txt'));
  try
    Reset(FontScript);
    while not Eof(FontScript) do begin
      ReadLn(FontScript, S);
      if S <> '' then
        if S[1] = '#' then begin
          S := TrimRight(S);
          if S = '#SMALL' then Section := ftSmall
          else if S = '#TINY' then Section := ftTiny
          else if S = '#CAPTION' then Section := ftCaption
          else if S = '#BUTTON' then Section := ftButton
          else Section := ftNormal;
        end else begin
          P := Pos(',', S);
          if P > 0 then begin
            UniFont[section].Name := Trim(Copy(S, 1, P - 1));
            Size := 0;
            for I := P + 1 to Length(S) do
              case S[I] of
                '0' .. '9':
                  Size := Size * 10 + Byte(S[I]) - 48;
                'B', 'b':
                  UniFont[section].Style := UniFont[section].Style + [TFontStyle.fsBold];
                'I', 'i':
                  UniFont[section].Style := UniFont[section].Style + [TFontStyle.fsItalic];
              end;
            UniFont[section].Size := Round(Size * ScaleToNative(72) / UniFont[section].PixelsPerInch);
          end;
        end;
    end;
    CloseFile(FontScript);
  except
  end;
end;

procedure ReleaseFonts;
var
  Section: TFontType;
begin
  for Section := Low(TFontType) to High(TFontType) do
    FreeAndNil(UniFont[section]);
end;

procedure InitGammaLookupTable;
var
  I: Integer;
  P: Integer;
begin
  GammaLookupTable[0] := 0;
  for I := 1 to 255 do begin
    P := Round(255.0 * Exp(Ln(I / 255.0) * 100.0 / Gamma));
    Assert((P >= 0) and (P < 256));
    GammaLookupTable[I] := P;
  end;
end;

procedure Gtk2DisableControlStyling(WinControl: TWinControl);
{$IFDEF LCLGTK2}
var
  GtkWhite: string;
  GtkBlue: string;
  GtkBlack: string;
  GtkOrange: string;
{$ENDIF}
begin
  {$IFDEF LCLGTK2}
  // https://gitlab.com/freepascal.org/lazarus/lazarus/-/issues/38516
  GtkBlue := '{ 0.373, 0.467, 0.796 }';
  GtkWhite := '{ 1.0, 1.0, 1.0 }';
  GtkBlack := '{ 0, 0, 0 }';
  GtkOrange := '{ 0.373, 0.465, 0.793 }';

  // parse gtkrc from string
  gtk_rc_parse_string(PChar('style "noengine" {' + LineEnding +
    'engine "" { }' + LineEnding +

    'base[INSENSITIVE] = ' + GtkBlack + LineEnding +
    'base[PRELIGHT] = ' + GtkBlack + LineEnding +
    'base[NORMAL] = ' + GtkBlack + LineEnding +
    'base[SELECTED] = ' + GtkBlue + LineEnding +
    'base[ACTIVE] = ' + GtkBlack + LineEnding +

    'text[INSENSITIVE] = ' + GtkOrange + LineEnding +
    'text[NORMAL] = ' + GtkOrange + LineEnding +
    'text[PRELIGHT] = ' + GtkOrange + LineEnding +
    'text[SELECTED] = ' + GtkWhite + LineEnding +
    'text[ACTIVE] = ' + GtkOrange + LineEnding +

    '}' + LineEnding +
    'widget "*.your-edit" style "noengine"'));

  if WinControl.HandleAllocated then begin
    // set gtk name to our component
    gtk_widget_set_name({%H-}PGtkWidget(WinControl.Handle), 'your-edit');
  end;
  {$ENDIF}
end;

procedure LoadConfig(Key: string);
var
  Reg: TRegistry;
begin
  Reg := TRegistry.Create;
  with Reg do try
    OpenKey(Key, True);
    if ValueExists('Gamma') then Gamma := ReadInteger('Gamma')
      else Gamma := 100;
    if Gamma <> 100 then InitGammaLookupTable;
    if ValueExists('CustomDpiEnabled') then CustomDpiEnabled := Reg.ReadBool('CustomDpiEnabled')
       else CustomDpiEnabled := False;
    if ValueExists('CustomDpi') then CustomDpi := Reg.ReadInteger('CustomDpi')
       else CustomDpi := 96;
    {$IFDEF DPI}
    if CustomDpiEnabled then Screen.Dpi := CustomDpi
      else Screen.Dpi := Screen.GetSystemDpi;
    {$ENDIF}
  finally
    Reg.Free;
  end;
end;

procedure SaveConfig(Key: string);
var
  Reg: TRegistry;
begin
  Reg := TRegistry.Create;
  with Reg do try
    OpenKey(Key, True);
    WriteInteger('Gamma', Gamma);
    WriteBool('CustomDpiEnabled', CustomDpiEnabled);
    WriteInteger('CustomDpi', CustomDpi);
  finally
    Free;
  end;
end;

procedure LoadAssets;
begin
  LoadPhrases;
  LoadFonts;
  Templates := LoadGraphicSet('Templates' + PngExt, False);
  with Templates do begin
    Logo := GetItem('Logo');
    BigBook := GetItem('BigBook');
    SmallBook := GetItem('SmallBook');
    MenuLogo := GetItem('MenuLogo');
    LinkArrows := GetItem('LinkArrows');
    ScienceNationDot := GetItem('ScienceNationDot');
    ResearchIcon := GetItem('Research');
    ChangeIcon := GetItem('Change');
    TreasuryIcon := GetItem('Treasury');
    StarshipDeparted := GetItem('StarshipDeparted');
    WeightOn := GetItem('WeightOn');
    WeightOff := GetItem('WeightOff');
  end;

  LoadGraphicFile(Colors, GetGraphicsDir + DirectorySeparator + 'Colors' + PngExt);
  LoadGraphicFile(Paper, GetGraphicsDir + DirectorySeparator + 'Paper' + JpgExt);
  LoadGraphicFile(BigImp, GetGraphicsDir + DirectorySeparator + 'Icons' + PngExt);
end;

procedure UnitInit;
var
  Section: TFontType;
begin
  Gamma := 100;
  InitGammaLookupTable;

  {$IFDEF WINDOWS}
  EnumDisplaySettings(nil, $FFFFFFFF, StartResolution);
  ResolutionChanged := False;
  {$ENDIF}

  for Section := Low(TFontType) to High(TFontType) do
    UniFont[Section] := TFont.Create;

  DrawBuffer := TBitmap.Create;
  DrawBuffer.PixelFormat := TPixelFormat.pf24bit;

  GrExt := TGraphicSets.Create;

  HGrSystem := LoadGraphicSet('System' + PngExt);
  with HGrSystem do begin
    CityMark1 := GetItem('CityMark1');
    CityMark2 := GetItem('CityMark2');
  end;

  HGrSystem2 := LoadGraphicSet('System2' + PngExt);
  with HGrSystem2 do begin
    Ornament := GetItem('Ornament');
    GBrainNoTerm := GetItem('BrainNoTerm');
    GBrainSuperVirtual := GetItem('BrainSuperVirtual');
    GBrainTerm := GetItem('BrainTerm');
    GBrainRandom := GetItem('BrainRandom');
  end;

  Colors := TBitmap.Create;
  Colors.PixelFormat := TPixelFormat.pf24bit;
  Paper := TBitmap.Create;
  Paper.PixelFormat := TPixelFormat.pf24bit;
  BigImp := TBitmap.Create;
  BigImp.PixelFormat := TPixelFormat.pf24bit;
  MainTexture := TTexture.Create;
  ClickFrameColor := HGrSystem.Data.Canvas.Pixels[187, 175];
  InitOrnamentDone := False;
  GenerateNames := True;

  LoadAssets;
end;

procedure UnitDone;
begin
  RestoreResolution;
  FreeAndNil(GrExt);
  ReleaseFonts;
  FreeAndNil(Phrases);
  FreeAndNil(Phrases2);
  FreeAndNil(DrawBuffer);
  FreeAndNil(BigImp);
  FreeAndNil(Paper);
  FreeAndNil(Colors);
  FreeAndNil(MainTexture);
end;

end.