1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:
66:
67:
68:
69:
70:
71:
72:
73:
74:
75:
76:
77:
78:
79:
80:
81:
82:
83:
84:
85:
86:
87:
88:
89:
90:
91:
92:
93:
94:
95:
96:
97:
98:
99:
100:
101:
102:
103:
104:
105:
106:
107:
108:
109:
110:
111:
112:
113:
114:
115:
116:
117:
118:
119:
120:
121:
122:
123:
124:
125:
126:
127:
128:
129:
130:
131:
132:
133:
134:
135:
136:
137:
138:
139:
140:
141:
142:
143:
144:
145:
146:
147:
148:
149:
150:
151:
152:
153:
154:
155:
156:
157:
158:
159:
160:
161:
162:
163:
164:
165:
166:
167:
168:
169:
170:
171:
172:
173:
174:
175:
176:
177:
178:
179:
180:
181:
182:
183:
184:
185:
186:
187:
188:
189:
190:
191:
192:
193:
194:
195:
196:
197:
198:
199:
200:
201:
202:
203:
204:
205:
206:
207:
208:
209:
210:
211:
212:
213:
214:
215:
216:
217:

//Allgemeine Funktionen
procedure raise_exception(s: String; errortype: TTermErrorType);  //Fehler ausgabe
begin
ErrorResult.Errortype := errortype;
ErrorResult.EMessage := s;
//exit;
end;

function copyab(const s:string; const i:integer):string;  //Rest von s ab i. em Zeichen
begin
  result:=copy(s,i,length(s)-i+1)
end;

function ohneLeerzeichenf(const s:string):string;    //entfernen der Leerzeichen
begin
   Result := stringreplace(s, ' ', '', [rfReplaceAll]);
end;



//----------- im Parser vorkommende Funktionen -----------------

function hoch(const x:real; n:integer):real; //x^n  n El Z
  begin
    if n<0 then result:=1/hoch(x,-n) else //x^n=1/x^(-n) für n<0
      if n=0 then  result:=1 else
        result:=x*hoch(x,n-1)//rekursiv
  end;


function ArcTan2(Y, X: Extended): Extended;
asm
        FLD     Y
        FLD     X
        FPATAN
        FWAIT
end;

function ArcCos(X: Extended): Extended;
begin
  Result := ArcTan2(Sqrt(1 - X*X), X);
end;

function ArcSin(X: Extended): Extended;
begin
  Result := ArcTan2(X, Sqrt(1 - X*X))
end;


function asn(x:real):real; //arcsin
begin
  result:=0;
  if abs(x-1)<1E-15 then result:=pi/2 else     //asn(1)=Pi/2
    if abs(x+1)<1E-15 then result:=-Pi/2 else  //asn(-1)=-Pi/2
    if x*x<1 then result:=arcsin(x) //siehe unit tttmath
     else Raise_Exception('Fehler beim Berechnen von Arcsin('+floatToStr(x) + ')', teTrigon);
end;

function acs(x:real):real;   //Arccos
begin
 result:=0;
 if abs(x-1)<1E-15 then result:=0 else
   if abs(x+1)<1E-15 then result:=Pi else
     if x*x<1 then result:=arcCos(x) //siehe unit tttmath
     else begin
     Raise_Exception('Fehler beim Berechnen von Arccos('+floatToStr(x) + ')', teTrigon);
     end;
end;

function tan(x:real):real;
begin
 result:=0;
 if cos(x)<>0 then tan:=sin(x)/cos(x)
    else Raise_Exception('Fehler beim Berechnen von Tan('+floatToStr(x) + ')', teTrigon);
end;

function wurzel(x:real):real;
begin
  result:=0;
  if x>=-1E-15 //nicht negativ bis auf Rundungsfehler
    then wurzel:=sqrt(x)
      else begin
     Raise_Exception('Fehler beim Berechnen von Sqrt('+floatToStr(x) + ')', teSqrt);
     end;
end;



//----------------- Es folgt ein Parser ---------------------

FUNCTION TermToReal(s: string;x:real): real; //rekursiv!
                                  // s beliebiger Term ohne wissensch Not
                                  // d.h. 1E-17 nicht erlaubt
    var u,v,p,q: string;
    function e(c:char): boolean; //falls möglich wird s zerlegt in s=u+c+v
            //z.B. s=(5+4)*(3+2) Bei c='+' wird u=(5+4) und v=(3+2). Dann e=true
            //    Bei c='*' wird wegen der Klammern e=false
          var i,k:integer;
      begin k:=0; // k zählt die Klammern
            i:=length(s)+1;
            repeat  dec(i);
              if s[i]=')' then inc(k);
              if s[i]='(' then k:=pred(k)
            until (i=1) or ((k=0) and (s[i]=c));
            if i=1 then Begin
              if k<>0 then begin
                Raise_Exception('Syntaxfehler: zu viele Klammern', teBrackets);
                 exit;  //sofort abbrechen
              end;
              result:=false
            End else Begin
              result:=true;
              u:=copy(s,1,i-1);
              v:=copyab(s,i+1)
            End
      end;
 begin

   result:=0;
   s:=OhneLeerzeichenf(s);      //entfernen der Leerzeichen
   u:=copy(s,1,3);
   v:=copyab(s,4);
   p:=copy(s,1,2);
   q:=copyab(s,3);
   if s='' then Begin result:=0; exit End;
   if s[1]='-' then s:='0'+s; //zB. s='-7/3x+14' -> s='0-7/3x+14'
 try
 {Punkt- vor Strichrechnung und vor Potenzen}
 if e('+') then result:=TermToReal(u,x)+TermToReal(v,x)        else
 if e('-') then result:=TermToReal(u,x)-TermToReal(v,x)        else
 if e('*') then result:=TermToReal(u,x)*TermToReal(v,x)        else
 if e('·') then result:=TermToReal(u,x)*TermToReal(v,x)        else //'·'=#183

 if e('/') or e(':') then Begin
   try result:=TermToReal(u,x)/TermToReal(v,x);
   except Raise_Exception('Division durch Null', teDivbyZero); end
 End else

  if e('^') then result:=hoch(TermToReal(u,x),round(TermToReal(v,x)))  else
  if p='lg' then Begin
    try result:=ln(TermToReal(q,x))/ln(10)
    Except Raise_Exception('Fehler beim Berechnen von Lg('+q + ')', teTrigon); End;
  End else

  if p='ln' then Begin
    try result:=ln(TermToReal(q,x))
    except Raise_Exception('Fehler beim Berechnen von Ln('+q + ')', teTrigon); End
  End else

  if p='lb' then Begin
    try result:=ln(TermToReal(q,x))/ln(2);
    except Raise_Exception('Fehler beim Berechnen von Lb('+q + ')', teTrigon); End
  End else

  if u='sin' then result:=sin(TermToReal(v,x))             else //sin im Bogenmaß
  if u='cos' then result:=cos(TermToReal(v,x))             else //cos im bogenmaß
  if u='si_' then result:=sin(Pi/180*TermToReal(v,x))      else //sin im Gradmaß

  if u='atn' then Begin
    try result:=arctan(TermToReal(v,x));
    except Raise_Exception('Fehler beim Berechnen von Arctan('+ v + '), Bogenmaß', teTrigon); End
  End else

  if u='acs' then result:=asn(TermToReal(v,x)) {Fehler s.o. }else

  if u='acc' then result:=acs(TermToReal(v,x)) {Fehler bei asn }else

  if u='at_' then Begin  //arTan im Gradmaß
    try result:=arctan(TermToReal(v,x))*180/Pi;
    except Raise_Exception('Fehler beim Berechnen von Arctan('+v + '), Gradmaß', teTrigon); End
  End else

  if u='as_' then Begin //arcsin im Gradmaß
    try result:=asn(TermToReal(v,x))*180/Pi;
    except Raise_Exception('Fehler beim Berechnen von Arcsin('+v + '), Gradmaß', teTrigon); End
  End else

  if u='ac_' then Begin //arccos im Gradmaß
    try result:=acs(TermToReal(v,x))*180/Pi;
    except Raise_Exception('Fehler beim Berechnen von Arccoc('+v + '), Gradmaß', teTrigon); End
  End else

  if u='co_' then Begin  //cos im Gradmaß
    try result:=cos(Pi/180*TermToReal(v,x));
    except Raise_Exception('Fehler beim Berechnen von cos('+v + '), Gradmaß', teTrigon); End
  End else

  if u='tan' then Begin  //tan im Bogenmaß
    try result:=tan(TermToReal(v,x));
    except Raise_Exception('Fehler beim Berechnen von Tan('+v + '), Bogenmaß', teTrigon); End
  End else

  if u='ta_' then Begin //tan im Gradmaß
    try result:=tan(Pi/180*TermToReal(v,x));
    except Raise_Exception('Fehler beim Berechnen von Tan('+v + '), Gradmaß', teTrigon); End
  End else

  if u='abs' then result:=abs(TermToReal(v,x))             else //Betrag
  if u='exp' then result:=exp(TermToReal(v,x))             else //???
  if u='wur' then result:=wurzel(TermToReal(v,x))          else //Wurzel
  if u='int' then result:=int(TermToReal(v,x))             else //abrunden
  if u='rou' then result:=int(TermToReal(v,x)+0.5)         else //Runden

  if s[1]='(' then Begin
     while (length(s)>1) and (s[length(s)]<>')') do copy(s,1,length(s)-1);
    s:=copy(s,2,length(s)-2);
    result:=TermToReal(s,x)
  End else if s='Pi' then result:=Pi else       //PI
    if s='x' then result:=x else //Variable x   //x
    Begin
      try result:=strToFloat(s); except Raise_Exception('Syntaxfehler in ' + s, teSyntax); result:=0; exit end;
    End
  except
    Raise_Exception('Syntaxfehler in ' + s, teSyntax);

  end;
end;    //end-Termtoreal