program microcalc;
Uses Crt;
TYPE Real=Extended;
{******** From Turbo-Pascal 3.0 'MICROCALC' (example-program) ************}
{******************* !!!!! recursiv !!!!! ********************************}
procedure Evaluate(var Formula: String; { Fomula to evaluate}
x : Real; { Place for x in formula }
var Value: Real; { Result of formula }
var ErrPos: Integer); { Position of error }
const
Numbers: set of Char = ['0'..'9'];
EofLine = ^M;
var
Pos, i: Integer; { Current position in formula }
Ch: Char; { Current character being scanned }
dummy : String;
SumR, SumL : Integer;
{ Procedure NextCh returns the next character in the formula }
{ The variable Pos contains the position ann Ch the character }
procedure NextCh;
begin
repeat
Pos:=Pos+1;
if Pos<=Length(Formula) then
Ch:=Formula[Pos] else Ch:=eofline;
until Ch<>' ';
end { NextCh };
function Fak(I: Integer): Real; { Fakultaet }
var dummy : Real;
j : Integer;
begin
IF i=1 THEN BEGIN Fak:=1; Exit; END;
dummy:=1;
FOR i:=1 TO I DO Dummy:=dummy*i;
Fak:=dummy;
end { Fact };
function Expression: Real;
var
E: Real;
Opr: Char;
function SimpleExpression: Real;
var
S: Real;
Opr: Char;
function Term: Real;
var
T: Real;
function SignedFactor: Real;
function Factor: Real;
type
StandardFunction = (fabs,fsqrt,fsqr,fsin,fcos,
farctan,fln,flog,fexp,ffact,fPi, fE, fX);
StandardFunctionList = array[StandardFunction] of string[6];
const
StandardFunctionNames: StandardFunctionList =('ABS','SQRT','SQR','SIN','COS',
'ARCTAN','LN','LOG','EXP','FAK','PI','E','X');
var
E,EE,L: Integer; { intermidiate variables }
Found:Boolean;
F: Real;
Sf:StandardFunction;
Start:Integer;
begin { Function Factor }
if Ch in Numbers then
begin
Start:=Pos;
repeat NextCh until not (Ch in Numbers);
if Ch='.' then repeat NextCh until not (Ch in Numbers);
if Ch='E' then
begin
NextCh;
repeat NextCh until not (Ch in Numbers);
end;
Val(Copy(Formula,Start,Pos-Start),F,ErrPos);
end else
if Ch='(' then
begin
NextCh;
F:=Expression;
if Ch=')' then NextCh else ErrPos:=Pos;
end else
begin
found:=false;
for sf:=fabs to fX do
if not found then
begin
l:=Length(StandardFunctionNames[sf]);
if copy(Formula,Pos,l)=StandardFunctionNames[sf] then
begin
Pos:=Pos+l-1; NextCh;
F:=Factor;
case sf of
fabs: f:=abs(f);
fsqrt: f:=sqrt(f);
fsqr: f:=sqr(f);
fsin: f:=sin(f);
fcos: f:=cos(f);
farctan: f:=arctan(f);
fln : f:=ln(f);
flog: f:=ln(f)/ln(10);
fexp: f:=exp(f);
ffact: f:=fak(trunc(f));
fPi: f:=Pi;
fE: f:=Exp(1);
fX: f:=X;
end;
Found:=true;
end;
end;
if not Found then ErrPos:=Pos;
end;
Factor:=F;
end { function Factor};
begin { SignedFactor }
if Ch='-' then
begin
NextCh; SignedFactor:=-Factor;
end else SignedFactor:=Factor;
end { SignedFactor };
begin { Term }
T:=SignedFactor;
while Ch='^' do
begin
NextCh; t:=exp(ln(t)*SignedFactor);
end;
Term:=t;
end { Term };
begin { SimpleExpression }
s:=term;
while Ch in ['*','/'] do
begin
Opr:=Ch; NextCh;
case Opr of
'*': s:=s*term;
'/': s:=s/term;
end;
end;
SimpleExpression:=s;
end { SimpleExpression };
begin { Expression }
E:=SimpleExpression;
while Ch in ['+','-'] do
begin
Opr:=Ch; NextCh;
case Opr of
'+': e:=e+SimpleExpression;
'-': e:=e-SimpleExpression;
end;
end;
Expression:=E;
end { Expression };
begin { procedure Evaluate }
{--first make the formula a little easier --}
dummy:=''; { remove all blanks }
FOR i:=1 TO Length(Formula) DO
IF Formula[i]<>' ' THEN Dummy:=dummy+Formula[i];
sumr:=0; suml:=0;
FOR i:=1 TO Length(dummy) DO { brackets ok ? }
CASE dummy[i] OF
',' : dummy[i]:='.';
'(' : Inc(SumR);
')' : Inc(SumL);
ELSE dummy[i]:=UpCase(dummy[i]);
END;
i:=1;
repeat
Inc(i);
IF (dummy[i]='.') AND NOT (dummy[i-1] IN numbers) THEN
BEGIN
Insert('0',dummy,i); Inc(i);
END;
until i>=Length(dummy);
if dummy[1]='.' then Insert('0',dummy,1);
if dummy[1]='+' then delete(dummy,1,1);
IF dummy='' THEN
BEGIN Value:=0; ErrPos:=-1; Exit; END;
IF sumR<>sumL THEN
BEGIN Value:=0; ErrPos:=-2; Exit; END;
Formula:=Dummy;
Pos:=0; NextCh;
Value:=Expression;
if Ch=EofLine then ErrPos:=0 else ErrPos:=Pos;
end { Evaluate };
var
Value, x : Real;
ErrPos, i : Integer;
Formula : String;
BEGIN { Main (Example) }
ClrScr;
Formula:='fak(49)/(fak(49-6)*fak(6))';
Evaluate(Formula, 0, Value, ErrPos);
Writeln(Formula,' = ',Value:7:0,' Possibilitys in "German Lotto"');
Formula:='100000^(1/5)*cos(pi)';
Evaluate(Formula, 0, Value, ErrPos);
Writeln(Formula,' = ',Value:7:2,'');
Writeln;
Formula:='exp(cos(-2*Sqr(x) - 4*x+ 3))/(1/(x+0.01))';
FOR i:=0 TO 10 DO
BEGIN
x:=i*0.1;
Evaluate(Formula, x, Value, ErrPos);
Writeln('x = ',x:5:1,' ',Formula,' = ',Value:7:3);
END;
END.
(
geocities.com/SiliconValley/2926) (
geocities.com/SiliconValley)