exprtofloat aus ../epost/*.pas uebernommen

2 files changed, 174 insertions, 17 deletions

diff --git a/lowlevelunit.pas b/lowlevelunit.pas
index 8fc6fa0..4e8652d 100644
--- a/lowlevelunit.pas
+++ b/lowlevelunit.pas
@@ -34,6 +34,11 @@ type
   tKodierung = (kUnbekannt,k32BitSignedInteger);
   tWarnstufe = (wsStreng,wsLasch);
   tGenauigkeit = (gSingle,gExtended);
+  tKnownValue = record
+    name:  string;
+    value: extended;
+  end;
+  tKnownValueArray = array of tKnownValue;
 
 function signSqr(x: extended): extended; inline;
 function mpfToStr(f: mpf_t): string;
diff --git a/matheunit.pas b/matheunit.pas
index 3049ca5..6df1e83 100644
--- a/matheunit.pas
+++ b/matheunit.pas
@@ -5,17 +5,11 @@ unit matheunit;
 interface
 
 uses
-  Classes, SysUtils, Gmp, Math;
+  Classes, SysUtils, Gmp, Math, lowlevelunit;
 
 type
-  tExtPoint = record
-    x,y: extended;
-  end;
-  tExtPointArray = array of tExtPoint;
-  pTExtPointArray = ^tExtPointArray;
-  tLongintArray = array of longint;
-  pTLongintArray = ^tLongintArray;
-  tExtendedArray = array of extended;
+  tCallBackGetValue = function(name: string): extended of object;
+  tExprToFloat = function(syntaxtest: boolean; name: string): extended of object;
 
 function plus(a,b: tExtPoint): tExtPoint;
 function durch(a: tExtPoint; b: extended): tExtPoint;
@@ -32,19 +26,25 @@ procedure copyArray(i: tExtPointArray; out o: tExtPointArray); overload;
 procedure copyArray(i: tLongintArray; out o: tLongintArray); overload;
 procedure copyArray(i: tExtendedArray; out o: tExtendedArray); overload;
 function nullfunktion(x: extended): extended;
+function exprtofloat(st: boolean; s: string; cbgv: tCallBackGetValue): extended; overload;
+function exprtofloat(st: boolean; s: string; kvs: tKnownValueArray; cbgv: tCallBackGetValue): extended; overload;
 
 implementation
 
 function plus(a,b: tExtPoint): tExtPoint;
+var
+  c: char;
 begin
-  result.x:=a.x+b.x;
-  result.y:=a.y+b.y;
+  for c:='x' to 'y' do
+    result[c]:=a[c]+b[c];
 end;
 
 function durch(a: tExtPoint; b: extended): tExtPoint;
+var
+  c: char;
 begin
-  result.x:=a.x/b;
-  result.y:=a.y/b;
+  for c:='x' to 'y' do
+    result[c]:=a[c]/b;
 end;
 
 function myFrac(x: extended): extended;
@@ -225,12 +225,12 @@ end;
 procedure copyArray(i: tExtPointArray; out o: tExtPointArray);
 var
   j: longint;
+  c: char;
 begin
   setlength(o,length(i));
-  for j:=0 to length(o)-1 do begin
-    o[j].x:=i[j].x;
-    o[j].y:=i[j].y;
-  end;
+  for j:=0 to length(o)-1 do
+    for c:='x' to 'y' do
+      o[j,c]:=i[j,c];
 end;
 
 procedure copyArray(i: tLongintArray; out o: tLongintArray);
@@ -256,5 +256,157 @@ begin
   result:=0*x;
 end;
 
+function exprtofloat(st: boolean; s: string; cbgv: tCallBackGetValue): extended;
+var
+  kvs: tKnownValueArray;
+begin
+  setlength(kvs,0);
+  result:=exprtofloat(st,s,kvs,cbgv);
+end;
+
+function exprtofloat(st: boolean; s: string; kvs: tKnownValueArray; cbgv: tCallBackGetValue): extended;
+var i,j,k,l,m:   longint;
+    inv,neg,cbv: boolean;
+    val1,val2:   extended;
+const
+    fkt1: array[0..5] of string = ('exp','sin','cos','tan','sqr','sqrt');
+    fkt2: array[0..1] of string = ('min','max');
+begin
+  s:=trimAll(s);
+
+  for i:=0 to length(fkt1)-1 do
+    while fktpos(fkt1[i],s)>0 do begin
+      j:=fktpos(fkt1[i],s)+length(fkt1[i]);
+      while (j<=length(s)) and (s[j]<>'(') do
+        inc(j);
+      m:=j+1;                // erstes Zeichen innerhalb der Klammern
+      k:=1;
+      while (j<length(s)) and (k>0) do begin
+        inc(j);
+        case s[j] of
+          '(': inc(k);
+          ')': dec(k);
+        end;
+      end;
+      k:=fktpos(fkt1[i],s); // erstes Zeichen des Funktionsnamens
+      val1:=exprtofloat(st,copy(s,m,j-m),cbgv);
+      case i of
+        0: val1:=exp(val1);
+        1: val1:=sin(val1);
+        2: val1:=cos(val1);
+        3: val1:=tan(val1);
+        4: val1:=sqr(val1);
+        5: val1:=sqrt(val1);
+      end{of case};
+      s:=copy(s,1,k-1) + floattostr(val1) + copy(s,j+1,length(s));
+    end;
+
+  for i:=0 to length(fkt2)-1 do
+    while fktpos(fkt2[i],s)>0 do begin
+      j:=fktpos(fkt2[i],s)+length(fkt2[i]);
+      while (j<=length(s)) and (s[j]<>'(') do
+        inc(j);
+      m:=j+1;                // erstes Zeichen innerhalb der Klammern
+      k:=1;
+      l:=-1;
+      while (j<length(s)) and (k>0) do begin
+        if (k=1) and (s[j] in [',',';']) then
+          l:=j;              // das Komma/Semikolon
+        inc(j);
+        case s[j] of
+          '(': inc(k);
+          ')': dec(k);
+        end;
+      end;
+      k:=fktpos(fkt1[i],s); // erstes Zeichen des Funktionsnamens
+      val1:=exprtofloat(st,copy(s,m,l-m),cbgv);
+      val2:=exprtofloat(st,copy(s,l+1,j-l-1),cbgv);
+      case i of
+        0: val1:=min(val1,val2);
+        1: val1:=max(val1,val2);
+      end{of case};
+      s:=copy(s,1,k-1) + floattostr(val1) + copy(s,j+1,length(s));
+    end;
+
+  while pos('(',s)>0 do begin
+    i:=pos('(',s);
+    j:=1;
+    while j>0 do begin
+      inc(i);
+      case s[i] of
+        '(': inc(j);
+        ')': dec(j);
+      end;
+    end;
+    s:=copy(s,1,pos('(',s)-1)+
+       floattostr(exprtofloat(st,copy(s,pos('(',s)+1,i-pos('(',s)-1),cbgv))+
+       copy(s,i+1,length(s)-i);
+  end;
+  if (binOpPos('+',s)>0) or (binOpPos('-',s)>0) then begin
+    result:=0;
+    inv:=false;
+    repeat
+      i:=min(binOpPos('+',s),binOpPos('-',s));
+      if i=0 then i:=max(binOpPos('+',s),binOpPos('-',s));
+      if i=0 then i:=length(s)+1;
+      if inv then result:=result-exprtofloat(st,copy(s,1,i-1),cbgv)
+             else result:=result+exprtofloat(st,copy(s,1,i-1),cbgv);
+      inv:=s[i-byte(i>length(s))]='-';
+      delete(s,1,i);
+    until s='';
+    exit;
+  end;
+  if (binOpPos('*',s)>0) or (binOpPos('/',s)>0) then begin
+    result:=1;
+    inv:=false;
+    repeat
+      i:=min(binOpPos('*',s),binOpPos('/',s));
+      if i=0 then i:=max(binOpPos('*',s),binOpPos('/',s));
+      if i=0 then i:=length(s)+1;
+      if inv then result:=result/exprtofloat(st,copy(s,1,i-1),cbgv)
+             else result:=result*exprtofloat(st,copy(s,1,i-1),cbgv);
+      inv:=s[i-byte(i>length(s))]='/';
+      delete(s,1,i);
+    until s='';
+    exit;
+  end;
+  if binOpPos('^',s)>0 then begin
+    i:=binOpPos('^',s);
+    result:=power(exprtofloat(st,copy(s,1,i-1),cbgv),
+                  exprtofloat(st,copy(s,i+1,length(s)-i),cbgv));
+    exit
+  end;
+  neg:=startetMit('-',s);
+  cbv:=false;
+  for i:=1 to length(s) do
+    cbv:=cbv or not (s[i] in ['0'..'9','.',',','e','E']);
+  if not cbv then result:=strtofloat(s)
+  else begin
+    result:=nan;
+    for i:=0 to length(kvs)-1 do
+      if kvs[i].name=s then begin
+        result:=kvs[i].value;
+        break;
+      end;
+    if isNan(result) then begin
+      if st then result:=1
+      else if assigned(cbgv) then result:=cbgv(s);
+    end;
+  end;
+(*   if s='np' then result:=params.np
+  else if s='maxw' then result:=params.maxW
+  else if s='minw' then result:=params.minW
+  else if s='beta' then result:=params.beta
+  else if s='xstart' then result:=params.xstart
+  else if s='xstop' then result:=params.xstop
+  else if s='tstart' then result:=params.tstart
+  else if s='tstop' then result:=params.tstop
+  else if st then result:=1
+  else if assigned(cbgv) then result:=cbgv(s)
+  else result:=nan; *)
+
+  result:=result*(2*byte(not neg)-1);
+end;
+
 end.