急求delphi曲线拟合算法(200分)

  • 主题发起人 jun_happy
  • 开始时间
J

jun_happy

Unregistered / Unconfirmed
GUEST, unregistred user!
急求delphi曲线拟合算法(最好有例子)
 
X

xzh2000

Unregistered / Unconfirmed
GUEST, unregistred user!
是bezier区线吗?
用OpengL吧。
 
L

lichdr

Unregistered / Unconfirmed
GUEST, unregistred user!
http://www.delphibbs.com/delphibbs/dispq.asp?lid=1906225
 
J

jrq

Unregistered / Unconfirmed
GUEST, unregistred user!
http://www.delphibbs.com/delphibbs/dispq.asp?lid=1472630
http://www.delphibbs.com/delphibbs/dispq.asp?lid=848126
http://www.delphibbs.com/delphibbs/dispq.asp?lid=313910
 
L

linsb

Unregistered / Unconfirmed
GUEST, unregistred user!
参考:
unit TDataFitUnit;
{ 这是一个多项式拟和类,可以采用四种多项式(幂指数、勒让德、埃米特、车比雪夫)
进行拟和,最后可得到拟合数值及其导数值。程序中还包含了高斯消元法解线性方程组
的过程。拟合次数不限,数据个数不限。
在应用中要注意的一点是:在求取拟合数值及其导数值的时候,因变量和拟合所得的系数
要重新输入一次.这增加了一点小的麻烦,然而保证了程序运行的安全.
这个类中由于使用了数组Property,因此使用极其方便,欢迎大家使用.
程序的一点不足之处是:没有充分利用正交多项式的性质而节省计算量。
软件类型:完全免费。
若发现问题,或觉得这个程序对你有所帮助,请发Mail:Xh_Xn@163.com
陈小斌
中国地震局地质研究所
2003.4.24
}
interface
Uses
SysUtils,math,Dialogs,Controls;
Var
index:Integer;
Type
TBasFunc=Function(i:Integer;X:Double):Double;
TEn_FitMethod=(E_PowerPoly,E_Hermite,E_Legendre,E_Chebyshev);
TArray1d=Array ofdo
uble;
TMatrx2d=Array of TArray1d;
TDataFit=Class
Private
fcanFit:Boolean;
fDataXisSet,fDataYisSet:Boolean;
fCIsSet:Boolean;
fNofFit:Integer;
//最小二乘多项式拟合的次数;
fNofData:Integer;
fDataX,fDataY:TArray1d;//输入的待拟合的数据
fA:TMatrx2d;
//拟合线性方程组系数矩阵
fB:TArray1d;
//拟合线性方程组右端矩阵
fEn_FitMethod: TEn_FitMethod;
fC: TArray1D;
fBasFunc,fdBasFunc:TBasFunc;
procedure SetfNofFit(const Value: Integer);
procedure SetfNofData(const Value: Integer);
//最小二乘多项式拟合数据点的个数;
Procedure FormFitmatrix;
procedure NormalDataX;
procedure SetfDataX(const Value: TArray1d);
procedure SetfDataY(const Value: TArray1d);
function GetfC: TArray1D;
procedure SetfC(const Value: TArray1D);
procedure SetEn_FitMethodItem(const Value: TEn_FitMethod);
Public
Constructor Create();
Procedure FitData;
Function GetFitValue: TArray1D;
Function GetdFitValue: TArray1D;
Property nF:Integer read fNofFit Write SetfNofFit;
Property nD:Integer read fNofData Write SetfNofData;
Property X:TArray1d Read fDataX Write SetfDataX;
Property Y:TArray1d Read fDataY Write SetfDataY;
Property C:TArray1D Read GetfC Write SetfC;
Property En_FitMethod:TEn_FitMethod Read fEn_FitMethod Write SetEn_FitMethodItem;
end;

function BasFuncOfPoly(i:Integer;X:Double):Double;
//幂基函数
Function BasFuncOfLEG(i:Integer;X:Double):Double;
//勒让德基函数
Function BasFuncOfCHEBEV(i:Integer;X:Double):Double;
//切比雪夫多项式
Function BasFuncOfHermite(i:Integer;X:Double):Double;
//埃米特多项式
function dBasFuncOfPoly(i:Integer;X:Double):Double;
//幂基函数的导数
Function dBasFuncOfLEG(i:Integer;X:Double):Double;
//勒让德基函数的导数
Function dBasFuncOfCHEBEV(i:Integer;X:Double):Double;
//切比雪夫多项式的导数
Function dBasFuncOfHermite(i:Integer;X:Double):Double;
//埃米特多项式的导数
Function En_FitMethodtoBasFunc(const Value: TEn_FitMethod):TBasFunc;
Function En_FitMethodtodBasFunc(const Value: TEn_FitMethod):TBasFunc;
Function NormalArray(A:TArray1d):TArray1d;
Function PowerInt(x:Double;i:Integer):Double;
Procedure GaussSolution(Ma:TMatrx2d;
//线性方程组矩阵系数
Mb: TArray1d;
//线性方程组右端常数向量
Var Mx: TArray1d);
//线性方程组的解;
//列主消元法求解线性方程组
implementation
Constructor TDataFit.Create;
begin
nF:=1;
nD:=1;
fCanFit:=false;
fCisSet:=False;
fDataXISSet:=False;
fDataYIsSet:=False;
fBasFunc:=BasFuncofPoly;
fdBasFunc:=dBasFuncofPoly;
inherited;
end;

procedure TDataFit.SetfNofData(const Value: Integer);
begin
If fNofData<>Value then
begin
fNofData := Value;
Setlength(fDataX,Value);
SetLength(fDataY,Value);
end;
end;

procedure TDataFit.SetfNofFit(const Value: Integer);
begin
If fNofFit<>Value then
begin
fNofFit := Value;
Setlength(fA,Value,Value);
Setlength(fB,Value);
SetLength(fC,Value);
end;
end;

procedure TDataFit.FormFitmatrix;
//函数作形参
Var
i,j,k:Integer;
begin
For i:=0 to nF-1do
begin
For j:=0 to nF-1do
begin
fA[i,j]:=0;
For k:=0 to nD-1do
fA[i,j]:=fA[i,j]+fBasfunc(i,fDataX[k])*fBasFunc(j,fDataX[k]);
end;
// End j Loop;
fB:=0;
for k:=0 to nD-1do
fB:=fB+fBasfunc(i,fDataX[k])*fDataY[k];
end;
// End i Loop;
end;

procedure TDataFit.FitData;
begin
NormalDataX;
If fCanFit then
begin
FormFitMatrix;

GaussSolution(fA,fB,fC);
fCanFit:=False;
fDataXisSet:=False;
fDataXisSet:=False;
end;
end;

function TDataFit.GetFitValue: TArray1D;
Var
k,i:Integer;
x:Double;
begin
Try
NormalDataX;
SetLength(Result,nD);
If fDataXIsSet And fCIsSet then
For k:=0 to nD-1do
begin
Result[k]:=0;
x:=fDataX[k];
For i:=0 to nF-1do
Result[k]:=Result[k]+fC*fBasfunc(i,x);
end;
Finally
fDataXIsSet:=False;
fCIsSet:=False;
end;
end;

function TDataFit.GetdFitValue: TArray1D;
Var
k,i:Integer;
x:Double;
begin
Try
NormalDataX;
SetLength(Result,nD);
If fDataXIsSet And fCIsSet then
For k:=0 to nD-1do
begin
Result[k]:=0;
x:=fDataX[k];
For i:=0 to nF-1do
Result[k]:=Result[k]+fC*fdBasfunc(i,x);
end;
Finally
fDataXIsSet:=False;
fCIsSet:=False;
end;
end;

Procedure TDataFit.NormalDataX;
begin
Try
If (En_FitMethod=E_Legendre) or (En_FitMethod=E_Chebyshev) then
fDataX:=NormalArray(fDataX);
If fDataXisSet And fDataYisSet then
fCanFit:=True;
Except
fDataXisSet:=False;
fDataXisSet:=False;
fCanFit:=False;
end;
end;

procedure TDataFit.SetfDataX(const Value: TArray1d);
Var
i:Integer;
begin
Try
If nD<>Length(Value) then
nD:=Length(Value);
For i:=0 to nD-1do
fDataX := Value;
fDataXisSet:=True;
Except
fDataXisSet:=False;
end;
end;

procedure TDataFit.SetfDataY(const Value: TArray1d);
Var
i:Integer;
begin
Try
If nD<>Length(Value) then
nD:=Length(Value);
For i:=0 to nD-1do
fDataY := Value;
fDataYisSet:=true;
Except
fDataYisSet:=False;
end;
end;

function TDataFit.GetfC: TArray1D;
Var
i:Integer;
begin
Setlength(Result,nF);
For i:=0 to nF-1do
Result:=fC;
end;

procedure TDataFit.SetfC(const Value: TArray1D);
Var
i:Integer;
begin
Try
If nF<>Length(Value) then
nF:=Length(Value);
For i:=0 to nF-1do
fC:=Value;
fCisSet:=True;
Except
fCisSet:=False;
end;
end;

procedure TDataFit.SetEn_FitMethodItem(const Value: TEn_FitMethod);
begin
fBasFunc:=En_FitMethodtoBasFunc(Value);
fdBasFunc:=En_FitMethodtodBasFunc(Value);
end;

//拟合基函数为幂函数
function BasFuncOfPoly(i:Integer;X:Double):Double;
begin
Result:=PowerInt(x,i);
end;

//拟合基函数为幂函数,求其导数
function DBasFuncOfPoly(i:Integer;X:Double):Double;
begin
result:=i*PowerInt(x,i-1);
end;

//拟合基函数为勒让德函数
function BasFuncOfLEG(i:Integer;X:Double):Double;
Var
j:integer;
Pl:TArray1d;
begin
If i=0 then
Result:=1;
If i=1 then
Result:=x;
If i>1 then
begin
Setlength(Pl,i+1);
Pl[0]:=1;
Pl[1]:=x;
For j:=2 to ido
begin
Pl[j]:=(2*j-1)/j*x*Pl[j-1]-(j-1)/j*Pl[j-2];
end;
Result:=Pl;
end;
end;

//拟合基函数为勒让德函数,求其导数
function dBasFuncOfLEG(i:Integer;X:Double):Double;
Var
j:integer;
dPl:TArray1d;
begin
If i=0 then
Result:=0;
If i=1 then
Result:=1;
If i>1 then
begin
Setlength(DPl,i+1);
dPl[0]:=0;
dPl[1]:=1;
For j:=2 to ido
begin
dPl[j]:=(2*j-1)/j*(x*dPl[j-1]+BasFuncOfLEG(j-1,x))-(j-1)/j*dPl[j-2];
end;
Result:=dPl;
end;
end;

//拟合基函数为切比雪夫函数
Function BasFuncOfCHEBEV(i:Integer;X:Double):Double;
Var
j:integer;
Tn:TArray1d;
begin
If i=0 then
Result:=1;
If i=1 then
Result:=x;
If i>1 then
begin
Setlength(Tn,i+1);
Tn[0]:=1;
Tn[1]:=x;
For j:=2 to ido
begin
Tn[j]:=2*x*Tn[j-1]-Tn[j-2];
end;
Result:=Tn;
end;
// Result:=Cos(i*ArcCos(x));
end;

//拟合基函数为切比雪夫函数,求其导数
Function dBasFuncOfCHEBEV(i:Integer;X:Double):Double;
Var
j:integer;
dTn:TArray1d;
begin
If i=0 then
Result:=0;
If i=1 then
Result:=1;
If i>1 then
begin
Setlength(dTn,i+1);
dTn[0]:=1;
dTn[1]:=x;
For j:=2 to ido
dTn[j]:=2*(BasFuncOfCHEBEV(j-1,x)+x*dTn[j-1])-dTn[j-2];
Result:=dTn;
end;
// Result:=Sin(i*ArcCos(x))*i/Sin(x);
end;

//拟合基函数为埃米特函数
Function BasFuncOfHermite(i:Integer;X:Double):Double;
Var
j:integer;
Hn:TArray1d;
begin
If i=0 then
Result:=1;
If i=1 then
Result:=2*x;
If i>1 then
begin
Setlength(Hn,i+1);
Hn[0]:=1;
Hn[1]:=2*x;
For j:=2 to ido
begin
Hn[j]:=2*x*Hn[j-1]-2*(j-1)*Hn[j-2];
end;
Result:=Hn;
end;
end;

//拟合基函数为埃米特函数,求其导数
Function dBasFuncOfHermite(i:Integer;X:Double):Double;
Var
j:integer;
dHn:TArray1d;
begin
If i=0 then
Result:=0;
If i=1 then
Result:=2;
If i>1 then
begin
Setlength(dHn,i+1);
dHn[0]:=1;
dHn[1]:=2;
For j:=2 to ido
begin
dHn[j]:=2*(BasFuncOfHermite(j-1,x)+x*dHn[j-1])-2*(j-1)*dHn[j-2];
end;
Result:=dHn;
end;
end;

Function En_FitMethodtoBasFunc(const Value: TEn_FitMethod):TBasFunc;
begin
case Value of
E_PowerPoly : Result:=BasFuncOfPoly;
E_Hermite : Result:=BasFuncOfHermite;
E_Legendre : Result:=BasFuncOfLEG;
E_Chebyshev : Result:=BasFuncOfCHEBEV;
end;
end;

Function En_FitMethodtodBasFunc(const Value: TEn_FitMethod):TBasFunc;
begin
case Value of
E_PowerPoly : Result:=dBasFuncOfPoly;
E_Hermite : Result:=dBasFuncOfHermite;
E_Legendre : Result:=dBasFuncOfLEG;
E_Chebyshev : Result:=dBasFuncOfCHEBEV;
end;
end;

//将一个数组的值规范化到[-1,1]区间
Function NormalArray(A:TArray1d):TArray1d;
Var
i,N:Integer;
dMax,dMin:Double;
begin
dMax:=-1e+10;
dMin:= 1e+10;
N:=Length(A);
SetLength(Result,N);
For i:=0 to N-1do
begin
If(dMax<A) then
dMax:=A;
If(dMin>A) then
dMin:=A;
end;
For i:=0 to N-1do
Result:=(2*A-dMax-dMin)/(dmax-dMin);
end;

Function PowerInt(x:Double;i:Integer):Double;
Var
j:Integer;
begin
Result:=1;
For j:=1 to ido
Result:=Result*x;
end;

procedure GaussSolution(Ma: TMatrx2d;
Mb: TArray1d;
Var Mx: TArray1d);
var
nX,i,j,k,P:Integer;
//nX为未知数的个数;
MaxOfRow:Double;
Ma_Tem:Double;
begin
nX:=Length(Mb);
iF Nx<>lENGTH(mX) then
If MessageDlg('Data Enter Error!',mtError,[mbOk],0)=mrOK then
Exit;
For k:=0 to nX-2do
begin
MaxOfRow:=Ma[k,k];
p:=k;
For i:=k to nX-1do
If(abs(Ma[i,k])>Abs(MaxOfRow)) then
begin
MaxOfRow:=Ma[i,k];
p:=i;
end;
//End If(abs(Ma[i,k)>Abs(MaxOfRow)) then
If(Abs(MaxofRow)>0)then
begin
if(p<>k) then
begin
for i:=k to nX-1do
begin
Ma_Tem:=Ma[k,i];
Ma[k,i]:=Ma[p,i];
Ma[p,i]:=Ma_Tem;
end;
//End i Loop;
Ma_Tem:=Mb[k];
Mb[k]:=Mb[p];
Mb[p]:=ma_Tem;
End // End if(p<>k) then
End //End If MaxofRow>0 then
{ to Here the main element(Max of that row) is found!!
The next Step is to decom the Matrix Ma}
else
If MessageDlg('There is no solution!!!',mtInformation,[mbOk],0)=mrOK then
Exit;
For i:=k+1 to nX-1do
begin
For j:= k+1 to nx-1do
ma[i,j]:=Ma[i,j]-Ma[i,k]*ma[k,j]/ma[k,k];
Mb:=Mb-ma[i,k]*Mb[k]/Ma[k,k];
end;
// End i Loop;
end;
// End K Loop;
{ to Here Decom is Over, the next step
is to solve the equation group}
Mx[nX-1]:=Mb[nX-1]/Ma[Nx-1,Nx-1];
For i:= nX-2do
wnto 0do
begin
Ma_Tem:=0;
For k:=i+1 to nX-1do
Ma_Tem:=Ma_Tem+Ma[i,k]*Mx[k];
Mx:=(Mb-Ma_tem)/Ma[i,i];
end;
end;

end.

{==============================================}
//下面是一个简单例子的关键部分源码:

procedure TForm1.RadioGroup1Click(Sender: TObject);
begin
Case RadioGroup1.ItemIndex of
0:fEn_FitMethod:=E_PowerPoly;
//幂指数多项式
1:fEn_FitMethod:=E_Legendre;
//勒让得多项式
2:fEn_FitMethod:=E_Chebyshev;
//车比雪夫多项式
3:fEn_FitMethod:=E_Hermite;
//爱米特多项式
end;
end;

procedure TForm1.Button3Click(Sender: TObject);
begin
fFitData.nD:=nD;
//nd...待拟和的数据数目
fFitData.nF:=nF;
//nF..拟合多项式次数
fFitData.X:=fX;
//待拟合数据的自变量数组
fFitData.Y:=fY;
//待拟和数组的因变量
fFitData.En_FitMethod:=fEn_FitMethod;
//选择一种多项式拟合方法
fFitData.FitData;
//进行数据拟合
fC:=fFitData.C;
//得到数据拟合系数
//在获得拟合数据前要重新赋值
fFitData.X:=fX;
//输入需计算其值的自变量值
fFitData.C:=fC;
//输入刚才拟合得到的系数
fFitY:=fFitData.GetFitValue;
//获得拟合数据
end;

 
L

ljlljl-79

Unregistered / Unconfirmed
GUEST, unregistred user!
J

jun_happy

Unregistered / Unconfirmed
GUEST, unregistred user!
linsb,无法执行的呀,能不能把例子讲得详细点啊,或者给我发一个,我的邮箱是
zhy9376@163.com
 
Z

zwz_good

Unregistered / Unconfirmed
GUEST, unregistred user!
其实到图书馆找一本数值拟合的书看一看就会了
 
顶部