Проверка достоверности полученных результатов

 

В общем случае проверка полученных результатов после очередной итерации вычисления осуществляется следующим образом:

Целевая функция считается 2 способами:

 

1.

 

2. Пусть минимальным элементом матрицы С^(k) оказался элемент с индексами μ, κ, тогда значение целевой функции на этом шаге будет равно:

 

 

Если значения не совпадают то, то на экран выводится ошибка.

Если условие выполняется, то полученный результат (на данной итерации) достоверен.

При выполнении дооптимизации единственным подтверждением правильности результатов может служить уменьшение целевой функции

 

.

Алгоритм решения задачи

 

1. Проверка правильности ввода данных.

2. Проверка условия баланса.

3. Построение начального опорного плана Х⁽⁰⁾ методом минимального элемента.

4. Проверка плана на вырожденность, если нужно добавляем фиктивные перевозки.

5. Расчет начальных потенциалов и заполнение матрицы С⁽¹⁾.

6. Поиск минимального элемента в матрице С⁽¹⁾.

7. Если этот элемент меньше нуля, то заменяем нулевой элемент, соответствующий минимальному в С⁽¹⁾, в плане Х⁽⁰⁾ на фиктивную перевозку, иначе на пункт 12.

8. Производим процедуру вычеркивания.

9. Оставшиеся не вычеркнутыми элементы разделяем на четные и нечетные, учитывая, что добавленный элемент принадлежит к четным.

10. Находим минимальный нечетный элемент и прибавляем его ко всем четным и отнимаем от нечетных элементов. Причем, если минимальных элементов окажется 2 или более, то один из них обнуляем, а остальные делаем фиктивными. В итоге получаем план Х⁽¹⁾.

11. Производим процедуру вычеркивания. Получаем матрицу С⁽²⁾.

12. Проверяем матрицу С⁽²⁾ на наличие отрицательных элементов. Если такие элементы присутствуют, то повторяем пункты с 5 по11.

13. Если во время решения достоверность результатов нарушается, прекращаются дальнейшие вычисления, пользователю выдается информация об ошибке.

14. Дооптимизация по времени.

14.1. Ищем отличный от нуля элемент в матрице X^(k), которому соответствует наибольший элемент матрицы Т=t_max.

14.2. Ищем в матице С^(k) нули соответствующие таким нулям в матрице X^(k), что соответствующие им элементы матрицы Т меньше t_max.

14.3. Если в предыдущем пункте нашелся хоть один ноль, то производим процедуры пунктов 7-10.

14.4. Переходим к пункту 14.1.

15. Вывод результатов.

Листинг программы, реализующий алгоритм задачи

 

const

color=TColor(Clred);

var i,j,v,w:integer;

err,kon:boolean;

str:String;

begin

kon:=true;

Label3.Caption:='';

for j:=1 to StringGrid1.RowCount-1 do

if (StringGrid1.Cells[1,j]='')or(StringGrid1.Cells[0,j]='')then

kon:=false;

for j:=1 to StringGrid2.RowCount-1 do

if (StringGrid2.Cells[1,j]='')or(StringGrid2.Cells[0,j]='')then

kon:=false;

if kon=true then

begin

err:=true;

for j:=1 to StringGrid1.RowCount-1 do

begin

Str:=Trim(StringGrid1.Cells[1,j]);

Recurs(str,1,err);

If err=false then

begin

StringGrid1.Canvas.Brush.color := color;

StringGrid1.canvas.fillRect(StringGrid1.CellRect(1,j));

StringGrid1.canvas.TextOut(StringGrid1.CellRect(1,j).Left,StringGrid1.CellRect(1,j).Top,StringGrid1.Cells[1,j]);

Label3.Caption:= ’Выделенные значения не верны';

end;

Err:=true;

end;

for j:=1 to StringGrid2.RowCount-1 do

begin

Str:=Trim(StringGrid2.Cells[1,j]);

Recurs(str,1,err);

If err=false then

begin

StringGrid2.Canvas.Brush.color := color;

StringGrid2.canvas.fillRect(StringGrid2.CellRect(1,j));

StringGrid2.canvas.TextOut(StringGrid2.CellRect(1,j).Left,StringGrid2.CellRect(1,j).Top,StringGrid2.Cells[1,j]);

Label3.Caption:= ‘Выделенные значения не верны';

end;

Err:=true;

end;

for j:=1 to StringGrid1.RowCount-1 do

begin

Str:=Trim(StringGrid1.Cells[1,j]);

Recurs(str,1,err);

end;

for j:=1 to StringGrid2.RowCount-1 do

begin

Str:=Trim(StringGrid2.Cells[1,j]);

Recurs(str,1,err);

end;

If err=true then

begin

for j:=1 to StringGrid1.RowCount-1 do

begin

If (StrToInt(trim(StringGrid1.Cells[1,j]))<0)or(StrToInt(trim(StringGrid1.Cells[1,j]))>190)

then

begin

StringGrid1.Canvas.Brush.color := color;

StringGrid1.canvas.fillRect(StringGrid1.CellRect(1,j));

StringGrid1.canvas.TextOut(StringGrid1.CellRect(1,j).Left,StringGrid1.CellRect(1,j).Top,StringGrid1.Cells[1,j]);

err:=false;

Label3.Caption:= ‘Выделенные значения не верны';

end;

end;

for j:=1 to StringGrid2.RowCount-1 do

begin

If (StrToInt(trim(StringGrid2.Cells[1,j]))<0)or(StrToInt(trim(StringGrid2.Cells[1,j]))>160)

then

begin

StringGrid2.Canvas.Brush.color := color;

StringGrid2.canvas.fillRect(StringGrid2.CellRect(1,j));

StringGrid2.canvas.TextOut(StringGrid2.CellRect(1,j).Left,StringGrid2.CellRect(1,j).Top,StringGrid2.Cells[1,j]);

err:=false;

Label3.Caption:= ‘Выделенные значения не верны';

end;

end;

if err=true then

begin

w:=0;//ai

v:=0;//bj

SetLength(c,StringGrid2.RowCount-1,StringGrid1.RowCount-1);

SetLength(t,StringGrid2.RowCount-1,StringGrid1.RowCount-1);

SetLength(a,StringGrid1.RowCount-1);

SetLength(b,StringGrid2.RowCount-1);

//Проверка условия баланса

For i:=1 to StringGrid1.RowCount-1 do

w:=w+StrToint(Trim(StringGrid1.cells[1,i]));

For i:=1 to StringGrid2.RowCount-1 do

v:=v+StrToint(Trim(StringGrid2.cells[1,i]));

if w<v then

begin

Setlength(c,(StringGrid2.RowCount-1),(StringGrid1.RowCount));

SetLength(a,StringGrid1.RowCount);

for i:=0 to Length(c)-1 do

begin

c[i,Length(c[1])-1]:=1000;

end;

a[length(a)-1]:=v-w;

end;

if w>v then

begin

Setlength(c,(StringGrid2.RowCount),(StringGrid1.RowCount-1));

SetLength(b,StringGrid2.RowCount);

for i:=0 to Length(c[1])-1 do

begin

c[length(c)-1,i]:=1000;

end;

b[length(b)-1]:=w-v;

end;

For i:=0 to StringGrid1.RowCount-2 do

a[i]:=StrtoInt(Trim(StringGrid1.cells[1,i+1]));

For i:=0 to StringGrid2.RowCount-2 do

b[i]:=StrtoInt(Trim(StringGrid2.Cells[1,i+1]));

For i:=1 to StringGrid1.RowCount-1 do

begin

Form3.StringGrid1.Cells[0,i]:=StringGrid1.cells[0,i];

Form3.StringGrid2.Cells[0,i]:=StringGrid1.cells[0,i];

end;

For i:=1 to StringGrid2.RowCount-1 do

begin

Form3.StringGrid1.Cells[i,0]:=StringGrid2.cells[0,i];

Form3.StringGrid2.Cells[i,0]:=StringGrid2.cells[0,i];

end;

Form3.Show;

Form5.Close;

end;

end;

end

else ShowMessage('Заполните все поля');

procedure Potencial(x:Tmatr; u,v:Tmas; var z:Tmatr );

var

i,j,k,r:integer;

begin

SetLength(u,length(x[1]));

SetLength(v,Length(x));

For r:=0 to Length(x)-1 do

v[r]:=-1000;

for j:=0 to Length(x[1])-1 do

u[j]:=-1000;

u[0]:=0;

For r:=0 to Length(x)-1 do

for j:=0 to Length(x[1])-1 do

begin

for i:=0 to Length(x)-1 do

if (x[i,j]<>0) and (v[i]=-1000)then

if (u[j]<>-1000)then

v[i]:=c[i,j]+u[j];

For i:=0 to Length(x)-1 do

if v[i]<>-1000 then

for k:=0 to Length(x[1])-1 do

if (k<>j)and(x[i,k]<>0)and(u[k]=-1000)then

u[k]:=v[i]-c[i,k];

end;

Setlength(z,Length(c),Length(c[1]));

For i:=0 to Length(x)-1 do

For j:=0 to Length(x[1])-1 do

z[i,j]:=c[i,j]-(v[i]-u[j]);

end;

//Проверкана вырожденость

procedure Virogden(var x:Tmatr);

var i,j,r,k,d:integer;

h,g:boolean;

begin

d:=0;

For i:=0 to Length(x)-1 do

for j:=0 to length(x[1])-1 do

if x[i,j]<>0 then d:=d+1;

if d<Length(x)+Length(x[1])-1 then

For i:=0 to Length(x)-2 do

for j:=0 to Length(x[1])-2 do

begin

if x[i,j]>0 then

begin

h:=true;

g:=true;

for r:=i+1 to Length(x)-1 do

if x[r,j]>0 then

h:=false;

for k:=j+1 to Length(x[1])-1 do

if x[i,k]>0 then

g:=false;

if(h=true)and(g=true) then

x[i,j+1]:=-2;

end;

end;

end;

 

procedure Opornplan(StringGrid1:TStringGrid; var x,z:Tmatr);

var i,j:integer;

c1:TMatr;

begin

Setlength(x,Length(c),Length(c[1]));

Setlength(c1,Length(x)*Length(x[1]),3);

For i:=0 to Length(x)-1 do

for j:=0 to Length(x[1])-1 do

begin

c1[(Length(x[1]))*i+j,0]:=c[i,j];

c1[(Length(x[1]))*i+j,1]:=i;

c1[(Length(x[1]))*i+j,2]:=j;

end;

Setlength(z,1,3);

//Сортировка

For i:=0 to Length(c1)-2 do

for j:=0 to Length(c1)-2 do

if c1[j,0]>c1[j+1,0] then

begin

z[0]:=c1[j+1];

c1[j+1]:=c1[j];

c1[j]:=z[0];

end;

for i:=0 to Length(x)-1 do

for j:=0 to Length(x[1])-1 do

x[i,j]:=-1;

For i:=0 to Length(x)*Length(x[1])-1 do

if x[c1[i,1],c1[i,2]]=-1 then

begin

//Если à>b

If a[c1[i,2]]>b[c1[i,1]] then

begin

x[c1[i,1],c1[i,2]]:=b[c1[i,1]];

For j:=0 to Length(x[1])-1 do

If x[c1[i,1],j]=-1 then

x[c1[i,1],j]:=0;

a[c1[i,2]]:=a[c1[i,2]]-b[c1[i,1]];

b[c1[i,1]]:=0;

end;

//Если b>a

If a[c1[i,2]]<b[c1[i,1]] then

begin

x[c1[i,1],c1[i,2]]:=a[c1[i,2]];

For j:=0 to Length(x)-1 do

if x[j,c1[i,2]]=-1 then

x[j,c1[i,2]]:=0;

b[c1[i,1]]:=b[c1[i,1]]-a[c1[i,2]];

a[c1[i,2]]:=0;

end;

//Если равны

If a[c1[i,2]]=b[c1[i,1]] then

begin

x[c1[i,1],c1[i,2]]:=a[c1[i,2]];

For j:=0 to Length(x[1])-1 do

if x[c1[i,1],j]=-1 then

x[c1[i,1],j]:=0;

For j:=0 to Length(x)-1 do

If x[j,c1[i,2]]=-1 then

x[j,c1[i,2]]:=0;

a[c1[i,2]]:=0;

b[c1[i,1]]:=0;

end;

end;

//Проверка на вырожденность

Virogden(x);

potencial(x,u,v,z);

end;

 

procedure Vicherk(var z:TMatr;var err:boolean);

var i,j,min,k:integer;

w,d:Tmas;

begin

SetLength(w,Length(z));

SetLength(d,Length(z[1]));

min:=z[0,0];

k:=0;

For i:=0 to length(w)-1 do

for j:=0 to length(d)-1 do

if z[i,j]<min then

begin

min:=z[i,j];

k:=j;

end;

for i:=0 to length(w)-1 do

if (z[i,k]=0)and(x[i,k]<>0) then

w[i]:=5;

d[k]:=-1;

For k:=0 to length(d)*Length(w)-2 do

begin

for i:=0 to Length(w)-1 do

if w[i]>0 then

begin

for j:=0 to Length(d)-1 do

if (z[i,j]=0)and(x[i,j]<>0)and(d[j]<>-1) then

d[j]:=5;

w[i]:=-1;

end;

For j:=0 to Length(d)-1 do

if d[j]>0 then

begin

for i:=0 to Length(w)-1 do

if (z[i,j]=0)and(x[i,j]<>0)and(w[i]<>-1) then

w[i]:=5;

d[j]:=-1;

end;

end;

For i:=0 to length(d)-1 do

if d[i]=-1 then

for j:=0 to length(w)-1 do

z[j,i]:=z[j,i]+abs(min);

for i:=0 to Length(w)-1 do

if w[i]=-1 then

for j:=0 to length(d)-1 do

z[i,j]:=z[i,j]-abs(min);

err:=true;

i:=0;j:=0;

Repeat

j:=0;

Repeat

if z[i,j]<0 then

err:=false;

j:=j+1;

until (err=False)or(j=Length(z[1]));

i:=i+1;

until (err=false)or(i=Length(z));

end;

 

procedure Cikle (l,r:integer ; var x:Tmatr);

var i,j,k,min:integer;

s,q,m,n:Tmatr;

kon:boolean;

begin

//Добавляем на соответствующее место фиктивную перевозку

x[l,r]:=-2;

Setlength(s,Length(x),Length(x[1]));

For i:=0 to Length(x)-1 do

For j:=0 to Length(x[1])-1 do

s[i,j]:=x[i,j];

//ищем цикл в матрице

Repeat

kon:=true;

for i:=0 to length(s)-1 do

begin

k:=0;

For j:=0 to length(s[1])-1 do

if s[i,j]<>0 then

k:=k+1;

if k=1 then

begin

for j:=0 to length(s[1])-1 do

s[i,j]:=0;

kon:=false;

end;

end;

for i:=0 to length(s[1])-1 do

begin

k:=0;

For j:=0 to length(s)-1 do

if s[j,i]<>0 then

k:=k+1;

if k=1 then

begin

for j:=0 to length(s)-1 do

s[j,i]:=0;

kon:=false;

end;

end;

until kon=true;

k:=0;

//Записываем элементы цикла в масив

For i:=0 to Length(s)-1 do

for j:=0 to Length(s[1])-1 do

if s[i,j]<>0 then

k:=k+1;

SetLength(q,k,3);

k:=0;

For i:=0 to Length(s)-1 do

for j:=0 to Length(s[1])-1 do

If s[i,j]<>0 then

begin

q[k,0]:=s[i,j];

q[k,1]:=i;

q[k,2]:=j;

k:=k+1;

end;

//Разделяем на четные и нечетные

Setlength(n,Round(k/2),3);

Setlength(m,Round(k/2),3);

n[0,0]:=q[0,0];

n[0,1]:=q[0,1];

n[0,2]:=q[0,2];

q[0,0]:=0;

For j:=0 to length(n)-1 do

begin

i:=0;

kon:=false;

repeat

if i<=Length(q)-1 then

begin

If (q[i,0]<>0)and(q[i,1]=n[j,1]) then

begin

m[j,0]:=q[i,0];

m[j,1]:=q[i,1];

m[j,2]:=q[i,2];

q[i,0]:=0;

kon:=true;

end;

i:=i+1;

end

else kon:=true;

until kon=true;

i:=0;

kon:=false;

repeat

if i<=Length(q)-1 then

begin

If (q[i,0]<>0)and(q[i,2]=m[j,2]) then

begin

n[j+1,0]:=q[i,0];

n[j+1,1]:=q[i,1];

n[j+1,2]:=q[i,2];

q[i,0]:=0;

kon:=true;

end;

i:=i+1;

end

else kon:=true;

until kon=true;

end;

i:=0;

repeat

if (n[i,0]=s[l,r])and(n[i,1]=l)and(n[i,2]=r)then

kon:=false

else kon:=true;

i:=i+1;

until (i>length(n)-1)or(kon=false);

if kon=true then

for i:=0 to length(n)-1 do

begin

q[i,0]:=m[i,0];

q[i,1]:=m[i,1];

q[i,2]:=m[i,2];

m[i,0]:=n[i,0];

m[i,1]:=n[i,1];

m[i,2]:=n[i,2];

n[i,0]:=q[i,0];

n[i,1]:=q[i,1];

n[i,2]:=q[i,2];

end;

min:=m[0,0];

kon:=false;

i:=0;

//Ищем минимальный среди нечетных

repeat

if m[i,0]<min then

begin

min:=m[i,0];

end;

if m[i,0]=-2 then

begin

m[i,0]:=0;

min:=0;

kon:=true;

end;

i:=i+1;

until (kon=true)or(i>=length(m));

kon:=false;

i:=0;

repeat

if m[i,0]=min then

begin

m[i,0]:=0;

kon:=true;

end;

i:=i+1;

until (kon=true)or(i>=length(m));

if min>0 then

begin

for i:=0 to length(m)-1 do

if m[i,0]=min then m[i,0]:=-2

else

if m[i,0]<>0 then

m[i,0]:=m[i,0]-min;

for i:=0 to Length(n)-1 do

if n[i,0]=-2 then n[i,0]:=min

else n[i,0]:=n[i,0]+min;

end;

for i:=0 to Length(m)-1 do

begin

x[m[i,1],m[i,2]]:=m[i,0];

x[n[i,1],n[i,2]]:=n[i,0];

end;

end;

 

Procedure Dooptimiz(var max2:integer; var x:Tmatr);

var i,j,k,l,r,max:integer;

kon,err:boolean;

q:TMatr;

s:Tmatr;

begin

kon:=true;

SetLength(s,Length(t),Length(t[1]));

 

max2:=0;

for i:=0 to Length(t)-1 do

For j:=0 to Length(t[1])-1 do

s[i,j]:=x[i,j];

Repeat

err:=true;

max:=0;k:=0;

SetLength(q,0,0);

for i:=0 to Length(t)-1 do

For j:=0 to Length(t[1])-1 do

If (s[i,j]>0)and(t[i,j]>max) then

begin

max:=t[i,j];

l:=i;

r:=j;

end;

for i:=0 to Length(t)-1 do

For j:=0 to Length(t[1])-1 do

If (z[i,j]=0)and(s[i,j]=0) then

begin

SetLength(q,k+1,2);

q[k,0]:=i;

q[k,1]:=j;

inc(k);

end;

for i:=0 to Length(q)-1 do

If t[q[i,0],q[i,1]]<max then

 

else

begin

q[i,0]:=-1;

q[i,1]:=-1;

end;

i:=0;

kon:=false;

Repeat

if q[i,0]>=0 then

begin

Cikle(q[i,0],q[i,1],s);

if s[l,r]=0 then

begin

kon:=true;

err:=false;

for k:=0 to Length(t)-1 do

For j:=0 to Length(t[1])-1 do

x[k,j]:=s[k,j];

end

else

begin

q[i,0]:=-1;

q[i,1]:=-1;

for k:=0 to Length(t)-1 do

For j:=0 to Length(t[1])-1 do

s[k,j]:=x[k,j];

end;

end;

inc(i);

Until (i>length(q)-1)or(kon=true);

Until (err=true)and(kon=false);

max2:=0;

for i:=0 to Length(t)-1 do

For j:=0 to Length(t[1])-1 do

If (s[i,j]>0)and(t[i,j]>max2) then

max2:=t[i,j];

if max>max2 then

begin

for i:=0 to Length(t)-1 do

For j:=0 to Length(t[1])-1 do

x[i,j]:=s[i,j];

end;

end;

 

procedure TForm4.Button1Click(Sender: TObject);

var i,j,l,r,min,max:integer;

err:boolean;

begin

Opornplan(StringGrid1,x,z);

StringGrid1.RowCount:=Length(x[1]);

StringGrid1.ColCount:=Length(x);

StringGrid2.RowCount:=Length(x[1]);

StringGrid2.ColCount:=Length(x);

min:=z[0,0];

l:=0;

r:=0;

For i:=0 to length(z)-1 do

for j:=0 to length(z[1])-1 do

if z[i,j]<min then

begin

min:=z[i,j];

l:=i;

r:=j;

end;

if Min<0 then

begin

Cikle(l,r,x);

Repeat

Vicherk(z,err);

If err=false then

begin

min:=z[0,0];

l:=0;

r:=0;

For i:=0 to length(z)-1 do

for j:=0 to length(z[1])-1 do

if z[i,j]<min then

begin

min:=z[i,j];

l:=i;

r:=j;

end;

Cikle(l,r,x);

end;

until err=true;

end;

Dooptimiz(max,x);

r:=0;l:=0;

for i:=0 to StringGrid1.RowCount-1 do

begin

Memo1.Lines.add('Из пункта производства '+Form5.StringGrid1.Cells[0,i+1]+' в :');

for j:=0 to StringGrid1.ColCount-1 do

if (x[j,i]>0)and(c[j,i]<100)then

begin

r:=r+x[j,i]*c[j,i];

Memo1.Lines.add(' '+Form5.StringGrid2.Cells[0,j+1]+' '+IntToStr(x[j,i])+' ед . продукции');

end;

end;

Label1.Caption:=Label1.Caption+IntToStr(r);

label2.Caption:=label2.Caption+IntTostr(max);

for i:=0 to StringGrid1.ColCount-1 do

for j:=0 to StringGrid1.RowCount-1 do

StringGrid1.Cells[i,j]:=IntToStr(x[i,j]);

for i:=0 to StringGrid1.ColCount-1 do

for j:=0 to StringGrid1.RowCount-1 do

StringGrid2.Cells[i,j]:=IntToStr(z[i,j]);

button1.Enabled:=false;

end;

Примечания:

1. В качестве фиктивной перевозки используется " -2", т.к. для сохранения и работы с матрицами используется тип Integer.

2. Цель использования этого типа: уменьшение объемов памяти требуемой для запуска приложения, и ,как следствие, возможность использования этой программы на маломощных машинах.