Параметрична оптимізація економічних процесів

Memo1.Clear;

Case RadioGroup1.ItemIndex of

0:My;

1:Mk;

//2: Mpr;

end;

Button2.Enabled:=true;

end;

procedure TForm1.Button2Click(Sender: TObject);

var

i:integer;                                                                     

eg,deg,ym:real;

Xmy:Tar1_rn;

Ymy:Tar1_rk;

begin

Xmy[1]:=StrToFloat(Edit1.Text);

Xmy[2]:=StrToFloat(Edit2.Text);

Xmy[3]:=StrToFloat(Edit3.Text);

Xmy[4]:=StrToFloat(Edit4.Text);

Series1.Clear;

Series2.Clear;

deg:=(X2[4]-X1[4])/10;

for i:=1 to 11 do

begin

  eg:=X1[4]+(i-1)*deg;

  Xmy[4]:=eg;

  Value_Y(Xmy,Ymy);

  Series1.AddXY(eg,Ymy[1]);

  Series2.AddXY(eg,Ymy[2]);

end;

end;

procedure TForm1.FormCreate(Sender: TObject);

begin

TabSheet2.Show;

StringGrid1.Cells[0,0]:='Хар-ка';

StringGrid1.Cells[1,0]:='Y -';

StringGrid1.Cells[2,0]:='Y +';

StringGrid1.Cells[3,0]:='KY';

StringGrid1.Cells[0,1]:='C,тис.грн/рік';

StringGrid1.Cells[0,2]:='Q, тис.м^3/рік';

StringGrid1.Cells[0,3]:='P1/P2, - ';

StringGrid1.Cells[0,4]:=' ';

StringGrid1.Cells[0,5]:=' ';

StringGrid2.Cells[0,0]:='';

StringGrid2.Cells[1,0]:='Х -';

StringGrid2.Cells[2,0]:='X +';

StringGrid2.Cells[3,0]:='KX';

Продовж. Додатку А

StringGrid2.Cells[0,1]:='D, дюйм';

StringGrid2.Cells[0,2]:='P1, атм';

StringGrid2.Cells[0,3]:='P2, атм';

StringGrid2.Cells[0,4]:='L, км';

StringGrid3.Cells[0,0]:='';

StringGrid3.Cells[1,0]:='Вага';

StringGrid3.Cells[0,1]:='';

StringGrid3.Cells[0,2]:='';

StringGrid3.Cells[0,3]:='';

StringGrid3.Cells[0,4]:='';

StringGrid3.Cells[0,5]:='';

StringGrid3.ColWidths[0]:=1;

StringGrid1.Cells[1,1]:='100';

StringGrid1.Cells[1,2]:='1200';

StringGrid1.Cells[1,3]:='1,1';

StringGrid1.Cells[2,1]:='1500';

StringGrid1.Cells[2,2]:='5000';

StringGrid1.Cells[2,3]:='6';

StringGrid1.Cells[3,1]:='2';

StringGrid1.Cells[3,2]:='1';

StringGrid1.Cells[3,3]:='0';

StringGrid2.Cells[1,1]:='10';

StringGrid2.Cells[1,2]:='5';

StringGrid2.Cells[1,3]:='2';

StringGrid2.Cells[1,4]:='10';

StringGrid2.Cells[2,1]:='40';

StringGrid2.Cells[2,2]:='10';

StringGrid2.Cells[2,3]:='3,8';

StringGrid2.Cells[2,4]:='50';

StringGrid2.Cells[3,1]:='1';

StringGrid2.Cells[3,2]:='1';

StringGrid2.Cells[3,3]:='1';

StringGrid2.Cells[3,4]:='1';

StringGrid3.Cells[1,1]:='0,5';

StringGrid3.Cells[1,2]:='0,5';

StringGrid3.Cells[1,3]:='0';

end;

procedure TForm1.Button3Click(Sender: TObject);

begin

Application.Terminate;

end;

Продовж. Додатку А

procedure TForm1.Button4Click(Sender: TObject);

begin

Form1.Memo1.Lines.Add('Попередня оцінка)');

In_OX;

In_OY;

Prov_OY(X,by);

if by=true then Form1.Memo1.Lines.Add(' Область допустима')

           else Form1.Memo1.Lines.Add(' Область не допустима');

Vyvod;

end;

procedure TForm1.RadioGroup1Click(Sender: TObject);

begin

if RadioGroup1.ItemIndex=1 then begin

label7.Visible:=true;

Edit5.Visible:=true;

end else begin

label7.Visible:=false;

Edit5.Visible:=false;

end;

end;

//Показати доп. область

procedure TForm1.Button6Click(Sender: TObject);

begin

  With StringGrid2 do begin

  Cells[1,2]:=Edit2.Text;      Cells[3,2]:='0';

  Cells[1,3]:=Edit3.Text;      Cells[3,3]:='0';

  end;

  D_Mk;

PageControl2.Show;

end;

end.

Продовж. Додатку А

А1. Модуль процедур оптимізації Unit2

unit Unit2;

interface

uses

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

  StdCtrls;

const

  n=4;

  k=3;

  m=17;

alfa=1.3;

  mxv=10000;

  mxz=10;

  epsilon=0.01;

  delta=  0.01;

  extr='min';

type Tar1_rn=array [1..n] of real;

type Tar1_rk=array [1..k] of double;

type Tar1_rm=array [1..m] of real;

type Tar2_r=array [1..m,1..n] of real;

type Tar1_bk=array [1..k] of byte;

type Tar1_bn=array [1..n] of byte;

var

    i,j,ix,nz,nv : word;

    X,X1,X2,CX:Tar1_rn;

    sX,rX:Tar1_rn;

    TX:Tar2_r;

    YN,YV,Y,Y1,Y2,v:Tar1_rk;

    KX:Tar1_bn;

    KY:Tar1_bk;

    G:Tar1_rm;

    N_mk:integer;

b,bx,by:boolean; ug,ux:real; Wx:real; ft:text;

Cs,Qsum,Rsum,eg1,e1,e2,pg0,pg,Rog,Roh,dn,Rb,alf,Vce,

v1,v2:real; J1,J2,J3,J4,J5:real;

procedure Vyvod;

procedure My;

procedure Mk;

procedure D_Mk;

Procedure In_OX;

Procedure In_OY;

function FToS(F:Real;a,b:Byte):String;

Procedure Prov_OY(X:Tar1_rn;var b:boolean);

Procedure Prov2_OY(X:Tar1_rn;var b:boolean);

Procedure Value_Y(X:Tar1_rn;var Y:Tar1_rk);

Продовж. Додатку А

implementation

uses unit1;

// точка ---> запятая

function T_Z(S:string):string;

var k,l:word;

begin

k:=Length(S);

for l:=0 to k-1 do if s[l]='.' then s[l]:=',';

Result:=S;

end;

//  Format Float To String

function FToS(F:Real;a,b:Byte):String;

var

s:string;

begin

str(F:a:b,s);

Result:=T_Z(S);

end;

Procedure Outs_X(B:Tar1_rn);

var

j:word;

begin

for j:=1 to n do

  begin

   Form1.Memo1.Text:=Form1.Memo1.Text+FToS(B[j],10,3);

  end;

end;

Procedure In_OX;

var i:word;

begin

with Form1.StringGrid2 do

begin

  X1[1]:=StrToReal(Cells[1,1]); X2[1]:=StrToReal(Cells[2,1]); KX[1]:=StrToInt(Cells[3,1]);

  X1[2]:=StrToReal(Cells[1,2]); X2[2]:=StrToReal(Cells[2,2]); KX[2]:=StrToInt(Cells[3,2]);

  X1[3]:=StrToReal(Cells[1,3]); X2[3]:=StrToReal(Cells[2,3]); KX[3]:=StrToInt(Cells[3,3]);

  X1[4]:=StrToReal(Cells[1,4]); X2[4]:=StrToReal(Cells[2,4]); KX[4]:=StrToInt(Cells[3,4]);

end;

for i:=1 to 4 do X[i]:=0.5*(X1[i]+X2[i]);

end;

Procedure In_OY;

begin

with Form1.StringGrid1 do

begin

  Y1[1]:=StrToReal(Cells[1,1]); Y2[1]:=StrToReal(Cells[2,1]); KY[1]:=StrToInt(Cells[3,1]);

  Y1[2]:=StrToReal(Cells[1,2]); Y2[2]:=StrToReal(Cells[2,2]); KY[2]:=StrToInt(Cells[3,2]);

Продовж. Додатку А

  Y1[3]:=StrToReal(Cells[1,3]); Y2[3]:=StrToReal(Cells[2,3]); KY[3]:=StrToInt(Cells[3,3]);

end;

with Form1.StringGrid3 do

begin

  v[1]:=StrToReal(Cells[1,1]);

  v[2]:=StrToReal(Cells[1,2]);

  v[3]:=StrToReal(Cells[1,3]);

end;

end;

Procedure Value_Y(X:Tar1_rn;var Y:Tar1_rk);

var

i:word;

r,fr,f,p1,p2:real;

begin

if X[3]>X[2] then X[3]:=0.9*X[2];

p1:=X[2]*2.5;

p2:=X[3]*2.5;

r:=X[2]/X[3];

Y[3]:=r;

fr:=X[1]*X[1];

f:=sqrt(0.008/fr/fr/fr/fr);

Y[2]:=3.39*sqrt((p1*p1-p2*p2)*fr*fr*X[1]/f/X[4]/1.38)/1000;

Y[1]:=(7.84*fr*p1+45000+36900*X[1]+6.57e6/X[4]/1.38+7.72e6/X[4]/1.38*(exp(0.219*ln(r))))/1000;

Cs:=Y[1];

Qsum:=Y[2];

Rsum:=Y[3];

  for  i:=1 to 3 do begin

  YN[i]:=Y[i]/Y1[i];

  YV[i]:=Y2[i]/Y[i]

  end;

end;

procedure Vyvod;

begin

Form1.Memo1.Lines.Add('D='+ftos(X[1],10,2)+' дюйм;  Р1='+ftos(X[2],7,2)+' атм');

Form1.Memo1.Lines.Add(' Р2='+ftos(X[3],7,2)+' атм;  L='+ftos(X[4],7,2)+' км');

form1.Edit1.Text:=FloatToStr(Round(X[1]*1000)/1000);

form1.Edit2.Text:=FloatToStr(Round(X[2]*1000)/1000);

form1.Edit3.Text:=FloatToStr(Round(X[3]*1000)/1000);

form1.Edit4.Text:=FloatToStr(Round(X[4]*1000)/1000);

Form1.Memo1.Lines.Add(' С = '+ftos(Cs,5,0)+' тис.грн/рік');

Form1.Memo1.Lines.Add(' Q = '+ftos(Qsum,5,0)+' тис.м^3/рік');

Form1.Memo1.Lines.Add(' P1/P2 ='+ftos(Rsum,5,3));

end;

function W(X:Tar1_rn):real;

var

S:real;

Продовж. Додатку А

i:word;

Yn:Tar1_rk;

begin

  for i:=1 to k do Yn[i]:=0;

  for i:=1 to k do

  begin

    if KY[i]=0 then continue;

    if KY[i]=1 then Yn[i]:=Y1[i]/Y[i];

    if KY[i]=2 then Yn[i]:=Y[i]/Y1[i];

    if KY[i]=3 then Yn[i]:=2*Y[i]/(Y1[i]+Y2[i]);

  end;

  Case Form1.RadioGroup2.ItemIndex of

  0: W:=Yn[1]*V[1]-Yn[2]*V[2]+Yn[3]*V[3];

  1: begin

     s:=1;

//     if (v[i]=0)or(KY[i]=0)or(KY[i]=3) then Continue;

     if (v[i]<>0)and(KY[i]=1) then for i:=1 to k do s:=s/Yn[i];

     if (v[i]<>0)and(KY[i]=2) then for i:=1 to k do s:=s*Yn[i];

     W:=s;

     end;

  2: begin

     //  MinMax

     end;

  end;

end;

Procedure Generate_X(var X:Tar1_rn);

var

a:real;

j:word;

begin

Randomize;

for j:=1 to n do

  begin

   a:=Random(1000)/1000;

   X[j]:=X1[j]+a*(X2[j]-X1[j]);

  end;

end;

Procedure Prov2_OY(X:Tar1_rn;var b:boolean);

var

i:word;

begin

Value_Y(X,Y);

b:=true;

for i:=1 to k do

  begin

   if KY[i]=0 then Continue;

   if KY[i]=1 then

    if Y[i]<1 then begin b:=false; Break; end;

   if KY[i]=2 then

Продовж. Додатку А

    if Y[i]>1 then begin b:=false; Break; end;

   if KY[i]=3 then

    if (Y[i]<1)or(Y[i]>1) then begin b:=false; Break; end

     else

     begin

     end;

  end;

end;

Procedure Prov_OY(X:Tar1_rn;var b:boolean);

var

i:word;

begin

Value_Y(X,Y);

b:=true;

for i:=1 to k do

  begin

   if KY[i]=0 then Continue;

   if KY[i]=1 then

    if YN[i]<1 then begin b:=false; Break; end;

   if KY[i]=2 then

    if YV[i]<1 then begin b:=false; Break; end;

   if KY[i]=3 then

    if (YN[i]<1)or(YV[i]<1) then begin b:=false; Break; end

     else

     begin

     end;

  end;

end;

Procedure Prov_OX(X:Tar1_rn;var b:boolean);

var

j:word;

begin

b:=true;

for j:=1 to n do

  begin

  if KX[j]=0 then Continue

   else

   if (X[j]<X1[j])or(X[j]>X2[j]) then begin b:=false; Break; end;

  end;

end;

Procedure Generate_TX(var b:boolean);

var

  i,j,k2:word;

Procedure Generate_X(var X:Tar1_rn);

var

a:real;

j:word;

begin

Продовж. Додатку А

Randomize;

for j:=1 to n do

  begin

   a:=Random(1000)/1000;

   X[j]:=X1[j]+a*(X2[j]-X1[j]);

  end;

end;

Begin

i:=0;

k2:=0;

b:=true;

While (i<m)and(k2<10000) do

begin

  k2:=k2+1;

  Generate_X(X);

  Prov_OY(X,b);

   if b=false then Continue

    else

     begin

      i:=i+1;

      for j:=1 to n do TX[i,j]:=X[j];

     end;

  end;

if K2>=9998 then  begin ShowMessage('Допустима область не знайдена!!');

    b:=false end;

End;

Procedure Value_G(var G:Tar1_rm);

var

i,j:word;

begin

for i:=1 to m do

begin

  for j:=1 to n do X[j]:=TX[i,j];

  G[i]:=W(X);

end;

end;

Procedure Extr_W(G:Tar1_rm;var ix:word);

var

i,imx,imn:word;

mx,mn:real;

begin

mx:=G[1]; mn:=G[1]; imx:=1;imn:=1;

for i:=2 to m do

  if G[i]>mx then begin mx:=G[i]; imx:=i; end

   else

  if G[i]<mn then begin mn:=G[i]; imn:=i; end;

if extr='min' then ix:=imx else ix:=imn;

end;

Продовж. Додатку А

Procedure Center_X(ix:word;var CX:Tar1_rn);

var

i,j,m1:word;

begin

if ix=0 then m1:=m else m1:=m-1;

for j:=1 to n do

begin

  CX[j]:=0;

  for i:=1 to m do

   if i<>ix then CX[j]:=CX[j]+TX[i,j];

  CX[j]:=CX[j]/m1;

end;

end;

Procedure Sdvig_X(var X:Tar1_rn);

var

j:word;

begin

for j:=1 to n do X[j]:=(X[j]+CX[j])/2;

Prov_OY(X,b);

end;

Procedure Vidobr_X(var X:Tar1_rn);

var

j:word;

begin

ix:=0;

for j:=1 to n do X[j]:=CX[j]+alfa*(CX[j]-X[j]);

end;

Procedure End_it(var sX,rX:Tar1_rn;var ug,ux:real);

var

i,j:word;

sg:real;

begin

sg:=0;

for i:=1 to m do sg:=sg+G[i];

sg:=sg/m;

ug:=0;

for i:=1 to m do ug:=ug+sqr(G[i]-sg);

ug:=ug/m;

Center_X(0,sX);

for j:=1 to n do

begin

  rX[j]:=0;

  for i:=1 to m do rX[j]:=rX[j]+sqr(TX[i,j]-sX[j]);

  rX[j]:=rX[j]/m;

end;

ux:=rX[1];

for j:=2 to n do

if rX[j]>ux then ux:=rX[j];

Продовж. Додатку А

end;

Procedure Step_it(ix:word;var X:Tar1_rn;var Wx:real;var nz:word);

var

j:word;

We:real;

function z(z1,z2:real):boolean;

var

t:boolean;

begin

if extr='min' then

  if z1<z2 then t:=true else t:=false

else

  if z1>z2 then t:=true else t:=false;

z:=t;

end;

procedure It_sdvig;

begin

nz:=0;

Repeat

Sdvig_X(X); Wx:=W(X);

nz:=nz+1;

Until ((b=true)and(z(Wx,We)=true)or(nz>mxz));

end;

begin

for j:=1 to n do X[j]:=TX[ix,j];

We:=G[ix];

Vidobr_X(X);

Wx:=W(X);

Prov_OY(X,by);

Prov_OX(X,bx);

b:=by and bx;

if (b=true)and(z(Wx,We)=true) then Exit;

if (b=true)and(z(Wx,We)=false) then It_sdvig;

if (b=false) then It_sdvig;

end;

//Method of romplex

procedure My;

Label 1;

Begin

b:=true;

Randomize;

In_OX;

In_OY;

Generate_TX(b);

if b=false then Exit;

Form1.Memo1.Lines.Add('**************');

Value_G(G);

Продовж. Додатку А

nv:=1;

Repeat

Extr_W(G,ix);

i:=ix;

Center_X(ix,CX);

Prov_OY(CX,b);

if b=false then  Goto 1;

Step_it(ix,X,Wx,nz);

for j:=1 to n do TX[i,j]:=X[j];

G[i]:=Wx;

nv:=nv+1;

if nv>mxv then

  begin

   Form1.Memo1.Lines.Add('Допущена кiлькiсть вiдображень вичерпано');

   End_it(sX,rX,ug,ux); Goto 1;

  end;

End_it(sX,rX,ug,ux);

Until  (ug<=epsilon)and(ux<=delta);

1:

Form1.Memo1.Lines.Add('Розв''язок (екстемальна точка комплексу)');

Vyvod;

Extr_W(G,ix);

for j:=1 to n do X[j]:=TX[ix,j];

Wx:=G[ix];

for j:= 1 to n do X[j]:=TX[ix,j];

Wx:=G[ix];

Form1.Memo1.Lines.Add('Значення по критерию epsilon='+ftos(ug,8,5));

Form1.Memo1.Lines.Add('Значення по критерию delta  ='+ftos(ux,8,5));

//Close(ft);

end;

//Method of Monte-Karlo

procedure Mk;

Var

W_n,W_t:real;

b:boolean;

i,j,Np:byte;

Begin

Form1.Memo1.Clear;

N_mk:=StrToInt(Form1.Edit5.Text);

Randomize;

In_OX;

In_OY;

W_n:=1e10;

Np:=0;

For i:=1 to N_mk do begin

Generate_X(X);

Value_Y(X,Y);

Prov_OY(X,b);

if b=false then continue;

Продовж. Додатку А

  W_t:=W(X);

  Np:=Np+1;

  if W_t<W_n then begin W_n:=W_t; sX:=X; YN:=Y end;

end;    //tnd of For i:=1

Form1.Memo1.Lines.Add('Проведено '+IntTostr(N_mk)+' испытаний методом Монте-Карло');

Form1.Memo1.Lines.Add('Крітерій W= '+FToS(W_t,6,4));

Form1.Memo1.Lines.Add('D = '+FToS(X[1],6,2)+' дюйм');

Form1.Memo1.Lines.Add('P1= '+FToS(X[2],6,2)+' атм');

Form1.Memo1.Lines.Add('P2= '+FToS(X[3],6,2)+' атм');

Form1.Memo1.Lines.Add('L = '+FToS(X[4],6,2)+' км');

Form1.Edit1.Text:=FToS(X[1],6,2);

Form1.Edit2.Text:=FToS(X[2],6,2);

Form1.Edit3.Text:=FToS(X[3],6,2);

Form1.Edit4.Text:=FToS(X[4],6,2);

For i:=1 to 4 do Form1.StringGrid2.Cells[1,i]:=FToS(X[i],6,2);

End;

//Dop. M-K of Monte-Karlo

procedure D_Mk;

Var

W_n,W_t:real;

b:boolean;

i,j,Np:byte;

Begin

Form1.Series3.Clear;

N_mk:=StrToInt(Form1.Edit5.Text);

In_OX;

In_OY;

Np:=0;

For i:=1 to N_mk do begin

Randomize;

Generate_X(X);

Value_Y(X,Y);

b:=true;

Prov_OY(X,b);

if b=false then continue;

Np:=Np+1;

Form1.Series3.AddXY(X[4],X[1]);

end;    //tnd of For i:=1

Form1.Label11.Caption:=

IntToStr(Np)+' точок у доп.області із '+Form1.Edit5.Text+' випробувань ';

End;

end.