关于计算公式的实现，有谁能够提供(100分)

用户自定义公式，然后根据公式，输入数据产生计算结果
主要是计算公式的算法
最后是用delphi实现
请高手指教

可以用别人的控件

用户自定义公式？怎么个自定义法？

用第三方

在数据结构这本书的第一章里就有讲这个算法。
其实很简单，自己写一个函数就可以了。
其核心思想是：把中缀表达式转换为后缀表达式；
我曾写过一个类似的函数，是用来比较两个表达式的值的。具体做法是：先把表达式的数字
与符号分开存放（须按后缀表达式的要求），再一一取出来分别进行计算或比较；

网上有下载的，我就下载了一个啊，不过我忘了哪里下载的。

up

看一看《编译原理》，模仿着写一个表达式解析树就行了。
或者，看一看 rxlib 中的 rxparse.pas。


一款设计精巧的表达式解析器
---- 开发MIS系统时，报表设计中经常会碰到表达式解释器，完成用户自定义的公式运算。
这种程序的设计需要有比较高的技巧，以下介绍一款用DELPHI4.0开发的程序[程序重在算法，
语言特性很少，用其它语言的人也能读懂]，只要按自已的要求稍加修改，即可做成组件或全局方法发部。
它支持 "加[+]、减[-]、乘[*]、除[/]、商[$：两整数相除，结果的整数部分]、
模[%]、括号[（）]"四则混合运算，
支持"与[&amp;]、或[|]、异或[^]、左移[< ]、右移[ >]和非[!]"逻辑运算功能，
同时它们可以出现在同一个表达式中，
它们的优先级依次为括号、非、与或异或左右移、乘除商模、加减。
如式：12.45+3*16 >2*(3+6*(3+2)-1)=12.45+3*4*32，计算结果为：396.45。

程序包括两大部分功能：表达式拆解、因子计算，分别由两个类TBdsProc和TPUSHPOP完成。具体如下：

CDIKind=record
case id: Boolean of
True: (dval: Double);
False: (ival: Integer);
end;
CDKind：区别表达式中的整数和浮点数类型，
因为有些运算符不支持浮点数（如逻辑运算）。

ValKind = CDIKind;
TBdsProc = class
private
Fghpd : Integer;//识别并标记左右括号是否成对出现
function IsCalcFh(c: Char): boolean;
//判别一个字符是否运算符
function CopyRight(abds: String;start: Integer):
String;//截取字符串表达式
function BdsSs(var abds: String): ValKind;
//返回一个子表达式的值
function BdsYz(var abds: String): ValKind;
//表达式因子，如：15、(13+5)
function BdsItm(var abds: String): ValKind;
//读取表达式中的一个因子
public
function CalcValue(const bds: String): ValKind;
//返回计算结果
end;

TPUSHPOP = class
private
ffh: array [0..2] of Char;//符号数组
value: array [0..3] of CDIKind;//值数组
flevel: Byte;//因子个数
fisfh: Boolean;//识别等待输入值或运算符
fisnot: Boolean;//识别待计算数据项是否执行非运算
function Calcsj(av1,av2: CDIKind;fh: Char): CDIKind;
//执行两个数值的四则运算
function Calclg(av1,av2: CDIKind; fh: Char): CDIKind;
//执行两个数的逻辑运算
procedure Calccur;{当输入数据项满足四个数后
[依运算优先级层数求得,见下述算式解析原理]执行中间运算}
function IsLgFh(fh: Char): Boolean;
//一个符号是否逻辑运算符
function IsCcFH(fh: Char): Boolean;
// 一个符号乘除商模运算符
public
constructor Create;
procedure PushValue(avalue: CDIKind);//存入一个数据项
procedure PushFh(afh: Char);//存入一个符号
function CalcValue: CDIKind;//计算并返回值
end;

---- 表达式解析基本原理：

---- 1．表达式处理：

---- 表达式的一个个数据项组成，中间由运算符连接，每个数据项为一个分析基本分析单元。表达式中如果包含有改变运算优先级别的括号运算，先计出括号中式子的值，再把该值当一个数据项处理,这一点在程序设计中只要运用递归功就能实现。

---- 2．数据项计算处理

---- a >非运算：

---- 它为单目运算符，级别最高，在存入符号时做标记，存入数据时即时计算并去除标记。

---- b >表达式运算：

---- 设f1、f2、f3分别表示一二三级运算符，V1、V2、V3、V4分别表示顺序四个数，则极端表达式模型为R=V1 f1 V2 f2 V3 f3 V4 …，计算时顺序应为 R=…V4 f3 V3 f2 V2 f1 V1。为了简化运算，把其中运算级别最高的逻辑运算在存入数据时先计算完成, 初始化时设V1=0,第一个运算符设为'+'。则公式化为： R=…V4 f2(f1) V3 f2(f1) V2 f1 V1。这样，当V2与V3间的运算符级别为f2时，V4与V3间的运算符级别< =f2，则：V2 =（V2与V3计算值），V3后的值和运算符前移；若V2与V3间的运算级别为f1，可先算V1与V2，V2以后的值和运算符前移。则计算后的表达式为：R=V3 f2(f2) V2 f1 V1刚好满足循环取数条件。

---- 3．实现：

---- 程序比较长(TBdsProc和TPUSHPOP的源代码合计长度为400多行)，完整代码见附件，以下对一些重要实现方法做介绍：

---- < 1 >表达式拆解：由方法BdsSs和BdsYz完成表达式拆解和因子处理

function TBdsProc.BdsSs(var abds: String): ValKind;
var
c: Char;
lpp: TPushPop;
begin
lpp := TPushPop.Create;//建立数据计算对象
while abds< >'' do
begin
c := abds[1];
if IsCalcFh(c) then//是否运算符
begin
lpp.PushFh(c);//保存运算符
abds := CopyRight(abds,2);
end
else
begin
if c=')' then
begin
Dec(Fghpd);//括号匹配
abds := CopyRight(abds,2);
if Fghpd < 0 then
Raise Exception.Create('括号不配对');
Result := lpp.CalcValue;
//返回括号中的子项值，进行下一步计算
lpp.Free;
Exit;
end
else
begin
if c='(' then
Inc(Fghpd);//做括号层数标识
lpp.PushValue(BdsYz(abds));//取下一项的值。
end;
end;
end;
if Fghpd< >0 then
Raise Exception.Create('括号不配对');
Result := lpp.CalcValue;//返回最终运算值
lpp.Free;
end;

function TBdsProc.BdsYZ(var abds: String): ValKind;
begin
if abds< >'' then
begin
if abds[1]='(' then
begin
abds := CopyRight(abds,2);
Result := BdsSs(abds);//递归调用，求括号中的值
end
else
Result := BdsItm(abds);{读一个数据项，
如果包括函数定义，可以在该方法中定义接口或连接}
end;
end;
若表达式要支持函数功能，只要定义系统支持的函数，
在取行表达式因子BdsItm中加入连接函数定义即可，如下：
…..
else if (c< ='Z') and (c >='A') then
begin
bhs := 取出函数名及参数
Result := … //调用函数处理 (函数定义)
abds := 下一项
end
….
< 2 > 数据计算：主要包PushValue,PushFh,
Calccur分别完成存入数、符号、中间计算
procedure TPUSHPOP.PushValue(avalue: CDIKind);
begin
if fisfh=True then
Raise Exception.Create('缺少运算符');
if fisnot then//进行非运算
begin
if avalue.id then
Raise Exception.Create('浮点数不能做非运算');
avalue.ival := not avalue.ival;
fisnot := False;
end;
if IsLgFh(ffh[flevel]) then//运行逻辑运算
begin
value[flevel] := Calclg(value[flevel],
avalue,ffh[flevel]);
//与当前值做逻辑运算
end
else
begin
Inc(flevel);//存数位置指针加1
value[flevel] := avalue;//存入值
if flevel >2 then//数据个数达到4，进行中间运算
Calccur;
end;
fisfh := True;//输入符号可见
end;

procedure TPUSHPOP.PushFh(afh: Char);
begin
if (fisfh=false) then//非运算是一级
begin
if (afh='!') and (not fisnot) then//标识非运算
begin
fisnot := True;
Exit;
end
else
Raise Exception.Create('运算符重复');
End
Else
begin
ffh[flevel] := afh;//存入运算符
fisfh := False; 输入值可见
end;
end;

procedure TPUSHPOP.Calccur;
begin
if IsCcFh(ffh[1]) then//二级运算符
begin
value[1] := Calcsj(value[1],value[2],ffh[1]);
//计算2和3项的值
ffh[1] := ffh[2];//后序运符和值前移
value[2] := value[3];
end
else//一级运算符
begin
value[0] := Calcsj(value[0],value[1],ffh[0]);
//计算1和2项的值
value[1] := value[2];{ 后序运符和值前移,
2和3项的值不计算是为了保持第一个运算符为一级运算符}
value[2] := value[3];
ffh[0] := ffh[1];
ffh[1] := ffh[2];
end;
Dec(flevel);//存数位置指针减1
end;

用户表达式，恐怕不是那么简单吧，需要用户自定义替换变量的吧。
实际操作中还是以确定性来操作比较好。替换变量比较难。

to zhihui:thank you
谢谢各位，继续发表自己的看法
等一起给各位加分

to cztwf,:第三方控件一向用的比较少，介绍以下了

数结结构有人算法,你只帮它改成Delphi就可以

看看数据结构的书，有这样的例子，用两个堆栈实现

看看Ralib
不是rxlib呵

到www.playicq.com down

有一个叫parser的控件，做计算用的，用户可以子定义变量替换。我前一段用过，你可以到网上找找

http://www.playicq.com/dispdoc.php?t=&amp;id=1949

控件教人懒啊！

same to ：pengjinlongex

这个东东我实现过，不过懒得传代码了，你可以看一下西安交大出版的《数据结构》
第二版，用C语言实现的，改成Delphi就行了,是用堆栈实现的

(*//
标题:计算表达式
说明:加、减、乘、除及括号;请大家多多测试
设计:Zswang
日期:2002-01-26
支持:wjhu111@21cn.com
//*)

///////Begin Source
uses
Math;

procedure Bracket(mText: string; var nLStr, nCStr, nRStr: string);
var
L, R: Integer;
I: Integer;
B: Boolean;
begin
nLStr := '';
nCStr := '';
nRStr := '';
B := True;
L := 0;
R := 0;
for I := 1 to Length(mText) do
if B then begin
if mText = '(' then
Inc(L)
else if mText = ')' then
Inc(R);
if L = 0 then
nLStr := nLStr + mText
else if L > R then
nCStr := nCStr + mText
else B := False;
end else nRStr := nRStr + mText;
Delete(nCStr, 1, 1);
end; { Bracket }

function Calc(mText: string): string;
var
vText: string;

function fCalc(mText: string): string;
var
vLStr, vCStr, vRStr: string;
I, J, K, L: Integer;
begin
L := Length(mText);
if Pos('(', mText) > 0 then begin
Bracket(mText, vLStr, vCStr, vRStr);
Result := fCalc(vLStr + fCalc(vCStr) + vRStr);
end else if (Pos('+', mText) > 0) or (Pos('-', mText) > 0) then begin
I := Pos('+', mText);
J := Pos('-', mText);
if I = 0 then I := L;
if J = 0 then J := L;
K := Min(I, J);
vLStr := Copy(mText, 1, Pred(K));
vRStr := Copy(mText, Succ(K), L);
if vLStr = '' then vLStr := '0';
if vRStr = '' then vRStr := '0';
if I = K then
Result := FloatToStr(StrToFloat(fCalc(vLStr)) + StrToFloat(fCalc(vRStr)))
else Result := FloatToStr(StrToFloat(fCalc(vLStr)) - StrToFloat(fCalc(vRStr)))
end else if (Pos('*', mText) > 0) or (Pos('/', mText) > 0) then begin
I := Pos('*', mText);
J := Pos('/', mText);
if I = 0 then I := L;
if J = 0 then J := L;
K := Min(I, J);
vLStr := Copy(mText, 1, Pred(K));
vRStr := Copy(mText, Succ(K), L);
if vLStr = '' then vLStr := '0';
if vRStr = '' then vRStr := '0';
if I = K then
Result := FloatToStr(StrToFloat(fCalc(vLStr)) * StrToFloat(fCalc(vRStr)))
else Result := FloatToStr(StrToFloat(fCalc(vLStr)) / StrToFloat(fCalc(vRStr)))
end else if Pos('_', mText) = 1 then
Result := FloatToStr(-StrToFloat(fCalc(Copy(mText, 2, L))))
else Result := FloatToStr(StrToFloat(mText));
end;
var
I, L: Integer;
begin
vText := '';
L := Length(mText);
for I := 1 to L do
if (mText = '-') and (I < L) and (not (mText[Succ(I)] in ['+', '-', '(', ')'])) then
if (I = 1) or ((I > 1) and (mText[Pred(I)] in ['*', '/'])) then
vText := vText + '_'
else if ((I > 1) and (mText[Pred(I)] in ['+', '-'])) or
((I < L) and (not (mText[Succ(I)] in ['+', '-', '(', ')']))) then
vText := vText + '+_'
else vText := vText + mText
else vText := vText + mText;
Result := fCalc(vText);
end; { Calc }
///////End Source

///////Begin Demo
procedure TForm1.Button1Click(Sender: TObject);
begin
Edit1.Text := Calc(Edit2.Text);
end;
///////End Demo

/////////////////////////////////////////////又一个
unit m;

interface

uses
Windows, Messages, Math, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls;
const
Symbol_Mod = 'M';
Symbol_Div = 'D';
Symbol_Shl = 'L';
Symbol_Shr = 'R';
Symbol_Or = 'O';
Symbol_Xor = 'X';
Symbol_And = 'A';
type
TForm1 = class(TForm)
Button1: TButton;
Edit1: TEdit;
Edit2: TEdit;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

function ConvertExpression(ExpressionString: PChar): PChar;
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;
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('无法识别的语法 : ' + 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;
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;

procedure TForm1.Button1Click(Sender: TObject);
begin
Edit1.Text:=ConvertExpression(pchar(Edit1.text));
Edit2.Text:=floattostr(ParseExpression(Pchar(Edit1.text)));
end;

end.