{adapted to Turbo Pascal by Glenn Brooke 5/6/86 from a program
by Herbert Shcildt.
this program reads an expression and returns the result. It can
handle up to 26 one letter (A-Z) variables and real numbers.
Supports +,-,*,/,and powers. Not bad! Speed isn't too bad, either.
This kind of a program is really best as a function in your own program,
so that the user can enter an expression, and the program can compute
the result. For example, a function plotting program can simply ask
for a function like 2*X + (3.14/X^4)/1.23, and plot the curve from
-5 to +5. Quite powerful!
}
type
str80 = string[80];
Ttype = (Delimiter, Variable, Number);
var
token, prog : str80;
TokType : Ttype;
code, t : integer;
result : real;
vars : array[0..25] of real; {26 variables}
function IsAlpha(ch : char) : boolean;
{true if ch is letter in alphabe}
begin
IsAlpha := (Upcase(ch) in ['A'..'Z'])
end;
function IsWhite(ch : char) : boolean;
{true if newline, space or tab}
begin
IsWhite := (ch= ' ') or (ch=chr(9)) or (ch=chr(13));
end;
function IsDelim(ch : char) : boolean;
begin
if pos(ch,' +-/*%^=()$')<>0 then IsDelim := true
else IsDelim := false
end;
function Isdigit(ch : char) : boolean;
begin
Isdigit := ch in ['0'..'9']
end;
procedure GetToken;
var temp : str80;
begin
token := '';
while (IsWhite(prog[t])) do t := succ(t);
if prog[t]='$' then token := '$';
if pos(prog[t],'+-*/%^=()')<>0 then
begin
TokType := Delimiter;
token := prog[t]; {is an operator}
t := succ(t);
end
else if IsAlpha(prog[t]) then
begin
while (not IsDelim(prog[t])) do
begin
token := token + prog[t]; {build token}
t := succ(t)
end;
TokType := Variable;
end
else if IsDigit(prog[t]) then
begin
while (not IsDelim(prog[t])) do
begin
token := token + prog[t]; {build number}
t := succ(t);
Toktype := number;
end;
end;
end; {GetToken}
procedure PutBack; {put back unused token}
begin
t := t - length(token)
end;
procedure Serror(i : integer); {print error msg}
begin
case i of
1 : writeln('Syntax error');
2 : writeln('Unbalanced parentheses');
3 : writeln('No expression Present')
end;
end;
function Pwr(a,b : real) : real;
{raise a to the b power}
var t : integer;
temp : real;
begin
if a= 0 then pwr := 1
else
begin
temp := a;
for t := trunc(b) downto 2 do a := a * temp;
Pwr := a
end
end;
function FindVar(s : str80) : real;
var t : integer;
begin
FindVar := vars[ord(upcase(s[1]))-ord('A')]
end;
procedure Arith(op : char; var result, operand : real);
begin
case op of
'+' : result := result + operand;
'-' : result := result - operand;
'*' : result := result * operand;
'/' : result := result / operand;
'^' : result := Pwr(result,operand);
end
end;
{*********** Expression Parser w/ variables and assignment ********}
procedure Level2(var result : real); forward;
procedure Level1(var result : real); forward;
procedure Level3(var result : real); forward;
procedure Level4(var result : real); forward;
procedure Level5(var result : real); forward;
procedure Level6(var result : real); forward;
procedure Primitive(var result : real); forward;
procedure GetExp(var result: real);
begin
GetToken;
if length(token) <> 0 then Level1(result) else Serror(3)
end;
procedure Level1;
var hold : real;
temp : Ttype;
slot : integer;
TempToken : str80;
begin
if Toktype = Variable then
begin
{save old token}
temptoken := token;
temp := toktype;
slot := ord(upcase(token[1]))-ord('A');
GetToken; {see if there is an = for assignment}
if token[1] <> '=' then {restore}
begin
Putback;
token := temptoken;
toktype := temp;
level2(result)
end
else {is assignment}
begin
Gettoken;
Level2(result);
vars[slot] := result;
end;
end
else Level2(result)
end; {Level1}
procedure Level2;
var op : char;
hold : real;
begin
Level3(result);
op := token[1];
while ((op='+') or (op='-')) do
begin
Gettoken;
Level3(hold);
arith(op, result, hold);
op := token[1]
end;
end; {Level2}
procedure Level3;
var op : char;
hold : real;
begin
Level4(result);
op := token[1];
while ((op='*') or (op='/')) do
begin
Gettoken;
level4(hold);
arith(op, result, hold);
op := token[1]
end;
end; {Level3}
procedure Level4;
var hold : real;
begin
Level5(result);
if token[1] = '^' then
begin
GetToken;
Level4(hold);
arith('^',result, hold); {exponent}
end
end;
procedure Level5;
var op : char;
begin
op := ' ';
if ((tokType=Delimiter) and ((token[1]='+') or (token[1]= '-'))) then
begin {unary plus or minus}
op := token[1];
Gettoken
end;
Level6(result);
if op='-' then result := -result
end; {level5}
procedure Level6;
begin
if (token[1]='(') and (Toktype=Delimiter) then
begin {parenthesized expression}
GetToken;
Level2(result);
if token[1]<>')' then Serror(2); {unbalanced}
GetToken;
end
else Primitive(result);
end; {Level6}
procedure Primitive;
begin
if TokType=Number then val(token, result, code)
else if TokType=Variable then result := FindVar(token)
else serror(1);
GetToken
end; {Primitive}
{************************** Main Test body ******************}
begin
for t := 0 to 25 do vars[t] := 0; {initialize variables}
repeat
t := 1;
write(' Enter an expression (quit to stop) : ');
readln(prog);
prog := prog + '$';
GetExp(result);
writeln(result);
until prog = 'quit$';
end.
