unit1.~pas

用delphi语言实现运筹学黄金分割法程序

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ComCtrls;
const length=9;
      gold=1.618034;glimit=100;tiny=1e-20;r=0.61803399;c=0.38196601;
type
  TForm1 = class(TForm)
    PageControl1: TPageControl;
    TabSheet1: TTabSheet;
    TabSheet2: TTabSheet;
    Button1: TButton;
    Edit1: TEdit;
    Edit2: TEdit;
    Edit3: TEdit;
    Label1: TLabel;
    Label2: TLabel;
    Button2: TButton;
    Button3: TButton;
    Edit4: TEdit;
    Button4: TButton;
    Label3: TLabel;
    Label4: TLabel;
    procedure Button1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure Button3Click(Sender: TObject);
    procedure Edit3KeyPress(Sender: TObject; var Key: Char);
    procedure Button2Click(Sender: TObject);
    procedure Button4Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;
type  array1=array[1..length] of Tedit;
      array2=array[1..length] of Tlabel;
var
  Form1: TForm1;

implementation
{$R *.dfm}
uses math;
var Cedit:array1;
    n:integer;

function Func(xx:real):real ;
var s:real;
    i:integer;
    xishu: array[1..length] of real;
begin
  s:=0;
  for i:=1 to n+1 do
    begin
      xishu[i]:=strtofloat(Cedit[i].text);
      s:=s+xishu[i]*power(xx,n+1-i);
    end;
  result:=s;
end;
{-------------------计算函数值f(x)----------------------}
procedure sxqj(var ax,bx,cx,fa,fb,fc:real);
var  r,q,dum,u,ulim,fu:real;
begin
    fa:=func(ax);
    fb:=func(bx);
    if (fb>fa) then
      begin
        dum:=ax;
        ax:=bx;
        bx:=dum;
        dum:=fb;
        fb:=fa;
        fa:=dum;
      end;
    cx:=bx+gold*(bx-ax);
    fc:=func(cx);
	while (fb>=fc) do
	begin
        r:=(bx-ax)*(fb-fc);
        q:=(bx-cx)*(fb-fa);
        dum:=q-r;
        if (abs(dum)<tiny) then
          dum:=tiny;
        u:=bx-((bx-cx)*q-(bx-ax)*r)/(2*dum);
        ulim:=bx+glimit*(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-ulim)>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-ulim)*(ulim-cx)>=0)  then
                      begin
                        u := ulim;
                        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;

function  golden(ax,bx,cx,tol:real;var xmin:real):real;
var x0,x1,x2,x3,f0,f1,f2,f3:real;
begin
    x0:=ax;
    x3:=cx;
    if (abs(cx-bx)>abs(bx-ax)) then
	begin
          x1:=bx;
          x2:=bx+c*(cx-bx);
	end
    else
	begin
          x2:=bx;
          x1:=bx-c*(bx-ax);
        end;
    f1:=func(x1);
    f2:=func(x2);
    while (abs(x3-x0)>tol*(abs(x1)+abs(x2))) do
      begin
        if (f2<f1) then
          begin
            x0:= x1;
            x1:= x2;
            x2:= r * x1 + c * x3;
            f0:= f1;
            f1:= f2;
            f2:= func(x2);
          end
        else
          begin
            x3:= x2;
            x2:= x1;
            x1:= r * x2 + c * x0;
            f3:= f2;
            f2:= f1;
            f1:= func(x1);
         end;
      end;
    if (f1<f2) then
      begin
        xmin:=x1;
        result:=f1;
      end
    else
      begin
        xmin:=x2;
        result:=f2;
      end;
end;
{-------------------黄金分割子函数----------------------}
procedure TForm1.Button1Click(Sender: TObject);
var i:integer;
    Clabel1,Clabel2: array2;
begin
  if (edit1.text<>'') and (edit2.text<>'')and (edit3.text<>'') and (edit4.text<>'')  then
  begin
    n:=strtoint(edit3.text);
    for i:=1  to  n+1  do
      begin
        Cedit[i]:=Tedit.Create(self);
        Cedit[i].parent:=form1.TabSheet2;
        Cedit[i].Width:=40;
        Cedit[i].Height:=24;
        Cedit[i].left:=3+(i-1)*(Cedit[i].Width+1);
        Cedit[i].top:=64;
        Clabel1[i]:=Tlabel.Create(self);
        Clabel1[i].parent:=form1.TabSheet2;
        Clabel1[i].Width:=40;
        Clabel1[i].Height:=24;
        Clabel1[i].left:=16+(i-1)*(Clabel1[i].Width+1);
        Clabel1[i].top:=46;
        Clabel1[i].Caption:='x';
        Clabel1[i].Font.Size:=11;
        Clabel2[i]:=Tlabel.Create(self);
        Clabel2[i].parent:=form1.TabSheet2;
        Clabel2[i].Width:=40;
        Clabel2[i].Height:=24;
        Clabel2[i].left:=20+(i-1)*(Clabel2[i].Width+1);
        Clabel2[i].top:=39;
        Clabel2[i].Caption:=inttostr(n+1-i);
        Clabel2[i].Font.Size:=2;
      end;
    PageControl1.ActivePageIndex:=1;
  end;
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.Button3Click(Sender: TObject);
begin
  close;
end;
procedure TForm1.Edit3KeyPress(Sender: TObject; var Key: Char);
begin
  if not (key in ['1'..'8']) then
      key:=chr(0);
end;
{------------------控制整数输入值的范围-------------}
procedure TForm1.Button2Click(Sender: TObject);
var ax,bx,cx,fa,fb,fc,tol,x,f,xmin:real;
begin
  ax:=strtofloat(edit1.text);
  bx:=strtofloat(edit2.text);
  tol:=strtofloat(edit4.text);
  sxqj(ax,bx,cx,fa,fb,fc);
  f:=golden(ax,bx,cx,tol,xmin);
  showmessage('最优解是：'+formatfloat('0.###',xmin)+#13+'函数值为：'+formatfloat('0.###',f));
end;
{----------------显示结果-----------------------------}
procedure TForm1.Button4Click(Sender: TObject);
begin
  close;
end;

end.