Транспортная задача по критериям стоимости и времени (стр. 3 из 4)
При выполнении дооптимизации единственным подтверждением правильности результатов может служить уменьшение целевой функции
.5. Алгоритм решения задачи
1. Проверка правильности ввода данных.
2. Проверка условия баланса.
3. Построение начального опорного плана Х(0) методом минимального элемента.
4. Проверка плана на вырожденность, если нужно добавляем фиктивные перевозки.
5. Расчет начальных потенциалов и заполнение матрицы С(1).
6. Поиск минимального элемента в матрице С(1).
7. Если этот элемент меньше нуля, то заменяем нулевой элемент, соответствующий минимальному в С(1), в плане Х(0) на фиктивную перевозку, иначе на пункт 12.
8. Производим процедуру вычеркивания.
9. Оставшиеся не вычеркнутыми элементы разделяем на четные и нечетные, учитывая, что добавленный элемент принадлежит к четным.
10. Находим минимальный нечетный элемент и прибавляем его ко всем четным и отнимаем от нечетных элементов. Причем, если минимальных элементов окажется 2 или более, то один из них обнуляем, а остальные делаем фиктивными. В итоге получаем план Х(1).
11. Производим процедуру вычеркивания. Получаем матрицу С(2).
12. Проверяем матрицу С(2) на наличие отрицательных элементов. Если такие элементы присутствуют, то повторяем пункты с 5 по11.
13. Если во время решения достоверность результатов нарушается, прекращаются дальнейшие вычисления, пользователю выдается информация об ошибке.
14. Дооптимизация по времени.
14.1. Ищем отличный от нуля элемент в матрице X(k), которому соответствует наибольший элемент матрицы Т=tmax.
14.2. Ищем в матице С(k) нули соответствующие таким нулям в матрице X(k), что соответствующие им элементы матрицы Т меньше tmax.
14.3. Если в предыдущем пункте нашелся хоть один ноль, то производим процедуры пунктов 7-10.
14.4. Переходим к пункту 14.1.
15. Вывод результатов.
6. Листинг программы, реализующий алгоритм задачи
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;