Баклавру - Курсовые и рефераты
Home Курсовые Программирование и компьютеры Нахождение опорного плана транспортной задачи
 
 

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

Файл: kurs-553.doc ( 270336 байт )
Размер файла:270336 байт
Дата файла:28.12.1999 12:02:54
Длина текста:27219 байт
Другие части работы:  [TLISOVA.doc ( 208384 байт )]   [kurs-557.doc ( 50688 байт )]   [kurs-0104.doc ( 32256 байт )]   [kurs-555.doc ( 26624 байт )]   [kurs-554.doc ( 25088 байт )]   [kurs-558.doc ( 23040 байт )]   [TLTLT-~2.doc ( 20992 байт )]   [kurs-556.doc ( 19456 байт )]   [TRANST~1.PAS ( 14750 байт )]   [UNIT1.PAS ( 521 байт )] 
Блок-схема меню определение опорного плана (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
begin
lblTypeTask.Caption:='Открытая';
If sumb>suma then
lblMsg.Caption:='Создать фиктивного поставщика с грузом '+IntToStr(sumb
-suma);
if sumb<suma then
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.

Начало

FmMain
Главная форма

Выбор метода решения

Метод минимально-го элемента

Метод Фогеля

Metod=1

Metod = 2

Метод двойного предпочтения

Metod = 3

2

2

Ввод размерности таблицы перевозок m,n

Отображение пустой таблицы размерностей m*n

Ввод таблицы данных:
Вектора А
Вектора В
Матрица С

Открытая задача Eai< >Ebj

Введение фиктивного поставщика (А) или потребителя (В) с нулевыт тарифом Cij=0

Решение транспортной задачи Transsolver

Отображение результатов решения D – матрицы перевозок и Z – значения целевой функции – затрат на перевозки.

Конец

Начало

Выбор минимального тарифа из матрицы С MIN

Определяем i min, j min

Amin = MIN(a i min, b j min)

Корректируем элементы исходного массива
aij = a i min – A min
b j min = b j min – A min

A i min

Исключаем строку i min

B j min=0

Исключаем строку j min

4

4

Заносим в матрицу перевозок значение A min
D i min j min

(aij and bij)=0

Вычисление целевой функции Z по матрице D и C

Конец

Начало

Metod = 1

Minielem

Metod = 2

FOGEL

Metod = 3

DoublePref

Конец

Лист
Кп-км-п-44-2203-99

Лист
Кп-км-п-44-2203-99

Лист
Кп-км-п-44-2203-99

Лист
Кп-км-п-44-2203-99

Лист
Кп-км-п-44-2203-99

Лист
Кп-км-п-44-2203-99

Лист
Кп-км-п-44-2203-99

Лист
Кп-км-п-44-2203-99

Лист
Кп-км-п-44-2203-99

Лист
Кп-км-п-44-2203-99

Лист
Кп-км-п-44-2203-99

Лист
Кп-км-п-44-2203-99

Лист
Кп-км-п-44-2203-99

Лист
Кп-км-п-44-2203-99

Лист
Кп-км-п-44-2203-99

Лист
Кп-км-п-44-2203-99

Другие части работы:  [TLISOVA.doc ( 208384 байт )]   [kurs-557.doc ( 50688 байт )]   [kurs-0104.doc ( 32256 байт )]   [kurs-555.doc ( 26624 байт )]   [kurs-554.doc ( 25088 байт )]   [kurs-558.doc ( 23040 байт )]   [TLTLT-~2.doc ( 20992 байт )]   [kurs-556.doc ( 19456 байт )]   [TRANST~1.PAS ( 14750 байт )]   [UNIT1.PAS ( 521 байт )] 

 
Top! Top!