Программная реализация на языке Delphi

var

i,j,k: integer;

temp: double;

begin

done:=false;

solve:=false;

is_ok:=true;

temp:=100000;

i0:=0;

j0:=0;

i:=n+1;

for j:=1 to m+y do

if (i0=0) or (j0=0) then

if matrix[i,j]>0 then

begin

j0:=j;

for k:=1 to n do

if (matrix[k,j]>0) then

if (matrix[k,m+y+1]/matrix[k,j]<temp) then

begin

temp:=matrix[k,m+y+1]/matrix[k,j];

i0:=k;

end;

end;

if (j0=0) and (i0=0) then

for j:=1 to m do

if matrix[n+1,j]=0 then

for i:=1 to n do

if (matrix[i,j]<>0) and (matrix[i,j]<>1) then

begin

is_ok:=false;

j0:=j;

end;

if is_ok=false then

begin

temp:=100000;

for k:=1 to n do

if (matrix[k,j0]>0) then

if (matrix[k,m+y+1]/matrix[k,j0]<temp) then

begin

temp:=matrix[k,m+y+1]/matrix[k,j0];

i0:=k;

end;

end;

if (j0=0) and (i0=0) then

begin

writeln(f, '<P>Конец вычислений</P>');

done:=true;

solve:=true;

end

else if (j0<>0) and (i0=0) then

begin

writeln(f, '<P>Не удается решить систему</P>');

done:=true;

solve:=false;

end

else

if iter<>0 then

begin

writeln(f,'<P><b>Итерация ',iter,'</b></P>');

writeln(f, '<P>Найдем ведущий элемент:</P>');

zapisat(n+1,m+y+1,i0,j0);

writeln(f,'<P>Ведущий столбец: ',j0,'<br>Ведущая строка: ',i0,'</P>');

write(f,'<P>В строке ',i0,': базис ');

writeln(f,'X_{',all_basis[i0],'} заменяем на X_',j0,'</P>');

all_basis[i0]:=j0;

end;

end;

{/////////////////}

procedure okr;

{округляет мелкие погрешности}

var

i,j: integer;

begin

for i:=1 to n+1 do

for j:=1 to m+y+1 do

if abs(matrix[i,j]-round(matrix[i,j]))< tochnost then

matrix[i,j]:=round(matrix[i,j]);

end;

{/////////////////}

procedure preobr;

{преобразует  массив относительно ведущего  элемента}

var

i,j,k,l,t: integer;

temp: double;

begin

if done=false then

begin

write(f, '<P>Пересчет:</P>');

temp:=matrix[i0,j0];

for j:=1 to m+y+1 do matrix[i0,j]:=matrix[i0,j]/temp;

for i:=1 to n+1 do

begin

temp:=matrix[i,j0];

for j:=1 to m+y+1 do

if (i<>i0) then

matrix[i,j]:=matrix[i,j]-matrix[i0,j]*temp;

end;

okr;

zapisat(n+1,m+y+1,-1,-1);

{/////////////////////////убираем  искусственный базис/////////////////////}

if i_basis>0 then {если он есть }

begin

t:=0;

for j:=m+y-i_basis+1 to m+y do {от первого исскусственного элемеента до конца}

begin

need_i_basis:=false;{предполагаем, что элемент не нужен (*)}

for i:=1 to n do {просматриваем столбец}

if all_basis[i]=j then{и если элемент в базисе}

need_i_basis:=true;{тогда он все-таки нужен}

if need_i_basis=false then t:=j;

{если наши  предположения (*) подтвердились, то запомним этот элемент}

end;

if t<>0 then

begin

for k:=1 to n+1 do {во всех строках}

begin

for l:=t to m+y do {от текущего столбца до последнего}

matrix[k,l]:=matrix[k,l+1];{заменяем элемент на соседний}

matrix[k,m+y+1]:=0;{а последний убираем}

end;

{столбец удален! надо это запомнить}

y:=y-1;

i_basis:=i_basis-1;

if i_basis>0 then {если остались еще искусственные переменные,}

for l:=m+y-i_basis+1 to m+y do{то от первой из них до последней}

for i:=1 to n do {просматриваем строки в столбце}

if matrix[i,l]=1 then all_basis[i]:=l; {туда, где 1, заносим в базис}

writeln(f,'<P>Искусственная переменная исключена из базиса<br>');

writeln(f,'и может быть удалена из таблицы.');

writeln(f,'</P>');

zapisat(n+1,m+y+1,-1,-1);

end;

end;

{///////////////закончили  убирать искусственный базис////////////////////}

end;

end;

{/////////////////}

procedure otvet;

{выводит ответ}

var

i,j: integer;

begin

writeln(f,'<P><b>ОТВЕТ:</b></P>');

form1.Memo1.ReadOnly:=false;

form1.Memo1.Lines.Clear;

form1.Memo1.Lines.Add('ОТВЕТ:');

form1.Memo1.Lines.Add('');

if (solve=true) and (i_basis=0) then

write(f,'F(');

form1.Memo1.Lines.Text:=form1.Memo1.Lines.Text+'F(';

if form1.Extrem.ItemIndex=0 then

begin

write(f,'max) = ',0-matrix[n+1,m+y+1]:0:3);

form1.Memo1.Lines.Text:=form1.Memo1.Lines.Text+'max) = ';

form1.Memo1.Lines.Text:=form1.Memo1.Lines.Text+floattostr(0-matrix[n+1,m+y+1]);

end

else

begin

write(f,'min) = ',matrix[n+1,m+y+1]:0:3);

form1.Memo1.Lines.Text:=form1.Memo1.Lines.Text+'min) = ';

form1.Memo1.Lines.Text:=form1.Memo1.Lines.Text+floattostr(matrix[n+1,m+y+1]);

end;

writeln(f,'<br>при значениях:<br>');

form1.Memo1.Lines.Add('');

form1.Memo1.Lines.Add('');

form1.Memo1.Lines.Add('при  значениях:');

form1.Memo1.Lines.Add('');

for j:=1 to m do

begin

writeln(f,'x_',j,' = ');

form1.Memo1.Lines.Text:=form1.Memo1.Lines.Text+'X[';

form1.Memo1.Lines.Text:=form1.Memo1.Lines.Text+inttostr(j);

form1.Memo1.Lines.Text:=form1.Memo1.Lines.Text+'] = ';

written:=false;

for i:=1 to n do

if all_basis[i]=j then

begin

writeln(f,matrix[i,m+y+1]:0:3,'<br>');

form1.Memo1.Lines.Text:=form1.Memo1.Lines.Text+floattostr(matrix[i,m+y+1]);

form1.Memo1.Lines.Add('');

form1.Memo1.Lines.Add('');

written:=true;

end;

if written=false then

begin

writeln(f,'0.000 <br>');

form1.Memo1.Lines.Text:=form1.Memo1.Lines.Text+'0';

form1.Memo1.Lines.Add('');

form1.Memo1.Lines.Add('');

end;

end;

end else

begin

writeln(f,'<P>Решение не найдено.(</P>');

form1.Memo1.Lines.Text:=form1.Memo1.Lines.Text+'Решение не найдено.';

end;

form1.Memo1.ReadOnly:=true;

end;

{/////////////////}

procedure Step2;

{шаг второй: решение задачи и формирование  отчета}

var

i,j: integer;

k: integer;

begin

for i:=1 to n+1 do

for j:=1 to m+1 do

begin

matrix[i,j]:=strtofloat(pole[i,j].Text); {Вводим значения в массив}

pole[i,j].Enabled:=false; {Блокируем поля}

if i<=n then znak[i].Enabled:=false;{блокируем знаки}

end;

form1.Extrem.Enabled:=false;

{////////////////////////////////////////////////////////////////////////////}

{ имеем матрицу [ n+1, m+1 ] }

rewrite(f);

writeln(f,'<HTML>');

writeln(f,'<HEAD>');

writeln(f,'<TITLE>Отчет</TITLE>');

writeln(f,'</HEAD>');

writeln(f,'<BODY>');

writeln(f,'<H1>Отчет</H1>');

write(f,'<P><b>Необходимо ');

if form1.Extrem.ItemIndex=0 then write(f,'макс') else write(f,'мин');

writeln(f,'имизировать целевую функцию:</b></P>');

kanon:=false;{еще не в канонической форме}

write_system(n+1,m+1);{Выведем ее в отчет}

{приведем ее  к каноническому виду}

writeln(f,'<P><b>Приведем к каноническому виду:</b></P>');

y:=0;{количество  дополнительных переменных}

need_basis:=false;

for i:=1 to n do

if znak[i].ItemIndex<>2 then {если ограничение не является равенством}

begin

y:=y+1; {вводим  дополнительную переменную, для  этого:}

for k:=1 to n+1 do begin {во всех ограничениях и в ЦФ}

{перед правой  частью добавляем столбец}

matrix[k,m+y+1]:=matrix[k,m+y];

matrix[k,m+y]:=0;{состоящий из нулей}

end;

{а в текущем  ограничении, если знак был  > или >=}

if (znak[i].ItemIndex=0) or (znak[i].ItemIndex=1) then

begin

matrix[i,m+y]:=-1;{записываем -1}

need_basis:=true;

end

else {иначе, т.е. в случае < или <=}

matrix[i,m+y]:=1; {записываем 1}

end

else need_basis:=true;

{ЦФ приравнивается  к нулю, а свободный член переносится  в правую часть:}

matrix[n+1,m+y+1]:=0-matrix[n+1,m+y+1];

{правые части  ограничений должны быть неотрицательны, проверим это:}

for i:=1 to n do {для всех ограничений}

if matrix[i,m+y+1]<0 then {если правая часть отрицательна,}

{то отнимаем  всю строку от нуля}

for j:=1 to m+y+1 do matrix[i,j]:=(0-matrix[i,j]);

kanon:=true;{система приведена к каноническому виду}

{выведем ее  в отчет}

write_system(n+1,m+y+1);

{если ф-ция на минимум, то нужно поменять знаки в последней строке}

if form1.Extrem.ItemIndex=1 then

for j:=1 to m+y+1 do matrix[n+1,j]:=0-matrix[n+1,j];

{////////////////////////////////////////////////////////////////////////////}

{////////////////////////// Тут надо ввести базис ///////////////////////////}

i_basis:=0;

for i:=1 to n do {то во всех ограничениях}

begin

is_basis:=false;

for j:=1 to m+y do

if (matrix[i,j]=1) then

if (is_basis=false) then

begin

all_basis[i]:=j;