path: root/lowlevelunit.pas

unit lowlevelunit;

{$mode objfpc}{$H+}

interface

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

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 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);

implementation

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:  int64;
  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: int64;
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;

// 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));
 if fileexists('Log'+inttostr(id)) then append(f)
 else rewrite(f);
 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;

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