Материалы сайта
Это интересно
Нахождение опорного плана транспортной задачи
Блок-схема меню определение опорного плана (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'' 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