diff options
Diffstat (limited to 'lowlevelunit.pas')
| -rw-r--r-- | lowlevelunit.pas | 577 |
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; |