用过多项式拟和的朋友请进来，帮我看一下我调用那错了。 ( 积分: 200 )

  • 主题发起人 主题发起人 thankl
  • 开始时间 开始时间
T

thankl

Unregistered / Unconfirmed
GUEST, unregistred user!
unit DataFitUnit;

{ 这是一个多项式拟和类,可以采用四种多项式(幂指数、勒让德、埃米特、车比雪夫）
进行拟和,最后可得到拟合数值及其导数值。程序中还包含了高斯消元法解线性方程组
的过程。拟合次数不限，数据个数不限。
在应用中要注意的一点是:在求取拟合数值及其导数值的时候,因变量和拟合所得的系数
要重新输入一次.这增加了一点小的麻烦,然而保证了程序运行的安全.
这个类中由于使用了数组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 of Double;
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-1 do
Begin
For j:=0 to nF-1 do
begin
fA[i,j]:=0;
For k:=0 to nD-1 do
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-1 do
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-1 Do
Begin
Result[k]:=0;
x:=fDataX[k];
For i:=0 to nF-1 Do
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-1 Do
Begin
Result[k]:=0;
x:=fDataX[k];
For i:=0 to nF-1 Do
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-1 Do
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-1 Do
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-1 Do
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-1 Do
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 i Do
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 i Do
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 i Do
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 i Do
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 i Do
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 i Do
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-1 Do
Begin
If(dMax<A) Then dMax:=A;
If(dMin>A) Then dMin:=A;
End;
For i:=0 to N-1 Do
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 i Do
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-2 do
Begin
MaxOfRow:=Ma[k,k];
p:=k;
For i:=k to nX-1 do
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-1 do
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-1 do
Begin
For j:= k+1 to nx-1 Do
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-2 Downto 0 do
Begin
Ma_Tem:=0;
For k:=i+1 to nX-1 do
Ma_Tem:=Ma_Tem+Ma[i,k]*Mx[k];
Mx:=(Mb-Ma_tem)/Ma[i,i];
End;
End;

End.
unit Unit1;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls;

type
TForm1 = class(TForm)
RadioButton1: TRadioButton;
Button3: TButton;
procedure Button3Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation
uses
DataFitUnit;
{$R *.DFM}

{==============================================}

//下面是一个简单例子的关键部分源码：



procedure TForm1.Button3Click(Sender: TObject);
var
fFitData:TDataFit;
N_1,N_2,N_3,N_4,N_5:TArray1d;
begin
setLength(N_1,5);
setLength(N_2,5);
setLength(N_3,1);
setLength(N_5,5);
setLength(N_4,5);
{ N_1:=[16.8,18.0,19.8,22.0,23.8];
N_2:=[1.64,1.72,1.75,1.71,1.64]; }
N_1[0]:=16.8;
N_1[1]:=18.0;
N_1[2]:=19.8;
N_1[3]:=22.0;
N_1[4]:=23.8;
N_2[0]:=1.64;
N_2[1]:=1.72;
N_2[2]:=1.75;
N_2[3]:=1.71;
N_2[4]:=1.64;

fFitData.nD:=5; //nd...待拟和的数据数目
fFitData.nF:=1; //nF..拟合多项式次数
fFitData.X:=N_1; //待拟合数据的自变量数组
fFitData.Y:=N_2; //待拟和数组的因变量
fFitData.En_FitMethod:=E_Chebyshev; //选择一种多项式拟合方法
fFitData.FitData; //进行数据拟合
N_3:=fFitData.C; //得到数据拟合系数
//在获得拟合数据前要重新赋值
fFitData.X:=N_1; //输入需计算其值的自变量值
fFitData.C:=N_3; //输入刚才拟合得到的系数
N_5:=fFitData.GetFitValue; //获得拟合数据
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; }

end.
 
unit DataFitUnit;

{ 这是一个多项式拟和类,可以采用四种多项式(幂指数、勒让德、埃米特、车比雪夫）
进行拟和,最后可得到拟合数值及其导数值。程序中还包含了高斯消元法解线性方程组
的过程。拟合次数不限，数据个数不限。
在应用中要注意的一点是:在求取拟合数值及其导数值的时候,因变量和拟合所得的系数
要重新输入一次.这增加了一点小的麻烦,然而保证了程序运行的安全.
这个类中由于使用了数组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 of Double;
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-1 do
Begin
For j:=0 to nF-1 do
begin
fA[i,j]:=0;
For k:=0 to nD-1 do
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-1 do
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-1 Do
Begin
Result[k]:=0;
x:=fDataX[k];
For i:=0 to nF-1 Do
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-1 Do
Begin
Result[k]:=0;
x:=fDataX[k];
For i:=0 to nF-1 Do
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-1 Do
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-1 Do
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-1 Do
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-1 Do
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 i Do
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 i Do
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 i Do
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 i Do
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 i Do
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 i Do
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-1 Do
Begin
If(dMax<A) Then dMax:=A;
If(dMin>A) Then dMin:=A;
End;
For i:=0 to N-1 Do
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 i Do
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-2 do
Begin
MaxOfRow:=Ma[k,k];
p:=k;
For i:=k to nX-1 do
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-1 do
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-1 do
Begin
For j:= k+1 to nx-1 Do
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-2 Downto 0 do
Begin
Ma_Tem:=0;
For k:=i+1 to nX-1 do
Ma_Tem:=Ma_Tem+Ma[i,k]*Mx[k];
Mx:=(Mb-Ma_tem)/Ma[i,i];
End;
End;

End.
unit Unit1;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls;

type
TForm1 = class(TForm)
RadioButton1: TRadioButton;
Button3: TButton;
procedure Button3Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation
uses
DataFitUnit;
{$R *.DFM}

{==============================================}

//下面是一个简单例子的关键部分源码：



procedure TForm1.Button3Click(Sender: TObject);
var
fFitData:TDataFit;
N_1,N_2,N_3,N_4,N_5:TArray1d;
begin
setLength(N_1,5);
setLength(N_2,5);
setLength(N_3,1);
setLength(N_5,5);
setLength(N_4,5);
{ N_1:=[16.8,18.0,19.8,22.0,23.8];
N_2:=[1.64,1.72,1.75,1.71,1.64]; }
N_1[0]:=16.8;
N_1[1]:=18.0;
N_1[2]:=19.8;
N_1[3]:=22.0;
N_1[4]:=23.8;
N_2[0]:=1.64;
N_2[1]:=1.72;
N_2[2]:=1.75;
N_2[3]:=1.71;
N_2[4]:=1.64;

fFitData.nD:=5; //nd...待拟和的数据数目
fFitData.nF:=1; //nF..拟合多项式次数
fFitData.X:=N_1; //待拟合数据的自变量数组
fFitData.Y:=N_2; //待拟和数组的因变量
fFitData.En_FitMethod:=E_Chebyshev; //选择一种多项式拟合方法
fFitData.FitData; //进行数据拟合
N_3:=fFitData.C; //得到数据拟合系数
//在获得拟合数据前要重新赋值
fFitData.X:=N_1; //输入需计算其值的自变量值
fFitData.C:=N_3; //输入刚才拟合得到的系数
N_5:=fFitData.GetFitValue; //获得拟合数据
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; }

end.
 
linsb大侠在不在？他好像搞过看他以前的例子
 
路过的也帮我顶一下。要不我就沉下去了。
 
好像有本关于各种算法的书是用delphi来实现的，可以在书店找找。
 
thankl, 借你的宝地一用:
在http://www.delphibbs.com/delphibbs/dispq.asp?lid=2008706
这个帖子里, Another_eYes发的完成端口控件你是否还有备份?
如有的话麻烦发一份到doxpix@hotmail.com, 要多少感谢分你说吧.
 
您必须登录或注册才可回复。

Similar threads

C
字符串加解密源程序(200分)
回复
5
查看
156
chooy
C
B
挑战问题的进来。(20分)
回复
7
查看
173
beckzd
B
V
看看这个复制当前记录的函数有什么问题,为什么不能复制子表...(50分)
回复
1
查看
124
jsxjd
J
C
三层模式中客户端如何调用服务器端的过程或函数?(200分)
回复
12
查看
192
Aldrich_lwh
A
J
请高手帮忙看一下这段代码.(95分)
回复
3
查看
162
joann
J
后退
顶部