summaryrefslogtreecommitdiff
path: root/lowlevelunit.pas
diff options
context:
space:
mode:
Diffstat (limited to 'lowlevelunit.pas')
-rw-r--r--lowlevelunit.pas522
1 files changed, 277 insertions, 245 deletions
diff --git a/lowlevelunit.pas b/lowlevelunit.pas
index ced3603..1d3aa33 100644
--- a/lowlevelunit.pas
+++ b/lowlevelunit.pas
@@ -74,6 +74,7 @@ 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; Trenner: string = ' '; trimmen: boolean = true): string; inline;
+function unEscape(s: string): string;
function mydatetimetostr(t: tDateTime): string;
function t2x2ExtendedToStr(p: t2x2Extended): string;
function tExtPointToStr(p: tExtPoint): string;
@@ -143,7 +144,7 @@ end;
function signSqr(x: extended): extended;
begin
- result:=sign(x)*sqr(x);
+ result:=sign(x)*sqr(x);
end;
function mpfToStr(f: mpf_t): string;
@@ -151,46 +152,46 @@ 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);
+ 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;
+ 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 mpfMyRoot(rad: mpf_t; wzlExp: int64): extended;
@@ -205,16 +206,16 @@ 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;
+ 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;
@@ -222,67 +223,67 @@ 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);
+ 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');
+ 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);
+ 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;
@@ -290,28 +291,28 @@ 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;
+ 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 myIntToStr(i,dg: longint): string;
@@ -359,7 +360,8 @@ begin
end;
function ZeitDarstellen(t: extended): string;
-var schreibe: boolean;
+var
+ schreibe: boolean;
begin
result:='(';
schreibe:=t>=1;
@@ -393,7 +395,8 @@ begin
end;
function fktPos(fkt,s: string): integer;
-var tmp: longint;
+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
@@ -413,129 +416,133 @@ function strToGen(out gen: tGenauigkeit; s: string): boolean;
begin
result:=true;
if (s='float') or (s='single') then
- begin
+ begin
gen:=gSingle;
exit;
- end;
+ end;
if s='double' then
- begin
+ begin
gen:=gDouble;
exit;
- end;
+ end;
if s='extended' then
- begin
+ begin
gen:=gExtended;
exit;
- end;
+ 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)));
+ 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;
+ 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;
+ 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);
+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;
+ 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;
+ result.red:=c.rgbRed;
+ result.green:=c.rgbGreen;
+ result.blue:=c.rgbBlue;
end;
function rgb(r,g,b: byte): tRGB;
begin
- result.rgbRed:=r;
- result.rgbGreen:=g;
- result.rgbBlue:=b;
+ result.rgbRed:=r;
+ result.rgbGreen:=g;
+ result.rgbBlue:=b;
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);
+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;
procedure cleanupLogs;
-var sr: tSearchRec;
- err: longint;
+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);
+ 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;
+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);
@@ -553,84 +560,108 @@ var
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);
+ 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)));
+ 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)));
+ 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);
+ result:=s;
+ while pos(' ',result)>0 do
+ delete(result,pos(' ',result),1);
end;
function erstesArgument(var s: string; Trenner: string; trimmen: boolean): string;
begin
- result:=copy(s,1,pos(Trenner,s+Trenner)-1);
- delete(s,1,length(result)+length(Trenner));
- if not trimmen then exit;
- s:=trim(s);
- result:=trim(result);
+ result:=copy(s,1,pos(Trenner,s+Trenner)-1);
+ delete(s,1,length(result)+length(Trenner));
+ if not trimmen then exit;
+ s:=trim(s);
+ result:=trim(result);
+end;
+
+function unEscape(s: string): string;
+var
+ i: longint;
+ ec,qt: boolean;
+begin
+ result:='';
+ ec:=false;
+ qt:=false;
+ for i:=1 to length(s) do
+ if ec then begin
+ result:=result+s[i];
+ ec:=false;
+ end else
+ case s[i] of
+ '"','''': qt:=not qt;
+ '\': ec:=true;
+ else result:=result+s[i];
+ end{of case};
+ if qt then
+ fehler('Anführungszeichen sind nicht ausgeglichen in '''+s+'''!');
+ if ec then
+ fehler(''''+s+''' endet auf einen aktiven Deaktivierer!');
end;
function mydatetimetostr(t: tDateTime): string;
begin
- result:=formatDateTime('YYYY.MM.DD_hh.mm.ss',t);
+ result:=formatDateTime('YYYY.MM.DD_hh.mm.ss',t);
end;
function t2x2ExtendedToStr(p: t2x2Extended): string;
begin
- result:=
- floattostr(p['x','x'])+' .. '+floattostr(p['x','y'])+' x '+
- floattostr(p['y','x'])+' .. '+floattostr(p['y','y']);
+ result:=
+ floattostr(p['x','x'])+' .. '+floattostr(p['x','y'])+' x '+
+ floattostr(p['y','x'])+' .. '+floattostr(p['y','y']);
end;
function tExtPointToStr(p: tExtPoint): string;
begin
- result:=floattostr(p['x'])+';'+floattostr(p['y']);
+ result:=floattostr(p['x'])+';'+floattostr(p['y']);
end;
function tIntPointToStr(p: tIntPoint): string;
begin
- result:=inttostr(p['x'])+';'+inttostr(p['y']);
+ result:=inttostr(p['x'])+';'+inttostr(p['y']);
end;
procedure fehler(s: string);
begin
- gibAus(s,1);
- raise exception.create(s);
+ 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);
+ result:='';
+ for i:=cnt-1 downto 0 do
+ result:=result+inttohex((pByte(p)+i)^,2);
end;
function base64ToBin(var s: string): boolean;
@@ -697,27 +728,27 @@ function mirrorBits(qw: qword): qword;
begin
result:=
(mirrorBits(longword(qw and $ffffffff)) shl 32) or
- mirrorBits(longword(qw shr 32));
+ 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));
+ 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));
+ mirrorBits(byte(w shr 8));
end;
function mirrorBits(b: byte): byte;
begin
result:=
- byte(odd(b shr 7)) or
+ 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
@@ -731,14 +762,14 @@ 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!');
+ 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;
function intervallAusrollen(s: string): string;
@@ -876,7 +907,8 @@ begin
end;
end;
-var b: byte;
+var
+ b: byte;
begin
for b:=0 to 25 do begin
generated by cgit v1.2.3-70-g09d2 (git 2.47.0) at 2024-12-04 19:17:44 +0000