diff options
| -rw-r--r-- | lowlevelunit.pas | 577 | ||||
| -rw-r--r-- | mystringlistunit.pas | 187 |
2 files changed, 518 insertions, 246 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; diff --git a/mystringlistunit.pas b/mystringlistunit.pas index d3fe052..45963d4 100644 --- a/mystringlistunit.pas +++ b/mystringlistunit.pas @@ -5,7 +5,7 @@ unit mystringlistunit; interface uses - Classes, SysUtils, RegExpr, Process, Math; + Classes, SysUtils, RegExpr, Process, Math, lowlevelunit; type tMyStringlist = class; @@ -30,8 +30,13 @@ type function readln(out s: string): boolean; procedure grep(expr: string); function eof: boolean; + procedure rewind; + function stillNeed(bez: string): boolean; + function unfoldMacros: boolean; end; +procedure _del(var s: string; p,c: longint); inline; // identisch zu delete(s,p,c) -- lediglich um delete innerhalb von tMyStringlist verfügbar zu haben + implementation // tInputThread **************************************************************** @@ -188,5 +193,185 @@ begin result:=line>=count; end; +procedure tMyStringlist.rewind; +begin + line:=0; +end; + +function tMyStringlist.stillNeed(bez: string): boolean; +var i: longint; + s,t: string; +begin + result:=false; + for i:=max(0,line-1) to count-1 do begin + s:=' '+self[i]+' '; + while pos(bez,s)>0 do begin + t:=copy(s,1,pos(bez,s)+length(bez)); + _del(s,1,pos(bez,s)+length(bez)-1); + _del(t,1,length(t)-length(bez)-2); + if (t[1] in [' ',#9,':','[']) and (t[length(t)] in [' ',#9,':',']']) and (copy(t,2,length(bez))=bez) then begin + result:=true; + exit; + end; + end; + end; +end; + +function tMyStringlist.unfoldMacros: boolean; +var i,j,k,l,Ebene: longint; + s,t,u,v: string; + SchleifenInhalt: tMyStringlist; + istWahr,gefunden: boolean; +const binops: array[0..8] of string = + ('<=','>=','<>','≤','≥','=','≠','<','>'); +begin + result:=false; + + i:=0; + while i<count do begin // Kommentare löschen + s:=self[i]; + s:=erstesArgument(s,'#'); + if length(s)=0 then begin + delete(i); + continue; + end; + self[i]:=s; + inc(i); + end; + + i:=0; + while i<count do begin // Übersprünge überspringen, alles nach 'Dateiende' löschen + s:=self[i]; + if startetMit('!überspringe:',s) then begin + for j:=0 to strtoint(s) do + delete(i); + continue; + end; + + if s='Dateiende' then begin + inc(i); + while i<count do + delete(i); + continue; + end; + inc(i); + end; + + i:=0; + while i<count do begin // Schleifen ausrollen + s:=self[i]; + if startetMit('!Schleife:',s) then begin + l:=i; + delete(i); + t:=erstesArgument(s,':'); + if (length(t)=0) or (t[1]<>'$') then exit; + + SchleifenInhalt:=tMyStringlist.create; // Schleifenkörper merken + Ebene:=0; + while (i<Count) and ((Ebene<>0) or (self[i]<>'!Schleifenende')) do begin + SchleifenInhalt.Add(self[i]); + if self[i]='!Schleifenende' then dec(Ebene); + if pos('!Schleife:',self[i])=1 then inc(Ebene); + delete(i); + end; + delete(i); + + while length(s)>0 do begin // Schleifenzähler laufen lassen + u:=erstesArgument(s); + for j:=0 to SchleifenInhalt.Count-1 do begin // Schleifenkörper ... + v:=SchleifenInhalt[j]; + k:=length(v); + while (pos(t,v)>0) and (k>0) do begin // ... nach Ersetzung ... + v:=copy(v,1,pos(t,v)-1)+u+copy(v,pos(t,v)+length(t),length(v)); + dec(k); + end; + insert(i,v); // ... kopieren + inc(i); + end; + end; + + SchleifenInhalt.free; + i:=l; + continue; + end; + self[i]:=s; + inc(i); + end; + + i:=0; + while i<count do begin // Bedingungen auswerten + s:=self[i]; + if startetMit('?',s) then begin + t:=erstesArgument(s,':'); + gefunden:=false; + for j:=0 to length(binops)-1 do + if pos(binops[j],t)>0 then begin + gefunden:=true; + u:=trim(copy(t,1,pos(binops[j],t)-1)); + _del(t,1,pos(binops[j],t)+length(binops[j])-1); + t:=trim(t); + case binops[j] of + '≤','<=': istWahr:=strtofloat(u)<=strtofloat(t); + '≥','>=': istWahr:=strtofloat(u)>=strtofloat(t); + '=': + try + istWahr:=strtofloat(u)=strtofloat(t); + except + istWahr:=u=t; + end; + '≠','<>': + try + istWahr:=strtofloat(u)<>strtofloat(t); + except + istWahr:=u<>t; + end; + '<': istWahr:=strtofloat(u)<strtofloat(t); + '>': istWahr:=strtofloat(u)>strtofloat(t); + else begin + gibAus('Operator '''+binops[j]+''' ist nicht implementiert!',3); + exit; + end; + end{of case}; + if not istWahr then + delete(i); + break; + end; + if not gefunden then begin + gibAus('Ich kann keinen gültigen Operator in Bedingung '''+t+''' finden!',3); + exit; + end; + if not istWahr then + continue; + self[i]:=s; + end; + inc(i); + end; + + i:=0; + while i<count do begin // nochmals Übersprünge überspringen und alles nach 'Dateiende' ignorieren + s:=self[i]; + if startetMit('!überspringe:',s) then begin + for j:=0 to strtoint(s) do + delete(i); + continue; + end; + + if s='Dateiende' then begin + inc(i); + while i<count do + delete(i); + continue; + end; + inc(i); + end; + + result:=true; +end; + +procedure _del(var s: string; p,c: longint); +begin + delete(s,p,c); +end; + end. |