summaryrefslogtreecommitdiff
path: root/romunit.pas
diff options
context:
space:
mode:
Diffstat (limited to 'romunit.pas')
-rw-r--r--romunit.pas271
1 files changed, 168 insertions, 103 deletions
diff --git a/romunit.pas b/romunit.pas
index bfd4ca9..f62b8fe 100644
--- a/romunit.pas
+++ b/romunit.pas
@@ -63,17 +63,19 @@ begin
end;
procedure readRawInputs(nam: string; out d1,d2: tExtPointArray; var absShift: extended);
-var f: file;
- tf: textfile;
- s: string;
- i,j,k,start,stop,traces,steps: longint;
- i32: int32;
- sr: tSearchRec;
- fl: single;
- buff: array of single;
- factor,dx,cells_left,maxAmp: extended;
+var
+ f: file;
+ tf: textfile;
+ s: string;
+ i,j,k,start,stop,traces,steps: longint;
+ i32: int32;
+ sr: tSearchRec;
+ fl: single;
+ buff: array of single;
+ factor,dx,cells_left,maxAmp: extended;
begin
- if not fileexists(nam) then Fehler('Die Datei '''+nam+''' existiert nicht!');
+ if not fileexists(nam) then
+ Fehler('Die Datei '''+nam+''' existiert nicht!');
assignfile(tf,nam);
i:=0;
reset(tf);
@@ -143,7 +145,11 @@ begin
end{of case};
end;
closefile(tf);
- if (not odd(i)) or ((absShift<-1.5e9) and ((dx=0) or (cells_left=0))) then Fehler('Unerwartetes Dateiende in '''+nam+'''!');
+ if (not odd(i)) or
+ ((absShift<-1.5e9) and
+ ((dx=0) or
+ (cells_left=0))) then
+ Fehler('Unerwartetes Dateiende in '''+nam+'''!');
setlength(d1,0);
setlength(d2,0);
@@ -192,7 +198,8 @@ begin
for j:=0 to traces-1 do begin
blockread(f,fl,sizeof(single)); // x-Position
if j=0 then begin
- if i=start then cells_left:=cells_left-fl;
+ if i=start then
+ cells_left:=cells_left-fl;
blockread(f,buff[0],sizeof(single)*steps); // fp
for k:=0 to steps-1 do begin
d1[k+length(d1)-steps]['x']:=(i-1+k/steps)*factor;
@@ -221,9 +228,10 @@ begin
end;
procedure readTextInput(nam: string; out dat: tExtPointArray);
-var f: textfile;
- i: longint;
- s: string;
+var
+ f: textfile;
+ i: longint;
+ s: string;
begin
if not fileexists(nam) then
Fehler('Datei '''+nam+''' existiert nicht!');
@@ -233,9 +241,12 @@ begin
i:=0;
while not eof(f) do begin
readln(f,s);
- if pos('#',s)>0 then delete(s,pos('#',s),length(s));
- while (length(s)>0) and (s[1]=' ') do delete(s,1,1);
- if s='' then continue;
+ if pos('#',s)>0 then
+ delete(s,pos('#',s),length(s));
+ while (length(s)>0) and (s[1]=' ') do
+ delete(s,1,1);
+ if s='' then
+ continue;
inc(i);
end;
closefile(f);
@@ -243,26 +254,33 @@ begin
setlength(dat,i);
for i:=0 to length(dat)-1 do begin
readln(f,s);
- if pos('#',s)>0 then delete(s,pos('#',s),length(s));
- while (length(s)>0) and (s[1]=' ') do delete(s,1,1);
- if s='' then continue;
+ if pos('#',s)>0 then
+ delete(s,pos('#',s),length(s));
+ while (length(s)>0) and (s[1]=' ') do
+ delete(s,1,1);
+ if s='' then
+ continue;
dat[i]['x']:=strtofloat(copy(s,1,pos(' ',s)-1));
delete(s,1,pos(' ',s));
- while (length(s)>0) and (s[1]=' ') do delete(s,1,1);
+ while (length(s)>0) and (s[1]=' ') do
+ delete(s,1,1);
dat[i]['y']:=strtofloat(copy(s,1,pos(' ',s+' ')-1));
- if i and 1023 = 0 then write(stderr,'.');
+ if i and 1023 = 0 then
+ write(stderr,'.');
end;
closefile(f);
writeln(stderr,'fertig');
end;
procedure writeOutput(nam: string; const dat: tExtPointArray);
-var f: textfile;
- i,ml,mr: longint;
- leer: string;
- strings: array of array[boolean] of string;
+var
+ f: textfile;
+ i,ml,mr: longint;
+ leer: string;
+ strings: array of array[boolean] of string;
begin
- if length(dat)=0 then exit;
+ if length(dat)=0 then
+ exit;
write(stderr,'Datei '''+nam+''' schreiben ');
assignfile(f,nam);
rewrite(f);
@@ -274,23 +292,27 @@ begin
strings[i,true]:=floattostr(dat[i]['y']);
ml:=max(ml,length(strings[i,false]));
mr:=max(mr,pos('.',strings[i,true]+'.'));
- if i and 65535 = 0 then write(stderr,'.');
+ if i and 65535 = 0 then
+ write(stderr,'.');
end;
setlength(leer,ml+mr);
fillchar(leer[1],length(leer),' ');
for i:=0 to length(dat)-1 do begin
writeln(f,strings[i,false]+copy(leer,1,1+ml+mr-length(strings[i,false])-pos('.',strings[i,true]+'.'))+strings[i,true]);
- if i and 65535 = 0 then write(stderr,'.');
+ if i and 65535 = 0 then
+ write(stderr,'.');
end;
closefile(f);
writeln(stderr,' fertig');
end;
procedure writeOutput(nam: string; const dat,datArg: tExtPointArray); overload;
-var f: textfile;
- i: longint;
+var
+ f: textfile;
+ i: longint;
begin
- if length(dat)=0 then exit;
+ if length(dat)=0 then
+ exit;
if length(dat)<>length(datArg) then
Fehler('dat und datArg haben unterschiedlich viele Werte!');
write(stderr,'Datei '''+nam+''' schreiben ');
@@ -305,19 +327,21 @@ begin
floattostr(dat[i]['y'])+#9+
floattostr(datArg[i]['y'])
);
- if i and 65535 = 0 then write(stderr,'.');
+ if i and 65535 = 0 then
+ write(stderr,'.');
end;
closefile(f);
writeln(stderr,' fertig');
end;
procedure berechneTrajektorie(const inPuls,outPuls: tExtPointArray; out surTraj: tExtPointArray; absShift: extended);
-var i,j: longint;
- exList: array[0..3] of tLongintArray;
- psThreads: array of tPhaseShiftThread;
- stuecke: array of array[boolean,boolean] of longint;
- erledigt: array of boolean;
- b1,b2: boolean;
+var
+ i,j: longint;
+ exList: array[0..3] of tLongintArray;
+ psThreads: array of tPhaseShiftThread;
+ stuecke: array of array[boolean,boolean] of longint;
+ erledigt: array of boolean;
+ b1,b2: boolean;
begin
for i:=0 to length(inPuls)-2 do
if inPuls[i+1]['x']<=inPuls[i]['x'] then
@@ -374,7 +398,8 @@ begin
j:=0;
while (j<length(erledigt)) and erledigt[j] do
inc(j);
- if j>=length(erledigt) then continue;
+ if j>=length(erledigt) then
+ continue;
psThreads[i]:=
tPhaseShiftThread.create(
@inPuls,
@@ -389,14 +414,16 @@ begin
end;
b1:=false;
end;
- if not b1 then sleep(100);
+ if not b1 then
+ sleep(100);
for i:=0 to length(erledigt)-1 do
b1:=b1 and erledigt[i];
until b1;
end;
procedure smoothen(var dat: tExtPointArray; width: longint);
-var i,j: longint;
+var
+ i,j: longint;
begin
for i:=0 to length(dat)-width do begin
for j:=1 to width-1 do
@@ -412,13 +439,15 @@ begin
end;
procedure sort(var dat: tExtPointArray; start, stop, threads: longint);
-var sortThreads: array of tSortThread;
- i,j,k: longint;
- fertig: boolean;
- apos,epos: array of longint;
- tmp: tExtPointArray;
+var
+ sortThreads: array of tSortThread;
+ i,j,k: longint;
+ fertig: boolean;
+ apos,epos: array of longint;
+ tmp: tExtPointArray;
begin
- if start>=stop then exit;
+ if start>=stop then
+ exit;
if threads=1 then begin
sort(dat,start,(start+stop) div 2,threads);
sort(dat,(start+stop) div 2 + 1,stop,threads);
@@ -463,9 +492,11 @@ begin
fertig:=true;
j:=-1;
for i:=0 to length(apos)-1 do begin
- if apos[i]>epos[i] then continue;
+ if apos[i]>epos[i] then
+ continue;
fertig:=false;
- if (j=-1) or (dat[apos[i]]['x']<dat[apos[j]]['x']) then j:=i;
+ if (j=-1) or (dat[apos[i]]['x']<dat[apos[j]]['x']) then
+ j:=i;
end;
if not fertig then begin
tmp[k]:=dat[apos[j]];
@@ -479,9 +510,11 @@ begin
end;
procedure cut(var dat: tExtPointArray; tmax: extended);
-var i: longint;
+var
+ i: longint;
begin
- if tmax<0 then exit;
+ if tmax<0 then
+ exit;
i:=0;
while (i<length(dat)) and (dat[i]['x']<tmax) do
inc(i);
@@ -507,9 +540,10 @@ begin
end;
procedure filtereExtrema(const dat: tExtPointArray; var extrema: tLongintArray; sollAbst, toleranz: extended);
-var mitte,i,j,k: longint;
- mx,dist: extended;
- behalten: array of boolean;
+var
+ mitte,i,j,k: longint;
+ mx,dist: extended;
+ behalten: array of boolean;
begin
setlength(behalten,length(extrema));
for i:=0 to length(behalten)-1 do
@@ -547,9 +581,10 @@ begin
end;
procedure monotonieHerstellen(const dat: tExtPointArray; var minima,maxima: tLongintArray);
-var i,j,k: longint;
- b: boolean;
- behalten: array[boolean] of array of Boolean;
+var
+ i,j,k: longint;
+ b: boolean;
+ behalten: array[boolean] of array of Boolean;
begin
setlength(behalten[false],length(maxima));
setlength(behalten[true],length(minima));
@@ -607,16 +642,21 @@ begin
end;
procedure gesamtverschiebung(var inPuls,outPuls: tExtPointArray; var absShift: extended);
-var iMax,oMax,i: longint;
+var
+ iMax,oMax,i: longint;
begin
iMax:=0;
for i:=1 to length(inPuls)-1 do
- if inPuls[i]['y']>inPuls[iMax]['y'] then iMax:=i;
+ if inPuls[i]['y']>inPuls[iMax]['y'] then
+ iMax:=i;
oMax:=0;
for i:=1 to length(outPuls)-1 do
- if outPuls[i]['y']>outPuls[oMax]['y'] then oMax:=i;
- if absShift<-0.9e9 then absShift:=outPuls[oMax]['x']-inPuls[iMax]['x']
- else absShift:=(outPuls[oMax]['x']-inPuls[iMax]['x'])-round((outPuls[oMax]['x']-inPuls[iMax]['x'])-absShift);
+ if outPuls[i]['y']>outPuls[oMax]['y'] then
+ oMax:=i;
+ if absShift<-0.9e9 then
+ absShift:=outPuls[oMax]['x']-inPuls[iMax]['x']
+ else
+ absShift:=(outPuls[oMax]['x']-inPuls[iMax]['x'])-round((outPuls[oMax]['x']-inPuls[iMax]['x'])-absShift);
for i:=0 to length(outPuls)-1 do
outPuls[i]['x']:=outPuls[i]['x']-absShift;
@@ -655,7 +695,8 @@ var
i: longint;
begin
bound:=abs(bound);
- if dist<1 then dist:=1;
+ if dist<1 then
+ dist:=1;
setlength(outdat,length(indat)-dist);
for i:=0 to length(outdat)-1 do begin
outdat[i]['x']:=(indat[i+dist]['x']+indat[i]['x'])/2;
@@ -669,8 +710,9 @@ begin
end;
procedure removeLinearOffset(var dat: tExtPointArray);
-var i: longint;
- d: tExtPoint;
+var
+ i: longint;
+ d: tExtPoint;
begin
d:=extPoint(0,0);
for i:=0 to 99 do
@@ -686,16 +728,18 @@ begin
end;
procedure flip(var dat: tExtPointArray);
-var i: longint;
+var
+ i: longint;
begin
for i:=0 to length(dat)-1 do
dat[i]['y']:=-dat[i]['y'];
end;
procedure vereineExtrema(const dat1,dat2: tExtPointArray; var el1,el2: tLongintArray; toleranz: extended);
-var i,j,k: longint;
- b: boolean;
- behalten: array[boolean] of array of boolean;
+var
+ i,j,k: longint;
+ b: boolean;
+ behalten: array[boolean] of array of boolean;
begin
setlength(behalten[false],length(el1));
setlength(behalten[true],length(el2));
@@ -732,16 +776,20 @@ begin
end;
procedure uniq(var dat: tExtPointArray; streng: boolean);
-var i,j,k: longint;
- tmp: extended;
- s: string;
+var
+ i,j,k: longint;
+ tmp: extended;
+ s: string;
begin
write(stderr,'Dopplungen entfernen ...');
j:=0;
k:=0;
tmp:=0;
for i:=0 to length(dat)-1 do begin
- if (i<length(dat)-1) and (dat[i]['x']=dat[i+1]['x']) and ((dat[i]['y']=dat[i+1]['y']) or not streng) then begin
+ if (i<length(dat)-1) and
+ (dat[i]['x']=dat[i+1]['x']) and
+ ((dat[i]['y']=dat[i+1]['y']) or
+ not streng) then begin
inc(k);
tmp:=tmp+dat[i]['y'];
continue;
@@ -752,21 +800,24 @@ begin
k:=0;
tmp:=0;
end
- else dat[j]:=dat[i];
+ else
+ dat[j]:=dat[i];
inc(j);
end;
s:=floattostr(round(100*(length(dat)-j)/length(dat)*10)/10);
- if pos('.',s)>0 then delete(s,pos('.',s)+2,length(s));
+ if pos('.',s)>0 then
+ delete(s,pos('.',s)+2,length(s));
writeln(stderr,' fertig (es gab '+inttostr(length(dat)-j)+' Dopplungen - etwa '+s+'%)');
setlength(dat,j);
end;
procedure fft(var dat: tExtPointArray; out datArg: tExtPointArray);
-var i,j,k,n,dist,absch,wnum,wstep,haL: longint;
- in0,out0: boolean;
- wRe,wIm: tExtendedArray;
- t1,t2,vorher,nachher,fstep,pvFehler: extended;
- umsortierung: tLongintArray;
+var
+ i,j,k,n,dist,absch,wnum,wstep,haL: longint;
+ in0,out0: boolean;
+ wRe,wIm: tExtendedArray;
+ t1,t2,vorher,nachher,fstep,pvFehler: extended;
+ umsortierung: tLongintArray;
begin
write(stderr,'FFT ('+inttostr(length(dat))+') ... ');
fstep:=dat[1]['x']-dat[0]['x'];
@@ -861,18 +912,23 @@ begin
for i:=0 to 2*haL-1 do
nachher:=nachher + dat[i]['y'];
- if (nachher=0) and (vorher=0) then pvFehler:=0
- else pvFehler:=abs(nachher-vorher)/(nachher+vorher);
+ if (nachher=0) and (vorher=0) then
+ pvFehler:=0
+ else
+ pvFehler:=abs(nachher-vorher)/(nachher+vorher);
writeln(stderr,' fertig (Parseval-Fehler = '+floattostr(pvFehler)+' ... nämlich von '+floattostr(vorher)+' zu '+floattostr(nachher)+')');
- if in0 then writeln(stderr,'Nur Nullen im Input der FFT!');
- if out0 then writeln(stderr,'Nur Nullen im Output der FFT!');
+ if in0 then
+ writeln(stderr,'Nur Nullen im Input der FFT!');
+ if out0 then
+ writeln(stderr,'Nur Nullen im Output der FFT!');
end;
procedure interpoliere(var dat: tExtPointArray);
-var i,j: longint;
- tmp,xLen: extended;
- tdat: tExtPointArray;
+var
+ i,j: longint;
+ tmp,xLen: extended;
+ tdat: tExtPointArray;
begin
tmp:=0;
xLen:=dat[length(dat)-1]['x']-dat[0]['x'];
@@ -902,23 +958,28 @@ begin
end;
procedure normiere(var dat: tExtPointArray);
-var i: longint;
- m: extended;
+var
+ i: longint;
+ m: extended;
begin
- if length(dat)=0 then exit;
+ if length(dat)=0 then
+ exit;
m:=dat[0]['y'];
for i:=1 to length(dat)-1 do
m:=max(m,dat[i]['y']);
- if m=0 then exit;
+ if m=0 then
+ exit;
for i:=0 to length(dat)-1 do
dat[i]['y']:=dat[i]['y']/m;
end;
procedure berechneRefPuls(inPuls,surTraj: tExtPointArray; betaGlaette: longint; betaBound: extended; out cRefPuls: tExtPointArray);
-var iSur,iIn,anz: longint;
- beta,frac: extended;
+var
+ iSur,iIn,anz: longint;
+ beta,frac: extended;
begin
- if betaGlaette<1 then betaGlaette:=1;
+ if betaGlaette<1 then
+ betaGlaette:=1;
setlength(cRefPuls,0);
anz:=0;
iIn:=0;
@@ -928,7 +989,8 @@ begin
continue;
while (iIn<length(inPuls)-1) and (inPuls[iIn+1]['x']<=surTraj[iSur]['x']-surTraj[iSur]['y']) do
inc(iIn);
- if iIn>=length(inPuls)-1 then break;
+ if iIn>=length(inPuls)-1 then
+ break;
if anz>=length(cRefPuls) then
setlength(cRefPuls,anz+32768);
@@ -970,8 +1032,9 @@ end;
// tPhaseShiftThread ***********************************************************
constructor tPhaseShiftThread.create(p1d,p2d: pTExtPointArray; sta1, sto1, sta2, sto2: longint; absShift: extended);
-var i: longint;
- b: boolean;
+var
+ i: longint;
+ b: boolean;
begin
inherited create(true);
_starts[false]:=sta1;
@@ -996,9 +1059,10 @@ begin
end;
procedure tPhaseShiftThread.execute;
-var i,j,offset: longint;
- b: boolean;
- t1,t2,t3,bestErr,bestPos: extended;
+var
+ i,j,offset: longint;
+ b: boolean;
+ t1,t2,t3,bestErr,bestPos: extended;
begin
for b:=false to true do begin // normieren (auf 0..1)
t1:=0;
@@ -1015,7 +1079,8 @@ begin
offset:=byte(b)*(_stops[false]-_starts[false]+1);
for i:=0 to _stops[b]-_starts[b] do begin
_ergebnis[offset + i]['x']:=_dats[b,i]['x'];
- if (i=0) then bestPos:=_dats[not b,0]['x']
+ if (i=0) then
+ bestPos:=_dats[not b,0]['x']
else begin
t1:=_dats[b,i]['y'];
j:=0; // floor(_ergebnis[offset + i - 1]['y']); <- das war Murks
generated by cgit v1.2.3-54-g00ecf (git 2.44.0) at 2024-05-06 00:51:39 +0000