Добавил:
Upload Опубликованный материал нарушает ваши авторские права? Сообщите нам.
Вуз: Предмет: Файл:
ММДО 5.doc
Скачиваний:
3
Добавлен:
07.06.2015
Размер:
309.19 Кб
Скачать

Листинг программы

unit untMain;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

ExtCtrls, StdCtrls, Series, ArrowCha, Math, TeEngine, TeeProcs, Chart,

Grids;

type

TFunc = function (x:extended):extended;

TVekt = array of extended;

TCelf = function (x:TVekt):extended;

TVals = record x, y: extended; end;

TForm1 = class(TForm)

pnlDraw: TPanel;

crtGraph: TChart;

srsAxisY: TLineSeries;

srsAxisX: TLineSeries;

srsGraph: TArrowSeries;

graf1: TLineSeries;

graf2: TLineSeries;

GroupBox1: TGroupBox;

GroupBox2: TGroupBox;

edX1: TEdit;

edX2: TEdit;

edNmax: TEdit;

edE: TEdit;

Label1: TLabel;

Label2: TLabel;

Label3: TLabel;

Label5: TLabel;

edX1min: TEdit;

edX2min: TEdit;

edFmin: TEdit;

edN: TEdit;

Label6: TLabel;

Label7: TLabel;

Label8: TLabel;

Label9: TLabel;

btnWork: TButton;

GroupBox3: TGroupBox;

strF: TStringGrid;

procedure FormCreate(Sender: TObject);

procedure btnWorkClick(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

//Нахождение градиента функции

procedure gradmin(f:TCelf; m:integer; e:extended; var xo:TVekt;

var yopt:extended; var ip:integer);

//Добавление координат для отрисовки

procedure addkoord(f:TCelf; xo:TVekt);

//Отрисовка графика по векторам

procedure drawvekt(series:TArrowSeries; x, y:TVekt);

//Отрисовка графика по функции

procedure drawfunc(series:TLineSeries; f:TFunc; a, b:extended);

end;

var

Form1: TForm1;

xk: TVekt;

e, d, fopt: extended;

Nmax, ip:integer;

gx, gy, gz, gr: TVekt;

dta: array [1..100] of extended;

p: integer;

implementation

function f(x:TVekt):extended;

begin

f:=sqr(exp(-x[0])-exp(x[1])+1)+ sqr(x[1]*x[0]+1);

end;

function gr1(x:extended):extended;

begin

result:=1/(exp(x)-1);

end;

function gr2(x:extended):extended;

begin

result:=-(1/x);

end;

//Нахождение градиента функции

function gradient(f:TCelf; e:extended; x:TVekt): TVekt;

var

n, i: integer;

fp, fo: extended;

g: TVekt;

begin

n:=length(x);

setlength(g,n);

for i:= 0 to n-1 do begin

x[i]:=x[i]+e;

fp:=f(x);

x[i]:=x[i]-2*e;

fo:=f(x);

x[i]:=x[i]+e;

g[i]:=(fp-fo)/(2*e);

end;

gradient:=g;

end;

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);

begin

with strF do begin

cells[0,0]:='№ итерации';

cells[1,0]:=' X1';

cells[2,0]:=' X2';

cells[3,0]:='DELTA';

end;

setlength(xk, 2);

try

xk[0]:=strtofloat(edX1.Text);

except

ShowMessage('Ошибка ввода данных!');

Exit;

end;

try

xk[1]:=strtofloat(edX2.text);

except

ShowMessage('Ошибка ввода данных!');

Exit;

end;

try

Nmax:=strtoint(edNmax.Text);

except

ShowMessage('Ошибка ввода данных!');

Exit;

end;

try

e:=strtofloat(edE.text);

except

ShowMessage('Ошибка ввода данных!');

Exit;

end;

end;

procedure TForm1.btnWorkClick(Sender: TObject);

var a:extended; i:integer;

begin

Form1.oncreate(Form1);

a:=xk[0];

gradmin(f, Nmax, e, xk, fopt, ip);

drawfunc(graf1,gr1,xk[0]-(a-xk[0])/5,a);

drawfunc(graf2,gr2,xk[0]-(a-xk[0])/5,a);

if ip=0 then showmessage('Превышено Nmax');

edX1min.text:=floattostr(xk[0]);

edX2min.text:=floattostr(xk[1]);

edFmin.text:=floattostr(fopt);

edN.text:=floattostr(ip);

strF.RowCount:=ip+1;

for i:=1 to ip do

with strF do begin

cells[0,i]:=inttostr(i);

cells[1,i]:=floattostr(gx[i]);

cells[2,i]:=floattostr(gy[i]);

cells[3,i]:=floattostr(round(dta[i]*1000000)/1000000);

end;

drawvekt(srsGraph, gx, gy);

end;

procedure TForm1.gradmin(f:TCelf; m:integer; e:extended; var xo:TVekt;var yopt:extended; var ip:integer);

var

dk: TVekt;

od, lambda, s: extended;

i, n: integer;

function ff(x:extended): extended;

var i: integer;

begin

for i:=0 to n-1 do xo[i]:=xo[i]+abs(x)*dk[i]/od;

ff:=f(xo);

for i:=0 to n-1 do xo[i]:=xo[i]-abs(x)*dk[i]/od;

end;

procedure min(a, b, e:extended; var xm,ym:extended);

var x, y, xo, xk, h:extended;

begin

xo:=a;

xk:=b;

h:=1;

repeat

ym:=1e30;

x:=xo;

while x<=xk do begin

y:=ff(x);

if y<= ym then begin

ym:=y;

xm:=x;

x:=x+h;

end

else break;

end;

if h<e then exit;

xo:=xm-h;

xk:=xm+h;

if xo<a then xo:=a;

if xk>b then xk:=b;

h:=h/5;

until false;

end;

begin

setlength(gx, 0);

setlength(gy, 0);

setlength(gz, 0);

setlength(gr, 0);

addkoord(f, xo);

n:=length(xo);

ip:=0;

lambda:=0;

repeat

dk:=gradient(f, e/2, xo);

for i:=0 to n-1 do dk[i]:=-dk[i];

od:=0;

for i:=0 to n-1 do od:=od+sqr(dk[i]);

od:=sqrt(od);

if od<e then break;

ip:=ip+1;

addkoord(f, xo);

if ip>m then begin

ip:=0;

yopt:=f(xo);

exit;

end;

min(0, 10, e, lambda, s);

dta[ip]:=lambda;

for i:=0 to n-1 do xo[i]:=xo[i]+lambda*dk[i]/od;

until lambda<e;

addkoord(f, xo);

yopt:=f(xo);

end;

procedure TForm1.addkoord(f:TCelf; xo:Tvekt);

var n:integer;

begin

n:=length(gx);

setlength(gx, n+1);

setlength(gy, n+1);

setlength(gz, n+1);

setlength(gr, n+1);

gx[n]:=xo[0];

gy[n]:=xo[1];

if length(xo)>2 then gz[n]:=xo[2] else gz[n]:=0;

gr[n]:=f(xo);

end;

procedure TForm1.drawvekt(series:TArrowSeries; x, y:TVekt);var i:integer;

begin

series.clear;

for i:=0 to length(x)-2 do

series.addarrow(x[i], y[i], x[i+1], y[i+1], '', series.seriescolor);

if p>series.count-1 then p:=series.count-1;

end;

procedure TForm1.drawfunc(series:TLineSeries; f:TFunc; a, b:extended);

var d:extended;

begin

series.clear;

d:=abs(a-b)/100;

while a<b+d do begin

series.addxy(a, f(a), '', series.seriescolor);

a:=a+d;

end;

if p>series.count-1 then p:=series.count-1;

end;

end.

Листинг программы

unit untMain;

Interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

ExtCtrls, StdCtrls, Series, ArrowCha, Math, TeEngine, TeeProcs, Chart,

Grids;

type

TFunc = function (x:extended):extended;

TVekt = array of extended;

TCelf = function (x:TVekt):extended;

TVals = record x, y: extended; end;

TForm1 = class(TForm)

pnlDraw: TPanel;

crtGraph: TChart;

srsAxisY: TLineSeries;

srsAxisX: TLineSeries;

srsGraph: TArrowSeries;

graf1: TLineSeries;

graf2: TLineSeries;

GroupBox1: TGroupBox;

GroupBox2: TGroupBox;

edX1: TEdit;

edX2: TEdit;

edNmax: TEdit;

edE: TEdit;

Label1: TLabel;

Label2: TLabel;

Label3: TLabel;

Label5: TLabel;

edX1min: TEdit;

edX2min: TEdit;

edFmin: TEdit;

edN: TEdit;

Label6: TLabel;

Label7: TLabel;

Label8: TLabel;

Label9: TLabel;

btnWork: TButton;

GroupBox3: TGroupBox;

strF: TStringGrid;

procedure FormCreate(Sender: TObject);

procedure btnWorkClick(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

//Нахождение градиента функции

procedure gradmin(f:TCelf; m:integer; e:extended; var xo:TVekt;

Var yopt:extended; var ip:integer);

//Добавление координат для отрисовки

procedure addkoord(f:TCelf; xo:TVekt);

//Отрисовка графика по векторам

procedure drawvekt(series:TArrowSeries; x, y:TVekt);

//Отрисовка графика по функции

procedure drawfunc(series:TLineSeries; f:TFunc; a, b:extended);

end;

var

Form1: TForm1;

Xk: tVekt;

e, d, fopt: extended;

Nmax, ip:integer;

gx, gy, gz, gr: TVekt;

dta: array [1..100] of extended;

p: integer;

Implementation

function f(x:TVekt):extended;

begin

f:=sqr(exp(x[1])-sqr(x[1])+1)+ sqr(x[1]*sin(x[1])/cos(x[1]));

end;

function gr1(x:extended):extended;

begin

result:=1/(exp(x)-1);

end;

function gr2(x:extended):extended;

begin

result:=-(1/x);

end;

//Нахождение градиента функции

function gradient(f:TCelf; e:extended; x:TVekt): TVekt;

var

n, i: integer;

fp, fo: extended;

g: TVekt;

begin

n:=length(x);

setlength(g,n);

for i:= 0 to n-1 do begin

x[i]:=x[i]+e;

fp:=f(x);

x[i]:=x[i]-2*e;

fo:=f(x);

x[i]:=x[i]+e;

g[i]:=(fp-fo)/(2*e);

end;

gradient:=g;

end;

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);

begin

with strF do begin

cells[0,0]:='№ итерации';

cells[1,0]:=' X1';

cells[2,0]:=' X2';

cells[3,0]:='DELTA';

end;

setlength(xk, 2);

try

xk[0]:=strtofloat(edX1.Text);

except

ShowMessage('Ошибка ввода данных!');

Exit;

end;

try

xk[1]:=strtofloat(edX2.text);

except

ShowMessage('Ошибка ввода данных!');

Exit;

end;

try

Nmax:=strtoint(edNmax.Text);

except

ShowMessage('Ошибка ввода данных!');

Exit;

end;

try

e:=strtofloat(edE.text);

except

ShowMessage('Ошибка ввода данных!');

Exit;

end;

end;

procedure TForm1.btnWorkClick(Sender: TObject);

var a:extended; i:integer;

begin

Form1.oncreate(Form1);

a:=xk[0];

gradmin(f, Nmax, e, xk, fopt, ip);

drawfunc(graf1,gr1,xk[0]-(a-xk[0])/5,a);

drawfunc(graf2,gr2,xk[0]-(a-xk[0])/5,a);

if ip=0 then showmessage('Превышено Nmax');

edX1min.text:=floattostr(xk[0]);

edX2min.text:=floattostr(xk[1]);

edFmin.text:=floattostr(fopt);

edN.text:=floattostr(ip);

strF.RowCount:=ip+1;

for i:=1 to ip do

with strF do begin

cells[0,i]:=inttostr(i);

cells[1,i]:=floattostr(gx[i]);

cells[2,i]:=floattostr(gy[i]);

cells[3,i]:=floattostr(round(dta[i]*1000000)/1000000);

end;

drawvekt(srsGraph, gx, gy);

end;

procedure TForm1.gradmin(f:TCelf; m:integer; e:extended; var xo:TVekt;var yopt:extended; var ip:integer);

var

dk: TVekt;

od, lambda, s: extended;

i, n: integer;

function ff(x:extended): extended;

var i: integer;

begin

for i:=0 to n-1 do xo[i]:=xo[i]+abs(x)*dk[i]/od;

ff:=f(xo);

for i:=0 to n-1 do xo[i]:=xo[i]-abs(x)*dk[i]/od;

end;

procedure min(a, b, e:extended; var xm,ym:extended);

var x, y, xo, xk, h:extended;

begin

xo:=a;

xk:=b;

h:=1;

repeat

ym:=1e30;

x:=xo;

while x<=xk do begin

y:=ff(x);

if y<= ym then begin

ym:=y;

xm:=x;

x:=x+h;

end

else break;

end;

if h<e then exit;

xo:=xm-h;

xk:=xm+h;

if xo<a then xo:=a;

if xk>b then xk:=b;

h:=h/5;

until false;

end;

begin

setlength(gx, 0);

setlength(gy, 0);

setlength(gz, 0);

setlength(gr, 0);

addkoord(f, xo);

n:=length(xo);

ip:=0;

lambda:=0;

repeat

dk:=gradient(f, e/2, xo);

for i:=0 to n-1 do dk[i]:=-dk[i];

od:=0;

for i:=0 to n-1 do od:=od+sqr(dk[i]);

od:=sqrt(od);

if od<e then break;

ip:=ip+1;

addkoord(f, xo);

if ip>m then begin

ip:=0;

yopt:=f(xo);

exit;

end;

min(0, 10, e, lambda, s);

dta[ip]:=lambda;

for i:=0 to n-1 do xo[i]:=xo[i]+lambda*dk[i]/od;

until lambda<e;

addkoord(f, xo);

yopt:=f(xo);

end;

procedure TForm1.addkoord(f:TCelf; xo:Tvekt);

var n:integer;

begin

n:=length(gx);

setlength(gx, n+1);

setlength(gy, n+1);

setlength(gz, n+1);

setlength(gr, n+1);

gx[n]:=xo[0];

gy[n]:=xo[1];

if length(xo)>2 then gz[n]:=xo[2] else gz[n]:=0;

gr[n]:=f(xo);

end;

procedure TForm1.drawvekt(series:TArrowSeries; x, y:TVekt);var i:integer;

begin

series.clear;

for i:=0 to length(x)-2 do

series.addarrow(x[i], y[i], x[i+1], y[i+1], '', series.seriescolor);

if p>series.count-1 then p:=series.count-1;

end;

procedure TForm1.drawfunc(series:TLineSeries; f:TFunc; a, b:extended);

var d:extended;

begin

series.clear;

d:=abs(a-b)/100;

while a<b+d do begin

series.addxy(a, f(a), '', series.seriescolor);

a:=a+d;

end;

if p>series.count-1 then p:=series.count-1;

end;

end.

Соседние файлы в предмете Исследование операций