path: root/lowlevelunit.pas

unit lowlevelunit;

{$mode objfpc}{$H+}

interface

uses
  math, Classes, SysUtils, gmp, RegExpr, process, FPimage;

type
  generic tArray<T> = array of T;
  tLongintArray = specialize tArray<longint>;
  pTLongintArray = ^tLongintArray;
  tSingleArray = specialize tArray<single>;
  pTSingleArray = ^tSingleArray;
  tIntPoint = array['x'..'y'] of longint;
  tExtPoint = array['x'..'y'] of extended;
  t2x2Longint = array['x'..'y','x'..'y'] of longint;
  t2x2Extended = array['x'..'y','x'..'y'] of extended;
  tExtPointArray = specialize tArray<tExtPoint>;
  pTExtPointArray = ^tExtPointArray;
  tExtendedArray = specialize tArray<extended>;
  pTExtendedArray = ^tExtendedArray;
  tDoubleArray = specialize tArray<single>;
  tInt32Array = specialize tArray<int32>;
  tByteArray = specialize tArray<byte>;
  tStringArray = specialize tArray<string>;
  tIntPointArray = specialize tArray<tIntPoint>;
  tRGB = record
    rgbBlue : byte;
    rgbGreen: byte;
    rgbRed  : byte;
  end;
  tRgbArray = specialize tArray<tRGB>;
  tKodierung = (kUnbekannt,k32BitSignedInteger);
  tWarnstufe = (wsStreng,wsLasch);
  tGenauigkeit = (gSingle,gDouble,gExtended);

function signSqr(x: extended): extended; inline;
function mpfToStr(f: mpf_t): string;
function myTimeToStr(t: extended): string;
function cpuUtilization: extended;
function numCpus: int64;
function momentanFreieCpus: int64;
function mpfMyRoot(rad: mpf_t; wzlExp: int64): extended;
function belegterSpeicher: int64;
function minCache: int64;
function cmpStr(s1,s2: string): longint;
function mitte(s1,s2: string): string;
function myFloatToStr(x: extended): string; overload;
function myFloatToStr(x: extended; ex: string): string; overload;
function myStrToFloat(s: string): extended;
function max(g1,g2: tGenauigkeit): tGenauigkeit; overload;
function wertGroesze(g: tGenauigkeit): longint;

function floattostrtrunc(f: extended; dig: longint; laessig: boolean): string;
function binOpPos(op: char; s: string): integer;
function fktPos(fkt,s: string): integer;
procedure gibAus(s: string; ausgaben: byte);
function strToGen(out gen: tGenauigkeit; s: string): boolean;
function orFarben(a,b: tRGB): tRGB;
function andFarben(a,b: tRGB): tRGB;
function wertZuFarbe(x: extended; p: tRGBArray): tRGB;
function tFPColor2tRgb(c: tFPColor): tRGB;
function tRgb2tFPColor(c: tRGB): tFPColor;
procedure myDebugLnThreadLog(s: string);
function belegterSpeicher: longint;
procedure cleanupLogs;
procedure cleanupLog(tid: PtrUInt);
procedure raiseAndDumpExceptionCallStack(msg: string);
procedure dumpExceptionCallStack(E: Exception);
function startetMit(start: string; var s: string): boolean;
function endetMit(ende: string; var s: string): boolean;
function trimAll(s: string): string;
function erstesArgument(var s: string): string; overload;
function erstesArgument(var s: string; Trenner: string): string; overload;
function mydatetimetostr(t: tDateTime): string;
function tExtPointToStr(p: tExtPoint): string;
function tIntPointToStr(p: tIntPoint): string;
procedure fehler(s: string);

function hexDump(p: pointer; cnt: longint): string;
function base64ToBin(var s: string): boolean;
function base64Decode(const s: string; out i: qword): boolean; overload;
function base64Decode(const s: string; out i: longword): boolean; overload;
function base64Encode(i: longword): string; overload;
function base64Encode(i,siz: longword): string; overload;
function mirrorBits(qw: qword): qword; overload;
function mirrorBits(lw: longword): longword; overload;
function mirrorBits(w: word): word; overload;
function mirrorBits(b: byte): byte; overload;

function zusammenfassen(s1,s2: string): string;

var
  base64Chars: array[0..63] of char;
  base64CharsInvers: array[char] of byte;

implementation

uses matheunit;

var _cpuLastUsed,_cpuLastIdle: int64;

// allgemeine Funktionen *******************************************************

function signSqr(x: extended): extended;
begin
 result:=sign(x)*sqr(x);
end;

function mpfToStr(f: mpf_t): string;
var
  ex:  mp_exp_t;
  off: byte;
begin
 result:=mpf_get_str(nil,ex,10,0,f);
 off:=1+byte(pos('-',result)=1);
 if result='' then
   result:='0'
 else if ex=1 then
   result:=copy(result,1,off)+','+copy(result,off+1,length(result)-off)
 else
   result:=copy(result,1,off)+','+copy(result,off+1,length(result)-off)+' * 10^'+inttostr(ex-1);
end;

function myTimeToStr(t: extended): string;
var
  tim: int64;
begin
 tim:=floor(t*24*60*60);
 result:=inttostr(tim mod 10)+'s';
 tim:=tim div 10;
 if tim=0 then exit;
 result:=inttostr(tim mod 6)+result;
 tim:=tim div 6;
 if tim=0 then exit;
 result:=inttostr(tim mod 10)+'min '+result;
 tim:=tim div 10;
 if tim=0 then exit;
 result:=inttostr(tim mod 6)+result;
 tim:=tim div 6;
 if tim=0 then exit;
 result:=inttostr(tim mod 24)+'h '+result;
 tim:=tim div 24;
 if tim=0 then exit;
 result:=' '+result;
 if (tim mod 7)<>1 then
   result:='e'+result;
 result:=inttostr(tim mod 7)+'Tag'+result;
 tim:=tim div 7;
 if tim=0 then exit;
 result:=' '+result;
 if tim<>1 then
   result:='n'+result;
 result:=inttostr(tim)+'Woche'+result;
end;

function cpuUtilization: extended;
var
  procstat:  textfile;
  s:         string;
  used,idle: int64;
  i:         integer;
begin
  result:=0;
  s:='';
  assignfile(procstat,'/proc/stat');
  reset(procstat);
  while not eof(procstat) do begin
    readln(procstat,s);
    if pos('cpu ',s)=1 then break;
  end;
  closefile(procstat);
  if pos('cpu ',s)<>1 then exit;
  delete(s,1,pos(' ',s));
  s:=trim(s);
  used:=0;
  idle:=0;
  for i:=0 to 3 do begin
    used:=used+idle;
    idle:=strtoint(copy(s,1,pos(' ',s)-1));
    delete(s,1,pos(' ',s));
    s:=trim(s);
  end;
  result:=(used-_cpuLastUsed)/max(1,used-_cpuLastUsed + idle-_cpuLastIdle);
  _cpuLastUsed:=used;
  _cpuLastIdle:=idle;
end;

function numCpus: int64;
var
  procstat:  textfile;
  s:         string;
begin
  result:=0;
  s:='';
  assignfile(procstat,'/proc/stat');
  reset(procstat);
  while not eof(procstat) do begin
    readln(procstat,s);
    if (pos('cpu',s)=1) and
       (pos('cpu ',s)<>1) then
      inc(result);
  end;
  closefile(procstat);
end;

function momentanFreieCpus: int64;
begin
  result:=floor(numCpus*(1-cpuUtilization));
end;

function mpfMyRoot(rad: mpf_t; wzlExp: int64): extended;
var
  ex: mp_exp_t;
begin
  result:=power(mpf_get_d_2exp(ex,rad),1/wzlExp);
  result:=result*power(2,ex/wzlExp);
end;

function belegterSpeicher: int64;
var f:    textFile;
    s:    string;
begin
 s:='/proc/'+inttostr(getProcessId)+'/smaps';
 result:=0;
 if not fileexists(s) then exit;
 assignfile(f,s);
 reset(f);
 while not eof(f) do begin
   readln(f,s);
   if (leftStr(s,4)='Rss:') and (rightStr(s,3)=' kB') then begin
     delete(s,1,4);
     delete(s,length(s)-2,3);
     s:=trim(s);
     result:=result+strtoint(s);
   end;
 end;
 closefile(f);
end;

function minCache: int64;
var f:    textFile;
    s:    string;
begin
 s:='/proc/cpuinfo';
 result:=0;
 if not fileexists(s) then exit;
 assignfile(f,s);
 reset(f);
 while not eof(f) do begin
   readln(f,s);
   if (leftStr(s,10)='cache size') and (rightStr(s,3)=' kB') then begin
     delete(s,1,pos(':',s));
     delete(s,length(s)-2,3);
     s:=trim(s);
     if result=0 then result:=strtoint(s)
     else result:=min(result,strtoint(s));
   end;
 end;
 closefile(f);
end;

function cmpStr(s1,s2: string): longint;
var
  i: longint;
begin
 for i:=1 to min(length(s1),length(s2)) do
   if s1[i]<>s2[i] then begin
     result:=2*byte(s1[i]>s2[i])-1;
     exit;
   end;
 if length(s1)<>length(s2) then begin
   result:=2*byte(length(s1)>length(s2))-1;
   exit;
 end;
 result:=0;
end;

function mitte(s1,s2: string): string;
var
  i:    longint;
  w,nw: word;
begin
 setlength(result,max(length(s1),length(s2)));
 w:=0;
 for i:=length(result) downto 1 do begin // result:= "s1+s2";
   if i<=length(s1) then
     w:=w+byte(s1[i]);
   if i<=length(s2) then
     w:=w+byte(s2[i]);
   result[i]:=char(w and $ff);
   w:=w shr 8;
 end;
 result:=char(w)+result;
 w:=0;
 for i:=1 to length(result) do begin
   nw:=byte(odd(byte(result[i])+w));
   result[i]:=char((byte(result[i])+w) div 2);
   w:=nw shl 8;
 end;
 if w<>0 then
   result:=result+char(w div 2);
 if result[1]<>#0 then begin
   writeln('Fehler bei der Mittenfindeung!');
   halt;
 end;
 delete(result,1,1);
end;

function myFloatToStr(x: extended): string;
begin
 result:=myFloatToStr(x,'E');
end;

function myFloatToStr(x: extended; ex: string): string;
var
  i,e: longint;
begin
 e:=0;
 if x<0 then begin
   result:='-';
   x:=-x;
 end
 else
   result:='';
 if x=0 then begin
   result:='0';
   exit;
 end;
 while x<1 do begin
   dec(e);
   x:=x*10;
 end;
 while x>=10 do begin
   inc(e);
   x:=x/10;
 end;
 result:=result+char(ord('0')+floor(x))+'.';
 for i:=0 to 20 do begin
   x:=(x-floor(x))*10;
   result:=result+char(ord('0')+floor(x));
 end;
 if e<>0 then
   result:=result+ex+inttostr(e);
end;

function myStrToFloat(s: string): extended;
var
  i,e: longint;
  neg: boolean;
begin
 if pos('E',s)>0 then begin
   e:=strtoint(rightStr(s,length(s)-pos('E',s)));
   delete(s,pos('E',s),length(s));
 end
 else e:=0;
 if pos('.',s)=0 then begin
   result:=strtoint(s)*power(10,e);
   exit;
 end;
 neg:=leftStr(s,1)='-';
 if neg then
   delete(s,1,1);
 if pos('.',s)=2 then begin
   result:=0;
   for i:=length(s) downto 3 do
     result:=result/10 + ord(s[i])-ord('0');
   result:=result/10 + ord(s[1])-ord('0');
 end
 else result:=strtofloat(s);
 result:=result*power(10,e);
 if neg then
   result:=-result;
end;

function max(g1,g2: tGenauigkeit): tGenauigkeit;
begin
  if g1>g2 then result:=g1
  else result:=g2;
end;

function wertGroesze(g: tGenauigkeit): longint;
begin
  case g of
    gSingle: result:=sizeof(single);
    gDouble: result:=sizeof(double);
    gExtended: result:=sizeof(extended);
    else begin
      gibAus('Unbekannter Genauigkeitstyp!',3);
      raise exception.create('Unbekannter Genauigkeitstyp!');
    end;
  end;
end;

// allgemeine Funktionen *******************************************************

function floattostrtrunc(f: extended; dig: longint; laessig: boolean): string;
begin
  result:=inttostr(round(f*power(10,dig)));
  result:=copy(result,1,length(result)-dig)+'.'+copy(result,length(result)-dig+1,dig);
  if laessig then
    while result[length(result)]='0' do
      delete(result,length(result),1);
  if result[length(result)]='.' then
    delete(result,length(result),1);
end;

function ZeitDarstellen(t: extended): string;
var schreibe: boolean;
begin
  result:='(';
  schreibe:=t>=1;
  if schreibe then begin
    result:=result+inttostr(floor(t))+' Tage ';
    t:=t-floor(t);
  end;
  t:=t*24;
  schreibe:=schreibe or (t>=1);
  if schreibe then begin
    result:=inttostr(floor(t))+':';
    t:=t-floor(t);
  end;
  t:=t*60;
  schreibe:=schreibe or (t>=1);
  if schreibe then begin
    result:=inttostr(floor(t))+':';
    t:=t-floor(t);
  end;
  t:=t*60;
  result:=result+inttostr(round(t))+' s)';
end;

function binOpPos(op: char; s: string): integer;
begin
  result:=0;
  repeat
    result:=result+max(1,pos(op,copy(s,result+1,length(s)-result)));
  until ((result>1) and not (s[result-1] in ['+','-','*','/','(','E','e','^'])) or (result>length(s)) or (s[result]<>op);
  if (result>length(s)) or (s[result]<>op) then result:=0;
end;

function fktPos(fkt,s: string): integer;
var tmp: longint;
begin
  result:=pos(fkt,s);
  while (result<>0) and ((result+length(fkt)>length(s)) or not (s[result+length(fkt)] in [' ','('])) do begin
    tmp:=pos(fkt,copy(s,result+1,length(s)));
    if tmp=0 then result:=0
    else result:=result + tmp;
  end;
end;

procedure gibAus(s: string; ausgaben: byte);
begin
  if odd(ausgaben) then myDebugLnThreadLog(s);
  if odd(ausgaben div 2) then writeln(s);
end;

function strToGen(out gen: tGenauigkeit; s: string): boolean;
begin
  result:=true;
  if (s='float') or (s='single') then
   begin
    gen:=gSingle;
    exit;
   end;
  if s='double' then
   begin
    gen:=gDouble;
    exit;
   end;
  if s='extended' then
   begin
    gen:=gExtended;
    exit;
   end;
  gibAus('Kenne Genauigkeitstyp '''+s+''' nicht!',3);
  result:=false;
end;

function mischeFarben(a,b: tRGB; x: extended): tRGB;
begin
 result.rgbRed:=min(255,max(0,round(a.rgbRed*(1-x)+b.rgbRed*x)));
 result.rgbGreen:=min(255,max(0,round(a.rgbGreen*(1-x)+b.rgbGreen*x)));
 result.rgbBlue:=min(255,max(0,round(a.rgbBlue*(1-x)+b.rgbBlue*x)));
end;

function orFarben(a,b: tRGB): tRGB;
begin
 result.rgbRed:=a.rgbRed or b.rgbRed;
 result.rgbGreen:=a.rgbGreen or b.rgbGreen;
 result.rgbBlue:=a.rgbBlue or b.rgbBlue;
end;

function andFarben(a,b: tRGB): tRGB;
begin
 result.rgbRed:=a.rgbRed and b.rgbRed;
 result.rgbGreen:=a.rgbGreen and b.rgbGreen;
 result.rgbBlue:=a.rgbBlue and b.rgbBlue;
end;

function wertZuFarbe(x: extended; p: tRGBArray): tRGB;
var i: longint;
begin
 x:=min(1,max(0,x))*(length(p)-1);
 i:=floor(x);
 if i>=(length(p)-1) then begin
   result.rgbRed:=p[length(p)-1].rgbRed;
   result.rgbGreen:=p[length(p)-1].rgbGreen;
   result.rgbBlue:=p[length(p)-1].rgbBlue;
   exit;
 end;
 if i<0 then begin
   result.rgbRed:=p[0].rgbRed;
   result.rgbGreen:=p[0].rgbGreen;
   result.rgbBlue:=p[0].rgbBlue;
   exit;
 end;
 x:=x-i;
 result:=mischeFarben(p[i],p[i+1],x);
end;

function tFPColor2tRgb(c: tFPColor): tRGB;
begin
 result.rgbRed:=c.red;
 result.rgbGreen:=c.green;
 result.rgbBlue:=c.blue;
end;

function tRgb2tFPColor(c: tRGB): tFPColor;
begin
 result.red:=c.rgbRed;
 result.green:=c.rgbGreen;
 result.blue:=c.rgbBlue;
end;

procedure myDebugLnThreadLog(s: string);
var f:  textfile;
    id: PtrUInt;
begin
 id:=getThreadID;
 assignfile(f,'Log'+inttostr(id));
 try
   if fileexists('Log'+inttostr(id)) then append(f)
   else rewrite(f);
 except
   exit;
 end;
 writeln(f,inttostr(id)+': '+s);
 closefile(f);
end;

function belegterSpeicher: longint;
var f:    textFile;
    s:    string;
begin
 s:='/proc/'+inttostr(getProcessId)+'/smaps';
 result:=0;
 if not fileexists(s) then exit;
 assignfile(f,s);
 reset(f);
 while not eof(f) do begin
   readln(f,s);
   if (leftStr(s,4)='Rss:') and (rightStr(s,3)=' kB') then begin
     delete(s,1,4);
     delete(s,length(s)-2,3);
     s:=trim(s);
     result:=result+strtoint(s);
   end;
 end;
 closefile(f);
end;

procedure cleanupLogs;
var sr:  tSearchRec;
    err: longint;
begin
 err:=findfirst('Log*',$3f,sr);
 while err=0 do begin
   deletefile(sr.name);
   err:=findnext(sr);
 end;
 findclose(sr);
end;

procedure cleanupLog(tid: PtrUInt);
var s:    string;
    Zeit: extended;
begin
 s:='Log'+inttostr(tid);
 Zeit:=now+1/24/60/60;
 while (not fileexists(s)) and (Zeit>now) do
   sleep(100);
 if fileexists(s) then
   deletefile(s)
 else begin
   gibAus('Datei '''+s+''' kann nicht gelöscht werden, da sie nicht existiert!',3);
   raise exception.create('Datei '''+s+''' kann nicht gelöscht werden, da sie nicht existiert!');
 end;
end;

procedure raiseAndDumpExceptionCallStack(msg: string);
var
  e: exception;
begin
  e:=exception.create(msg);
  dumpExceptionCallStack(e);
  raise e;
end;

procedure dumpExceptionCallStack(E: Exception);
var
  I: Integer;
  Frames: PPointer;
  Report: string;
begin
 Report := 'Program exception! ' + LineEnding +
   'Stacktrace:' + LineEnding + LineEnding;
 if E <> nil then begin
   Report := Report + 'Exception class: ' + E.ClassName + LineEnding +
   'Message: ' + E.Message + LineEnding;
 end;
 Report := Report + BackTraceStrFunc(ExceptAddr);
 Frames := ExceptFrames;
 for I := 0 to ExceptFrameCount - 1 do
   Report := Report + LineEnding + BackTraceStrFunc(Frames[I]);
 gibAus(Report,3);
end;

function startetMit(start: string; var s: string): boolean;
begin
 result:=leftStr(s,length(start))=start;
 if result then
   s:=trim(rightStr(s,length(s)-length(start)));
end;

function endetMit(ende: string; var s: string): boolean;
begin
 result:=rightStr(s,length(ende))=ende;
 if result then
   s:=trim(leftStr(s,length(s)-length(ende)));
end;

function trimAll(s: string): string;
begin
 result:=s;
 while pos(' ',result)>0 do
   delete(result,pos(' ',result),1);
end;

function erstesArgument(var s: string): string;
begin
 result:=erstesArgument(s,' ');
end;

function erstesArgument(var s: string; Trenner: string): string;
begin
 result:=copy(s,1,pos(Trenner,s+Trenner)-1);
 delete(s,1,length(result)+length(Trenner));
 s:=trim(s);
 result:=trim(result);
end;

function mydatetimetostr(t: tDateTime): string;
begin
 result:=formatDateTime('YYYY.MM.DD_hh.mm.ss',t);
end;

function tExtPointToStr(p: tExtPoint): string;
begin
 result:=floattostr(p['x'])+';'+floattostr(p['y']);
end;

function tIntPointToStr(p: tIntPoint): string;
begin
 result:=inttostr(p['x'])+';'+inttostr(p['y']);
end;

procedure fehler(s: string);
begin
 gibAus(s,1);
 raise exception.create(s);
end;

function hexDump(p: pointer; cnt: longint): string;
var
  i: longint;
begin
 result:='';
 for i:=cnt-1 downto 0 do
   result:=result+inttohex((pByte(p)+i)^,2);
end;

function base64ToBin(var s: string): boolean;
var
  i,j: longint;
  t:   string;
  b:   byte;
begin
  t:='';
  result:=false;
  for i:=1 to length(s) do begin
    b:=base64CharsInvers[s[i]];
    if b=255 then exit;
    for j:=5 downto 0 do
      t:=t+char(ord('0')+byte(odd(b shr j)));
  end;
  s:=t;
  result:=true;
end;

function base64Decode(const s: string; out i: qword): boolean;
var
  j: longint;
  b: byte;
begin
  i:=0;
  result:=false;
  for j:=1 to length(s) do begin
    b:=base64CharsInvers[s[j]];
    if b=255 then exit;
    i:=(i shl 6) or b;
  end;
  result:=true;
end;

function base64Decode(const s: string; out i: longword): boolean;
var
  j: qword;
begin
  result:=base64Decode(s,j);
  if result then
    i:=j
  else
    i:=0;
end;

function base64Encode(i: longword): string;
begin
  result:=base64Encode(i,(8*sizeof(i)+7) div 6);
end;

function base64Encode(i,siz: longword): string;
var
  j: longint;
begin
  result:='';
  for j:=0 to siz-1 do begin
    result:=base64Chars[i and $3f]+result;
    i:=i shr 6;
  end;
end;

function mirrorBits(qw: qword): qword;
begin
  result:=
    (mirrorBits(longword(qw and $ffffffff)) shl 32) or
     mirrorBits(longword(qw shr 32));
end;

function mirrorBits(lw: longword): longword;
begin
  result:=
    (mirrorBits(word(lw and $ffff)) shl 16) or
     mirrorBits(word(lw shr 16));
end;

function mirrorBits(w: word): word;
begin
  result:=
    (mirrorBits(byte(w and $ff)) shl 8) or
     mirrorBits(byte(w shr 8));
end;

function mirrorBits(b: byte): byte;
begin
  result:=
     byte(odd(b shr 7)) or
    (byte(odd(b shr 6)) shl 1) or
    (byte(odd(b shr 5)) shl 2) or
    (byte(odd(b shr 4)) shl 3) or
    (byte(odd(b shr 3)) shl 4) or
    (byte(odd(b shr 2)) shl 5) or
    (byte(odd(b shr 1)) shl 6) or
    (byte(odd(b)) shl 7);
end;

function zusammenfassen(s1,s2: string): string;
var
  i: longint;
begin
 if istGanzZahl(s1) and istGanzZahl(s2) then begin
   i:=strtoint(s1)+strtoint(s2);
   result:=inttostr(i);
   if (startetMit('+',s1) or startetMit('+',s2)) and (i>=0) then
     result:='+'+result;
 end
 else if s1=s2 then result:=s1
 else raise exception.create('Ich kann '''+s1+''' und '''+s2+''' nicht zusammenfassen!');
end;

var b: byte;

begin
  _cpuLastUsed:=0;
  _cpuLastIdle:=0;
  cpuUtilization;

  for b:=0 to 25 do begin
    base64Chars[b]:=   char(b+ord('A'));
    base64Chars[b+26]:=char(b+ord('a'));
  end;
  for b:=0 to 9 do
    base64Chars[52+b]:=char(b+ord('0'));
  base64Chars[62]:='+';
  base64Chars[63]:='/';
  for b:=0 to 255 do
    base64CharsInvers[char(b)]:=255;
  for b:=0 to 63 do
    base64CharsInvers[base64Chars[b]]:=b;
end.