📄 unit1.~pas
字号:
unit Unit1;
interface
uses
Windows,math, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ComCtrls;
const length=10;e=0.00001;
iitem2 = 100; cgold = 0.381966; zeps = 0.0000000001;
gold=1.618034;limg=100;tiny=1e-20;
tol= 0.0001;
iitem=200; eps=0.0000000001;
type
TForm1 = class(TForm)
PageControl1: TPageControl;
TabSheet1: TTabSheet;
TabSheet2: TTabSheet;
Edit1: TEdit;
Edit2: TEdit;
Label1: TLabel;
Label2: TLabel;
Button1: TButton;
Button2: TButton;
Button3: TButton;
Button4: TButton;
Label3: TLabel;
Edit3: TEdit;
Label4: TLabel;
Label5: TLabel;
procedure Button1Click(Sender: TObject);
procedure Button3Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure Button4Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
type array1=array[1..length,1..length] of Tedit;
type array2=array[1..length] of Tedit;
type array3=array[1..length,1..length] of real;
type array4=array[1..length] of real;
type array5=array[1..length] of Tlabel;
var
Form1: TForm1;
procedure sxqj(var ax,bx,cx,fa,fb,fc:real);
implementation
var n,m:integer;
xishu:array[1..length,1..length] of real;
shuru1:array1;
STpoint:array2;
nnc:integer;
pp, xxi:array4;
{$R *.dfm}
function func2(xx:array4;n:integer):real;
var i,j:integer;
s:real;
begin
s:=0;
for i:=1 to n do
for j:=1 to m+1 do
s:=s+xishu[i,j]*power(xx[i],n+1-j);
result:=s;
end;
function transl(x:real):real;
var j:integer;
xt:array4;
begin
for j:=1 to nnc do
xt[j]:=pp[j] + x * xxi[j];
result:=func2(xt,nnc);
end;
function func(x:real):real;
begin
result:=transl(x);
end;
{----------------求初始的函数值-----------------}
procedure dfunc(xx:array4;var df:array4);
var s:array4;
i,j:integer;
begin
for i:=1 to n do
begin
s[i]:=0;
for j:=1 to m do
s[i]:=s[i]+xishu[i,j]*(m+1-j)*power(xx[i],m-j);
df[i]:=s[i];
end;
end;
{----------------求初始的导数值-----------------}
function brqd(ax,bx,cx,tol:real;var xmin:real):real;
var teme,kk:integer;
d,fu,r,q,p,xm,r1,r2,a,b:real;
u,tempe,dm,v,w,x,ee,fx,fv1,fw:real;
begin
a:=ax;
if (cx<ax) then
a:=cx;
b := ax;
if (cx>ax) then
b:=cx;
v:=bx;
w:=v;
x:=v;
ee:=0.0;
fx:=func(x);
fv1:=fx;
fw:=fx;
for kk:=1 to iitem2 do
begin
xm:=0.5*(a+b);
r1:=tol*abs(x)+zeps;
r2:=2.0*r1;
if (abs(x-xm)<=r2-0.5*(b-a)) then break;
teme:=-1;
if (abs(ee)>r1) then
begin
r:=(x-w)*(fx-fv1);
q:=(x-v)*(fx-fw);
p:=(x-v)*q-(x-w)*r;
q:=2.0*(q-r);
if (q>0.0) then p:=-p;
q:=abs(q);
tempe:=ee;
ee:=d;
dm:=abs(0.5*q*tempe);
if (abs(p)<dm ) and (p>q*(a-x)) and (p<q*(b-x)) then
begin
d:=p/q;
u:=x+d;
if (u-a<r2) or (b-u<r2) then
d:=abs(r1)*sign(xm - x);
teme:=0;
end;
end;
if (teme<>0) then
begin
if (x>= xm) then
ee:=a-x
else
ee:=b-x;
d:=cgold*ee;
end;
if (abs(d)>= r1) then
u:=x+d
else
u:=x+abs(r1)*sign(d);
fu:=func(u);
if (fu<=fx) then
begin
if (u>=x) then
a:=x
else
b:=x;
v:=w;
fv1:=fw;
w:=x;
fw:=fx;
x:=u;
fx:=fu;
end
else
begin
if (u<x) then
a:=u
else
b:=u;
if (fu<=fw) or (w=x) then
begin
v:=w;
fv1:=fw;
w:=u;
fw:=fu;
end
else
begin
if (fu<=fv1) or (v=x) or (v=w) then
begin
v:=u;
fv1:=fu;
end;
end;
end;
end;
xmin:=x;
result:=fx;
end;
procedure sxqj(var ax,bx,cx,fa,fb,fc:real);
var r,q,dm,u,ylm,fu:real;
begin
fa:=func(ax);
fb:=func(bx);
if (fb>fa) then
begin
dm:=ax;
ax:=bx;
bx:=dm;
dm:=fb;
fb:=fa;
fa:=dm;
end;
cx:=bx+gold*(bx-ax);
fc:=func(cx);
while (fb>=fc) do
begin
r:=(bx-ax)*(fb-fc);
q:=(bx-cx)*(fb-fa);
dm:=q-r;
if (abs(dm)<tiny) then
dm:=tiny;
u:=bx-((bx-cx)*q-(bx-ax)*r)/(2*dm);
ylm:=bx+limg*(cx-bx);
if ((bx-u)*(u-cx)>0) then
begin
fu:=func(u);
if (fu<fc) then
begin
ax:=bx;
fa:=fb;
bx:=u;
fb:=fu;
exit;
end
else
begin
if (fu>fb) then
begin
cx:=u;
fc:=fu;
exit;
end;
end;
u:=cx+gold*(cx-bx);
fu:=func(u);
end
else
begin
if ((cx-u)*(u-ylm)>0) then
begin
fu:=func(u);
if (fu<fc) then
begin
bx:=cx;
cx:=u;
u:=cx+gold*(cx-bx);
fb:=fc;
fc:=fu;
fu:=func(u);
end;
end
else
begin
if ((u-ylm)*(ylm-cx)>=0) then
begin
u:=ylm;
fu:=func(u);
end
else
begin
u:=cx+gold*(cx-bx);
fu:=func(u);
end;
end;
end;
ax:=bx;
bx:=cx;
cx:=u;
fa:=fb;
fb:=fc;
fc:=fu;
end;
end;
procedure lmbh(var p:array4;xi:array4;n:integer;var fret:real);
var j:integer;
fa,fx,fb,bx,xmin,ax,xx:real;
begin
ax:=0.0;
xx:=1.0;
nnc:=n;
for j:=1 to n do
begin
pp[j]:=p[j];
xxi[j]:=xi[j];
end;
sxqj(ax,xx,bx,fa,fx,fb);
fret:=brqd(ax,xx,bx,tol,xmin);
for j:=1 to n do
begin
xi[j]:=xmin*xi[j];
p[j]:=p[j]+xi[j];
end;
end;
procedure DFPmin(var p:array4;n:integer;ftol:real;var kk:integer;var f:real);
var i,j,its:integer;
fp,fac,fad,fae,aaa,bbb:real;
hessin:array3;
xi,g,dg,hdg:array4;
begin
fp:=func2(p,n);
dfunc(p,g);
for i:=1 to n do
begin
for j:=1 to n do
hessin[i][j]:=0.0;
hessin[i][i]:=1.0;
xi[i]:=-g[i];
end;
for its:=1 to iitem do
begin
kk:=its;
lmbh(p,xi,n,f);
if (2.0*abs(f-fp)<=ftol*(abs(f)+abs(fp)+eps)) then
exit;
fp:=f;
for i:=1 to n do
dg[i]:=g[i];
f:=func2(p,n);
dfunc(p,g);
for i:=1 to n do
dg[i]:=g[i]-dg[i];
for i:=1 to n do
begin
hdg[i]:=0.0;
for j:=1 to n do
hdg[i]:=hdg[i]+hessin[i][j]*dg[j];
end;
fac:=0.0;
fae:=0.0;
for i:=1 to n do
begin
fac:=fac+dg[i]*xi[i];
fae:=fae+dg[i]*hdg[i];
end;
fac:=1.0/fac;
fad:=1.0/fae;
for i:=1 to n do
dg[i]:=fac*xi[i]-fad*hdg[i];
for i:=1 to n do
begin
for j:=1 to n do
begin
aaa:=fac*xi[i]*xi[j]-fad*hdg[i]*hdg[j];
bbb:=fae*dg[i]*dg[j];
hessin[i][j]:=hessin[i][j]+aaa+bbb;
end;
end;
for i:=1 to n do
begin
xi[i]:=0.0;
for j:=1 to n do
xi[i]:=xi[i]-hessin[i][j]*g[j];
end;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
var i,j:integer;
lab:array5;
begin
if (edit1.Text<>'') and (edit2.Text<>'') then
begin
n:=strtoint(edit1.text);
m:=strtoint(edit2.text);
for i:=1 to n do
begin
STpoint[i]:=Tedit.Create(self);
STpoint[i].parent:=tabsheet2;
STpoint[i].Width:=40;
STpoint[i].Height:=24;
STpoint[i].left:=40+(i-1)*(STpoint[i].Width+15);
STpoint[i].top:=25;
lab[i]:=Tlabel.Create(self);
lab[i].parent:=tabsheet2;
lab[i].Width:=30;
lab[i].Height:=24;
lab[i].left:=20;
lab[i].top:=80+(i-1)*(lab[i].Height+2);;
lab[i].caption:='X'+inttostr(i);
for j:=1 to m+1 do
begin
shuru1[i,j]:=Tedit.Create(self);
shuru1[i,j].parent:=tabsheet2;
shuru1[i,j].Width:=60;
shuru1[i,j].Height:=24;
shuru1[i,j].left:=40+(j-1)*(shuru1[i,j].Width+20);
shuru1[i,j].top:=75+(i-1)*(shuru1[i,j].Height+2);
end;
PageControl1.ActivePageIndex:=1;
end;
end;
end;
{------------------生成控件--------------------}
procedure TForm1.Button3Click(Sender: TObject);
var i,j,kk:integer;
xx:array4;
ex,f:real;
Str:string;
begin
ex:=strtofloat(edit3.text);
for i:=1 to n do
xx[i]:=strtofloat(STpoint[i].text);
for i:=1 to n do
for j:=1 to m+1 do
xishu[i,j]:=strtofloat(shuru1[i,j].text);
DFPmin(xx,n,ex,kk,f);
Str:='';
for i:=1 to n do
Str:=Str+'x'+inttostr(i)+'='+formatfloat('0.####',xx[i])+#13 ;
showmessage(Str+'f='+formatfloat('0.####',f));
end;
{------------------输出显示最优解与最优值---------------}
procedure TForm1.FormCreate(Sender: TObject);
var i:integer;
begin
for i:=0 to PageControl1.PageCount-1 do
PageControl1.Pages[I].TabVisible:=False;
PageControl1.ActivePageIndex:=0 ;
end;
{------------------控制控件的可视性-------------------}
procedure TForm1.Button2Click(Sender: TObject);
begin
close;
end;
procedure TForm1.Button4Click(Sender: TObject);
begin
close;
end;
end.
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -