tKontur.erzeugeAusFunktion neu

1 files changed, 190 insertions, 2 deletions

diff --git a/epostunit.pas b/epostunit.pas
index 9ffa44a..32cccfd 100644
--- a/epostunit.pas
+++ b/epostunit.pas
@@ -69,6 +69,7 @@ type
     function init(st: boolean; var f: tMyStringlist; w: pTWerteArray; mt: longint): boolean;
     function liesVonDatei(st: boolean; s: string; xmi,xma,tmi,tma: extended): boolean;
     function erzeugeAusWerten(st: boolean; s: string; w: pTWerteArray; mt: longint; _xmin,_xmax,_tmin,_tmax: string): boolean;
+    function erzeugeAusFunktion(st: boolean; s: string; xmi,xma,tmi,tma,dx,dt: extended; mt: longint): boolean;
     property xmin: extended read rxmin;
     property xmax: extended read rxmax;
     property tmin: extended read rtmin;
@@ -4997,8 +4998,8 @@ end;
 
 function tKontur.init(st: boolean; var f: tMyStringlist; w: pTWerteArray; mt: longint): boolean;
 var
-  s,xmi,xma,tmi,tma: string;
-  i,j,k,tmpi:        longint;
+  s,xmi,xma,tmi,tma,dx,dt: string;
+  i,j,k,tmpi:              longint;
 begin
   result:=false;
   gibAus('Kontur erzeugen ...',1);
@@ -5006,6 +5007,8 @@ begin
   xma:='1e9';
   tmi:='-1e9';
   tma:='1e9';
+  dx:='1';
+  dt:='1';
   repeat
     if not f.metaReadln(s,true) then begin
       gibAus('Unerwartetes Dateiende in '''+paramstr(1)+'''!',3);
@@ -5060,6 +5063,14 @@ begin
       tma:=s;
       continue;
     end;
+    if startetMit('dx:',s) then begin
+      dx:=s;
+      continue;
+    end;
+    if startetMit('dy:',s) or startetMit('dt:',s) then begin
+      dt:=s;
+      continue;
+    end;
     if startetMit('reduziere nach ',s) then begin
       if not st then
         if not sortiere_nach_y(mt) then exit;
@@ -5098,6 +5109,20 @@ begin
       gibAus('Richtung '''+s+''' ist mir unbekannt zum Reduzieren einer Kontur!',3);
       exit;
     end;
+    if startetMit('Funktion:',s) then begin
+      if not erzeugeAusFunktion(
+               st,
+               s,
+               exprtofloat(st,xmi,nil),
+               exprtofloat(st,xma,nil),
+               exprtofloat(st,tmi,nil),
+               exprtofloat(st,tma,nil),
+               exprtofloat(st,dx,nil),
+               exprtofloat(st,dt,nil),
+               mt) then
+        exit;
+      continue;
+    end;
     if s='Ende' then break;
     gibAus('Verstehe Option '''+s+''' nicht beim Einlesen/Berechnen einer Kontur!',3);
     exit;
@@ -5194,6 +5219,169 @@ begin
   result:=true;
 end;
 
+function tKontur.erzeugeAusFunktion(st: boolean; s: string; xmi,xma,tmi,tma,dx,dt: extended; mt: longint): boolean;
+var
+  xf,yf:        string;
+  kvs:          tKnownValues;
+  pOrte:        array of array[0..2] of extended;
+  baustellen:   array of tIntPoint;
+  lenPO,lenB,i: longint;
+
+procedure berechnePOrt(i: longint); inline;
+begin
+  kvs.add(s,pOrte[i,0]);
+  pOrte[i,1]:=exprToFloat(st,xf,kvs);
+  pOrte[i,2]:=exprToFloat(st,yf,kvs);
+end;
+
+function pOIndexInnerhalb(i: longint): boolean; inline;
+begin
+  result:=(i>=0) and (i<lenPO);
+end;
+
+function liegtInnerhalb(i: longint): boolean; inline;
+begin
+  result:=pOIndexInnerhalb(i) and (pOrte[i,1]>=xmi) and (pOrte[i,1]<=xma) and (pOrte[i,2]>=tmi) and (pOrte[i,2]<=tma);
+end;
+
+function punkteFastGleich(i1,i2: longint): boolean; inline;
+begin
+  result:=
+    pOIndexInnerhalb(i1) and
+    pOIndexInnerhalb(i2) and
+    (abs(round(pOrte[i1,1]/dx)-round(pOrte[i2,1]/dx))<=1) and
+    (abs(round(pOrte[i1,2]/dt)-round(pOrte[i2,2]/dt))<=1);
+end;
+
+function baustelleUeberfluessig(i: longint): boolean; inline;
+begin
+  result:=
+    punkteFastGleich(baustellen[i,'x'],baustellen[i,'y']);
+end;
+
+procedure dumpStand;
+var
+  i: longint;
+begin
+  writeln('****** dumpStand ******');
+  writeln('pOrte: ('+inttostr(lenPO)+')');
+  for i:=0 to lenPO-1 do
+    writeln(inttostr(i)+': '+floattostr(pOrte[i,0])+' -> ('+floattostr(pOrte[i,1])+';'+floattostr(pOrte[i,2])+')');
+  writeln('baustellen: ('+inttostr(lenB)+')');
+  for i:=0 to lenB-1 do
+    writeln(inttostr(i)+': '+floattostr(baustellen[i,'x'])+';'+floattostr(baustellen[i,'y']));
+  writeln('***********************');
+end;
+
+begin
+  result:=false;
+  xf:=erstesArgument(s,';');
+  yf:=erstesArgument(s,';');
+
+  kvs:=tKnownValues.create;
+
+  lenPO:=1;
+  setlength(pOrte,speicherHappen);
+  pOrte[0,0]:=0;
+
+  berechnePOrt(0);
+
+  if st then begin
+    result:=true;
+    kvs.free;
+    setlength(pOrte,0);
+    exit;
+  end;
+
+  if not liegtInnerhalb(0) then begin
+    gibAus('Die Funktionen '''+xf+''' bzw. '''+yf+''' erzeugen für '''+s+'''=0 keinen Punkt innerhalb der Grenzen ('+floattostr(xmi)+'..'+floattostr(xma)+' x '+floattostr(tmi)+'..'+floattostr(tma)+')!',3);
+    kvs.free;
+    setlength(pOrte,0);
+    exit;
+  end;
+
+  lenB:=2;
+  setlength(baustellen,speicherHappen);
+  baustellen[0,'x']:=low(longint);
+  baustellen[0,'y']:=0;
+  baustellen[1,'x']:=0;
+  baustellen[1,'y']:=high(longint);
+
+  while lenB>0 do begin
+    if baustelleUeberfluessig(lenB-1) then begin
+      dec(lenB);
+      continue;
+    end;
+    if length(baustellen)<=lenB+1 then
+      setlength(baustellen,lenB+speicherHappen);
+    if length(pOrte)<=lenPO+2 then
+      setlength(pOrte,lenPO+speicherHappen);
+
+    inc(lenPO);
+    if baustellen[lenB-1,'x']=low(longint) then
+      pOrte[lenPO-1,0]:=pOrte[baustellen[lenB-1,'y'],0]-1
+    else if baustellen[lenB-1,'y']=high(longint) then
+      pOrte[lenPO-1,0]:=pOrte[baustellen[lenB-1,'x'],0]+1
+    else
+      pOrte[lenPO-1,0]:=(pOrte[baustellen[lenB-1,'x'],0] + pOrte[baustellen[lenB-1,'y'],0])/2;
+    berechnePOrt(lenPO-1);
+    case 4*byte(liegtInnerhalb(lenPO-1)) + 2*byte(liegtInnerhalb(baustellen[lenB-1,'x'])) + byte(liegtInnerhalb(baustellen[lenB-1,'y'])) of
+      3..7: begin // Punkt oder wenigstens beide Grenzen innerhalb  => Baustelle wird vmtl. geteilt
+        baustellen[lenB,'x']:=lenPO-1;
+        baustellen[lenB,'y']:=baustellen[lenB-1,'y'];
+        baustellen[lenB-1,'y']:=lenPO-1;
+        inc(lenB);
+        if baustelleUeberfluessig(lenB-2) then begin
+          baustellen[lenB-2]:=baustellen[lenB-1];
+          dec(lenB);
+        end;
+        if baustelleUeberfluessig(lenB-1) then dec(lenB);
+      end;
+      2: // Punkt und rechte Grenze außerhalb => rechte Grenze auf neuen Punkt verschieben
+        if pOIndexInnerhalb(baustellen[lenB-1,'y']) then begin // rechte Grenze ist real
+          pOrte[baustellen[lenB-1,'y']]:=pOrte[lenPO-1];       // dann wird der Ort verschoben
+          dec(lenPO);                                          // und der alte gelöscht
+        end
+        else                                                   // sonst
+          baustellen[lenB-1,'y']:=lenPO-1;                     // wird nur der Ortsindex verschoben
+      1: // Punkt und linke Grenze außerhalb => linke Grenze auf neuen Punkt verschieben
+        if pOIndexInnerhalb(baustellen[lenB-1,'x']) then begin // linke Grenze ist real
+          pOrte[baustellen[lenB-1,'x']]:=pOrte[lenPO-1];       // dann wird der Ort verschoben
+          dec(lenPO);                                          // und der alte gelöscht
+        end
+        else                                                   // sonst
+          baustellen[lenB-1,'x']:=lenPO-1;                     // wird nur der Ortsindex verschoben
+      0: begin // alles außer Rand und Band => Baustelle und Punkt entfernen
+        dec(lenB);
+        dec(lenPO);
+      end;
+    end{of case};
+  end;
+
+  setlength(orte,lenPO);
+  for i:=0 to lenPO-1 do begin
+    orte[i,'x']:=i;
+    orte[i,'y']:=pOrte[i,0];
+  end;
+
+  if not sortiere_nach_y(mt) then begin
+    setlength(baustellen,0);
+    setlength(pOrte,0);
+    kvs.free;
+    exit;
+  end;
+
+  for i:=0 to lenPO-1 do begin
+    orte[i,'y']:=pOrte[round(orte[i,'x']),2];
+    orte[i,'x']:=pOrte[round(orte[i,'x']),1];
+  end;
+
+  setlength(baustellen,0);
+  setlength(pOrte,0);
+  kvs.free;
+  result:=true;
+end;
+
 function tKontur.sortiere_nach_y(mt: longint): boolean;
 begin
   result:=sortiere_nach_y(mt,0,length(Orte)-1);