{*************************************************************************}
{                                                                         }
{ Alkatraz.pas - frequently used functions                                }
{                                                                         }
{ © Parfenov Alexey Andreevich, 2007                                      }
{                                                                         }
{ e-mail: AlkatrazStudio@yandex.ru                                        }
{                                                                         }
{ This library is free software; you can redistribute it and/or           }
{ modify it under the terms of the GNU General Public License             }
{ as published by the Free Software Foundation; either version 2.1 of     }
{ the License, or (at your option) any later version.                     }
{                                                                         }
{ This library is distributed in the hope that it will be useful,         }
{ but WITHOUT ANY WARRANTY; without even the implied warranty of          }
{ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU        }
{ General Public License for more details.                                }
{                                                                         }
{ You may read GNU General Public License at:                             }
{   http://www.gnu.org/copyleft/gpl.html                                  }
{                                                                         }
{ last modified: 25.04.2009                                               }
{*************************************************************************}
unit Alkatraz;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs,shellapi,math,inifiles;

// Mail to address on subject with body
procedure MailTo(adress,subject,body:string);
// Sprite collision check rect=(s1x,s1y,s1x+s1xx,s1y+s1yy)
function SpriteCollision(s1x,s1y,s1xx,s1yy,s2x,s2y,s2xx,s2yy:real):Boolean;
// Get literal key name
function GetKeyName(Key:byte):string;
// Wait for user keyboard input
function WaitForKey:Byte;
// Get files list from Dir directory matching Mask in TStrings
procedure GetFilesInDir(List:TStringList;Dir,Mask:String);
// Get RGB from TColor
procedure GetRGB(Color:Tcolor;var R:byte;var G:byte;var B:byte);
// Get TColor from RGB
function SetRGB(R,G,B:Byte):Tcolor;
// Get sign of number -1,0,1
function Sgn(X:real):ShortInt;
// Factiorial
function Factorial(N:Integer):integer;
// Angle between X-Axis and vector [(x1,y1)-(x2,y2)]
function GetAngle(x1,y1,x2,y2:single):single;
// Returns angle in 0..359 degrees range
function Angle(a:single):single;
// Apllication folder
function AppPath:string;
// Filename without extention
function ExtractFileNameOnly(FileName:string):string;
// Set application as a screensaver
procedure SetAsScreenSaver;
// Format milliseconds to MM:SS format
function MsecsToTimeStr(Value: Integer): string;
// Get file icon like in the Explorer
function GetShellIcon(Path:String;LargeIcon:Boolean=True):Hicon;
// Localized MessageDlg (not working in console)
function MessageDlgRus(Caption,Msg:String;Flags:Integer):TModalResult;
// The silliest procedure ever
procedure SetIllumination(Number:Byte;SetLight:Boolean);
// Make directory with all subdirectories
function CreateMultiDir(dir:string):boolean;
// Transliterate s
function Transliteration(s:string):string;
// Converts integer to it's fixed digit string representation
function IntToStrFixed(i:integer;digits:word):string;
// Is "Ñ" a letter?
function IsLetter(C:Char):boolean;
// Opens a folder end selects file in it (WinXP only)
procedure ShowFileInExplorer(FileName:string;HideFolders:boolean=true);
// Sends a keys sequence in a window
procedure EmulateKeys(s:string;Wnd:HWND;i:integer);
// Put data in console stdin and gets output from stdout
function GetConsoleStdOut(CommandLine:string;InStr:string;var OutStr:string;TimeOut:Cardinal=INFINITE):boolean;
// Returns filename's extension in lower case
function LowerExt(FileName:string):string;
// Returns titles and masks of filters in separate arrays
function ParseFilter(Filter:String;Names,Masks:TStrings):integer;
// Load numerated strings from ini-file
function LoadStringsFromIni(ini:TIniFile;section:string;var buf:array of string;start:integer=0):integer;

var RussianAlphabet:string;
var EnglishAlphabet:string;

implementation

var AlphabetEnumerator:byte;

procedure MailTo(adress,subject,body:string);
var
  s,s1:string;
  a:integer;
begin
  s:='mailto:'+adress+'?subject='+subject+'&body='+body;
  s1:='';
  for a:=1 to length(s) do
    case s[a] of
      #32:s1:=s1+'%20';
      #13:s1:=s1+'%0d';
      #10:;
      else s1:=s1+s[a];
    end;
  ShellExecute(0,'open',pchar(s1),nil,nil,SW_RESTORE);
end;

function SpriteCollision(s1x,s1y,s1xx,s1yy,s2x,s2y,s2xx,s2yy:real):Boolean;
begin
  result:=((s1x+s1xx)>s2x)and(s1x<(s2x+s2xx))and((s1y+s1yy)>s2y)and(s1y<(s2y+s2yy));
end;

function GetKeyName(key:byte):string;
begin
  case key of
    1:Result:='Left Click';
    2:Result:='Right Click';
    4:Result:='Roll Click';
    8:Result:='Backspace';
    9:Result:='Tab';
    13:Result:='Enter';
    19:Result:='Pause';
    20:Result:='Caps Lock';
    27:Result:='Escape';
    32:Result:='Space';
    33:Result:='Page Up';
    34:Result:='Page Down';
    35:Result:='End';
    36:Result:='Home';
    37:Result:='Left';
    38:Result:='Up';
    39:Result:='Right';
    40:Result:='Down';
    44:Result:='Print Screen';
    45:Result:='Insert';
    46:Result:='Delete';
    48..57,65..90:result:=chr(key);
    91:Result:='Left Windows';
    92:Result:='Right Windows';
    93:Result:='Context';
    96..105:Result:='Num '+chr(key-48);
    106:Result:='Num *';
    107:Result:='Num +';
    109:Result:='Num -';
    110:Result:='Num .';
    111:Result:='Num /';
    112..123:Result:='F'+inttostr(key-111);
    144:Result:='Num Lock';
    145:Result:='Scroll Lock';
    160:Result:='Left Shift';
    161:Result:='Right Shift';
    162:Result:='Left Control';
    163:Result:='Right Control';
    164:Result:='Left Alt';
    165:Result:='Right Alt';
    186:Result:=';';
    187:Result:='=';
    188:Result:=',';
    189:Result:='-';
    190:Result:='.';
    191:Result:='/';
    192:Result:='¨';
    219:Result:='[';
    220:Result:='\';
    221:Result:=']';
    222:Result:='''';
  else
    Result:='';
  end;
end;

function WaitForKey: Byte;
var
  a:byte;
  k:TKeyboardState;
begin
  Result:=0;
  while Result=0 do
  begin
    Application.ProcessMessages;
    GetKeyboardState(k);
    for a:=1 to 255 do
      if k[a]>10 then result:=a;
  end;
end;

function AppPath:string;
begin
  result:=ExtractFilePath(ParamStr(0));
end;

procedure GetFilesInDir(List:TStringList;Dir,mask:String);
var
  f:TSearchRec;
begin
  if FindFirst(dir+'\'+mask,faAnyFile,f)=0 then
  repeat
    List.Add(dir+'\'+f.Name);
  until FindNext(f)<>0;
  FindClose(f);
end;

procedure GetRGB(Color:Tcolor;var R:byte;var G:byte;var B:byte);
begin
  B:=trunc(Color/256/256);
  G:=trunc((Color-B*256*256)/256);
  R:=trunc(Color-B*256*256-G*256);
end;

function SetRGB(R,G,B:Byte):Tcolor;
begin
  Result:=r+g*256+b*256*256;
end;

function Sgn(X:real):ShortInt;
begin
  if x>0 then Result:=1 else
    if x<0 then Result:=-1 else
      Result:=0;
end;

function Factorial(N:Integer):integer;
begin
  if n=0 then Result:=1 else
    result:=N*Factorial(n-1);
end;

function GetAngle(x1,y1,x2,y2:single):single;
var
  a:single;
begin
  a:=(sqrt((x1-x2)*(x1-x2)+(y1-y2)*(y1-y2)));
  result:=Arccos((x2-x1)/a)*sgn(y2-y1);
  Result:=RadToDeg(Result);
  result:=angle(Result)
end;

function Angle(a:single):single;
begin
  if a<0 then begin a:=a+360;a:=angle(a);end else
  if a>=360 then begin a:=a-360;a:=angle(a);end;
  result:=a;
end;

function ExtractFileNameOnly(FileName:string):string;
begin
  Result:=ChangeFileExt(ExtractFileName(FileName),'');
end;

procedure SetAsScreenSaver;
begin
  ShellExecute(0, 'open', PChar('rundll32.exe'),PChar('desk.cpl,InstallScreenSaver ' + AppPath), nil, SW_SHOWNORMAL);
end;

function MsecsToTimeStr(Value: Integer): string;
var
  m,s:integer;
  ss:string;
begin
  s:=trunc(value/1000);
  ss:='';
  m:=trunc(s/60);
  ss:=inttostr(m)+':';
  s:=s-m*60;
  if s<10 then ss:=ss+'0';
  ss:=ss+inttostr(s);
  if m<100 then ss:='  '+ss else if m<10 then ss:=' '+ss;
  result:=ss;
end;

function GetShellIcon(Path:String;LargeIcon:Boolean=True):Hicon;
var
  fi:TSHFileInfo;
begin
  if not FileExists(Path) then Path:=IncludeTrailingBackslash(Path);
  if LargeIcon then
    SHGetFileInfo(PAnsiChar(Path),0,Fi,sizeof(fi),SHGFI_ICON or SHGFI_LARGEICON or SHGFI_SYSICONINDEX)
  else
    SHGetFileInfo(PAnsiChar(Path),0,Fi,sizeof(fi),SHGFI_ICON or SHGFI_SMALLICON or SHGFI_SYSICONINDEX);
  Result:=fi.hIcon;
end;

procedure SetIllumination(Number:Byte;SetLight:Boolean);
const keys:array[1..3] of integer=(144,20,145);
var
  k:byte;
  ks:TKeyboardState;
begin
  k:=keys[Number];
  GetKeyboardState(ks);
  if SetLight then
  begin
    if ks[k]=0 then
    begin
      keybd_event(k,k,0,0);
      keybd_event(k,k,KEYEVENTF_KEYUP,0);
    end;
  end
  else
  if ks[k]=1 then
  begin
    keybd_event(k,k,0,0);
    keybd_event(k,k,KEYEVENTF_KEYUP,0);
  end;
end;

function MessageDlgRus(Caption,Msg:String;Flags:Integer):TModalResult;
begin
  result:=Application.MessageBox(PAnsiChar(msg),PAnsiChar(Caption),Flags)
end;

function CreateMultiDir(dir:string):boolean;
var
  s:string;
begin
  s:=ExtractFileDir(dir);
  if not DirectoryExists(s) then
  begin
    if CreateMultiDir(s) then
      result:=CreateDir(dir)
    else
      result:=false;
  end
  else
    result:=CreateDir(dir);
end;

function Transliteration(s:string):string;
var
  r1,r2,e1,e2:string;
  a,p:cardinal;
begin
  r1:=RussianAlphabet;
  r2:=AnsiUpperCase(r1);
  e1:=' a b v g d e yozhz i j k l m n o p r s t u f h tschshsh'' y '' e yuya';
  e2:=AnsiUpperCase(e1);
  for a:=1 to Length(s) do
  begin
    p:=Pos(s[a],r1);
    if p>0 then
    begin
      result:=result+e1[p*2];
      if e1[p*2+1]<>' ' then result:=result+e1[p*2+1];
    end
    else
    begin
      p:=Pos(s[a],r2);
      if p>0 then
      begin
        result:=result+e2[p*2];
        if e2[p*2+1]<>' ' then result:=result+e2[p*2+1];
      end
      else result:=result+s[a];
    end;
  end;
end;

function IntToStrFixed(i:integer;digits:word):string;
begin
  result:=inttostr(i);
  while length(result)<digits do result:='0'+result;
end;

function IsLetter(C:Char):boolean;
var
  tmp:string;
begin
  tmp:=AnsiLowerCase(c);
  if pos(tmp,EnglishAlphabet)>0 then
    result:=true
  else
    if pos(tmp,RussianAlphabet)>0 then
      result:=true
    else
      result:=false;
end;

procedure EmulateKeys(s:string;Wnd:HWND;i:integer);
var
  a,n:integer;
  ss:string;
  eng:boolean;
begin
  n:=length(s);
  SetForegroundWindow(wnd);sleep(1000);
  if n>0 then
  begin
    LoadKeyboardLayout('00000409',KLF_ACTIVATE);eng:=true;
    ss:=AnsiLowerCase(s);
    for a:=1 to n do
    begin
      if pos(ss[a],RussianAlphabet)>0 then
      begin
        if eng then
        begin
          LoadKeyboardLayout('00000419',KLF_ACTIVATE);
          eng:=false;
        end;
      end
      else
        if pos(ss[a],EnglishAlphabet)>0 then
        begin
          if not eng then
          begin
            LoadKeyboardLayout('00000409',KLF_ACTIVATE);
            eng:=true;
          end;
        end;
      SendMessage(Wnd,WM_CHAR,ord(ss[a]),0);
      if a<>n then sleep(i);
    end;
  end;
end;

procedure ShowFileInExplorer(FileName:string;HideFolders:boolean=true);
var
  s:string;
  wnd,tmp:HWND;
begin
  s:=ExtractFileDir(FileName);
  ShellExecute(0,PAnsiChar('explore'),PAnsiChar(s),nil,nil,SW_SHOWNORMAL);
  sleep(1000);
  wnd:=GetForegroundWindow;
  tmp:= FindWindowEx(
          FindWindowEx(
            FindWindowEx(wnd,0,'BaseBar',nil),
          0,'ReBarWindow32',nil),
        0,'ToolbarWindow32',nil);
  wnd:= FindWindowEx(
          FindWindowEx(
            FindWindowEx(
              FindWindowEx(
                FindWindowEx(
                  wnd,
                0,'SHELLDLL_DefView',nil),
              0,'DUIViewWndClassName',nil),
            0,'DirectUIHWND',nil),
          0,'CtrlNotifySink',nil),
        0,'SysListView32',nil);
  if HideFolders then
  begin
    SendMessage(tmp,WM_LBUTTONDOWN,0,0);
    SendMessage(tmp,WM_LBUTTONUP,0,0);
  end;
  EmulateKeys(ExtractFileName(FileName),wnd,50);
end;

function GetConsoleStdOut(CommandLine:string;InStr:string;var OutStr:string;TimeOut:Cardinal=INFINITE):boolean;
const BufferSize=1048576;
var
  Security:TSecurityAttributes;
  ReadPipe,WritePipe:THandle;
  StartInfo:TStartUpInfo;
  ProcessInfo:TProcessInformation;
  Buffer:array of char;
  BytesRead:DWord;
  CanRead:DWORD;
begin
  result:=false;
  with Security do
  begin
    nLength:=SizeOf(TSecurityAttributes);
    bInheritHandle:=true;
    lpSecurityDescriptor:=nil;
  end;
  if CreatePipe(ReadPipe,WritePipe,@Security,0)then
  begin
    FillChar(StartInfo,Sizeof(StartInfo),#0);
    with StartInfo do
    begin
      cb:=SizeOf(StartInfo);
      hStdOutput:=WritePipe;
      hStdInput:=ReadPipe;
      wShowWindow:=SW_HIDE;
      dwFlags:=STARTF_USESTDHANDLES or STARTF_USESHOWWINDOW;
    end;
    if CreateProcess(nil,PChar(CommandLine),@Security,@Security,true,
      NORMAL_PRIORITY_CLASS,nil,nil,StartInfo,ProcessInfo) then
    begin
      SetLength(Buffer,BufferSize+1);
      WaitForSingleObject(ProcessInfo.hProcess,INFINITE);
      OutStr:='';
      repeat
        PeekNamedPipe(ReadPipe,nil,0,nil,@CanRead,nil);
        if CanRead=0 then Break;
        ReadFile(ReadPipe,Buffer[0],BufferSize,BytesRead,nil);
        Buffer[BytesRead]:=#0;
        OutStr:=OutStr+string(Buffer);
      until false;
      result:=true;
      CloseHandle(ProcessInfo.hProcess);
      CloseHandle(ProcessInfo.hThread);
      SetLength(Buffer,0);
      OutStr:=String(PAnsiChar(OutStr));
    end;
    CloseHandle(ReadPipe);
    CloseHandle(WritePipe);
  end;
end;

function LowerExt(FileName:string):string;
begin
  result:=AnsiLowerCase(ExtractFileExt(FileName));
end;

function ParseFilter(Filter:String;Names,Masks:TStrings):integer;
var
  a,n:integer;
  s,s1,s2:string;
  v:boolean;

  procedure AddIt;
  begin
    if v then
    begin
      Masks[Masks.Count-1]:=s;v:=false;
    end
    else
    begin
      Names.Add(s);Masks.Add('');v:=true;
    end;
    s:='';
  end;

begin
  Names.Clear;Masks.Clear;
  n:=Length(Filter);
  if n>0 then
  begin
    s:='';s1:='';s2:='';v:=false;
    for a:=1 to n do
      if Filter[a]<>'|' then s:=s+Filter[a] else AddIt;
    AddIt;
  end;
  result:=Names.Count;
end;

function LoadStringsFromIni(ini:TIniFile;section:string;var buf:array of string;start:integer=0):integer;
var
  s,tmp:string;
  cnt:integer;
begin
  result:=0;cnt:=start;
  repeat
    s:=inttostr(result);
    tmp:=ini.ReadString(section,s,'');
    if tmp='' then break;
    buf[cnt]:=tmp;
    inc(result);inc(cnt);
  until false;
end;

initialization

  SetLength(RussianAlphabet,33);
  for AlphabetEnumerator:=224 to 229 do
    RussianAlphabet[AlphabetEnumerator-223]:=chr(AlphabetEnumerator);
  RussianAlphabet[7]:=#184;
  for AlphabetEnumerator:=230 to 255 do
    RussianAlphabet[AlphabetEnumerator-222]:=chr(AlphabetEnumerator);
  SetLength(EnglishAlphabet,26);
  for AlphabetEnumerator:=97 to 122 do
    EnglishAlphabet[AlphabetEnumerator-96]:=chr(AlphabetEnumerator);

finalization

  SetLength(RussianAlphabet,0);
  SetLength(EnglishAlphabet,0);

end.