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 |