etliche Prozeduren aus ../epost/*.pas uebernommen

1 files changed, 332 insertions, 245 deletions

diff --git a/lowlevelunit.pas b/lowlevelunit.pas
index d97cbf3..8fc6fa0 100644
--- a/lowlevelunit.pas
+++ b/lowlevelunit.pas
@@ -5,44 +5,35 @@ unit lowlevelunit;
 interface
 
 uses
-  math, Classes, SysUtils, gmp, RegExpr, process;
+  math, Classes, SysUtils, gmp, RegExpr, process, agg_2D, FPimage, agg_basics;
 
 type
-  tMersenneTwister = class
-  private
-    state: array[0..623] of longword;
-    index: longint;
-  public
-    procedure init(seed: longword);
-    function extract_number: longword;
-    function random(ma: longword): longword; overload;
-    function random: extended; overload;
-    procedure generate_numbers;
-  end;
-
-  tMyStringlist = class;
-
-  tInputThread = class (tThread)
-    fertig: boolean;
-    inhalt: tMyStringList;
-    proc:   tProcess;
-    constructor create(p: tProcess; sl: tMyStringList);
-    destructor destroy; override;
-    procedure execute; override;
-  end;
-
-  tMyStringlist = class (tStringlist)
-  private
-    line:  longint;
-  public
-    constructor create;
-    procedure loadFromFile(const s: ansiString); override;
-    procedure loadFromGz(const s: ansiString);
-    procedure saveToGz(const s: ansiString);
-    function readln(out s: string): boolean;
-    procedure grep(expr: string);
-    function eof: boolean;
+  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;
+  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,gExtended);
 
 function signSqr(x: extended): extended; inline;
 function mpfToStr(f: mpf_t): string;
@@ -55,221 +46,39 @@ function belegterSpeicher: int64;
 function minCache: int64;
 function cmpStr(s1,s2: string): longint;
 function mitte(s1,s2: string): string;
-function myFloatToStr(x: extended): string;
+function myFloatToStr(x: extended): string; overload;
+function myFloatToStr(x: extended; ex: string): string; overload;
 function myStrToFloat(s: string): extended;
 
+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 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;
 
-// tMersenneTwister ************************************************************
-
-procedure tMersenneTwister.init(seed: longword);
-var
-  i: longint;
-begin
- index:=0;
- state[0]:=seed;
- for i:=1 to 623 do
-   state[i]:=longword($ffffffff and (qword(1812433253) * qword(state[i-1] xor state[i-1] shr 30) + i)); // 0x6c078965
-end;
-
-function tMersenneTwister.extract_number: longword;
-begin
- if index=0 then
-   generate_numbers;
-
- result:=state[index];
- result:=result xor (result shr 11);
- result:=result xor longword(qword(result shl 7) and 2636928640);  // 0x9d2c5680
- result:=result xor longword(qword(result shl 15) and 4022730752); // 0xefc60000
- result:=result xor (result shr 18);
-
- index := (index + 1) mod 624;
-end;
-
-function tMersenneTwister.random(ma: longword): longword;
-var
-  i: longword;
-begin
- repeat
-   i:=extract_number;
- until i<((high(longword)+1) div qword(ma))*ma;
- result:=i mod ma;
-end;
-
-function tMersenneTwister.random: extended;
-begin
- result:=(extract_number/(high(longword)+1) + extract_number)/(high(longword)+1);
-end;
-
-procedure tMersenneTwister.generate_numbers;
-var
-  i,y: longint;
-begin
- for i:=0 to 623 do begin
-   y:=longint((state[i] and $80000000) or            // bit 31 (32nd bit) of MT[i]
-              (state[(i+1) mod 624] and $7fffffff)); // bits 0-30 (first 31 bits) of MT[...]
-   state[i]:=state[(i + 397) mod 624] xor (y shr 1);
-   if odd(y) then
-     state[i]:=longword(state[i] xor 2567483615); // 0x9908b0df
- end;
-end;
-
-// tInputThread ****************************************************************
-
-constructor tInputThread.create(p: tProcess; sl: tMyStringList);
-begin
- inherited create(true);
- fertig:=false;
- inhalt:=sl;
- proc:=p;
- suspended:=false;
-end;
-
-destructor tInputThread.destroy;
-begin
- inhalt:=nil;
- proc:=nil;
- inherited destroy;
-end;
-
-procedure tInputThread.execute;
-var
-  wb,cwb: longint;
-begin
- wb:=0;
- while wb<length(inhalt.text) do begin
-   cwb:=proc.input.write(inhalt.text[wb+1],length(inhalt.text)-wb);
-   if cwb=0 then
-     sleep(1)
-   else
-     wb:=wb+cwb;
- end;
- proc.CloseInput;
- fertig:=true;
-end;
-
-// tMyStringlist ***************************************************************
-
-constructor tMyStringlist.create;
-begin
- inherited create;
- line:=0;
-end;
-
-procedure tMyStringlist.loadFromFile(const s: ansiString);
-var i: longint;
-begin
- inherited loadFromFile(s);
- for i:=0 to count-1 do
-   self[i]:=trim(self[i]);
- line:=0;
- writeln(inttostr(count)+' Zeilen eingelesen');
-end;
-
-procedure tMyStringlist.loadFromGz(const s: ansiString);
-var p:     tProcess;
-    buf:   ansiString;
-    rb,br: longint;
-begin
- p:=tProcess.create(nil);
- p.executable:='/usr/bin/zcat';
- p.parameters.add(s);
- p.options:=p.options + [poUsePipes];
- setlength(buf,0);
- br:=0;
- p.execute;
- while p.running do begin
-   rb:=p.output.numBytesAvailable;
-   if rb>0 then begin
-     if length(buf)<br+rb then
-       setlength(buf,br+rb+1048576);
-     rb:=p.output.read(buf[br+1],rb);
-     br:=br+rb;
-   end
-   else sleep(1);
- end;
- setlength(buf,br);
- rb:=p.output.numBytesAvailable;
- while rb>0 do begin
-   setlength(buf,br+rb);
-   rb:=p.output.read(buf[br+1],rb);
-   br:=br+rb;
-   rb:=p.output.numBytesAvailable;
- end;
- text:=buf;
- setlength(buf,0);
- p.free;
- for rb:=0 to count-1 do
-   self[rb]:=trim(self[rb]);
- line:=0;
- writeln(inttostr(count)+' Zeilen eingelesen');
-end;
-
-procedure tMyStringlist.saveToGz(const s: ansiString);
-var
-  p:     tProcess;
-  buf:   array of byte;
-  f:     file;
-  rb:    longint;
-  it:    tInputThread;
-const
-  outBufLen = 1024*1024;
-begin
- p:=tProcess.create(nil);
- p.executable:='/usr/bin/gzip';
- p.parameters.add('--best');
- p.parameters.add('-c');
- p.options:=p.options + [poUsePipes];
- p.execute;
- setlength(buf,outBufLen);
- fillchar(buf[0],length(buf)*sizeof(buf[0]),$0);
- it:=tInputThread.create(p,self);
- assignfile(f,s);
- rewrite(f,1);
- while p.running or (not it.fertig) or (p.output.numBytesAvailable>0) do begin
-   rb:=min(length(buf),p.output.numBytesAvailable);
-   if rb>0 then begin
-     rb:=p.output.read(buf[0],rb);
-     blockwrite(f,buf[0],rb);
-   end
-   else
-     sleep(1); // nix zu Schreiben, nix zu Lesen, also warten wir
- end;
- it.free;
- closefile(f);
-end;
-
-function tMyStringlist.readln(out s: string): boolean;
-begin
- result:=not eof;
- if not result then begin
-   s:='';
-   exit;
- end;
- s:=self[line];
- inc(line);
-end;
-
-procedure tMyStringlist.grep(expr: string);
-var
-  re: tRegExpr;
-  i:  longint;
-begin
-  re:=tRegExpr.create;
-  re.Expression:=expr;
-  for i:=count-1 downto 0 do
-    if not re.Exec(self[i]) then
-      delete(i);
-  re.free;
-end;
-
-function tMyStringlist.eof: boolean;
-begin
- result:=line>=count;
-end;
-
 // allgemeine Funktionen *******************************************************
 
 function signSqr(x: extended): extended;
@@ -478,6 +287,11 @@ begin
 end;
 
 function myFloatToStr(x: extended): string;
+begin
+ result:=myFloatToStr(x,'E');
+end;
+
+function myFloatToStr(x: extended; ex: string): string;
 var
   i,e: longint;
 begin
@@ -506,7 +320,7 @@ begin
    result:=result+char(ord('0')+floor(x));
  end;
  if e<>0 then
-   result:=result+'E'+inttostr(e);
+   result:=result+ex+inttostr(e);
 end;
 
 function myStrToFloat(s: string): extended;
@@ -538,6 +352,279 @@ begin
    result:=-result;
 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='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 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;