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

Работа добавлена на сайт bukvasha.net: 2015-10-28

Поможем написать учебную работу

Если у вас возникли сложности с курсовой, контрольной, дипломной, рефератом, отчетом по практике, научно-исследовательской и любой другой работой - мы готовы помочь.

Предоплата всего

от 25%

Подписываем

договор

Имя

Выберите тип работы:

Принимаю Политику конфиденциальности

Скидка 25% при заказе до 9.11.2024

Блок-схема меню определение опорного плана (
Transtask.pas)

Да

нет

4 Да

нет

6 Да

нет

8 Да

нет

Да
14

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

нет

Блок-схема подпрограммы решения методом минимального элемента MINIELEM
1

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

Корректируем элементы исходного массива

aij = a i min – A min

b j min = b j min – A min

6 Да

нет

8

Да

9
нет

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

D i min j min

Да

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

Блок-схема подпрограммы решения транспортной задачи
Transsolver

2

Да

нет

4 Да

нет

7

нет

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);

Лист

Кп-км-п-44-2203-99

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

Лист

Кп-км-п-44-2203-99

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

Лист

Кп-км-п-44-2203-99

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;

Лист

Кп-км-п-44-2203-99

//отыскиваем максимальное значение в строке

   // сперва находим начальный наибольший элемент
   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

Лист

Кп-км-п-44-2203-99

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

Лист

Кп-км-п-44-2203-99

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;

Лист

Кп-км-п-44-2203-99

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

Лист

Кп-км-п-44-2203-99

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

Лист

Кп-км-п-44-2203-99

for j:= 0 to n-1 do write(out,d[i,j]:8);

Лист

Кп-км-п-44-2203-99

writeln(out)

end;

CloseFile(out);

end;
End.

Bukvasha