diff options
| -rw-r--r-- | lowlevelunit.pas | 522 |
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 |