Нахождение опорного плана транспортной задачи

Блок-схема меню определение опорного плана
(Transtask.pas)
1
2
3
Да
нет
4 Да
5
нет
6 Да
7
нет
8 Да
9
нет
10
11
12
13
Да
14
нет
15
16
Блок-схема подпрограммы решения методом минимального
элемента MINIELEM
1
2
3
4
5
6 Да
7
нет
8
Да
9
нет
10
11
Да
12
13
Блок-схема подпрограммы решения транспортной задачи
Transsolver
1
2
Да
3
нет
4 Да
5
нет
6
7
нет
8
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
Grids;
type
TForm1 = class(TForm)
StringGrid1: TStringGrid;
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
word:string;
words:TStringList;
i:integer;
implementation
{$R *.DFM}
Form1.slString=TStringList.Create;
for i:=1 to 8 do
begin
word:=IntTostr(i);
words.add(word)
end
end.
unit TransTask;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, ExtCtrls, Grids, ComCtrls, Math;
type
TfmTransTask = class(TForm)
pgcTransTask: TPageControl;
tbsAbout: TTabSheet;
tbsData: TTabSheet;
tbsTarif: TTabSheet;
tbsSolve: TTabSheet;
Label1: TLabel;
edProviderCount: TEdit;
spnProviderCount: TUpDown;
Label2: TLabel;
stgProvider: TStringGrid;
Label3: TLabel;
Label4: TLabel;
edCustomerCount: TEdit;
spnCustomerCount: TUpDown;
stgCustomer: TStringGrid;
Label5: TLabel;
lblTypeTask: TLabel;
lblProviderGruz: TLabel;
lblCustomerGruz: TLabel;
stgTarif: TStringGrid;
stgSolve: TStringGrid;
rgMetod: TRadioGroup;
rbMinelem: TRadioButton;
rbFogel: TRadioButton;
rbTwoWall: TRadioButton;
btnSolve: TButton;
btnPrint: TButton;
Label6: TLabel;
Label7: TLabel;
Label8: TLabel;
Label9: TLabel;
btnLoadData: TButton;
btnLoadDataC: TButton;
lblProvider: TLabel;
lblCustomer: TLabel;
lblTupeTask: TLabel;
lblMsg: TLabel;
Label10: TLabel;
lblZ: TLabel;
procedure FormCreate(Sender: TObject);
procedure edProviderCountChange(Sender: TObject);
procedure edCustomerCountChange(Sender: TObject);
procedure btnLoadDataClick(Sender: TObject);
procedure btnLoadDataCClick(Sender: TObject);
procedure btnSolveClick(Sender: TObject);
procedure btnPrintClick(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
fmTransTask: TfmTransTask;
a,b: array of integer;// наличие груза у поставщиков
// и спрос у потребителей
c: array of array of integer; // матрица тарифов перевозок
d: array of array of integer;// матрица перевозок (решение)
z,m,n:integer; //число поставщиков и потребителей
s:string;
implementation
{$R *.DFM}
procedure ShowSolve;
var
i,j:integer;
begin
for i:= 0 to m-1 do
for j:= 0 to n-1 do
fmTransTask.stgSolve.Cells[j+1,i+1]:=IntToStr(d[i,j]);
fmTransTask.lblZ.Caption:=IntToStr(z);
end;
procedure Minelem;
label
l1;
var
i,j,imin,jmin,cmin:integer;
set_i:set of 0..255;
set_j:set of 0..255;
begin
// создаем множество индексов
set_i:=[];
for i:=0 to m-1 do include(set_i,i);
set_j:=[];
for j:=0 to n-1 do include(set_j,j);
z:=0;
repeat
// поиск первоначального минимального ьэлемента в матрице тарифов
for i:= 0 to m-1 do
for j:= 0 to n-1 do
if (i in set_i) and (j in set_j) then
begin
cmin:=c[i,j];
goto l1
end;
l1:
// поиск минимального элемента в
// в матрице тарифов c
for i:= 0 to m-1 do
for j:= 0 to n-1 do
if (i in set_i) and (j in set_j) then
if c[i,j]<=cmin then
begin
cmin:=c[i,j];
imin:=i;
jmin:=j
end;
// определение величины поставки
d[imin,jmin]:=min(a[imin],b[jmin]);
// определяем исключаемую строку столбец
a[imin]:=a[imin]-d[imin,jmin];
if a[imin]=0 then
exclude(set_i,imin);
b[jmin]:=b[jmin]-d[imin,jmin];
if b[jmin]=0 then
exclude(set_j,jmin);
z:=z+d[imin,jmin]*cmin
until (set_i=[]) and (set_j=[]);
ShowSolve
end;
procedure Fogel;
var
i,j:integer;
cminprev,cmin:integer;
SubCol,SubRow:array of array of integer;
set_i,set_j:set of 0..255;
imin,jmin:integer;
imax,jmax:integer;
SubRowMax,SubColMax:integer;
begin
// размещаем массивы
SetLength(SubRow,m);
for i:= 0 to m-1 do SetLength(SubRow[i],2);
SetLength(SubCol,n);
for j:= 0 to n-1 do SetLength(SubCol[j],2);
set_i:=[];
for i:=0 to m-1 do include(set_i,i);
set_j:=[];
for j:=0 to n-1 do include(set_j,j);
repeat
// цикл по строкам
for i:= 0 to m-1 do
if i in set_i then
begin
// ищем первоначальный минимальный элемент в строке
for j:= 0 to n-1 do
if j in set_j then
begin
cmin:=c[i,j];
break
end;
// ищем 1-ое наименьшее значение в строке
for j:= 0 to n-1 do
if j in set_j then
if c[i,j]<=cmin then
begin
cmin:=c[i,j];
SubRow[i,1]:=j
end;
cminprev:=cmin;
// ищем первоначальный минимальный элемент в строке
for j:= 0 to n-1 do
if (j in set_j) and (j<>SubRow[i,1]) then
begin
cminprev:=c[i,j];
break
end;
// ищем 2-ое наименьшее значение в строке
for j:= 0 to n-1 do
if (j in set_j) and (j<>SubRow[i,1]) then
if c[i,j]<=cminprev then
cminprev:=c[i,j];
// Вычисляем разность между двумя наименьшими
SubRow[i,0]:=cminprev-cmin;
end;
// цикл по столбцам
for j:= 0 to n-1 do
if j in set_j then
begin
// ищем первоначальный минимальный элемент в столбце
for i:= 0 to m-1 do
if i in set_i then
begin
cmin:=c[i,j];
break
end;
// ищем 1-ое наименьшее значение в столбце
for i:= 0 to m-1 do
if i in set_i then
if c[i,j]<=cmin then
begin
cmin:=c[i,j];
SubCol[j,1]:=i
end;
cminprev:=cmin;
// ищем первоначальный минимальный элемент в столбце
for i:= 0 to m-1 do
if (i in set_i) and (i<>SubCol[j,1]) then
begin
cminprev:=c[i,j];
break
end;
// ищем 2-ое наименьшее значение в столбце
for i:= 0 to m-1 do
if (i in set_i) and (i<>SubCol[j,1]) then
if c[i,j]<=cminprev then
cminprev:=c[i,j];
// Вычисляем разность между двумя наименьшими
SubCol[j,0]:=cminprev-cmin;
end;
//отыскиваем максимальное значение в строке
// сперва находим начальный наибольший элемент
for i:= 0 to m-1 do
if i in set_i then
begin
SubRowMax:=Subrow[i,0];
break
end;
// Теперь просматриваем всю строку
for i:= 0 to m-1 do
if i in set_i then
if SubRow[i,0]>=SubRowMax then
begin
SubRowMax:=SubRow[i,0];
imax:=i
end;
//отыскиваем максимальное значение в строке
// сперва находим начальный наибольший элемент
for j:= 0 to n-1 do
if j in set_j then
begin
SubColMax:=SubCol[j,0];
break
end;
// Теперь просматриваем всю строку
for j:= 0 to n-1 do
if j in set_j then
if SubCol[j,0]>=SubColMax then
begin
SubColMax:=SubCol[j,0];
jmax:=j
end;
// сравниваем максимальное значение разности по строкам и столбцам
if SubRowMax>SubColMax then
begin
d[imax,SubRow[imax,1]]:=min(a[imax],b[SubRow[imax,1]]);
a[imax]:=a[imax]-d[imax,SubRow[imax,1]];
b[SubRow[imax,1]]:=b[SubRow[imax,1]]-d[imax,SubRow[imax,1]];
if a[imax]=0 then Exclude(set_i,imax);
if b[SubRow[imax,1]]=0 then
Exclude(set_j,SubRow[imax,1]);
z:=z+d[imax,SubRow[imax,1]]*c[imax,SubRow[imax,1]];
if set_i=[] then set_j:=[];
if set_j=[] then set_i:=[]
end
else
begin
d[SubCol[jmax,1],jmax]:=min(a[SubCol[jmax,1]],b[jmax]);
a[SubCol[jmax,1]]:=a[SubCol[jmax,1]]-d[SubCol[jmax,1],jmax];
b[jmax]:=b[jmax]-d[SubCol[jmax,1],jmax];
if a[SubCol[jmax,1]]=0 then Exclude(set_i,SubCol[jmax,1]);
if b[jmax]=0 then
Exclude(set_j,SubCol[jmax,1]);
z:=z+d[SubCol[jmax,1],jmax]*c[SubCol[jmax,1],jmax];
if set_i=[] then set_j:=[];
if set_j=[] then set_i:=[]
end
until (set_i=[]) and (set_j = []);
ShowSolve
end;
procedure TwoWall;
var
RowMin,ColMin:integer;
i,j,jj,j0:integer;
imin,jmin:integer;
set_i,set_j:set of 0..255;
begin
set_i:=[];
for i:=0 to m-1 do include(set_i,i);
set_j:=[];
for j:=0 to n-1 do include(set_j,j);
repeat
// начинаем цикл по столбцам
for j:= 0 to n-1 do
if j in set_j then
begin
// находим начальный минимальный элемент строки
for i:= 0 to m-1 do
if i in set_i then
begin
RowMin:=c[i,j];
break
end;
// теперь просматриваем весь столбец
for i:=0 to m-1 do
if i in set_i then
if c[i,j]<=RowMin then
begin
RowMin:=c[i,j];
imin:=i
end;
// минимальный элемент в j-ом столбце найден
// проверяем , минимальный ли он в своей строке
j0:=j;
for jj:= 0 to n-1 do
if jj in set_j then
if c[imin,jj]< RowMin then
j0:=jj;
// проверяем по индексу не тот ли это элемент
if j=j0 then
begin
d[imin,j]:=min(a[imin],b[j]);
a[imin]:=a[imin]-d[imin,j];
b[j]:=b[j]-d[imin,j];
if a[imin]=0 then exclude(set_i,imin);
if b[j]=0 then exclude(set_j,j);
z:=z+d[imin,j]*c[imin,j];
end
end
until (set_i=[]) and (set_j=[]);
ShowSolve
end;
procedure TfmTransTask.FormCreate(Sender: TObject);
var
i,j:integer;
begin
m:=3;
n:=3;
SetLength(a,m);
for i:= 0 to m-1 do a[i]:=0;
SetLength(b,n);
for j:= 0 to n-1 do b[j]:=0;
SetLength(c,m);
for i:= 0 to m-1 do SetLength(c[i],n);
for i:= 0 to m-1 do
for j:= 0 to n-1 do
c[i,j]:=0;
SetLength(d,m);
for i:= 0 to m-1 do SetLength(d[i],n);
for i:= 0 to m-1 do
for j:= 0 to n-1 do
d[i,j]:=0;
for i:= 1 to m do
begin
stgProvider.Cells[i-1,0]:=IntToStr(i);
str(a[i-1],s);
stgProvider.Cells[i-1,1]:=s;
end;
for j:= 1 to n do
begin
stgCustomer.Cells[j-1,0]:=IntToStr(j);
str(b[j-1],s);
stgCustomer.Cells[j-1,1]:=s;
end;
for i:= 1 to m do
stgTarif.Cells[0,i]:=IntToStr(i);
for j:= 1 to n do
stgTarif.Cells[j,0]:=IntToStr(j);
for i:= 1 to m do
stgSolve.Cells[0,i]:=IntToStr(i);
for j:= 1 to n do
stgSolve.Cells[j,0]:=IntToStr(j);
end;
procedure TfmTransTask.edProviderCountChange(Sender: TObject);
var
i:integer;
begin
stgProvider.ColCount:=StrToInt(edProviderCount.Text);
stgTarif.RowCount:=stgProvider.ColCount+1;
stgSolve.RowCount:=stgTarif.RowCount;
m:=StrToInt(edProviderCount.Text);
SetLength(a,m);
SetLength(c,m);
for i:= 0 to m-1 do SetLength(c[i],n);
SetLength(d,m);
for i:= 0 to m-1 do SetLength(d[i],n);
stgProvider.Cells[stgProvider.ColCount-1,0]:=edProviderCount.Text;
stgTarif.Cells[0,stgProvider.ColCount]:=edProviderCount.Text;
stgSolve.Cells[0,stgProvider.Colcount]:=edProviderCount.Text;
end;
procedure TfmTransTask.edCustomerCountChange(Sender: TObject);
var
i:integer;
begin
stgCustomer.ColCount:=StrToInt(edCustomerCount.Text);
stgTarif.ColCount:=stgCustomer.ColCount+1;
stgSolve.ColCount:=stgTarif.ColCount;
n:=StrToInt(edCustomerCount.Text);
SetLength(b,n);
SetLength(c,m);
for i:= 0 to m-1 do SetLength(c[i],n);
SetLength(d,m);
for i:= 0 to m-1 do SetLength(d[i],n);
stgCustomer.Cells[stgCustomer.ColCount-1,0]:=edCustomerCount.Text;
stgTarif.Cells[stgCustomer.ColCount,0]:=edCustomerCount.Text;
stgSolve.Cells[stgCustomer.Colcount,0]:=edCustomerCount.Text;
end;
procedure TfmTransTask.btnLoadDataClick(Sender: TObject);
var
i,j:integer;
suma,sumb:integer;
begin
for i:= 0 to m-1 do
if stgProvider.Cells[i,1]<>'' then
a[i]:=StrToInt(stgProvider.Cells[i,1])
else
a[i]:=0;
suma:=0;
for i:= 0 to m-1 do suma:=suma+a[i];
lblProvider.Caption:=IntToStr(suma);
for j:= 0 to n-1 do
if stgCustomer.Cells[j,1]<>'' then
b[j]:=StrToInt(stgCustomer.Cells[j,1])
else
b[j]:=0;
sumb:=0;
for j:= 0 to n-1 do sumb:=sumb+b[j];
lblCustomer.Caption:=IntToStr(sumb);
if sumb suma then
lblMsg.Caption:='Создать фиктивного поставщика с грузом '+IntToStr(sumb
-suma);
if sumb lblMsg.Caption:='Создать фиктивного потребителя со спросом '+
IntToStr(suma-sumb)
end
else
begin
lblTypeTask.Caption:='Закрытая';
lblMsg.Caption:=''
end;
btnSolve.Enabled:=True
end;
procedure TfmTransTask.btnLoadDataCClick(Sender: TObject);
var
i,j:integer;
begin
for i:= 0 to m-1 do
for j:= 0 to n-1 do
if stgTarif.Cells[j+1,i+1]<>'' then
c[i,j]:=StrToInt(stgTarif.Cells[j+1,i+1]);
end;
procedure TfmTransTask.btnSolveClick(Sender: TObject);
begin
if rbMinelem.Checked then Minelem;
if rbFogel.Checked then Fogel;
if rbTwoWall.Checked then TwoWall
end;
procedure TfmTransTask.btnPrintClick(Sender: TObject);
var
i,j:integer;
out:TextFile;
begin
AssignFile(out,'rezult.txt');
Rewrite(out);
writeln(out,'Исходные данные транспортной задачи');
writeln(out,'потребность потребителей');
for j:= 0 to n-1 do write(out,b[j]:8);
writeln(out);
writeln(out,'Матрица тарифов перевозок');
for i:= 0 to m-1 do
begin
write(out,a[i]:8);
for j:= 0 to n-1 do write(out,c[i,j]:8);
writeln(out)
end;
writeln(out,'Матрица перевозок (решение)');
for i:= 0 to m-1 do
begin
for j:= 0 to n-1 do write(out,d[i,j]:8);
writeln(out)
end;
CloseFile(out);
end;
End.