Rainbow-Editor/gamefont.pas

unit gamefont;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, Controls, StdCtrls, Graphics, Types;

function GetMonospacedFontName: String;
function GetMonospacedFontSize: Integer;
procedure ResizeMemoForFont(Memo: TMemo; WidthChars, HeightChars: Integer);
function FindXPosOverMemo(Memo: TMemo; WidthChars: Integer): Integer;

implementation

{$IFDEF MSWINDOWS}
uses
  Windows;
{$ENDIF}

function GetMemoChrome(Memo: TMemo): TSize;
var
  TempBmp: Graphics.TBitmap;
  ChromeWidth, ChromeHeight: Integer;
  CharSize: TSize;

  {$IFDEF MSWINDOWS}
  procedure GetWindowsCromeValues;
  begin
    { Idea adapted from here: https://stackoverflow.com/a/48110254

     I'm not 100% sure why I have to add +4 for this to work, but I guess
     this will do for now.  }
    ChromeWidth := Windows.GetSystemMetrics(SM_CXEDGE) * 2 + 4;
    ChromeHeight := Windows.GetSystemMetrics(SM_CYEDGE) * 2 + 4;
  end;
  {$ENDIF}

begin
  //TODO: how do we get the width and the height of the memo's chrome?
  //for now, assume 1.5 char size (this seems to work in Windows)
  TempBmp:= Graphics.TBitmap.Create;
  TempBmp.Canvas.Font.Size := GetMonospacedFontSize;
  TempBmp.Canvas.Font.Name := GetMonospacedFontName;

  CharSize := TempBmp.Canvas.TextExtent('m');

  { This is a heuristic that will *hopefully* be correct. These values are
    overwritten by platform-specific functions to get frame/indent widths. }
  ChromeWidth := 3 * CharSize.Width div 2;
  ChromeHeight := CharSize.Height div 2;

  {$IFDEF MSWINDOWS}
    GetWindowsCromeValues;
  {$ENDIF}

  FreeAndNil(TempBmp);

  Result.Width := ChromeWidth;
  Result.Height := ChromeHeight;
end;

function GetMonospacedFontName: String;
begin
  //TODO change this to take OS and font availability into account
  {$IF Defined(LCLGtk) or Defined(LCLGtk2) or Defined(LCLGtk3)}
    GetMonospacedFontName := 'Monospace';
  {$ELSE}
    GetMonospacedFontName := 'Courier New';
  {$ENDIF}
end;

function GetMonospacedFontSize: Integer;
begin
  //TODO change this to take OS and font availability into account
  GetMonospacedFontSize := 9;
end;

function GetTestStringSizes(WidthChars: Integer): TSize;
var
  TempBmp: Graphics.TBitmap;
  TestStr: String;
begin
  TempBmp:= Graphics.TBitmap.Create;
  TempBmp.Canvas.Font.Size := GetMonospacedFontSize;
  TempBmp.Canvas.Font.Name := GetMonospacedFontName;

  TestStr := StringOfChar('m', WidthChars);

  GetTestStringSizes := TempBmp.Canvas.TextExtent(TestStr);

  FreeAndNil(TempBmp);
end;

procedure ResizeMemoForFont(Memo: TMemo; WidthChars, HeightChars: Integer);
var
  StrSize: TSize;
  ChromeSize: TSize;
begin
  StrSize := GetTestStringSizes(WidthChars);
  ChromeSize := GetMemoChrome(Memo);

  Memo.Width := StrSize.Width + ChromeSize.Width;
  Memo.Height := HeightChars * StrSize.Height + ChromeSize.Height;
end;

function FindXPosOverMemo(Memo: TMemo; WidthChars: Integer): Integer;
var
  StrSize: TSize;
  ChromeSize: TSize;
begin
  StrSize := GetTestStringSizes(WidthChars);
  ChromeSize := GetMemoChrome(Memo);

  FindXPosOverMemo := StrSize.Width + (ChromeSize.Width div 2);
end;

end.