unit uCalc;
interface
uses Dialogs, Math, SysUtils;
Const
Symbol_Mod='M'; Symbol_Div='D';
Symbol_Shl='L'; Symbol_Shr='R';
Symbol_Or='O'; Symbol_Xor='X';
Symbol_And='A';
function ConvertExpression(ExpressionString:PChar):PChar; stdcall;
function ParseExpression(ExpressionString:PChar): extended; stdcall;
function ParseExpressionToStr(ExpressionString:PChar):PChar; stdcall;
implementation
function ConvertExpression(ExpressionString:PChar):PChar; stdcall;
var inputexp:string;
begin
inputexp:=ExpressionString;
//convert input expression to recognize expression
if pos('=',inputexp)=0 then inputexp:=inputexp+'=' else inputexp:=Copy(inputexp,1,Pos('=',inputexp));
inputexp:=UpperCase(inputexp);
inputexp:=StringReplace(inputexp,' ','',[rfReplaceAll]);
inputexp:=StringReplace(inputexp,'MOD',Symbol_Mod,[rfReplaceAll]);
inputexp:=StringReplace(inputexp,'DIV',Symbol_Div,[rfReplaceAll]);
inputexp:=StringReplace(inputexp,'AND',Symbol_And,[rfReplaceAll]);
inputexp:=StringReplace(inputexp,'XOR',Symbol_Xor,[rfReplaceAll]);
inputexp:=StringReplace(inputexp,'OR',Symbol_Or,[rfReplaceAll]);
inputexp:=StringReplace(inputexp,'SHL',Symbol_Shl,[rfReplaceAll]);
inputexp:=StringReplace(inputexp,'SHR',Symbol_Shr,[rfReplaceAll]);
inputexp:=StringReplace(inputexp,'(-','(0-',[rfReplaceAll]);
if pos('-',inputexp)=1 then inputexp:='0'+inputexp;
Result:=PChar(inputexp);
end;
function ParseExpression(ExpressionString:PChar): extended; stdcall;
var
nextch:char;
nextchpos,position:word;
inputexp:string;
procedure expression(var ev:extended);forward;
procedure readnextch;
begin
repeat
if inputexp[position]='=' then nextch:='='
else
begin
inc(nextchpos);
inc(position);
nextch:=inputexp[position];
end;
until (nextch<>' ') or eoln;
end;
procedure error(ErrorString:string);
begin
MessageDlg('Unknown expression : '+ErrorString,mterror,[mbok],0);
exit;
end;
procedure number(var nv:extended);
var radix:longint; snv:string;
function BinToInt(value: string): integer;
var i,size:integer;
begin // convert binary number to integer
result:=0;
size:=length(value);
for i:=size downto 1 do
if copy(value,i,1)='1'
then result:=result+(1 shl (size-i));
end;
begin
nv:=0;
snv:='';
while nextch in ['0'..'9','A'..'F'] do
begin
// nv:=10*nv+ord(nextch)-ord('0');
snv:=snv+nextch;
readnextch;
end;
// parse Hex, Bin
if snv<>'' then
if snv[Length(snv)]='B'
then nv:=BinToInt(Copy(snv,1,Length(snv)-1))
else if nextch='H' then begin nv:=StrToInt('$'+snv); readnextch; end
else nv:=StrToInt(snv);
if nextch='.' then
begin
radix:=10;
readnextch;
while nextch in ['0'..'9'] do
begin
nv:=nv+(ord(nextch)-ord('0'))/radix;
radix:=radix*10;
readnextch;
end;
end;
end;
procedure factor(var fv:extended);
Var Symbol:string;
function CalcN(Value:integer):extended;
var i:integer;
begin
Result:=1;
if Value=0 then Exit
else for i:=1 to Value do
Result:=Result*i;
end;
function ParseFunction(var FunctionSymbol:string):boolean;
begin
FunctionSymbol:='';
while not (nextch in ['0'..'9','.','(',')','+','-','*','/','=']) do
begin
FunctionSymbol:=FunctionSymbol+nextch;
readnextch;
end;
if FunctionSymbol='ABS' then Result:=true else
if FunctionSymbol='SIN' then Result:=true else
if FunctionSymbol='COS' then Result:=true else
if FunctionSymbol='TG' then Result:=true else
if FunctionSymbol='TAN' then Result:=true else
if FunctionSymbol='ARCSIN' then Result:=true else
if FunctionSymbol='ARCCOS' then Result:=true else
if FunctionSymbol='ARCTG' then Result:=true else
if FunctionSymbol='ARCTAN' then Result:=true else
if FunctionSymbol='LN' then Result:=true else
if FunctionSymbol='LG' then Result:=true else
if FunctionSymbol='EXP' then Result:=true else
if FunctionSymbol='SQR' then Result:=true else
if FunctionSymbol='SQRT' then Result:=true else
if FunctionSymbol='PI' then Result:=true else
if FunctionSymbol='NOT' then Result:=true else
if FunctionSymbol='N!' then Result:=true else
if FunctionSymbol='E' then Result:=true else
Result:=false;
end;
begin
Case nextch of
'0'..'9' : number(fv);
'(' : begin
readnextch;
expression(fv);
if nextch=')'
then readnextch else error(nextch);
end
else if ParseFunction(Symbol) then
if nextch='(' then
begin
readnextch;
expression(fv);
if Symbol='ABS' then fv:=abs(fv) else
if Symbol='SIN' then fv:=sin(fv) else
if Symbol='COS' then fv:=cos(fv) else
if Symbol='TG' then fv:=tan(fv) else
if Symbol='TAN' then fv:=tan(fv) else
if Symbol='ARCSIN' then fv:=arcsin(fv) else
if Symbol='ARCCOS' then fv:=arccos(fv) else
if Symbol='ARCTG' then fv:=arctan(fv) else
if Symbol='ARCTAN' then fv:=arctan(fv) else
if Symbol='LN' then fv:=ln(fv) else
if Symbol='LG' then fv:=ln(fv)/ln(10) else
if Symbol='EXP' then fv:=exp(fv) else
if Symbol='SQR' then fv:=sqr(fv) else
if Symbol='SQRT' then fv:=sqrt(fv) else
if Symbol='NOT' then fv:=not(Round(fv)) else
if Symbol='N!' then fv:=CalcN(Round(fv)) else
error(symbol);
if nextch=')' then readnextch else error(nextch);
end else begin // parse constant
if Symbol='PI' then fv:=3.14159265358979324 else
if Symbol='E' then fv:=2.71828182845904523 else error(symbol);
end else begin error(Symbol); fv:=1; end;
end;
end;
procedure Power_(var pv:extended);
var
multiop:char;
fs:extended;
begin
factor(pv);
while nextch in ['^'] do
begin
multiop:=nextch;
readnextch;
factor(fs);
case multiop of
'^':if pv<>0.0 then pv:=exp(ln(pv)*fs) else error(multiop);
end;
end;
end;
procedure term_(var tv:extended);
var
multiop:char;
fs:extended;
begin
Power_(tv);
while nextch in ['*','/',Symbol_Mod,Symbol_Div,Symbol_And,Symbol_Shl,Symbol_Shr] do
begin
multiop:=nextch;
readnextch;
Power_(fs);
case multiop of
'*':tv:=tv*fs;
'/':if fs<>0.0 then tv:=tv/fs else error(multiop);
Symbol_Mod:tv:=round(tv) mod round(fs); // prase mod
Symbol_Div:tv:=round(tv) div round(fs); // parse div
Symbol_And:tv:=round(tv) and round(fs); // parse and
Symbol_Shl:tv:=round(tv) shl round(fs); // parse shl
Symbol_Shr:tv:=round(tv) shr round(fs); // parse shr
end;
end;
end;
procedure expression(var ev:extended);
var
addop:char;
fs:extended;
begin
term_(ev);
while nextch in ['+','-',Symbol_Or,Symbol_Xor] do
begin
addop:=nextch;
readnextch;
term_(fs);
case addop of
'+':ev:=ev+fs;
'-':ev:=ev-fs;
Symbol_Or:ev:=round(ev) or round(fs); // parse or
Symbol_Xor:ev:=round(ev) xor round(fs); // parse xor
end;
end;
end;
BEGIN
inputexp:=ConvertExpression(ExpressionString);
if pos('=',inputexp)=0 then
inputexp:=ConvertExpression(ExpressionString);
position:=0;
while inputexp[position]<>'=' do
begin
nextchpos:=0;
readnextch;
expression(result);
end;
END;
function ParseExpressionToStr(ExpressionString:PChar):PChar; stdcall;
var ES:string;
begin
ES:=ExpressionString;
if pos('=',ES)=0
then ES:=ES+'='
else ES:=Copy(ES,1,Pos('=',ES));
ES:=ES+FormatFloat('0.000000000000',ParseExpression(ExpressionString));
Result:=PChar(ES);
end;
end.