Если у вас возникли сложности с курсовой, контрольной, дипломной, рефератом, отчетом по практике, научно-исследовательской и любой другой работой - мы готовы помочь.
Предоплата всего
Подписываем
type
TMio = class(TForm)
condition: TPanel;
ogr1: TEdit;
ogr2: TEdit;
ogr3: TEdit;
ogr4: TEdit;
ogr5: TEdit;
ogr6: TEdit;
ogr7: TEdit;
ogrminus: TSpeedButton;
ogrplus: TSpeedButton;
Ogr: TLabel;
Exit: TSpeedButton;
Help: TSpeedButton;
Calculate: TSpeedButton;
func: TEdit;
FuncLabel: TLabel;
Open: TSpeedButton;
Save: TSpeedButton;
OpenFile: TOpenDialog;
SaveFile: TSaveDialog;
procedure ogrplusClick(Sender: TObject);
procedure ExitClick(Sender: TObject);
procedure OpenClick(Sender: TObject);
procedure SaveClick(Sender: TObject);
procedure HelpClick(Sender: TObject);
procedure CalculateClick(Sender: TObject);
procedure funcChange(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Mio: TMio;
m:integer=3;//количество ограничений
minmax:boolean=false;
endc:boolean;//признак окончания решения
n:integer;//количество переменных
a:array[0..10,0..7,0..12] of Real;//массив решений задачи
Ab:array[0..10,0..7] of integer;
Cj1,Cj:array[0..12] of Real;//массив базисных переменных
i,j:integer;
counter:integer;//счетчик итераций
b:array [0..7,0..12] of Real;
Cb:array [0..10,0..6] of Real;
onmax:boolean=false;//направление поиска
delta:array [0..10,0..12] of Real;//массив симплекс разностей
optimum:real;
correct:boolean;
zogr:boolean;
implementation
uses TablCalc, tablhelp;
{$R *.DFM}
function ogrcorrectfill:boolean;//проверка правильности заполнения ограничений
var
ss,s:string;
k,i,j:integer;
begin
zogr:=true;
correct:=true;
for k:=1 to m do
begin
if k=1 then
s:=mio.ogr1.text;
if k=2 then
s:=mio.ogr2.text;
if k=3 then
s:=mio.ogr3.text;
if k=4 then
s:=mio.ogr4.text;
if k=5 then
s:=mio.ogr5.text;
if k=6 then
s:=mio.ogr6.text;
if k=7 then
s:=mio.ogr7.text;
for j:=1 to strlen(pchar(s))-1 do
begin
if strlen(pchar(s))=0 then
correct:=false;
ss:=copy(s,j,2);
if ss='>=' then
begin
miomain.correct:=false;
miomain.zogr:=false;
end;
end;
end;
if zogr=false then
showmessage('Все ограничения должны иметь знак <=');
end;
procedure Func;//нахождение коэффициентов целевой функции
var
s:string;
s2,s1:string;
maxj:integer;
still:boolean;
return:boolean;
begin
maxj:=0;
for j:=0 to 4 do
Cj[j]:=0;
n:=0;
s:=mio.func.text;
if strlen(pchar(s))=0 then correct:=false;
j:=0;
i:=1;
still:=true;
if uppercase(copy(s,1,1))='X' then
begin
j:=strtoint(copy(s,2,1));
Cj[j-1]:=1;
i:=3
end;
while i<=strlen(pchar(s)) do
begin
s1:='';
s2:=copy(s,i,1);
if still=true then
begin
while ((uppercase(s2)<>'X')
and (s2<>'=') and (
still=true)) do
begin
if s2='=' then
still:=false;
i:=i+1;
s1:=s1+s2;
s2:=copy(s,i,1);
end;
if uppercase(s2)='X' then
begin
j:=strtoint(copy(s,i+1,1));
if j>maxj then
maxj:=j;
end;
if ((strlen(pchar(s1))>0) and
(still=true)) then
begin
if ((s1='-') or (s1='+')) then
s1:=s1+'1';
Cj[j-1]:=strtoint(s1);
end;
if s2='=' then
still:=false;
end;
s1:='';
i:=i+2;
end;
n:=maxj;
for i:=n to n+m do
Cj[i]:=0;
end;
procedure Ogr;//нахождение коэффициентов при переменных в ограничениях
var
s:string;
s2,s1:string;
s22:integer;
still:boolean;
k:integer;
begin
ogrcorrectfill;
if zogr=true then
begin
for k:=0 to m-1 do
begin
if k=0 then
s:=mio.ogr1.text;
if k=1 then
s:=mio.ogr2.text;
if k=2 then
s:=mio.ogr3.text;
if k=3 then
s:=mio.ogr4.text;
if k=4 then
s:=mio.ogr5.text;
if k=5 then
s:=mio.ogr6.text;
if k=6 then
s:=mio.ogr7.text;
j:=0;
i:=1;
still:=true;
if uppercase(copy(s,1,1))='X' then
begin
j:=strtoint(copy(s,2,1));
a[0,k,j]:=1;
i:=3
end;
while i<=strlen(pchar(s)) do
begin
s1:='';
s2:=copy(s,i,1);
if still=true then
begin
while ((uppercase(s2)<>'X') and
(s2<>'=') and
(s2<>'<') and
(still=true)) do
begin
if s2='=' then
still:=false;
i:=i+1;
s1:=s1+s2;
s2:=copy(s,i,1);
end;
if ((strlen(pchar(s1))>0) and (still=true)) then
begin
if uppercase(s2)='X'
then j:=strtoint(copy(s,i+1,1));
if ((s1='-') or (s1='+')) then
s1:=s1+'1';
a[0,k,j]:=strtoint(s1);
end;
if ((s2='=') or (s2='<') or (s2='>')) then
still:=false;
end;
s1:='';
i:=i+2;
end;
s22:=pos('=',s);
a[0,k,0]:=strtofloat(copy(s,s22+1,strlen(pchar(s))-s22));
end;
end;
end;
procedure calc;
var
min:real;
mins:real;
temp:real;
tempa:integer;
index_col,index_str:integer;
f:textfile;
found:boolean;
begin
counter:=0;
for i:=0 to m do
for j:=0 to n+m do
a[counter,i,j]:=0;
for j:=0 to n+m do
delta[counter,j]:=0;
for j:=0 to m-1 do
Cb[counter,j]:=0;
func;
ogr;
if miomain.correct=true then
begin
for i:=0 to m-1 do
a[counter,i,i+n+1]:=1;
//канонизация задачи
endc:=false;
for j:=0 to m+n do
Ab[counter,j-m]:=0;
for j:=0 to m-1 do
Ab[counter,j]:=n+j+1;
while (counter<=9) and (endc=false) do
begin
for j:=0 to n+m do
delta[counter,j]:=0;
//расчет симплекс разностей
for j:=0 to n+m do
begin
for i:=0 to m-1 do
delta[counter,j]:=delta[counter,j]+Cb[counter,i]*a[counter,i,j];
if j<>0 then delta[counter,j]:=delta[counter,j]-Cj[j-1];
end;
//проверка на оптимальность
endc:=true;
if onmax=true then
for i:=0 to m+n do
if delta[counter,i]<0 then
endc:=false;
if onmax=false then
for i:=0 to m+n do
if delta[counter,i]>0 then
endc:=false;
//поиск направляющего столбца
min:=delta[counter,1];
index_col:=1;
if onmax=true then
for j:=0 to n+m do
if delta[counter,j]<min then
begin
min:=delta[counter,j];
index_col:=j
end;
if onmax=false then
for j:=0 to n+m do
if delta[counter,j]>min then
begin
min:=delta[counter,j];
index_col:=j
end;
//поиск направляющей строки
index_str:=0;
j:=0;
found:=false;
for i:=0 to m-1 do
if ((a[counter,i,0]>0 )and
(a[counter,i,index_col]>0) and
(found=false))then
begin
mins:=a[counter,i,0]/a[counter,i,index_col];found:=true ;
index_str:=i
end;
for i:=0 to m-1 do
if ((a[counter,i,0]>0 )and
(a[counter,i,index_col]>0) and
(a[counter,i,0]/a[counter,i,index_col]<=mins)) then
begin
mins:=a[counter,i,0]/a[counter,i,index_col];
index_str:=i;
end;
for j:=0 to n+m do
Cj1[j]:=Cj[j];
for j:=0 to n+m do
begin
temp:=a[counter,index_str,j]/a[counter,index_str,index_col];
b[index_str,j]:=temp;
end;
//заполнение таблицы
for j:=0 to n+m do
Cj[j]:=Cj1[j];
for i:=0 to m-1 do
if i<>index_str then
for j:=0 to n+m do
b[i,j]:=a[counter,i,j]-b[index_str,j]*a[counter,i,index_col];
for i:=0 to m-1 do
begin
temp:=Cb[counter,i];
Cb[counter+1,i]:=temp;
tempa:=Ab[counter,i];
Ab[counter+1,i]:=tempa
end;
for i:=0 to m-1 do
if i=index_str then
begin
temp:=Cj[index_col-1];
Cb[counter+1,i]:=temp;
Ab[counter+1,i]:=index_col;
end
else
Ab[counter+1,i]:=Ab[counter+1,i];
for i:=0 to m-1 do
for j:=0 to n+m do
a[counter+1,i,j]:=b[i,j];
if endc=true then
tablres.answer.tabvisible:=true;
counter:=counter+1;
end;
if counter=10 then
begin
showmessage('Программа не смогла выполнить расчет,'+
'так как необходимо слишком много итераций');
counter:=9;
end;
if counter<=9 then tablres.showmodal;
end;
end;
Procedure FillVar;
//чтение целевой функции и ограничений из файла
var
fil:text;
fun,ogr:string;
begin
AssignFile(fil,mio.openfile.filename);
reset(fil);
mio.ogr1.visible:=false;
mio.ogr2.visible:=false;
mio.ogr3.visible:=false;
mio.ogr4.visible:=false;
mio.ogr5.visible:=false;
mio.ogr6.visible:=false;
mio.ogr7.visible:=false;
if not eof(fil) then
begin
readln(fil,fun);
if UpperCase(copy(fun,1,4))='FMIN' then
begin
Onmax:=false;
fun:=copy(fun,6,strlen(pchar(fun)))+'=min'
end;
if UpperCase(copy(fun,1,4))='FMAX' then
begin
Onmax:=true;
fun:=copy(fun,6,strlen(pchar(fun)))+'=max'
end;
mio.func.text:=fun
end;
m:=0;
while ((not eof(fil)) and (m<7)) do
begin
m:=m+1;
if m=1 then
begin
mio.ogr1.visible:=true;
readln(fil,ogr);
mio.ogr1.text:=ogr
end;
if m=2 then
begin
mio.ogr2.visible:=true;
readln(fil,ogr);
mio.ogr2.text:=ogr
end;
if m=3 then
begin
mio.ogr3.visible:=true;
readln(fil,ogr);
mio.ogr3.text:=ogr
end;
if m=4 then
begin
mio.ogr4.visible:=true;
readln(fil,ogr);
mio.ogr4.text:=ogr
end;
if m=5 then
begin
mio.ogr5.visible:=true;
readln(fil,ogr);
mio.ogr5.text:=ogr
end;
if m=6 then
begin
mio.ogr6.visible:=true;
readln(fil,ogr);
mio.ogr6.text:=ogr
end;
if m=7 then
begin
mio.ogr7.visible:=true;
readln(fil,ogr);
mio.ogr7.text:=ogr
end;
end;
CloseFile(fil)
end;
Procedure SaveVar;
//сохранение целевой функции и ограничений в файле
var
fil:text;
fnc:string;
num:integer;
begin
AssignFile(fil,mio.SaveFile.filename+'.dat');
rewrite(fil);
fnc:='F'+copy(mio.func.text,strlen(pchar(mio.func.text))-2,3)+'='+copy(mio.func.text,1,strlen(pchar(mio.func.text))-4);
writeln(fil,fnc);
for num:=1 to m do
begin
if num=1 then writeln(fil,mio.ogr1.text);
if num=2 then
writeln(fil,mio.ogr2.text);
if num=3 then
writeln(fil,mio.ogr3.text);
if num=4 then
writeln(fil,mio.ogr4.text);
if num=5 then
writeln(fil,mio.ogr5.text);
if num=6 then
writeln(fil,mio.ogr6.text);
if num=7 then
writeln(fil,mio.ogr7.text);
end;
CloseFile(fil)
end;
procedure TMio.ogrplusClick(Sender: TObject);
//добавление или удаление ограничений
begin
if sender=ogrplus then
begin
m:=m+1;
if m>7 then
m:=7;
end;
if sender=ogrminus then
begin
m:=m-1;
if m<1 then
m:=1;
end;
if m=1 then
begin
ogr1.visible:=true;
ogr2.visible:=false;
ogr2.text:='';
end;
if m=2 then
begin
ogr2.visible:=true;
ogr3.visible:=false;
ogr3.text:='';
end;
if m=3 then
begin
ogr3.visible:=true;
ogr4.visible:=false;
ogr4.text:='';
end;
if m=4 then
begin
ogr4.visible:=true;
ogr5.visible:=false;
ogr5.text:='';
end;
if m=5 then
begin
ogr5.visible:=true;
ogr6.visible:=false;
ogr6.text:='';
end;
if m=6 then
begin
ogr6.visible:=true;
ogr7.visible:=false;ogr7.text:='';
end;
if m=7 then
begin
ogr7.visible:=true;
end;
end;
procedure TMio.ExitClick(Sender: TObject);
begin
close
end;
procedure TMio.OpenClick(Sender: TObject);
//открытие файла
begin
if OpenFile.Execute then FillVar;
end;
procedure TMio.SaveClick(Sender: TObject);
//сохранение файла
begin
if SaveFile.Execute then SaveVar;
end;
procedure TMio.HelpClick(Sender: TObject);
//вызов справки
begin
tabhelp.showmodal;
end;
procedure TMio.CalculateClick(Sender: TObject);
//расчет задачи
begin
calc;
end;
procedure TMio.funcChange(Sender: TObject);
//определение направления поиска оптимального решения
begin
if minmax=true then
begin
if copy(mio.func.text,strlen(pchar(mio.func.text)),1)='0' then
begin
Onmax:=false;
mio.func.text:=copy(mio.func.text,1,strlen(pchar(mio.func.text))-1)+'min';
minmax:=false;
end;
if copy(mio.func.text,strlen(pchar(mio.func.text)),1)='1' then begin OnMax:=true;mio.func.text:=copy(mio.func.text,1,strlen(pchar(mio.func.text))-1)+'max';minmax:=false;end;
end;
if copy(mio.func.text,strlen(pchar(mio.func.text)),1)='=' then minmax:=true;
end;
end.