exprToBool neu in matheunit.pas

1 files changed, 172 insertions, 0 deletions

diff --git a/matheunit.pas b/matheunit.pas
index c728d29..f34f2b3 100644
--- a/matheunit.pas
+++ b/matheunit.pas
@@ -47,6 +47,7 @@ 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; kvs: tKnownValues; cbgv: tCallBackGetValue): extended;
+function exprToBool(st: boolean; s: string; kvs: tKnownValues; cbgv: tCallBackGetValue): boolean;
 function formelnAuswerten(s: string; kvs: tKnownValues; cbgv: tCallBackGetValue): string;
 function knownValue(nam: string; val: extended): tKnownValue;
 
@@ -538,6 +539,177 @@ begin
   result:=result*(2*byte(not neg)-1);
 end;
 
+function simpleExprToBool(st: boolean; s: string; kvs: tKnownValues; cbgv: tCallBackGetValue): boolean;
+var
+  i: longint;
+  t: string;
+const
+  binOps: array[0..12] of string =
+    ('<=','>=','<>','≤','≥','=','≠','<','>',' in ','∈',' notIn ','∉');
+begin
+  s:=trim(s);
+  while (leftStr(s,1)='(') and (rightStr(s,1)=')') do
+    s:=trim(copy(s,2,length(s)-2));
+
+  if uppercase(s)='TRUE' then begin
+    result:=true;
+    exit;
+  end;
+  if uppercase(s)='FALSE' then begin
+    result:=false;
+    exit;
+  end;
+
+  for i:=0 to length(binOps)-1 do
+    if pos(binOps[i],s)>0 then begin
+      t:=erstesArgument(s,binOps[i]);
+      case binOps[i] of
+        '≤','<=': result:=exprtofloat(st,t,kvs,cbgv)<=exprtofloat(st,s,kvs,cbgv);
+        '≥','>=': result:=exprtofloat(st,t,kvs,cbgv)>=exprtofloat(st,s,kvs,cbgv);
+        '=':
+          try
+            result:=exprtofloat(st,t,kvs,cbgv)=exprtofloat(st,s,kvs,cbgv);
+          except
+            result:=t=s;
+          end;
+        '≠','<>':
+          try
+            result:=exprtofloat(st,t,kvs,cbgv)<>exprtofloat(st,s,kvs,cbgv);
+          except
+            result:=t<>s;
+          end;
+        '<': result:=exprtofloat(st,t,kvs,cbgv)<exprtofloat(st,s,kvs,cbgv);
+        '>': result:=exprtofloat(st,t,kvs,cbgv)>exprtofloat(st,s,kvs,cbgv);
+        ' in ','∈': begin
+          result:=false;
+          while (s<>'') and not result do
+            result:=erstesArgument(s)=t;
+        end;
+        ' notIn ','∉': begin
+          result:=true;
+          while (s<>'') and result do
+            result:=erstesArgument(s)<>t;
+        end;
+        else
+          fehler('Operator '''+binOps[i]+''' ist nicht implementiert!');
+      end{of case};
+      exit;
+    end;
+  fehler(''''+s+''' ist kein gültiger logischer Ausdruck!');
+end;
+
+function exprToBool(st: boolean; s: string; kvs: tKnownValues; cbgv: tCallBackGetValue): boolean;
+var
+  i,j,anz:       longint;
+  operatoren,
+  ausdruecke:    tIntPointArray;
+  werte:         tBooleanArray;
+  klammernZahl:  tLongintArray;
+const
+  logOpsNamen: array[0..6] of string =
+    ('not ',' and ','&&',' or ','||',' xor ',' equiv ');
+  logOpsAktionen: array[0..6,boolean,boolean] of boolean =
+    (((true,false),(true,false)),  // not (1. Argument ignoriert!)
+     ((false,false),(false,true)), // and
+     ((false,false),(false,true)), // &&
+     ((false,true),(true,true)),   // or
+     ((false,true),(true,true)),   // ||
+     ((false,true),(true,false)),  // xor
+     ((true,false),(false,true))); // equiv
+
+begin
+  i:=1;
+  setlength(operatoren,0);
+  while i<=length(s) do begin
+    for j:=0 to length(logOpsNamen)-1 do
+      if copy(s,i,length(logOpsNamen[j]))=logOpsNamen[j] then begin
+        setlength(operatoren,length(operatoren)+1);
+        operatoren[length(operatoren)-1,'x']:=j;
+        operatoren[length(operatoren)-1,'y']:=i;
+        i:=i+length(logOpsNamen[j]);
+        break;
+      end;
+    inc(i);
+  end;
+
+  setlength(ausdruecke,length(operatoren)+1);
+  setlength(klammernZahl,length(operatoren)+1);
+
+  for i:=0 to length(ausdruecke)-1 do begin
+    if i=0 then
+      ausdruecke[i,'x']:=1
+    else
+      ausdruecke[i,'x']:=operatoren[i-1,'y']+length(logOpsNamen[operatoren[i-1,'x']]);
+    if i=length(operatoren) then
+      ausdruecke[i,'y']:=length(s)
+    else
+      ausdruecke[i,'y']:=operatoren[i,'y']-1;
+
+    anz:=0;
+    for j:=ausdruecke[i,'x'] to ausdruecke[i,'y'] do
+      if s[j]='(' then
+        inc(anz)
+      else if s[j]=')' then
+        dec(anz);
+
+    klammernZahl[i]:=anz;
+
+    while (anz<0) and (ausdruecke[i,'y']>=ausdruecke[i,'x']) do begin // zu viele schließende Klammern (am rechten Rand)
+      if s[ausdruecke[i,'y']]=')' then
+        inc(anz);
+      dec(ausdruecke[i,'y']);
+    end;
+    while (anz>0) and (ausdruecke[i,'y']>=ausdruecke[i,'x']) do begin // zu viele öffnende Klammern (am linken Rand)
+      if s[ausdruecke[i,'x']]='(' then
+        dec(anz);
+      inc(ausdruecke[i,'x']);
+    end;
+    if (ausdruecke[i,'y']<ausdruecke[i,'x']) and ((i=length(operatoren)) or (operatoren[i,'x']<>0)) then // das linke Argument von "not" darf leer sein
+      fehler('Klammerfehler in '''+s+''' ('+inttostr(ausdruecke[i,'y'])+'<'+inttostr(ausdruecke[i,'x'])+')!');
+  end;
+
+  anz:=0;
+  for i:=0 to length(klammernZahl)-1 do begin
+    anz:=anz+klammernZahl[i];
+    if anz<0 then
+      fehler('zu viele oder zu zeitige schließende Klammern in '''+s+'''!');
+  end;
+  if anz<>0 then
+    fehler('Klammern in '''+s+''' sind nicht ausgeglichen!');
+
+  setlength(werte,length(ausdruecke));
+  for i:=0 to length(werte)-1 do
+    if (i=length(werte)-1) or (operatoren[i,'x']<>0) then // kein linkes Argument von "not"
+      werte[i]:=simpleExprToBool(st,copy(s,ausdruecke[i,'x'],ausdruecke[i,'y']-ausdruecke[i,'x']+1),kvs,cbgv)
+    else
+      werte[i]:=false;
+  setlength(ausdruecke,0);
+  i:=length(werte)-2;
+  while i>=0 do
+    if ((klammernZahl[i]>0) or (i=0)) and (klammernZahl[i+1]<=0) then begin
+      result:=true;
+      werte[i]:=logOpsAktionen[operatoren[i,'x'],werte[i],werte[i+1]];
+      klammernZahl[i]:=klammernZahl[i]+klammernZahl[i+1];
+      for j:=i+1 to length(operatoren)-1 do
+        operatoren[j-1]:=operatoren[j];
+      for j:=i+2 to length(werte)-1 do begin
+        werte[j-1]:=werte[j];
+        klammernZahl[j-1]:=klammernZahl[j];
+      end;
+      setlength(operatoren,length(operatoren)-1);
+      setlength(werte,length(werte)-1);
+      setlength(klammernZahl,length(klammernZahl)-1);
+      if i>length(werte)-2 then
+        dec(i);
+    end
+    else
+      dec(i);
+  if length(werte)<>1 then
+    fehler('Kann kein Paar von öffnenden und schließenden Klammern in '''+s+''' mehr finden - das sollte eigentlich nicht passieren können!');
+
+  result:=werte[0];
+end;
+
 function formelnAuswerten(s: string; kvs: tKnownValues; cbgv: tCallBackGetValue): string;
 var
   i,start,mitte,