////////////////////////////////////////////////////////////////////////////////
// Copyright (c) 2001-2023 Alexey Kuryakin daqgroup@mail.ru under MIT license //
////////////////////////////////////////////////////////////////////////////////

////////////////////////////////////////////////////////////////////////////////
// This file is part of the CRW-DAQ project by DaqGroup - component CRWLIB.   //
////////////////////////////////////////////////////////////////////////////////

////////////////////////////////////////////////////////////////////////////////
// Purpose:                                                                   //
// This unit contains GUI Utilities, useful routines for GUI Applications.    //
////////////////////////////////////////////////////////////////////////////////

////////////////////////////////////////////////////////////////////////////////
// History:                                                                   //
// 20230430 - Created by A.K.                                                 //
////////////////////////////////////////////////////////////////////////////////

unit _crw_guiutils; //  Unit contains useful GUI Utilities.

{$I _crw_sysdef}

{$IFDEF FPC}{$mode Delphi}{$ENDIF}{$H+}

{$WARN 5023 off : Unit "$1" not used in $2}

interface

uses
 _crw_sharemem, // NB: THIS UNIT MUST BE FIRST !!!
 {$IFDEF UNIX} cthreads, dl, {$ENDIF}
 {$IFDEF WINDOWS} windows, {$ENDIF}
 sysutils, strutils, classes,
 graphics, forms, controls, stdctrls, buttons, process,
 _crw_alloc;

// Locate Form to center of Screen, set new size in percents.
procedure FormCenterToScreen(Form:TForm; PercentW,PercentH:Integer);

// Set crHandPoint cursor for all button types.
procedure SetButtonCursorToHandPoint(Comp:TComponent);

// Set Font.Name to default value.
procedure SetDefaultFontName(Font:TFont);
procedure SetDefaultMonoFontName(Font:TFont);
procedure SetDefaultSansFontName(Font:TFont);
procedure SetDefaultSerifFontName(Font:TFont);
procedure SetDefaultRomanFontName(Font:TFont);
procedure SetDefaultNarrowFontName(Font:TFont);

const // Constants for DefaultFontType.
 ft_Mono=0; ft_Sans=1; ft_Serif=2; ft_Roman=3; ft_Narrow=4;

var // Type of SetDefaultFontName.
 DefaultFontType : Integer = ft_Mono;

// Find available font name from font name list or return fallback value.
// Font.Name:=GetAvailableFontName(DefaultMonoFonts,FallbackMonoFont);
function GetAvailableFontName(FontNameList,Fallback:String):String;

const // List of popular Mono Fonts to use by default.
 DefaultMonoFonts = 'PT Mono, Consola Mono, Consolas, '
                  + 'Code New Roman, Source Code Pro, '
                  + 'Liberation Mono, DejaVu Sans Mono, '
                  + 'Droid Sans Mono, Roboto Mono, Fira Mono, '
                  + 'Ubuntu Mono, Cousine, Anonymous Pro, FreeMono'
                  + 'Courier New, Courier, Lucida Console, Fixedsys, Monospace';
 DefaultSansFonts = 'PT Sans, PT Astra Sans, Sans, Liberation Sans, '
                  + 'DejaVu Sans, Droid Sans, FreeSans, Fira Sans, Source Sans Pro, '
                  + 'Arial, Verdana, Tahoma, Lucida Sans, Microsoft Sans Serif, MS Sans Serif';
 DefaultSerifFonts = 'PT Serif, PT Astra Serif, Serif, Liberation Serif, '
                  + 'DejaVu Serif, Droid Serif, FreeSerif, Source Serif Pro'
                  + 'Microsoft Sans Serif, MS Serif';
 DefaultRomanFonts = 'PT Astra Serif, Times New Roman, Roman, '
                  + 'Code New Roman, Royal Times New Roman, MS Serif';
 DefaultNarrowFonts = 'PT Sans Narrow, Liberation Sans Narrow, Arial Narrow, '
                    + 'Microsoft Sans Serif, MS Sans Serif';

const // Fallback font if none found.
 FallbackMonoFont   = {$IFDEF WINDOWS} 'Courier New'    {$ELSE} 'Monospace' {$ENDIF};
 FallbackSansFont   = {$IFDEF WINDOWS} 'MS Sans Serif'  {$ELSE} 'Sans'      {$ENDIF};
 FallbackSerifFont  = {$IFDEF WINDOWS} 'MS Serif'       {$ELSE} 'Serif'     {$ENDIF};
 FallbackRomanFont  = {$IFDEF WINDOWS} 'MS Serif'       {$ELSE} 'Serif'     {$ENDIF};
 FallbackNarrowFont = {$IFDEF WINDOWS} 'MS Sans Serif'  {$ELSE} 'Serif'     {$ENDIF};

 // Name:PT_Mono\Size:10\Color:Black\Style:[Bold]
function GetFontStyleAsText(Font:TFont):String;
function GetFontStylesAsText(Styles:TFontStyles):String;
function GetSetFontParams(Font:TFont; Params:String):String;

 // Get Application main Form
function GetApplicationMainForm:TForm;
function GetApplicationMainFormWindowId:String;


implementation

procedure FormCenterToScreen(Form:TForm; PercentW,PercentH:Integer);
begin
 if (Form<>nil) then with Form do begin
  if (PercentH>0) then Height:=(Screen.Height * PercentH) div 100;
  if (PercentW>0) then Width:=(Screen.Width * PercentW) div 100;
  Top:=(Screen.Height-Height) div 2;
  Left:=(Screen.Width-Width) div 2;
 end;
end;

procedure SetButtonCursorToHandPoint(Comp:TComponent);
var i:Integer;
begin
 if (Comp <> nil) then
 if (Comp is TButton) then TButton(Comp).Cursor:=crHandPoint else
 if (Comp is TBitBtn) then TBitBtn(Comp).Cursor:=crHandPoint else
 if (Comp is TSpeedButton) then TSpeedButton(Comp).Cursor:=crHandPoint else
 if (Comp is TForm) then begin for i:=0 to TForm(Comp).ComponentCount-1 do SetButtonCursorToHandPoint(TForm(Comp).Components[i]); end;
end;

function GetAvailableFontName(FontNameList,Fallback:String):String;
var i:Integer; S:String; Delims:TCharSet;
begin
 Result:=Fallback; Delims:=[#0..#31,',',';'];
 for i:=1 to WordCount(FontNameList,Delims) do begin
  S:=Trim(ExtractWord(i,FontNameList,Delims));
  if (S<>'') and (Screen.Fonts.IndexOf(S)>=0) then begin
   Result:=S;
   Break;
  end;
 end;
end;

procedure SetDefaultFontName(Font:TFont);
begin
 if (Font=nil) then Exit;
 case DefaultFontType of
  0: SetDefaultMonoFontName(Font);
  1: SetDefaultSansFontName(Font);
  2: SetDefaultSerifFontName(Font);
  3: SetDefaultRomanFontName(Font);
  4: SetDefaultNarrowFontName(Font);
 end;
end;

procedure SetDefaultMonoFontName(Font:TFont);
begin
 if (Font=nil) then Exit;
 Font.Name:=GetAvailableFontName(DefaultMonoFonts,FallbackMonoFont);
end;

procedure SetDefaultSansFontName(Font:TFont);
begin
 if (Font=nil) then Exit;
 Font.Name:=GetAvailableFontName(DefaultSansFonts,FallbackSansFont);
end;

procedure SetDefaultSerifFontName(Font:TFont);
begin
 if (Font=nil) then Exit;
 Font.Name:=GetAvailableFontName(DefaultSerifFonts,FallbackSerifFont);
end;

procedure SetDefaultRomanFontName(Font:TFont);
begin
 if (Font=nil) then Exit;
 Font.Name:=GetAvailableFontName(DefaultRomanFonts,FallbackRomanFont);
end;

procedure SetDefaultNarrowFontName(Font:TFont);
begin
 if (Font=nil) then Exit;
 Font.Name:=GetAvailableFontName(DefaultNarrowFonts,FallbackNarrowFont);
end;

function GetFontStylesAsText(Styles:TFontStyles):String;
begin
 Result:='';
 if (Styles=[]) then begin Result:='[]'; Exit; end;
 if (fsBold in Styles) then Result:=Result+' Bold';
 if (fsItalic in Styles) then Result:=Result+' Italic';
 if (Result='') then Result:='Normal';
 if (fsStrikeOut in Styles) then Result:=Result+' StrikeOut';
 if (fsUnderline in Styles) then Result:=Result+' Underline';
 Result:='['+StringReplace(Trim(Result),' ',',',[rfReplaceAll])+']';
end;

function GetFontStyleAsText(Font:TFont):String;
begin
 Result:='';
 if (Font=nil) then Exit;
 Result:=GetFontStylesAsText(Font.Style);
end;

function WordIndex(s,list:String; delims:TCharSet):Integer;
var i,j,n:Integer;
begin
 i:=1;
 j:=0;
 n:=WordCount(list,delims);
 while i<=n do begin
  if SameText(s,ExtractWord(i,list,delims)) then begin
   j:=i;
   i:=n;
  end;
  i:=i+1;
 end;
 Result:=j;
end;

function SkipWords(const N: Integer; const S: string; const WordDelims: TSysCharSet): String;
var P:SizeInt;
begin
 Result:='';
 if (S='') then Exit;
 P:=WordPosition(N+1,S,WordDelims);
 case P of
  0:   Exit;
  1:   Result:=S;
  else Result:=Copy(S,P,Length(S)-P+1);
 end;
end;

function GetSetFontParams(Font:TFont; Params:String):String;
var Lines:TStrings; s:String;
begin
 Result:='';
 try
  Lines:=TStringList.Create;
  try
   Params:=Trim(Params);
   if (Params<>'') then begin
    Params:=StringReplace(Params,'_',' ',[rfReplaceAll]);
    Params:=StringReplace(Params,':','=',[rfReplaceAll]);
    Params:=StringReplace(Params,'\',LineEnding,[rfReplaceAll]);
    Lines.Text:=AdjustLineBreaks(Params);
   end;
   if (Font<>nil) then begin
    s:=Trim(Lines.Values['Name']);  if (s<>'') then Font.Name:=s;
    s:=Trim(Lines.Values['Size']);  if (s<>'') then Font.Size:=StrToIntDef(s,Font.Size);
    s:=Trim(Lines.Values['Color']); if (s<>'') then Font.Color:=StrToIntDef(s,Font.Color);
    s:=Trim(Lines.Values['Style']);
    if (s<>'') then begin
     if (WordIndex('Bold',s,[','])>0) then Font.Style:=Font.Style+[fsBold] else Font.Style:=Font.Style-[fsBold];
     if (WordIndex('Italic',s,[','])>0) then Font.Style:=Font.Style+[fsItalic] else Font.Style:=Font.Style-[fsItalic];
     if (WordIndex('StrikeOut',s,[','])>0) then Font.Style:=Font.Style+[fsStrikeOut] else Font.Style:=Font.Style-[fsStrikeOut];
     if (WordIndex('Underline',s,[','])>0) then Font.Style:=Font.Style+[fsUnderline] else Font.Style:=Font.Style-[fsUnderline];

    end;
    Lines.Clear;
    Lines.Values['Name']:=Font.Name;
    Lines.Values['Size']:=IntToStr(Font.Size);
    Lines.Values['Color']:=ColorToString(Font.Color);
    Lines.Values['Style']:=GetFontStyleAsText(Font);
   end;
   Result:=Trim(Lines.Text);
   Result:=StringReplace(Result,' ','_',[rfReplaceAll]);
   Result:=StringReplace(Result,'=',':',[rfReplaceAll]);
   Result:=StringReplace(Result,LineEnding,'\',[rfReplaceAll]);
  finally
   Lines.Free;
  end;
 except
  on E:Exception do BugReport(E,Application,'GetSetFontParams');
 end;
end;

function GetApplicationMainForm:TForm;
begin
 Result:=nil;
 if Application=nil then Exit;
 Result:=Application.MainForm;
end;

function GetApplicationMainFormWindowId:String;
var Form:TForm; List:TStringList; i:Integer; cmd,pid,line:String; delims:TCharSet;
begin
 Result:='';
 try
  Form:=GetApplicationMainForm;
  if not (Form is TForm) then Exit;
  if IsWindows then begin
   Result:=Format('0x%x',[Form.Handle]);
  end else
  if IsUnix then begin
   List:=TStringList.Create;
   try
    delims:=[#0..' '];
    pid:=Format('%u',[GetProcessId]);
    cmd:=FileSearch('wmctrl',GetEnvironmentVariable('PATH'),false);
    if not FileExists(cmd) then cmd:='wmctrl';
    if RunCommand(cmd,['-l','-p'],line) then List.Text:=line;
    for i:=0 to List.Count-1 do begin
     line:=Trim(List.Strings[i]);
     if SameText(ExtractWord(3,line,delims),pid) then
     if SameText(SkipWords(4,line,delims),Trim(Form.Caption)) then begin
      Result:=ExtractWord(1,line,delims);
      Break;
     end;
    end;
   finally
    List.Free;
   end;
  end;
 except
  on E:Exception do BugReport(E,Application,'GetApplicationMainFormWindowId');
 end;
end;

///////////////////////////////////////
// Unit initialization and finalization
///////////////////////////////////////

procedure Init_crw_guiutils;
begin
end;

procedure Free_crw_guiutils;
begin
end;

initialization

 Init_crw_guiutils;

finalization

 Free_crw_guiutils;

end.

//////////////
// END OF FILE
//////////////

