//  *    TOOLS ver 4.0g
//  *    (c) by Kirill Kranz 2022
//  *    Key-Real of Very Important Pictures
{$IFDEF FPC}
{$DEFINE OBJFPC}
{$MODE OBJFPC}
{$ENDIF}

{$IFNDEF OBJFPC}
{$DEFINE DELPHI}
{$DEFINE WINDOWS}
{$ENDIF}


{$IFDEF darwin} {$modeswitch objectivec1} {$ENDIF}

{$H+}
unit tools;
interface
{$IFDEF WINDOWS}uses windows;{$ENDIF}
{$IFDEF darwin}uses MacOSAll,CocoaAll;{$ENDIF}

{$IFDEF DELPHI}
type qword = Uint64;
{$ENDIF}

 function GetResourcesPath:string;
 function GetExecutablePath:string;

 function  ByteHex(X:byte):String;
 function  WordHex(X:word):String;
 function  dWordHex(X:dword):String;
 function  StrNum(S:string):longint;
 function  NumStr(Num:longint):String;
 function  NumStrDigits(num:longint; digits:byte):String;
 function  NumStrDword(Num:dword):String;
 function  UpSTR(s:String):String;
 function  DownSTR(s:String):string;
 Function  ChartoNum(ch:char):byte;
 Function  NumtoChar(Num:byte):char;
 Function  BoolStr(ok:boolean):string;
 Function  NumBoolStr(num:word):string;
 function  strFloat(s:string):Single;
 function  Parameter(s:string):boolean;
 function  FloatStr(si:single):string;
 function  isdigit(ch:char):boolean;


 function  spaces(num:integer):string;


 Function  DelSubStr(const s:string; delstart,n:LongInt):string;

 procedure readASCIZ(var f:file;var s:string);

 Procedure DelFile(name:string);
 Procedure CopyFile(source,dest:string);
 procedure RenameFile(source,dest:string);
 function  Exist(Name:String):Boolean;


 Procedure LogWrite(T:String);
 Procedure LogNum(Num:longint);
 Procedure LogDword(num:dword);
 Procedure LogFloat(num:single);
 Procedure Log(T:String);
 Procedure NewLog;

function deg2rad(degree:single):single;
function sgn(a:single):single;
function atan2(y,x:single):single;

function extractFileNameFromPath(s:string):string;

function LoadFile2mem(name:string; var data:pointer; var size:dword):boolean;

procedure Error(errormsg:string);
Procedure makeMessage(s:string);

function  strpchar(s:string):pchar;

Procedure SwapI64(Var A:int64; var b:int64);
Procedure SwapB(Var A : byte; Var B : byte);
Procedure SwapL(Var A : Longint; Var B : Longint);
Procedure SwapI(Var A : integer; Var B : integer);
Procedure SwapD(Var A : dword; Var B : dword);
Procedure SwapS(Var A : Single; Var B : Single);


procedure ClearBit(var Value: QWord; Index: Byte);
procedure SetBit(var Value: QWord; Index: Byte);
procedure PutBit(var Value: QWord; Index: Byte; State: Boolean);
function  GetBit(Value: QWord; Index: Byte): Boolean;

{$IFDEF DELPHI}
function pointer2nativeUInt(p:pointer):nativeUint;
{$ELSE}
function pointer2nativeUInt(p:pointer):pointer;
{$ENDIF}


var
   MouseCursorWidth:integer;
   MouseCursorHeight:integer;


implementation
uses sysutils;


{$IFDEF darwin}
function GetResourcesPath:string;
var
  pathStr: shortstring;
  status: Boolean = false;
begin
  status := CFStringGetPascalString(CFStringRef(NSBundle.mainBundle.resourcePath), @pathStr, 255, CFStringGetSystemEncoding());

  if(status = true) then
    Result := pathStr + PathDelim
  else
    raise Exception.Create('Error in GetResourcesPath()');
end;
{$ELSE}
function GetResourcesPath: string;
begin
 result:='./';
end;
{$ENDIF}


{$IFDEF darwin}
function GetExecutablePath:string;
var bundlepath:string;
begin
  bundlepath:=NSBundle.mainBundle.bundlePath.UTF8String+'/';
  result:= ExtractFilePath(ExcludeTrailingPathDelimiter(bundlepath));
end;
{$ELSE}
function GetExecutablePath:string;
begin
  result:='./';
end;
{$ENDIF}

{$IFDEF DELPHI}
function pointer2nativeUInt(p:pointer):nativeUint;
begin
  result:=nativeUint(p);
end;
{$ELSE}
function pointer2nativeUInt(p:pointer):pointer;
begin
  result:=p;
end;
{$ENDIF}





function spaces(num:integer):string;
var i:integer;
    s:string;
begin
  s:='';
  for i:=0 to num do s:=s+' ';
  spaces:=s;
end;



procedure Error(errormsg:string);
begin
 makeMessage('ERROR: '+errormsg);
 halt;
end;




{$IFDEF linux}
Procedure makeMessage(s:string);
begin

end;
{$ENDIF}

{$IFDEF GO32V2}
Procedure makeMessage(s:string);
begin

end;
{$ENDIF}


{$IFDEF darwin}
Procedure makeMessage(s:string);
var header_ref:CFStringRef;
    message_ref:CFStringRef;
    res:CFOptionFlags;
begin
     message_ref:=CFStringCreateWithPascalString(nil, s, kCFStringEncodingUTF8);
     header_ref:=CFStringCreateWithPascalString(nil, 'Message', kCFStringEncodingUTF8);

     CFUserNotificationDisplayAlert(
                                        0, // no timeout
                                        kCFUserNotificationNoteAlertLevel, //change it depending message_type flags ( MB_ICONASTERISK.... etc.)
                                        NIL, //icon url, use default, you can change it depending message_type flags
                                        NIL, //not used
                                        NIL, //localization of strings
                                        header_ref, //header text
                                        message_ref, //message text
                                        NIL, //default "ok" text in button
                                        NIL, //alternate button title
                                        NIL, //other button title, null--> no other button
                                        &res //response flags
                                        );
        //Clean up the strings
    CFRelease( header_ref );
    CFRelease( message_ref );


    tools.log('MESSAGE: '+s);
end;
{$ENDIF}

{$IFDEF windows}
procedure makeMessage(s:string);
begin
    MessageBox(0,pchar(s),nil,mb_Ok);
    tools.log('MESSAGE: '+s);
end;
{$ENDIF}




function LoadFile2mem(name:string; var data:pointer; var size:dword):boolean;
var f:file;
    d:dword;
begin

  if not FileExists(name) then begin
   LoadFile2mem:=false;
   exit;
  end;

  AssignFile (f,name);

  FileMode := fmOpenRead;
  reset(f,1);


  size:=filesize(f);
   d:=0;


   getmem(data,size);

   blockread(f,data^,size,d);



   if size<>d then begin
   LoadFile2mem:=false;
   exit;
  end;

  closeFile(f);
FileMode := fmOpenReadWrite;
  LoadFile2mem:=true;
end;




Function  DelSubStr(const s:string; delstart,n:LongInt):string;
var i:LongInt; s1:string;
begin
s1:=s;
for i:=delstart to length(s)-n-1 do
  s1[i]:=s1[i+n];
SetLength(s1,length(s)-n);
DelSubStr:=s1;
end;

function sgn (a : single) : single;
begin
  if a < 0  then  sgn := -1 else  sgn :=  1;
end;

function atan2 (y, x : single) : single;
begin
  if x > 0       then  atan2 := arctan (y/x)
  else if x < 0  then  atan2 := arctan (y/x) + pi
  else                 atan2 := pi/2 * sgn (y);
end;


function deg2rad(degree:single):single;
begin
  deg2rad:= degree * (PI/180);
end;


function Exist(Name:String):Boolean;
begin
  exist:=fileexists(name);
end;

Function ByteHex(X : byte) : String;
const Digits : array [0..15] of char = '0123456789ABCDEF';
begin
  ByteHex := Concat(Digits[X shr 4],Digits[X and 15]);
end;

function WordHex(X : word) : String;
begin
  WordHex := Concat(ByteHex(X shr 8),ByteHex(X and $FF));
end;

function dWordHex(X : dword) : String;
begin
  dWordHex := Concat(ByteHex(X shr 8),ByteHex(X and $FF));
end;


function StrNum(S:string):longint;
var num:longint;
    code:longint;
begin
 repeat
  Val(s,num,Code);
  if code <> 0 then Delete(S,code,1)
 until code=0;
 StrNum:=num;
end;

function  strFloat(s:string):Single;
{$IFDEF OBJFPC}
var num:Single;
    code:longint;
begin
 if s='' then begin
  strFloat:=0;
  exit;
 end;

 for code:=1 to length(s) do begin
  if s[code]=',' then s[code]:='.';
 end;
repeat
  Val(s,num,Code);
  if code <> 0 then Delete(S,code,1)
 until code=0;
 StrFloat:=num;
end;
{$ENDIF}
{$IFDEF DELPHI}
var num:Single;
    code:longint;
    negative:boolean;
begin

//writeln('s=',s);

if s='' then begin
  result:=0;
  exit;
end;

negative:=false;
 for code:=1 to length(s) do begin
  if s[code]='.' then s[code]:=',';
  if s[code]='-' then begin negative:=true; Delete(S,code,1) end;

 end;


  if negative then result:=-strtofloat(s) else result:=strtofloat(s);
  // writeln(result);
end;
{$ENDIF}


function NumStr(num:longint):String;
var s:string;
begin
 str(num,s);
 NumStr:=s;
end;

function NumStrDigits(num:longint; digits:byte):String;
var s:string; i:byte;
begin
 str(num,s);
if length(s) < digits then
for i := 0 to digits-length(s)-1 do s:='0'+s;
 NumStrDigits:=s;
end;

function  NumStrDword(Num:dword):String;
var s:string;
begin
 str(num,s);
 NumStrDWord:=s;
end;

function  FloatStr(si:single):string;
var s:string;
begin
 str(si:4:2,s);
 FloatStr:=s;
end;


function UpSTR(s:String):String;
var i:word;
    t:char;
    ss:string;
begin
 ss:=s;
 for i:=1 to length(s) do begin
  t:=UpCase(s[i]);
  ss[i]:=t;
 end;
 UpSTR:=ss;
end;

function  DownSTR(s:String):string;
var i:word;
    t:char;

function downcase(ch:char):char;
var c:char;
begin
 case ch of
  'Q':c:='q';
  'W':c:='w';
  'E':c:='e';
  'R':c:='r';
  'T':c:='t';
  'Y':c:='y';
  'U':c:='u';
  'I':c:='i';
  'O':c:='o';
  'P':c:='p';
  'A':c:='a';
  'S':c:='s';
  'D':c:='d';
  'F':c:='f';
  'G':c:='g';
  'H':c:='h';
  'J':c:='j';
  'K':c:='k';
  'L':c:='l';
  'Z':c:='z';
  'X':c:='x';
  'C':c:='c';
  'V':c:='v';
  'B':c:='b';
  'N':c:='n';
  'M':c:='m';
  else c:=ch;
 end;
 downcase:=c;
end;

begin
 for i:=0 to length(s) do begin
  t:=DownCase(s[i]);
  s[i]:=t;
 end;
 DownSTR:=s;
end;

Procedure DelFile(name:string);
var f:file;
begin
 Assign(f,name);
  Erase(f);
end;

procedure RenameFile(source,dest:string);
var f:file;
begin
Assign(f,source);
 rename(f,dest);
end;

Procedure CopyFile(source,dest:string);
var f1,f2:file;
    NumRead,NumWritten:longint;
    Buf:array[0..2048] of Byte;
begin
 if not exist(source) then exit;
 numwritten:=0;
 numread:=0;
 assign(f1,source);
 reset(f1,1);
 assign(f2,dest);
 rewrite(f2,1);
 repeat
  BlockRead(F1,Buf,2048,NumRead);
  BlockWrite(F2,Buf,NumRead,NumWritten);
 until (NumRead=0) or (NumWritten<>NumRead);
 Close(F1);
 Close(F2);
end;

function ChartoNum(ch:char):byte;
begin
 ChartoNum:=0;
 case UPCase(ch) of
 'A' : ChartoNum:=1;
 'B' : ChartoNum:=2;
 'C' : ChartoNum:=3;
 'D' : ChartoNum:=4;
 'E' : ChartoNum:=5;
 'F' : ChartoNum:=6;
 'G' : ChartoNum:=7;
 'H' : ChartoNum:=8;
 'I' : ChartoNum:=9;
 'J' : ChartoNum:=10;
 'K' : ChartoNum:=11;
 'L' : ChartoNum:=12;
 'M' : ChartoNum:=13;
 'N' : ChartoNum:=14;
 'O' : ChartoNum:=15;
 'P' : ChartoNum:=16;
 'Q' : ChartoNum:=17;
 'R' : ChartoNum:=18;
 'S' : ChartoNum:=19;
 'T' : ChartoNum:=20;
 'U' : ChartoNum:=21;
 'V' : ChartoNum:=22;
 'W' : ChartoNum:=23;
 'X' : ChartoNum:=24;
 'Y' : ChartoNum:=25;
 'Z' : ChartoNum:=26;
 end;
end;

function NumtoChar(Num:byte):char;
begin
 case num of
  1 : NumtoChar:='A';
  2 : NumtoChar:='B';
  3 : NumtoChar:='C';
  4 : NumtoChar:='D';
  5 : NumtoChar:='E';
  6 : NumtoChar:='F';
  7 : NumtoChar:='G';
  8 : NumtoChar:='H';
  9 : NumtoChar:='I';
  10: NumtoChar:='J';
  11: NumtoChar:='K';
  12: NumtoChar:='L';
  13: NumtoChar:='M';
  14: NumtoChar:='N';
  15: NumtoChar:='O';
  16: NumtoChar:='P';
  17: NumtoChar:='Q';
  18: NumtoChar:='R';
  19: NumtoChar:='S';
  20: NumtoChar:='T';
  21: NumtoChar:='U';
  22: NumtoChar:='V';
  23: NumtoChar:='W';
  24: NumtoChar:='X';
  25: NumtoChar:='Y';
  26: NumtoChar:='Z';
  else NumtoChar:=#0;
 end;
end;

Function  BoolStr(ok:boolean):string;
begin
 case ok of
  True:BoolSTR:='TRUE';
  False:BoolSTR:='FALSE';
 end;
end;

Function  NumBoolStr(num:word):string;
begin
 case num of
  0:NumBoolStr:='FALSE';
  1:NumBoolStr:='TRUE';
  else NumBoolStr:=numstr(num);
 end;
end;


function Parameter(s:string):boolean;
var i:word;
    ok:boolean;
begin
 i:=1;
 ok:=false;
 repeat
  if upstr(paramstr(i))=s then ok:=true;
  inc(i);
 until (ok)or(i=paramcount);
 Parameter:=ok;
end;

procedure readASCIZ(var f:file;var s:string);
var ch:char;
begin
 s:='';
 ch:=#0;
 repeat
  BlockRead(f,ch,1);
  s:=s+ch;
 until ch=#0;
 delete(s,length(s),1);
end;

function  isdigit(ch:char):boolean;
var ok:boolean;
begin
 ok:=false;
 case ch of
  '0' : ok:=true;
  '1' : ok:=true;
  '2' : ok:=true;
  '3' : ok:=true;
  '4' : ok:=true;
  '5' : ok:=true;
  '6' : ok:=true;
  '7' : ok:=true;
  '8' : ok:=true;
  '9' : ok:=true;
 end;
 isdigit:=ok;
end;


Procedure Log(T:String);
var f:text;
  name:string;
begin

  name:='logger.log';
  name:=GetExecutablePath + name;


 assign(f,name);

 if not exist(name) then begin
  rewrite(f);
  close(f);
 end;

 append(f);
 writeln(f,t);
 close(f);
end;

Procedure LogWrite(T:String);
begin
 Log(T);
 Writeln(T);
end;

Procedure LogNum(Num:longint);
var s,txt:string;
begin
 str(Num,S);
 txt:='#';
 txt:=txt+s;
 Log(txt);
end;

Procedure LogDword(num:dword);
var s,txt:string;
begin
 str(Num,S);
 txt:='#';
 txt:=txt+s;
 Log(txt);
end;


Procedure LogFloat(num:single);
var txt:string;
begin
 txt:='#';
 txt:=txt+floatstr(num);
 Log(txt);
end;


Procedure NewLog;
var 
  {$IFDEF darwin}bundlepath,abovepath:string;{$ENDIF}
  name:string;
begin

  name:='logger.log';
  {$IFDEF darwin}
  bundlepath:=NSBundle.mainBundle.bundlePath.UTF8String+'/';
  abovepath:= ExtractFilePath(ExcludeTrailingPathDelimiter(bundlepath));
  name:=abovepath+'logger.log';
  {$ENDIF}

 if exist(name) then delFile(name);
end;

function extractFileNameFromPath(s:string):string;
var i:integer;
    ch:char;
    ss:string;
begin
  i:=length(s);
  ss:='';
  repeat
   ch:=s[i];
   dec(i);
  until (ch='\') or (ch='/');
  inc(i,2);
  repeat
   ch:=s[i];
   ss:=ss+ch;
   inc(i);
  until i=length(s)+1;

  extractFileNameFromPAth:=ss;

end;


function  strpchar(s:string):pchar;
var
    pc:pchar;
    i:integer;
begin
  getmem(pc,length(s)+1);

  for i:=0 to length(s)-1 do pc[i]:=s[i+1];
  pc[length(s)]:=#0;

  strpchar:=pc;
end;



Procedure SwapI64(Var A:int64; var b:int64);
var t:int64;
Begin
    t:=A;
    a:=B;
    b:=t;
End;


Procedure SwapB(Var A : byte; Var B : byte);
var t:byte;
Begin
    t:=A;
    a:=B;
    b:=t;
End;


Procedure SwapL(Var A : Longint; Var B : Longint);
var t:Longint;
Begin
    t:=A;
    a:=B;
    b:=t;
End;


Procedure SwapI(Var A : integer; Var B : integer);
var t:integer;
Begin
    t:=A;
    a:=B;
    b:=t;
End;


Procedure SwapD(Var A : dword; Var B : dword);
var t:dword;
Begin
    t:=A;
    a:=B;
    b:=t;
End;


Procedure SwapS(Var A : Single; Var B : Single);
var t:Single;
Begin
    t:=A;
    a:=B;
    b:=t;
End;

procedure ClearBit(var Value: QWord; Index: Byte);
begin
  Value := Value and ((QWord(1) shl Index) xor High(QWord));
end;

procedure SetBit(var Value: QWord; Index: Byte);
begin
  Value:=  Value or (QWord(1) shl Index);
end;

procedure PutBit(var Value: QWord; Index: Byte; State: Boolean);
begin
  Value := (Value and ((QWord(1) shl Index) xor High(QWord))) or (QWord(State) shl Index);
end;

function GetBit(Value: QWord; Index: Byte): Boolean;
begin
  Result := ((Value shr Index) and 1) = 1;
end;


function getMouseCursorHeight:integer;
{$IFDEF WINDOWS}
var
  ii:tICONINFO ;
  bitmap:tBITMAP;
begin
  GetIconInfo(GetCursor, {$IFDEF OBJFPC} @ii {$ELSE} ii {$ENDIF});
  GetObject(ii.hbmColor, sizeof(tBITMAP), @bitmap);
  getMouseCursorHeight:= bitmap.bmHeight div 2;
  DeleteObject(ii.hbmColor);
end;
{$ELSE}
begin
   getMouseCursorHeight:=0;
end;
{$ENDIF}


function getMouseCursorWidth:integer;
{$IFDEF WINDOWS}
var
  ii:tICONINFO ;
  bitmap:tBITMAP;
begin
  GetIconInfo(GetCursor, {$IFDEF OBJFPC} @ii {$ELSE} ii {$ENDIF});
  GetObject(ii.hbmColor, sizeof(tBITMAP), @bitmap);
  getMouseCursorWidth:= bitmap.bmWidth div 2;
  DeleteObject(ii.hbmColor);
end;
{$ELSE}
begin
  getMouseCursorWidth:=0;
end;
{$ENDIF}


begin

  MouseCursorWidth:=getMouseCursorWidth;
  MouseCursorHeight:=getMouseCursorHeight;

 newlog;
end.
